module Yesod.Yesod
(
Yesod (..)
, YesodSite (..)
, YesodSubSite (..)
, YesodPersist (..)
, module Database.Persist
, get404
, YesodBreadcrumbs (..)
, breadcrumbs
, applyLayout
, applyLayoutJson
, maybeAuthorized
, defaultErrorHandler
, AuthResult (..)
) where
import Yesod.Content
import Yesod.Request
import Yesod.Hamlet
import Yesod.Handler
import qualified Network.Wai as W
import Yesod.Json
import Yesod.Internal
import Web.ClientSession (getKey, defaultKeyFile)
import qualified Web.ClientSession as CS
import Data.Monoid (mempty)
import Data.ByteString.UTF8 (toString)
import Database.Persist
import Web.Routes.Site (Site)
import Control.Monad.Trans.Class (MonadTrans (..))
import Control.Monad.Attempt (Failure)
class Eq (Route y) => YesodSite y where
getSite :: Site (Route y) (Method -> Maybe (Handler y ChooseRep))
type Method = String
class Eq (Route s) => YesodSubSite s y where
getSubSite :: Site (Route s) (Method -> Maybe (GHandler s y ChooseRep))
class Eq (Route a) => Yesod a where
approot :: a -> String
encryptKey :: a -> IO CS.Key
encryptKey _ = getKey defaultKeyFile
clientSessionDuration :: a -> Int
clientSessionDuration = const 120
errorHandler :: ErrorResponse -> GHandler sub a ChooseRep
errorHandler = defaultErrorHandler
defaultLayout :: PageContent (Route a) -> GHandler sub a Content
defaultLayout p = hamletToContent [$hamlet|
!!!
%html
%head
%title $pageTitle.p$
^pageHead.p^
%body
^pageBody.p^
|]
onRequest :: GHandler sub a ()
onRequest = return ()
urlRenderOverride :: a -> Route a -> Maybe String
urlRenderOverride _ _ = Nothing
isAuthorized :: Route a -> GHandler s a AuthResult
isAuthorized _ = return Authorized
authRoute :: a -> Maybe (Route a)
authRoute _ = Nothing
data AuthResult = Authorized | AuthenticationRequired | Unauthorized String
deriving (Eq, Show, Read)
class YesodBreadcrumbs y where
breadcrumb :: Route y -> GHandler sub y (String, Maybe (Route y))
breadcrumbs :: YesodBreadcrumbs y => GHandler sub y (String, [(Route y, String)])
breadcrumbs = do
x' <- getCurrentRoute
tm <- getRouteToMaster
let x = fmap tm x'
case x of
Nothing -> return ("Not found", [])
Just y -> do
(title, next) <- breadcrumb y
z <- go [] next
return (title, z)
where
go back Nothing = return back
go back (Just this) = do
(title, next) <- breadcrumb this
go ((this, title) : back) next
applyLayout :: Yesod master
=> String
-> Hamlet (Route master)
-> Hamlet (Route master)
-> GHandler sub master RepHtml
applyLayout t h b =
RepHtml `fmap` defaultLayout PageContent
{ pageTitle = string t
, pageHead = h
, pageBody = b
}
applyLayoutJson :: Yesod master
=> String
-> Hamlet (Route master)
-> Hamlet (Route master)
-> Json
-> GHandler sub master RepHtmlJson
applyLayoutJson t h html json = do
html' <- defaultLayout PageContent
{ pageTitle = string t
, pageHead = h
, pageBody = html
}
json' <- jsonToContent json
return $ RepHtmlJson html' json'
applyLayout' :: Yesod master
=> String
-> Hamlet (Route master)
-> GHandler sub master ChooseRep
applyLayout' s = fmap chooseRep . applyLayout s mempty
defaultErrorHandler :: Yesod y => ErrorResponse -> GHandler sub y ChooseRep
defaultErrorHandler NotFound = do
r <- waiRequest
applyLayout' "Not Found" $ [$hamlet|
%h1 Not Found
%p $toString.pathInfo.r$
|]
where
pathInfo = W.pathInfo
defaultErrorHandler (PermissionDenied msg) =
applyLayout' "Permission Denied" $ [$hamlet|
%h1 Permission denied
%p $msg$
|]
defaultErrorHandler (InvalidArgs ia) =
applyLayout' "Invalid Arguments" $ [$hamlet|
%h1 Invalid Arguments
%ul
$forall ia msg
%li $msg$
|]
defaultErrorHandler (InternalError e) =
applyLayout' "Internal Server Error" $ [$hamlet|
%h1 Internal Server Error
%p $e$
|]
defaultErrorHandler (BadMethod m) =
applyLayout' "Bad Method" $ [$hamlet|
%h1 Method Not Supported
%p Method "$m$" not supported
|]
class YesodPersist y where
type YesodDB y :: (* -> *) -> * -> *
runDB :: YesodDB y (GHandler sub y) a -> GHandler sub y a
get404 :: (PersistBackend (t m), PersistEntity val, Monad (t m),
Failure ErrorResponse m, MonadTrans t)
=> Key val -> t m val
get404 key = do
mres <- get key
case mres of
Nothing -> lift notFound
Just res -> return res
maybeAuthorized :: Yesod a => Route a -> GHandler s a (Maybe (Route a))
maybeAuthorized r = do
x <- isAuthorized r
return $ if x == Authorized then Just r else Nothing