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
, permissionDeniedI
, invalidArgs
, invalidArgsI
, sendFile
, sendFilePart
, sendResponse
, sendResponseStatus
, sendResponseCreated
, sendWaiResponse
, setCookie
, deleteCookie
, setHeader
, setLanguage
, cacheSeconds
, neverExpires
, alreadyExpired
, expiresAt
, SessionMap
, lookupSession
, getSession
, setSession
, deleteSession
, setUltDest
, setUltDestString
, setUltDestText
, setUltDest'
, setUltDestReferer
, redirectUltDest
, clearUltDest
, setMessage
, setMessageI
, getMessage
, hamletToContent
, hamletToRepHtml
, newIdent
, liftIOHandler
, getMessageRender
, CacheKey
, mkCacheKey
, cacheLookup
, cacheInsert
, cacheDelete
, 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 Control.Applicative
import Control.Monad (liftM)
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import Control.Monad.Trans.Reader
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 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 qualified Data.Map as Map
import qualified Data.ByteString as S
import Data.ByteString (ByteString)
import Data.Enumerator (Iteratee (..), run_, ($$))
import Network.Wai.Parse (parseHttpAccept)
import Yesod.Content
import Data.Maybe (fromMaybe)
import Web.Cookie (SetCookie (..), renderSetCookie)
import Control.Arrow ((***))
import qualified Network.Wai.Parse as NWP
import Data.Monoid (mappend, mempty, Endo (..))
import qualified Data.ByteString.Char8 as S8
import Data.CaseInsensitive (CI)
import Blaze.ByteString.Builder (toByteString)
import Data.Text (Text)
import Yesod.Message (RenderMessage (..))
import Text.Blaze (toHtml, preEscapedText)
import Yesod.Internal.TestApi (catchIter)
import qualified Yesod.Internal.Cache as Cache
import Yesod.Internal.Cache (mkCacheKey, CacheKey)
import Data.Typeable (Typeable)
import qualified Data.IORef as I
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
, handlerState :: I.IORef GHState
}
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
}
get :: MonadIO monad => GGHandler sub master monad GHState
get = do
hd <- ask
liftIO $ I.readIORef $ handlerState hd
put :: MonadIO monad => GHState -> GGHandler sub master monad ()
put g = do
hd <- ask
liftIO $ I.writeIORef (handlerState hd) g
modify :: MonadIO monad => (GHState -> GHState) -> GGHandler sub master monad ()
modify f = do
hd <- ask
liftIO $ I.atomicModifyIORef (handlerState hd) $ \g -> (f g, ())
tell :: MonadIO monad => Endo [Header] -> GGHandler sub master monad ()
tell hs = modify $ \g -> g { ghsHeaders = ghsHeaders g `mappend` hs }
toMasterHandler :: (Route sub -> Route master)
-> (master -> sub)
-> Route sub
-> GGHandler sub master mo a
-> GGHandler sub' master mo a
toMasterHandler tm ts route = withReaderT (handlerSubData tm ts route)
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 h = do
sub <- getSub
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 = getter <$> getYesod
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 = withReaderT (handlerSubDataMaybe tm ts route)
type GGHandler sub master = ReaderT (HandlerData sub master)
type GHandler sub master = GGHandler sub master (Iteratee ByteString IO)
data GHState = GHState
{ ghsSession :: SessionMap
, ghsRBC :: Maybe RequestBodyContents
, ghsIdent :: Int
, ghsCache :: Cache.Cache
, ghsHeaders :: Endo [Header]
}
type SessionMap = Map.Map Text Text
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
deriving Typeable
instance Show HandlerContents where
show _ = "Cannot show a HandlerContents"
instance Exception HandlerContents
getRequest :: Monad mo => GGHandler s m mo Request
getRequest = handlerRequest `liftM` ask
instance MonadIO monad => Failure ErrorResponse (GGHandler sub master monad) where
failure = liftIO . throwIO . HCError
runRequestBody :: GHandler s m RequestBodyContents
runRequestBody = do
x <- get
case ghsRBC x of
Just rbc -> return rbc
Nothing -> do
rr <- waiRequest
rbc <- lift $ rbHelper rr
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` ask
getYesod :: Monad m => GGHandler sub master m master
getYesod = handlerMaster `liftM` ask
getUrlRender :: Monad m => GGHandler sub master m (Route master -> Text)
getUrlRender = do
x <- handlerRender `liftM` ask
return $ flip x []
getUrlRenderParams
:: Monad m
=> GGHandler sub master m (Route master -> [(Text, Text)] -> Text)
getUrlRenderParams = handlerRender `liftM` ask
getCurrentRoute :: Monad m => GGHandler sub master m (Maybe (Route sub))
getCurrentRoute = handlerRoute `liftM` ask
getRouteToMaster :: Monad m => GGHandler sub master m (Route sub -> Route master)
getRouteToMaster = handlerToMaster `liftM` 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
istate <- liftIO $ I.newIORef GHState
{ ghsSession = initSession
, ghsRBC = Nothing
, ghsIdent = 1
, ghsCache = mempty
, ghsHeaders = mempty
}
let hd = HandlerData
{ handlerRequest = rr
, handlerSub = sa
, handlerMaster = ma
, handlerRoute = sroute
, handlerRender = mrender
, handlerToMaster = tomr
, handlerState = istate
}
contents' <- catchIter (fmap Right $ runReaderT handler hd)
(\e -> return $ Left $ maybe (HCError $ toErrorHandler e) id
$ fromException e)
state <- liftIO $ I.readIORef istate
let finalSession = ghsSession state
let headers = ghsHeaders state
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' = appEndo headers hs
in return $ YARPlain (getStatus e) hs' ct c sess
YARWai _ -> return yar
let sendFile' ct fp p =
return $ YARPlain H.status200 (appEndo headers []) ct (ContentFile fp p) finalSession
case contents of
HCContent status a -> do
(ct, c) <- liftIO $ a cts
return $ YARPlain status (appEndo headers []) ct c finalSession
HCError e -> handleError e
HCRedirect rt loc -> do
let hs = Header "Location" (encodeUtf8 loc) : appEndo 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) : appEndo headers []
return $ YARPlain
H.status201
hs
typePlain
emptyContent
finalSession
HCWai r -> return $ YARWai r
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 :: MonadIO mo => RedirectType -> Route master -> GGHandler sub master mo a
redirect rt url = redirectParams rt url []
redirectParams :: MonadIO 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 :: MonadIO mo => RedirectType -> Text -> GGHandler sub master mo a
redirectText rt = liftIO . throwIO . HCRedirect rt
redirectString = redirectText
ultDestKey :: Text
ultDestKey = "_ULT"
setUltDest :: MonadIO mo => Route master -> GGHandler sub master mo ()
setUltDest dest = do
render <- getUrlRender
setUltDestString $ render dest
setUltDestText :: MonadIO mo => Text -> GGHandler sub master mo ()
setUltDestText = setSession ultDestKey
setUltDestString :: MonadIO mo => Text -> GGHandler sub master mo ()
setUltDestString = setSession ultDestKey
setUltDest' :: MonadIO mo => GGHandler sub master mo ()
setUltDest' = do
route <- getCurrentRoute
case route of
Nothing -> return ()
Just r -> do
tm <- getRouteToMaster
gets' <- reqGetParams `liftM` handlerRequest `liftM` ask
render <- getUrlRenderParams
setUltDestString $ render (tm r) gets'
setUltDestReferer :: MonadIO mo => GGHandler sub master mo ()
setUltDestReferer = do
mdest <- lookupSession ultDestKey
maybe
(waiRequest >>= maybe (return ()) setUltDestBS . lookup "referer" . W.requestHeaders)
(const $ return ())
mdest
where
setUltDestBS = setUltDestText . T.pack . S8.unpack
redirectUltDest :: MonadIO mo
=> RedirectType
-> Route master
-> GGHandler sub master mo a
redirectUltDest rt def = do
mdest <- lookupSession ultDestKey
deleteSession ultDestKey
maybe (redirect rt def) (redirectText rt) mdest
clearUltDest :: MonadIO mo => GGHandler sub master mo ()
clearUltDest = deleteSession ultDestKey
msgKey :: Text
msgKey = "_MSG"
setMessage :: MonadIO mo => Html -> GGHandler sub master mo ()
setMessage = setSession msgKey . T.concat . TL.toChunks . Text.Blaze.Renderer.Text.renderHtml
setMessageI :: (RenderMessage y msg, MonadIO mo) => msg -> GGHandler sub y mo ()
setMessageI msg = do
mr <- getMessageRender
setMessage $ toHtml $ mr msg
getMessage :: MonadIO mo => GGHandler sub master mo (Maybe Html)
getMessage = do
mmsg <- liftM (fmap preEscapedText) $ lookupSession msgKey
deleteSession msgKey
return mmsg
sendFile :: MonadIO mo => ContentType -> FilePath -> GGHandler sub master mo a
sendFile ct fp = liftIO . throwIO $ HCSendFile ct fp Nothing
sendFilePart :: MonadIO mo
=> ContentType
-> FilePath
-> Integer
-> Integer
-> GGHandler sub master mo a
sendFilePart ct fp off count =
liftIO . throwIO $ HCSendFile ct fp $ Just $ W.FilePart off count
sendResponse :: (MonadIO mo, HasReps c) => c -> GGHandler sub master mo a
sendResponse = liftIO . throwIO . HCContent H.status200
. chooseRep
sendResponseStatus :: (MonadIO mo, HasReps c) => H.Status -> c -> GGHandler s m mo a
sendResponseStatus s = liftIO . throwIO . HCContent s
. chooseRep
sendResponseCreated :: MonadIO mo => Route m -> GGHandler s m mo a
sendResponseCreated url = do
r <- getUrlRender
liftIO . throwIO $ HCCreated $ r url
sendWaiResponse :: MonadIO mo => W.Response -> GGHandler s m mo b
sendWaiResponse = liftIO . throwIO . HCWai
notFound :: Failure ErrorResponse m => m a
notFound = failure NotFound
badMethod :: MonadIO 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
permissionDeniedI :: (RenderMessage y msg, MonadIO mo) => msg -> GGHandler s y mo a
permissionDeniedI msg = do
mr <- getMessageRender
permissionDenied $ mr msg
invalidArgs :: Failure ErrorResponse m => [Text] -> m a
invalidArgs = failure . InvalidArgs
invalidArgsI :: (RenderMessage y msg, MonadIO mo) => [msg] -> GGHandler s y mo a
invalidArgsI msg = do
mr <- getMessageRender
invalidArgs $ map mr msg
setCookie :: MonadIO mo
=> Int
-> H.Ascii
-> H.Ascii
-> GGHandler sub master mo ()
setCookie a b = addHeader . AddCookie a b
deleteCookie :: MonadIO mo => H.Ascii -> GGHandler sub master mo ()
deleteCookie = addHeader . DeleteCookie
setLanguage :: MonadIO mo => Text -> GGHandler sub master mo ()
setLanguage = setSession langKey
setHeader :: MonadIO mo
=> CI H.Ascii -> H.Ascii -> GGHandler sub master mo ()
setHeader a = addHeader . Header a
cacheSeconds :: MonadIO mo => Int -> GGHandler s m mo ()
cacheSeconds i = setHeader "Cache-Control" $ S8.pack $ concat
[ "max-age="
, show i
, ", public"
]
neverExpires :: MonadIO mo => GGHandler s m mo ()
neverExpires = setHeader "Expires" "Thu, 31 Dec 2037 23:55:55 GMT"
alreadyExpired :: MonadIO mo => GGHandler s m mo ()
alreadyExpired = setHeader "Expires" "Thu, 01 Jan 1970 05:05:05 GMT"
expiresAt :: MonadIO mo => UTCTime -> GGHandler s m mo ()
expiresAt = setHeader "Expires" . encodeUtf8 . formatRFC1123
setSession :: MonadIO mo
=> Text
-> Text
-> GGHandler sub master mo ()
setSession k = modify . modSession . Map.insert k
deleteSession :: MonadIO mo => Text -> GGHandler sub master mo ()
deleteSession = modify . modSession . Map.delete
modSession :: (SessionMap -> SessionMap) -> GHState -> GHState
modSession f x = x { ghsSession = f $ ghsSession x }
addHeader :: MonadIO mo => Header -> GGHandler sub master mo ()
addHeader = tell . Endo . (:)
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 =
local (\hd -> hd { handlerRoute = Nothing })
lookupSession :: MonadIO mo => Text -> GGHandler s m mo (Maybe Text)
lookupSession n = do
m <- liftM ghsSession get
return $ Map.lookup n m
getSession :: MonadIO mo => GGHandler s m mo SessionMap
getSession = liftM ghsSession 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 =
if minutes == 0
then Nothing
else Just $ getExpires minutes
, setCookieDomain = Nothing
, setCookieHttpOnly = True
})
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 :: MonadIO mo => GGHandler sub master mo String
newIdent = 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 (ReaderT m) = ReaderT $ \r -> liftIO $ m r
redirectToPost :: MonadIO 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
=> HtmlUrl (Route master) -> GGHandler sub master mo Content
hamletToContent h = do
render <- getUrlRenderParams
return $ toContent $ h render
hamletToRepHtml :: Monad mo
=> HtmlUrl (Route master) -> GGHandler sub master mo RepHtml
hamletToRepHtml = liftM RepHtml . hamletToContent
waiRequest :: Monad mo => GGHandler sub master mo W.Request
waiRequest = reqWaiRequest `liftM` getRequest
getMessageRender :: (Monad mo, RenderMessage master message) => GGHandler s master mo (message -> Text)
getMessageRender = do
m <- getYesod
l <- reqLangs `liftM` getRequest
return $ renderMessage m l
cacheLookup :: MonadIO mo => CacheKey a -> GGHandler sub master mo (Maybe a)
cacheLookup k = do
gs <- get
return $ Cache.lookup k $ ghsCache gs
cacheInsert :: MonadIO mo => CacheKey a -> a -> GGHandler sub master mo ()
cacheInsert k v = modify $ \gs ->
gs { ghsCache = Cache.insert k v $ ghsCache gs }
cacheDelete :: MonadIO mo => CacheKey a -> GGHandler sub master mo ()
cacheDelete k = modify $ \gs ->
gs { ghsCache = Cache.delete k $ ghsCache gs }