Completely replaced Handler type

Data/Object/Html.hs

@@ -112,6 +112,9 @@ instance ConvertSuccess HtmlObject JsonObject where
 instance ConvertSuccess HtmlObject JsonDoc where
     convertSuccess = cs . (cs :: HtmlObject -> JsonObject)
 
+instance ToObject Html String Html where
+    toObject = Scalar
+
 instance ToSElem HtmlObject where
     toSElem (Scalar h) = STR $ TL.unpack $ cs h
     toSElem (Sequence hs) = LI $ map toSElem hs

Yesod/Application.hs

@@ -25,6 +25,7 @@ module Yesod.Application
 import Web.Encodings
 import Data.Enumerable
 import Control.Monad (when)
+import Data.Object.Html
 
 import qualified Hack
 import Hack.Middleware.CleanPath
@@ -40,6 +41,7 @@ import Yesod.Handler
 import Yesod.Definitions
 import Yesod.Constants
 import Yesod.Resource
+import Yesod.Rep
 
 import Data.Convertible.Text
 import Control.Arrow ((***))
@@ -60,7 +62,7 @@ class ResourceName a => RestfulApp a where
                 ]
 
     -- | Output error response pages.
-    errorHandler :: Monad m => a -> RawRequest -> ErrorResult -> [RepT m] -- FIXME better type sig?
+    errorHandler :: a -> RawRequest -> ErrorResult -> HtmlObject -- FIXME better type sig?
 
     -- | Whether or not we should check for overlapping resource names.
     checkOverlaps :: a -> Bool
@@ -100,12 +102,12 @@ takeJusts (Just x:rest) = x : takeJusts rest
 
 toHackApplication :: RestfulApp resourceName
                   => resourceName
-                  -> (resourceName -> Verb -> Handler)
+                  -> (resourceName -> Verb -> Handler [(ContentType, Content)])
                   -> 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 :: Handler, urlParams') =
+    let (handler, urlParams') =
           case findResourceNames resource of
             [] -> (notFound, [])
             ((rn, urlParams''):_) ->
@@ -113,7 +115,7 @@ toHackApplication sampleRN hm env = do
                  in (hm rn verb, urlParams'')
     let rr = envToRawRequest urlParams' env
     let rawHttpAccept = tryLookup "" "Accept" $ Hack.http env
-        ctypes' = parseHttpAccept rawHttpAccept
+        ctypes' = map TypeOther $ parseHttpAccept rawHttpAccept
     r <-
         runHandler handler rr ctypes' >>=
         either (applyErrorHandler sampleRN rr ctypes') return
@@ -126,20 +128,19 @@ applyErrorHandler :: (RestfulApp ra, Monad m)
                   -> (ErrorResult, [Header])
                   -> m Response
 applyErrorHandler ra rr cts (er, headers) = do
-    let (ct, c) = chooseRep cts (errorHandler ra rr er)
+    let (ct, c) = chooseRep (errorHandler ra rr er) cts
-    c' <- c
     return $ Response
                 (getStatus er)
                 (getHeaders er ++ headers)
                 ct
-                c'
+                c
 
 responseToHackResponse :: [String] -- ^ language list
                        -> Response -> IO Hack.Response
-responseToHackResponse ls (Response sc hs ct c) = do
+responseToHackResponse _FIXMEls (Response sc hs ct c) = do
     hs' <- mapM toPair hs
-    let hs'' = ("Content-Type", ct) : hs'
+    let hs'' = ("Content-Type", show ct) : hs'
-    let asLBS = runContent ls c
+    let asLBS = unContent c
     return $ Hack.Response sc hs'' asLBS
 
 envToRawRequest :: [(ParamName, ParamValue)] -> Hack.Env -> RawRequest

Yesod/Handler.hs

@@ -18,13 +18,10 @@
 ---------------------------------------------------------
 module Yesod.Handler
     ( -- * Handler monad
-      HandlerT
+      Handler
-    , HandlerT' -- FIXME
-    , HandlerIO
-    , Handler
     , runHandler
     , liftIO
-    , ToHandler (..)
+    --, ToHandler (..)
       -- * Special handlers
     , redirect
     , notFound
@@ -36,54 +33,76 @@ module Yesod.Handler
 
 import Yesod.Request
 import Yesod.Response
+import Yesod.Rep
 
 import Control.Exception hiding (Handler)
+import Control.Applicative
 
-import Control.Monad.Reader
 import Control.Monad.Writer
 import Control.Monad.Attempt
 
-import Data.Typeable
+--import Data.Typeable
 
 ------ Handler monad
-type HandlerT m =
+newtype Handler a = Handler {
-    ReaderT RawRequest (
+    unHandler :: RawRequest -> IO ([Header], HandlerContents a)
-        AttemptT (
+}
-            WriterT [Header] m
+data HandlerContents a =
-        )
+    forall e. Exception e => HCError e
-    )
+    | HCSpecial ErrorResult
-type HandlerIO = HandlerT IO
+    | HCContent a
-type Handler = HandlerIO [RepT HandlerIO]
-type HandlerT' m a =
-    ReaderT RawRequest (
-        AttemptT (
-            WriterT [Header] m
-        )
-    ) a
 
--- FIXME shouldn't call error here...
+instance Functor Handler where
-instance MonadRequestReader HandlerIO where
+    fmap = liftM
-    askRawRequest = ask
+instance Applicative Handler where
+    pure = return
+    (<*>) = ap
+instance Monad Handler where
+    fail = failureString -- We want to catch all exceptions anyway
+    return x = Handler $ \_ -> return ([], HCContent x)
+    (Handler handler) >>= f = Handler $ \rr -> do
+        (headers, c) <- handler rr
+        (headers', c') <-
+            case c of
+                (HCError e) -> return $ ([], HCError e)
+                (HCSpecial e) -> return $ ([], HCSpecial e)
+                (HCContent a) -> unHandler (f a) rr
+        return (headers ++ headers', c')
+instance MonadIO Handler where
+    liftIO i = Handler $ \_ -> i >>= \i' -> return ([], HCContent i')
+instance Exception e => Failure e Handler where
+    failure e = Handler $ \_ -> return ([], HCError e)
+instance MonadRequestReader Handler where
+    askRawRequest = Handler $ \rr -> return ([], HCContent rr)
     invalidParam _pt _pn _pe = error "invalidParam"
     authRequired = error "authRequired"
-instance Exception e => Failure e HandlerIO where
-    failure = error "HandlerIO failure"
 
+-- FIXME this is a stupid signature
+runHandler :: HasReps a
+           => Handler a
+           -> RawRequest
+           -> [ContentType]
+           -> IO (Either (ErrorResult, [Header]) Response)
+runHandler (Handler handler) rr cts = do
+    (headers, contents) <- handler rr
+    case contents of
+        HCError e -> return $ Left (InternalError $ show e, headers)
+        HCSpecial e -> return $ Left (e, headers)
+        HCContent a ->
+            let (ct, c) = chooseRep a cts
+             in return $ Right $ Response 200 headers ct c
+{- FIXME
 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
@@ -124,6 +143,7 @@ joinHandler cts rs = do
     let (ct, c) = chooseRep cts rs'
     c' <- c
     return (ct, c')
+-}
 
 {-
 runHandler :: (ErrorResult -> Reps)
@@ -151,33 +171,32 @@ runHandler eh wrapper ctypesAll (HandlerT inside) rr = do
 -}
 
 ------ Special handlers
-errorResult :: ErrorResult -> HandlerIO a
+errorResult :: ErrorResult -> Handler a
-errorResult = lift . failure -- FIXME more instances in Attempt?
+errorResult er = Handler $ \_ -> return ([], HCSpecial er)
 
 -- | Redirect to the given URL.
-redirect :: String -> HandlerIO a
+redirect :: String -> Handler a
 redirect = errorResult . Redirect
 
 -- | Return a 404 not found page. Also denotes no handler available.
-notFound :: HandlerIO a
+notFound :: Handler a
 notFound = errorResult NotFound
 
 ------- Headers
 -- | Set the cookie on the client.
-addCookie :: Monad m
+addCookie :: Int -- ^ minutes to timeout
-          => Int -- ^ minutes to timeout
           -> String -- ^ key
           -> String -- ^ value
-          -> HandlerT m ()
+          -> Handler ()
 addCookie a b = addHeader . AddCookie a b
 
 -- | Unset the cookie on the client.
-deleteCookie :: Monad m => String -> HandlerT m ()
+deleteCookie :: String -> Handler ()
 deleteCookie = addHeader . DeleteCookie
 
 -- | Set an arbitrary header on the client.
-header :: Monad m => String -> String -> HandlerT m ()
+header :: String -> String -> Handler ()
 header a = addHeader . Header a
 
-addHeader :: Monad m => Header -> HandlerT m ()
+addHeader :: Header -> Handler ()
-addHeader = lift . lift . tell . return
+addHeader h = Handler $ \_ -> return ([h], HCContent ())

Yesod/Helpers/AtomFeed.hs

@@ -19,7 +19,8 @@ module Yesod.Helpers.AtomFeed
     , AtomFeedEntry (..)
     ) where
 
-import Yesod.Response
+import Yesod.Rep
+import Data.Convertible.Text (cs)
 
 import Data.Time.Clock
 import Web.Encodings
@@ -31,9 +32,9 @@ data AtomFeed = AtomFeed
     , atomUpdated :: UTCTime
     , atomEntries :: [AtomFeedEntry]
     }
-instance Monad m => HasReps AtomFeed m where
+instance HasReps AtomFeed where
-    reps e =
+    reps =
-        [ ("application/atom+xml", return $ toContent $ show e)
+        [ (TypeAtom, cs . show)
         ]
 
 data AtomFeedEntry = AtomFeedEntry

Yesod/Helpers/Auth.hs

@@ -26,6 +26,9 @@ import qualified Web.Authenticate.Rpxnow as Rpxnow
 import qualified Web.Authenticate.OpenId as OpenId
 import Data.Enumerable
 
+import Data.Object.Html
+import Data.Convertible.Text (cs)
+
 import Yesod
 import Yesod.Constants
 
@@ -57,7 +60,7 @@ instance Enumerable AuthResource where
 
 newtype RpxnowApiKey = RpxnowApiKey String
 
-authHandler :: Maybe RpxnowApiKey -> AuthResource -> Verb -> Handler
+authHandler :: Maybe RpxnowApiKey -> AuthResource -> Verb -> Handler HtmlObject
 authHandler _ Check Get = authCheck
 authHandler _ Logout Get = authLogout
 authHandler _ Openid Get = authOpenidForm
@@ -85,7 +88,7 @@ instance Show OIDFormReq where
     show (OIDFormReq (Just s) _) = "<p class='message'>" ++ encodeHtml s ++
                                  "</p>"
 
-authOpenidForm :: Handler
+authOpenidForm :: Handler HtmlObject
 authOpenidForm = do
     m@(OIDFormReq _ dest) <- parseRequest
     let html =
@@ -97,9 +100,9 @@ authOpenidForm = do
     case dest of
         Just dest' -> addCookie 120 "DEST" dest'
         Nothing -> return ()
-    return $ htmlResponse html
+    return $ toHtmlObject $ Html $ cs html
 
-authOpenidForward :: Handler
+authOpenidForward :: Handler HtmlObject
 authOpenidForward = do
     oid <- getParam "openid"
     env <- parseEnv
@@ -112,7 +115,7 @@ authOpenidForward = do
       redirect
       res
 
-authOpenidComplete :: Handler
+authOpenidComplete :: Handler HtmlObject
 authOpenidComplete = do
     gets' <- rawGetParams <$> askRawRequest
     dest <- cookieParam "DEST"
@@ -138,7 +141,7 @@ chopHash ('#':rest) = rest
 chopHash x = x
 
 rpxnowLogin :: String -- ^ api key
-            -> Handler
+            -> Handler HtmlObject
 rpxnowLogin apiKey = do
     token <- anyParam "token"
     postDest <- postParam "dest"
@@ -154,24 +157,17 @@ rpxnowLogin apiKey = do
     header authCookieName $ Rpxnow.identifier ident
     redirect dest
 
-authCheck :: Handler
+authCheck :: Handler HtmlObject
-authCheck = error "authCheck"
-
-authLogout :: Handler
-authLogout = error "authLogout"
-{- FIXME
-authCheck :: Handler
 authCheck = do
     ident <- maybeIdentifier
     case ident of
-        Nothing -> return $ objectResponse [("status", "notloggedin")]
+        Nothing -> return $ toHtmlObject [("status", "notloggedin")]
-        Just i -> return $ objectResponse
+        Just i -> return $ toHtmlObject
             [ ("status", "loggedin")
             , ("ident", i)
             ]
 
-authLogout :: Handler
+authLogout :: Handler HtmlObject
 authLogout = do
     deleteCookie authCookieName
-    return $ objectResponse [("status", "loggedout")]
+    return $ toHtmlObject [("status", "loggedout")]
--}

Yesod/Helpers/Sitemap.hs

@@ -24,11 +24,12 @@ module Yesod.Helpers.Sitemap
 
 import Yesod.Definitions
 import Yesod.Handler
-import Yesod.Response
+import Yesod.Rep
 import Web.Encodings
 import qualified Hack
 import Yesod.Request
 import Data.Time (UTCTime)
+import Data.Convertible.Text (cs)
 
 data SitemapLoc = AbsLoc String | RelLoc String
 data SitemapChangeFreq = Always
@@ -55,7 +56,7 @@ data SitemapUrl = SitemapUrl
     }
 data SitemapRequest = SitemapRequest String Int
 data SitemapResponse = SitemapResponse SitemapRequest [SitemapUrl]
-instance Show SitemapResponse where
+instance Show SitemapResponse where -- FIXME very ugly, use Text instead
     show (SitemapResponse (SitemapRequest host port) urls) =
         "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n" ++
         "<urlset xmlns=\"http://www.sitemaps.org/schemas/sitemap/0.9\">" ++
@@ -80,19 +81,19 @@ instance Show SitemapResponse where
             showLoc (AbsLoc s) = s
             showLoc (RelLoc s) = prefix ++ s
 
-instance Monad m => HasReps SitemapResponse m where
+instance HasReps SitemapResponse where
-    reps res =
+    reps =
-        [ ("text/xml", return $ toContent $ show res)
+        [ (TypeXml, cs . show)
         ]
 
-sitemap :: IO [SitemapUrl] -> Handler
+sitemap :: IO [SitemapUrl] -> Handler SitemapResponse
 sitemap urls' = do
     env <- parseEnv
     -- FIXME
     let req = SitemapRequest (Hack.serverName env) (Hack.serverPort env)
     urls <- liftIO urls'
-    return $ reps $ SitemapResponse req urls
+    return $ SitemapResponse req urls
 
-robots :: Approot -> Handler
+robots :: Approot -> Handler Plain
 robots (Approot ar) = do
-    return $ genResponse "text/plain" $ "Sitemap: " ++ ar ++ "sitemap.xml"
+    return $ plain $ "Sitemap: " ++ ar ++ "sitemap.xml"

Yesod/Helpers/Static.hs

@@ -22,11 +22,12 @@ module Yesod.Helpers.Static
     , fileLookupDir
     ) where
 
-import qualified Data.ByteString as B
+import qualified Data.ByteString.Lazy as B
 import System.Directory (doesFileExist)
 import Control.Applicative ((<$>))
 
 import Yesod
+import Yesod.Rep
 
 type FileLookup = FilePath -> IO (Maybe B.ByteString)
 
@@ -39,30 +40,30 @@ fileLookupDir dir fp = do
         then Just <$> B.readFile fp'
         else return Nothing
 
-serveStatic :: FileLookup -> Verb -> Handler
+serveStatic :: FileLookup -> Verb -> Handler [(ContentType, Content)]
 serveStatic fl Get = getStatic fl
 serveStatic _ _ = notFound
 
-getStatic :: FileLookup -> Handler
+getStatic :: FileLookup -> Handler [(ContentType, Content)]
 getStatic fl = do
     fp <- urlParam "filepath" -- FIXME check for ..
     content <- liftIO $ fl fp
     case content of
         Nothing -> notFound
-        Just bs -> return [(mimeType $ ext fp, return $ toContent bs)]
+        Just bs -> return [(mimeType $ ext fp, Content bs)]
 
-mimeType :: String -> String
+mimeType :: String -> ContentType
-mimeType "jpg" = "image/jpeg"
+mimeType "jpg" = TypeJpeg
-mimeType "jpeg" = "image/jpeg"
+mimeType "jpeg" = TypeJpeg
-mimeType "js" = "text/javascript"
+mimeType "js" = TypeJavascript
-mimeType "css" = "text/css"
+mimeType "css" = TypeCss
-mimeType "html" = "text/html"
+mimeType "html" = TypeHtml
-mimeType "png" = "image/png"
+mimeType "png" = TypePng
-mimeType "gif" = "image/gif"
+mimeType "gif" = TypeGif
-mimeType "txt" = "text/plain"
+mimeType "txt" = TypePlain
-mimeType "flv" = "video/x-flv"
+mimeType "flv" = TypeFlv
-mimeType "ogv" = "video/ogg"
+mimeType "ogv" = TypeOgv
-mimeType _ = "application/octet-stream"
+mimeType _ = TypeOctet
 
 ext :: String -> String
 ext = reverse . fst . break (== '.') . reverse

Yesod/Rep.hs

@@ -1,6 +1,8 @@
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE TypeSynonymInstances #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
 -- | Representations of data. A representation is basically how you display
 -- information in a certain mime-type. For example, tree-style data can easily
 -- be displayed as both JSON and Yaml.
@@ -26,12 +28,15 @@
 module Yesod.Rep
     (
       ContentType (..)
-    , Content
+    , Content (..)
     , Rep
     , Reps
     , HasReps (..)
     , chooseRep
     -- FIXME TemplateFile or some such...
+      -- * Specific types of representations
+    , Plain (..)
+    , plain
 #if TEST
     , testSuite
 #endif
@@ -58,21 +63,46 @@ import Test.HUnit hiding (Test)
 
 data ContentType =
     TypeHtml
+    | TypePlain
     | TypeJson
+    | TypeXml
+    | TypeAtom
+    | TypeJpeg
+    | TypePng
+    | TypeGif
+    | TypeJavascript
+    | TypeCss
+    | TypeFlv
+    | TypeOgv
+    | TypeOctet
     | TypeOther String
-    deriving Eq
 instance Show ContentType where
     show TypeHtml = "text/html"
+    show TypePlain = "text/plain"
     show TypeJson = "application/json"
+    show TypeXml = "text/xml"
+    show TypeAtom = "application/atom+xml"
+    show TypeJpeg = "image/jpeg"
+    show TypePng = "image/png"
+    show TypeGif = "image/gif"
+    show TypeJavascript = "text/javascript"
+    show TypeCss = "text/css"
+    show TypeFlv = "video/x-flv"
+    show TypeOgv = "video/ogg"
+    show TypeOctet = "application/octet-stream"
     show (TypeOther s) = s
+instance Eq ContentType where
+    x == y = show x == show y
 
-newtype Content = Content ByteString
+newtype Content = Content { unContent :: ByteString }
     deriving (Eq, Show)
 
 instance ConvertSuccess Text Content where
     convertSuccess = Content . cs
 instance ConvertSuccess ByteString Content where
     convertSuccess = Content
+instance ConvertSuccess String Content where
+    convertSuccess = Content . cs
 
 type Rep a = (ContentType, a -> Content)
 type Reps a = [Rep a]
@@ -81,25 +111,32 @@ type Reps a = [Rep a]
 -- one representation for each type.
 class HasReps a where
     reps :: Reps a
+instance HasReps [(ContentType, Content)] where
+    reps = [(TypeOther "FIXME", const $ Content $ cs "FIXME")]
 
-chooseRep :: (Applicative f, HasReps a)
+-- FIXME done badly, needs cleanup
-          => f a
+chooseRep :: HasReps a
+          => a
           -> [ContentType]
-          -> f (ContentType, Content)
+          -> (ContentType, Content)
-chooseRep fa ts =
+chooseRep a ts =
     let choices = rs' ++ rs
-        helper2 (ct, f) =
+        helper2 (ct, f) = (ct, f a)
-            let fbs = f `fmap` fa
-             in pure (\bs -> (ct, bs)) <*> fbs
      in if null rs
             then error "Invalid empty reps"
-            else helper2 (head choices)
+            else helper2 $ head choices
     where
         rs = reps
         rs' = filter (\r -> fst r `elem` ts) rs
         -- for type signature stuff
         _ignored = pure (undefined :: Content) `asTypeOf`
-                   (snd (head rs) `fmap` fa)
+                   (snd (head rs) )
+
+newtype Plain = Plain Text
+    deriving (Eq, Show)
+
+plain :: ConvertSuccess x Text => x -> Plain
+plain = Plain . cs
 
 -- Useful instances of HasReps
 instance HasReps HtmlObject where
@@ -112,13 +149,13 @@ instance HasReps HtmlObject where
 caseChooseRep :: Assertion
 caseChooseRep = do
     let content = "IGNOREME"
-        a = Just $ toHtmlObject content
+        a = toHtmlObject content
         htmlbs = Content . cs . unHtmlDoc . cs $ toHtmlObject content
         jsonbs = Content . cs $ "\"" ++ content ++ "\""
-    chooseRep a [TypeHtml] @?= Just (TypeHtml, htmlbs)
+    chooseRep a [TypeHtml] @?= (TypeHtml, htmlbs)
-    chooseRep a [TypeJson] @?= Just (TypeJson, jsonbs)
+    chooseRep a [TypeJson] @?= (TypeJson, jsonbs)
-    chooseRep a [TypeHtml, TypeJson] @?= Just (TypeHtml, htmlbs)
+    chooseRep a [TypeHtml, TypeJson] @?= (TypeHtml, htmlbs)
-    chooseRep a [TypeOther "foo", TypeJson] @?= Just (TypeJson, jsonbs)
+    chooseRep a [TypeOther "foo", TypeJson] @?= (TypeJson, jsonbs)
 
 testSuite :: Test
 testSuite = testGroup "Yesod.Rep"

Yesod/Resource.hs

@@ -36,6 +36,12 @@ import Data.List (intercalate)
 import Data.Enumerable
 import Data.Char (isDigit)
 
+#if TEST
+import Yesod.Rep hiding (testSuite)
+#else
+import Yesod.Rep
+#endif
+
 #if TEST
 import Control.Monad (replicateM, when)
 import Test.Framework (testGroup, Test)
@@ -86,7 +92,7 @@ class (Show a, Enumerable a) => ResourceName a where
     resourcePattern :: a -> String
 
     -- | Find the handler for each resource name/verb pattern.
-    getHandler :: a -> Verb -> Handler
+    getHandler :: a -> Verb -> Handler [(ContentType, Content)] -- FIXME
 
 type SMap = [(String, String)]
 

Yesod/Response.hs

@@ -19,15 +19,6 @@
 ---------------------------------------------------------
 module Yesod.Response
     ( Response (..)
-      -- * Representations
-    , RepT
-    , chooseRep
-    , HasReps (..)
-    , ContentType
-      -- * Content
-    , Content
-    , ToContent (..)
-    , runContent
       -- * Abnormal responses
     , ErrorResult (..)
     , getHeaders
@@ -35,21 +26,19 @@ module Yesod.Response
       -- * Header
     , Header (..)
     , toPair
-      -- * Generic responses
-    , genResponse
-    , htmlResponse
 #if TEST
       -- * Tests
     , testSuite
 #endif
     ) where
 
-import Yesod.Definitions
+#if TEST
+import Yesod.Rep hiding (testSuite)
+#else
+import Yesod.Rep
+#endif
+
 import Data.Time.Clock
-import qualified Data.ByteString as SBS
-import qualified Data.ByteString.Lazy as LBS
-import qualified Data.Text as ST
-import qualified Data.Text.Lazy as LT
 
 import Web.Encodings (formatW3)
 
@@ -59,62 +48,9 @@ import Test.Framework (testGroup, Test)
 
 import Data.Generics
 import Control.Exception (Exception)
-import Data.Maybe (fromJust)
-import Data.Convertible.Text
-
-import Data.Text.Lazy (Text)
 
 data Response = Response Int [Header] ContentType Content
 
-type ContentType = String
-
--- | FIXME: Lazy in theory is better, but kills actual programs
-data Content = ByteString SBS.ByteString
-             | Text ST.Text
-             | TransText ([Language] -> ST.Text)
-
-runContent :: [Language] -> Content -> LBS.ByteString
-runContent _ (ByteString sbs) = convertSuccess sbs
-runContent _ (Text lt) = convertSuccess lt
-runContent ls (TransText t) = convertSuccess $ t ls
-
-class ToContent a where
-    toContent :: a -> Content
-instance ToContent SBS.ByteString where
-    toContent = ByteString
-instance ToContent LBS.ByteString where
-    toContent = ByteString . convertSuccess
-instance ToContent String where
-    toContent = Text . convertSuccess
-instance ToContent Text where
-    toContent = Text . convertSuccess
-instance ToContent ([Language] -> String) where
-    toContent f = TransText $ convertSuccess . f
-
-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 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 -> [RepT m]
-
 -- | Abnormal return codes.
 data ErrorResult =
     Redirect String
@@ -155,19 +91,6 @@ toPair (DeleteCookie key) = return
      key ++ "=; path=/; expires=Thu, 01-Jan-1970 00:00:00 GMT")
 toPair (Header key value) = return (key, value)
 
------- Generic responses
--- FIXME move these to Handler?
--- | Return a response with an arbitrary content type.
-genResponse :: (Monad m, ToContent t)
-            => ContentType
-            -> t
-            -> [RepT m]
-genResponse ct t = [(ct, return $ toContent t)]
-
--- | Return a response with a text/html content type.
-htmlResponse :: (Monad m, ToContent t) => t -> [RepT m]
-htmlResponse = genResponse "text/html"
-
 #if TEST
 ----- Testing
 testSuite :: Test

Yesod/Yesod.hs

@@ -7,7 +7,7 @@ module Yesod.Yesod
 
 import Yesod.Rep
 import Data.Object.Html (toHtmlObject)
-import Yesod.Response hiding (reps, ContentType, Content, chooseRep)
+import Yesod.Response
 import Yesod.Request
 import Yesod.Constants
 --import Yesod.Definitions
@@ -43,7 +43,7 @@ class Yesod a where
                 ]
 
     -- | Output error response pages.
-    errorHandler :: a -> RawRequest -> ErrorResult -> [ContentType] -> MyIdentity (ContentType, Content) -- FIXME better type sig?
+    errorHandler :: a -> RawRequest -> ErrorResult -> [ContentType] -> (ContentType, Content) -- FIXME better type sig?
     errorHandler = defaultErrorHandler
     -- | Whether or not we should check for overlapping resource names.
     checkOverlaps :: a -> Bool
@@ -60,20 +60,20 @@ defaultErrorHandler :: a
                     -> RawRequest
                     -> ErrorResult
                     -> [ContentType]
-                    -> MyIdentity (ContentType, Content)
+                    -> (ContentType, Content)
-defaultErrorHandler _ rr NotFound = chooseRep $ pure . toHtmlObject $
+defaultErrorHandler _ rr NotFound = chooseRep $ toHtmlObject $
                                    "Not found: " ++ show rr
 defaultErrorHandler _ _ (Redirect url) =
-        chooseRep $ pure . toHtmlObject $ "Redirect to: " ++ url
+        chooseRep $ toHtmlObject $ "Redirect to: " ++ url
 defaultErrorHandler _ _ (InternalError e) =
-        chooseRep $ pure . toHtmlObject $ "Internal server error: " ++ e
+        chooseRep $ toHtmlObject $ "Internal server error: " ++ e
 defaultErrorHandler _ _ (InvalidArgs ia) =
-        chooseRep $ pure $ toHtmlObject
+        chooseRep $ toHtmlObject
             [ ("errorMsg", toHtmlObject "Invalid arguments")
             , ("messages", toHtmlObject ia)
             ]
 defaultErrorHandler _ _ PermissionDenied =
-        chooseRep $ pure $ toHtmlObject "Permission denied"
+        chooseRep $ toHtmlObject "Permission denied"
 
 toHackApp :: Yesod y => y -> Hack.Application
 toHackApp a env = do