module Yesod.Handler
(
Route
, GHandler
, getYesod
, getYesodSub
, getUrlRender
, getUrlRenderParams
, getCurrentRoute
, getRouteToMaster
, RedirectType (..)
, redirect
, redirectParams
, redirectString
, notFound
, badMethod
, permissionDenied
, invalidArgs
, sendFile
, sendResponse
, setCookie
, deleteCookie
, setHeader
, setLanguage
, cacheSeconds
, neverExpires
, alreadyExpired
, expiresAt
, SessionMap
, lookupSession
, getSession
, setSession
, deleteSession
, setUltDest
, setUltDestString
, setUltDest'
, redirectUltDest
, setMessage
, getMessage
, runHandler
, YesodApp (..)
, toMasterHandler
, localNoCurrent
, HandlerData
, ErrorResponse (..)
#if TEST
, testSuite
#endif
) where
import Prelude hiding (catch)
import Yesod.Request
import Yesod.Internal
import Data.Neither
import Data.Time (UTCTime)
import Control.Exception hiding (Handler, catch, finally)
import qualified Control.Exception as E
import Control.Applicative
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 System.IO
import qualified Network.Wai as W
import Control.Failure (Failure (failure))
import Text.Hamlet
import Control.Monad.Invert (MonadInvertIO (..))
import Control.Monad (liftM)
import qualified Data.Map as Map
#if TEST
import Test.Framework (testGroup, Test)
import Test.Framework.Providers.HUnit (testCase)
import Test.HUnit hiding (Test)
import Yesod.Content hiding (testSuite)
import Data.IORef
#else
import Yesod.Content
#endif
type family Route a
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 route hd = hd
{ handlerSub = ts $ handlerMaster hd
, handlerToMaster = tm
, handlerRoute = Just route
}
toMasterHandler :: (Route sub -> Route master)
-> (master -> sub)
-> Route sub
-> GHandler sub master a
-> GHandler master master a
toMasterHandler tm ts route (GHandler h) =
GHandler $ withReaderT (handlerSubData tm ts route) h
newtype GHandler sub master a =
GHandler
{ unGHandler :: GHInner sub master a
}
deriving (Functor, Applicative, Monad, MonadIO)
type GHInner s m =
ReaderT (HandlerData s m) (
MEitherT HandlerContents (
WriterT (Endo [Header]) (
StateT SessionMap (
IO
))))
type SessionMap = Map.Map String String
instance MonadInvertIO (GHandler s m) where
newtype InvertedIO (GHandler s m) a =
InvGHandlerIO
{ runInvGHandlerIO :: InvertedIO (GHInner s m) a
}
type InvertedArg (GHandler s m) = (HandlerData s m, (SessionMap, ()))
invertIO = liftM (fmap InvGHandlerIO) . invertIO . unGHandler
revertIO f = GHandler $ revertIO $ liftM runInvGHandlerIO . f
type Endo a = a -> a
newtype YesodApp = YesodApp
{ unYesodApp
:: (ErrorResponse -> YesodApp)
-> Request
-> [ContentType]
-> SessionMap
-> IO (W.Status, [Header], ContentType, Content, SessionMap)
}
data HandlerContents =
HCContent ChooseRep
| HCError ErrorResponse
| HCSendFile ContentType FilePath
| HCRedirect RedirectType String
instance Failure ErrorResponse (GHandler sub master) where
failure = GHandler . lift . throwMEither . HCError
instance RequestReader (GHandler sub master) where
getRequest = handlerRequest <$> GHandler ask
getYesodSub :: GHandler sub master sub
getYesodSub = handlerSub <$> GHandler ask
getYesod :: GHandler sub master master
getYesod = handlerMaster <$> GHandler ask
getUrlRender :: GHandler sub master (Route master -> String)
getUrlRender = do
x <- handlerRender <$> GHandler ask
return $ flip x []
getUrlRenderParams :: GHandler sub master (Route master -> [(String, String)] -> String)
getUrlRenderParams = handlerRender <$> GHandler ask
getCurrentRoute :: GHandler sub master (Maybe (Route sub))
getCurrentRoute = handlerRoute <$> GHandler ask
getRouteToMaster :: GHandler sub master (Route sub -> Route master)
getRouteToMaster = handlerToMaster <$> GHandler ask
runHandler :: HasReps c
=> GHandler sub master c
-> (Route master -> [(String, String)] -> String)
-> Maybe (Route sub)
-> (Route sub -> Route master)
-> master
-> (master -> sub)
-> YesodApp
runHandler handler mrender sroute tomr ma tosa =
YesodApp $ \eh rr cts initSession -> do
let toErrorHandler =
InternalError
. (show :: Control.Exception.SomeException -> String)
let hd = HandlerData
{ handlerRequest = rr
, handlerSub = tosa ma
, handlerMaster = ma
, handlerRoute = sroute
, handlerRender = mrender
, handlerToMaster = tomr
}
((contents', headers), finalSession) <- E.catch (
flip runStateT initSession
$ runWriterT
$ runMEitherT
$ flip runReaderT hd
$ unGHandler handler
) (\e -> return ((MLeft $ HCError $ toErrorHandler e, id), initSession))
let contents = meither id (HCContent . chooseRep) contents'
let handleError e = do
(_, hs, ct, c, sess) <- unYesodApp (eh e) safeEh rr cts finalSession
let hs' = headers hs
return (getStatus e, hs', ct, c, sess)
let sendFile' ct fp =
return (W.status200, headers [], ct, W.ResponseFile fp, finalSession)
case contents of
HCContent a -> do
(ct, c) <- chooseRep a cts
return (W.status200, headers [], ct, c, finalSession)
HCError e -> handleError e
HCRedirect rt loc -> do
let hs = Header "Location" loc : headers []
return (getRedirectStatus rt, hs, typePlain, emptyContent,
finalSession)
HCSendFile ct fp -> E.catch
(sendFile' ct fp)
(handleError . toErrorHandler)
safeEh :: ErrorResponse -> YesodApp
safeEh er = YesodApp $ \_ _ _ session -> do
liftIO $ hPutStrLn stderr $ "Error handler errored out: " ++ show er
return (W.status500, [], typePlain, toContent "Internal Server Error",
session)
redirect :: RedirectType -> Route master -> GHandler sub master a
redirect rt url = redirectParams rt url []
redirectParams :: RedirectType -> Route master -> [(String, String)]
-> GHandler sub master a
redirectParams rt url params = do
r <- getUrlRenderParams
redirectString rt $ r url params
redirectString :: RedirectType -> String -> GHandler sub master a
redirectString rt = GHandler . lift . throwMEither . HCRedirect rt
ultDestKey :: String
ultDestKey = "_ULT"
setUltDest :: Route master -> GHandler sub master ()
setUltDest dest = do
render <- getUrlRender
setUltDestString $ render dest
setUltDestString :: String -> GHandler sub master ()
setUltDestString = setSession ultDestKey
setUltDest' :: GHandler sub master ()
setUltDest' = do
route <- getCurrentRoute
case route of
Nothing -> return ()
Just r -> do
tm <- getRouteToMaster
gets' <- reqGetParams <$> getRequest
render <- getUrlRenderParams
setUltDestString $ render (tm r) gets'
redirectUltDest :: RedirectType
-> Route master
-> GHandler sub master ()
redirectUltDest rt def = do
mdest <- lookupSession ultDestKey
deleteSession ultDestKey
maybe (redirect rt def) (redirectString rt) mdest
msgKey :: String
msgKey = "_MSG"
setMessage :: Html -> GHandler sub master ()
setMessage = setSession msgKey . lbsToChars . renderHtml
getMessage :: GHandler sub master (Maybe Html)
getMessage = do
mmsg <- fmap (fmap preEscapedString) $ lookupSession msgKey
deleteSession msgKey
return mmsg
sendFile :: ContentType -> FilePath -> GHandler sub master a
sendFile ct = GHandler . lift . throwMEither . HCSendFile ct
sendResponse :: HasReps c => c -> GHandler sub master a
sendResponse = GHandler . lift . throwMEither . HCContent . chooseRep
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 :: Int
-> String
-> String
-> GHandler sub master ()
setCookie a b = addHeader . AddCookie a b
deleteCookie :: String -> GHandler sub master ()
deleteCookie = addHeader . DeleteCookie
setLanguage :: String -> GHandler sub master ()
setLanguage = setSession langKey
setHeader :: String -> String -> GHandler sub master ()
setHeader a = addHeader . Header a
cacheSeconds :: Int -> GHandler s m ()
cacheSeconds i = setHeader "Cache-Control" $ concat
[ "max-age="
, 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 :: String
-> String
-> GHandler sub master ()
setSession k = GHandler . lift . lift . lift . modify . Map.insert k
deleteSession :: String -> GHandler sub master ()
deleteSession = GHandler . lift . lift . lift . modify . Map.delete
addHeader :: Header -> GHandler sub master ()
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 :: GHandler s m a -> GHandler s m a
localNoCurrent =
GHandler . local (\hd -> hd { handlerRoute = Nothing }) . unGHandler
lookupSession :: ParamName -> GHandler s m (Maybe ParamValue)
lookupSession n = GHandler $ do
m <- lift $ lift $ lift get
return $ Map.lookup n m
getSession :: GHandler s m SessionMap
getSession = GHandler $ lift $ lift $ lift get
#if TEST
testSuite :: Test
testSuite = testGroup "Yesod.Handler"
[
]
#endif