diff --git a/Data/Object/Html.hs b/Data/Object/Html.hs
index beb8e67e..8c289da7 100644
--- 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
diff --git a/Yesod/Application.hs b/Yesod/Application.hs
index 7a562893..aa97a4f7 100644
--- 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
diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs
index 2d9233cc..ee0d456d 100644
--- 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 ())
diff --git a/Yesod/Helpers/AtomFeed.hs b/Yesod/Helpers/AtomFeed.hs
index 77a35bc4..9a4ffaba 100644
--- 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
diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs
index 47523fc5..e722e21b 100644
--- 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) _) = "
" ++ encodeHtml s ++
"
"
-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")]
diff --git a/Yesod/Helpers/Sitemap.hs b/Yesod/Helpers/Sitemap.hs
index 410cde5c..16a65721 100644
--- 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) =
"\n" ++
"" ++
@@ -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"
diff --git a/Yesod/Helpers/Static.hs b/Yesod/Helpers/Static.hs
index dd3d3066..0d198353 100644
--- 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
diff --git a/Yesod/Rep.hs b/Yesod/Rep.hs
index 926825e1..1ce9a195 100644
--- 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"
diff --git a/Yesod/Resource.hs b/Yesod/Resource.hs
index 05a90be7..3e29f387 100644
--- 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)]
diff --git a/Yesod/Response.hs b/Yesod/Response.hs
index 069f6e26..f4232ead 100644
--- 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
diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs
index 9cecddeb..9580d2ce 100644
--- 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