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