Massive changes to response and handler stuff

Web/Restful/Application.hs

@@ -23,7 +23,6 @@ module Web.Restful.Application
     ) where
 
 import Web.Encodings
-import qualified Data.ByteString.Lazy as B
 import Data.Object.Raw
 import Data.Enumerable
 import Control.Monad (when)
@@ -58,13 +57,8 @@ class ResourceName a => RestfulApp a where
                 , methodOverride
                 ]
 
-    -- | Wrappers for cleaning up responses. Especially intended for
-    -- beautifying static HTML. FIXME more user friendly.
-    responseWrapper :: a -> String -> B.ByteString -> IO B.ByteString
-    responseWrapper _ _ = return
-
     -- | Output error response pages.
-    errorHandler :: a -> RawRequest -> ErrorResult -> Reps
+    errorHandler :: Monad m => a -> RawRequest -> ErrorResult -> [RepT m] -- FIXME better type sig?
     errorHandler _ rr NotFound = reps $ toRawObject $ "Not found: " ++ show rr
     errorHandler _ _ (Redirect url) =
         reps $ toRawObject $ "Redirect to: " ++ url
@@ -119,21 +113,44 @@ toHackApplication :: RestfulApp resourceName
                   -> (resourceName -> Verb -> Handler)
                   -> Hack.Application
 toHackApplication sampleRN hm env = do
+    -- The following is safe since we run cleanPath as middleware
     let (Right resource) = splitPath $ Hack.pathInfo env
-    let (handler, urlParams', wrapper) =
+    let (handler :: Handler, urlParams') =
           case findResourceNames resource of
-            [] -> (notFound, [], const return)
+            [] -> (notFound, [])
             ((rn, urlParams''):_) ->
                 let verb = toVerb $ Hack.requestMethod env
-                 in (hm rn verb, urlParams'', responseWrapper rn)
+                 in (hm rn verb, urlParams'')
     let rr = envToRawRequest urlParams' env
     let rawHttpAccept = tryLookup "" "Accept" $ Hack.http env
         ctypes' = parseHttpAccept rawHttpAccept
-    runHandler (errorHandler sampleRN rr)
+    r <-
-               wrapper
+        runHandler handler rr ctypes' >>=
-               ctypes'
+        either (applyErrorHandler sampleRN rr ctypes') return
-               handler
+    responseToHackResponse (rawLanguages rr) r
-               rr
+
+applyErrorHandler :: (RestfulApp ra, Monad m)
+                  => ra
+                  -> RawRequest
+                  -> [ContentType]
+                  -> ErrorResult
+                  -> m Response
+applyErrorHandler ra rr cts er = do
+    let (ct, c) = chooseRep cts (errorHandler ra rr er)
+    c' <- c
+    return $ Response
+                (getStatus er)
+                (getHeaders er)
+                ct
+                c'
+
+responseToHackResponse :: [String] -- ^ language list
+                       -> Response -> IO Hack.Response
+responseToHackResponse ls (Response sc hs ct c) = do
+    hs' <- mapM toPair hs
+    let hs'' = ("Content-Type", ct) : hs'
+    let asLBS = runContent ls c
+    return $ Hack.Response sc hs'' asLBS
 
 envToRawRequest :: [(ParamName, ParamValue)] -> Hack.Env -> RawRequest
 envToRawRequest urlParams' env =
@@ -145,4 +162,5 @@ envToRawRequest urlParams' env =
                        $ Hack.hackInput env
         rawCookie = tryLookup "" "Cookie" $ Hack.http env
         cookies' = decodeCookies rawCookie :: [(String, String)]
-     in RawRequest rawPieces urlParams' gets' posts cookies' files env
+        langs = ["en"] -- FIXME
+     in RawRequest rawPieces urlParams' gets' posts cookies' files env langs

Web/Restful/Handler.hs

@@ -1,7 +1,8 @@
 {-# LANGUAGE ExistentialQuantification #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE TypeSynonymInstances #-} -- FIXME remove
+{-# LANGUAGE FlexibleContexts #-}
 ---------------------------------------------------------
 --
 -- Module        : Web.Restful.Handler
@@ -35,31 +36,78 @@ module Web.Restful.Handler
 import Web.Restful.Request
 import Web.Restful.Response
 
-import Control.Monad.Trans
+import Control.Exception hiding (Handler)
-import Control.Monad.Attempt.Class
-import Control.Monad (liftM, ap)
-import Control.Applicative
 
-import Data.Maybe (fromJust)
+import Control.Monad.Reader
-import qualified Data.ByteString.Lazy as B
+import Control.Monad.Writer
-import qualified Hack
+import Control.Monad.Attempt
-import qualified Control.OldException
+
+import Data.Typeable
 
 ------ Handler monad
-newtype HandlerT m a =
+type HandlerT m =
-    HandlerT (RawRequest -> m (Either ErrorResult a, [Header]))
+    ReaderT RawRequest (
+        WriterT [Header] (
+            AttemptT m
+        )
+    )
 type HandlerIO = HandlerT IO
-type Handler = HandlerIO Reps
+type Handler = HandlerIO [RepT HandlerIO]
+
+instance MonadRequestReader HandlerIO where
+    askRawRequest = ask
+    invalidParam _pt _pn _pe = error "invalidParam"
+    authRequired = error "authRequired"
+instance Exception e => MonadFailure e HandlerIO where
+    failure = error "HandlerIO failure"
 
 class ToHandler a where
     toHandler :: a -> Handler
 
+{- FIXME
 instance (Request r, ToHandler h) => ToHandler (r -> h) where
     toHandler f = parseRequest >>= toHandler . f
+-}
 
 instance ToHandler Handler where
     toHandler = id
 
+{- FIXME
+instance HasReps r HandlerIO => ToHandler (HandlerIO r) where
+    toHandler = fmap reps
+-}
+
+runHandler :: Handler
+           -> RawRequest
+           -> [ContentType]
+           -> IO (Either ErrorResult Response)
+runHandler h rr cts = do
+    let ares = runAttemptT $ runWriterT $ runReaderT (joinHandler cts h) rr
+    ares' <- takeAllExceptions ares
+    return $ attempt (Left . toErrorResult) (Right . toResponse) ares'
+    where
+        takeAllExceptions :: IO (Attempt x) -> IO (Attempt x)
+        takeAllExceptions ioa =
+            Control.Exception.catch ioa (return . Failure)
+        toErrorResult :: Exception e => e -> ErrorResult
+        toErrorResult e =
+            case cast e of
+                Just x -> x
+                Nothing -> InternalError $ show e
+        toResponse :: ((ContentType, Content), [Header]) -> Response
+        toResponse ((ct, c), hs) = Response 200 hs ct c
+
+joinHandler :: Monad m
+            => [ContentType]
+            -> m [RepT m]
+            -> m (ContentType, Content)
+joinHandler cts rs = do
+    rs' <- rs
+    let (ct, c) = chooseRep cts rs'
+    c' <- c
+    return (ct, c')
+
+{-
 runHandler :: (ErrorResult -> Reps)
             -> (ContentType -> B.ByteString -> IO B.ByteString)
             -> [ContentType]
@@ -67,9 +115,6 @@ runHandler :: (ErrorResult -> Reps)
             -> RawRequest
             -> IO Hack.Response
 runHandler eh wrapper ctypesAll (HandlerT inside) rr = do
-    (x, headers') <- Control.OldException.catch
-                        (inside rr)
-                        (\e -> return (Left $ InternalError $ show e, []))
     let extraHeaders =
             case x of
                 Left r -> getHeaders r
@@ -85,67 +130,18 @@ runHandler eh wrapper ctypesAll (HandlerT inside) rr = do
     finalRep <- wrapper ctype $ selectedRep languages
     let headers'' = ("Content-Type", ctype) : headers
     return $! Hack.Response statusCode headers'' finalRep
-
+-}
-chooseRep :: Monad m
-          => Reps
-          -> [ContentType]
-          -> m Rep
-chooseRep rs cs
-  | null rs = fail "All reps must have at least one representation"
-  | 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)
-
-instance Monad m => Applicative (HandlerT m) where
-    pure = return
-    (<*>) = ap
-
-instance Monad m => MonadRequestReader (HandlerT m) where
-    askRawRequest = HandlerT $ \rr -> return (Right rr, [])
-    invalidParam ptype name msg =
-        errorResult $ InvalidArgs [(name ++ " (" ++ show ptype ++ ")", msg)]
-    authRequired = errorResult PermissionDenied
-
-instance Monad m => MonadAttempt (HandlerT m) where
-    failure = errorResult . InternalError . show
-    wrapFailure _ = id -- We don't actually use exception types
 
 ------ Special handlers
-errorResult :: Monad m => ErrorResult -> HandlerT m a
+errorResult :: ErrorResult -> HandlerIO a
-errorResult er = HandlerT (const $ return (Left er, []))
+errorResult = lift . lift . failure -- FIXME more instances in Attempt?
 
 -- | Redirect to the given URL.
-redirect :: Monad m => String -> HandlerT m a
+redirect :: String -> HandlerIO a
 redirect = errorResult . Redirect
 
 -- | Return a 404 not found page. Also denotes no handler available.
-notFound :: Monad m => HandlerT m a
+notFound :: HandlerIO a
 notFound = errorResult NotFound
 
 ------- Headers
@@ -166,4 +162,4 @@ header :: Monad m => String -> String -> HandlerT m ()
 header a = addHeader . Header a
 
 addHeader :: Monad m => Header -> HandlerT m ()
-addHeader h = HandlerT (const $ return (Right (), [h]))
+addHeader = tell . return

Web/Restful/Helpers/Auth.hs

@@ -97,7 +97,7 @@ authOpenidForm = do
     case dest of
         Just dest' -> addCookie 120 "DEST" dest'
         Nothing -> return ()
-    htmlResponse html
+    return $ htmlResponse html
 
 authOpenidForward :: Handler
 authOpenidForward = do
@@ -158,8 +158,8 @@ authCheck :: Handler
 authCheck = do
     ident <- maybeIdentifier
     case ident of
-        Nothing -> objectResponse [("status", "notloggedin")]
+        Nothing -> return $ objectResponse [("status", "notloggedin")]
-        Just i -> objectResponse
+        Just i -> return $ objectResponse
             [ ("status", "loggedin")
             , ("ident", i)
             ]
@@ -167,4 +167,4 @@ authCheck = do
 authLogout :: Handler
 authLogout = do
     deleteCookie authCookieName
-    objectResponse [("status", "loggedout")]
+    return $ objectResponse [("status", "loggedout")]

Web/Restful/Helpers/Static.hs

@@ -46,7 +46,7 @@ getStatic fl = do
     content <- liftIO $ fl fp
     case content of
         Nothing -> notFound
-        Just bs -> genResponse (mimeType $ ext fp) bs
+        Just bs -> return $ genResponse (mimeType $ ext fp) bs
 
 mimeType :: String -> String
 mimeType "jpg" = "image/jpeg"

Web/Restful/Request.hs

@@ -55,6 +55,7 @@ import Control.Applicative (Applicative (..))
 import Web.Encodings
 import Data.Time.Calendar (Day, fromGregorian)
 import Data.Char (isDigit)
+import Data.Object.Translate (Language)
 
 -- $param_overview
 -- In Restful, all of the underlying parameter values are strings. They can
@@ -232,6 +233,7 @@ data RawRequest = RawRequest
     , rawCookies :: [(ParamName, ParamValue)]
     , rawFiles :: [(ParamName, FileInfo)]
     , rawEnv :: Hack.Env
+    , rawLanguages :: [Language]
     }
     deriving Show
 

Web/Restful/Response.hs

@@ -1,6 +1,8 @@
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE TypeSynonymInstances #-} -- FIXME remove
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE DeriveDataTypeable #-}
 ---------------------------------------------------------
 --
 -- Module        : Web.Restful.Response
@@ -15,11 +17,18 @@
 --
 ---------------------------------------------------------
 module Web.Restful.Response
-    ( -- * Representations
+    ( Response (..)
-      Rep
+      -- * Representations
-    , Reps
+    , RepT
+    , chooseRep
     , HasReps (..)
     , ContentType
+      -- * Content
+    , Content
+    , ToContent (..)
+    , runContent
+    , lbsContent
+    , translateContent
       -- * Abnormal responses
     , ErrorResult (..)
     , getHeaders
@@ -28,16 +37,11 @@ module Web.Restful.Response
     , Header (..)
     , toPair
       -- * Generic responses
-    , response
     , genResponse
     , htmlResponse
     , objectResponse
       -- * Tests
     , testSuite
-      -- * Translation
-    , TranslatorBS
-    , noTranslate
-    , translateBS
     ) where
 
 import Data.Time.Clock
@@ -45,33 +49,72 @@ import Data.Object
 import Data.Object.Raw
 import Data.Object.Translate
 import Data.Object.Instances
-import Data.ByteString.Lazy (ByteString)
+import qualified Data.ByteString.Lazy as LBS
 import Data.ByteString.Class
+import qualified Data.Text.Lazy as LT
+import qualified Data.Text.Lazy.Encoding as LTE
 
 import Web.Encodings (formatW3)
 
 import Test.Framework (testGroup, Test)
 
+import Data.Generics
+import Control.Exception (Exception)
+import Data.Maybe (fromJust)
+
+data Response = Response Int [Header] ContentType Content
+
 type ContentType = String
 
-type TranslatorBS = [Language] -> ByteString
+data Content = ByteString LBS.ByteString
-noTranslate :: LazyByteString lbs => lbs -> TranslatorBS
+             | Text LT.Text
-noTranslate lbs = const $ toLazyByteString lbs
+             | TransText ([Language] -> LT.Text)
 
-translateBS :: CanTranslate t => t -> TranslatorBS
+runContent :: [Language] -> Content -> LBS.ByteString
-translateBS t langs = toLazyByteString $ translate t langs
+runContent _ (ByteString lbs) = lbs
+runContent _ (Text lt) = LTE.encodeUtf8 lt
+runContent ls (TransText t) = LTE.encodeUtf8 $ t ls
 
-type Rep = (ContentType, TranslatorBS)
+class ToContent a where
-type Reps = [Rep]
+    toContent :: a -> Content
+instance ToContent LBS.ByteString where
+    toContent = ByteString
+instance ToContent String where
+    toContent = Text . LT.pack
+instance ToContent ([Language] -> String) where
+    toContent f = TransText $ LT.pack . f
+instance ToContent Translator where
+    toContent = TransText
+
+lbsContent :: LazyByteString lbs => lbs -> Content
+lbsContent = ByteString . toLazyByteString
+
+translateContent :: CanTranslate t => t -> Content
+translateContent t = toContent $ translate t
+
+type RepT m = (ContentType, m Content)
+
+chooseRep :: Monad m
+          => [ContentType]
+          -> [RepT m]
+          -> RepT m
+chooseRep cs rs
+  | null rs = error "All reps must have at least one representation" -- FIXME
+  | otherwise = do
+    let availCs = map fst rs
+    case filter (`elem` availCs) cs of
+        [] -> head rs
+        [ctype] -> (ctype, fromJust $ lookup ctype rs) -- FIXME
+        _ -> error "Overlapping representations" -- FIXME just take the first?
 
 -- | Something which can be represented as multiple content types.
 -- Each content type is called a representation of the data.
-class HasReps a where
+class Monad m => HasReps a m 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 -> Reps
+    reps :: a -> [RepT m]
 
 -- | Abnormal return codes.
 data ErrorResult =
@@ -80,6 +123,8 @@ data ErrorResult =
     | InternalError String
     | InvalidArgs [(String, String)]
     | PermissionDenied
+    deriving (Show, Typeable)
+instance Exception ErrorResult
 
 getStatus :: ErrorResult -> Int
 getStatus (Redirect _) = 303
@@ -112,37 +157,36 @@ toPair (DeleteCookie key) = return
 toPair (Header key value) = return (key, value)
 
 ------ Generic responses
--- | Lifts a 'HasReps' into a monad.
+-- FIXME move these to Handler?
-response :: (Monad m, HasReps reps) => reps -> m Reps
-response = return . reps
-
 -- | Return a response with an arbitrary content type.
 genResponse :: (Monad m, LazyByteString lbs)
             => ContentType
             -> lbs
-            -> m Reps
+            -> [RepT m]
-genResponse ct lbs = return [(ct, noTranslate lbs)]
+genResponse ct lbs = [(ct, return $ lbsContent lbs)]
 
 -- | Return a response with a text/html content type.
-htmlResponse :: (Monad m, LazyByteString lbs) => lbs -> m Reps
+htmlResponse :: (Monad m, LazyByteString lbs) => lbs -> [RepT m]
 htmlResponse = genResponse "text/html"
 
--- | Return a response from an Object.
+-- | Return a response from an Object. FIXME use TextObject
-objectResponse :: (Monad m, ToObject o Raw Raw) => o -> m Reps
+objectResponse :: (Monad m, ToObject o Raw Raw) => o -> [RepT m]
-objectResponse o = return $ reps $ (toObject o :: RawObject)
+objectResponse = reps . toRawObject
 
 -- HasReps instances
-instance HasReps () where
+instance Monad m => HasReps () m where
-    reps _ = [("text/plain", noTranslate "")]
+    reps _ = [("text/plain", return $ lbsContent "")]
-instance HasReps RawObject where
+instance Monad m => HasReps RawObject m where -- FIXME TextObject
     reps o =
-        [ ("text/html", noTranslate $ unHtml $ safeFromObject o)
+        [ ("text/html", return $ lbsContent $ unHtml $ safeFromObject o)
-        , ("application/json", noTranslate $ unJson $ safeFromObject o)
+        , ("application/json", return $ lbsContent $ unJson $ safeFromObject o)
-        , ("text/yaml", noTranslate $ unYaml $ safeFromObject o)
+        , ("text/yaml", return $ lbsContent $ unYaml $ safeFromObject o)
         ]
 
-instance HasReps Reps where
+{- FIXME
+instance HasReps (Reps m) where
     reps = id
+-}
 
 ----- Testing
 testSuite :: Test

Web/Restful/Response/AtomFeed.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
 ---------------------------------------------------------
 --
 -- Module        : Web.Restful.Response.AtomFeed
@@ -29,9 +31,9 @@ data AtomFeed = AtomFeed
     , atomUpdated :: UTCTime
     , atomEntries :: [AtomFeedEntry]
     }
-instance HasReps AtomFeed where
+instance Monad m => HasReps AtomFeed m where
     reps e =
-        [ ("application/atom+xml", noTranslate $ show e)
+        [ ("application/atom+xml", return $ toContent $ show e)
         ]
 
 data AtomFeedEntry = AtomFeedEntry

Web/Restful/Response/Sitemap.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
 ---------------------------------------------------------
 --
 -- Module        : Web.Restful.Response.AtomFeed
@@ -77,9 +79,9 @@ instance Show SitemapResponse where
             showLoc (AbsLoc s) = s
             showLoc (RelLoc s) = prefix ++ s
 
-instance HasReps SitemapResponse where
+instance Monad m => HasReps SitemapResponse m where
     reps res =
-        [ ("text/xml", noTranslate $ show res)
+        [ ("text/xml", return $ toContent $ show res)
         ]
 
 sitemap :: IO [SitemapUrl] -> Handler
@@ -93,4 +95,4 @@ sitemap urls' = do
 robots :: Handler
 robots = do
     ar <- approot
-    genResponse "text/plain" $ "Sitemap: " ++ ar ++ "sitemap.xml"
+    return $ genResponse "text/plain" $ "Sitemap: " ++ ar ++ "sitemap.xml"

restful.cabal

@@ -1,5 +1,5 @@
 name:            restful
-version:         0.1.9
+version:         0.1.10
 license:         BSD3
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>
@@ -22,7 +22,7 @@ library
                      hack-handler-cgi >= 0.0.2,
                      hack >= 2009.5.19,
                      split >= 0.1.1,
-                     authenticate >= 0.2.0,
+                     authenticate >= 0.2.1,
                      data-default >= 0.2,
                      predicates >= 0.1,
                      bytestring >= 0.9.1.4,
@@ -40,7 +40,9 @@ library
                      directory >= 1,
                      transformers >= 0.1.4.0,
                      monads-fd >= 0.0.0.1,
-                     attempt
+                     attempt,
+                     syb,
+                     text >= 0.5
     exposed-modules: Web.Restful,
                      Web.Restful.Constants,
                      Web.Restful.Request,