module Yesod.Handler
(
Route
, YesodSubRoute (..)
, GHandler
, GGHandler
, getYesod
, getYesodSub
, getUrlRender
, getUrlRenderParams
, getCurrentRoute
, getRouteToMaster
, RedirectType (..)
, redirect
, redirectParams
, redirectString
, redirectToPost
, notFound
, badMethod
, permissionDenied
, invalidArgs
, sendFile
, sendResponse
, sendResponseStatus
, sendResponseCreated
, sendWaiResponse
, setCookie
, deleteCookie
, setHeader
, setLanguage
, cacheSeconds
, neverExpires
, alreadyExpired
, expiresAt
, SessionMap
, lookupSession
, getSession
, setSession
, deleteSession
, setUltDest
, setUltDestString
, setUltDest'
, redirectUltDest
, setMessage
, getMessage
, hamletToContent
, hamletToRepHtml
, newIdent
, liftIOHandler
, runHandler
, YesodApp (..)
, runSubsiteGetter
, toMasterHandler
, toMasterHandlerDyn
, toMasterHandlerMaybe
, localNoCurrent
, HandlerData
, ErrorResponse (..)
, YesodAppResult (..)
, handlerToYAR
, yarToResponse
, headerToPair
) where
import Prelude hiding (catch)
import Yesod.Request
import Yesod.Internal
import Data.Time (UTCTime)
import Control.Exception hiding (Handler, catch, finally)
import qualified Control.Exception as E
import Control.Applicative
import Control.Monad (liftM, join)
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import Control.Monad.Trans.Writer
import Control.Monad.Trans.Reader
import Control.Monad.Trans.State
import Control.Monad.Trans.Error (throwError, ErrorT (..), Error (..))
import System.IO
import qualified Network.Wai as W
import Control.Failure (Failure (failure))
import Text.Hamlet
import Control.Monad.IO.Peel (MonadPeelIO)
import Control.Monad.Trans.Peel (MonadTransPeel (peel), liftPeel)
import qualified Data.Map as Map
import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as S8
import Data.ByteString (ByteString)
import Data.Enumerator (Iteratee (..))
import Network.Wai.Parse (parseHttpAccept)
import Yesod.Content
import Data.Maybe (fromMaybe)
import Web.Cookie (SetCookie (..), renderSetCookie)
import Blaze.ByteString.Builder (toByteString)
import Data.Enumerator (run_, ($$))
import Control.Arrow (second, (***))
import qualified Network.Wai.Parse as NWP
type family Route a
class YesodSubRoute s y where
fromSubRoute :: s -> y -> Route s -> Route y
data HandlerData sub master = HandlerData
{ handlerRequest :: Request
, handlerSub :: sub
, handlerMaster :: master
, handlerRoute :: Maybe (Route sub)
, handlerRender :: (Route master -> [(String, String)] -> String)
, handlerToMaster :: Route sub -> Route master
}
handlerSubData :: (Route sub -> Route master)
-> (master -> sub)
-> Route sub
-> HandlerData oldSub master
-> HandlerData sub master
handlerSubData tm ts = handlerSubDataMaybe tm ts . Just
handlerSubDataMaybe :: (Route sub -> Route master)
-> (master -> sub)
-> Maybe (Route sub)
-> HandlerData oldSub master
-> HandlerData sub master
handlerSubDataMaybe tm ts route hd = hd
{ handlerSub = ts $ handlerMaster hd
, handlerToMaster = tm
, handlerRoute = route
}
toMasterHandler :: (Route sub -> Route master)
-> (master -> sub)
-> Route sub
-> GGHandler sub master mo a
-> GGHandler sub' master mo a
toMasterHandler tm ts route (GHandler h) =
GHandler $ withReaderT (handlerSubData tm ts route) h
toMasterHandlerDyn :: Monad mo
=> (Route sub -> Route master)
-> GGHandler sub' master mo sub
-> Route sub
-> GGHandler sub master mo a
-> GGHandler sub' master mo a
toMasterHandlerDyn tm getSub route (GHandler h) = do
sub <- getSub
GHandler $ withReaderT (handlerSubData tm (const sub) route) h
class SubsiteGetter g m s | g -> s where
runSubsiteGetter :: g -> m s
instance (master ~ master'
) => SubsiteGetter (master -> sub) (GHandler anySub master') sub where
runSubsiteGetter getter = do
y <- getYesod
return $ getter y
instance (anySub ~ anySub'
,master ~ master'
) => SubsiteGetter (GHandler anySub master sub) (GHandler anySub' master') sub where
runSubsiteGetter = id
toMasterHandlerMaybe :: (Route sub -> Route master)
-> (master -> sub)
-> Maybe (Route sub)
-> GGHandler sub master mo a
-> GGHandler sub' master mo a
toMasterHandlerMaybe tm ts route (GHandler h) =
GHandler $ withReaderT (handlerSubDataMaybe tm ts route) h
newtype GGHandler sub master m a =
GHandler
{ unGHandler :: GHInner sub master m a
}
deriving (Functor, Applicative, Monad, MonadIO, MonadPeelIO)
instance MonadTrans (GGHandler s m) where
lift = GHandler . lift . lift . lift . lift
type GHandler sub master = GGHandler sub master (Iteratee ByteString IO)
data GHState = GHState
{ ghsSession :: SessionMap
, ghsRBC :: Maybe RequestBodyContents
, ghsIdent :: Int
}
type GHInner s m monad =
ReaderT (HandlerData s m) (
ErrorT HandlerContents (
WriterT (Endo [Header]) (
StateT GHState (
monad
))))
type SessionMap = Map.Map String String
type Endo a = a -> a
newtype YesodApp = YesodApp
{ unYesodApp
:: (ErrorResponse -> YesodApp)
-> Request
-> [ContentType]
-> SessionMap
-> Iteratee ByteString IO YesodAppResult
}
data YesodAppResult
= YARWai W.Response
| YARPlain W.Status [Header] ContentType Content SessionMap
data HandlerContents =
HCContent W.Status ChooseRep
| HCError ErrorResponse
| HCSendFile ContentType FilePath
| HCRedirect RedirectType ByteString
| HCCreated ByteString
| HCWai W.Response
instance Error HandlerContents where
strMsg = HCError . InternalError
instance Monad monad => Failure ErrorResponse (GGHandler sub master monad) where
failure = GHandler . lift . throwError . HCError
instance RequestReader (GHandler sub master) where
getRequest = handlerRequest <$> GHandler ask
runRequestBody = do
x <- GHandler $ lift $ lift $ lift get
case ghsRBC x of
Just rbc -> return rbc
Nothing -> do
rr <- waiRequest
rbc <- lift $ rbHelper rr
GHandler $ lift $ lift $ lift $ put x { ghsRBC = Just rbc }
return rbc
rbHelper :: W.Request -> Iteratee ByteString IO RequestBodyContents
rbHelper req =
(map fix1 *** map fix2) <$> iter
where
iter = NWP.parseRequestBody NWP.lbsSink req
fix1 = bsToChars *** bsToChars
fix2 (x, NWP.FileInfo a b c) =
(bsToChars x, FileInfo (bsToChars a) (bsToChars b) c)
getYesodSub :: Monad m => GGHandler sub master m sub
getYesodSub = handlerSub `liftM` GHandler ask
getYesod :: Monad m => GGHandler sub master m master
getYesod = handlerMaster `liftM` GHandler ask
getUrlRender :: Monad m => GGHandler sub master m (Route master -> String)
getUrlRender = do
x <- handlerRender `liftM` GHandler ask
return $ flip x []
getUrlRenderParams
:: Monad m
=> GGHandler sub master m (Route master -> [(String, String)] -> String)
getUrlRenderParams = handlerRender `liftM` GHandler ask
getCurrentRoute :: Monad m => GGHandler sub master m (Maybe (Route sub))
getCurrentRoute = handlerRoute `liftM` GHandler ask
getRouteToMaster :: Monad m => GGHandler sub master m (Route sub -> Route master)
getRouteToMaster = handlerToMaster `liftM` GHandler ask
runHandler :: HasReps c
=> GHandler sub master c
-> (Route master -> [(String, String)] -> String)
-> Maybe (Route sub)
-> (Route sub -> Route master)
-> master
-> sub
-> YesodApp
runHandler handler mrender sroute tomr ma sa =
YesodApp $ \eh rr cts initSession -> do
let toErrorHandler e =
case fromException e of
Just x -> x
Nothing -> InternalError $ show e
let hd = HandlerData
{ handlerRequest = rr
, handlerSub = sa
, handlerMaster = ma
, handlerRoute = sroute
, handlerRender = mrender
, handlerToMaster = tomr
}
let initSession' = GHState initSession Nothing 1
((contents', headers), finalSession) <- catchIter (
fmap (second ghsSession)
$ flip runStateT initSession'
$ runWriterT
$ runErrorT
$ flip runReaderT hd
$ unGHandler handler
) (\e -> return ((Left $ HCError $ toErrorHandler e, id), initSession))
let contents = either id (HCContent W.status200 . chooseRep) contents'
let handleError e = do
yar <- unYesodApp (eh e) safeEh rr cts finalSession
case yar of
YARPlain _ hs ct c sess ->
let hs' = headers hs
in return $ YARPlain (getStatus e) hs' ct c sess
YARWai _ -> return yar
let sendFile' ct fp =
return $ YARPlain W.status200 (headers []) ct (ContentFile fp) finalSession
case contents of
HCContent status a -> do
(ct, c) <- liftIO $ chooseRep a cts
return $ YARPlain status (headers []) ct c finalSession
HCError e -> handleError e
HCRedirect rt loc -> do
let hs = Header "Location" loc : headers []
return $ YARPlain
(getRedirectStatus rt) hs typePlain emptyContent
finalSession
HCSendFile ct fp -> catchIter
(sendFile' ct fp)
(handleError . toErrorHandler)
HCCreated loc -> do
let hs = Header "Location" loc : headers []
return $ YARPlain
(W.Status 201 (S8.pack "Created"))
hs
typePlain
emptyContent
finalSession
HCWai r -> return $ YARWai r
catchIter :: Exception e
=> Iteratee ByteString IO a
-> (e -> Iteratee ByteString IO a)
-> Iteratee ByteString IO a
catchIter (Iteratee mstep) f = Iteratee $ mstep `E.catch` (runIteratee . f)
safeEh :: ErrorResponse -> YesodApp
safeEh er = YesodApp $ \_ _ _ session -> do
liftIO $ hPutStrLn stderr $ "Error handler errored out: " ++ show er
return $ YARPlain
W.status500
[]
typePlain
(toContent ("Internal Server Error" :: S.ByteString))
session
redirect :: Monad mo => RedirectType -> Route master -> GGHandler sub master mo a
redirect rt url = redirectParams rt url []
redirectParams :: Monad mo
=> RedirectType -> Route master -> [(String, String)]
-> GGHandler sub master mo a
redirectParams rt url params = do
r <- getUrlRenderParams
redirectString rt $ S8.pack $ r url params
redirectString :: Monad mo => RedirectType -> ByteString -> GGHandler sub master mo a
redirectString rt = GHandler . lift . throwError . HCRedirect rt
ultDestKey :: String
ultDestKey = "_ULT"
setUltDest :: Monad mo => Route master -> GGHandler sub master mo ()
setUltDest dest = do
render <- getUrlRender
setUltDestString $ render dest
setUltDestString :: Monad mo => String -> GGHandler sub master mo ()
setUltDestString = setSession ultDestKey
setUltDest' :: Monad mo => GGHandler sub master mo ()
setUltDest' = do
route <- getCurrentRoute
case route of
Nothing -> return ()
Just r -> do
tm <- getRouteToMaster
gets' <- reqGetParams `liftM` handlerRequest `liftM` GHandler ask
render <- getUrlRenderParams
setUltDestString $ render (tm r) gets'
redirectUltDest :: Monad mo
=> RedirectType
-> Route master
-> GGHandler sub master mo ()
redirectUltDest rt def = do
mdest <- lookupSession ultDestKey
deleteSession ultDestKey
maybe (redirect rt def) (redirectString rt . S8.pack) mdest
msgKey :: String
msgKey = "_MSG"
setMessage :: Monad mo => Html -> GGHandler sub master mo ()
setMessage = setSession msgKey . lbsToChars . renderHtml
getMessage :: Monad mo => GGHandler sub master mo (Maybe Html)
getMessage = do
mmsg <- liftM (fmap preEscapedString) $ lookupSession msgKey
deleteSession msgKey
return mmsg
sendFile :: Monad mo => ContentType -> FilePath -> GGHandler sub master mo a
sendFile ct = GHandler . lift . throwError . HCSendFile ct
sendResponse :: (Monad mo, HasReps c) => c -> GGHandler sub master mo a
sendResponse = GHandler . lift . throwError . HCContent W.status200
. chooseRep
sendResponseStatus :: (Monad mo, HasReps c) => W.Status -> c -> GGHandler s m mo a
sendResponseStatus s = GHandler . lift . throwError . HCContent s
. chooseRep
sendResponseCreated :: Monad mo => Route m -> GGHandler s m mo a
sendResponseCreated url = do
r <- getUrlRender
GHandler $ lift $ throwError $ HCCreated $ S8.pack $ r url
sendWaiResponse :: Monad mo => W.Response -> GGHandler s m mo b
sendWaiResponse = GHandler . lift . throwError . HCWai
notFound :: Failure ErrorResponse m => m a
notFound = failure NotFound
badMethod :: (RequestReader m, Failure ErrorResponse m) => m a
badMethod = do
w <- waiRequest
failure $ BadMethod $ bsToChars $ W.requestMethod w
permissionDenied :: Failure ErrorResponse m => String -> m a
permissionDenied = failure . PermissionDenied
invalidArgs :: Failure ErrorResponse m => [String] -> m a
invalidArgs = failure . InvalidArgs
setCookie :: Monad mo
=> Int
-> ByteString
-> ByteString
-> GGHandler sub master mo ()
setCookie a b = addHeader . AddCookie a b
deleteCookie :: Monad mo => ByteString -> GGHandler sub master mo ()
deleteCookie = addHeader . DeleteCookie
setLanguage :: Monad mo => String -> GGHandler sub master mo ()
setLanguage = setSession langKey
setHeader :: Monad mo
=> W.ResponseHeader -> ByteString -> GGHandler sub master mo ()
setHeader a = addHeader . Header a
cacheSeconds :: Monad mo => Int -> GGHandler s m mo ()
cacheSeconds i = setHeader "Cache-Control" $ S8.pack $ concat
[ "max-age="
, show i
, ", public"
]
neverExpires :: Monad mo => GGHandler s m mo ()
neverExpires = setHeader "Expires" "Thu, 31 Dec 2037 23:55:55 GMT"
alreadyExpired :: Monad mo => GGHandler s m mo ()
alreadyExpired = setHeader "Expires" "Thu, 01 Jan 1970 05:05:05 GMT"
expiresAt :: Monad mo => UTCTime -> GGHandler s m mo ()
expiresAt = setHeader "Expires" . S8.pack . formatRFC1123
setSession :: Monad mo
=> String
-> String
-> GGHandler sub master mo ()
setSession k = GHandler . lift . lift . lift . modify . modSession . Map.insert k
deleteSession :: Monad mo => String -> GGHandler sub master mo ()
deleteSession = GHandler . lift . lift . lift . modify . modSession . Map.delete
modSession :: (SessionMap -> SessionMap) -> GHState -> GHState
modSession f x = x { ghsSession = f $ ghsSession x }
addHeader :: Monad mo => Header -> GGHandler sub master mo ()
addHeader = GHandler . lift . lift . tell . (:)
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
data RedirectType = RedirectPermanent
| RedirectTemporary
| RedirectSeeOther
deriving (Show, Eq)
localNoCurrent :: Monad mo => GGHandler s m mo a -> GGHandler s m mo a
localNoCurrent =
GHandler . local (\hd -> hd { handlerRoute = Nothing }) . unGHandler
lookupSession :: Monad mo => ParamName -> GGHandler s m mo (Maybe ParamValue)
lookupSession n = GHandler $ do
m <- liftM ghsSession $ lift $ lift $ lift get
return $ Map.lookup n m
getSession :: Monad mo => GGHandler s m mo SessionMap
getSession = liftM ghsSession $ GHandler $ lift $ lift $ lift get
handlerToYAR :: (HasReps a, HasReps b)
=> m
-> s
-> (Route s -> Route m)
-> (Route m -> [(String, String)] -> String)
-> (ErrorResponse -> GHandler s m a)
-> Request
-> Maybe (Route s)
-> SessionMap
-> GHandler s m b
-> Iteratee ByteString IO YesodAppResult
handlerToYAR y s toMasterRoute render errorHandler rr murl sessionMap h =
unYesodApp ya eh' rr types sessionMap
where
ya = runHandler h render murl toMasterRoute y s
eh' er = runHandler (errorHandler' er) render murl toMasterRoute y s
types = httpAccept $ reqWaiRequest rr
errorHandler' = localNoCurrent . errorHandler
type HeaderRenderer = [Header]
-> ContentType
-> SessionMap
-> [(W.ResponseHeader, ByteString)]
yarToResponse :: HeaderRenderer -> YesodAppResult -> W.Response
yarToResponse _ (YARWai a) = a
yarToResponse renderHeaders (YARPlain s hs ct c sessionFinal) =
case c of
ContentBuilder b mlen ->
let hs' = maybe finalHeaders finalHeaders' mlen
in W.ResponseBuilder s hs' b
ContentFile fp -> W.ResponseFile s finalHeaders fp
ContentEnum e ->
W.ResponseEnumerator $ \iter -> run_ $ e $$ iter s finalHeaders
where
finalHeaders = renderHeaders hs ct sessionFinal
finalHeaders' len = ("Content-Length", S8.pack $ show len)
: finalHeaders
httpAccept :: W.Request -> [ContentType]
httpAccept = parseHttpAccept
. fromMaybe S.empty
. lookup "Accept"
. W.requestHeaders
headerToPair :: (Int -> UTCTime)
-> Header
-> (W.ResponseHeader, ByteString)
headerToPair getExpires (AddCookie minutes key value) =
("Set-Cookie", toByteString $ renderSetCookie $ SetCookie
{ setCookieName = key
, setCookieValue = value
, setCookiePath = Just "/"
, setCookieExpires = Just $ getExpires minutes
, setCookieDomain = Nothing
})
headerToPair _ (DeleteCookie key) =
( "Set-Cookie"
, key `S.append` "=; path=/; expires=Thu, 01-Jan-1970 00:00:00 GMT"
)
headerToPair _ (Header key value) = (key, value)
newIdent :: Monad mo => GGHandler sub master mo String
newIdent = GHandler $ lift $ lift $ lift $ do
x <- get
let i' = ghsIdent x + 1
put x { ghsIdent = i' }
return $ "h" ++ show i'
liftIOHandler :: MonadIO mo
=> GGHandler sub master IO a
-> GGHandler sub master mo a
liftIOHandler x = do
k <- peel
join $ liftIO $ k x
instance MonadTransPeel (GGHandler s m) where
peel = GHandler $ do
k <- liftPeel $ liftPeel $ liftPeel peel
return $ liftM GHandler . k . unGHandler
redirectToPost :: Monad mo => Route master -> GGHandler sub master mo a
redirectToPost dest = hamletToRepHtml
#if GHC7
[hamlet|
#else
[$hamlet|
#endif
\<!DOCTYPE html>
<html>
<head>
<title>Redirecting...
<body onload="document.getElementById('form').submit()">
<form id="form" method="post" action="@{dest}">
<noscript>
<p>Javascript has been disabled; please click on the button below to be redirected.
<input type="submit" value="Continue">
|] >>= sendResponse
hamletToContent :: Monad mo
=> Hamlet (Route master) -> GGHandler sub master mo Content
hamletToContent h = do
render <- getUrlRenderParams
return $ toContent $ h render
hamletToRepHtml :: Monad mo
=> Hamlet (Route master) -> GGHandler sub master mo RepHtml
hamletToRepHtml = liftM RepHtml . hamletToContent