Completely replaced Handler type

2009-12-13 01:38:20 +02:00 · 2009-12-13 01:38:20 +02:00 · 77dc6ed78b
commit 77dc6ed78b
parent 002f6ef788
11 changed files with 195 additions and 207 deletions
--- a/Data/Object/Html.hs
+++ b/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
--- a/Yesod/Application.hs
+++ b/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)
-    c' <- c
+    let (ct, c) = chooseRep (errorHandler ra rr er) cts
    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 asLBS = runContent ls c
+    let hs'' = ("Content-Type", show ct) : hs'
+    let asLBS = unContent c
    return $ Hack.Response sc hs'' asLBS

 envToRawRequest :: [(ParamName, ParamValue)] -> Hack.Env -> RawRequest
--- a/Yesod/Handler.hs
+++ b/Yesod/Handler.hs
@ -18,13 +18,10 @@
 ---------------------------------------------------------
 module Yesod.Handler
    ( -- * Handler monad
-      HandlerT
-    , HandlerT' -- FIXME
-    , HandlerIO
-    , Handler
+      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 =
-    ReaderT RawRequest (
-        AttemptT (
-            WriterT [Header] m
-        )
-    )
-type HandlerIO = HandlerT IO
-type Handler = HandlerIO [RepT HandlerIO]
-type HandlerT' m a =
-    ReaderT RawRequest (
-        AttemptT (
-            WriterT [Header] m
-        )
-    ) a
+newtype Handler a = Handler {
+    unHandler :: RawRequest -> IO ([Header], HandlerContents a)
+}
+data HandlerContents a =
+    forall e. Exception e => HCError e
+    | HCSpecial ErrorResult
+    | HCContent a

-- FIXME shouldn't call error here...
-instance MonadRequestReader HandlerIO where
-    askRawRequest = ask
+instance Functor Handler where
+    fmap = liftM
+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 = lift . failure -- FIXME more instances in Attempt?
+errorResult :: ErrorResult -> Handler a
+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
-          => Int -- ^ minutes to timeout
+addCookie :: 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 = lift . lift . tell . return
+addHeader :: Header -> Handler ()
+addHeader h = Handler $ \_ -> return ([h], HCContent ())
--- a/Yesod/Helpers/AtomFeed.hs
+++ b/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
-    reps e =
-        [ ("application/atom+xml", return $ toContent $ show e)
+instance HasReps AtomFeed where
+    reps =
+        [ (TypeAtom, cs . show)
        ]

 data AtomFeedEntry = AtomFeedEntry
--- a/Yesod/Helpers/Auth.hs
+++ b/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 = error "authCheck"
-
-authLogout :: Handler
-authLogout = error "authLogout"
-{- FIXME
-authCheck :: Handler
+authCheck :: Handler HtmlObject
 authCheck = do
    ident <- maybeIdentifier
    case ident of
-        Nothing -> return $ objectResponse [("status", "notloggedin")]
-        Just i -> return $ objectResponse
+        Nothing -> return $ toHtmlObject [("status", "notloggedin")]
+        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")]
--- a/Yesod/Helpers/Sitemap.hs
+++ b/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
-    reps res =
-        [ ("text/xml", return $ toContent $ show res)
+instance HasReps SitemapResponse where
+    reps =
+        [ (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"
--- a/Yesod/Helpers/Static.hs
+++ b/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 "jpg" = "image/jpeg"
-mimeType "jpeg" = "image/jpeg"
-mimeType "js" = "text/javascript"
-mimeType "css" = "text/css"
-mimeType "html" = "text/html"
-mimeType "png" = "image/png"
-mimeType "gif" = "image/gif"
-mimeType "txt" = "text/plain"
-mimeType "flv" = "video/x-flv"
-mimeType "ogv" = "video/ogg"
-mimeType _ = "application/octet-stream"
+mimeType :: String -> ContentType
+mimeType "jpg" = TypeJpeg
+mimeType "jpeg" = TypeJpeg
+mimeType "js" = TypeJavascript
+mimeType "css" = TypeCss
+mimeType "html" = TypeHtml
+mimeType "png" = TypePng
+mimeType "gif" = TypeGif
+mimeType "txt" = TypePlain
+mimeType "flv" = TypeFlv
+mimeType "ogv" = TypeOgv
+mimeType _ = TypeOctet

 ext :: String -> String
 ext = reverse . fst . break (== '.') . reverse
--- a/Yesod/Rep.hs
+++ b/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)
-          => f a
+-- FIXME done badly, needs cleanup
+chooseRep :: HasReps a
+          => a
          -> [ContentType]
-          -> f (ContentType, Content)
-chooseRep fa ts =
+          -> (ContentType, Content)
+chooseRep a ts =
    let choices = rs' ++ rs
-        helper2 (ct, f) =
-            let fbs = f `fmap` fa
-             in pure (\bs -> (ct, bs)) <*> fbs
+        helper2 (ct, f) = (ct, f a)
     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 [TypeJson] @?= Just (TypeJson, jsonbs)
-    chooseRep a [TypeHtml, TypeJson] @?= Just (TypeHtml, htmlbs)
-    chooseRep a [TypeOther "foo", TypeJson] @?= Just (TypeJson, jsonbs)
+    chooseRep a [TypeHtml] @?= (TypeHtml, htmlbs)
+    chooseRep a [TypeJson] @?= (TypeJson, jsonbs)
+    chooseRep a [TypeHtml, TypeJson] @?= (TypeHtml, htmlbs)
+    chooseRep a [TypeOther "foo", TypeJson] @?= (TypeJson, jsonbs)

 testSuite :: Test
 testSuite = testGroup "Yesod.Rep"
--- a/Yesod/Resource.hs
+++ b/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)]

--- a/Yesod/Response.hs
+++ b/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
--- a/Yesod/Yesod.hs
+++ b/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)
-defaultErrorHandler _ rr NotFound = chooseRep $ pure . toHtmlObject $
+                    -> (ContentType, Content)
+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