Massive revamp of responses; not yet fully functional

2009-09-18 04:14:52 +03:00 · 2009-09-18 04:14:52 +03:00 · 86ca811ac5
commit 86ca811ac5
parent c3c4d647d3
10 changed files with 266 additions and 243 deletions
--- 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 "<!DOCTYPE html>\n<html><body>"
+        [ toLazyByteString "<!DOCTYPE html>\n<html><body>" -- FIXME full doc or just fragment?
        , helper o
-        , toStrictByteString "</body></html>"
+        , toLazyByteString "</body></html>"
        ] where
            helper :: Object -> B.ByteString
            helper (Scalar s) = B.concat
-                [ toStrictByteString "<p>"
-                , s
-                , toStrictByteString "</p>"
+                [ toLazyByteString "<p>"
+                , toLazyByteString s
+                , toLazyByteString "</p>"
                ]
-            helper (Sequence []) = toStrictByteString "<ul></ul>"
+            helper (Sequence []) = toLazyByteString "<ul></ul>"
            helper (Sequence s) = B.concat
-                [ toStrictByteString "<ul><li>"
-                , B.intercalate (toStrictByteString "</li><li>") $ map helper s
-                , toStrictByteString "</li></ul>"
+                [ toLazyByteString "<ul><li>"
+                , B.intercalate (toLazyByteString "</li><li>") $ map helper s
+                , toLazyByteString "</li></ul>"
                ]
            helper (Mapping m) = B.concat $
-                toStrictByteString "<dl>" :
+                toLazyByteString "<dl>" :
                map helper2 m ++
-                [ toStrictByteString "</dl>" ]
-            helper2 :: (B.ByteString, Object) -> B.ByteString
+                [ toLazyByteString "</dl>" ]
+            helper2 :: (BS.ByteString, Object) -> B.ByteString
            helper2 (k, v) = B.concat $
-                [ toStrictByteString "<dt>"
-                , k
-                , toStrictByteString "</dt><dd>"
+                [ toLazyByteString "<dt>"
+                , toLazyByteString k
+                , toLazyByteString "</dt><dd>"
                , helper v
-                , toStrictByteString "</dd>"
+                , toLazyByteString "</dd>"
                ]
--- 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
--- 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)
        ]
--- 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
--- 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) _) = "<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) =
+
+authOpenidForm :: OIDFormReq -> ResponseIO GenResponse
+authOpenidForm m@(OIDFormReq _ dest) = do
    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
+    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")]
--- 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

--- 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 = "<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)]
+        ("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) =
-    "<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 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)
--- 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
--- 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
--- 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 <michael@snoyman.com>