module Yesod.Dispatch
(
parseRoutes
, mkYesod
, mkYesodSub
, mkYesodData
, mkYesodSubData
, mkYesodDispatch
, mkYesodSubDispatch
, SinglePiece (..)
, MultiPiece (..)
, Strings
, toWaiApp
, toWaiAppPlain
) where
import Data.Either (partitionEithers)
import Prelude hiding (exp)
import Yesod.Core
import Yesod.Handler
import Yesod.Internal.Dispatch
import Web.Routes.Quasi
import Web.Routes.Quasi.Parse
import Web.Routes.Quasi.TH
import Language.Haskell.TH.Syntax
import qualified Network.Wai as W
import Network.Wai.Middleware.Jsonp
import Network.Wai.Middleware.Gzip
import qualified Data.ByteString.Char8 as B
import Data.ByteString.Lazy.Char8 ()
import Web.ClientSession
import Data.Char (isUpper)
import Web.Routes (decodePathInfo)
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 = do
let dropSlash ('/':x) = x
dropSlash x = x
let segments = decodePathInfo $ dropSlash $ B.unpack $ W.pathInfo env
case yesodDispatch y key' segments y id of
Just app -> app env
Nothing -> yesodRunner y y id key' Nothing notFound env