{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts  #-}
module Yesod.Core.Class.Dispatch where

import qualified Network.Wai as W
import Yesod.Core.Types
import Yesod.Core.Content (ToTypedContent (..))
import Yesod.Core.Handler (sendWaiApplication)
import Yesod.Core.Class.Yesod

-- | This class is automatically instantiated when you use the template haskell
-- mkYesod function. You should never need to deal with it directly.
class Yesod site => YesodDispatch site where
    yesodDispatch :: YesodRunnerEnv site -> W.Application

class YesodSubDispatch sub master where
    yesodSubDispatch :: YesodSubRunnerEnv sub master -> W.Application

instance YesodSubDispatch WaiSubsite master where
    yesodSubDispatch :: YesodSubRunnerEnv WaiSubsite master -> Application
yesodSubDispatch YesodSubRunnerEnv {YesodRunnerEnv master
master -> WaiSubsite
Route WaiSubsite -> Route master
ParentRunner master
ysreParentEnv :: forall sub parent.
YesodSubRunnerEnv sub parent -> YesodRunnerEnv parent
ysreToParentRoute :: forall sub parent.
YesodSubRunnerEnv sub parent -> Route sub -> Route parent
ysreGetSub :: forall sub parent. YesodSubRunnerEnv sub parent -> parent -> sub
ysreParentRunner :: forall sub parent.
YesodSubRunnerEnv sub parent -> ParentRunner parent
ysreParentEnv :: YesodRunnerEnv master
ysreToParentRoute :: Route WaiSubsite -> Route master
ysreGetSub :: master -> WaiSubsite
ysreParentRunner :: ParentRunner master
..} = Application
app
      where
        WaiSubsite Application
app = master -> WaiSubsite
ysreGetSub (master -> WaiSubsite) -> master -> WaiSubsite
forall a b. (a -> b) -> a -> b
$ YesodRunnerEnv master -> master
forall site. YesodRunnerEnv site -> site
yreSite YesodRunnerEnv master
ysreParentEnv

instance YesodSubDispatch WaiSubsiteWithAuth master where
  yesodSubDispatch :: YesodSubRunnerEnv WaiSubsiteWithAuth master -> Application
yesodSubDispatch YesodSubRunnerEnv {YesodRunnerEnv master
master -> WaiSubsiteWithAuth
Route WaiSubsiteWithAuth -> Route master
ParentRunner master
ysreParentEnv :: YesodRunnerEnv master
ysreToParentRoute :: Route WaiSubsiteWithAuth -> Route master
ysreGetSub :: master -> WaiSubsiteWithAuth
ysreParentRunner :: ParentRunner master
ysreParentEnv :: forall sub parent.
YesodSubRunnerEnv sub parent -> YesodRunnerEnv parent
ysreToParentRoute :: forall sub parent.
YesodSubRunnerEnv sub parent -> Route sub -> Route parent
ysreGetSub :: forall sub parent. YesodSubRunnerEnv sub parent -> parent -> sub
ysreParentRunner :: forall sub parent.
YesodSubRunnerEnv sub parent -> ParentRunner parent
..} Request
req =
      ParentRunner master
ysreParentRunner HandlerFor master TypedContent
handlert YesodRunnerEnv master
ysreParentEnv ((Route WaiSubsiteWithAuth -> Route master)
-> Maybe (Route WaiSubsiteWithAuth) -> Maybe (Route master)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Route WaiSubsiteWithAuth -> Route master
ysreToParentRoute Maybe (Route WaiSubsiteWithAuth)
route) Request
req
    where
      route :: Maybe (Route WaiSubsiteWithAuth)
route = Route WaiSubsiteWithAuth -> Maybe (Route WaiSubsiteWithAuth)
forall a. a -> Maybe a
Just (Route WaiSubsiteWithAuth -> Maybe (Route WaiSubsiteWithAuth))
-> Route WaiSubsiteWithAuth -> Maybe (Route WaiSubsiteWithAuth)
forall a b. (a -> b) -> a -> b
$ [Text] -> [(Text, Text)] -> Route WaiSubsiteWithAuth
WaiSubsiteWithAuthRoute (Request -> [Text]
W.pathInfo Request
req) []
      WaiSubsiteWithAuth Application
set = master -> WaiSubsiteWithAuth
ysreGetSub (master -> WaiSubsiteWithAuth) -> master -> WaiSubsiteWithAuth
forall a b. (a -> b) -> a -> b
$ YesodRunnerEnv master -> master
forall site. YesodRunnerEnv site -> site
yreSite (YesodRunnerEnv master -> master)
-> YesodRunnerEnv master -> master
forall a b. (a -> b) -> a -> b
$ YesodRunnerEnv master
ysreParentEnv
      handlert :: HandlerFor master TypedContent
handlert = Application -> HandlerFor master TypedContent
forall (m :: * -> *) b. MonadHandler m => Application -> m b
sendWaiApplication Application
set

subHelper
  :: ToTypedContent content
  => SubHandlerFor child master content
  -> YesodSubRunnerEnv child master
  -> Maybe (Route child)
  -> W.Application
subHelper :: SubHandlerFor child master content
-> YesodSubRunnerEnv child master
-> Maybe (Route child)
-> Application
subHelper (SubHandlerFor HandlerData child master -> IO content
f) YesodSubRunnerEnv {YesodRunnerEnv master
master -> child
Route child -> Route master
ParentRunner master
ysreParentEnv :: YesodRunnerEnv master
ysreToParentRoute :: Route child -> Route master
ysreGetSub :: master -> child
ysreParentRunner :: ParentRunner master
ysreParentEnv :: forall sub parent.
YesodSubRunnerEnv sub parent -> YesodRunnerEnv parent
ysreToParentRoute :: forall sub parent.
YesodSubRunnerEnv sub parent -> Route sub -> Route parent
ysreGetSub :: forall sub parent. YesodSubRunnerEnv sub parent -> parent -> sub
ysreParentRunner :: forall sub parent.
YesodSubRunnerEnv sub parent -> ParentRunner parent
..} Maybe (Route child)
mroute =
    ParentRunner master
ysreParentRunner HandlerFor master TypedContent
handler YesodRunnerEnv master
ysreParentEnv ((Route child -> Route master)
-> Maybe (Route child) -> Maybe (Route master)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Route child -> Route master
ysreToParentRoute Maybe (Route child)
mroute)
  where
    handler :: HandlerFor master TypedContent
handler = (content -> TypedContent)
-> HandlerFor master content -> HandlerFor master TypedContent
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap content -> TypedContent
forall a. ToTypedContent a => a -> TypedContent
toTypedContent (HandlerFor master content -> HandlerFor master TypedContent)
-> HandlerFor master content -> HandlerFor master TypedContent
forall a b. (a -> b) -> a -> b
$ (HandlerData master master -> IO content)
-> HandlerFor master content
forall site a. (HandlerData site site -> IO a) -> HandlerFor site a
HandlerFor ((HandlerData master master -> IO content)
 -> HandlerFor master content)
-> (HandlerData master master -> IO content)
-> HandlerFor master content
forall a b. (a -> b) -> a -> b
$ \HandlerData master master
hd ->
      let rhe :: RunHandlerEnv master master
rhe = HandlerData master master -> RunHandlerEnv master master
forall child site.
HandlerData child site -> RunHandlerEnv child site
handlerEnv HandlerData master master
hd
          rhe' :: RunHandlerEnv child master
rhe' = RunHandlerEnv master master
rhe
            { rheRoute :: Maybe (Route child)
rheRoute = Maybe (Route child)
mroute
            , rheChild :: child
rheChild = master -> child
ysreGetSub (master -> child) -> master -> child
forall a b. (a -> b) -> a -> b
$ YesodRunnerEnv master -> master
forall site. YesodRunnerEnv site -> site
yreSite YesodRunnerEnv master
ysreParentEnv
            , rheRouteToMaster :: Route child -> Route master
rheRouteToMaster = Route child -> Route master
ysreToParentRoute
            }
       in HandlerData child master -> IO content
f HandlerData master master
hd { handlerEnv :: RunHandlerEnv child master
handlerEnv = RunHandlerEnv child master
rhe' }