77 lines
2.6 KiB
Haskell
77 lines
2.6 KiB
Haskell
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
{-# LANGUAGE RankNTypes #-}
|
|
{-# LANGUAGE ViewPatterns #-}
|
|
{-# LANGUAGE FlexibleInstances #-}
|
|
{-# LANGUAGE TypeFamilies #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
module Yesod.Core.Class.Dispatch where
|
|
|
|
import Yesod.Routes.Class
|
|
import qualified Network.Wai as W
|
|
import Yesod.Core.Types
|
|
import Yesod.Core.Content
|
|
import Yesod.Core.Class.Yesod
|
|
import Yesod.Core.Class.Handler
|
|
import Yesod.Core.Internal.Request (textQueryString)
|
|
import Yesod.Core.Internal.Run
|
|
import Control.Monad.Trans.Control (MonadBaseControl)
|
|
|
|
-- | 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
|
|
=> YesodRunnerEnv sub master
|
|
-> W.Application
|
|
|
|
instance YesodDispatch WaiSubsite master where
|
|
yesodDispatch YesodRunnerEnv { yreSub = WaiSubsite app } req =
|
|
app req
|
|
|
|
class YesodSubDispatch sub m where
|
|
yesodSubDispatch
|
|
:: (HandlerError m, HandlerState m, master ~ HandlerMaster m, Yesod master, MonadBaseControl IO m)
|
|
=> (m TypedContent
|
|
-> YesodRunnerEnv master master
|
|
-> Maybe (Route master)
|
|
-> W.Application)
|
|
-> (master -> sub)
|
|
-> (Route sub -> Route master)
|
|
-> YesodRunnerEnv master master
|
|
-> W.Application
|
|
|
|
instance YesodSubDispatch WaiSubsite master where
|
|
yesodSubDispatch _ toSub _ YesodRunnerEnv { yreMaster = master } req =
|
|
app req
|
|
where
|
|
WaiSubsite app = toSub master
|
|
|
|
{-
|
|
subHelper :: Yesod master => (YesodRunnerEnv sub master -> W.Application)
|
|
-> (forall res. ToTypedContent res
|
|
=> m res
|
|
-> YesodRunnerEnv master master
|
|
-> Maybe (Route master)
|
|
-> W.Application)
|
|
-> (master -> sub)
|
|
-> (Route sub -> Route master)
|
|
-> W.Application
|
|
subHelper runBase getSub toMaster = error "subHelper"
|
|
-}
|
|
|
|
subHelper :: (HandlerMaster m ~ master, HandlerState m, MonadBaseControl IO m)
|
|
=> (m TypedContent
|
|
-> YesodRunnerEnv master master
|
|
-> Maybe (Route master)
|
|
-> W.Application)
|
|
-> (master -> sub)
|
|
-> (Route sub -> Route master)
|
|
-> HandlerT sub m TypedContent
|
|
-> YesodRunnerEnv master master
|
|
-> Maybe (Route sub)
|
|
-> W.Application
|
|
subHelper parentRunner getSub toMaster handlert env route =
|
|
parentRunner base env (fmap toMaster route)
|
|
where
|
|
base = stripHandlerT (fmap toTypedContent handlert) getSub toMaster route
|