980 lines
32 KiB
Haskell
980 lines
32 KiB
Haskell
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
{-# LANGUAGE FlexibleInstances #-}
|
|
{-# LANGUAGE TypeSynonymInstances #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE TypeFamilies #-}
|
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
|
{-# LANGUAGE CPP #-}
|
|
{-# LANGUAGE FunctionalDependencies #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE QuasiQuotes #-}
|
|
{-# LANGUAGE DeriveDataTypeable #-}
|
|
---------------------------------------------------------
|
|
--
|
|
-- Module : Yesod.Handler
|
|
-- Copyright : Michael Snoyman
|
|
-- License : BSD3
|
|
--
|
|
-- Maintainer : Michael Snoyman <michael@snoyman.com>
|
|
-- Stability : stable
|
|
-- Portability : portable
|
|
--
|
|
-- Define Handler stuff.
|
|
--
|
|
---------------------------------------------------------
|
|
module Yesod.Handler
|
|
( -- * Type families
|
|
YesodSubRoute (..)
|
|
-- * Handler monad
|
|
, GHandler
|
|
-- ** Read information from handler
|
|
, getYesod
|
|
, getYesodSub
|
|
, getUrlRender
|
|
, getUrlRenderParams
|
|
, getCurrentRoute
|
|
, getRouteToMaster
|
|
, getRequest
|
|
, waiRequest
|
|
, runRequestBody
|
|
-- * Special responses
|
|
-- ** Redirecting
|
|
, RedirectUrl (..)
|
|
, redirect
|
|
, redirectWith
|
|
, redirectToPost
|
|
-- ** Errors
|
|
, notFound
|
|
, badMethod
|
|
, permissionDenied
|
|
, permissionDeniedI
|
|
, invalidArgs
|
|
, invalidArgsI
|
|
-- ** Short-circuit responses.
|
|
, sendFile
|
|
, sendFilePart
|
|
, sendResponse
|
|
, sendResponseStatus
|
|
, sendResponseCreated
|
|
, sendWaiResponse
|
|
-- * Setting headers
|
|
, setCookie
|
|
, getExpires
|
|
, deleteCookie
|
|
, setHeader
|
|
, setLanguage
|
|
-- ** Content caching and expiration
|
|
, cacheSeconds
|
|
, neverExpires
|
|
, alreadyExpired
|
|
, expiresAt
|
|
-- * Session
|
|
, SessionMap
|
|
, lookupSession
|
|
, lookupSessionBS
|
|
, getSession
|
|
, setSession
|
|
, setSessionBS
|
|
, deleteSession
|
|
, clearSession
|
|
-- ** Ultimate destination
|
|
, setUltDest
|
|
, setUltDestCurrent
|
|
, setUltDestReferer
|
|
, redirectUltDest
|
|
, clearUltDest
|
|
-- ** Messages
|
|
, setMessage
|
|
, setMessageI
|
|
, getMessage
|
|
-- * Helpers for specific content
|
|
-- ** Hamlet
|
|
, hamletToContent
|
|
, hamletToRepHtml
|
|
-- ** Misc
|
|
, newIdent
|
|
-- * Lifting
|
|
, MonadLift (..)
|
|
-- * i18n
|
|
, getMessageRender
|
|
-- * Per-request caching
|
|
, CacheKey
|
|
, mkCacheKey
|
|
, cacheLookup
|
|
, cacheInsert
|
|
, cacheDelete
|
|
-- * Internal Yesod
|
|
, 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.Html.Renderer.Text as RenderText
|
|
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 qualified Data.ByteString.Lazy as L
|
|
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.ByteString (ByteString)
|
|
import Data.CaseInsensitive (CI)
|
|
import qualified Data.CaseInsensitive as CI
|
|
import Blaze.ByteString.Builder (toByteString, toLazyByteString, fromLazyByteString)
|
|
import Data.Text (Text)
|
|
import Yesod.Message (RenderMessage (..))
|
|
|
|
import Text.Blaze.Html (toHtml, preEscapedToMarkup)
|
|
#define preEscapedText preEscapedToMarkup
|
|
|
|
import System.Log.FastLogger
|
|
import Control.Monad.Logger
|
|
|
|
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
|
|
import Data.Word (Word64)
|
|
import Language.Haskell.TH.Syntax (Loc)
|
|
|
|
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
|
|
, handlerUpload :: Word64 -> FileUpload
|
|
, handlerLog :: Loc -> LogLevel -> LogStr -> IO ()
|
|
}
|
|
|
|
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 }
|
|
|
|
-- | Used internally for promoting subsite handler functions to master site
|
|
-- handler functions. Should not be needed by users.
|
|
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)
|
|
|
|
-- | FIXME do we need this?
|
|
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)
|
|
|
|
-- | A generic handler monad, which can have a different subsite and master
|
|
-- site. We define a newtype for better error message.
|
|
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
|
|
|
|
-- | 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
|
|
-- the 'GHandler' monad and template haskell code should hide it away.
|
|
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) -- FIXME replace FilePath with opaque type from system-filepath?
|
|
| 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
|
|
hd <- ask
|
|
let getUpload = handlerUpload hd
|
|
len = reqBodySize $ handlerRequest hd
|
|
upload = getUpload len
|
|
x <- get
|
|
case ghsRBC x of
|
|
Just rbc -> return rbc
|
|
Nothing -> do
|
|
rr <- waiRequest
|
|
rbc <- lift $ rbHelper upload rr
|
|
put x { ghsRBC = Just rbc }
|
|
return rbc
|
|
|
|
rbHelper :: FileUpload -> W.Request -> ResourceT IO RequestBodyContents
|
|
rbHelper upload =
|
|
case upload of
|
|
FileUploadMemory s -> rbHelper' s mkFileInfoLBS
|
|
FileUploadDisk s -> rbHelper' s mkFileInfoFile
|
|
FileUploadSource s -> rbHelper' s mkFileInfoSource
|
|
|
|
rbHelper' :: NWP.BackEnd x
|
|
-> (Text -> Text -> x -> FileInfo)
|
|
-> W.Request
|
|
-> ResourceT IO ([(Text, Text)], [(Text, FileInfo)])
|
|
rbHelper' backend mkFI req =
|
|
(map fix1 *** map fix2) <$> (NWP.parseRequestBody backend req)
|
|
where
|
|
fix1 = go *** go
|
|
fix2 (x, NWP.FileInfo a b c) =
|
|
(go x, mkFI (go a) (go b) c)
|
|
go = decodeUtf8With lenientDecode
|
|
|
|
-- | Get the sub application argument.
|
|
getYesodSub :: GHandler sub master sub
|
|
getYesodSub = handlerSub `liftM` ask
|
|
|
|
-- | Get the master site appliation argument.
|
|
getYesod :: GHandler sub master master
|
|
getYesod = handlerMaster `liftM` ask
|
|
|
|
-- | Get the URL rendering function.
|
|
getUrlRender :: GHandler sub master (Route master -> Text)
|
|
getUrlRender = do
|
|
x <- handlerRender `liftM` ask
|
|
return $ flip x []
|
|
|
|
-- | The URL rendering function with query-string parameters.
|
|
getUrlRenderParams
|
|
:: GHandler sub master (Route master -> [(Text, Text)] -> Text)
|
|
getUrlRenderParams = handlerRender `liftM` ask
|
|
|
|
-- | Get the route requested by the user. If this is a 404 response- where the
|
|
-- user requested an invalid route- this function will return 'Nothing'.
|
|
getCurrentRoute :: GHandler sub master (Maybe (Route sub))
|
|
getCurrentRoute = handlerRoute `liftM` ask
|
|
|
|
-- | Get the function to promote a route for a subsite to a route for the
|
|
-- master site.
|
|
getRouteToMaster :: GHandler sub master (Route sub -> Route master)
|
|
getRouteToMaster = handlerToMaster `liftM` ask
|
|
|
|
-- | Function used internally by Yesod in the process of converting a
|
|
-- 'GHandler' into an 'W.Application'. Should not be needed by users.
|
|
runHandler :: HasReps c
|
|
=> GHandler sub master c
|
|
-> (Route master -> [(Text, Text)] -> Text)
|
|
-> Maybe (Route sub)
|
|
-> (Route sub -> Route master)
|
|
-> master
|
|
-> sub
|
|
-> (Word64 -> FileUpload)
|
|
-> (Loc -> LogLevel -> LogStr -> IO ())
|
|
-> Bool -- ^ to eval body?
|
|
-> YesodApp
|
|
runHandler handler mrender sroute tomr master sub upload log' toEval =
|
|
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
|
|
, handlerUpload = upload
|
|
, handlerLog = log'
|
|
}
|
|
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
|
|
ec' <- if toEval then liftIO $ evaluateContent c else return (Right c)
|
|
case ec' of
|
|
Left e -> handleError e
|
|
Right c' -> 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
|
|
|
|
evaluateContent :: Content -> IO (Either ErrorResponse Content)
|
|
evaluateContent (ContentBuilder b mlen) = Control.Exception.handle f $ do
|
|
let lbs = toLazyByteString b
|
|
L.length lbs `seq` return (Right $ ContentBuilder (fromLazyByteString lbs) mlen)
|
|
where
|
|
f :: SomeException -> IO (Either ErrorResponse Content)
|
|
f = return . Left . InternalError . T.pack . show
|
|
evaluateContent c = return (Right c)
|
|
|
|
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 to the given route.
|
|
-- HTTP status code 303 for HTTP 1.1 clients and 302 for HTTP 1.0
|
|
-- This is the appropriate choice for a get-following-post
|
|
-- technique, which should be the usual use case.
|
|
--
|
|
-- If you want direct control of the final status code, or need a different
|
|
-- status code, please use 'redirectWith'.
|
|
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
|
|
|
|
-- | Redirect to the given URL with the specified status code.
|
|
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"
|
|
|
|
-- | Sets the ultimate destination variable to the given route.
|
|
--
|
|
-- An ultimate destination is stored in the user session and can be loaded
|
|
-- later by 'redirectUltDest'.
|
|
setUltDest :: RedirectUrl master url => url -> GHandler sub master ()
|
|
setUltDest url = do
|
|
urlText <- toTextUrl url
|
|
setSession ultDestKey urlText
|
|
|
|
-- | Same as 'setUltDest', but uses the current page.
|
|
--
|
|
-- If this is a 404 handler, there is no current page, and then this call does
|
|
-- nothing.
|
|
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')
|
|
|
|
-- | Sets the ultimate destination to the referer request header, if present.
|
|
--
|
|
-- This function will not overwrite an existing ultdest.
|
|
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
|
|
|
|
-- | Redirect to the ultimate destination in the user's session. Clear the
|
|
-- value from the session.
|
|
--
|
|
-- The ultimate destination is set with 'setUltDest'.
|
|
--
|
|
-- This function uses 'redirect', and thus will perform a temporary redirect to
|
|
-- a GET request.
|
|
redirectUltDest :: RedirectUrl master url
|
|
=> url -- ^ default destination if nothing in session
|
|
-> GHandler sub master a
|
|
redirectUltDest def = do
|
|
mdest <- lookupSession ultDestKey
|
|
deleteSession ultDestKey
|
|
maybe (redirect def) redirect mdest
|
|
|
|
-- | Remove a previously set ultimate destination. See 'setUltDest'.
|
|
clearUltDest :: GHandler sub master ()
|
|
clearUltDest = deleteSession ultDestKey
|
|
|
|
msgKey :: Text
|
|
msgKey = "_MSG"
|
|
|
|
-- | Sets a message in the user's session.
|
|
--
|
|
-- See 'getMessage'.
|
|
setMessage :: Html -> GHandler sub master ()
|
|
setMessage = setSession msgKey . T.concat . TL.toChunks . RenderText.renderHtml
|
|
|
|
-- | Sets a message in the user's session.
|
|
--
|
|
-- See 'getMessage'.
|
|
setMessageI :: (RenderMessage y msg) => msg -> GHandler sub y ()
|
|
setMessageI msg = do
|
|
mr <- getMessageRender
|
|
setMessage $ toHtml $ mr msg
|
|
|
|
-- | Gets the message in the user's session, if available, and then clears the
|
|
-- variable.
|
|
--
|
|
-- See 'setMessage'.
|
|
getMessage :: GHandler sub master (Maybe Html)
|
|
getMessage = do
|
|
mmsg <- liftM (fmap preEscapedText) $ lookupSession msgKey
|
|
deleteSession msgKey
|
|
return mmsg
|
|
|
|
-- | Bypass remaining handler code and output the given file.
|
|
--
|
|
-- For some backends, this is more efficient than reading in the file to
|
|
-- memory, since they can optimize file sending via a system call to sendfile.
|
|
sendFile :: ContentType -> FilePath -> GHandler sub master a
|
|
sendFile ct fp = liftIO . throwIO $ HCSendFile ct fp Nothing
|
|
|
|
-- | Same as 'sendFile', but only sends part of a file.
|
|
sendFilePart :: ContentType
|
|
-> FilePath
|
|
-> Integer -- ^ offset
|
|
-> Integer -- ^ count
|
|
-> GHandler sub master a
|
|
sendFilePart ct fp off count =
|
|
liftIO . throwIO $ HCSendFile ct fp $ Just $ W.FilePart off count
|
|
|
|
-- | Bypass remaining handler code and output the given content with a 200
|
|
-- status code.
|
|
sendResponse :: HasReps c => c -> GHandler sub master a
|
|
sendResponse = liftIO . throwIO . HCContent H.status200
|
|
. chooseRep
|
|
|
|
-- | Bypass remaining handler code and output the given content with the given
|
|
-- status code.
|
|
sendResponseStatus :: HasReps c => H.Status -> c -> GHandler s m a
|
|
sendResponseStatus s = liftIO . throwIO . HCContent s
|
|
. chooseRep
|
|
|
|
-- | Send a 201 "Created" response with the given route as the Location
|
|
-- response header.
|
|
sendResponseCreated :: Route m -> GHandler s m a
|
|
sendResponseCreated url = do
|
|
r <- getUrlRender
|
|
liftIO . throwIO $ HCCreated $ r url
|
|
|
|
-- | Send a 'W.Response'. Please note: this function is rarely
|
|
-- necessary, and will /disregard/ any changes to response headers and session
|
|
-- that you have already specified. This function short-circuits. It should be
|
|
-- considered only for very specific needs. If you are not sure if you need it,
|
|
-- you don't.
|
|
sendWaiResponse :: W.Response -> GHandler s m b
|
|
sendWaiResponse = liftIO . throwIO . HCWai
|
|
|
|
-- | Return a 404 not found page. Also denotes no handler available.
|
|
notFound :: GHandler sub master a
|
|
notFound = hcError NotFound
|
|
|
|
-- | Return a 405 method not supported page.
|
|
badMethod :: GHandler sub master a
|
|
badMethod = do
|
|
w <- waiRequest
|
|
hcError $ BadMethod $ W.requestMethod w
|
|
|
|
-- | Return a 403 permission denied page.
|
|
permissionDenied :: Text -> GHandler sub master a
|
|
permissionDenied = hcError . PermissionDenied
|
|
|
|
-- | Return a 403 permission denied page.
|
|
permissionDeniedI :: RenderMessage master msg => msg -> GHandler sub master a
|
|
permissionDeniedI msg = do
|
|
mr <- getMessageRender
|
|
permissionDenied $ mr msg
|
|
|
|
-- | Return a 400 invalid arguments page.
|
|
invalidArgs :: [Text] -> GHandler sub master a
|
|
invalidArgs = hcError . InvalidArgs
|
|
|
|
-- | Return a 400 invalid arguments page.
|
|
invalidArgsI :: RenderMessage y msg => [msg] -> GHandler s y a
|
|
invalidArgsI msg = do
|
|
mr <- getMessageRender
|
|
invalidArgs $ map mr msg
|
|
|
|
------- Headers
|
|
-- | Set the cookie on the client.
|
|
|
|
setCookie :: SetCookie
|
|
-> GHandler sub master ()
|
|
setCookie = addHeader . AddCookie
|
|
|
|
-- | Helper function for setCookieExpires value
|
|
getExpires :: Int -- ^ minutes
|
|
-> IO UTCTime
|
|
getExpires m = do
|
|
now <- liftIO getCurrentTime
|
|
return $ fromIntegral (m * 60) `addUTCTime` now
|
|
|
|
|
|
-- | Unset the cookie on the client.
|
|
--
|
|
-- Note: although the value used for key and path is 'Text', you should only
|
|
-- use ASCII values to be HTTP compliant.
|
|
deleteCookie :: Text -- ^ key
|
|
-> Text -- ^ path
|
|
-> GHandler sub master ()
|
|
deleteCookie a = addHeader . DeleteCookie (encodeUtf8 a) . encodeUtf8
|
|
|
|
|
|
-- | Set the language in the user session. Will show up in 'languages' on the
|
|
-- next request.
|
|
setLanguage :: Text -> GHandler sub master ()
|
|
setLanguage = setSession langKey
|
|
|
|
-- | Set an arbitrary response header.
|
|
--
|
|
-- Note that, while the data type used here is 'Text', you must provide only
|
|
-- ASCII value to be HTTP compliant.
|
|
setHeader :: Text -> Text -> GHandler sub master ()
|
|
setHeader a = addHeader . Header (encodeUtf8 a) . encodeUtf8
|
|
|
|
-- | Set the Cache-Control header to indicate this response should be cached
|
|
-- for the given number of seconds.
|
|
cacheSeconds :: Int -> GHandler s m ()
|
|
cacheSeconds i = setHeader "Cache-Control" $ T.concat
|
|
[ "max-age="
|
|
, T.pack $ show i
|
|
, ", public"
|
|
]
|
|
|
|
-- | Set the Expires header to some date in 2037. In other words, this content
|
|
-- is never (realistically) expired.
|
|
neverExpires :: GHandler s m ()
|
|
neverExpires = setHeader "Expires" "Thu, 31 Dec 2037 23:55:55 GMT"
|
|
|
|
-- | Set an Expires header in the past, meaning this content should not be
|
|
-- cached.
|
|
alreadyExpired :: GHandler s m ()
|
|
alreadyExpired = setHeader "Expires" "Thu, 01 Jan 1970 05:05:05 GMT"
|
|
|
|
-- | Set an Expires header to the given date.
|
|
expiresAt :: UTCTime -> GHandler s m ()
|
|
expiresAt = setHeader "Expires" . formatRFC1123
|
|
|
|
-- | Set a variable in the user's session.
|
|
--
|
|
-- The session is handled by the clientsession package: it sets an encrypted
|
|
-- and hashed cookie on the client. This ensures that all data is secure and
|
|
-- not tampered with.
|
|
setSession :: Text -- ^ key
|
|
-> Text -- ^ value
|
|
-> GHandler sub master ()
|
|
setSession k = setSessionBS k . encodeUtf8
|
|
|
|
-- | Same as 'setSession', but uses binary data for the value.
|
|
setSessionBS :: Text
|
|
-> S.ByteString
|
|
-> GHandler sub master ()
|
|
setSessionBS k = modify . modSession . Map.insert k
|
|
|
|
-- | Unsets a session variable. See 'setSession'.
|
|
deleteSession :: Text -> GHandler sub master ()
|
|
deleteSession = modify . modSession . Map.delete
|
|
|
|
-- | Clear all session variables.
|
|
--
|
|
-- Since: 1.0.1
|
|
clearSession :: GHandler sub master ()
|
|
clearSession = modify $ \x -> x { ghsSession = Map.empty }
|
|
|
|
modSession :: (SessionMap -> SessionMap) -> GHState -> GHState
|
|
modSession f x = x { ghsSession = f $ ghsSession x }
|
|
|
|
-- | Internal use only, not to be confused with 'setHeader'.
|
|
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
|
|
|
|
-- | Some value which can be turned into a URL for redirects.
|
|
class RedirectUrl master a where
|
|
-- | Converts the value to the URL and a list of query-string parameters.
|
|
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 })
|
|
|
|
-- | Lookup for session data.
|
|
lookupSession :: Text -> GHandler s m (Maybe Text)
|
|
lookupSession = (fmap . fmap) (decodeUtf8With lenientDecode) . lookupSessionBS
|
|
|
|
-- | Lookup for session data in binary format.
|
|
lookupSessionBS :: Text -> GHandler s m (Maybe S.ByteString)
|
|
lookupSessionBS n = do
|
|
m <- liftM ghsSession get
|
|
return $ Map.lookup n m
|
|
|
|
-- | Get all session variables.
|
|
getSession :: GHandler sub master SessionMap
|
|
getSession = liftM ghsSession get
|
|
|
|
handlerToYAR :: (HasReps a, HasReps b)
|
|
=> master -- ^ master site foundation
|
|
-> sub -- ^ sub site foundation
|
|
-> (Word64 -> FileUpload)
|
|
-> (Loc -> LogLevel -> LogStr -> IO ())
|
|
-> Bool -- ^ to eval body?
|
|
-> (Route sub -> Route master)
|
|
-> (Route master -> [(Text, Text)] -> Text) -- route renderer
|
|
-> (ErrorResponse -> GHandler sub master a)
|
|
-> Request
|
|
-> Maybe (Route sub)
|
|
-> SessionMap
|
|
-> GHandler sub master b
|
|
-> ResourceT IO YesodAppResult
|
|
handlerToYAR y s upload log' toEval toMasterRoute render errorHandler rr murl sessionMap h =
|
|
unYesodApp ya eh' rr types sessionMap
|
|
where
|
|
ya = runHandler h render murl toMasterRoute y s upload log' toEval
|
|
eh' er = runHandler (errorHandler' er) render murl toMasterRoute y s upload log' toEval
|
|
types = httpAccept $ reqWaiRequest rr
|
|
errorHandler' = localNoCurrent . errorHandler
|
|
|
|
yarToResponse :: YesodAppResult -> [(CI ByteString, ByteString)] -> 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
|
|
|
|
-- | Convert Header to a key/value pair.
|
|
headerToPair :: Header
|
|
-> (CI ByteString, ByteString)
|
|
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)
|
|
|
|
-- | Get a unique identifier.
|
|
newIdent :: GHandler sub master Text
|
|
newIdent = do
|
|
x <- get
|
|
let i' = ghsIdent x + 1
|
|
put x { ghsIdent = i' }
|
|
return $ T.pack $ 'h' : show i'
|
|
|
|
-- | Redirect to a POST resource.
|
|
--
|
|
-- This is not technically a redirect; instead, it returns an HTML page with a
|
|
-- POST form, and some Javascript to automatically submit the form. This can be
|
|
-- useful when you need to post a plain link somewhere that needs to cause
|
|
-- changes on the server.
|
|
redirectToPost :: RedirectUrl master url => url -> GHandler sub master a
|
|
redirectToPost url = do
|
|
urlText <- toTextUrl url
|
|
hamletToRepHtml [hamlet|
|
|
$newline never
|
|
$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
|
|
|
|
-- | Converts the given Hamlet template into 'Content', which can be used in a
|
|
-- Yesod 'Response'.
|
|
hamletToContent :: HtmlUrl (Route master) -> GHandler sub master Content
|
|
hamletToContent h = do
|
|
render <- getUrlRenderParams
|
|
return $ toContent $ h render
|
|
|
|
-- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'.
|
|
hamletToRepHtml :: HtmlUrl (Route master) -> GHandler sub master RepHtml
|
|
hamletToRepHtml = liftM RepHtml . hamletToContent
|
|
|
|
-- | Get the request\'s 'W.Request' value.
|
|
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
|
|
|
|
-- | The standard @MonadTrans@ class only allows lifting for monad
|
|
-- transformers. While @GHandler@ and @GWidget@ should allow lifting, their
|
|
-- types do not express that they actually are transformers. This replacement
|
|
-- class accounts for this.
|
|
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
|
|
|
|
-- Instances for GHandler
|
|
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
|
|
|
|
instance MonadLogger (GHandler sub master) where
|
|
monadLoggerLog a b c = do
|
|
hd <- ask
|
|
liftIO $ handlerLog hd a b (toLogStr c)
|