module Yesod.Handler
(
Route
, YesodSubRoute (..)
, GHandler
, GGHandler
, getYesod
, getYesodSub
, getUrlRender
, getUrlRenderParams
, getCurrentRoute
, getRouteToMaster
, getRequest
, waiRequest
, runRequestBody
, RedirectType (..)
, redirect
, redirectParams
, redirectString
, redirectText
, redirectToPost
, notFound
, badMethod
, permissionDenied
, invalidArgs
, sendFile
, sendFilePart
, 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.Internal.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 qualified Network.HTTP.Types as H
import Control.Failure (Failure (failure))
import Text.Hamlet
import Text.Blaze (preEscapedText)
import qualified Text.Blaze.Renderer.Text
import qualified Data.Text as T
import Data.Text.Encoding (encodeUtf8, decodeUtf8With)
import Data.Text.Encoding.Error (lenientDecode)
import qualified Data.Text.Lazy as TL
import Control.Monad.IO.Control (MonadControlIO)
import Control.Monad.Trans.Control (MonadTransControl, liftControl)
import qualified Data.Map as Map
import qualified Data.ByteString as S
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 Data.Enumerator (run_, ($$))
import Control.Arrow (second, (***))
import qualified Network.Wai.Parse as NWP
import Data.Monoid (mappend, mempty)
import qualified Data.ByteString.Char8 as S8
import Data.CaseInsensitive (CI)
import Blaze.ByteString.Builder (toByteString)
import Data.Text (Text)
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 -> [(Text, Text)] -> Text)
, 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, MonadControlIO)
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 Text Text
type Endo a = a -> a
newtype YesodApp = YesodApp
{ unYesodApp
:: (ErrorResponse -> YesodApp)
-> Request
-> [ContentType]
-> SessionMap
-> Iteratee ByteString IO YesodAppResult
}
data YesodAppResult
= YARWai W.Response
| YARPlain H.Status [Header] ContentType Content SessionMap
data HandlerContents =
HCContent H.Status ChooseRep
| HCError ErrorResponse
| HCSendFile ContentType FilePath (Maybe W.FilePart)
| HCRedirect RedirectType Text
| HCCreated Text
| HCWai W.Response
instance Error HandlerContents where
strMsg = HCError . InternalError . T.pack
getRequest :: Monad mo => GGHandler s m mo Request
getRequest = handlerRequest `liftM` GHandler ask
instance Monad monad => Failure ErrorResponse (GGHandler sub master monad) where
failure = GHandler . lift . throwError . HCError
runRequestBody :: GHandler s m RequestBodyContents
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 = go *** go
fix2 (x, NWP.FileInfo a b c) =
(go x, FileInfo (go a) (go b) c)
go = decodeUtf8With lenientDecode
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 -> Text)
getUrlRender = do
x <- handlerRender `liftM` GHandler ask
return $ flip x []
getUrlRenderParams
:: Monad m
=> GGHandler sub master m (Route master -> [(Text, Text)] -> Text)
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 -> [(Text, Text)] -> Text)
-> 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 $ T.pack $ 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 H.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 p =
return $ YARPlain H.status200 (headers []) ct (ContentFile fp p) 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" (encodeUtf8 loc) : headers []
return $ YARPlain
(getRedirectStatus rt) hs typePlain emptyContent
finalSession
HCSendFile ct fp p -> catchIter
(sendFile' ct fp p)
(handleError . toErrorHandler)
HCCreated loc -> do
let hs = Header "Location" (encodeUtf8 loc) : headers []
return $ YARPlain
H.status201
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
H.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 -> [(Text, Text)]
-> GGHandler sub master mo a
redirectParams rt url params = do
r <- getUrlRenderParams
redirectString rt $ r url params
redirectString, redirectText :: Monad mo => RedirectType -> Text -> GGHandler sub master mo a
redirectText rt = GHandler . lift . throwError . HCRedirect rt
redirectString = redirectText
ultDestKey :: Text
ultDestKey = "_ULT"
setUltDest :: Monad mo => Route master -> GGHandler sub master mo ()
setUltDest dest = do
render <- getUrlRender
setUltDestString $ render dest
setUltDestString :: Monad mo => Text -> 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) (redirectText rt) mdest
msgKey :: Text
msgKey = "_MSG"
setMessage :: Monad mo => Html -> GGHandler sub master mo ()
setMessage = setSession msgKey . T.concat . TL.toChunks . Text.Blaze.Renderer.Text.renderHtml
getMessage :: Monad mo => GGHandler sub master mo (Maybe Html)
getMessage = do
mmsg <- liftM (fmap preEscapedText) $ lookupSession msgKey
deleteSession msgKey
return mmsg
sendFile :: Monad mo => ContentType -> FilePath -> GGHandler sub master mo a
sendFile ct fp = GHandler . lift . throwError $ HCSendFile ct fp Nothing
sendFilePart :: Monad mo
=> ContentType
-> FilePath
-> Integer
-> Integer
-> GGHandler sub master mo a
sendFilePart ct fp off count =
GHandler . lift . throwError $ HCSendFile ct fp $ Just $ W.FilePart off count
sendResponse :: (Monad mo, HasReps c) => c -> GGHandler sub master mo a
sendResponse = GHandler . lift . throwError . HCContent H.status200
. chooseRep
sendResponseStatus :: (Monad mo, HasReps c) => H.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 $ 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 :: Monad mo => GGHandler s m mo a
badMethod = do
w <- waiRequest
failure $ BadMethod $ W.requestMethod w
permissionDenied :: Failure ErrorResponse m => Text -> m a
permissionDenied = failure . PermissionDenied
invalidArgs :: Failure ErrorResponse m => [Text] -> m a
invalidArgs = failure . InvalidArgs
setCookie :: Monad mo
=> Int
-> H.Ascii
-> H.Ascii
-> GGHandler sub master mo ()
setCookie a b = addHeader . AddCookie a b
deleteCookie :: Monad mo => H.Ascii -> GGHandler sub master mo ()
deleteCookie = addHeader . DeleteCookie
setLanguage :: Monad mo => Text -> GGHandler sub master mo ()
setLanguage = setSession langKey
setHeader :: Monad mo
=> CI H.Ascii -> H.Ascii -> 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" . encodeUtf8 . formatRFC1123
setSession :: Monad mo
=> Text
-> Text
-> GGHandler sub master mo ()
setSession k = GHandler . lift . lift . lift . modify . modSession . Map.insert k
deleteSession :: Monad mo => Text -> 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 -> H.Status
getStatus NotFound = H.status404
getStatus (InternalError _) = H.status500
getStatus (InvalidArgs _) = H.status400
getStatus (PermissionDenied _) = H.status403
getStatus (BadMethod _) = H.status405
getRedirectStatus :: RedirectType -> H.Status
getRedirectStatus RedirectPermanent = H.status301
getRedirectStatus RedirectTemporary = H.status302
getRedirectStatus RedirectSeeOther = H.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 => Text -> GGHandler s m mo (Maybe Text)
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 -> [(Text, Text)] -> Text)
-> (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
-> [(CI H.Ascii, H.Ascii)]
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 p -> W.ResponseFile s finalHeaders fp p
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 mempty
. lookup "Accept"
. W.requestHeaders
headerToPair :: S.ByteString
-> (Int -> UTCTime)
-> Header
-> (CI H.Ascii, H.Ascii)
headerToPair cp getExpires (AddCookie minutes key value) =
("Set-Cookie", toByteString $ renderSetCookie $ SetCookie
{ setCookieName = key
, setCookieValue = value
, setCookiePath = Just cp
, setCookieExpires = Just $ getExpires minutes
, setCookieDomain = Nothing
})
headerToPair cp _ (DeleteCookie key) =
( "Set-Cookie"
, key `mappend` "=; path=" `mappend` cp `mappend` "; 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 m = GHandler $
ReaderT $ \r ->
ErrorT $
WriterT $
StateT $ \s ->
liftIO $ runGGHandler m r s
runGGHandler :: GGHandler sub master m a
-> HandlerData sub master
-> GHState
-> m ( ( Either HandlerContents a
, Endo [Header]
)
, GHState
)
runGGHandler m r s = runStateT
(runWriterT
(runErrorT
(runReaderT
(unGHandler m) r))) s
instance MonadTransControl (GGHandler s m) where
liftControl f =
GHandler $
liftControl $ \runRdr ->
liftControl $ \runErr ->
liftControl $ \runWrt ->
liftControl $ \runSt ->
f ( liftM ( GHandler
. join . lift
. join . lift
. join . lift
)
. runSt . runWrt . runErr . runRdr
. 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
waiRequest :: Monad mo => GGHandler sub master mo W.Request
waiRequest = reqWaiRequest `liftM` getRequest