module Yesod.Dispatch
(
parseRoutes
, parseRoutesFile
, mkYesod
, mkYesodSub
, mkYesodData
, mkYesodSubData
, mkYesodDispatch
, mkYesodSubDispatch
, SinglePiece (..)
, MultiPiece (..)
, Strings
, toWaiApp
, toWaiAppPlain
) where
import Data.Either (partitionEithers)
import Prelude hiding (exp)
import Yesod.Internal.Core
import Yesod.Handler
import Yesod.Internal.Dispatch
import Web.Routes.Quasi (SinglePiece, MultiPiece, Strings)
import Web.Routes.Quasi.Parse (Resource (..), parseRoutes, parseRoutesFile)
import Web.Routes.Quasi.TH (THResource, Pieces (..), createRoutes, createRender)
import Language.Haskell.TH.Syntax
import qualified Network.Wai as W
import Network.Wai.Middleware.Jsonp
import Network.Wai.Middleware.Gzip
import Data.ByteString.Lazy.Char8 ()
import Web.ClientSession
import Data.Char (isUpper)
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 name' = mkName name
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'], [y])
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 = do
a <- toWaiAppPlain y
return $ gzip False
$ jsonp
a
toWaiAppPlain :: (Yesod y, YesodDispatch y y) => y -> IO W.Application
toWaiAppPlain a = do
key' <- encryptKey a
return $ toWaiApp' a key'
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