Split into multiple modules
This commit is contained in:
Michael Snoyman
parent
d99fa2d8bc
commit
019dca9968
879
Web/Restful.hs
879
Web/Restful.hs
@ -1,9 +1,3 @@
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE TypeSynonymInstances #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE ExistentialQuantification #-}
|
||||
{-# LANGUAGE OverlappingInstances #-}
|
||||
---------------------------------------------------------
|
||||
--
|
||||
-- Module : Web.Restful
|
||||
@ -19,870 +13,13 @@
|
||||
---------------------------------------------------------
|
||||
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
|
||||
module Data.Object
|
||||
, module Web.Restful.Request
|
||||
, module Web.Restful.Response
|
||||
, module Web.Restful.Application
|
||||
) 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)]
|
||||
import Data.Object
|
||||
import Web.Restful.Request
|
||||
import Web.Restful.Response
|
||||
import Web.Restful.Application
|
||||
|
||||
362
Web/Restful/Application.hs
Normal file
362
Web/Restful/Application.hs
Normal file
@ -0,0 +1,362 @@
|
||||
{-# LANGUAGE TypeSynonymInstances #-}
|
||||
{-# LANGUAGE ExistentialQuantification #-}
|
||||
---------------------------------------------------------
|
||||
--
|
||||
-- Module : Web.Restful.Application
|
||||
-- Copyright : Michael Snoyman
|
||||
-- License : BSD3
|
||||
--
|
||||
-- Maintainer : Michael Snoyman <michael@snoyman.com>
|
||||
-- Stability : Stable
|
||||
-- Portability : portable
|
||||
--
|
||||
-- Defining the application.
|
||||
--
|
||||
---------------------------------------------------------
|
||||
module Web.Restful.Application
|
||||
(
|
||||
-- * 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 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 Hack.Middleware.Gzip
|
||||
import Hack.Middleware.CleanPath
|
||||
import Hack.Middleware.Jsonp
|
||||
import Hack.Middleware.ClientSession
|
||||
|
||||
import Control.Applicative ((<$>), Applicative (..))
|
||||
import Control.Arrow (second)
|
||||
|
||||
import Web.Restful.Request
|
||||
import Web.Restful.Response
|
||||
import Web.Restful.Constants
|
||||
import Web.Restful.Utils
|
||||
import Data.Object
|
||||
|
||||
-- | 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
|
||||
|
||||
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')
|
||||
|
||||
data AuthRequest = AuthRequest (Maybe String)
|
||||
instance Request AuthRequest where
|
||||
parseRequest = AuthRequest `fmap` identifier
|
||||
|
||||
authCheck :: AuthRequest -> IO Object
|
||||
authCheck (AuthRequest Nothing) =
|
||||
return $ toObject [("status", "notloggedin")]
|
||||
authCheck (AuthRequest (Just i)) =
|
||||
return $ toObject
|
||||
[ ("status", "loggedin")
|
||||
, ("ident", i)
|
||||
]
|
||||
|
||||
authLogout :: () -> IO LogoutResponse
|
||||
authLogout _ = return LogoutResponse
|
||||
|
||||
data LogoutResponse = LogoutResponse
|
||||
instance Response LogoutResponse where
|
||||
reps _ = map (second addCookie) $ reps tree where
|
||||
tree = toObject [("status", "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
|
||||
17
Web/Restful/Constants.hs
Normal file
17
Web/Restful/Constants.hs
Normal file
@ -0,0 +1,17 @@
|
||||
---------------------------------------------------------
|
||||
--
|
||||
-- Module : Web.Restful.Constants
|
||||
-- Copyright : Michael Snoyman
|
||||
-- License : BSD3
|
||||
--
|
||||
-- Maintainer : Michael Snoyman <michael@snoyman.com>
|
||||
-- Stability : Stable
|
||||
-- Portability : portable
|
||||
--
|
||||
-- Constants used throughout Restful.
|
||||
--
|
||||
---------------------------------------------------------
|
||||
module Web.Restful.Constants where
|
||||
|
||||
authCookieName :: String
|
||||
authCookieName = "IDENTIFIER"
|
||||
271
Web/Restful/Request.hs
Normal file
271
Web/Restful/Request.hs
Normal file
@ -0,0 +1,271 @@
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE TypeSynonymInstances #-}
|
||||
{-# LANGUAGE OverlappingInstances #-}
|
||||
---------------------------------------------------------
|
||||
--
|
||||
-- Module : Web.Restful.Request
|
||||
-- Copyright : Michael Snoyman
|
||||
-- License : BSD3
|
||||
--
|
||||
-- Maintainer : Michael Snoyman <michael@snoyman.com>
|
||||
-- Stability : Stable
|
||||
-- Portability : portable
|
||||
--
|
||||
-- Code for extracting parameters from requests.
|
||||
--
|
||||
---------------------------------------------------------
|
||||
module Web.Restful.Request
|
||||
(
|
||||
-- * 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 (..)
|
||||
-- ** FIXME
|
||||
, parseEnv
|
||||
, RawRequest (..)
|
||||
, PathInfo
|
||||
, runRequestParser
|
||||
) where
|
||||
|
||||
import qualified Hack
|
||||
import Data.Function.Predicate (equals)
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.Writer
|
||||
import Control.Monad.Error ()
|
||||
import Web.Restful.Constants
|
||||
import Web.Restful.Utils
|
||||
import Control.Applicative (Applicative (..))
|
||||
import Web.Encodings
|
||||
|
||||
-- $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 PathInfo = [String]
|
||||
293
Web/Restful/Response.hs
Normal file
293
Web/Restful/Response.hs
Normal file
@ -0,0 +1,293 @@
|
||||
{-# LANGUAGE ExistentialQuantification #-}
|
||||
---------------------------------------------------------
|
||||
--
|
||||
-- Module : Web.Restful.Response
|
||||
-- Copyright : Michael Snoyman
|
||||
-- License : BSD3
|
||||
--
|
||||
-- Maintainer : Michael Snoyman <michael@snoyman.com>
|
||||
-- Stability : Stable
|
||||
-- Portability : portable
|
||||
--
|
||||
-- Generating responses.
|
||||
--
|
||||
---------------------------------------------------------
|
||||
module Web.Restful.Response
|
||||
(
|
||||
-- * Response construction
|
||||
Response (..)
|
||||
, response
|
||||
-- ** Helper 'Response' instances
|
||||
-- *** Atom news feed
|
||||
, AtomFeed (..)
|
||||
, AtomFeedEntry (..)
|
||||
-- *** Sitemap
|
||||
, sitemap
|
||||
, SitemapUrl (..)
|
||||
, SitemapLoc (..)
|
||||
, SitemapChangeFreq (..)
|
||||
-- *** Generics
|
||||
-- **** List/detail
|
||||
, ListDetail (..)
|
||||
, ItemList (..)
|
||||
, ItemDetail (..)
|
||||
-- **** Multiple response types.
|
||||
, GenResponse (..)
|
||||
-- * FIXME
|
||||
, ResponseWrapper (..)
|
||||
, ErrorResponse (..)
|
||||
) where
|
||||
|
||||
import Data.ByteString.Class
|
||||
import qualified Hack
|
||||
import Data.Time.Format
|
||||
import Data.Time.Clock
|
||||
import Web.Encodings
|
||||
import System.Locale
|
||||
import Web.Restful.Request -- FIXME ultimately remove
|
||||
import Data.Object
|
||||
import Data.List (intercalate)
|
||||
|
||||
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
|
||||
|
||||
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"
|
||||
|
||||
-- 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
|
||||
|
||||
data GenResponse = HtmlResponse String
|
||||
| ObjectResponse Object
|
||||
| HtmlOrObjectResponse String Object
|
||||
| RedirectResponse String
|
||||
| PermissionDeniedResult String
|
||||
| NotFoundResponse String
|
||||
instance Response GenResponse where
|
||||
reps (HtmlResponse h) = [("text/html", response 200 [] h)]
|
||||
reps (ObjectResponse t) = reps t
|
||||
reps (HtmlOrObjectResponse 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)]
|
||||
class ToObject a => ListDetail a where
|
||||
htmlDetail :: a -> String
|
||||
htmlDetail = treeToHtml . toObject
|
||||
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] -> Object -- FIXME
|
||||
treeList = Sequence . map treeListSingle
|
||||
treeListSingle :: a -> Object
|
||||
treeListSingle = toObject
|
||||
|
||||
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 $ toObject i)
|
||||
]
|
||||
|
||||
-- FIXME remove treeTo functions, replace with Object instances
|
||||
treeToJson :: Object -> String
|
||||
treeToJson (Scalar s) = '"' : encodeJson (fromStrictByteString s) ++ "\""
|
||||
treeToJson (Sequence l) =
|
||||
"[" ++ intercalate "," (map treeToJson l) ++ "]"
|
||||
treeToJson (Mapping m) =
|
||||
"{" ++ intercalate "," (map helper m) ++ "}" where
|
||||
helper (k, v) =
|
||||
treeToJson (Scalar k) ++
|
||||
":" ++
|
||||
treeToJson v
|
||||
|
||||
treeToHtml :: Object -> String
|
||||
treeToHtml (Scalar s) = encodeHtml $ fromStrictByteString s
|
||||
treeToHtml (Sequence l) =
|
||||
"<ul>" ++ concatMap (\e -> "<li>" ++ treeToHtml e ++ "</li>") l ++
|
||||
"</ul>"
|
||||
treeToHtml (Mapping m) =
|
||||
"<dl>" ++
|
||||
concatMap (\(k, v) -> "<dt>" ++
|
||||
encodeHtml (fromStrictByteString k) ++
|
||||
"</dt>" ++
|
||||
"<dd>" ++
|
||||
treeToHtml v ++
|
||||
"</dd>") m ++
|
||||
"</dl>"
|
||||
|
||||
instance Response Object where
|
||||
reps tree =
|
||||
[ ("text/html", response 200 [] $ treeToHtml tree)
|
||||
, ("application/json", response 200 [] $ treeToJson tree)
|
||||
]
|
||||
33
Web/Restful/Utils.hs
Normal file
33
Web/Restful/Utils.hs
Normal file
@ -0,0 +1,33 @@
|
||||
---------------------------------------------------------
|
||||
--
|
||||
-- Module : Web.Restful.Utils
|
||||
-- Copyright : Michael Snoyman
|
||||
-- License : BSD3
|
||||
--
|
||||
-- Maintainer : Michael Snoyman <michael@snoyman.com>
|
||||
-- Stability : Stable
|
||||
-- Portability : portable
|
||||
--
|
||||
-- Utility functions for Restful.
|
||||
--
|
||||
---------------------------------------------------------
|
||||
module Web.Restful.Utils
|
||||
( parseHttpAccept
|
||||
, tryLookup
|
||||
) where
|
||||
|
||||
import Data.List.Split (splitOneOf)
|
||||
|
||||
parseHttpAccept :: String -> [String]
|
||||
parseHttpAccept = filter (not . specialHttpAccept) . splitOneOf ";,"
|
||||
|
||||
specialHttpAccept :: String -> Bool
|
||||
specialHttpAccept ('q':'=':_) = True
|
||||
specialHttpAccept ('*':_) = True
|
||||
specialHttpAccept _ = False
|
||||
|
||||
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
|
||||
@ -28,6 +28,12 @@ library
|
||||
bytestring >= 0.9.1.4,
|
||||
bytestring-class,
|
||||
web-encodings,
|
||||
mtl >= 1.1.0.2
|
||||
exposed-modules: Web.Restful
|
||||
mtl >= 1.1.0.2,
|
||||
data-object
|
||||
exposed-modules: Web.Restful,
|
||||
Web.Restful.Constants,
|
||||
Web.Restful.Request,
|
||||
Web.Restful.Response,
|
||||
Web.Restful.Utils,
|
||||
Web.Restful.Application
|
||||
ghc-options: -Wall
|
||||
|
||||
Loading…
Reference in New Issue
Block a user