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

Massive revamp of responses; not yet fully functional

Browse Source
This commit is contained in:
Michael Snoyman 2009-09-18 04:14:52 +03:00
parent c3c4d647d3
commit 86ca811ac5
10 changed files with 266 additions and 243 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

61
Data/Object/Instances.hs
View File

@ -20,10 +20,11 @@ module Data.Object.Instances
) where ) where
import Data.Object import Data.Object
import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as B
import qualified Data.ByteString as BS
import Data.ByteString.Class import Data.ByteString.Class
import Web.Encodings (encodeJson) import Web.Encodings (encodeJson)
import qualified Text.Yaml as Y import Text.Yaml (encode)
class SafeFromObject a where class SafeFromObject a where
safeFromObject :: Object -> a safeFromObject :: Object -> a
@ -33,31 +34,31 @@ instance SafeFromObject Json where
safeFromObject = Json . helper where safeFromObject = Json . helper where
helper :: Object -> B.ByteString helper :: Object -> B.ByteString
helper (Scalar s) = B.concat helper (Scalar s) = B.concat
[ toStrictByteString "\"" [ toLazyByteString "\""
, encodeJson $ fromStrictByteString s , encodeJson $ fromStrictByteString s
, toStrictByteString "\"" , toLazyByteString "\""
] ]
helper (Sequence s) = B.concat helper (Sequence s) = B.concat
[ toStrictByteString "[" [ toLazyByteString "["
, B.intercalate (toStrictByteString ",") $ map helper s , B.intercalate (toLazyByteString ",") $ map helper s
, toStrictByteString "]" , toLazyByteString "]"
] ]
helper (Mapping m) = B.concat helper (Mapping m) = B.concat
[ toStrictByteString "{" [ toLazyByteString "{"
, B.intercalate (toStrictByteString ",") $ map helper2 m , B.intercalate (toLazyByteString ",") $ map helper2 m
, toStrictByteString "}" , toLazyByteString "}"
] ]
helper2 :: (B.ByteString, Object) -> B.ByteString helper2 :: (BS.ByteString, Object) -> B.ByteString
helper2 (k, v) = B.concat helper2 (k, v) = B.concat
[ toStrictByteString "\"" [ toLazyByteString "\""
, encodeJson $ fromStrictByteString k , encodeJson $ fromStrictByteString k
, toStrictByteString "\":" , toLazyByteString "\":"
, helper v , helper v
] ]
newtype Yaml = Yaml { unYaml :: B.ByteString } newtype Yaml = Yaml { unYaml :: B.ByteString }
instance SafeFromObject Yaml where instance SafeFromObject Yaml where
safeFromObject = Yaml . Y.encode safeFromObject = Yaml . encode
-- | Represents as an entire HTML 5 document by using the following: -- | Represents as an entire HTML 5 document by using the following:
-- --
@ -68,31 +69,31 @@ newtype Html = Html { unHtml :: B.ByteString }
instance SafeFromObject Html where instance SafeFromObject Html where
safeFromObject o = Html $ B.concat safeFromObject o = Html $ B.concat
[ toStrictByteString "<!DOCTYPE html>\n<html><body>" [ toLazyByteString "<!DOCTYPE html>\n<html><body>" -- FIXME full doc or just fragment?
, helper o , helper o
, toStrictByteString "</body></html>" , toLazyByteString "</body></html>"
] where ] where
helper :: Object -> B.ByteString helper :: Object -> B.ByteString
helper (Scalar s) = B.concat helper (Scalar s) = B.concat
[ toStrictByteString "<p>" [ toLazyByteString "<p>"
, s , toLazyByteString s
, toStrictByteString "</p>" , toLazyByteString "</p>"
] ]
helper (Sequence []) = toStrictByteString "<ul></ul>" helper (Sequence []) = toLazyByteString "<ul></ul>"
helper (Sequence s) = B.concat helper (Sequence s) = B.concat
[ toStrictByteString "<ul><li>" [ toLazyByteString "<ul><li>"
, B.intercalate (toStrictByteString "</li><li>") $ map helper s , B.intercalate (toLazyByteString "</li><li>") $ map helper s
, toStrictByteString "</li></ul>" , toLazyByteString "</li></ul>"
] ]
helper (Mapping m) = B.concat $ helper (Mapping m) = B.concat $
toStrictByteString "<dl>" : toLazyByteString "<dl>" :
map helper2 m ++ map helper2 m ++
[ toStrictByteString "</dl>" ] [ toLazyByteString "</dl>" ]
helper2 :: (B.ByteString, Object) -> B.ByteString helper2 :: (BS.ByteString, Object) -> B.ByteString
helper2 (k, v) = B.concat $ helper2 (k, v) = B.concat $
[ toStrictByteString "<dt>" [ toLazyByteString "<dt>"
, k , toLazyByteString k
, toStrictByteString "</dt><dd>" , toLazyByteString "</dt><dd>"
, helper v , helper v
, toStrictByteString "</dd>" , toLazyByteString "</dd>"
] ]

34
Web/Restful/Application.hs
View File

@ -23,8 +23,6 @@ module Web.Restful.Application
) where ) where
import Web.Encodings import Web.Encodings
import Data.Maybe (isJust)
import Data.Function.Predicate (equals)
import Data.ByteString.Class import Data.ByteString.Class
import qualified Data.ByteString.Lazy as B import qualified Data.ByteString.Lazy as B
@ -105,7 +103,7 @@ takeJusts (Just x:rest) = x : takeJusts rest
toHackApplication :: RestfulApp resourceName model toHackApplication :: RestfulApp resourceName model
=> resourceName => resourceName
-> HandlerMap resourceName -> (resourceName -> Verb -> Handler)
-> Hack.Application -> Hack.Application
toHackApplication sampleRN hm env = do toHackApplication sampleRN hm env = do
let (Right resource) = splitPath $ Hack.pathInfo env let (Right resource) = splitPath $ Hack.pathInfo env
@ -116,31 +114,11 @@ toHackApplication sampleRN hm env = do
verb = toVerb $ Hack.requestMethod env verb = toVerb $ Hack.requestMethod env
rr :: RawRequest rr :: RawRequest
rr = envToRawRequest urlParams' env rr = envToRawRequest urlParams' env
case hm rn verb of handler :: Handler
(Just handler) -> do handler = hm rn verb
let rawHttpAccept = tryLookup "" "Accept" $ Hack.http env let rawHttpAccept = tryLookup "" "Accept" $ Hack.http env
ctypes' = parseHttpAccept rawHttpAccept ctypes' = parseHttpAccept rawHttpAccept
body <- runHandler handler rr runResponse (handler rr) ctypes'
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 sampleRN $ env
Just (ctype, Hack.Response status headers content) -> do
content' <- responseWrapper sampleRN ctype content
let response' = Hack.Response
status
(("Content-Type", ctype) : headers)
content'
return response'
Nothing -> response404 sampleRN $ env
x -> error $ "Invalid matches: " ++ show x x -> error $ "Invalid matches: " ++ show x
envToRawRequest :: [(ParamName, ParamValue)] -> Hack.Env -> RawRequest envToRawRequest :: [(ParamName, ParamValue)] -> Hack.Env -> RawRequest

14
Web/Restful/Generic/ListDetail.hs
View File

@ -25,7 +25,7 @@ import Data.ByteString.Class
class ToObject a => ListDetail a where class ToObject a => ListDetail a where
htmlDetail :: a -> String htmlDetail :: a -> String
htmlDetail = fromStrictByteString . unHtml . safeFromObject . toObject htmlDetail = fromLazyByteString . unHtml . safeFromObject . toObject
detailTitle :: a -> String detailTitle :: a -> String
detailUrl :: a -> String detailUrl :: a -> String
htmlList :: [a] -> String htmlList :: [a] -> String
@ -42,14 +42,14 @@ class ToObject a => ListDetail a where
treeListSingle = toObject treeListSingle = toObject
newtype ItemList a = ItemList [a] newtype ItemList a = ItemList [a]
instance ListDetail a => Response (ItemList a) where instance ListDetail a => HasReps (ItemList a) where
reps (ItemList l) = reps (ItemList l) =
[ ("text/html", response 200 [] $ htmlList l) [ ("text/html", toLazyByteString $ htmlList l)
, ("application/json", response 200 [] $ unJson $ safeFromObject $ treeList l) , ("application/json", unJson $ safeFromObject $ treeList l)
] ]
newtype ItemDetail a = ItemDetail a newtype ItemDetail a = ItemDetail a
instance ListDetail a => Response (ItemDetail a) where instance ListDetail a => HasReps (ItemDetail a) where
reps (ItemDetail i) = reps (ItemDetail i) =
[ ("text/html", response 200 [] $ htmlDetail i) [ ("text/html", toLazyByteString $ htmlDetail i)
, ("application/json", response 200 [] $ unJson $ safeFromObject $ toObject i) , ("application/json", unJson $ safeFromObject $ toObject i)
] ]

30
Web/Restful/Handler.hs
View File

@ -15,28 +15,26 @@
-- --
--------------------------------------------------------- ---------------------------------------------------------
module Web.Restful.Handler module Web.Restful.Handler
( Handler (..) ( Handler
, runHandler
, HandlerMap
, liftHandler , liftHandler
, noHandler
) where ) where
import Web.Restful.Definitions
import Web.Restful.Request import Web.Restful.Request
import Web.Restful.Response import Web.Restful.Response
data Handler = forall req. Request req => Handler (req -> IO ResponseWrapper) type Handler = RawRequest -> Response
runHandler :: Handler -> RawRequest -> IO ResponseWrapper liftHandler :: (Request req, HasReps rep)
runHandler (Handler f) rreq = do => (req -> ResponseIO rep)
let rparser = parseRequest -> Handler
case runRequestParser rparser rreq of liftHandler f req = liftRequest req >>= wrapResponse . f
liftRequest :: (Request req, Monad m) => RawRequest -> m req
liftRequest r =
case runRequestParser parseRequest r of
Left errors -> fail $ unlines errors -- FIXME Left errors -> fail $ unlines errors -- FIXME
Right req -> f req Right req -> return req
type HandlerMap a = a -> Verb -> Maybe Handler noHandler :: Handler
noHandler = const notFound
liftHandler :: (Request req, Response res)
=> (req -> IO res)
-> Maybe Handler
liftHandler f = Just . Handler $ fmap ResponseWrapper . f

110
Web/Restful/Helpers/Auth.hs
View File

@ -26,10 +26,10 @@ import Web.Restful
import Web.Restful.Constants import Web.Restful.Constants
import Control.Applicative ((<$>), Applicative (..)) import Control.Applicative ((<$>), Applicative (..))
import Control.Arrow (second)
import Control.Monad.Reader import Control.Monad.Reader
import Data.Object import Data.Object
import Data.Maybe (fromMaybe)
data AuthResource = data AuthResource =
Check Check
@ -48,7 +48,7 @@ instance ResourceName AuthResource (Maybe RpxnowApiKey) where
getHandler _ OpenidForward Get = liftHandler authOpenidForward getHandler _ OpenidForward Get = liftHandler authOpenidForward
getHandler _ OpenidComplete Get = liftHandler authOpenidComplete getHandler _ OpenidComplete Get = liftHandler authOpenidComplete
getHandler (Just key) LoginRpxnow Get = liftHandler $ rpxnowLogin key getHandler (Just key) LoginRpxnow Get = liftHandler $ rpxnowLogin key
getHandler _ _ _ = Nothing getHandler _ _ _ = noHandler
allValues = allValues =
Check Check
@ -74,24 +74,20 @@ instance Show OIDFormReq where
show (OIDFormReq Nothing _) = "" show (OIDFormReq Nothing _) = ""
show (OIDFormReq (Just s) _) = "<p class='message'>" ++ encodeHtml s ++ show (OIDFormReq (Just s) _) = "<p class='message'>" ++ encodeHtml s ++
"</p>" "</p>"
data OIDFormRes = OIDFormRes String (Maybe String)
instance Response OIDFormRes where authOpenidForm :: OIDFormReq -> ResponseIO GenResponse
reps (OIDFormRes s dest) = [("text/html", response 200 heads s)] authOpenidForm m@(OIDFormReq _ dest) = do
where
heads =
case dest of
Nothing -> []
Just dest' ->
[("Set-Cookie", "DEST=" ++ dest' ++ "; path=/")]
authOpenidForm :: OIDFormReq -> IO OIDFormRes
authOpenidForm m@(OIDFormReq _ dest) =
let html = let html =
show m ++ show m ++
"<form method='get' action='forward/'>" ++ "<form method='get' action='forward/'>" ++
"OpenID: <input type='text' name='openid'>" ++ "OpenID: <input type='text' name='openid'>" ++
"<input type='submit' value='Login'>" ++ "<input type='submit' value='Login'>" ++
"</form>" "</form>"
in return $! OIDFormRes html dest case dest of
Just dest' -> addCookie 20 "DEST" dest'
Nothing -> return ()
return $! HtmlResponse html
data OIDFReq = OIDFReq String String data OIDFReq = OIDFReq String String
instance Request OIDFReq where instance Request OIDFReq where
parseRequest = do parseRequest = do
@ -101,14 +97,13 @@ instance Request OIDFReq where
show (Hack.serverPort env) ++ show (Hack.serverPort env) ++
"/auth/openid/complete/" "/auth/openid/complete/"
return $! OIDFReq oid complete return $! OIDFReq oid complete
authOpenidForward :: OIDFReq -> IO GenResponse authOpenidForward :: OIDFReq -> Response
authOpenidForward (OIDFReq oid complete) = do authOpenidForward (OIDFReq oid complete) = do
res <- OpenId.getForwardUrl oid complete :: IO (Either String String) res <- liftIO $ OpenId.getForwardUrl oid complete
return $ case res of
case res of Left err -> redirect $ "/auth/openid/?message="
Left err -> RedirectResponse $ "/auth/openid/?message=" ++ ++ encodeUrl (err :: String)
encodeUrl err Right url -> redirect url
Right url -> RedirectResponse url
data OIDComp = OIDComp [(String, String)] (Maybe String) data OIDComp = OIDComp [(String, String)] (Maybe String)
instance Request OIDComp where instance Request OIDComp where
@ -117,35 +112,17 @@ instance Request OIDComp where
let gets = rawGetParams rr let gets = rawGetParams rr
dest <- cookieParam "DEST" dest <- cookieParam "DEST"
return $! OIDComp gets 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) authOpenidComplete :: OIDComp -> Response
resetCookie name =
("Set-Cookie",
name ++ "=; path=/; expires=Thu, 01-Jan-1970 00:00:00 GMT")
authOpenidComplete :: OIDComp -> IO OIDCompRes
authOpenidComplete (OIDComp gets' dest) = do authOpenidComplete (OIDComp gets' dest) = do
res <- OpenId.authenticate gets' :: IO (Either String OpenId.Identifier) res <- liftIO $ OpenId.authenticate gets'
return $ case res of
case res of Left err -> redirect $ "/auth/openid/?message="
Left err -> OIDCompResErr err ++ encodeUrl (err :: String)
Right (OpenId.Identifier ident) -> OIDCompResGood ident dest Right (OpenId.Identifier ident) -> do
deleteCookie "DEST"
header authCookieName ident
redirect $ fromMaybe "/" dest
-- | token dest -- | token dest
data RpxnowRequest = RpxnowRequest String (Maybe String) data RpxnowRequest = RpxnowRequest String (Maybe String)
@ -159,34 +136,25 @@ chopHash :: String -> String
chopHash ('#':rest) = rest chopHash ('#':rest) = rest
chopHash x = x 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 rpxnowLogin :: String -- ^ api key
-> RpxnowRequest -> RpxnowRequest
-> IO RpxnowResponse -> Response
rpxnowLogin apiKey (RpxnowRequest token dest') = do rpxnowLogin apiKey (RpxnowRequest token dest') = do
let dest = case dest' of let dest = case dest' of
Nothing -> "/" Nothing -> "/"
Just "" -> "/" Just "" -> "/"
Just s -> s Just s -> s
ident' <- Rpxnow.authenticate apiKey token ident' <- liftIO $ Rpxnow.authenticate apiKey token
return $ RpxnowResponse dest (Rpxnow.identifier `fmap` ident') case ident' of
Nothing -> return ()
Just ident -> header authCookieName $ Rpxnow.identifier ident
redirect dest
data AuthRequest = AuthRequest (Maybe String) data AuthRequest = AuthRequest (Maybe String)
instance Request AuthRequest where instance Request AuthRequest where
parseRequest = AuthRequest `fmap` identifier parseRequest = AuthRequest `fmap` identifier
authCheck :: AuthRequest -> IO Object authCheck :: AuthRequest -> ResponseIO Object
authCheck (AuthRequest Nothing) = authCheck (AuthRequest Nothing) =
return $ toObject [("status", "notloggedin")] return $ toObject [("status", "notloggedin")]
authCheck (AuthRequest (Just i)) = authCheck (AuthRequest (Just i)) =
@ -195,13 +163,7 @@ authCheck (AuthRequest (Just i)) =
, ("ident", i) , ("ident", i)
] ]
authLogout :: () -> IO LogoutResponse authLogout :: () -> ResponseIO Object
authLogout _ = return LogoutResponse authLogout _ = do
deleteCookie authCookieName
data LogoutResponse = LogoutResponse return $ toObject [("status", "loggedout")]
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

2
Web/Restful/Resource.hs
View File

@ -49,7 +49,7 @@ class Show a => ResourceName a b | a -> b where
allValues :: [a] allValues :: [a]
-- | Find the handler for each resource name/verb pattern. -- | Find the handler for each resource name/verb pattern.
getHandler :: b -> a -> Verb -> Maybe Handler getHandler :: b -> a -> Verb -> Handler
-- FIXME add some overlap checking functions -- FIXME add some overlap checking functions

239
Web/Restful/Response.hs
View File

@ -1,5 +1,6 @@
{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeSynonymInstances #-}
--------------------------------------------------------- ---------------------------------------------------------
-- --
-- Module : Web.Restful.Response -- Module : Web.Restful.Response
@ -14,110 +15,192 @@
-- --
--------------------------------------------------------- ---------------------------------------------------------
module Web.Restful.Response module Web.Restful.Response
( ( formatW3
-- * Response construction , HasReps (..)
Response (..) , notFound
, response , wrapResponse
-- * FIXME , ResponseIO
, ResponseT
, Response
, runResponse
, deleteCookie
, redirect
, addCookie
, header
, GenResponse (..) , GenResponse (..)
, ResponseWrapper (..) , liftIO
, ErrorResponse (..)
, formatW3
, UTCTime
) where ) where
import Data.ByteString.Class import Data.ByteString.Class
import qualified Hack
import Data.Time.Format import Data.Time.Format
import Data.Time.Clock import Data.Time.Clock
import Web.Encodings
import System.Locale import System.Locale
import Data.Object import Data.Object
import Data.List (intercalate) import qualified Data.ByteString.Lazy as B
import Data.Object.Instances
import Data.Maybe (fromJust)
import Control.Monad.Trans
import qualified Hack
type ContentType = String type ContentType = String
-- | The output for a resource. -- | Something which can be represented as multiple content types.
class Response a where -- Each content type is called a representation of the data.
-- | Provide an ordered list of possible responses, depending on content class HasReps a where
-- type. If the user asked for a specific response type (like -- | Provide an ordered list of possible representations, 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 -- text/html), then that will get priority. If not, then the first
-- element in this list will be used. -- element in this list will be used.
reps :: a -> [(ContentType, Hack.Response)] reps :: a -> [(ContentType, B.ByteString)]
-- | Wrapper around 'Hack.Response' to allow arbitrary pieces of data to be -- | Wrap up any instance of 'HasReps'.
-- used for the body. data HasRepsW = forall a. HasReps a => HasRepsW a
response :: LazyByteString lbs
=> Int
-> [(String, String)]
-> lbs
-> Hack.Response
response a b c = Hack.Response a b $ toLazyByteString c
instance Response () where instance HasReps HasRepsW where
reps _ = [("text/plain", response 200 [] "")] reps (HasRepsW r) = reps r
newtype ErrorResponse = ErrorResponse String -- | The result of a request. This does not include possible headers.
instance Response ErrorResponse where data Result =
reps (ErrorResponse s) = [("text/plain", response 500 [] s)] Redirect String
| NotFound
| InternalError String
| Content HasRepsW
data ResponseWrapper = forall res. Response res => ResponseWrapper res instance HasReps Result where
instance Response ResponseWrapper where reps (Redirect s) = [("text/plain", toLazyByteString s)]
reps (ResponseWrapper res) = reps res reps NotFound = [("text/plain", toLazyByteString "not found")] -- FIXME use the real 404 page
reps (InternalError s) = [("text/plain", toLazyByteString s)]
reps (Content r) = reps r
getStatus :: Result -> Int
getStatus (Redirect _) = 303
getStatus NotFound = 404
getStatus (InternalError _) = 500
getStatus (Content _) = 200
getHeaders :: Result -> [Header]
getHeaders (Redirect s) = [Header "Location" s]
getHeaders _ = []
newtype ResponseT m a = ResponseT (m (Either Result a, [Header]))
type ResponseIO = ResponseT IO
type Response = ResponseIO HasRepsW
runResponse :: Response -> [ContentType] -> IO Hack.Response
runResponse (ResponseT inside) ctypesAll = do
(x, headers') <- inside
let extraHeaders =
case x of
Left r -> getHeaders r
Right _ -> []
headers <- mapM toPair (headers' ++ extraHeaders)
let outReps = either reps reps x
let statusCode =
case x of
Left r -> getStatus r
Right _ -> 200
(ctype, finalRep) <- chooseRep outReps ctypesAll
let headers'' = ("Content-Type", ctype) : headers
return $! Hack.Response statusCode headers'' finalRep
chooseRep :: Monad m
=> [(ContentType, B.ByteString)]
-> [ContentType]
-> m (ContentType, B.ByteString)
chooseRep rs cs
| length rs == 0 = fail "All reps must have at least one value"
| otherwise = do
let availCs = map fst rs
case filter (`elem` availCs) cs of
[] -> return $ head rs
[ctype] -> return (ctype, fromJust $ lookup ctype rs)
_ -> fail "Overlapping representations"
toPair :: Header -> IO (String, String)
toPair (AddCookie minutes key value) = do
now <- getCurrentTime
let expires = addUTCTime (fromIntegral $ minutes * 60) now
return ("Set-Cookie", key ++ "=" ++ value ++"; path=/; expires="
++ formatW3 expires)
toPair (DeleteCookie key) = return
("Set-Cookie",
key ++ "=; path=/; expires=Thu, 01-Jan-1970 00:00:00 GMT")
toPair (Header key value) = return (key, value)
wrapResponse :: (Monad m, HasReps rep)
=> ResponseT m rep
-> ResponseT m HasRepsW
wrapResponse = fmap HasRepsW
instance MonadTrans ResponseT where
lift ma = ResponseT $ do
a <- ma
return (Right a, [])
instance MonadIO ResponseIO where
liftIO = lift
redirect :: Monad m => String -> ResponseT m a
redirect s = ResponseT (return (Left $ Redirect s, []))
notFound :: Monad m => ResponseT m a
notFound = ResponseT (return (Left NotFound, []))
instance Monad m => Functor (ResponseT m) where
fmap f x = x >>= return . f
instance Monad m => Monad (ResponseT m) where
return = lift . return
fail s = ResponseT (return (Left $ InternalError s, []))
(ResponseT mx) >>= f = ResponseT $ do
(x, hs1) <- mx
case x of
Left x' -> return (Left x', hs1)
Right a -> do
let (ResponseT b') = f a
(b, hs2) <- b'
return (b, hs1 ++ hs2)
-- | Headers to be added to a 'Result'.
data Header =
AddCookie Int String String
| DeleteCookie String
| Header String String
addCookie :: Monad m => Int -> String -> String -> ResponseT m ()
addCookie a b c = addHeader $ AddCookie a b c
deleteCookie :: Monad m => String -> ResponseT m ()
deleteCookie = addHeader . DeleteCookie
header :: Monad m => String -> String -> ResponseT m ()
header a b = addHeader $ Header a b
addHeader :: Monad m => Header -> ResponseT m ()
addHeader h = ResponseT (return (Right (), [h]))
instance HasReps () where
reps _ = [("text/plain", toLazyByteString "")]
data GenResponse = HtmlResponse String data GenResponse = HtmlResponse String
| ObjectResponse Object | ObjectResponse Object
| HtmlOrObjectResponse String Object | HtmlOrObjectResponse String Object
| RedirectResponse String instance HasReps GenResponse where
| PermissionDeniedResult String reps (HtmlResponse h) = [("text/html", toLazyByteString h)]
| NotFoundResponse String
instance Response GenResponse where
reps (HtmlResponse h) = [("text/html", response 200 [] h)]
reps (ObjectResponse t) = reps t reps (ObjectResponse t) = reps t
reps (HtmlOrObjectResponse h t) = reps (HtmlOrObjectResponse h t) =
("text/html", response 200 [] h) : reps t ("text/html", toLazyByteString 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)]
-- FIXME remove treeTo functions, replace with Object instances instance HasReps Object where
treeToJson :: Object -> String reps o =
treeToJson (Scalar s) = '"' : encodeJson (fromStrictByteString s) ++ "\"" [ ("text/html", unHtml $ safeFromObject o)
treeToJson (Sequence l) = , ("application/json", unJson $ safeFromObject o)
"[" ++ intercalate "," (map treeToJson l) ++ "]" , ("text/yaml", unYaml $ safeFromObject o)
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)
] ]
instance Response [(String, Hack.Response)] where instance HasReps [(ContentType, B.ByteString)] where
reps = id reps = id
-- FIXME put in a separate module (maybe Web.Encodings) -- FIXME put in a separate module (maybe Web.Encodings)

7
Web/Restful/Response/AtomFeed.hs
View File

@ -19,10 +19,9 @@ module Web.Restful.Response.AtomFeed
import Web.Restful.Response import Web.Restful.Response
import Data.Time.Format
import Data.Time.Clock import Data.Time.Clock
import Web.Encodings import Web.Encodings
import System.Locale import Data.ByteString.Class
data AtomFeed = AtomFeed data AtomFeed = AtomFeed
{ atomTitle :: String { atomTitle :: String
@ -31,9 +30,9 @@ data AtomFeed = AtomFeed
, atomUpdated :: UTCTime , atomUpdated :: UTCTime
, atomEntries :: [AtomFeedEntry] , atomEntries :: [AtomFeedEntry]
} }
instance Response AtomFeed where instance HasReps AtomFeed where
reps e = reps e =
[ ("application/atom+xml", response 200 [] $ show e) [ ("application/atom+xml", toLazyByteString $ show e)
] ]
data AtomFeedEntry = AtomFeedEntry data AtomFeedEntry = AtomFeedEntry

10
Web/Restful/Response/Sitemap.hs
View File

@ -23,6 +23,8 @@ import Web.Restful.Response
import Web.Encodings import Web.Encodings
import qualified Hack import qualified Hack
import Web.Restful.Request import Web.Restful.Request
import Data.ByteString.Class
import Data.Time (UTCTime)
data SitemapLoc = AbsLoc String | RelLoc String data SitemapLoc = AbsLoc String | RelLoc String
data SitemapChangeFreq = Always data SitemapChangeFreq = Always
@ -79,12 +81,12 @@ instance Show SitemapResponse where
showLoc (AbsLoc s) = s showLoc (AbsLoc s) = s
showLoc (RelLoc s) = prefix ++ s showLoc (RelLoc s) = prefix ++ s
instance Response SitemapResponse where instance HasReps SitemapResponse where
reps res = reps res =
[ ("text/xml", response 200 [] $ show res) [ ("text/xml", toLazyByteString $ show res)
] ]
sitemap :: IO [SitemapUrl] -> SitemapRequest -> IO SitemapResponse sitemap :: IO [SitemapUrl] -> SitemapRequest -> ResponseIO SitemapResponse
sitemap urls' req = do sitemap urls' req = do
urls <- urls' urls <- liftIO urls'
return $ SitemapResponse req urls return $ SitemapResponse req urls

2
restful.cabal
View File

@ -1,5 +1,5 @@
name: restful name: restful
version: 0.1.1 version: 0.1.2
license: BSD3 license: BSD3
license-file: LICENSE license-file: LICENSE
author: Michael Snoyman <michael@snoyman.com> author: Michael Snoyman <michael@snoyman.com>