From 26ad604a19f0e2b478bdf945061f44ea90fac638 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Fri, 23 Apr 2010 11:03:36 -0700 Subject: [PATCH] Began major refactoring of code --- Yesod/Dispatch.hs | 92 ++++++++++++++++++++++++++++++--- Yesod/Hamlet.hs | 33 +++++++----- Yesod/Handler.hs | 26 +++++++--- Yesod/Helpers/Auth.hs | 16 +++--- Yesod/Request.hs | 117 +++++++++++++----------------------------- Yesod/Response.hs | 112 +++++++++------------------------------- 6 files changed, 192 insertions(+), 204 deletions(-) diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs index 8078d42f..6fcd0822 100644 --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -32,15 +32,34 @@ import System.Environment (getEnvironment) import qualified Data.ByteString.Char8 as B import Data.Maybe (fromMaybe) -import Web.Encodings (parseHttpAccept) +import Web.Encodings import Web.Mime import Data.List (intercalate) import Web.Routes (encodePathInfo, decodePathInfo) -mkYesod :: String -> [Resource] -> Q [Dec] +import Control.Concurrent.MVar +import Control.Arrow ((***)) +import Data.Convertible.Text (cs) + +import Data.Time.Clock + +-- | Generates URL datatype and site function for the given 'Resource's. This +-- is used for creating sites, *not* subsites. See 'mkYesodSub' for the latter. +-- Use 'parseRoutes' in generate to create the 'Resource's. +mkYesod :: String -- ^ name of the argument datatype + -> [Resource] + -> Q [Dec] mkYesod name = mkYesodGeneral name [] False -mkYesodSub :: String -> [Name] -> [Resource] -> Q [Dec] +-- | Generates URL datatype and site function for the given 'Resource's. This +-- is used for creating subsites, *not* sites. See 'mkYesod' for the latter. +-- Use 'parseRoutes' in generate to create the 'Resource's. In general, a +-- subsite is not executable by itself, but instead provides functionality to +-- be embedded in other sites. +mkYesodSub :: String -- ^ name of the argument datatype + -> [Name] -- ^ a list of classes the master datatype must be an instance of + -> [Resource] + -> Q [Dec] mkYesodSub name clazzes = mkYesodGeneral name clazzes True explodeHandler :: HasReps c @@ -74,6 +93,8 @@ mkYesodGeneral name clazzes isSub res = do } return $ (if isSub then id else (:) yes) [w, x, y, z] +-- | Convert the given argument into a WAI application, executable with any WAI +-- handler. You can use 'basicHandler' if you wish. toWaiApp :: Yesod y => y -> IO W.Application toWaiApp a = do key' <- encryptKey a @@ -82,7 +103,7 @@ toWaiApp a = do $ jsonp $ methodOverride $ cleanPath - $ \thePath -> clientsession encryptedCookies key' mins + $ \thePath -> clientsession encryptedCookies key' mins -- FIXME allow user input for encryptedCookies $ toWaiApp' a thePath toWaiApp' :: Yesod y @@ -91,7 +112,7 @@ toWaiApp' :: Yesod y -> [(B.ByteString, B.ByteString)] -> W.Request -> IO W.Response -toWaiApp' y resource session env = do +toWaiApp' y resource session' env = do let site = getSite method = B.unpack $ W.methodToBS $ W.requestMethod env types = httpAccept env @@ -99,7 +120,7 @@ toWaiApp' y resource session env = do eurl = quasiParse site pathSegments render u = approot y ++ '/' : encodePathInfo (fixSegs $ quasiRender site u) - rr <- parseWaiRequest env session + rr <- parseWaiRequest env session' onRequest y rr print pathSegments -- FIXME remove let ya = case eurl of @@ -153,3 +174,62 @@ fixSegs [x] | any (== '.') x = [x] | otherwise = [x, ""] -- append trailing slash fixSegs (x:xs) = x : fixSegs xs + +parseWaiRequest :: W.Request + -> [(B.ByteString, B.ByteString)] -- ^ session + -> IO Request +parseWaiRequest env session' = do + let gets' = map (cs *** cs) $ decodeUrlPairs $ W.queryString env + let reqCookie = fromMaybe B.empty $ lookup W.Cookie $ W.requestHeaders env + cookies' = map (cs *** cs) $ parseCookies reqCookie + acceptLang = lookup W.AcceptLanguage $ W.requestHeaders env + langs = map cs $ maybe [] parseHttpAccept acceptLang + langs' = case lookup langKey cookies' of + Nothing -> langs + Just x -> x : langs + langs'' = case lookup langKey gets' of + Nothing -> langs' + Just x -> x : langs' + session'' = map (cs *** cs) session' + rbthunk <- iothunk $ rbHelper env + return $ Request gets' cookies' session'' rbthunk env langs'' + +rbHelper :: W.Request -> IO RequestBodyContents +rbHelper = fmap (fix1 *** map fix2) . parseRequestBody lbsSink where + fix1 = map (cs *** cs) + fix2 (x, FileInfo a b c) = (cs x, FileInfo (cs a) (cs b) c) + +-- | Produces a \"compute on demand\" value. The computation will be run once +-- it is requested, and then the result will be stored. This will happen only +-- once. +iothunk :: IO a -> IO (IO a) +iothunk = fmap go . newMVar . Left where + go :: MVar (Either (IO a) a) -> IO a + go mvar = modifyMVar mvar go' + go' :: Either (IO a) a -> IO (Either (IO a) a, a) + go' (Right val) = return (Right val, val) + go' (Left comp) = do + val <- comp + return (Right val, val) + +responseToWaiResponse :: (W.Status, [Header], ContentType, Content) + -> IO W.Response +responseToWaiResponse (sc, hs, ct, c) = do + hs' <- mapM headerToPair hs + let hs'' = (W.ContentType, cs $ contentTypeToString ct) : hs' + return $ W.Response sc hs'' $ case c of + ContentFile fp -> Left fp + ContentEnum e -> Right $ W.Enumerator e + +-- | Convert Header to a key/value pair. +headerToPair :: Header -> IO (W.ResponseHeader, B.ByteString) +headerToPair (AddCookie minutes key value) = do + now <- getCurrentTime + let expires = addUTCTime (fromIntegral $ minutes * 60) now + return (W.SetCookie, cs $ key ++ "=" ++ value ++"; path=/; expires=" + ++ formatW3 expires) +headerToPair (DeleteCookie key) = return + (W.SetCookie, cs $ + key ++ "=; path=/; expires=Thu, 01-Jan-1970 00:00:00 GMT") +headerToPair (Header key value) = + return (W.responseHeaderFromBS $ cs key, cs value) diff --git a/Yesod/Hamlet.hs b/Yesod/Hamlet.hs index 343b664e..ab185393 100644 --- a/Yesod/Hamlet.hs +++ b/Yesod/Hamlet.hs @@ -1,15 +1,20 @@ {-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE QuasiQuotes #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Yesod.Hamlet - ( hamletToContent - , hamletToRepHtml - , PageContent (..) - , Hamlet + ( -- * Hamlet library + Hamlet , hamlet , HtmlContent (..) + -- * Convert to something displayable + , hamletToContent + , hamletToRepHtml + -- * Page templates + , PageContent (..) + -- * data-object , HtmlObject ) where @@ -22,12 +27,19 @@ import Data.Convertible.Text import Data.Object import Control.Arrow ((***)) +-- | Content for a web page. By providing this datatype, we can easily create +-- generic site templates, which would have the type signature: +-- +-- > PageContent url -> Hamlet url IO () data PageContent url = PageContent { pageTitle :: HtmlContent , pageHead :: Hamlet url IO () , pageBody :: Hamlet url IO () } +-- FIXME some typeclasses for the stuff below? +-- | Converts the given Hamlet template into 'Content', which can be used in a +-- Yesod 'Response'. hamletToContent :: Hamlet (Routes sub) IO () -> GHandler sub master Content hamletToContent h = do render <- getUrlRender @@ -40,16 +52,9 @@ hamletToContent h = do Right ((), x) -> return $ Right x iter' iter seed text = iter seed $ cs text -hamletToRepHtml :: Hamlet (Routes y) IO () -> Handler y RepHtml -hamletToRepHtml h = do - c <- hamletToContent h - return $ RepHtml c - --- FIXME some type of JSON combined output... ---hamletToRepHtmlJson :: x --- -> (x -> Hamlet (Routes y) IO ()) --- -> (x -> Json) --- -> Handler y RepHtmlJson +-- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'. +hamletToRepHtml :: Hamlet (Routes sub) IO () -> GHandler sub master RepHtml +hamletToRepHtml = fmap RepHtml . hamletToContent instance Monad m => ConvertSuccess String (Hamlet url m ()) where convertSuccess = outputHtml . Unencoded . cs diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs index a6b38aa8..8bc3fce9 100644 --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -78,7 +78,7 @@ newtype YesodApp = YesodApp :: (ErrorResponse -> YesodApp) -> Request -> [ContentType] - -> IO Response + -> IO (W.Status, [Header], ContentType, Content) } ------ Handler monad @@ -164,28 +164,28 @@ runHandler handler mrender sroute tomr ma tosa = YesodApp $ \eh rr cts -> do }) (\e -> return ([], HCError $ toErrorHandler e)) let handleError e = do - Response _ hs ct c <- unYesodApp (eh e) safeEh rr cts + (_, hs, ct, c) <- unYesodApp (eh e) safeEh rr cts let hs' = headers ++ hs - return $ Response (getStatus e) hs' ct c + return $ (getStatus e, hs', ct, c) let sendFile' ct fp = do c <- BL.readFile fp - return $ Response W.Status200 headers ct $ cs c + return (W.Status200, headers, ct, cs c) case contents of HCError e -> handleError e HCSpecial (Redirect rt loc) -> do let hs = Header "Location" loc : headers - return $ Response (getRedirectStatus rt) hs TypePlain $ cs "" + return (getRedirectStatus rt, hs, TypePlain, cs "") HCSpecial (SendFile ct fp) -> Control.Exception.catch (sendFile' ct fp) (handleError . toErrorHandler) HCContent a -> do (ct, c) <- chooseRep a cts - return $ Response W.Status200 headers ct c + return (W.Status200, headers, ct, c) safeEh :: ErrorResponse -> YesodApp safeEh er = YesodApp $ \_ _ _ -> do liftIO $ hPutStrLn stderr $ "Error handler errored out: " ++ show er - return $ Response W.Status500 [] TypePlain $ cs "Internal Server Error" + return (W.Status500, [], TypePlain, cs "Internal Server Error") ------ Special handlers specialResponse :: SpecialResponse -> GHandler sub master a @@ -231,3 +231,15 @@ header a = addHeader . Header a addHeader :: Header -> GHandler sub master () addHeader h = Handler $ \_ -> return ([h], HCContent ()) + +getStatus :: ErrorResponse -> W.Status +getStatus NotFound = W.Status404 +getStatus (InternalError _) = W.Status500 +getStatus (InvalidArgs _) = W.Status400 +getStatus PermissionDenied = W.Status403 +getStatus (BadMethod _) = W.Status405 + +getRedirectStatus :: RedirectType -> W.Status +getRedirectStatus RedirectPermanent = W.Status301 +getRedirectStatus RedirectTemporary = W.Status302 +getRedirectStatus RedirectSeeOther = W.Status303 diff --git a/Yesod/Helpers/Auth.hs b/Yesod/Helpers/Auth.hs index c9e9c10f..f767c9cb 100644 --- a/Yesod/Helpers/Auth.hs +++ b/Yesod/Helpers/Auth.hs @@ -36,12 +36,10 @@ import Yesod import Data.Convertible.Text import Control.Monad.Attempt -import qualified Data.ByteString.Char8 as B8 import Data.Maybe import Data.Typeable (Typeable) import Control.Exception (Exception) -import Control.Applicative ((<$>)) -- FIXME check referer header to determine destination @@ -189,16 +187,16 @@ getLogout = do redirectToDest RedirectTemporary $ defaultDest y -- | Gets the identifier for a user if available. -maybeIdentifier :: (Functor m, Monad m, RequestReader m) => m (Maybe String) -maybeIdentifier = - fmap cs . lookup (B8.pack authCookieName) . reqSession - <$> getRequest +maybeIdentifier :: RequestReader m => m (Maybe String) +maybeIdentifier = do + s <- session + return $ listToMaybe $ s authCookieName -- | Gets the display name for a user if available. -displayName :: (Functor m, Monad m, RequestReader m) => m (Maybe String) +displayName :: RequestReader m => m (Maybe String) displayName = do - rr <- getRequest - return $ fmap cs $ lookup (B8.pack authDisplayName) $ reqSession rr + s <- session + return $ listToMaybe $ s authDisplayName -- | Gets the identifier for a user. If user is not logged in, redirects them -- to the login page. diff --git a/Yesod/Request.hs b/Yesod/Request.hs index 5c1ae5e1..880420ca 100644 --- a/Yesod/Request.hs +++ b/Yesod/Request.hs @@ -1,10 +1,5 @@ {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE CPP #-} {-# LANGUAGE PackageImports #-} -{-# LANGUAGE NoMonomorphismRestriction #-} --------------------------------------------------------- -- -- Module : Yesod.Request @@ -15,75 +10,73 @@ -- Stability : Stable -- Portability : portable -- --- Code for extracting parameters from requests. +-- | Provides a parsed version of the raw 'W.Request' data. -- --------------------------------------------------------- module Yesod.Request ( - -- * Request - Request (..) + -- * Request datatype + RequestBodyContents + , Request (..) , RequestReader (..) + -- * Convenience functions , waiRequest - , cookies + , languages + -- * Lookup parameters , getParams , postParams - , languages - , parseWaiRequest - -- * Parameter + , cookies + , session + -- * Parameter type synonyms , ParamName , ParamValue , ParamError -#if TEST - , testSuite -#endif ) where import qualified Network.Wai as W import Yesod.Definitions import Web.Encodings -import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL -import Data.Convertible.Text -import Control.Arrow ((***)) -import Data.Maybe (fromMaybe) import "transformers" Control.Monad.IO.Class -import Control.Concurrent.MVar import Control.Monad (liftM) -#if TEST -import Test.Framework (testGroup, Test) ---import Test.Framework.Providers.HUnit ---import Test.HUnit hiding (Test) -#endif - type ParamName = String type ParamValue = String type ParamError = String +-- | The reader monad specialized for 'Request'. class Monad m => RequestReader m where getRequest :: m Request instance RequestReader ((->) Request) where getRequest = id -languages :: (Functor m, RequestReader m) => m [Language] -languages = reqLangs `fmap` getRequest +-- | Get the list of supported languages supplied by the user. +languages :: RequestReader m => m [Language] +languages = reqLangs `liftM` getRequest --- | Get the req 'W.Request' value. +-- | Get the request\'s 'W.Request' value. waiRequest :: RequestReader m => m W.Request waiRequest = reqWaiRequest `liftM` getRequest +-- | A tuple containing both the POST parameters and submitted files. type RequestBodyContents = ( [(ParamName, ParamValue)] , [(ParamName, FileInfo String BL.ByteString)] ) --- | The req information passed through W, cleaned up a bit. +-- | The parsed request information. data Request = Request { reqGetParams :: [(ParamName, ParamValue)] , reqCookies :: [(ParamName, ParamValue)] - , reqSession :: [(B.ByteString, B.ByteString)] + -- | Session data stored in a cookie via the clientsession package. FIXME explain how to extend. + , reqSession :: [(ParamName, ParamValue)] + -- | The POST parameters and submitted files. This is stored in an IO + -- thunk, which essentially means it will be computed once at most, but + -- only if requested. This allows avoidance of the potentially costly + -- parsing of POST bodies for pages which do not use them. , reqRequestBody :: IO RequestBodyContents , reqWaiRequest :: W.Request + -- | Languages which the client supports. , reqLangs :: [Language] } @@ -94,8 +87,10 @@ multiLookup ((k, v):rest) pn | otherwise = multiLookup rest pn -- | All GET paramater values with the given name. -getParams :: Request -> ParamName -> [ParamValue] -getParams rr = multiLookup $ reqGetParams rr +getParams :: RequestReader m => m (ParamName -> [ParamValue]) +getParams = do + rr <- getRequest + return $ multiLookup $ reqGetParams rr -- | All POST paramater values with the given name. postParams :: MonadIO m => Request -> m (ParamName -> [ParamValue]) @@ -103,52 +98,14 @@ postParams rr = do (pp, _) <- liftIO $ reqRequestBody rr return $ multiLookup pp --- | Produces a \"compute on demand\" value. The computation will be run once --- it is requested, and then the result will be stored. This will happen only --- once. -iothunk :: IO a -> IO (IO a) -iothunk = fmap go . newMVar . Left where - go :: MVar (Either (IO a) a) -> IO a - go mvar = modifyMVar mvar go' - go' :: Either (IO a) a -> IO (Either (IO a) a, a) - go' (Right val) = return (Right val, val) - go' (Left comp) = do - val <- comp - return (Right val, val) - -- | All cookies with the given name. -cookies :: Request -> ParamName -> [ParamValue] -cookies rr name = - map snd . filter (fst `equals` name) . reqCookies $ rr - where - equals f x y = f y == x +cookies :: RequestReader m => m (ParamName -> [ParamValue]) +cookies = do + rr <- getRequest + return $ multiLookup $ reqCookies rr -parseWaiRequest :: W.Request - -> [(B.ByteString, B.ByteString)] -- ^ session - -> IO Request -parseWaiRequest env session = do - let gets' = map (cs *** cs) $ decodeUrlPairs $ W.queryString env - let reqCookie = fromMaybe B.empty $ lookup W.Cookie $ W.requestHeaders env - cookies' = map (cs *** cs) $ parseCookies reqCookie - acceptLang = lookup W.AcceptLanguage $ W.requestHeaders env - langs = map cs $ maybe [] parseHttpAccept acceptLang - langs' = case lookup langKey cookies' of - Nothing -> langs - Just x -> x : langs - langs'' = case lookup langKey gets' of - Nothing -> langs' - Just x -> x : langs' - rbthunk <- iothunk $ rbHelper env - return $ Request gets' cookies' session rbthunk env langs'' - -rbHelper :: W.Request -> IO RequestBodyContents -rbHelper = fmap (fix1 *** map fix2) . parseRequestBody lbsSink where - fix1 = map (cs *** cs) - fix2 (x, FileInfo a b c) = (cs x, FileInfo (cs a) (cs b) c) - -#if TEST -testSuite :: Test -testSuite = testGroup "Yesod.Request" - [ - ] -#endif +-- | All session data with the given name. +session :: RequestReader m => m (ParamName -> [ParamValue]) +session = do + rr <- getRequest + return $ multiLookup $ reqSession rr diff --git a/Yesod/Response.hs b/Yesod/Response.hs index 66ff9b1d..0f1f9f3e 100644 --- a/Yesod/Response.hs +++ b/Yesod/Response.hs @@ -3,7 +3,6 @@ {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} --------------------------------------------------------- -- @@ -19,42 +18,28 @@ -- --------------------------------------------------------- module Yesod.Response - ( -- * Representations + ( -- * Content Content (..) + , toContent + -- * Representations , ChooseRep , HasReps (..) , defChooseRep - , ioTextToContent - -- ** Convenience wrappers - , staticRep -- ** Specific content types , RepHtml (..) , RepJson (..) , RepHtmlJson (..) , RepPlain (..) , RepXml (..) - -- * Response type - , Response (..) -- * Special responses , RedirectType (..) - , getRedirectStatus , SpecialResponse (..) -- * Error responses , ErrorResponse (..) - , getStatus -- * Header , Header (..) - , headerToPair - -- * Converting to WAI values - , responseToWaiResponse -#if TEST - -- * Tests - , testSuite - , runContent -#endif ) where -import Data.Time.Clock import Data.Maybe (mapMaybe) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L @@ -62,22 +47,19 @@ import Data.Text.Lazy (Text) import qualified Data.Text as T import Data.Convertible.Text -import Web.Encodings (formatW3) import qualified Network.Wai as W import qualified Network.Wai.Enumerator as WE -#if TEST -import Yesod.Request hiding (testSuite) -import Web.Mime hiding (testSuite) -#else import Yesod.Request import Web.Mime -#endif - -#if TEST -import Test.Framework (testGroup, Test) -#endif +-- | There are two different methods available for providing content in the +-- response: via files and enumerators. The former allows server to use +-- optimizations (usually the sendfile system call) for serving static files. +-- The latter is a space-efficient approach to content. +-- +-- It can be tedious to write enumerators; often times, you will be well served +-- to use 'toContent'. data Content = ContentFile FilePath | ContentEnum (forall a. (a -> B.ByteString -> IO (Either a a)) @@ -94,13 +76,18 @@ instance ConvertSuccess Text Content where convertSuccess lt = cs (cs lt :: L.ByteString) instance ConvertSuccess String Content where convertSuccess s = cs (cs s :: Text) +instance ConvertSuccess (IO Text) Content where + convertSuccess = swapEnum . WE.fromLBS' . fmap cs -type ChooseRep = [ContentType] -> IO (ContentType, Content) +-- | A synonym for 'convertSuccess' to make the desired output type explicit. +toContent :: ConvertSuccess x Content => x -> Content +toContent = cs --- | It would be nice to simplify 'Content' to the point where this is --- unnecesary. -ioTextToContent :: IO Text -> Content -ioTextToContent = swapEnum . WE.fromLBS' . fmap cs +-- | A function which gives targetted representations of content based on the +-- content-types the user accepts. +type ChooseRep = + [ContentType] -- ^ list of content-types user accepts, ordered by preference + -> IO (ContentType, Content) swapEnum :: W.Enumerator -> Content swapEnum (W.Enumerator e) = ContentEnum e @@ -110,13 +97,16 @@ class HasReps a where chooseRep :: a -> ChooseRep -- | A helper method for generating 'HasReps' instances. +-- +-- This function should be given a list of pairs of content type and conversion +-- functions. If none of the content types match, the first pair is used. defChooseRep :: [(ContentType, a -> IO Content)] -> a -> ChooseRep defChooseRep reps a ts = do let (ct, c) = case mapMaybe helper ts of (x:_) -> x [] -> case reps of - [] -> error "Empty reps" + [] -> error "Empty reps to defChooseRep" (x:_) -> x c' <- c a return (ct, c') @@ -141,13 +131,6 @@ instance HasReps [(ContentType, Content)] where where go = simpleContentType . contentTypeToString --- | Data with a single representation. -staticRep :: ConvertSuccess x Content - => ContentType - -> x - -> [(ContentType, Content)] -staticRep ct x = [(ct, cs x)] - newtype RepHtml = RepHtml Content instance HasReps RepHtml where chooseRep (RepHtml c) _ = return (TypeHtml, c) @@ -167,19 +150,12 @@ newtype RepXml = RepXml Content instance HasReps RepXml where chooseRep (RepXml c) _ = return (TypeXml, c) -data Response = Response W.Status [Header] ContentType Content - -- | Different types of redirects. data RedirectType = RedirectPermanent | RedirectTemporary | RedirectSeeOther deriving (Show, Eq) -getRedirectStatus :: RedirectType -> W.Status -getRedirectStatus RedirectPermanent = W.Status301 -getRedirectStatus RedirectTemporary = W.Status302 -getRedirectStatus RedirectSeeOther = W.Status303 - -- | Special types of responses which should short-circuit normal response -- processing. data SpecialResponse = @@ -197,13 +173,6 @@ data ErrorResponse = | BadMethod String deriving (Show, Eq) -getStatus :: ErrorResponse -> W.Status -getStatus NotFound = W.Status404 -getStatus (InternalError _) = W.Status500 -getStatus (InvalidArgs _) = W.Status400 -getStatus PermissionDenied = W.Status403 -getStatus (BadMethod _) = W.Status405 - ----- header stuff -- | Headers to be added to a 'Result'. data Header = @@ -211,36 +180,3 @@ data Header = | DeleteCookie String | Header String String deriving (Eq, Show) - --- | Convert Header to a key/value pair. -headerToPair :: Header -> IO (W.ResponseHeader, B.ByteString) -headerToPair (AddCookie minutes key value) = do - now <- getCurrentTime - let expires = addUTCTime (fromIntegral $ minutes * 60) now - return (W.SetCookie, cs $ key ++ "=" ++ value ++"; path=/; expires=" - ++ formatW3 expires) -headerToPair (DeleteCookie key) = return - (W.SetCookie, cs $ - key ++ "=; path=/; expires=Thu, 01-Jan-1970 00:00:00 GMT") -headerToPair (Header key value) = - return (W.responseHeaderFromBS $ cs key, cs value) - -responseToWaiResponse :: Response -> IO W.Response -responseToWaiResponse (Response sc hs ct c) = do - hs' <- mapM headerToPair hs - let hs'' = (W.ContentType, cs $ contentTypeToString ct) : hs' - return $ W.Response sc hs'' $ case c of - ContentFile fp -> Left fp - ContentEnum e -> Right $ W.Enumerator e - -#if TEST -runContent :: Content -> IO L.ByteString -runContent (ContentFile fp) = L.readFile fp -runContent (ContentEnum c) = WE.toLBS $ W.Enumerator c - ------ Testing -testSuite :: Test -testSuite = testGroup "Yesod.Response" - [ - ] -#endif