module Yesod.Routes.TH.Dispatch
(
mkDispatchClause
, MkDispatchSettings (..)
, defaultGetHandler
) where
import Prelude hiding (exp)
import Yesod.Routes.TH.Types
import Language.Haskell.TH.Syntax
import Data.Maybe (catMaybes)
import Control.Monad (forM, replicateM)
import Data.Text (pack)
import qualified Yesod.Routes.Dispatch as D
import qualified Data.Map as Map
import Data.Char (toLower)
import Web.PathPieces (PathPiece (..), PathMultiPiece (..))
import Control.Applicative ((<$>))
import Data.List (foldl')
import Data.Text.Encoding (encodeUtf8)
data MkDispatchSettings = MkDispatchSettings
{ mdsRunHandler :: Q Exp
, mdsSubDispatcher :: Q Exp
, mdsGetPathInfo :: Q Exp
, mdsSetPathInfo :: Q Exp
, mdsMethod :: Q Exp
, mds404 :: Q Exp
, mds405 :: Q Exp
, mdsGetHandler :: Maybe String -> String -> Q Exp
}
defaultGetHandler :: Maybe String -> String -> Q Exp
defaultGetHandler Nothing s = return $ VarE $ mkName $ "handle" ++ s
defaultGetHandler (Just method) s = return $ VarE $ mkName $ map toLower method ++ s
mkDispatchClause :: MkDispatchSettings
-> [ResourceTree a]
-> Q Clause
mkDispatchClause mds ress' = do
getEnv0 <- newName "yesod_dispatch_env0"
req0 <- newName "req0"
pieces <- [|$(mdsGetPathInfo mds) $(return $ VarE req0)|]
dispatch <- newName "dispatch"
let dispatched = VarE dispatch `AppE` pieces
routes <- mapM (buildRoute mds) ress
toDispatch <- [|D.toDispatch|]
let dispatchFun = FunD dispatch
[Clause
[]
(NormalB $ toDispatch `AppE` ListE routes)
[]
]
let pats = map VarP [getEnv0, req0]
methodMaps <- catMaybes <$> mapM (buildMethodMap mds) ress
u <- [|case $(return dispatched) of
Just f -> f $(return $ VarE getEnv0)
$(return $ VarE req0)
Nothing -> $(mdsRunHandler mds)
$(mds404 mds)
$(return $ VarE getEnv0)
Nothing
$(return $ VarE req0)
|]
return $ Clause pats (NormalB u) $ dispatchFun : methodMaps
where
ress = flatten ress'
methodMapName :: String -> Name
methodMapName s = mkName $ "methods" ++ s
buildMethodMap :: MkDispatchSettings
-> FlatResource a
-> Q (Maybe Dec)
buildMethodMap _ (FlatResource _ _ _ (Methods _ [])) = return Nothing
buildMethodMap mds (FlatResource parents name pieces' (Methods mmulti methods)) = do
fromList <- [|Map.fromList|]
methods' <- mapM go methods
let exp = fromList `AppE` ListE methods'
let fun = FunD (methodMapName name) [Clause [] (NormalB exp) []]
return $ Just fun
where
pieces = concat $ map snd parents ++ [pieces']
go method = do
func <- mdsGetHandler mds (Just method) name
pack' <- [|encodeUtf8 . pack|]
let isDynamic Dynamic{} = True
isDynamic _ = False
let argCount = length (filter (isDynamic . snd) pieces) + maybe 0 (const 1) mmulti
xs <- replicateM argCount $ newName "arg"
runHandler <- mdsRunHandler mds
let rhs
| null xs = runHandler `AppE` func
| otherwise =
LamE (map VarP xs) $
runHandler `AppE` (foldl' AppE func $ map VarE xs)
return $ TupE
[ pack' `AppE` LitE (StringL method)
, rhs
]
buildMethodMap _ (FlatResource _ _ _ Subsite{}) = return Nothing
buildRoute :: MkDispatchSettings -> FlatResource a -> Q Exp
buildRoute mds (FlatResource parents name resPieces resDisp) = do
routePieces <- ListE <$> mapM (convertPiece . snd) allPieces
isMulti <-
case resDisp of
Methods Nothing _ -> [|False|]
_ -> [|True|]
[|D.Route
$(return routePieces)
$(return isMulti)
$(routeArg3
mds
parents
name
(map snd allPieces)
resDisp)
|]
where
allPieces = concat $ map snd parents ++ [resPieces]
routeArg3 :: MkDispatchSettings
-> [(String, [(CheckOverlap, Piece a)])]
-> String
-> [Piece a]
-> Dispatch a
-> Q Exp
routeArg3 mds parents name resPieces resDisp = do
pieces <- newName "pieces"
xs <- forM resPieces $ \piece ->
case piece of
Static _ -> return Nothing
Dynamic _ -> Just <$> newName "x"
ys <- forM (zip (catMaybes xs) [1..]) $ \(x, i) -> do
y <- newName $ "y" ++ show (i :: Int)
return (x, y)
xrest <- newName "xrest"
yrest <- newName "yrest"
pat <-
case resDisp of
Methods Nothing _ -> return $ ListP $ map (maybe WildP VarP) xs
_ -> do
let cons = mkName ":"
return $ foldr (\a b -> ConP cons [maybe WildP VarP a, b]) (VarP xrest) xs
fromPathPiece' <- [|fromPathPiece|]
xstmts <- forM ys $ \(x, y) -> return $ BindS (VarP y) (fromPathPiece' `AppE` VarE x)
(reststmts, yrest') <-
case resDisp of
Methods (Just _) _ -> do
fromPathMultiPiece' <- [|fromPathMultiPiece|]
return ([BindS (VarP yrest) (fromPathMultiPiece' `AppE` VarE xrest)], [yrest])
_ -> return ([], [])
caller <- buildCaller mds xrest parents name resDisp $ map snd ys ++ yrest'
just <- [|Just|]
let stmts = concat
[ xstmts
, reststmts
, [NoBindS $ just `AppE` caller]
]
errorMsg <- [|error "Invariant violated"|]
let matches =
[ Match pat (NormalB $ DoE stmts) []
, Match WildP (NormalB errorMsg) []
]
return $ LamE [VarP pieces] $ CaseE (VarE pieces) matches
buildCaller :: MkDispatchSettings
-> Name
-> [(String, [(CheckOverlap, Piece a)])]
-> String
-> Dispatch a
-> [Name]
-> Q Exp
buildCaller mds xrest parents name resDisp ys = do
getEnv <- newName "yesod_dispatch_env"
req <- newName "req"
method <- [|$(mdsMethod mds) $(return $ VarE req)|]
let pat = map VarP [getEnv, req]
let route = routeFromDynamics parents name ys
exp <-
case resDisp of
Methods _ ms -> do
handler <- newName "handler"
env <- [|$(return $ VarE getEnv) (Just $(return route))|]
runner <- [|$(return $ VarE handler)
$(return $ VarE getEnv)
(Just $(return route))
$(return $ VarE req)
|]
let myLet handlerExp =
LetE [FunD handler [Clause [] (NormalB handlerExp) []]] runner
if null ms
then do
base <- mdsGetHandler mds Nothing name
let he = foldl' (\a b -> a `AppE` VarE b) base ys
runHandler <- mdsRunHandler mds
return $ myLet $ runHandler `AppE` he
else do
mf <- [|Map.lookup $(return method) $(return $ VarE $ methodMapName name)|]
f <- newName "f"
let apply = foldl' (\a b -> a `AppE` VarE b) (VarE f) ys
body405 <-
[|$(mdsRunHandler mds)
$(mds405 mds)
$(return $ VarE getEnv)
(Just $(return route))
$(return $ VarE req)
|]
return $ CaseE mf
[ Match (ConP 'Just [VarP f]) (NormalB $ myLet apply) []
, Match (ConP 'Nothing []) (NormalB body405) []
]
Subsite _ getSub -> do
sub <- newName "sub"
let sub2 = LamE [VarP sub]
(foldl' (\a b -> a `AppE` VarE b) (VarE (mkName getSub) `AppE` VarE sub) ys)
[|$(mdsSubDispatcher mds)
$(mdsRunHandler mds)
$(return sub2)
$(return route)
$(return $ VarE getEnv)
($(mdsSetPathInfo mds)
$(return $ VarE xrest)
$(return $ VarE req)
)
|]
return $ LamE pat exp
convertPiece :: Piece a -> Q Exp
convertPiece (Static s) = [|D.Static (pack $(lift s))|]
convertPiece (Dynamic _) = [|D.Dynamic|]
routeFromDynamics :: [(String, [(CheckOverlap, Piece a)])]
-> String
-> [Name]
-> Exp
routeFromDynamics [] name ys = foldl' (\a b -> a `AppE` VarE b) (ConE $ mkName name) ys
routeFromDynamics ((parent, pieces):rest) name ys =
foldl' (\a b -> a `AppE` b) (ConE $ mkName parent) here
where
(here', ys') = splitAt (length $ filter (isDynamic . snd) pieces) ys
isDynamic Dynamic{} = True
isDynamic _ = False
here = map VarE here' ++ [routeFromDynamics rest name ys']