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
, setSession
, deleteSession
, setUltDest
, setUltDestString
, setUltDest'
, redirectUltDest
, setMessage
, getMessage
, runHandler
, YesodApp (..)
, toMasterHandler
, localNoCurrent
) where
import Prelude hiding (catch)
import Yesod.Request
import Yesod.Content
import Yesod.Internal
import Data.List (foldl')
import Data.Neither
import Control.Exception hiding (Handler, catch)
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 "MonadCatchIO-transformers" Control.Monad.CatchIO (MonadCatchIO)
import System.IO
import qualified Network.Wai as W
import Control.Monad.Attempt
import Data.ByteString.UTF8 (toString)
import qualified Data.ByteString.Lazy.UTF8 as L
import Text.Hamlet
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 ::
ReaderT (HandlerData sub master) (
MEitherT HandlerContents (
WriterT (Endo [Header]) (
WriterT (Endo [(String, Maybe String)]) (
IO
)))) a
}
deriving (Functor, Applicative, Monad, MonadIO, MonadCatchIO)
type Endo a = a -> a
newtype YesodApp = YesodApp
{ unYesodApp
:: (ErrorResponse -> YesodApp)
-> Request
-> [ContentType]
-> IO (W.Status, [Header], ContentType, Content, [(String, String)])
}
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
modifySession :: [(String, String)] -> (String, Maybe String)
-> [(String, String)]
modifySession orig (k, v) =
case v of
Nothing -> dropKeys k orig
Just v' -> (k, v') : dropKeys k orig
dropKeys :: String -> [(String, x)] -> [(String, x)]
dropKeys k = filter $ \(x, _) -> x /= k
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 -> 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), session') <- E.catch (
runWriterT
$ runWriterT
$ runMEitherT
$ flip runReaderT hd
$ unGHandler handler
) (\e -> return ((MLeft $ HCError $ toErrorHandler e, id), id))
let contents = meither id (HCContent . chooseRep) contents'
let finalSession = foldl' modifySession (reqSession rr) $ session' []
let handleError e = do
(_, hs, ct, c, sess) <- unYesodApp (eh e) safeEh rr cts
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 $ \_ _ _ -> do
liftIO $ hPutStrLn stderr $ "Error handler errored out: " ++ show er
return (W.status500, [], typePlain, toContent "Internal Server Error", [])
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 . L.toString . renderHtml
getMessage :: GHandler sub master (Maybe Html)
getMessage = do
deleteSession msgKey
fmap (fmap preEscapedString) $ lookupSession msgKey
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 $ toString $ 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
setSession :: String
-> String
-> GHandler sub master ()
setSession k v = GHandler . lift . lift . lift . tell $ (:) (k, Just v)
deleteSession :: String -> GHandler sub master ()
deleteSession k = GHandler . lift . lift . lift . tell $ (:) (k, Nothing)
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