module Yesod.Yesod
(
Yesod (..)
, YesodSite (..)
, YesodSubSite (..)
, YesodPersist (..)
, module Database.Persist
, get404
, YesodBreadcrumbs (..)
, breadcrumbs
, maybeAuthorized
, widgetToPageContent
, defaultLayoutJson
, redirectToPost
, defaultErrorHandler
, AuthResult (..)
#if TEST
, testSuite
#endif
) where
#if TEST
import Yesod.Content hiding (testSuite)
import Yesod.Json hiding (testSuite)
import Yesod.Handler hiding (testSuite)
import qualified Data.ByteString.UTF8 as BSU
#else
import Yesod.Content
import Yesod.Json
import Yesod.Handler
#endif
import Yesod.Widget
import Yesod.Request
import Yesod.Hamlet
import qualified Network.Wai as W
import Yesod.Internal
import Web.ClientSession (getKey, defaultKeyFile)
import qualified Web.ClientSession as CS
import Database.Persist
import Control.Monad.Trans.Class (MonadTrans (..))
import Control.Failure (Failure)
import qualified Data.ByteString as S
import qualified Network.Wai.Middleware.CleanPath
import qualified Data.ByteString.Lazy as L
import Data.Monoid
import Control.Monad.Trans.Writer
import Control.Monad.Trans.State hiding (get)
import Text.Hamlet
import Text.Cassius
import Text.Julius
import Web.Routes
#if TEST
import Test.Framework (testGroup, Test)
import Test.Framework.Providers.HUnit
import Test.Framework.Providers.QuickCheck2 (testProperty)
import Test.HUnit hiding (Test)
#endif
class Eq (Route y) => YesodSite y where
getSite :: Site (Route y) (Method -> Maybe (GHandler y 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 :: GWidget sub a () -> GHandler sub a RepHtml
defaultLayout w = do
p <- widgetToPageContent w
mmsg <- getMessage
hamletToRepHtml [$hamlet|
!!!
%html
%head
%title $pageTitle.p$
^pageHead.p^
%body
$maybe mmsg msg
%p.message $msg$
^pageBody.p^
|]
onRequest :: GHandler sub a ()
onRequest = return ()
urlRenderOverride :: a -> Route a -> Maybe String
urlRenderOverride _ _ = Nothing
isAuthorized :: Route a
-> Bool
-> GHandler s a AuthResult
isAuthorized _ _ = return Authorized
isWriteRequest :: Route a -> GHandler s a Bool
isWriteRequest _ = do
wai <- waiRequest
return $ not $ W.requestMethod wai `elem`
["GET", "HEAD", "OPTIONS", "TRACE"]
authRoute :: a -> Maybe (Route a)
authRoute _ = Nothing
splitPath :: a -> S.ByteString -> Either S.ByteString [String]
splitPath _ = Network.Wai.Middleware.CleanPath.splitPath
joinPath :: a -> String -> [String] -> [(String, String)] -> String
joinPath _ ar pieces qs =
ar ++ '/' : encodePathInfo (fixSegs pieces) qs
where
fixSegs [] = []
fixSegs [x]
| any (== '.') x = [x]
| otherwise = [x, ""]
fixSegs (x:xs) = x : fixSegs xs
addStaticContent :: String
-> String
-> L.ByteString
-> GHandler sub a (Maybe (Either String (Route a, [(String, String)])))
addStaticContent _ _ _ = return Nothing
sessionIpAddress :: a -> Bool
sessionIpAddress _ = True
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
defaultLayoutJson :: Yesod master
=> GWidget sub master ()
-> Json
-> GHandler sub master RepHtmlJson
defaultLayoutJson w json = do
RepHtml html' <- defaultLayout w
json' <- jsonToContent json
return $ RepHtmlJson html' json'
applyLayout' :: Yesod master
=> Html
-> Hamlet (Route master)
-> GHandler sub master ChooseRep
applyLayout' title body = fmap chooseRep $ defaultLayout $ do
setTitle title
addHamlet body
defaultErrorHandler :: Yesod y => ErrorResponse -> GHandler sub y ChooseRep
defaultErrorHandler NotFound = do
r <- waiRequest
let path' = bsToChars $ pathInfo r
applyLayout' "Not Found" $ [$hamlet|
%h1 Not Found
%p $path'$
|]
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
-> Bool
-> GHandler s a (Maybe (Route a))
maybeAuthorized r isWrite = do
x <- isAuthorized r isWrite
return $ if x == Authorized then Just r else Nothing
widgetToPageContent :: (Eq (Route master), Yesod master)
=> GWidget sub master ()
-> GHandler sub master (PageContent (Route master))
widgetToPageContent (GWidget w) = do
w' <- flip evalStateT 0
$ runWriterT $ runWriterT $ runWriterT $ runWriterT
$ runWriterT $ runWriterT $ runWriterT w
let ((((((((),
Body body),
Last mTitle),
scripts'),
stylesheets'),
style),
jscript),
Head head') = w'
let title = maybe mempty unTitle mTitle
let scripts = map (locationToHamlet . unScript) $ runUniqueList scripts'
let stylesheets = map (locationToHamlet . unStylesheet)
$ runUniqueList stylesheets'
let cssToHtml (Css b) = Html b
celper :: Cassius url -> Hamlet url
celper = fmap cssToHtml
jsToHtml (Javascript b) = Html b
jelper :: Julius url -> Hamlet url
jelper = fmap jsToHtml
render <- getUrlRenderParams
let renderLoc x =
case x of
Nothing -> Nothing
Just (Left s) -> Just s
Just (Right (u, p)) -> Just $ render u p
cssLoc <-
case style of
Nothing -> return Nothing
Just s -> do
x <- addStaticContent "css" "text/css; charset=utf-8"
$ renderCassius render s
return $ renderLoc x
jsLoc <-
case jscript of
Nothing -> return Nothing
Just s -> do
x <- addStaticContent "js" "text/javascript; charset=utf-8"
$ renderJulius render s
return $ renderLoc x
let head'' = [$hamlet|
$forall scripts s
%script!src=^s^
$forall stylesheets s
%link!rel=stylesheet!href=^s^
$maybe style s
$maybe cssLoc s
%link!rel=stylesheet!href=$s$
$nothing
%style ^celper.s^
$maybe jscript j
$maybe jsLoc s
%script!src=$s$
$nothing
%script ^jelper.j^
^head'^
|]
return $ PageContent title head'' body
#if TEST
testSuite :: Test
testSuite = testGroup "Yesod.Yesod"
[ testProperty "join/split path" propJoinSplitPath
, testCase "utf8 split path" caseUtf8SplitPath
, testCase "utf8 join path" caseUtf8JoinPath
]
data TmpYesod = TmpYesod
data TmpRoute = TmpRoute deriving Eq
type instance Route TmpYesod = TmpRoute
instance Yesod TmpYesod where approot _ = ""
propJoinSplitPath :: [String] -> Bool
propJoinSplitPath ss =
splitPath TmpYesod (BSU.fromString $ joinPath TmpYesod "" ss' [])
== Right ss'
where
ss' = filter (not . null) ss
caseUtf8SplitPath :: Assertion
caseUtf8SplitPath = do
Right ["שלום"] @=?
splitPath TmpYesod (BSU.fromString "/שלום/")
Right ["page", "Fooé"] @=?
splitPath TmpYesod (BSU.fromString "/page/Fooé/")
Right ["\156"] @=?
splitPath TmpYesod (BSU.fromString "/\156/")
Right ["ð"] @=?
splitPath TmpYesod (BSU.fromString "/%C3%B0/")
caseUtf8JoinPath :: Assertion
caseUtf8JoinPath = do
"/%D7%A9%D7%9C%D7%95%D7%9D/" @=? joinPath TmpYesod "" ["שלום"] []
#endif
redirectToPost :: Route master -> GHandler sub master a
redirectToPost dest = hamletToRepHtml [$hamlet|
!!!
%html
%head
%title Redirecting...
%body!onload="document.getElementById('form').submit()"
%form#form!method=post!action=@dest@
%noscript
%p Javascript has been disabled; please click on the button below to be redirected.
%input!type=submit!value=Continue
|] >>= sendResponse