135 lines
4.1 KiB
Haskell
135 lines
4.1 KiB
Haskell
-- | The basic typeclass for a Yesod application.
|
|
module Yesod.Yesod
|
|
( Yesod (..)
|
|
, YesodApproot (..)
|
|
, applyLayout'
|
|
, applyLayoutJson
|
|
, getApproot
|
|
, toWaiApp
|
|
) where
|
|
|
|
import Data.Object.Html
|
|
import Data.Object.Json (unJsonDoc)
|
|
import Yesod.Response
|
|
import Yesod.Request
|
|
import Yesod.Definitions
|
|
import Yesod.Handler
|
|
import qualified Data.ByteString as B
|
|
|
|
import Data.Maybe (fromMaybe)
|
|
import Web.Mime
|
|
import Web.Encodings (parseHttpAccept)
|
|
|
|
import qualified Network.Wai as W
|
|
import Network.Wai.Middleware.CleanPath
|
|
import Network.Wai.Middleware.ClientSession
|
|
import Network.Wai.Middleware.Gzip
|
|
import Network.Wai.Middleware.Jsonp
|
|
import Network.Wai.Middleware.MethodOverride
|
|
|
|
class Yesod a where
|
|
-- | Please use the Quasi-Quoter, you\'ll be happier. For more information,
|
|
-- see the examples/fact.lhs sample.
|
|
resources :: Resource -> Verb -> Handler a ChooseRep
|
|
|
|
-- | The encryption key to be used for encrypting client sessions.
|
|
encryptKey :: a -> IO Word256
|
|
encryptKey _ = getKey defaultKeyFile
|
|
|
|
-- | Number of minutes before a client session times out. Defaults to
|
|
-- 120 (2 hours).
|
|
clientSessionDuration :: a -> Int
|
|
clientSessionDuration = const 120
|
|
|
|
-- | Output error response pages.
|
|
errorHandler :: ErrorResponse -> Handler a ChooseRep
|
|
errorHandler = defaultErrorHandler
|
|
|
|
-- | Applies some form of layout to <title> and <body> contents of a page.
|
|
applyLayout :: a
|
|
-> String -- ^ title
|
|
-> Html -- ^ body
|
|
-> Content
|
|
applyLayout _ t b = cs (cs (Tag "title" [] $ cs t, b) :: HtmlDoc)
|
|
|
|
class Yesod a => YesodApproot a where
|
|
-- | An absolute URL to the root of the application.
|
|
approot :: a -> Approot
|
|
|
|
-- | A convenience wrapper around 'applyLayout'.
|
|
applyLayout' :: Yesod y
|
|
=> String
|
|
-> Html
|
|
-> Handler y ChooseRep
|
|
applyLayout' t b = do
|
|
y <- getYesod
|
|
return $ chooseRep
|
|
[ (TypeHtml, applyLayout y t b)
|
|
]
|
|
|
|
-- | A convenience wrapper around 'applyLayout' which provides a JSON
|
|
-- representation of the body.
|
|
applyLayoutJson :: Yesod y
|
|
=> String
|
|
-> HtmlObject
|
|
-> Handler y ChooseRep
|
|
applyLayoutJson t b = do
|
|
y <- getYesod
|
|
return $ chooseRep
|
|
[ (TypeHtml, applyLayout y t $ cs b)
|
|
, (TypeJson, cs $ unJsonDoc $ cs b)
|
|
]
|
|
|
|
getApproot :: YesodApproot y => Handler y Approot
|
|
getApproot = approot `fmap` getYesod
|
|
|
|
defaultErrorHandler :: Yesod y
|
|
=> ErrorResponse
|
|
-> Handler y ChooseRep
|
|
defaultErrorHandler NotFound = do
|
|
--rr <- getRawRequest
|
|
applyLayout' "Not Found" $ cs $ toHtmlObject [("Not found", "FIXME")]
|
|
defaultErrorHandler PermissionDenied =
|
|
applyLayout' "Permission Denied" $ cs "Permission denied"
|
|
defaultErrorHandler (InvalidArgs ia) =
|
|
applyLayout' "Invalid Arguments" $ cs $ toHtmlObject
|
|
[ ("errorMsg", toHtmlObject "Invalid arguments")
|
|
, ("messages", toHtmlObject ia)
|
|
]
|
|
defaultErrorHandler (InternalError e) =
|
|
applyLayout' "Internal Server Error" $ cs $ toHtmlObject
|
|
[ ("Internal server error", e)
|
|
]
|
|
|
|
toWaiApp :: Yesod y => y -> IO W.Application
|
|
toWaiApp a = do
|
|
key <- encryptKey a
|
|
let mins = clientSessionDuration a
|
|
return $ gzip
|
|
$ jsonp
|
|
$ methodOverride
|
|
$ cleanPath
|
|
$ \thePath -> clientsession encryptedCookies key mins
|
|
$ toWaiApp' a thePath
|
|
|
|
toWaiApp' :: Yesod y
|
|
=> y
|
|
-> [B.ByteString]
|
|
-> [(B.ByteString, B.ByteString)]
|
|
-> W.Request
|
|
-> IO W.Response
|
|
toWaiApp' y resource session env = do
|
|
let types = httpAccept env
|
|
verb = cs $ W.requestMethod env :: Verb
|
|
handler = resources (map cs resource) verb
|
|
rr <- parseWaiRequest env session
|
|
res <- runHandler handler errorHandler rr y types
|
|
responseToWaiResponse res
|
|
|
|
httpAccept :: W.Request -> [ContentType]
|
|
httpAccept = map contentTypeFromBS
|
|
. parseHttpAccept
|
|
. fromMaybe B.empty
|
|
. lookup W.Accept
|
|
. W.httpHeaders
|