haskell/yesod
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Imported existing code, documentation incomplete

Browse Source
This commit is contained in:
Michael Snoyman 2009-06-28 01:55:14 +03:00
parent a02230ab74
commit 4ad1b2956e
6 changed files with 940 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.gitignore vendored Normal file
View File

@ -0,0 +1,2 @@
dist
*.swp

25
LICENSE Normal file
View File

@ -0,0 +1,25 @@
The following license covers this documentation, and the source code, except
where otherwise indicated.
Copyright 2008, Michael Snoyman. All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
* Redistributions of source code must retain the above copyright notice, this
list of conditions and the following disclaimer.
* Redistributions in binary form must reproduce the above copyright notice,
this list of conditions and the following disclaimer in the documentation
and/or other materials provided with the distribution.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR
IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO
EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT,
INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,
OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

1
README
View File

@ -0,0 +1 @@
A Restful front controller built on Hack.

7
Setup.lhs Executable file
View File

@ -0,0 +1,7 @@
#!/usr/bin/env runhaskell
> module Main where
> import Distribution.Simple
> main :: IO ()
> main = defaultMain

888
Web/Restful.hs Normal file
View File

@ -0,0 +1,888 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE OverlappingInstances #-}
---------------------------------------------------------
--
-- Module : Web.Restful
-- Copyright : Michael Snoyman
-- License : BSD3
--
-- Maintainer : Michael Snoyman <michael@snoyman.com>
-- Stability : Stable
-- Portability : portable
--
-- Lightweight framework for designing RESTful APIs.
--
---------------------------------------------------------
module Web.Restful
(
-- * Request parsing
-- $param_overview
-- ** Types
ParamError
, ParamName
, ParamValue
-- ** Parameter type class
, Parameter (..)
-- ** RequestParser helpers
, getParam
, postParam
, urlParam
, anyParam
, cookieParam
, identifier
, acceptedLanguages
, requestPath
-- ** Building actual request
, Request (..)
, Hack.RequestMethod (..)
, rawFiles
-- * Response construction
, Response (..)
, response
-- ** Helper 'Response' instances
-- *** Generic hierarchichal text
, Tree (..)
, IsTree (..)
-- *** Atom news feed
, AtomFeed (..)
, AtomFeedEntry (..)
-- *** Sitemap
, sitemap
, SitemapUrl (..)
, SitemapLoc (..)
, SitemapChangeFreq (..)
-- *** Generics
-- **** List/detail
, ListDetail (..)
, ItemList (..)
, ItemDetail (..)
, -- **** Multiple response types.
GenResponse (..)
-- * Defining an application
, ApplicationMonad
-- ** Routing
, addResource
-- ** Settings
, setHandler
, setRpxnowApiKey
, setUrlRewriter
, setHtmlWrapper
-- ** Engage
, run
) where
-- hideously long import list
import qualified Hack
import qualified Hack.Handler.CGI
import Control.Monad.Reader
import Control.Monad.Writer
import Control.Monad.State hiding (gets)
import Data.List (intercalate)
import Web.Encodings
import Data.Maybe (isJust)
import Data.ByteString.Class
import qualified Data.ByteString.Lazy as BS
import Data.Function.Predicate (equals)
import Data.Default
import qualified Web.Authenticate.Rpxnow as Rpxnow
import qualified Web.Authenticate.OpenId as OpenId
import Data.List.Split (splitOneOf)
import Hack.Middleware.Gzip
import Hack.Middleware.CleanPath
import Hack.Middleware.Jsonp
import Hack.Middleware.ClientSession
import Data.Time.Format
import Data.Time.Clock
import System.Locale
import Control.Applicative ((<$>), Applicative (..))
import Control.Arrow (second)
-- $param_overview
-- In Restful, all of the underlying parameter values are strings. They can
-- come from multiple sources: GET parameters, URL rewriting (FIXME: link),
-- cookies, etc. However, most applications eventually want to convert
-- those strings into something else, like 'Int's. Additionally, it is
-- often desirable to allow multiple values, or no value at all.
--
-- That is what the parameter concept is for. A 'Parameter' is any value
-- which can be converted from a 'String', or list of 'String's.
-- | Any kind of error message generated in the parsing stage.
type ParamError = String
-- | In GET parameters, the key. In cookies, the cookie name. So on and so
-- forth.
type ParamName = String
-- | The 'String' value of a parameter, such as cookie content.
type ParamValue = String
-- | Anything which can be converted from a 'String' or list of 'String's.
--
-- The default implementation of 'readParams' will error out if given
-- anything but 1 'ParamValue'. This is usually what you want.
--
-- Minimal complete definition: either 'readParam' or 'readParams'.
class Parameter a where
-- | Convert a string into the desired value, or explain why that can't
-- happen.
readParam :: ParamValue -> Either ParamError a
readParam = readParams . return
-- | Convert a list of strings into the desired value, or explain why
-- that can't happen.
readParams :: [ParamValue] -> Either ParamError a
readParams [x] = readParam x
readParams [] = Left "Missing parameter"
readParams xs = Left $ "Given " ++ show (length xs) ++
" values, expecting 1"
-- | Attempt to parse a list of param values using 'readParams'.
-- If that fails, return an error message and an undefined value. This way,
-- we can process all of the parameters and get all of the error messages.
-- Be careful not to use the value inside until you can be certain the
-- reading succeeded.
tryReadParams:: Parameter a
=> ParamName
-> [ParamValue]
-> RequestParser a
tryReadParams name params =
case readParams params of
Left s -> do
tell [name ++ ": " ++ s]
return $
error $
"Trying to evaluate nonpresent parameter " ++
name
Right x -> return x
-- | Helper function for generating 'RequestParser's from various
-- 'ParamValue' lists.
genParam :: Parameter a
=> (RawRequest -> ParamName -> [ParamValue])
-> ParamName
-> RequestParser a
genParam f name = do
req <- ask
tryReadParams name $ f req name
-- | Parse a value passed as a GET parameter.
getParam :: Parameter a => ParamName -> RequestParser a
getParam = genParam getParams
-- | Parse a value passed as a POST parameter.
postParam :: Parameter a => ParamName -> RequestParser a
postParam = genParam postParams
-- | Parse a value passed in the URL and extracted using rewrite.
-- (FIXME: link to rewrite section.)
urlParam :: Parameter a => ParamName -> RequestParser a
urlParam = genParam urlParams
-- | Parse a value passed as a GET, POST or URL parameter.
anyParam :: Parameter a => ParamName -> RequestParser a
anyParam = genParam anyParams
-- | Parse a value passed as a raw cookie.
cookieParam :: Parameter a => ParamName -> RequestParser a
cookieParam = genParam cookies
-- | Parse a value in the hackHeader field.
hackHeaderParam :: Parameter a => ParamName -> RequestParser a
hackHeaderParam name = do
env <- parseEnv
let vals' = lookup name $ Hack.hackHeaders env
vals = case vals' of
Nothing -> []
Just x -> [x]
tryReadParams name vals
-- | Extract the cookie which specifies the identifier for a logged in
-- user.
identifier :: Parameter a => RequestParser a
identifier = hackHeaderParam authCookieName
-- | Get the raw 'Hack.Env' value.
parseEnv :: RequestParser Hack.Env
parseEnv = rawEnv `fmap` ask
-- | Determine the ordered list of language preferences.
--
-- FIXME: Future versions should account for some cookie.
acceptedLanguages :: RequestParser [String]
acceptedLanguages = do
env <- parseEnv
let rawLang = tryLookup "" "Accept-Language" $ Hack.http env
return $! parseHttpAccept rawLang
-- | Determinge the path requested by the user (ie, the path info).
requestPath :: RequestParser String
requestPath = do
env <- parseEnv
let q = case Hack.queryString env of
"" -> ""
q'@('?':_) -> q'
q' -> q'
return $! Hack.pathInfo env ++ q
type RequestParser a = WriterT [ParamError] (Reader RawRequest) a
instance Applicative (WriterT [ParamError] (Reader RawRequest)) where
pure = return
f <*> a = do
f' <- f
a' <- a
return $! f' a'
-- | Parse a request into either the desired 'Request' or a list of errors.
runRequestParser :: RequestParser a -> RawRequest -> Either [ParamError] a
runRequestParser p req =
let (val, errors) = (runReader (runWriterT p)) req
in case errors of
[] -> Right val
x -> Left x
-- | The raw information passed through Hack, cleaned up a bit.
data RawRequest = RawRequest
{ rawPathInfo :: PathInfo
, rawUrlParams :: [(ParamName, ParamValue)]
, rawGetParams :: [(ParamName, ParamValue)]
, rawPostParams :: [(ParamName, ParamValue)]
, rawCookies :: [(ParamName, ParamValue)]
, rawFiles :: [(ParamName, FileInfo)]
, rawEnv :: Hack.Env
}
-- | All GET paramater values with the given name.
getParams :: RawRequest -> ParamName -> [ParamValue]
getParams rr name = map snd
. filter (\x -> name == fst x)
. rawGetParams
$ rr
-- | All POST paramater values with the given name.
postParams :: RawRequest -> ParamName -> [ParamValue]
postParams rr name = map snd
. filter (\x -> name == fst x)
. rawPostParams
$ rr
-- | All URL paramater values (see rewriting) with the given name.
urlParams :: RawRequest -> ParamName -> [ParamValue]
urlParams rr name = map snd
. filter (\x -> name == fst x)
. rawUrlParams
$ rr
-- | All GET, POST and URL paramater values (see rewriting) with the given name.
anyParams :: RawRequest -> ParamName -> [ParamValue]
anyParams req name = urlParams req name ++
getParams req name ++
postParams req name
-- | All cookies with the given name.
cookies :: RawRequest -> ParamName -> [ParamValue]
cookies rr name = map snd . filter (fst `equals` name) . rawCookies $ rr
instance Parameter a => Parameter (Maybe a) where
readParams [] = Right Nothing
readParams [x] = readParam x >>= return . Just
readParams xs = Left $ "Given " ++ show (length xs) ++
" values, expecting 0 or 1"
instance Parameter a => Parameter [a] where
readParams = mapM readParam
instance Parameter String where
readParam = Right
instance Parameter Int where
readParam s = case reads s of
((x, _):_) -> Right x
_ -> Left $ "Invalid integer: " ++ s
-- | The input for a resource.
--
-- Each resource can define its own instance of 'Request' and then more
-- easily ensure that it received the correct input (ie, correct variables,
-- properly typed).
class Request a where
parseRequest :: RequestParser a
instance Request () where
parseRequest = return ()
type ContentType = String
-- | The output for a resource.
class Response a where
-- | Provide an ordered list of possible responses, depending on content
-- type. If the user asked for a specific response type (like
-- text/html), then that will get priority. If not, then the first
-- element in this list will be used.
reps :: a -> [(ContentType, Hack.Response)]
-- | Wrapper around 'Hack.Response' to allow arbitrary pieces of data to be
-- used for the body.
response :: LazyByteString lbs
=> Int
-> [(String, String)]
-> lbs
-> Hack.Response
response a b c = Hack.Response a b $ toLazyByteString c
instance Response () where
reps _ = [("text/plain", response 200 [] "")]
newtype ErrorResponse = ErrorResponse String
instance Response ErrorResponse where
reps (ErrorResponse s) = [("text/plain", response 500 [] s)]
data ResponseWrapper = forall res. Response res => ResponseWrapper res
instance Response ResponseWrapper where
reps (ResponseWrapper res) = reps res
-- | Contains settings and a list of resources.
type ApplicationMonad = StateT ApplicationSettings (Writer [Resource])
instance Applicative ApplicationMonad where
pure = return
f <*> a = do
f' <- f
a' <- a
return $! f' a'
data ApplicationSettings = ApplicationSettings
{ hackHandler :: Hack.Application -> IO ()
, rpxnowApiKey :: Maybe String
, encryptKey :: Either FilePath Word256
, urlRewriter :: UrlRewriter
, hackMiddleware :: [Hack.Middleware]
, response404 :: Hack.Env -> IO Hack.Response
, htmlWrapper :: BS.ByteString -> BS.ByteString
}
instance Default ApplicationSettings where
def = ApplicationSettings
{ hackHandler = Hack.Handler.CGI.run
, rpxnowApiKey = Nothing
, encryptKey = Left defaultKeyFile
, urlRewriter = \s -> (s, [])
, hackMiddleware = [gzip, cleanPath, jsonp]
, response404 = default404
, htmlWrapper = id
}
default404 :: Hack.Env -> IO Hack.Response
default404 env = return $
Hack.Response
404
[("Content-Type", "text/plain")]
$ toLazyByteString $ "Not found: " ++ Hack.pathInfo env
data Handler = forall req res. (Request req, Response res)
=> Handler (req -> IO res)
type LiftedHandler = RawRequest -> IO ResponseWrapper
liftHandler ::
Handler
-> RawRequest
-> IO ResponseWrapper
liftHandler (Handler h) rr = do
case runRequestParser parseRequest rr of
Left errors -> return $ ResponseWrapper
$ ErrorResponse
$ unlines errors
Right req -> ResponseWrapper `fmap` h req
type PathInfo = [String]
data Resource = Resource [Hack.RequestMethod] PathInfo LiftedHandler
-- FIXME document below here
addResource :: (Request req, Response res)
=> [Hack.RequestMethod]
-> PathInfo
-> (req -> IO res)
-> ApplicationMonad ()
addResource methods path f =
tell [Resource methods path $ liftHandler $ Handler f]
setUrlRewriter :: UrlRewriter -> ApplicationMonad ()
setUrlRewriter newUrlRewriter = do
s <- get
put $ s { urlRewriter = newUrlRewriter }
setHtmlWrapper :: (BS.ByteString -> BS.ByteString) -> ApplicationMonad ()
setHtmlWrapper f = do
s <- get
put $ s { htmlWrapper = f }
run :: ApplicationMonad () -> IO ()
run m = do
let (settings, resources') = runWriter $ execStateT m def
key <- case encryptKey settings of
Left f -> getKey f
Right k -> return k
let defApp = defaultResources settings
defResources = execWriter $ execStateT defApp def
resources = resources' ++ defResources
app' :: Hack.Application
app' = makeApplication' resources settings
clientsession' :: Hack.Middleware
clientsession' = clientsession [authCookieName] key
app :: Hack.Application
app = foldr ($) app' $ hackMiddleware settings ++ [clientsession']
hackHandler settings app
setHandler :: (Hack.Application -> IO ()) -> ApplicationMonad ()
setHandler h = do
settings <- get
put $ settings { hackHandler = h }
setRpxnowApiKey :: String -> ApplicationMonad ()
setRpxnowApiKey k = do
settings <- get
put $ settings { rpxnowApiKey = Just k }
defaultResources :: ApplicationSettings -> ApplicationMonad ()
defaultResources settings = do
addResource [Hack.GET] ["auth", "check"] authCheck
addResource [Hack.GET] ["auth", "logout"] authLogout
addResource [Hack.GET] ["auth", "openid"] authOpenidForm
addResource [Hack.GET] ["auth", "openid", "forward"] authOpenidForward
addResource [Hack.GET] ["auth", "openid", "complete"] authOpenidComplete
case rpxnowApiKey settings of
Nothing -> return ()
Just key -> do
addResource [Hack.GET] ["auth", "login", "rpxnow"] $
rpxnowLogin key
data OIDFormReq = OIDFormReq (Maybe String) (Maybe String)
instance Request OIDFormReq where
parseRequest = OIDFormReq <$> getParam "message" <*> getParam "dest"
instance Show OIDFormReq where
show (OIDFormReq Nothing _) = ""
show (OIDFormReq (Just s) _) = "<p class='message'>" ++ encodeHtml s ++
"</p>"
data OIDFormRes = OIDFormRes String (Maybe String)
instance Response OIDFormRes where
reps (OIDFormRes s dest) = [("text/html", response 200 heads s)]
where
heads =
case dest of
Nothing -> []
Just dest' ->
[("Set-Cookie", "DEST=" ++ dest' ++ "; path=/")]
authOpenidForm :: OIDFormReq -> IO OIDFormRes
authOpenidForm m@(OIDFormReq _ dest) =
let html =
show m ++
"<form method='get' action='forward/'>" ++
"OpenID: <input type='text' name='openid'>" ++
"<input type='submit' value='Login'>" ++
"</form>"
in return $! OIDFormRes html dest
data OIDFReq = OIDFReq String String
instance Request OIDFReq where
parseRequest = do
oid <- getParam "openid"
env <- parseEnv
let complete = "http://" ++ Hack.serverName env ++ ":" ++
show (Hack.serverPort env) ++
"/auth/openid/complete/"
return $! OIDFReq oid complete
authOpenidForward :: OIDFReq -> IO GenResponse
authOpenidForward (OIDFReq oid complete) = do
res <- OpenId.getForwardUrl oid complete :: IO (Either String String)
return $
case res of
Left err -> RedirectResponse $ "/auth/openid/?message=" ++
encodeUrl err
Right url -> RedirectResponse url
data OIDComp = OIDComp [(String, String)] (Maybe String)
instance Request OIDComp where
parseRequest = do
rr <- ask
let gets = rawGetParams rr
dest <- cookieParam "DEST"
return $! OIDComp gets dest
data OIDCompRes = OIDCompResErr String
| OIDCompResGood String (Maybe String)
instance Response OIDCompRes where
reps (OIDCompResErr err) =
reps $ RedirectResponse
$ "/auth/openid/?message=" ++
encodeUrl err
reps (OIDCompResGood ident Nothing) =
reps $ OIDCompResGood ident (Just "/")
reps (OIDCompResGood ident (Just dest)) =
[("text/plain", response 303 heads "")] where
heads =
[ (authCookieName, ident)
, resetCookie "DEST"
, ("Location", dest)
]
resetCookie :: String -> (String, String)
resetCookie name =
("Set-Cookie",
name ++ "=; path=/; expires=Thu, 01-Jan-1970 00:00:00 GMT")
authOpenidComplete :: OIDComp -> IO OIDCompRes
authOpenidComplete (OIDComp gets' dest) = do
res <- OpenId.authenticate gets' :: IO (Either String OpenId.Identifier)
return $
case res of
Left err -> OIDCompResErr err
Right (OpenId.Identifier ident) -> OIDCompResGood ident dest
-- | token dest
data RpxnowRequest = RpxnowRequest String (Maybe String)
instance Request RpxnowRequest where
parseRequest = do
token <- getParam "token"
dest <- getParam "dest"
return $! RpxnowRequest token $ chopHash `fmap` dest
chopHash :: String -> String
chopHash ('#':rest) = rest
chopHash x = x
-- | dest identifier
data RpxnowResponse = RpxnowResponse String (Maybe String)
instance Response RpxnowResponse where
reps (RpxnowResponse dest Nothing) =
[("text/html", response 303 [("Location", dest)] "")]
reps (RpxnowResponse dest (Just ident)) =
[("text/html", response 303
[ ("Location", dest)
, (authCookieName, ident)
]
"")]
rpxnowLogin :: String -- ^ api key
-> RpxnowRequest
-> IO RpxnowResponse
rpxnowLogin apiKey (RpxnowRequest token dest') = do
let dest = case dest' of
Nothing -> "/"
Just "" -> "/"
Just s -> s
ident' <- Rpxnow.authenticate apiKey token
return $ RpxnowResponse dest (Rpxnow.identifier `fmap` ident')
authCookieName :: String
authCookieName = "IDENTIFIER"
data AuthRequest = AuthRequest (Maybe String)
instance Request AuthRequest where
parseRequest = AuthRequest `fmap` identifier
authCheck :: AuthRequest -> IO Tree
authCheck (AuthRequest Nothing) =
return $ TreeMap [("status", TreeScalar "notloggedin")]
authCheck (AuthRequest (Just i)) =
return $ TreeMap $
[ ("status", TreeScalar "loggedin")
, ("ident", TreeScalar i)
]
authLogout :: () -> IO LogoutResponse
authLogout _ = return LogoutResponse
data LogoutResponse = LogoutResponse
instance Response LogoutResponse where
reps _ = map (second addCookie) $ reps tree where
tree = TreeMap [("status", TreeScalar "loggedout")]
addCookie (Hack.Response s h c) =
Hack.Response s (h':h) c
h' = resetCookie authCookieName
makeApplication' :: [Resource]
-> ApplicationSettings
-> Hack.Env
-> IO Hack.Response
makeApplication' resources settings env = do
let method = Hack.requestMethod env
rr = envToRawRequest (urlRewriter settings) env
path' = rawPathInfo rr
isValid :: Resource -> Bool
isValid (Resource methods path _) = method `elem` methods
&& path == path'
case filter isValid resources of
[Resource _ _ handler] -> do
let rawHttpAccept = tryLookup "" "Accept" $ Hack.http env
ctypes' = parseHttpAccept rawHttpAccept
body <- handler rr
let reps' = reps body
ctypes = filter (\c -> isJust $ lookup c reps') ctypes'
let handlerPair =
case ctypes of
[] -> Just $ head reps'
(c:_) ->
case filter (fst `equals` c) reps' of
[pair] -> Just pair
[] -> Nothing
_ -> error "Overlapping reps"
case handlerPair of
Nothing -> response404 settings $ env
Just (ctype, Hack.Response status headers content) -> do
let wrapper =
case ctype of
"text/html" -> htmlWrapper settings
_ -> id
return $ Hack.Response status
(("Content-Type", ctype) : headers)
$ toLazyByteString $ wrapper content
[] -> response404 settings $ env
_ -> fail "Overlapping handlers"
type UrlRewriter = PathInfo -> (PathInfo, [(String, String)])
envToRawRequest :: UrlRewriter -> Hack.Env -> RawRequest
envToRawRequest rewriter env =
let (Right rawPieces) = splitPath $ Hack.pathInfo env
(pi', urls) = rewriter rawPieces
gets' = decodeUrlPairs $ Hack.queryString env :: [(String, String)]
clength = tryLookup "0" "Content-Length" $ Hack.http env
ctype = tryLookup "" "Content-Type" $ Hack.http env
(posts, files) = parsePost ctype clength
$ Hack.hackInput env
rawCookie = tryLookup "" "Cookie" $ Hack.http env
cookies' = decodeCookies rawCookie :: [(String, String)]
in RawRequest pi' urls gets' posts cookies' files env
data Tree = TreeScalar String
| TreeList [Tree]
| TreeMap [(String, Tree)]
class IsTree a where
toTree :: a -> Tree
treeToJson :: Tree -> String
treeToJson (TreeScalar s) = '"' : encodeJson s ++ "\""
treeToJson (TreeList l) =
"[" ++ intercalate "," (map treeToJson l) ++ "]"
treeToJson (TreeMap m) =
"{" ++ intercalate "," (map helper m) ++ "}" where
helper (k, v) =
treeToJson (TreeScalar k) ++
":" ++
treeToJson v
treeToHtml :: Tree -> String
treeToHtml (TreeScalar s) = encodeHtml s
treeToHtml (TreeList l) =
"<ul>" ++ concatMap (\e -> "<li>" ++ treeToHtml e ++ "</li>") l ++
"</ul>"
treeToHtml (TreeMap m) =
"<dl>" ++
concatMap (\(k, v) -> "<dt>" ++ encodeHtml k ++ "</dt>" ++
"<dd>" ++ treeToHtml v ++ "</dd>") m ++
"</dl>"
instance Response Tree where
reps tree =
[ ("text/html", response 200 [] $ treeToHtml tree)
, ("application/json", response 200 [] $ treeToJson tree)
]
parseHttpAccept :: String -> [String]
parseHttpAccept = filter (not . specialHttpAccept) . splitOneOf ";,"
specialHttpAccept :: String -> Bool
specialHttpAccept ('q':'=':_) = True
specialHttpAccept ('*':_) = True
specialHttpAccept _ = False
data AtomFeed = AtomFeed
{ atomTitle :: String
, atomLinkSelf :: String
, atomLinkHome :: String
, atomUpdated :: UTCTime
, atomEntries :: [AtomFeedEntry]
}
instance Response AtomFeed where
reps e =
[ ("application/atom+xml", response 200 [] $ show e)
]
data AtomFeedEntry = AtomFeedEntry
{ atomEntryLink :: String
, atomEntryUpdated :: UTCTime
, atomEntryTitle :: String
, atomEntryContent :: String
}
instance Show AtomFeed where
show f = concat
[ "<?xml version='1.0' encoding='utf-8' ?>\n"
, "<feed xmlns='http://www.w3.org/2005/Atom'>"
, "<title>"
, encodeHtml $ atomTitle f
, "</title>"
, "<link rel='self' href='"
, encodeHtml $ atomLinkSelf f
, "'/>"
, "<link href='"
, encodeHtml $ atomLinkHome f
, "'/>"
, "<updated>"
, formatW3 $ atomUpdated f
, "</updated>"
, "<id>"
, encodeHtml $ atomLinkHome f
, "</id>"
, concatMap show $ atomEntries f
, "</feed>"
]
instance Show AtomFeedEntry where
show e = concat
[ "<entry>"
, "<id>"
, encodeHtml $ atomEntryLink e
, "</id>"
, "<link href='"
, encodeHtml $ atomEntryLink e
, "' />"
, "<updated>"
, formatW3 $ atomEntryUpdated e
, "</updated>"
, "<title>"
, encodeHtml $ atomEntryTitle e
, "</title>"
, "<content type='html'><![CDATA["
, atomEntryContent e
, "]]></content>"
, "</entry>"
]
formatW3 :: UTCTime -> String
formatW3 = formatTime defaultTimeLocale "%FT%X-08:00"
class IsTree a => ListDetail a where
htmlDetail :: a -> String
htmlDetail = treeToHtml . toTree
detailTitle :: a -> String
detailUrl :: a -> String
htmlList :: [a] -> String
htmlList l = "<ul>" ++ concatMap helper l ++ "</ul>"
where
helper i = "<li><a href=\"" ++ encodeHtml (detailUrl i) ++
"\">" ++ encodeHtml (detailTitle i) ++
"</a></li>"
-- | Often times for the JSON response of the list, we don't need all
-- the information.
treeList :: [a] -> Tree
treeList = TreeList . map treeListSingle
treeListSingle :: a -> Tree
treeListSingle = toTree
newtype ItemList a = ItemList [a]
instance ListDetail a => Response (ItemList a) where
reps (ItemList l) =
[ ("text/html", response 200 [] $ htmlList l)
, ("application/json", response 200 [] $ treeToJson $ treeList l)
]
newtype ItemDetail a = ItemDetail a
instance ListDetail a => Response (ItemDetail a) where
reps (ItemDetail i) =
[ ("text/html", response 200 [] $ htmlDetail i)
, ("application/json", response 200 [] $ treeToJson $ toTree i)
]
-- sitemaps
data SitemapLoc = AbsLoc String | RelLoc String
data SitemapChangeFreq = Always
| Hourly
| Daily
| Weekly
| Monthly
| Yearly
| Never
instance Show SitemapChangeFreq where
show Always = "always"
show Hourly = "hourly"
show Daily = "daily"
show Weekly = "weekly"
show Monthly = "monthly"
show Yearly = "yearly"
show Never = "never"
data SitemapUrl = SitemapUrl
{ sitemapLoc :: SitemapLoc
, sitemapLastMod :: UTCTime
, sitemapChangeFreq :: SitemapChangeFreq
, priority :: Double
}
data SitemapRequest = SitemapRequest String Int
instance Request SitemapRequest where
parseRequest = do
env <- parseEnv
return $! SitemapRequest (Hack.serverName env)
(Hack.serverPort env)
data SitemapResponse = SitemapResponse SitemapRequest [SitemapUrl]
instance Show SitemapResponse where
show (SitemapResponse (SitemapRequest host port) urls) =
"<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n" ++
"<urlset xmlns=\"http://www.sitemaps.org/schemas/sitemap/0.9\">" ++
concatMap helper urls ++
"</urlset>"
where
prefix = "http://" ++ host ++
case port of
80 -> ""
_ -> ":" ++ show port
helper (SitemapUrl loc modTime freq pri) = concat
[ "<url><loc>"
, encodeHtml $ showLoc loc
, "</loc><lastmod>"
, formatW3 modTime
, "</lastmod><changefreq>"
, show freq
, "</changefreq><priority>"
, show pri
, "</priority></url>"
]
showLoc (AbsLoc s) = s
showLoc (RelLoc s) = prefix ++ s
instance Response SitemapResponse where
reps res =
[ ("text/xml", response 200 [] $ show res)
]
sitemap :: IO [SitemapUrl] -> SitemapRequest -> IO SitemapResponse
sitemap urls' req = do
urls <- urls'
return $ SitemapResponse req urls
-- misc helper functions
tryLookup :: Eq k => v -> k -> [(k, v)] -> v
tryLookup v _ [] = v
tryLookup v k ((k', v'):rest)
| k == k' = v'
| otherwise = tryLookup v k rest
data GenResponse = HtmlResponse String
| TreeResponse Tree
| HtmlOrTreeResponse String Tree
| RedirectResponse String
| PermissionDeniedResult String
| NotFoundResponse String
instance Response GenResponse where
reps (HtmlResponse h) = [("text/html", response 200 [] h)]
reps (TreeResponse t) = reps t
reps (HtmlOrTreeResponse h t) =
("text/html", response 200 [] h) : reps t
reps (RedirectResponse url) = [("text/html", response 303 heads body)]
where
heads = [("Location", url)]
body = "<p>Redirecting to <a href='" ++ encodeHtml url ++
"'>" ++ encodeHtml url ++ "</a></p>"
reps (PermissionDeniedResult s) = [("text/plain", response 403 [] s)]
reps (NotFoundResponse s) = [("text/plain", response 404 [] s)]

17
restful.cabal Normal file
View File

@ -0,0 +1,17 @@
name: restful
version: 0.0.0
license: BSD3
license-file: LICENSE
author: Michael Snoyman <michael@snoyman.com>
maintainer: Michael Snoyman <michael@snoyman.com>
synopsis: A Restful front controller built on Hack.
category: Web
stability: unstable
cabal-version: >= 1.2
build-type: Simple
homepage: http://github.com/snoyberg/restful/tree/master
library
build-depends: base
exposed-modules: Web.Restful
ghc-options: -Wall