441 lines
15 KiB
Haskell
441 lines
15 KiB
Haskell
{-# LANGUAGE ExistentialQuantification #-}
|
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
{-# LANGUAGE FlexibleInstances #-}
|
|
{-# LANGUAGE TypeSynonymInstances #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE PackageImports #-}
|
|
{-# LANGUAGE TypeFamilies #-}
|
|
{-# LANGUAGE Rank2Types #-}
|
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
|
---------------------------------------------------------
|
|
--
|
|
-- Module : Yesod.Handler
|
|
-- Copyright : Michael Snoyman
|
|
-- License : BSD3
|
|
--
|
|
-- Maintainer : Michael Snoyman <michael@snoyman.com>
|
|
-- Stability : unstable
|
|
-- Portability : portable
|
|
--
|
|
-- Define Handler stuff.
|
|
--
|
|
---------------------------------------------------------
|
|
module Yesod.Handler
|
|
( -- * Type families
|
|
Route
|
|
-- * Handler monad
|
|
, Handler
|
|
, GHandler
|
|
-- ** Read information from handler
|
|
, getYesod
|
|
, getYesodSub
|
|
, getUrlRender
|
|
, getCurrentRoute
|
|
, getRouteToMaster
|
|
-- * Special responses
|
|
-- ** Redirecting
|
|
, RedirectType (..)
|
|
, redirect
|
|
, redirectParams
|
|
, redirectString
|
|
-- ** Errors
|
|
, notFound
|
|
, badMethod
|
|
, permissionDenied
|
|
, invalidArgs
|
|
-- ** Short-circuit responses.
|
|
, sendFile
|
|
, sendResponse
|
|
-- * Setting headers
|
|
, setCookie
|
|
, deleteCookie
|
|
, setHeader
|
|
, setLanguage
|
|
-- * Session
|
|
, setSession
|
|
, deleteSession
|
|
-- ** Ultimate destination
|
|
, setUltDest
|
|
, setUltDestString
|
|
, setUltDest'
|
|
, redirectUltDest
|
|
-- ** Messages
|
|
, setMessage
|
|
, getMessage
|
|
-- * Internal Yesod
|
|
, runHandler
|
|
, YesodApp (..)
|
|
, toMasterHandler
|
|
) where
|
|
|
|
import Prelude hiding (catch)
|
|
import Yesod.Request
|
|
import Yesod.Content
|
|
import Yesod.Internal
|
|
import Data.List (foldl', intercalate)
|
|
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
|
|
import Numeric (showIntAtBase)
|
|
import Data.Char (ord, chr)
|
|
|
|
-- | The type-safe URLs associated with a site argument.
|
|
type family Route a
|
|
|
|
data HandlerData sub master = HandlerData
|
|
{ handlerRequest :: Request
|
|
, handlerSub :: sub
|
|
, handlerMaster :: master
|
|
, handlerRoute :: Maybe (Route sub)
|
|
, handlerRender :: (Route master -> 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
|
|
}
|
|
|
|
-- | 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
|
|
-> Handler master a
|
|
toMasterHandler tm ts route (GHandler h) =
|
|
GHandler $ withReaderT (handlerSubData tm ts route) h
|
|
|
|
-- | A generic handler monad, which can have a different subsite and master
|
|
-- site. This monad is a combination of 'ReaderT' for basic arguments, a
|
|
-- 'WriterT' for headers and session, and an 'MEitherT' monad for handling
|
|
-- special responses. It is declared as a newtype to make compiler errors more
|
|
-- readable.
|
|
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
|
|
|
|
-- | A 'GHandler' limited to the case where the master and sub sites are the
|
|
-- same. This is the usual case for application writing; only code written
|
|
-- specifically as a subsite need been concerned with the more general variety.
|
|
type Handler yesod = GHandler yesod yesod
|
|
|
|
-- | 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]
|
|
-> 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
|
|
|
|
-- | Get the sub application argument.
|
|
getYesodSub :: GHandler sub master sub
|
|
getYesodSub = handlerSub <$> GHandler ask
|
|
|
|
-- | Get the master site appliation argument.
|
|
getYesod :: GHandler sub master master
|
|
getYesod = handlerMaster <$> GHandler ask
|
|
|
|
-- | Get the URL rendering function.
|
|
getUrlRender :: GHandler sub master (Route master -> String)
|
|
getUrlRender = handlerRender <$> GHandler 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 <$> GHandler 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 <$> 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
|
|
|
|
-- | 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 -> 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 to the given route.
|
|
redirect :: RedirectType -> Route master -> GHandler sub master a
|
|
redirect rt url = redirectParams rt url []
|
|
|
|
-- | Redirects to the given route with the associated query-string parameters.
|
|
redirectParams :: RedirectType -> Route master -> [(String, String)]
|
|
-> GHandler sub master a
|
|
redirectParams rt url params = do
|
|
r <- getUrlRender
|
|
redirectString rt $ r url ++
|
|
if null params then "" else '?' : encodeUrlPairs params
|
|
where
|
|
encodeUrlPairs = intercalate "&" . map encodeUrlPair
|
|
encodeUrlPair (x, []) = escape x
|
|
encodeUrlPair (x, y) = escape x ++ '=' : escape y
|
|
escape = concatMap escape'
|
|
escape' c
|
|
| 'A' < c && c < 'Z' = [c]
|
|
| 'a' < c && c < 'a' = [c]
|
|
| '0' < c && c < '9' = [c]
|
|
| c `elem` ".-~_" = [c]
|
|
| c == ' ' = "+"
|
|
| otherwise = '%' : myShowHex (ord c) ""
|
|
myShowHex :: Int -> ShowS
|
|
myShowHex n r = case showIntAtBase 16 toChrHex n r of
|
|
[] -> "00"
|
|
[c] -> ['0',c]
|
|
s -> s
|
|
toChrHex d
|
|
| d < 10 = chr (ord '0' + fromIntegral d)
|
|
| otherwise = chr (ord 'A' + fromIntegral (d - 10))
|
|
|
|
-- | Redirect to the given URL.
|
|
redirectString :: RedirectType -> String -> GHandler sub master a
|
|
redirectString rt = GHandler . lift . throwMEither . HCRedirect rt
|
|
|
|
ultDestKey :: String
|
|
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 :: Route master -> GHandler sub master ()
|
|
setUltDest dest = do
|
|
render <- getUrlRender
|
|
setUltDestString $ render dest
|
|
|
|
-- | Same as 'setUltDest', but use the given string.
|
|
setUltDestString :: String -> GHandler sub master ()
|
|
setUltDestString = setSession ultDestKey
|
|
|
|
-- | 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.
|
|
setUltDest' :: GHandler sub master ()
|
|
setUltDest' = do
|
|
route <- getCurrentRoute
|
|
tm <- getRouteToMaster
|
|
maybe (return ()) setUltDest $ tm <$> route
|
|
|
|
-- | Redirect to the ultimate destination in the user's session. Clear the
|
|
-- value from the session.
|
|
--
|
|
-- The ultimate destination is set with 'setUltDest'.
|
|
redirectUltDest :: RedirectType
|
|
-> Route master -- ^ default destination if nothing in session
|
|
-> GHandler sub master ()
|
|
redirectUltDest rt def = do
|
|
mdest <- lookupSession ultDestKey
|
|
deleteSession ultDestKey
|
|
maybe (redirect rt def) (redirectString rt) mdest
|
|
|
|
msgKey :: String
|
|
msgKey = "_MSG"
|
|
|
|
-- | Sets a message in the user's session.
|
|
--
|
|
-- The message set here will not be visible within the current request;
|
|
-- instead, it will only appear in the next request.
|
|
--
|
|
-- See 'getMessage'.
|
|
setMessage :: Html () -> GHandler sub master ()
|
|
setMessage = setSession msgKey . L.toString . renderHtml
|
|
|
|
-- | 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
|
|
deleteSession msgKey
|
|
fmap (fmap preEscapedString) $ lookupSession msgKey
|
|
|
|
-- | 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 = GHandler . lift . throwMEither . HCSendFile ct
|
|
|
|
-- | Bypass remaining handler code and output the given content.
|
|
sendResponse :: HasReps c => c -> GHandler sub master a
|
|
sendResponse = GHandler . lift . throwMEither . HCContent . chooseRep
|
|
|
|
-- | Return a 404 not found page. Also denotes no handler available.
|
|
notFound :: Failure ErrorResponse m => m a
|
|
notFound = failure NotFound
|
|
|
|
-- | Return a 405 method not supported page.
|
|
badMethod :: (RequestReader m, Failure ErrorResponse m) => m a
|
|
badMethod = do
|
|
w <- waiRequest
|
|
failure $ BadMethod $ toString $ W.requestMethod w
|
|
|
|
-- | Return a 403 permission denied page.
|
|
permissionDenied :: Failure ErrorResponse m => String -> m a
|
|
permissionDenied = failure . PermissionDenied
|
|
|
|
-- | Return a 400 invalid arguments page.
|
|
invalidArgs :: Failure ErrorResponse m => [String] -> m a
|
|
invalidArgs = failure . InvalidArgs
|
|
|
|
------- Headers
|
|
-- | Set the cookie on the client.
|
|
setCookie :: Int -- ^ minutes to timeout
|
|
-> String -- ^ key
|
|
-> String -- ^ value
|
|
-> GHandler sub master ()
|
|
setCookie a b = addHeader . AddCookie a b
|
|
|
|
-- | Unset the cookie on the client.
|
|
deleteCookie :: String -> GHandler sub master ()
|
|
deleteCookie = addHeader . DeleteCookie
|
|
|
|
-- | Set the language in the user session. Will show up in 'languages'.
|
|
setLanguage :: String -> GHandler sub master ()
|
|
setLanguage = setSession langKey
|
|
|
|
-- | Set an arbitrary header on the client.
|
|
setHeader :: String -> String -> GHandler sub master ()
|
|
setHeader a = addHeader . Header a
|
|
|
|
-- | 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 :: String -- ^ key
|
|
-> String -- ^ value
|
|
-> GHandler sub master ()
|
|
setSession k v = GHandler . lift . lift . lift . tell $ (:) (k, Just v)
|
|
|
|
-- | Unsets a session variable. See 'setSession'.
|
|
deleteSession :: String -> GHandler sub master ()
|
|
deleteSession k = GHandler . lift . lift . lift . tell $ (:) (k, Nothing)
|
|
|
|
-- | Internal use only, not to be confused with 'setHeader'.
|
|
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
|
|
|
|
-- | Different types of redirects.
|
|
data RedirectType = RedirectPermanent
|
|
| RedirectTemporary
|
|
| RedirectSeeOther
|
|
deriving (Show, Eq)
|