module Yesod.Dispatch
(
parseRoutes
, parseRoutesFile
, mkYesod
, mkYesodSub
, mkYesodData
, mkYesodSubData
, mkYesodDispatch
, mkYesodSubDispatch
, SinglePiece (..)
, MultiPiece (..)
, Texts
, toWaiApp
, toWaiAppPlain
) where
import Data.Functor ((<$>))
import Data.Either (partitionEithers)
import Prelude hiding (exp)
import Yesod.Internal.Core
import Yesod.Handler
import Yesod.Internal.Dispatch
import Yesod.Widget (GWidget)
import Web.PathPieces (SinglePiece (..), MultiPiece (..))
import Yesod.Internal.RouteParsing (THResource, Pieces (..), createRoutes, createRender, Resource (..), parseRoutes, parseRoutesFile)
import Language.Haskell.TH.Syntax
import qualified Network.Wai as W
import Network.Wai.Middleware.Jsonp
import Network.Wai.Middleware.Gzip
import Network.Wai.Middleware.Autohead
import Data.ByteString.Lazy.Char8 ()
import Web.ClientSession
import Data.Char (isUpper)
import Data.Text (Text)
type Texts = [Text]
mkYesod :: String
-> [Resource]
-> Q [Dec]
mkYesod name = fmap (uncurry (++)) . mkYesodGeneral name [] [] False
mkYesodSub :: String
-> Cxt
-> [Resource]
-> Q [Dec]
mkYesodSub name clazzes =
fmap (uncurry (++)) . mkYesodGeneral name' rest clazzes True
where
(name':rest) = words name
mkYesodData :: String -> [Resource] -> Q [Dec]
mkYesodData name res = mkYesodDataGeneral name [] False res
mkYesodSubData :: String -> Cxt -> [Resource] -> Q [Dec]
mkYesodSubData name clazzes res = mkYesodDataGeneral name clazzes True res
mkYesodDataGeneral :: String -> Cxt -> Bool -> [Resource] -> Q [Dec]
mkYesodDataGeneral name clazzes isSub res = do
let (name':rest) = words name
(x, _) <- mkYesodGeneral name' rest clazzes isSub res
let rname = mkName $ "resources" ++ name
eres <- lift res
let y = [ SigD rname $ ListT `AppT` ConT ''Resource
, FunD rname [Clause [] (NormalB eres) []]
]
return $ x ++ y
mkYesodDispatch :: String -> [Resource] -> Q [Dec]
mkYesodDispatch name = fmap snd . mkYesodGeneral name [] [] False
mkYesodSubDispatch :: String -> Cxt -> [Resource] -> Q [Dec]
mkYesodSubDispatch name clazzes = fmap snd . mkYesodGeneral name' rest clazzes True
where (name':rest) = words name
mkYesodGeneral :: String
-> [String]
-> Cxt
-> Bool
-> [Resource]
-> Q ([Dec], [Dec])
mkYesodGeneral name args clazzes isSub res = do
let args' = map mkName args
arg = foldl AppT (ConT name') $ map VarT args'
th' <- mapM thResourceFromResource res
let th = map fst th'
w' <- createRoutes th
let routesName = mkName $ name ++ "Route"
let w = DataD [] routesName [] w' [''Show, ''Read, ''Eq]
let x = TySynInstD ''Route [arg] $ ConT routesName
render <- createRender th
let x' = InstanceD [] (ConT ''RenderRoute `AppT` ConT routesName)
[ FunD (mkName "renderRoute") render
]
let splitter :: (THResource, Maybe String)
-> Either
(THResource, Maybe String)
(THResource, Maybe String)
splitter a@((_, SubSite{}), _) = Left a
splitter a = Right a
let (resSub, resLoc) = partitionEithers $ map splitter th'
yd <- mkYesodDispatch' resSub resLoc
let master = mkName "master"
let ctx = if isSub
then ClassP (mkName "Yesod") [VarT master] : clazzes
else []
let ytyp = if isSub
then ConT ''YesodDispatch `AppT` arg `AppT` VarT master
else ConT ''YesodDispatch `AppT` arg `AppT` arg
let y = InstanceD ctx ytyp [FunD (mkName "yesodDispatch") [yd]]
return ([w, x, x'] ++ masterTypSyns, [y])
where
name' = mkName name
masterTypSyns
| isSub = []
| otherwise =
[ TySynD
(mkName "Handler")
[]
(ConT ''GHandler `AppT` ConT name' `AppT` ConT name')
, TySynD
(mkName "Widget")
[]
(ConT ''GWidget `AppT` ConT name' `AppT` ConT name' `AppT` TupleT 0)
]
thResourceFromResource :: Resource -> Q (THResource, Maybe String)
thResourceFromResource (Resource n ps atts)
| all (all isUpper) atts = return ((n, Simple ps atts), Nothing)
thResourceFromResource (Resource n ps [stype, toSubArg]) = do
let stype' = ConT $ mkName stype
parse <- [|error "ssParse"|]
dispatch <- [|error "ssDispatch"|]
render <- [|renderRoute|]
tmg <- [|error "ssToMasterArg"|]
return ((n, SubSite
{ ssType = ConT ''Route `AppT` stype'
, ssParse = parse
, ssRender = render
, ssDispatch = dispatch
, ssToMasterArg = tmg
, ssPieces = ps
}), Just toSubArg)
thResourceFromResource (Resource n _ _) =
error $ "Invalid attributes for resource: " ++ n
toWaiApp :: (Yesod y, YesodDispatch y y) => y -> IO W.Application
toWaiApp y = gzip (gzipCompressFiles y) . jsonp . autohead <$> toWaiAppPlain y
toWaiAppPlain :: (Yesod y, YesodDispatch y y) => y -> IO W.Application
toWaiAppPlain a = toWaiApp' a <$> encryptKey a
toWaiApp' :: (Yesod y, YesodDispatch y y)
=> y
-> Maybe Key
-> W.Application
toWaiApp' y key' env =
case yesodDispatch y key' (W.pathInfo env) y id of
Just app -> app env
Nothing -> yesodRunner y y id key' Nothing notFound env