diff --git a/Data/Object/Instances.hs b/Data/Object/Instances.hs index 8b3ba8ef..3bb2f241 100644 --- a/Data/Object/Instances.hs +++ b/Data/Object/Instances.hs @@ -20,10 +20,11 @@ module Data.Object.Instances ) where 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 Web.Encodings (encodeJson) -import qualified Text.Yaml as Y +import Text.Yaml (encode) class SafeFromObject a where safeFromObject :: Object -> a @@ -33,31 +34,31 @@ instance SafeFromObject Json where safeFromObject = Json . helper where helper :: Object -> B.ByteString helper (Scalar s) = B.concat - [ toStrictByteString "\"" + [ toLazyByteString "\"" , encodeJson $ fromStrictByteString s - , toStrictByteString "\"" + , toLazyByteString "\"" ] helper (Sequence s) = B.concat - [ toStrictByteString "[" - , B.intercalate (toStrictByteString ",") $ map helper s - , toStrictByteString "]" + [ toLazyByteString "[" + , B.intercalate (toLazyByteString ",") $ map helper s + , toLazyByteString "]" ] helper (Mapping m) = B.concat - [ toStrictByteString "{" - , B.intercalate (toStrictByteString ",") $ map helper2 m - , toStrictByteString "}" + [ toLazyByteString "{" + , B.intercalate (toLazyByteString ",") $ map helper2 m + , toLazyByteString "}" ] - helper2 :: (B.ByteString, Object) -> B.ByteString + helper2 :: (BS.ByteString, Object) -> B.ByteString helper2 (k, v) = B.concat - [ toStrictByteString "\"" + [ toLazyByteString "\"" , encodeJson $ fromStrictByteString k - , toStrictByteString "\":" + , toLazyByteString "\":" , helper v ] newtype Yaml = Yaml { unYaml :: B.ByteString } instance SafeFromObject Yaml where - safeFromObject = Yaml . Y.encode + safeFromObject = Yaml . encode -- | 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 safeFromObject o = Html $ B.concat - [ toStrictByteString "\n" + [ toLazyByteString "\n" -- FIXME full doc or just fragment? , helper o - , toStrictByteString "" + , toLazyByteString "" ] where helper :: Object -> B.ByteString helper (Scalar s) = B.concat - [ toStrictByteString "

" - , s - , toStrictByteString "

" + [ toLazyByteString "

" + , toLazyByteString s + , toLazyByteString "

" ] - helper (Sequence []) = toStrictByteString "" + helper (Sequence []) = toLazyByteString "" helper (Sequence s) = B.concat - [ toStrictByteString "" + [ toLazyByteString "" ] helper (Mapping m) = B.concat $ - toStrictByteString "
" : + toLazyByteString "
" : map helper2 m ++ - [ toStrictByteString "
" ] - helper2 :: (B.ByteString, Object) -> B.ByteString + [ toLazyByteString "
" ] + helper2 :: (BS.ByteString, Object) -> B.ByteString helper2 (k, v) = B.concat $ - [ toStrictByteString "
" - , k - , toStrictByteString "
" + [ toLazyByteString "
" + , toLazyByteString k + , toLazyByteString "
" , helper v - , toStrictByteString "
" + , toLazyByteString "" ] diff --git a/Web/Restful/Application.hs b/Web/Restful/Application.hs index 9236a35e..529910ba 100644 --- a/Web/Restful/Application.hs +++ b/Web/Restful/Application.hs @@ -23,8 +23,6 @@ module Web.Restful.Application ) where import Web.Encodings -import Data.Maybe (isJust) -import Data.Function.Predicate (equals) import Data.ByteString.Class import qualified Data.ByteString.Lazy as B @@ -105,7 +103,7 @@ takeJusts (Just x:rest) = x : takeJusts rest toHackApplication :: RestfulApp resourceName model => resourceName - -> HandlerMap resourceName + -> (resourceName -> Verb -> Handler) -> Hack.Application toHackApplication sampleRN hm env = do let (Right resource) = splitPath $ Hack.pathInfo env @@ -116,31 +114,11 @@ toHackApplication sampleRN hm env = do verb = toVerb $ Hack.requestMethod env rr :: RawRequest rr = envToRawRequest urlParams' env - case hm rn verb of - (Just handler) -> do - let rawHttpAccept = tryLookup "" "Accept" $ Hack.http env - ctypes' = parseHttpAccept rawHttpAccept - body <- runHandler 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 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 + handler :: Handler + handler = hm rn verb + let rawHttpAccept = tryLookup "" "Accept" $ Hack.http env + ctypes' = parseHttpAccept rawHttpAccept + runResponse (handler rr) ctypes' x -> error $ "Invalid matches: " ++ show x envToRawRequest :: [(ParamName, ParamValue)] -> Hack.Env -> RawRequest diff --git a/Web/Restful/Generic/ListDetail.hs b/Web/Restful/Generic/ListDetail.hs index 00d48d57..6c4c45e7 100644 --- a/Web/Restful/Generic/ListDetail.hs +++ b/Web/Restful/Generic/ListDetail.hs @@ -25,7 +25,7 @@ import Data.ByteString.Class class ToObject a => ListDetail a where htmlDetail :: a -> String - htmlDetail = fromStrictByteString . unHtml . safeFromObject . toObject + htmlDetail = fromLazyByteString . unHtml . safeFromObject . toObject detailTitle :: a -> String detailUrl :: a -> String htmlList :: [a] -> String @@ -42,14 +42,14 @@ class ToObject a => ListDetail a where treeListSingle = toObject newtype ItemList a = ItemList [a] -instance ListDetail a => Response (ItemList a) where +instance ListDetail a => HasReps (ItemList a) where reps (ItemList l) = - [ ("text/html", response 200 [] $ htmlList l) - , ("application/json", response 200 [] $ unJson $ safeFromObject $ treeList l) + [ ("text/html", toLazyByteString $ htmlList l) + , ("application/json", unJson $ safeFromObject $ treeList l) ] newtype ItemDetail a = ItemDetail a -instance ListDetail a => Response (ItemDetail a) where +instance ListDetail a => HasReps (ItemDetail a) where reps (ItemDetail i) = - [ ("text/html", response 200 [] $ htmlDetail i) - , ("application/json", response 200 [] $ unJson $ safeFromObject $ toObject i) + [ ("text/html", toLazyByteString $ htmlDetail i) + , ("application/json", unJson $ safeFromObject $ toObject i) ] diff --git a/Web/Restful/Handler.hs b/Web/Restful/Handler.hs index b4a1f1fa..074240b6 100644 --- a/Web/Restful/Handler.hs +++ b/Web/Restful/Handler.hs @@ -15,28 +15,26 @@ -- --------------------------------------------------------- module Web.Restful.Handler - ( Handler (..) - , runHandler - , HandlerMap + ( Handler , liftHandler + , noHandler ) where -import Web.Restful.Definitions import Web.Restful.Request import Web.Restful.Response -data Handler = forall req. Request req => Handler (req -> IO ResponseWrapper) +type Handler = RawRequest -> Response -runHandler :: Handler -> RawRequest -> IO ResponseWrapper -runHandler (Handler f) rreq = do - let rparser = parseRequest - case runRequestParser rparser rreq of +liftHandler :: (Request req, HasReps rep) + => (req -> ResponseIO rep) + -> Handler +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 - Right req -> f req + Right req -> return req -type HandlerMap a = a -> Verb -> Maybe Handler - -liftHandler :: (Request req, Response res) - => (req -> IO res) - -> Maybe Handler -liftHandler f = Just . Handler $ fmap ResponseWrapper . f +noHandler :: Handler +noHandler = const notFound diff --git a/Web/Restful/Helpers/Auth.hs b/Web/Restful/Helpers/Auth.hs index 7d2c2481..7844e2c9 100644 --- a/Web/Restful/Helpers/Auth.hs +++ b/Web/Restful/Helpers/Auth.hs @@ -26,10 +26,10 @@ import Web.Restful import Web.Restful.Constants import Control.Applicative ((<$>), Applicative (..)) -import Control.Arrow (second) import Control.Monad.Reader import Data.Object +import Data.Maybe (fromMaybe) data AuthResource = Check @@ -48,7 +48,7 @@ instance ResourceName AuthResource (Maybe RpxnowApiKey) where getHandler _ OpenidForward Get = liftHandler authOpenidForward getHandler _ OpenidComplete Get = liftHandler authOpenidComplete getHandler (Just key) LoginRpxnow Get = liftHandler $ rpxnowLogin key - getHandler _ _ _ = Nothing + getHandler _ _ _ = noHandler allValues = Check @@ -74,24 +74,20 @@ instance Show OIDFormReq where show (OIDFormReq Nothing _) = "" show (OIDFormReq (Just s) _) = "

" ++ encodeHtml s ++ "

" -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) = + +authOpenidForm :: OIDFormReq -> ResponseIO GenResponse +authOpenidForm m@(OIDFormReq _ dest) = do let html = show m ++ "
" ++ "OpenID: " ++ "" ++ "
" - in return $! OIDFormRes html dest + case dest of + Just dest' -> addCookie 20 "DEST" dest' + Nothing -> return () + return $! HtmlResponse html + data OIDFReq = OIDFReq String String instance Request OIDFReq where parseRequest = do @@ -101,14 +97,13 @@ instance Request OIDFReq where show (Hack.serverPort env) ++ "/auth/openid/complete/" return $! OIDFReq oid complete -authOpenidForward :: OIDFReq -> IO GenResponse +authOpenidForward :: OIDFReq -> Response 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 + res <- liftIO $ OpenId.getForwardUrl oid complete + case res of + Left err -> redirect $ "/auth/openid/?message=" + ++ encodeUrl (err :: String) + Right url -> redirect url data OIDComp = OIDComp [(String, String)] (Maybe String) instance Request OIDComp where @@ -117,35 +112,17 @@ instance Request OIDComp where 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 -> Response 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 + res <- liftIO $ OpenId.authenticate gets' + case res of + Left err -> redirect $ "/auth/openid/?message=" + ++ encodeUrl (err :: String) + Right (OpenId.Identifier ident) -> do + deleteCookie "DEST" + header authCookieName ident + redirect $ fromMaybe "/" dest -- | token dest data RpxnowRequest = RpxnowRequest String (Maybe String) @@ -159,34 +136,25 @@ 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 + -> Response 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') + ident' <- liftIO $ Rpxnow.authenticate apiKey token + case ident' of + Nothing -> return () + Just ident -> header authCookieName $ Rpxnow.identifier ident + redirect dest data AuthRequest = AuthRequest (Maybe String) instance Request AuthRequest where parseRequest = AuthRequest `fmap` identifier -authCheck :: AuthRequest -> IO Object +authCheck :: AuthRequest -> ResponseIO Object authCheck (AuthRequest Nothing) = return $ toObject [("status", "notloggedin")] authCheck (AuthRequest (Just i)) = @@ -195,13 +163,7 @@ authCheck (AuthRequest (Just i)) = , ("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 +authLogout :: () -> ResponseIO Object +authLogout _ = do + deleteCookie authCookieName + return $ toObject [("status", "loggedout")] diff --git a/Web/Restful/Resource.hs b/Web/Restful/Resource.hs index afb1867c..2470c70d 100644 --- a/Web/Restful/Resource.hs +++ b/Web/Restful/Resource.hs @@ -49,7 +49,7 @@ class Show a => ResourceName a b | a -> b where allValues :: [a] -- | 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 diff --git a/Web/Restful/Response.hs b/Web/Restful/Response.hs index 9d5e8221..19db94d4 100644 --- a/Web/Restful/Response.hs +++ b/Web/Restful/Response.hs @@ -1,5 +1,6 @@ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} --------------------------------------------------------- -- -- Module : Web.Restful.Response @@ -14,110 +15,192 @@ -- --------------------------------------------------------- module Web.Restful.Response - ( - -- * Response construction - Response (..) - , response - -- * FIXME + ( formatW3 + , HasReps (..) + , notFound + , wrapResponse + , ResponseIO + , ResponseT + , Response + , runResponse + , deleteCookie + , redirect + , addCookie + , header , GenResponse (..) - , ResponseWrapper (..) - , ErrorResponse (..) - , formatW3 - , UTCTime + , liftIO ) where import Data.ByteString.Class -import qualified Hack import Data.Time.Format import Data.Time.Clock -import Web.Encodings import System.Locale 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 --- | 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 +-- | Something which can be represented as multiple content types. +-- Each content type is called a representation of the data. +class HasReps a where + -- | 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 -- 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 --- used for the body. -response :: LazyByteString lbs - => Int - -> [(String, String)] - -> lbs - -> Hack.Response -response a b c = Hack.Response a b $ toLazyByteString c +-- | Wrap up any instance of 'HasReps'. +data HasRepsW = forall a. HasReps a => HasRepsW a -instance Response () where - reps _ = [("text/plain", response 200 [] "")] +instance HasReps HasRepsW where + reps (HasRepsW r) = reps r -newtype ErrorResponse = ErrorResponse String -instance Response ErrorResponse where - reps (ErrorResponse s) = [("text/plain", response 500 [] s)] +-- | The result of a request. This does not include possible headers. +data Result = + Redirect String + | NotFound + | InternalError String + | Content HasRepsW -data ResponseWrapper = forall res. Response res => ResponseWrapper res -instance Response ResponseWrapper where - reps (ResponseWrapper res) = reps res +instance HasReps Result where + reps (Redirect s) = [("text/plain", toLazyByteString s)] + 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 | ObjectResponse Object | HtmlOrObjectResponse String Object - | RedirectResponse String - | PermissionDeniedResult String - | NotFoundResponse String -instance Response GenResponse where - reps (HtmlResponse h) = [("text/html", response 200 [] h)] +instance HasReps GenResponse where + reps (HtmlResponse h) = [("text/html", toLazyByteString 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 = "

Redirecting to " ++ encodeHtml url ++ "

" - reps (PermissionDeniedResult s) = [("text/plain", response 403 [] s)] - reps (NotFoundResponse s) = [("text/plain", response 404 [] s)] + ("text/html", toLazyByteString h) : reps t --- 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) = - "" -treeToHtml (Mapping m) = - "
" ++ - concatMap (\(k, v) -> "
" ++ - encodeHtml (fromStrictByteString k) ++ - "
" ++ - "
" ++ - treeToHtml v ++ - "
") m ++ - "
" - -instance Response Object where - reps tree = - [ ("text/html", response 200 [] $ treeToHtml tree) - , ("application/json", response 200 [] $ treeToJson tree) +instance HasReps Object where + reps o = + [ ("text/html", unHtml $ safeFromObject o) + , ("application/json", unJson $ safeFromObject o) + , ("text/yaml", unYaml $ safeFromObject o) ] -instance Response [(String, Hack.Response)] where +instance HasReps [(ContentType, B.ByteString)] where reps = id -- FIXME put in a separate module (maybe Web.Encodings) diff --git a/Web/Restful/Response/AtomFeed.hs b/Web/Restful/Response/AtomFeed.hs index c79d9d3b..8f093a49 100644 --- a/Web/Restful/Response/AtomFeed.hs +++ b/Web/Restful/Response/AtomFeed.hs @@ -19,10 +19,9 @@ module Web.Restful.Response.AtomFeed import Web.Restful.Response -import Data.Time.Format import Data.Time.Clock import Web.Encodings -import System.Locale +import Data.ByteString.Class data AtomFeed = AtomFeed { atomTitle :: String @@ -31,9 +30,9 @@ data AtomFeed = AtomFeed , atomUpdated :: UTCTime , atomEntries :: [AtomFeedEntry] } -instance Response AtomFeed where +instance HasReps AtomFeed where reps e = - [ ("application/atom+xml", response 200 [] $ show e) + [ ("application/atom+xml", toLazyByteString $ show e) ] data AtomFeedEntry = AtomFeedEntry diff --git a/Web/Restful/Response/Sitemap.hs b/Web/Restful/Response/Sitemap.hs index 0167a9f5..92f2566a 100644 --- a/Web/Restful/Response/Sitemap.hs +++ b/Web/Restful/Response/Sitemap.hs @@ -23,6 +23,8 @@ import Web.Restful.Response import Web.Encodings import qualified Hack import Web.Restful.Request +import Data.ByteString.Class +import Data.Time (UTCTime) data SitemapLoc = AbsLoc String | RelLoc String data SitemapChangeFreq = Always @@ -79,12 +81,12 @@ instance Show SitemapResponse where showLoc (AbsLoc s) = s showLoc (RelLoc s) = prefix ++ s -instance Response SitemapResponse where +instance HasReps SitemapResponse where 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 - urls <- urls' + urls <- liftIO urls' return $ SitemapResponse req urls diff --git a/restful.cabal b/restful.cabal index 4c28e492..a2f3f781 100644 --- a/restful.cabal +++ b/restful.cabal @@ -1,5 +1,5 @@ name: restful -version: 0.1.1 +version: 0.1.2 license: BSD3 license-file: LICENSE author: Michael Snoyman