Began major refactoring of code
This commit is contained in:
Michael Snoyman
parent
3265d7a717
commit
26ad604a19
@ -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)
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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.
|
||||
|
||||
117
Yesod/Request.hs
117
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
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user