haskell/yesod
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Use Endo (Tyson Whitehead)

Browse Source
This commit is contained in:
Michael Snoyman 2011-06-09 15:25:18 +03:00
parent 3cf472dcf5
commit da0e99c895
1 changed files with 8 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
Yesod/Handler.hs
View File

@ -155,7 +155,7 @@ import Web.Cookie (SetCookie (..), renderSetCookie)
import Data.Enumerator (run_, ($$)) import Data.Enumerator (run_, ($$))
import Control.Arrow (second, (***)) import Control.Arrow (second, (***))
import qualified Network.Wai.Parse as NWP import qualified Network.Wai.Parse as NWP
import Data.Monoid (mappend, mempty) import Data.Monoid (mappend, mempty, Endo (..))
import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Char8 as S8
import Data.CaseInsensitive (CI) import Data.CaseInsensitive (CI)
import Blaze.ByteString.Builder (toByteString) import Blaze.ByteString.Builder (toByteString)
@ -269,8 +269,6 @@ type GHInner s m monad = -- FIXME collapse the stack
type SessionMap = Map.Map Text Text type SessionMap = Map.Map Text Text
type Endo a = a -> a
-- | An extension of the basic WAI 'W.Application' datatype to provide extra -- | An extension of the basic WAI 'W.Application' datatype to provide extra
-- features needed by Yesod. Users should never need to use this directly, as -- features needed by Yesod. Users should never need to use this directly, as
-- the 'GHandler' monad and template haskell code should hide it away. -- the 'GHandler' monad and template haskell code should hide it away.
@ -387,24 +385,24 @@ runHandler handler mrender sroute tomr ma sa =
$ runErrorT $ runErrorT
$ flip runReaderT hd $ flip runReaderT hd
$ unGHandler handler $ unGHandler handler
) (\e -> return ((Left $ HCError $ toErrorHandler e, id), initSession)) ) (\e -> return ((Left $ HCError $ toErrorHandler e, mempty), initSession))
let contents = either id (HCContent H.status200 . chooseRep) contents' let contents = either id (HCContent H.status200 . chooseRep) contents'
let handleError e = do let handleError e = do
yar <- unYesodApp (eh e) safeEh rr cts finalSession yar <- unYesodApp (eh e) safeEh rr cts finalSession
case yar of case yar of
YARPlain _ hs ct c sess -> YARPlain _ hs ct c sess ->
let hs' = headers hs let hs' = appEndo headers hs
in return $ YARPlain (getStatus e) hs' ct c sess in return $ YARPlain (getStatus e) hs' ct c sess
YARWai _ -> return yar YARWai _ -> return yar
let sendFile' ct fp p = let sendFile' ct fp p =
return $ YARPlain H.status200 (headers []) ct (ContentFile fp p) finalSession return $ YARPlain H.status200 (appEndo headers []) ct (ContentFile fp p) finalSession
case contents of case contents of
HCContent status a -> do HCContent status a -> do
(ct, c) <- liftIO $ a cts (ct, c) <- liftIO $ a cts
return $ YARPlain status (headers []) ct c finalSession return $ YARPlain status (appEndo headers []) ct c finalSession
HCError e -> handleError e HCError e -> handleError e
HCRedirect rt loc -> do HCRedirect rt loc -> do
let hs = Header "Location" (encodeUtf8 loc) : headers [] let hs = Header "Location" (encodeUtf8 loc) : appEndo headers []
return $ YARPlain return $ YARPlain
(getRedirectStatus rt) hs typePlain emptyContent (getRedirectStatus rt) hs typePlain emptyContent
finalSession finalSession
@ -412,7 +410,7 @@ runHandler handler mrender sroute tomr ma sa =
(sendFile' ct fp p) (sendFile' ct fp p)
(handleError . toErrorHandler) (handleError . toErrorHandler)
HCCreated loc -> do HCCreated loc -> do
let hs = Header "Location" (encodeUtf8 loc) : headers [] let hs = Header "Location" (encodeUtf8 loc) : appEndo headers []
return $ YARPlain return $ YARPlain
H.status201 H.status201
hs hs
@ -670,7 +668,7 @@ modSession f x = x { ghsSession = f $ ghsSession x }
-- | Internal use only, not to be confused with 'setHeader'. -- | Internal use only, not to be confused with 'setHeader'.
addHeader :: Monad mo => Header -> GGHandler sub master mo () addHeader :: Monad mo => Header -> GGHandler sub master mo ()
addHeader = GHandler . lift . lift . tell . (:) addHeader = GHandler . lift . lift . tell . Endo . (:)
getStatus :: ErrorResponse -> H.Status getStatus :: ErrorResponse -> H.Status
getStatus NotFound = H.status404 getStatus NotFound = H.status404