Refactored and documented Response and Handler

Web/Restful/Application.hs

@@ -65,14 +65,14 @@ class ResourceName a b => RestfulApp a b | a -> b where
     responseWrapper _ _ = return
 
     -- | Output error response pages.
-    errorHandler :: a -> RawRequest -> ErrorResult -> HasRepsW
+    errorHandler :: a -> RawRequest -> ErrorResult -> Reps
-    errorHandler _ rr NotFound = HasRepsW $ toObject $ "Not found: " ++ show rr
+    errorHandler _ rr NotFound = reps $ toObject $ "Not found: " ++ show rr
     errorHandler _ _ (Redirect url) =
-        HasRepsW $ toObject $ "Redirect to: " ++ url
+        reps $ toObject $ "Redirect to: " ++ url
     errorHandler _ _ (InternalError e) =
-        HasRepsW $ toObject $ "Internal server error: " ++ e
+        reps $ toObject $ "Internal server error: " ++ e
     errorHandler _ _ (InvalidArgs ia) =
-        HasRepsW $ toObject $
+        reps $ toObject $
             [ ("errorMsg", toObject "Invalid arguments")
             , ("messages", toObject ia)
             ]
@@ -118,7 +118,7 @@ toHackApplication sampleRN hm env = do
     let (Right resource) = splitPath $ Hack.pathInfo env
     let (handler, urlParams') =
           case findResourceNames resource of
-            [] -> (noHandler, [])
+            [] -> (notFound, [])
             [(rn, urlParams'')] ->
                 let verb = toVerb $ Hack.requestMethod env
                  in (hm rn verb, urlParams'')
@@ -126,7 +126,7 @@ toHackApplication sampleRN hm env = do
     let rr = envToRawRequest urlParams' env
     let rawHttpAccept = tryLookup "" "Accept" $ Hack.http env
         ctypes' = parseHttpAccept rawHttpAccept
-    runResponse (errorHandler sampleRN rr)
+    runHandler (errorHandler sampleRN rr)
                 (responseWrapper sampleRN)
                 ctypes'
                 handler

Web/Restful/Handler.hs

@@ -1,6 +1,8 @@
 {-# LANGUAGE ExistentialQuantification #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TypeSynonymInstances #-}
 ---------------------------------------------------------
 --
 -- Module        : Web.Restful.Handler
@@ -15,22 +17,133 @@
 --
 ---------------------------------------------------------
 module Web.Restful.Handler
-    ( Handler
+    ( -- * Handler monad
-    , liftHandler
+      HandlerT
-    , noHandler
+    , HandlerIO
+    , Handler
+    , runHandler
+    , getRequest
+    , liftIO
+      -- * Special handlers
+    , redirect
+    , notFound
+      -- * Setting headers
+    , addCookie
+    , deleteCookie
+    , header
     ) where
 
 import Web.Restful.Request
 import Web.Restful.Response
 
-type Handler = Response -- FIXME maybe move some stuff around now...
+import Control.Monad.Trans
+import Control.Monad (liftM)
 
-liftHandler :: (Request req, HasReps rep)
+import Data.Maybe (fromJust)
-            => (req -> ResponseIO rep)
+import qualified Data.ByteString.Lazy as B
+import qualified Hack
+
+------ Handler monad
+newtype HandlerT m a =
+    HandlerT (RawRequest -> m (Either ErrorResult a, [Header]))
+type HandlerIO = HandlerT IO
+type Handler = HandlerIO Reps
+
+runHandler :: (ErrorResult -> Reps)
+            -> (ContentType -> B.ByteString -> IO B.ByteString)
+            -> [ContentType]
             -> Handler
-liftHandler f = do
+            -> RawRequest
-    req <- getRequest
+            -> IO Hack.Response
-    wrapResponse $ f req
+runHandler eh wrapper ctypesAll (HandlerT inside) rr = do
+    (x, headers') <- inside rr
+    let extraHeaders =
+            case x of
+                Left r -> getHeaders r
+                Right _ -> []
+    headers <- mapM toPair (headers' ++ extraHeaders)
+    let outReps = either (reps . eh) reps x
+    let statusCode =
+            case x of
+                Left r -> getStatus r
+                Right _ -> 200
+    (ctype, selectedRep) <- chooseRep outReps ctypesAll
+    finalRep <- wrapper ctype selectedRep
+    let headers'' = ("Content-Type", ctype) : headers
+    return $! Hack.Response statusCode headers'' finalRep
 
-noHandler :: Handler
+chooseRep :: Monad m
-noHandler = notFound
+          => [(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"
+
+instance MonadTrans HandlerT where
+    lift ma = HandlerT $ const $ do
+        a <- ma
+        return (Right a, [])
+
+instance MonadIO HandlerIO where
+    liftIO = lift
+
+instance Monad m => Functor (HandlerT m) where
+    fmap = liftM
+
+instance Monad m => Monad (HandlerT m) where
+    return = lift . return
+    fail s = HandlerT (const $ return (Left $ InternalError s, []))
+    (HandlerT mx) >>= f = HandlerT $ \rr -> do
+        (x, hs1) <- mx rr
+        case x of
+            Left x' -> return (Left x', hs1)
+            Right a -> do
+                let (HandlerT b') = f a
+                (b, hs2) <- b' rr
+                return (b, hs1 ++ hs2)
+
+-- | Parse a request in the Handler monad. On failure, return a 400 error.
+getRequest :: (Monad m, Request r) => HandlerT m r
+getRequest = HandlerT $ \rr -> return (helper rr, []) where
+    helper :: Request r
+           => RawRequest
+           -> Either ErrorResult r
+    helper rr =
+        case runRequestParser parseRequest rr of
+            Left errors -> Left $ InvalidArgs errors
+            Right r -> Right r
+
+------ Special handlers
+-- | Redirect to the given URL.
+redirect :: Monad m => String -> HandlerT m a
+redirect s = HandlerT (const $ return (Left $ Redirect s, []))
+
+-- | Return a 404 not found page. Also denotes no handler available.
+notFound :: Monad m => HandlerT m a
+notFound = HandlerT (const $ return (Left NotFound, []))
+
+------- Headers
+-- | Set the cookie on the client.
+addCookie :: Monad m
+          => Int -- ^ minutes to timeout
+          -> String -- ^ key
+          -> String -- ^ value
+          -> HandlerT m ()
+addCookie a b c = addHeader $ AddCookie a b c
+
+-- | Unset the cookie on the client.
+deleteCookie :: Monad m => String -> HandlerT m ()
+deleteCookie = addHeader . DeleteCookie
+
+-- | Set an arbitrary header on the client.
+header :: Monad m => String -> String -> HandlerT m ()
+header a b = addHeader $ Header a b
+
+addHeader :: Monad m => Header -> HandlerT m ()
+addHeader h = HandlerT (const $ return (Right (), [h]))

Web/Restful/Helpers/Auth.hs

@@ -28,7 +28,6 @@ import Web.Restful.Constants
 import Control.Applicative ((<$>), Applicative (..))
 import Control.Monad.Reader
 
-import Data.Object
 import Data.Maybe (fromMaybe)
 
 data AuthResource =
@@ -42,13 +41,13 @@ data AuthResource =
 
 type RpxnowApiKey = String -- FIXME newtype
 instance ResourceName AuthResource (Maybe RpxnowApiKey) where
-    getHandler _ Check Get = liftHandler authCheck
+    getHandler _ Check Get = authCheck
-    getHandler _ Logout Get = liftHandler authLogout
+    getHandler _ Logout Get = authLogout
-    getHandler _ Openid Get = liftHandler authOpenidForm
+    getHandler _ Openid Get = authOpenidForm
-    getHandler _ OpenidForward Get = liftHandler authOpenidForward
+    getHandler _ OpenidForward Get = authOpenidForward
-    getHandler _ OpenidComplete Get = liftHandler authOpenidComplete
+    getHandler _ OpenidComplete Get = authOpenidComplete
-    getHandler (Just key) LoginRpxnow Get = liftHandler $ rpxnowLogin key
+    getHandler (Just key) LoginRpxnow Get = rpxnowLogin key
-    getHandler _ _ _ = noHandler
+    getHandler _ _ _ = notFound
 
     allValues =
         Check
@@ -75,8 +74,9 @@ instance Show OIDFormReq where
     show (OIDFormReq (Just s) _) = "<p class='message'>" ++ encodeHtml s ++
                                  "</p>"
 
-authOpenidForm :: OIDFormReq -> ResponseIO GenResponse
+authOpenidForm :: Handler
-authOpenidForm m@(OIDFormReq _ dest) = do
+authOpenidForm = do
+    m@(OIDFormReq _ dest) <- getRequest
     let html =
             show m ++
             "<form method='get' action='forward/'>" ++
@@ -86,7 +86,7 @@ authOpenidForm m@(OIDFormReq _ dest) = do
     case dest of
         Just dest' -> addCookie 20 "DEST" dest'
         Nothing -> return ()
-    return $! htmlResponse html
+    htmlResponse html
 
 data OIDFReq = OIDFReq String String
 instance Request OIDFReq where
@@ -97,8 +97,9 @@ instance Request OIDFReq where
                        show (Hack.serverPort env) ++
                        "/auth/openid/complete/"
         return $! OIDFReq oid complete
-authOpenidForward :: OIDFReq -> Response
+authOpenidForward :: Handler
-authOpenidForward (OIDFReq oid complete) = do
+authOpenidForward = do
+    OIDFReq oid complete <- getRequest
     res <- liftIO $ OpenId.getForwardUrl oid complete
     case res of
         Left err -> redirect $ "/auth/openid/?message="
@@ -113,8 +114,9 @@ instance Request OIDComp where
         dest <- cookieParam "DEST"
         return $! OIDComp gets dest
 
-authOpenidComplete :: OIDComp -> Response
+authOpenidComplete :: Handler
-authOpenidComplete (OIDComp gets' dest) = do
+authOpenidComplete = do
+    OIDComp gets' dest <- getRequest
     res <- liftIO $ OpenId.authenticate gets'
     case res of
       Left err -> redirect $ "/auth/openid/?message="
@@ -137,9 +139,9 @@ chopHash ('#':rest) = rest
 chopHash x = x
 
 rpxnowLogin :: String -- ^ api key
-            -> RpxnowRequest
+            -> Handler
-            -> Response
+rpxnowLogin apiKey = do
-rpxnowLogin apiKey (RpxnowRequest token dest') = do
+    RpxnowRequest token dest' <- getRequest
     let dest = case dest' of
                 Nothing -> "/"
                 Just "" -> "/"
@@ -154,16 +156,17 @@ data AuthRequest = AuthRequest (Maybe String)
 instance Request AuthRequest where
     parseRequest = AuthRequest `fmap` identifier
 
-authCheck :: AuthRequest -> ResponseIO Object
+authCheck :: Handler
-authCheck (AuthRequest Nothing) =
+authCheck = do
-    return $ toObject [("status", "notloggedin")]
+    req <- getRequest
-authCheck (AuthRequest (Just i)) =
+    case req of
-    return $ toObject
+        AuthRequest Nothing -> objectResponse[("status", "notloggedin")]
-        [ ("status", "loggedin")
+        AuthRequest (Just i) -> objectResponse
-        , ("ident", i)
+            [ ("status", "loggedin")
-        ]
+            , ("ident", i)
+            ]
 
-authLogout :: () -> ResponseIO Object
+authLogout :: Handler
-authLogout _ = do
+authLogout = do
     deleteCookie authCookieName
-    return $ toObject [("status", "loggedout")]
+    objectResponse [("status", "loggedout")]

Web/Restful/Helpers/Static.hs

@@ -25,19 +25,20 @@ import Web.Restful
 type FileLookup = FilePath -> IO (Maybe B.ByteString)
 
 serveStatic :: FileLookup -> Verb -> Handler
-serveStatic fl Get = liftHandler $ getStatic fl
+serveStatic fl Get = getStatic fl
-serveStatic _ _ = noHandler
+serveStatic _ _ = notFound
 
 newtype StaticReq = StaticReq FilePath
 instance Request StaticReq where
     parseRequest = StaticReq `fmap` urlParam "filepath" -- FIXME check for ..
 
-getStatic :: FileLookup -> StaticReq -> ResponseIO GenResponse
+getStatic :: FileLookup -> Handler
-getStatic fl (StaticReq fp) = do
+getStatic fl = do
+    StaticReq fp <- getRequest
     content <- liftIO $ fl fp
     case content of
         Nothing -> notFound
-        Just bs -> return $ byteStringResponse (mimeType $ ext fp) bs
+        Just bs -> genResponse (mimeType $ ext fp) bs
 
 mimeType :: String -> String
 mimeType "jpg" = "image/jpeg"

Web/Restful/Response.hs

@@ -1,6 +1,4 @@
-{-# LANGUAGE ExistentialQuantification #-}
 {-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE TypeSynonymInstances #-}
 ---------------------------------------------------------
 --
 -- Module        : Web.Restful.Response
@@ -15,45 +13,36 @@
 --
 ---------------------------------------------------------
 module Web.Restful.Response
-    ( formatW3
+    ( -- * Representations
+      Reps
     , HasReps (..)
-    , notFound
+    , ContentType
-    , wrapResponse
+      -- * Abnormal responses
-    , ResponseIO
-    , ResponseT
-    , Response
-    , runResponse
-    , deleteCookie
-    , redirect
-    , addCookie
-    , header
-    , GenResponse (..)
-    , liftIO
     , ErrorResult (..)
-    , HasRepsW (..)
+    , getHeaders
-    , byteStringResponse
+    , getStatus
+      -- * Header
+    , Header (..)
+    , toPair
+      -- * Generic responses
+    , response
+    , genResponse
     , htmlResponse
-    , getRequest
+    , objectResponse
     ) where
 
 import Data.ByteString.Class
-import Data.Time.Format
 import Data.Time.Clock
-import System.Locale
 import Data.Object
 import qualified Data.ByteString.Lazy as B
 import Data.Object.Instances
-import Data.Maybe (fromJust)
 
-import Web.Restful.Request
+import Web.Restful.Utils (formatW3)
-
-import Control.Monad.Trans
-import Control.Monad (liftM)
-
-import qualified Hack
 
 type ContentType = String
 
+type Reps = [(ContentType, B.ByteString)]
+
 -- | Something which can be represented as multiple content types.
 -- Each content type is called a representation of the data.
 class HasReps a where
@@ -61,14 +50,9 @@ class HasReps a where
     -- 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, B.ByteString)]
+    reps :: a -> Reps
-
--- | Wrap up any instance of 'HasReps'.
-data HasRepsW = forall a. HasReps a => HasRepsW a
-
-instance HasReps HasRepsW where
-    reps (HasRepsW r) = reps r
 
+-- | Abnormal return codes.
 data ErrorResult =
     Redirect String
     | NotFound
@@ -85,47 +69,14 @@ getHeaders :: ErrorResult -> [Header]
 getHeaders (Redirect s) = [Header "Location" s]
 getHeaders _ = []
 
-newtype ResponseT m a =
+----- header stuff
-    ResponseT (RawRequest -> m (Either ErrorResult a, [Header]))
+-- | Headers to be added to a 'Result'.
-type ResponseIO = ResponseT IO
+data Header =
-type Response = ResponseIO HasRepsW
+    AddCookie Int String String
-
+    | DeleteCookie String
-runResponse :: (ErrorResult -> HasRepsW)
+    | Header String String
-            -> (ContentType -> B.ByteString -> IO B.ByteString)
-            -> [ContentType]
-            -> Response
-            -> RawRequest
-            -> IO Hack.Response
-runResponse eh wrapper ctypesAll (ResponseT inside) rr = do
-    (x, headers') <- inside rr
-    let extraHeaders =
-            case x of
-                Left r -> getHeaders r
-                Right _ -> []
-    headers <- mapM toPair (headers' ++ extraHeaders)
-    let outReps = either (reps . eh) reps x
-    let statusCode =
-            case x of
-                Left r -> getStatus r
-                Right _ -> 200
-    (ctype, selectedRep) <- chooseRep outReps ctypesAll
-    finalRep <- wrapper ctype selectedRep
-    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"
 
+-- | Convert Header to a key/value pair.
 toPair :: Header -> IO (String, String)
 toPair (AddCookie minutes key value) = do
     now <- getCurrentTime
@@ -137,78 +88,29 @@ toPair (DeleteCookie key) = return
      key ++ "=; path=/; expires=Thu, 01-Jan-1970 00:00:00 GMT")
 toPair (Header key value) = return (key, value)
 
-wrapResponse :: (Monad m, HasReps rep)
+------ Generic responses
-             => ResponseT m rep
+-- | Lifts a 'HasReps' into a monad.
-             -> ResponseT m HasRepsW
+response :: (Monad m, HasReps reps) => reps -> m Reps
-wrapResponse = fmap HasRepsW
+response = return . reps
 
-instance MonadTrans ResponseT where
+-- | Return a response with an arbitrary content type.
-    lift ma = ResponseT $ const $ do
+genResponse :: (Monad m, LazyByteString lbs)
-        a <- ma
+            => ContentType
-        return (Right a, [])
+            -> lbs
+            -> m Reps
+genResponse ct lbs = return [(ct, toLazyByteString lbs)]
 
-instance MonadIO ResponseIO where
+-- | Return a response with a text/html content type.
-    liftIO = lift
+htmlResponse :: (Monad m, LazyByteString lbs) => lbs -> m Reps
+htmlResponse = genResponse "text/html"
 
-redirect :: Monad m => String -> ResponseT m a
+-- | Return a response from an Object.
-redirect s = ResponseT (const $ return (Left $ Redirect s, []))
+objectResponse :: (Monad m, ToObject o) => o -> m Reps
-
+objectResponse = return . reps . toObject
-notFound :: Monad m => ResponseT m a
-notFound = ResponseT (const $ return (Left NotFound, []))
-
-instance Monad m => Functor (ResponseT m) where
-    fmap = liftM
-
-instance Monad m => Monad (ResponseT m) where
-    return = lift . return
-    fail s = ResponseT (const $ return (Left $ InternalError s, []))
-    (ResponseT mx) >>= f = ResponseT $ \rr -> do
-        (x, hs1) <- mx rr
-        case x of
-            Left x' -> return (Left x', hs1)
-            Right a -> do
-                let (ResponseT b') = f a
-                (b, hs2) <- b' rr
-                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 (const $ return (Right (), [h]))
 
+-- HasReps instances
 instance HasReps () where
     reps _ = [("text/plain", toLazyByteString "")]
-
-data GenResponse = HtmlResponse B.ByteString
-                 | ObjectResponse Object
-                 | HtmlOrObjectResponse String Object
-                 | ByteStringResponse ContentType B.ByteString
-instance HasReps GenResponse where
-    reps (HtmlResponse h) = [("text/html", toLazyByteString h)]
-    reps (ObjectResponse t) = reps t
-    reps (HtmlOrObjectResponse h t) =
-        ("text/html", toLazyByteString h) : reps t
-    reps (ByteStringResponse ct con) = [(ct, con)]
-
-byteStringResponse :: LazyByteString lbs => ContentType -> lbs -> GenResponse
-byteStringResponse ct = ByteStringResponse ct . toLazyByteString
-
-htmlResponse :: LazyByteString lbs => lbs -> GenResponse
-htmlResponse = HtmlResponse . toLazyByteString
-
 instance HasReps Object where
     reps o =
         [ ("text/html", unHtml $ safeFromObject o)
@@ -218,17 +120,3 @@ instance HasReps Object where
 
 instance HasReps [(ContentType, B.ByteString)] where
     reps = id
-
--- FIXME put in a separate module (maybe Web.Encodings)
-formatW3 :: UTCTime -> String
-formatW3 = formatTime defaultTimeLocale "%FT%X-08:00"
-
-getRequest :: (Monad m, Request r) => ResponseT m r
-getRequest = ResponseT $ \rr -> return (helper rr, []) where
-    helper :: Request r
-           => RawRequest
-           -> Either ErrorResult r
-    helper rr =
-        case runRequestParser parseRequest rr of
-            Left errors -> Left $ InvalidArgs errors -- FIXME better error output
-            Right r -> Right r

Web/Restful/Response/AtomFeed.hs

@@ -18,6 +18,7 @@ module Web.Restful.Response.AtomFeed
     ) where
 
 import Web.Restful.Response
+import Web.Restful.Utils
 
 import Data.Time.Clock
 import Web.Encodings

Web/Restful/Response/Sitemap.hs

@@ -19,7 +19,9 @@ module Web.Restful.Response.Sitemap
     , SitemapChangeFreq (..)
     ) where
 
+import Web.Restful.Handler
 import Web.Restful.Response
+import Web.Restful.Utils
 import Web.Encodings
 import qualified Hack
 import Web.Restful.Request
@@ -86,7 +88,7 @@ instance HasReps SitemapResponse where
         [ ("text/xml", toLazyByteString $ show res)
         ]
 
-sitemap :: IO [SitemapUrl] -> SitemapRequest -> ResponseIO SitemapResponse
+sitemap :: IO [SitemapUrl] -> SitemapRequest -> Handler
 sitemap urls' req = do
     urls <- liftIO urls'
-    return $ SitemapResponse req urls
+    return $ reps $ SitemapResponse req urls

Web/Restful/Utils.hs

@@ -9,15 +9,23 @@
 -- Portability   : portable
 --
 -- Utility functions for Restful.
+-- These are all functions which could be exported to another library.
 --
 ---------------------------------------------------------
 module Web.Restful.Utils
     ( parseHttpAccept
     , tryLookup
+    , formatW3
     ) where
 
 import Data.List.Split (splitOneOf)
+import Data.Maybe (fromMaybe)
 
+import Data.Time.Clock
+import System.Locale
+import Data.Time.Format
+
+-- | Parse the HTTP accept string to determine supported content types.
 parseHttpAccept :: String -> [String]
 parseHttpAccept = filter (not . specialHttpAccept) . splitOneOf ";,"
 
@@ -26,8 +34,10 @@ specialHttpAccept ('q':'=':_) = True
 specialHttpAccept ('*':_) = True
 specialHttpAccept _ = False
 
+-- | Attempt a lookup, returning a default value on failure.
 tryLookup :: Eq k => v -> k -> [(k, v)] -> v
-tryLookup v _ [] = v
+tryLookup def key = fromMaybe def . lookup key
-tryLookup v k ((k', v'):rest)
+
-    | k == k' = v'
+-- | Format a 'UTCTime' in W3 format; useful for setting cookies.
-    | otherwise = tryLookup v k rest
+formatW3 :: UTCTime -> String
+formatW3 = formatTime defaultTimeLocale "%FT%X-08:00" -- FIXME time zone?