module Yesod.Handler
(
YesodSubRoute (..)
, GHandler
, getYesod
, getYesodSub
, getUrlRender
, getUrlRenderParams
, getCurrentRoute
, getRouteToMaster
, getRequest
, waiRequest
, runRequestBody
, RedirectUrl (..)
, redirect
, redirectWith
, redirectToPost
, notFound
, badMethod
, permissionDenied
, permissionDeniedI
, invalidArgs
, invalidArgsI
, sendFile
, sendFilePart
, sendResponse
, sendResponseStatus
, sendResponseCreated
, sendWaiResponse
, setCookie
, getExpires
, deleteCookie
, setHeader
, setLanguage
, cacheSeconds
, neverExpires
, alreadyExpired
, expiresAt
, SessionMap
, lookupSession
, lookupSessionBS
, getSession
, setSession
, setSessionBS
, deleteSession
, clearSession
, setUltDest
, setUltDestCurrent
, setUltDestReferer
, redirectUltDest
, clearUltDest
, setMessage
, setMessageI
, getMessage
, hamletToContent
, hamletToRepHtml
, newIdent
, MonadLift (..)
, 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, getCurrentTime, addUTCTime)
import Control.Exception hiding (Handler, catch, finally)
import Control.Applicative
import Control.Monad (liftM)
import Control.Monad.IO.Class
import Control.Monad.Trans.Class (MonadTrans)
import qualified Control.Monad.Trans.Class
import System.IO
import qualified Network.Wai as W
import qualified Network.HTTP.Types as H
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 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 qualified Data.CaseInsensitive as CI
import Blaze.ByteString.Builder (toByteString)
import Data.Text (Text)
import Yesod.Message (RenderMessage (..))
import Text.Blaze (toHtml, preEscapedText)
import qualified Yesod.Internal.Cache as Cache
import Yesod.Internal.Cache (mkCacheKey, CacheKey)
import Data.Typeable (Typeable)
import qualified Data.IORef as I
import Control.Exception.Lifted (catch)
import Control.Monad.Trans.Control
import Control.Monad.Trans.Resource
import Control.Monad.Base
import Yesod.Routes.Class
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 :: GHandler sub master GHState
get = do
hd <- ask
liftIO $ I.readIORef $ handlerState hd
put :: GHState -> GHandler sub master ()
put g = do
hd <- ask
liftIO $ I.writeIORef (handlerState hd) g
modify :: (GHState -> GHState) -> GHandler sub master ()
modify f = do
hd <- ask
liftIO $ I.atomicModifyIORef (handlerState hd) $ \g -> (f g, ())
tell :: Endo [Header] -> GHandler sub master ()
tell hs = modify $ \g -> g { ghsHeaders = ghsHeaders g `mappend` hs }
toMasterHandler :: (Route sub -> Route master)
-> (master -> sub)
-> Route sub
-> GHandler sub master a
-> GHandler sub' master a
toMasterHandler tm ts route = local (handlerSubData tm ts route)
toMasterHandlerDyn :: (Route sub -> Route master)
-> GHandler sub' master sub
-> Route sub
-> GHandler sub master a
-> GHandler sub' master a
toMasterHandlerDyn tm getSub route h = do
sub <- getSub
local (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)
-> GHandler sub master a
-> GHandler sub' master a
toMasterHandlerMaybe tm ts route = local (handlerSubDataMaybe tm ts route)
newtype GHandler sub master a = GHandler
{ unGHandler :: HandlerData sub master -> ResourceT IO a
}
data GHState = GHState
{ ghsSession :: SessionMap
, ghsRBC :: Maybe RequestBodyContents
, ghsIdent :: Int
, ghsCache :: Cache.Cache
, ghsHeaders :: Endo [Header]
}
type SessionMap = Map.Map Text S.ByteString
newtype YesodApp = YesodApp
{ unYesodApp
:: (ErrorResponse -> YesodApp)
-> Request
-> [ContentType]
-> SessionMap
-> ResourceT 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 H.Status Text
| HCCreated Text
| HCWai W.Response
deriving Typeable
instance Show HandlerContents where
show _ = "Cannot show a HandlerContents"
instance Exception HandlerContents
getRequest :: GHandler s m Request
getRequest = handlerRequest `liftM` ask
hcError :: ErrorResponse -> GHandler sub master a
hcError = 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 -> ResourceT IO RequestBodyContents
rbHelper req =
(map fix1 *** map fix2) <$> (NWP.parseRequestBody NWP.lbsBackEnd req)
where
fix1 = go *** go
fix2 (x, NWP.FileInfo a b c) =
(go x, FileInfo (go a) (go b) c)
go = decodeUtf8With lenientDecode
getYesodSub :: GHandler sub master sub
getYesodSub = handlerSub `liftM` ask
getYesod :: GHandler sub master master
getYesod = handlerMaster `liftM` ask
getUrlRender :: GHandler sub master (Route master -> Text)
getUrlRender = do
x <- handlerRender `liftM` ask
return $ flip x []
getUrlRenderParams
:: GHandler sub master (Route master -> [(Text, Text)] -> Text)
getUrlRenderParams = handlerRender `liftM` ask
getCurrentRoute :: GHandler sub master (Maybe (Route sub))
getCurrentRoute = handlerRoute `liftM` ask
getRouteToMaster :: GHandler sub master (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 master sub =
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 = sub
, handlerMaster = master
, handlerRoute = sroute
, handlerRender = mrender
, handlerToMaster = tomr
, handlerState = istate
}
contents' <- catch (fmap Right $ unGHandler 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 status loc -> do
let hs = Header "Location" (encodeUtf8 loc) : appEndo headers []
return $ YARPlain
status hs typePlain emptyContent
finalSession
HCSendFile ct fp p -> catch
(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 :: RedirectUrl master url => url -> GHandler sub master a
redirect url = do
req <- waiRequest
let status =
if W.httpVersion req == H.http11
then H.status303
else H.status302
redirectWith status url
redirectWith :: RedirectUrl master url => H.Status -> url -> GHandler sub master a
redirectWith status url = do
urlText <- toTextUrl url
liftIO $ throwIO $ HCRedirect status urlText
ultDestKey :: Text
ultDestKey = "_ULT"
setUltDest :: RedirectUrl master url => url -> GHandler sub master ()
setUltDest url = do
urlText <- toTextUrl url
setSession ultDestKey urlText
setUltDestCurrent :: GHandler sub master ()
setUltDestCurrent = do
route <- getCurrentRoute
case route of
Nothing -> return ()
Just r -> do
tm <- getRouteToMaster
gets' <- reqGetParams `liftM` handlerRequest `liftM` ask
setUltDest (tm r, gets')
setUltDestReferer :: GHandler sub master ()
setUltDestReferer = do
mdest <- lookupSession ultDestKey
maybe
(waiRequest >>= maybe (return ()) setUltDestBS . lookup "referer" . W.requestHeaders)
(const $ return ())
mdest
where
setUltDestBS = setUltDest . T.pack . S8.unpack
redirectUltDest :: RedirectUrl master url
=> url
-> GHandler sub master a
redirectUltDest def = do
mdest <- lookupSession ultDestKey
deleteSession ultDestKey
maybe (redirect def) redirect mdest
clearUltDest :: GHandler sub master ()
clearUltDest = deleteSession ultDestKey
msgKey :: Text
msgKey = "_MSG"
setMessage :: Html -> GHandler sub master ()
setMessage = setSession msgKey . T.concat . TL.toChunks . Text.Blaze.Renderer.Text.renderHtml
setMessageI :: (RenderMessage y msg) => msg -> GHandler sub y ()
setMessageI msg = do
mr <- getMessageRender
setMessage $ toHtml $ mr msg
getMessage :: GHandler sub master (Maybe Html)
getMessage = do
mmsg <- liftM (fmap preEscapedText) $ lookupSession msgKey
deleteSession msgKey
return mmsg
sendFile :: ContentType -> FilePath -> GHandler sub master a
sendFile ct fp = liftIO . throwIO $ HCSendFile ct fp Nothing
sendFilePart :: ContentType
-> FilePath
-> Integer
-> Integer
-> GHandler sub master a
sendFilePart ct fp off count =
liftIO . throwIO $ HCSendFile ct fp $ Just $ W.FilePart off count
sendResponse :: HasReps c => c -> GHandler sub master a
sendResponse = liftIO . throwIO . HCContent H.status200
. chooseRep
sendResponseStatus :: HasReps c => H.Status -> c -> GHandler s m a
sendResponseStatus s = liftIO . throwIO . HCContent s
. chooseRep
sendResponseCreated :: Route m -> GHandler s m a
sendResponseCreated url = do
r <- getUrlRender
liftIO . throwIO $ HCCreated $ r url
sendWaiResponse :: W.Response -> GHandler s m b
sendWaiResponse = liftIO . throwIO . HCWai
notFound :: GHandler sub master a
notFound = hcError NotFound
badMethod :: GHandler sub master a
badMethod = do
w <- waiRequest
hcError $ BadMethod $ W.requestMethod w
permissionDenied :: Text -> GHandler sub master a
permissionDenied = hcError . PermissionDenied
permissionDeniedI :: RenderMessage master msg => msg -> GHandler sub master a
permissionDeniedI msg = do
mr <- getMessageRender
permissionDenied $ mr msg
invalidArgs :: [Text] -> GHandler sub master a
invalidArgs = hcError . InvalidArgs
invalidArgsI :: RenderMessage y msg => [msg] -> GHandler s y a
invalidArgsI msg = do
mr <- getMessageRender
invalidArgs $ map mr msg
setCookie :: SetCookie
-> GHandler sub master ()
setCookie = addHeader . AddCookie
getExpires :: Int
-> IO UTCTime
getExpires m = do
now <- liftIO getCurrentTime
return $ fromIntegral (m * 60) `addUTCTime` now
deleteCookie :: Text
-> Text
-> GHandler sub master ()
deleteCookie a = addHeader . DeleteCookie (encodeUtf8 a) . encodeUtf8
setLanguage :: Text -> GHandler sub master ()
setLanguage = setSession langKey
setHeader :: Text -> Text -> GHandler sub master ()
setHeader a = addHeader . Header (encodeUtf8 a) . encodeUtf8
cacheSeconds :: Int -> GHandler s m ()
cacheSeconds i = setHeader "Cache-Control" $ T.concat
[ "max-age="
, T.pack $ show i
, ", public"
]
neverExpires :: GHandler s m ()
neverExpires = setHeader "Expires" "Thu, 31 Dec 2037 23:55:55 GMT"
alreadyExpired :: GHandler s m ()
alreadyExpired = setHeader "Expires" "Thu, 01 Jan 1970 05:05:05 GMT"
expiresAt :: UTCTime -> GHandler s m ()
expiresAt = setHeader "Expires" . formatRFC1123
setSession :: Text
-> Text
-> GHandler sub master ()
setSession k = setSessionBS k . encodeUtf8
setSessionBS :: Text
-> S.ByteString
-> GHandler sub master ()
setSessionBS k = modify . modSession . Map.insert k
deleteSession :: Text -> GHandler sub master ()
deleteSession = modify . modSession . Map.delete
clearSession :: GHandler sub master ()
clearSession = modify $ \x -> x { ghsSession = Map.empty }
modSession :: (SessionMap -> SessionMap) -> GHState -> GHState
modSession f x = x { ghsSession = f $ ghsSession x }
addHeader :: Header -> GHandler sub master ()
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
class RedirectUrl master a where
toTextUrl :: a -> GHandler sub master Text
instance RedirectUrl master Text where
toTextUrl = return
instance RedirectUrl master String where
toTextUrl = toTextUrl . T.pack
instance RedirectUrl master (Route master) where
toTextUrl url = do
r <- getUrlRender
return $ r url
instance (key ~ Text, val ~ Text) => RedirectUrl master (Route master, [(key, val)]) where
toTextUrl (url, params) = do
r <- getUrlRenderParams
return $ r url params
localNoCurrent :: GHandler s m a -> GHandler s m a
localNoCurrent =
local (\hd -> hd { handlerRoute = Nothing })
lookupSession :: Text -> GHandler s m (Maybe Text)
lookupSession = (fmap . fmap) (decodeUtf8With lenientDecode) . lookupSessionBS
lookupSessionBS :: Text -> GHandler s m (Maybe S.ByteString)
lookupSessionBS n = do
m <- liftM ghsSession get
return $ Map.lookup n m
getSession :: GHandler sub master SessionMap
getSession = liftM ghsSession get
handlerToYAR :: (HasReps a, HasReps b)
=> master
-> sub
-> (Route sub -> Route master)
-> (Route master -> [(Text, Text)] -> Text)
-> (ErrorResponse -> GHandler sub master a)
-> Request
-> Maybe (Route sub)
-> SessionMap
-> GHandler sub master b
-> ResourceT 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
yarToResponse :: YesodAppResult -> [(CI H.Ascii, H.Ascii)] -> W.Response
yarToResponse (YARWai a) _ = a
yarToResponse (YARPlain s hs _ c _) extraHeaders =
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
ContentSource body -> W.ResponseSource s finalHeaders body
where
finalHeaders = extraHeaders ++ map headerToPair hs
finalHeaders' len = ("Content-Length", S8.pack $ show len)
: finalHeaders
httpAccept :: W.Request -> [ContentType]
httpAccept = parseHttpAccept
. fromMaybe mempty
. lookup "Accept"
. W.requestHeaders
headerToPair :: Header
-> (CI H.Ascii, H.Ascii)
headerToPair (AddCookie sc) =
("Set-Cookie", toByteString $ renderSetCookie $ sc)
headerToPair (DeleteCookie key path) =
( "Set-Cookie"
, S.concat
[ key
, "=; path="
, path
, "; expires=Thu, 01-Jan-1970 00:00:00 GMT"
]
)
headerToPair (Header key value) = (CI.mk key, value)
newIdent :: GHandler sub master Text
newIdent = do
x <- get
let i' = ghsIdent x + 1
put x { ghsIdent = i' }
return $ T.pack $ 'h' : show i'
redirectToPost :: RedirectUrl master url => url -> GHandler sub master a
redirectToPost url = do
urlText <- toTextUrl url
hamletToRepHtml [hamlet|
$doctype 5
<html>
<head>
<title>Redirecting...
<body onload="document.getElementById('form').submit()">
<form id="form" method="post" action=#{urlText}>
<noscript>
<p>Javascript has been disabled; please click on the button below to be redirected.
<input type="submit" value="Continue">
|] >>= sendResponse
hamletToContent :: HtmlUrl (Route master) -> GHandler sub master Content
hamletToContent h = do
render <- getUrlRenderParams
return $ toContent $ h render
hamletToRepHtml :: HtmlUrl (Route master) -> GHandler sub master RepHtml
hamletToRepHtml = liftM RepHtml . hamletToContent
waiRequest :: GHandler sub master W.Request
waiRequest = reqWaiRequest `liftM` getRequest
getMessageRender :: RenderMessage master message => GHandler s master (message -> Text)
getMessageRender = do
m <- getYesod
l <- reqLangs `liftM` getRequest
return $ renderMessage m l
cacheLookup :: CacheKey a -> GHandler sub master (Maybe a)
cacheLookup k = do
gs <- get
return $ Cache.lookup k $ ghsCache gs
cacheInsert :: CacheKey a -> a -> GHandler sub master ()
cacheInsert k v = modify $ \gs ->
gs { ghsCache = Cache.insert k v $ ghsCache gs }
cacheDelete :: CacheKey a -> GHandler sub master ()
cacheDelete k = modify $ \gs ->
gs { ghsCache = Cache.delete k $ ghsCache gs }
ask :: GHandler sub master (HandlerData sub master)
ask = GHandler return
local :: (HandlerData sub' master' -> HandlerData sub master)
-> GHandler sub master a
-> GHandler sub' master' a
local f (GHandler x) = GHandler $ \r -> x $ f r
class MonadLift base m | m -> base where
lift :: base a -> m a
instance (Monad m, MonadTrans t) => MonadLift m (t m) where
lift = Control.Monad.Trans.Class.lift
instance MonadLift (ResourceT IO) (GHandler sub master) where
lift = GHandler . const
instance Functor (GHandler sub master) where
fmap f (GHandler x) = GHandler $ \r -> fmap f (x r)
instance Applicative (GHandler sub master) where
pure = GHandler . const . pure
GHandler f <*> GHandler x = GHandler $ \r -> f r <*> x r
instance Monad (GHandler sub master) where
return = pure
GHandler x >>= f = GHandler $ \r -> x r >>= \x' -> unGHandler (f x') r
instance MonadIO (GHandler sub master) where
liftIO = GHandler . const . lift
instance MonadBase IO (GHandler sub master) where
liftBase = GHandler . const . lift
instance MonadBaseControl IO (GHandler sub master) where
data StM (GHandler sub master) a = StH (StM (ResourceT IO) a)
liftBaseWith f = GHandler $ \reader ->
liftBaseWith $ \runInBase ->
f $ liftM StH . runInBase . (\(GHandler r) -> r reader)
restoreM (StH base) = GHandler $ const $ restoreM base
instance MonadUnsafeIO (GHandler sub master) where
unsafeLiftIO = liftIO
instance MonadThrow (GHandler sub master) where
monadThrow = liftIO . throwIO
instance MonadResource (GHandler sub master) where
allocate a = lift . allocate a
register = lift . register
release = lift . release
resourceMask = lift . resourceMask