137 lines
4.3 KiB
Haskell
137 lines
4.3 KiB
Haskell
{-# LANGUAGE QuasiQuotes #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE CPP #-}
|
|
{-# LANGUAGE TemplateHaskell #-}
|
|
{-# LANGUAGE PatternGuards #-}
|
|
{-# LANGUAGE FlexibleInstances #-}
|
|
-- | The basic typeclass for a Yesod application.
|
|
module Yesod.Internal.Core
|
|
( -- * Type classes
|
|
Yesod (..)
|
|
, YesodDispatch (..)
|
|
, RenderRoute (..)
|
|
-- ** Breadcrumbs
|
|
, YesodBreadcrumbs (..)
|
|
, breadcrumbs
|
|
-- * Utitlities
|
|
, maybeAuthorized
|
|
, widgetToPageContent
|
|
-- * Defaults
|
|
, defaultErrorHandler
|
|
-- * Data types
|
|
, AuthResult (..)
|
|
-- * Sessions
|
|
, SessionBackend (..)
|
|
, defaultClientSessionBackend
|
|
, clientSessionBackend
|
|
, loadClientSession
|
|
, clientSessionDateCacher
|
|
-- * jsLoader
|
|
, ScriptLoadPosition (..)
|
|
, BottomOfHeadAsync
|
|
-- * Misc
|
|
, yesodVersion
|
|
, yesodRender
|
|
, resolveApproot
|
|
, Approot (..)
|
|
, FileUpload (..)
|
|
, runFakeHandler
|
|
) where
|
|
|
|
import Yesod.Content
|
|
import Yesod.Handler hiding (lift, getExpires)
|
|
|
|
import Yesod.Routes.Class
|
|
|
|
import qualified Network.Wai as W
|
|
import Yesod.Internal.Session
|
|
import Yesod.Core.Internal.Request
|
|
import Data.Text (Text)
|
|
import qualified Paths_yesod_core
|
|
import Data.Version (showVersion)
|
|
import System.Log.FastLogger (Logger)
|
|
import Yesod.Core.Types
|
|
import Yesod.Core.Class
|
|
import Yesod.Core.Run
|
|
|
|
yesodVersion :: String
|
|
yesodVersion = showVersion Paths_yesod_core.version
|
|
|
|
-- | A type-safe, concise method of creating breadcrumbs for pages. For each
|
|
-- resource, you declare the title of the page and the parent resource (if
|
|
-- present).
|
|
class YesodBreadcrumbs y where
|
|
-- | Returns the title and the parent resource, if available. If you return
|
|
-- a 'Nothing', then this is considered a top-level page.
|
|
breadcrumb :: Route y -> GHandler sub y (Text , Maybe (Route y))
|
|
|
|
-- | Gets the title of the current page and the hierarchy of parent pages,
|
|
-- along with their respective titles.
|
|
breadcrumbs :: YesodBreadcrumbs y => GHandler sub y (Text, [(Route y, Text)])
|
|
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
|
|
|
|
-- | Return the same URL if the user is authorized to see it.
|
|
--
|
|
-- Built on top of 'isAuthorized'. This is useful for building page that only
|
|
-- contain links to pages the user is allowed to see.
|
|
maybeAuthorized :: Yesod a
|
|
=> Route a
|
|
-> Bool -- ^ is this a write request?
|
|
-> GHandler s a (Maybe (Route a))
|
|
maybeAuthorized r isWrite = do
|
|
x <- isAuthorized r isWrite
|
|
return $ if x == Authorized then Just r else Nothing
|
|
|
|
-- | This class is automatically instantiated when you use the template haskell
|
|
-- mkYesod function. You should never need to deal with it directly.
|
|
class YesodDispatch sub master where
|
|
yesodDispatch
|
|
:: Yesod master
|
|
=> Logger
|
|
-> master
|
|
-> sub
|
|
-> (Route sub -> Route master)
|
|
-> (Maybe (SessionBackend master) -> W.Application) -- ^ 404 handler
|
|
-> (Route sub -> Maybe (SessionBackend master) -> W.Application) -- ^ 405 handler
|
|
-> Text -- ^ request method
|
|
-> [Text] -- ^ pieces
|
|
-> Maybe (SessionBackend master)
|
|
-> W.Application
|
|
|
|
yesodRunner :: Yesod master
|
|
=> Logger
|
|
-> GHandler sub master ChooseRep
|
|
-> master
|
|
-> sub
|
|
-> Maybe (Route sub)
|
|
-> (Route sub -> Route master)
|
|
-> Maybe (SessionBackend master)
|
|
-> W.Application
|
|
yesodRunner logger handler master sub murl tomaster msb = defaultYesodRunner YesodRunnerEnv
|
|
{ yreLogger = logger
|
|
, yreMaster = master
|
|
, yreSub = sub
|
|
, yreRoute = murl
|
|
, yreToMaster = tomaster
|
|
, yreSessionBackend = msb
|
|
} handler
|
|
|
|
instance YesodDispatch WaiSubsite master where
|
|
yesodDispatch _logger _master (WaiSubsite app) _tomaster _404 _405 _method _pieces _session = app
|