wai-routes 0.5.1 → 0.6.0
raw patch · 13 files changed
+953/−35 lines, 13 filesdep +containersdep +path-piecesdep +randomdep −yesod-routesdep ~aesondep ~basedep ~blaze-builder
Dependencies added: containers, path-pieces, random
Dependencies removed: yesod-routes
Dependency ranges changed: aeson, base, blaze-builder, bytestring, http-types, mtl, template-haskell, text, wai
Files
- examples/Example.hs +1/−1
- src/Network/Wai/Middleware/Routes/Class.hs +24/−0
- src/Network/Wai/Middleware/Routes/Handler.hs +10/−8
- src/Network/Wai/Middleware/Routes/Monad.hs +4/−2
- src/Network/Wai/Middleware/Routes/Overlap.hs +88/−0
- src/Network/Wai/Middleware/Routes/Parse.hs +254/−0
- src/Network/Wai/Middleware/Routes/Routes.hs +17/−9
- src/Network/Wai/Middleware/Routes/TH/Dispatch.hs +199/−0
- src/Network/Wai/Middleware/Routes/TH/ParseRoute.hs +43/−0
- src/Network/Wai/Middleware/Routes/TH/RenderRoute.hs +150/−0
- src/Network/Wai/Middleware/Routes/TH/RouteAttrs.hs +38/−0
- src/Network/Wai/Middleware/Routes/TH/Types.hs +101/−0
- wai-routes.cabal +24/−15
examples/Example.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes, TypeFamilies #-}+{-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes, TypeFamilies, ViewPatterns #-} module Main where import Network.Wai
+ src/Network/Wai/Middleware/Routes/Class.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+module Network.Wai.Middleware.Routes.Class+ ( RenderRoute (..)+ , ParseRoute (..)+ , RouteAttrs (..)+ ) where++import Data.Text (Text)+import Data.Set (Set)++class Eq (Route a) => RenderRoute a where+ -- | The <http://www.yesodweb.com/book/routing-and-handlers type-safe URLs> associated with a site argument.+ data Route a+ renderRoute :: Route a+ -> ([Text], [(Text, Text)]) -- ^ The path of the URL split on forward slashes, and a list of query parameters with their associated value.++class RenderRoute a => ParseRoute a where+ parseRoute :: ([Text], [(Text, Text)]) -- ^ The path of the URL split on forward slashes, and a list of query parameters with their associated value.+ -> Maybe (Route a)++class RenderRoute a => RouteAttrs a where+ routeAttrs :: Route a+ -> Set Text -- ^ A set of <http://www.yesodweb.com/book/route-attributes attributes associated with the route>.
src/Network/Wai/Middleware/Routes/Handler.hs view
@@ -29,7 +29,9 @@ import Control.Monad (liftM) import Control.Monad.State (StateT, get, put, modify, runStateT, MonadState, MonadIO, lift, MonadTrans) -import Network.Wai.Middleware.Routes.Routes (RequestData, Handler, waiReq, runNext)+import Control.Applicative (Applicative)++import Network.Wai.Middleware.Routes.Routes (RequestData, Handler, waiReq, runNext, ResponseHandler) import Network.Wai.Middleware.Routes.ContentTypes (contentType, typeHtml, typeJson, typePlain) import Data.ByteString (ByteString)@@ -49,7 +51,7 @@ -- | The internal implementation of the HandlerM monad -- TODO: Should change this to StateT over ReaderT (but performance may suffer) newtype HandlerMI master m a = H { extractH :: StateT (HandlerState master) m a }- deriving (Monad, MonadIO, Functor, MonadTrans, MonadState (HandlerState master))+ deriving (Applicative, Monad, MonadIO, Functor, MonadTrans, MonadState (HandlerState master)) -- | The HandlerM Monad type HandlerM master a = HandlerMI master IO a@@ -61,16 +63,16 @@ , respHeaders :: [(HeaderName, ByteString)] , respStatus :: Status , respBody :: BL.ByteString- , respResp :: Maybe Response+ , respResp :: Maybe ResponseHandler } -- | "Run" HandlerM, resulting in a Handler runHandlerM :: HandlerM master () -> Handler master-runHandlerM h m req = do+runHandlerM h m req hh = do (_, state) <- runStateT (extractH h) (HandlerState m req [] status200 "" Nothing) case respResp state of- Nothing -> return $ toResp state- Just resp -> return resp+ Nothing -> hh $ toResp state+ Just resp -> resp hh toResp :: HandlerState master -> Response toResp hs = responseBuilder (respStatus hs) (respHeaders hs) (fromLazyByteString $ respBody hs)@@ -133,9 +135,9 @@ next :: HandlerM master () next = do s <- get- resp <- lift $ runNext $ getRequestData s+ let resp = runNext (getRequestData s) modify $ setResp resp where- setResp :: Response -> HandlerState master -> HandlerState master+ setResp :: ResponseHandler -> HandlerState master -> HandlerState master setResp r st = st{respResp=Just r}
src/Network/Wai/Middleware/Routes/Monad.hs view
@@ -29,6 +29,8 @@ import Control.Monad.State +import Control.Applicative (Applicative)+ data RouteState = RouteState { middlewares :: [Middleware] , defaultApp :: Application@@ -37,7 +39,7 @@ -- The final "catchall" application, simply returns a 404 response -- Ideally you should put your own default application defaultApplication :: Application-defaultApplication _req = return $ responseLBS status404 [("Content-Type", "text/plain")] "Error : 404 - Document not found"+defaultApplication _req h = h $ responseLBS status404 [("Content-Type", "text/plain")] "Error : 404 - Document not found" addMiddleware :: Middleware -> RouteState -> RouteState@@ -48,7 +50,7 @@ -- | The Route Monad newtype RouteM a = S { runS :: StateT RouteState IO a }- deriving (Monad, MonadIO, Functor, MonadState RouteState)+ deriving (Applicative, Monad, MonadIO, Functor, MonadState RouteState) -- | Add a middleware to the application. -- Middleware is nested so the one declared earlier is outer.
+ src/Network/Wai/Middleware/Routes/Overlap.hs view
@@ -0,0 +1,88 @@+-- | Check for overlapping routes.+module Network.Wai.Middleware.Routes.Overlap+ ( findOverlapNames+ , Overlap (..)+ ) where++import Network.Wai.Middleware.Routes.TH.Types+import Data.List (intercalate)++data Flattened t = Flattened+ { fNames :: [String]+ , fPieces :: [Piece t]+ , fHasSuffix :: Bool+ , fCheck :: CheckOverlap+ }++flatten :: ResourceTree t -> [Flattened t]+flatten =+ go id id True+ where+ go names pieces check (ResourceLeaf r) = return Flattened+ { fNames = names [resourceName r]+ , fPieces = pieces (resourcePieces r)+ , fHasSuffix = hasSuffix $ ResourceLeaf r+ , fCheck = check && resourceCheck r+ }+ go names pieces check (ResourceParent newname check' newpieces children) =+ concatMap (go names' pieces' (check && check')) children+ where+ names' = names . (newname:)+ pieces' = pieces . (newpieces ++)++data Overlap t = Overlap+ { overlapParents :: [String] -> [String] -- ^ parent resource trees+ , overlap1 :: ResourceTree t+ , overlap2 :: ResourceTree t+ }++data OverlapF = OverlapF+ { _overlapF1 :: [String]+ , _overlapF2 :: [String]+ }++overlaps :: [Piece t] -> [Piece t] -> Bool -> Bool -> Bool++-- No pieces on either side, will overlap regardless of suffix+overlaps [] [] _ _ = True++-- No pieces on the left, will overlap if the left side has a suffix+overlaps [] _ suffixX _ = suffixX++-- Ditto for the right+overlaps _ [] _ suffixY = suffixY++-- Compare the actual pieces+overlaps (pieceX:xs) (pieceY:ys) suffixX suffixY =+ piecesOverlap pieceX pieceY && overlaps xs ys suffixX suffixY++piecesOverlap :: Piece t -> Piece t -> Bool+-- Statics only match if they equal. Dynamics match with anything+piecesOverlap (Static x) (Static y) = x == y+piecesOverlap _ _ = True++findOverlapNames :: [ResourceTree t] -> [(String, String)]+findOverlapNames =+ map go . findOverlapsF . filter fCheck . concatMap Network.Wai.Middleware.Routes.Overlap.flatten+ where+ go (OverlapF x y) =+ (go' x, go' y)+ where+ go' = intercalate "/"++findOverlapsF :: [Flattened t] -> [OverlapF]+findOverlapsF [] = []+findOverlapsF (x:xs) = concatMap (findOverlapF x) xs ++ findOverlapsF xs++findOverlapF :: Flattened t -> Flattened t -> [OverlapF]+findOverlapF x y+ | overlaps (fPieces x) (fPieces y) (fHasSuffix x) (fHasSuffix y) = [OverlapF (fNames x) (fNames y)]+ | otherwise = []++hasSuffix :: ResourceTree t -> Bool+hasSuffix (ResourceLeaf r) =+ case resourceDispatch r of+ Subsite{} -> True+ Methods Just{} _ -> True+ Methods Nothing _ -> False+hasSuffix ResourceParent{} = True
+ src/Network/Wai/Middleware/Routes/Parse.hs view
@@ -0,0 +1,254 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE PatternGuards #-}+{-# OPTIONS_GHC -fno-warn-missing-fields #-} -- QuasiQuoter+module Network.Wai.Middleware.Routes.Parse+ ( parseRoutes+ , parseRoutesFile+ , parseRoutesNoCheck+ , parseRoutesFileNoCheck+ , parseType+ , parseTypeTree+ , TypeTree (..)+ ) where++import Language.Haskell.TH.Syntax+import Data.Char (isUpper)+import Language.Haskell.TH.Quote+import qualified System.IO as SIO+import Network.Wai.Middleware.Routes.TH+import Network.Wai.Middleware.Routes.Overlap (findOverlapNames)+import Data.List (foldl')+import Data.Maybe (mapMaybe)+import qualified Data.Set as Set++-- | A quasi-quoter to parse a string into a list of 'Resource's. Checks for+-- overlapping routes, failing if present; use 'parseRoutesNoCheck' to skip the+-- checking. See documentation site for details on syntax.+parseRoutes :: QuasiQuoter+parseRoutes = QuasiQuoter { quoteExp = x }+ where+ x s = do+ let res = resourcesFromString s+ case findOverlapNames res of+ [] -> lift res+ z -> error $ unlines $ "Overlapping routes: " : map show z++parseRoutesFile :: FilePath -> Q Exp+parseRoutesFile = parseRoutesFileWith parseRoutes++parseRoutesFileNoCheck :: FilePath -> Q Exp+parseRoutesFileNoCheck = parseRoutesFileWith parseRoutesNoCheck++parseRoutesFileWith :: QuasiQuoter -> FilePath -> Q Exp+parseRoutesFileWith qq fp = do+ qAddDependentFile fp+ s <- qRunIO $ readUtf8File fp+ quoteExp qq s++readUtf8File :: FilePath -> IO String+readUtf8File fp = do+ h <- SIO.openFile fp SIO.ReadMode+ SIO.hSetEncoding h SIO.utf8_bom+ SIO.hGetContents h++-- | Same as 'parseRoutes', but performs no overlap checking.+parseRoutesNoCheck :: QuasiQuoter+parseRoutesNoCheck = QuasiQuoter+ { quoteExp = lift . resourcesFromString+ }++-- | Convert a multi-line string to a set of resources. See documentation for+-- the format of this string. This is a partial function which calls 'error' on+-- invalid input.+resourcesFromString :: String -> [ResourceTree String]+resourcesFromString =+ fst . parse 0 . filter (not . all (== ' ')) . lines+ where+ parse _ [] = ([], [])+ parse indent (thisLine:otherLines)+ | length spaces < indent = ([], thisLine : otherLines)+ | otherwise = (this others, remainder)+ where+ parseAttr ('!':x) = Just x+ parseAttr _ = Nothing++ stripColonLast =+ go id+ where+ go _ [] = Nothing+ go front [x]+ | null x = Nothing+ | last x == ':' = Just $ front [init x]+ | otherwise = Nothing+ go front (x:xs) = go (front . (x:)) xs++ spaces = takeWhile (== ' ') thisLine+ (others, remainder) = parse indent otherLines'+ (this, otherLines') =+ case takeWhile (/= "--") $ words thisLine of+ (pattern:rest0)+ | Just (constr:rest) <- stripColonLast rest0+ , Just attrs <- mapM parseAttr rest ->+ let (children, otherLines'') = parse (length spaces + 1) otherLines+ children' = addAttrs attrs children+ (pieces, Nothing, check) = piecesFromStringCheck pattern+ in ((ResourceParent constr check pieces children' :), otherLines'')+ (pattern:constr:rest) ->+ let (pieces, mmulti, check) = piecesFromStringCheck pattern+ (attrs, rest') = takeAttrs rest+ disp = dispatchFromString rest' mmulti+ in ((ResourceLeaf (Resource constr pieces disp attrs check):), otherLines)+ [] -> (id, otherLines)+ _ -> error $ "Invalid resource line: " ++ thisLine++piecesFromStringCheck :: String -> ([Piece String], Maybe String, Bool)+piecesFromStringCheck s0 =+ (pieces, mmulti, check)+ where+ (s1, check1) = stripBang s0+ (pieces', mmulti') = piecesFromString $ drop1Slash s1+ pieces = map snd pieces'+ mmulti = fmap snd mmulti'+ check = check1 && all fst pieces' && maybe True fst mmulti'++ stripBang ('!':rest) = (rest, False)+ stripBang x = (x, True)++addAttrs :: [String] -> [ResourceTree String] -> [ResourceTree String]+addAttrs attrs =+ map goTree+ where+ goTree (ResourceLeaf res) = ResourceLeaf (goRes res)+ goTree (ResourceParent w x y z) = ResourceParent w x y (map goTree z)++ goRes res =+ res { resourceAttrs = noDupes ++ resourceAttrs res }+ where+ usedKeys = Set.fromList $ map fst $ mapMaybe toPair $ resourceAttrs res+ used attr =+ case toPair attr of+ Nothing -> False+ Just (key, _) -> key `Set.member` usedKeys+ noDupes = filter (not . used) attrs++ toPair s =+ case break (== '=') s of+ (x, '=':y) -> Just (x, y)+ _ -> Nothing++-- | Take attributes out of the list and put them in the first slot in the+-- result tuple.+takeAttrs :: [String] -> ([String], [String])+takeAttrs =+ go id id+ where+ go x y [] = (x [], y [])+ go x y (('!':attr):rest) = go (x . (attr:)) y rest+ go x y (z:rest) = go x (y . (z:)) rest++dispatchFromString :: [String] -> Maybe String -> Dispatch String+dispatchFromString rest mmulti+ | null rest = Methods mmulti []+ | all (all isUpper) rest = Methods mmulti rest+dispatchFromString [subTyp, subFun] Nothing =+ Subsite subTyp subFun+dispatchFromString [_, _] Just{} =+ error "Subsites cannot have a multipiece"+dispatchFromString rest _ = error $ "Invalid list of methods: " ++ show rest++drop1Slash :: String -> String+drop1Slash ('/':x) = x+drop1Slash x = x++piecesFromString :: String -> ([(CheckOverlap, Piece String)], Maybe (CheckOverlap, String))+piecesFromString "" = ([], Nothing)+piecesFromString x =+ case (this, rest) of+ (Left typ, ([], Nothing)) -> ([], Just typ)+ (Left _, _) -> error "Multipiece must be last piece"+ (Right piece, (pieces, mtyp)) -> (piece:pieces, mtyp)+ where+ (y, z) = break (== '/') x+ this = pieceFromString y+ rest = piecesFromString $ drop 1 z++parseType :: String -> Type+parseType orig =+ maybe (error $ "Invalid type: " ++ show orig) ttToType $ parseTypeTree orig++parseTypeTree :: String -> Maybe TypeTree+parseTypeTree orig =+ toTypeTree pieces+ where+ pieces = filter (not . null) $ splitOn '-' $ addDashes orig+ addDashes [] = []+ addDashes (x:xs) =+ front $ addDashes xs+ where+ front rest+ | x `elem` "()[]" = '-' : x : '-' : rest+ | otherwise = x : rest+ splitOn c s =+ case y' of+ _:y -> x : splitOn c y+ [] -> [x]+ where+ (x, y') = break (== c) s++data TypeTree = TTTerm String+ | TTApp TypeTree TypeTree+ | TTList TypeTree+ deriving (Show, Eq)++toTypeTree :: [String] -> Maybe TypeTree+toTypeTree orig = do+ (x, []) <- gos orig+ return x+ where+ go [] = Nothing+ go ("(":xs) = do+ (x, rest) <- gos xs+ case rest of+ ")":rest' -> Just (x, rest')+ _ -> Nothing+ go ("[":xs) = do+ (x, rest) <- gos xs+ case rest of+ "]":rest' -> Just (TTList x, rest')+ _ -> Nothing+ go (x:xs) = Just (TTTerm x, xs)++ gos xs1 = do+ (t, xs2) <- go xs1+ (ts, xs3) <- gos' id xs2+ Just (foldl' TTApp t ts, xs3)++ gos' front [] = Just (front [], [])+ gos' front (x:xs)+ | x `elem` words ") ]" = Just (front [], x:xs)+ | otherwise = do+ (t, xs') <- go $ x:xs+ gos' (front . (t:)) xs'++ttToType :: TypeTree -> Type+ttToType (TTTerm s) = ConT $ mkName s+ttToType (TTApp x y) = ttToType x `AppT` ttToType y+ttToType (TTList t) = ListT `AppT` ttToType t++pieceFromString :: String -> Either (CheckOverlap, String) (CheckOverlap, Piece String)+pieceFromString ('#':'!':x) = Right $ (False, Dynamic x)+pieceFromString ('!':'#':x) = Right $ (False, Dynamic x) -- https://github.com/yesodweb/yesod/issues/652+pieceFromString ('#':x) = Right $ (True, Dynamic x)++pieceFromString ('*':'!':x) = Left (False, x)+pieceFromString ('+':'!':x) = Left (False, x)++pieceFromString ('!':'*':x) = Left (False, x)+pieceFromString ('!':'+':x) = Left (False, x)++pieceFromString ('*':x) = Left (True, x)+pieceFromString ('+':x) = Left (True, x)++pieceFromString ('!':x) = Right $ (False, Static x)+pieceFromString x = Right $ (True, Static x)
src/Network/Wai/Middleware/Routes/Routes.hs view
@@ -34,6 +34,10 @@ -- * Application Handlers , Handler + -- * As of Wai 3, Application datatype now follows continuation passing style+ -- A `ResponseHandler` represents a continuation passed to the application+ , ResponseHandler+ -- * Generated Datatypes , Routable(..) -- | Used internally. However needs to be exported for TH to work. , RenderRoute(..) -- | A `RenderRoute` instance for your site datatype is automatically generated by `mkRoute`@@ -45,17 +49,18 @@ , waiReq -- | Extract the wai `Request` object from `RequestData` , nextApp -- | Extract the next Application in the stack , runNext -- | Run the next application in the stack+ ) where -- Wai-import Network.Wai (Middleware, Application, pathInfo, requestMethod, requestMethod, Response, Request(..), responseBuilder)+import Network.Wai (ResponseReceived, Middleware, Application, pathInfo, requestMethod, requestMethod, Response, Request(..), responseBuilder) import Network.HTTP.Types (decodePath, encodePath, queryTextToQuery, queryToQueryText, status405) --- Yesod Routes-import Yesod.Routes.Class (Route, RenderRoute(..), ParseRoute(..), RouteAttrs(..))-import Yesod.Routes.Parse (parseRoutes, parseRoutesNoCheck, parseRoutesFile, parseRoutesFileNoCheck, parseType)-import Yesod.Routes.TH (mkRenderRouteInstance, mkParseRouteInstance, mkRouteAttrsInstance, mkDispatchClause, ResourceTree(..), MkDispatchSettings(..), defaultGetHandler)+-- Network.Wai.Middleware.Routes+import Network.Wai.Middleware.Routes.Class (Route, RenderRoute(..), ParseRoute(..), RouteAttrs(..))+import Network.Wai.Middleware.Routes.Parse (parseRoutes, parseRoutesNoCheck, parseRoutesFile, parseRoutesFileNoCheck, parseType)+import Network.Wai.Middleware.Routes.TH (mkRenderRouteInstance, mkParseRouteInstance, mkRouteAttrsInstance, mkDispatchClause, ResourceTree(..), MkDispatchSettings(..), defaultGetHandler) -- Text and Bytestring import Data.Text (Text)@@ -78,12 +83,15 @@ , nextApp :: Application } +-- AJ: Experimental+type ResponseHandler = (Response -> IO ResponseReceived) -> IO ResponseReceived+ -- | Run the next application in the stack-runNext :: RequestData -> IO Response+runNext :: RequestData -> ResponseHandler runNext req = nextApp req $ waiReq req -- | A `Handler` generates an App from the master datatype-type Handler master = master -> RequestData -> IO Response+type Handler master = master -> RequestData -> ResponseHandler -- Baked in applications that handle 404 and 405 errors -- TODO: Inspect the request to figure out acceptable output formats@@ -92,7 +100,7 @@ app404 _master = runNext app405 :: Handler master-app405 _master _req = return $ responseBuilder status405 [(contentType, typePlain)] $ fromByteString "405 - Method Not Allowed"+app405 _master _req h = h $ responseBuilder status405 [(contentType, typePlain)] $ fromByteString "405 - Method Not Allowed" -- | Generates all the things needed for efficient routing, -- including your application's `Route` datatype, and@@ -129,7 +137,7 @@ :: Handler master -> master -> Maybe (Route master)- -> RequestData -> IO Response -- App+ -> RequestData -> ResponseHandler -- App runHandler h master _ = h master -- | A `Routable` instance can be used in dispatching.
+ src/Network/Wai/Middleware/Routes/TH/Dispatch.hs view
@@ -0,0 +1,199 @@+{-# LANGUAGE RecordWildCards, TemplateHaskell, ViewPatterns #-}+module Network.Wai.Middleware.Routes.TH.Dispatch+ ( MkDispatchSettings (..)+ , mkDispatchClause+ , defaultGetHandler+ ) where++import Prelude hiding (exp)+import Language.Haskell.TH.Syntax+import Web.PathPieces+import Data.Maybe (catMaybes)+import Control.Monad (forM)+import Data.List (foldl')+import Control.Arrow (second)+import System.Random (randomRIO)+import Network.Wai.Middleware.Routes.TH.Types+import Data.Char (toLower)++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+ }++data SDC = SDC+ { clause404 :: Clause+ , extraParams :: [Exp]+ , extraCons :: [Exp]+ , envExp :: Exp+ , reqExp :: Exp+ }++-- | A simpler version of Network.Wai.Middleware.Routes.TH.Dispatch.mkDispatchClause, based on+-- view patterns.+--+-- Since 1.4.0+mkDispatchClause :: MkDispatchSettings -> [ResourceTree a] -> Q Clause+mkDispatchClause MkDispatchSettings {..} resources = do+ suffix <- qRunIO $ randomRIO (1000, 9999 :: Int)+ envName <- newName $ "env" ++ show suffix+ reqName <- newName $ "req" ++ show suffix+ helperName <- newName $ "helper" ++ show suffix++ let envE = VarE envName+ reqE = VarE reqName+ helperE = VarE helperName++ clause404' <- mkClause404 envE reqE+ getPathInfo <- mdsGetPathInfo+ let pathInfo = getPathInfo `AppE` reqE++ let sdc = SDC+ { clause404 = clause404'+ , extraParams = []+ , extraCons = []+ , envExp = envE+ , reqExp = reqE+ }+ clauses <- mapM (go sdc) resources++ return $ Clause+ [VarP envName, VarP reqName]+ (NormalB $ helperE `AppE` pathInfo)+ [FunD helperName $ clauses ++ [clause404']]+ where+ handlePiece :: Piece a -> Q (Pat, Maybe Exp)+ handlePiece (Static str) = return (LitP $ StringL str, Nothing)+ handlePiece (Dynamic _) = do+ x <- newName "dyn"+ let pat = ViewP (VarE 'fromPathPiece) (ConP 'Just [VarP x])+ return (pat, Just $ VarE x)++ handlePieces :: [Piece a] -> Q ([Pat], [Exp])+ handlePieces = fmap (second catMaybes . unzip) . mapM handlePiece++ mkCon :: String -> [Exp] -> Exp+ mkCon name = foldl' AppE (ConE $ mkName name)++ mkPathPat :: Pat -> [Pat] -> Pat+ mkPathPat final =+ foldr addPat final+ where+ addPat x y = ConP '(:) [x, y]++ go :: SDC -> ResourceTree a -> Q Clause+ go sdc (ResourceParent name _check pieces children) = do+ (pats, dyns) <- handlePieces pieces+ let sdc' = sdc+ { extraParams = extraParams sdc ++ dyns+ , extraCons = extraCons sdc ++ [mkCon name dyns]+ }+ childClauses <- mapM (go sdc') children++ restName <- newName "rest"+ let restE = VarE restName+ restP = VarP restName++ helperName <- newName $ "helper" ++ name+ let helperE = VarE helperName++ return $ Clause+ [mkPathPat restP pats]+ (NormalB $ helperE `AppE` restE)+ [FunD helperName $ childClauses ++ [clause404 sdc]]+ go SDC {..} (ResourceLeaf (Resource name pieces dispatch _ _check)) = do+ (pats, dyns) <- handlePieces pieces++ (chooseMethod, finalPat) <- handleDispatch dispatch dyns++ return $ Clause+ [mkPathPat finalPat pats]+ (NormalB chooseMethod)+ []+ where+ handleDispatch :: Dispatch a -> [Exp] -> Q (Exp, Pat)+ handleDispatch dispatch' dyns =+ case dispatch' of+ Methods multi methods -> do+ (finalPat, mfinalE) <-+ case multi of+ Nothing -> return (ConP '[] [], Nothing)+ Just _ -> do+ multiName <- newName "multi"+ let pat = ViewP (VarE 'fromPathMultiPiece)+ (ConP 'Just [VarP multiName])+ return (pat, Just $ VarE multiName)++ let dynsMulti =+ case mfinalE of+ Nothing -> dyns+ Just e -> dyns ++ [e]+ route' = foldl' AppE (ConE (mkName name)) dynsMulti+ route = foldr AppE route' extraCons+ jroute = ConE 'Just `AppE` route+ allDyns = extraParams ++ dynsMulti+ mkRunExp mmethod = do+ runHandlerE <- mdsRunHandler+ handlerE' <- mdsGetHandler mmethod name+ let handlerE = foldl' AppE handlerE' allDyns+ return $ runHandlerE+ `AppE` handlerE+ `AppE` envExp+ `AppE` jroute+ `AppE` reqExp++ func <-+ case methods of+ [] -> mkRunExp Nothing+ _ -> do+ getMethod <- mdsMethod+ let methodE = getMethod `AppE` reqExp+ matches <- forM methods $ \method -> do+ exp <- mkRunExp (Just method)+ return $ Match (LitP $ StringL method) (NormalB exp) []+ match405 <- do+ runHandlerE <- mdsRunHandler+ handlerE <- mds405+ let exp = runHandlerE+ `AppE` handlerE+ `AppE` envExp+ `AppE` jroute+ `AppE` reqExp+ return $ Match WildP (NormalB exp) []+ return $ CaseE methodE $ matches ++ [match405]++ return (func, finalPat)+ Subsite _ getSub -> do+ restPath <- newName "restPath"+ setPathInfoE <- mdsSetPathInfo+ subDispatcherE <- mdsSubDispatcher+ runHandlerE <- mdsRunHandler+ sub <- newName "sub"+ let sub2 = LamE [VarP sub]+ (foldl' (\a b -> a `AppE` b) (VarE (mkName getSub) `AppE` VarE sub) dyns)+ let reqExp' = setPathInfoE `AppE` VarE restPath `AppE` reqExp+ route' = foldl' AppE (ConE (mkName name)) dyns+ route = foldr AppE route' extraCons+ exp = subDispatcherE+ `AppE` runHandlerE+ `AppE` sub2+ `AppE` route+ `AppE` envExp+ `AppE` reqExp'+ return (exp, VarP restPath)++ mkClause404 envE reqE = do+ handler <- mds404+ runHandler <- mdsRunHandler+ let exp = runHandler `AppE` handler `AppE` envE `AppE` ConE 'Nothing `AppE` reqE+ return $ Clause [WildP] (NormalB 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
+ src/Network/Wai/Middleware/Routes/TH/ParseRoute.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE TemplateHaskell #-}+module Network.Wai.Middleware.Routes.TH.ParseRoute+ ( -- ** ParseRoute+ mkParseRouteInstance+ ) where++import Network.Wai.Middleware.Routes.TH.Types+import Language.Haskell.TH.Syntax+import Data.Text (Text)+import Network.Wai.Middleware.Routes.Class+import Network.Wai.Middleware.Routes.TH.Dispatch++mkParseRouteInstance :: Type -> [ResourceTree a] -> Q Dec+mkParseRouteInstance typ ress = do+ cls <- mkDispatchClause+ MkDispatchSettings+ { mdsRunHandler = [|\_ _ x _ -> x|]+ , mds404 = [|error "mds404"|]+ , mds405 = [|error "mds405"|]+ , mdsGetPathInfo = [|fst|]+ , mdsMethod = [|error "mdsMethod"|]+ , mdsGetHandler = \_ _ -> [|error "mdsGetHandler"|]+ , mdsSetPathInfo = [|\p (_, q) -> (p, q)|]+ , mdsSubDispatcher = [|\_runHandler _getSub toMaster _env -> fmap toMaster . parseRoute|]+ }+ (map removeMethods ress)+ helper <- newName "helper"+ fixer <- [|(\f x -> f () x) :: (() -> ([Text], [(Text, Text)]) -> Maybe (Route a)) -> ([Text], [(Text, Text)]) -> Maybe (Route a)|]+ return $ InstanceD [] (ConT ''ParseRoute `AppT` typ)+ [ FunD 'parseRoute $ return $ Clause+ []+ (NormalB $ fixer `AppE` VarE helper)+ [FunD helper [cls]]+ ]+ where+ -- We do this in order to ski the unnecessary method parsing+ removeMethods (ResourceLeaf res) = ResourceLeaf $ removeMethodsLeaf res+ removeMethods (ResourceParent w x y z) = ResourceParent w x y $ map removeMethods z++ removeMethodsLeaf res = res { resourceDispatch = fixDispatch $ resourceDispatch res }++ fixDispatch (Methods x _) = Methods x []+ fixDispatch x = x
+ src/Network/Wai/Middleware/Routes/TH/RenderRoute.hs view
@@ -0,0 +1,150 @@+{-# LANGUAGE TemplateHaskell #-}+module Network.Wai.Middleware.Routes.TH.RenderRoute+ ( -- ** RenderRoute+ mkRenderRouteInstance+ , mkRenderRouteInstance'+ , mkRouteCons+ , mkRenderRouteClauses+ ) where++import Network.Wai.Middleware.Routes.TH.Types+import Language.Haskell.TH.Syntax+import Data.Maybe (maybeToList)+import Control.Monad (replicateM)+import Data.Text (pack)+import Web.PathPieces (PathPiece (..), PathMultiPiece (..))+import Network.Wai.Middleware.Routes.Class+import Data.Monoid (mconcat)++-- | Generate the constructors of a route data type.+mkRouteCons :: [ResourceTree Type] -> ([Con], [Dec])+mkRouteCons =+ mconcat . map mkRouteCon+ where+ mkRouteCon (ResourceLeaf res) =+ ([con], [])+ where+ con = NormalC (mkName $ resourceName res)+ $ map (\x -> (NotStrict, x))+ $ concat [singles, multi, sub]+ singles = concatMap toSingle $ resourcePieces res+ toSingle Static{} = []+ toSingle (Dynamic typ) = [typ]++ multi = maybeToList $ resourceMulti res++ sub =+ case resourceDispatch res of+ Subsite { subsiteType = typ } -> [ConT ''Route `AppT` typ]+ _ -> []+ mkRouteCon (ResourceParent name _check pieces children) =+ ([con], dec : decs)+ where+ (cons, decs) = mkRouteCons children+ con = NormalC (mkName name)+ $ map (\x -> (NotStrict, x))+ $ concat [singles, [ConT $ mkName name]]+ dec = DataD [] (mkName name) [] cons [''Show, ''Read, ''Eq]++ singles = concatMap toSingle pieces+ toSingle Static{} = []+ toSingle (Dynamic typ) = [typ]++-- | Clauses for the 'renderRoute' method.+mkRenderRouteClauses :: [ResourceTree Type] -> Q [Clause]+mkRenderRouteClauses =+ mapM go+ where+ isDynamic Dynamic{} = True+ isDynamic _ = False++ go (ResourceParent name _check pieces children) = do+ let cnt = length $ filter isDynamic pieces+ dyns <- replicateM cnt $ newName "dyn"+ child <- newName "child"+ let pat = ConP (mkName name) $ map VarP $ dyns ++ [child]++ pack' <- [|pack|]+ tsp <- [|toPathPiece|]+ let piecesSingle = mkPieces (AppE pack' . LitE . StringL) tsp pieces dyns++ childRender <- newName "childRender"+ let rr = VarE childRender+ childClauses <- mkRenderRouteClauses children++ a <- newName "a"+ b <- newName "b"++ colon <- [|(:)|]+ let cons y ys = InfixE (Just y) colon (Just ys)+ let pieces' = foldr cons (VarE a) piecesSingle++ let body = LamE [TupP [VarP a, VarP b]] (TupE [pieces', VarE b]) `AppE` (rr `AppE` VarE child)++ return $ Clause [pat] (NormalB body) [FunD childRender childClauses]++ go (ResourceLeaf res) = do+ let cnt = length (filter isDynamic $ resourcePieces res) + maybe 0 (const 1) (resourceMulti res)+ dyns <- replicateM cnt $ newName "dyn"+ sub <-+ case resourceDispatch res of+ Subsite{} -> fmap return $ newName "sub"+ _ -> return []+ let pat = ConP (mkName $ resourceName res) $ map VarP $ dyns ++ sub++ pack' <- [|pack|]+ tsp <- [|toPathPiece|]+ let piecesSingle = mkPieces (AppE pack' . LitE . StringL) tsp (resourcePieces res) dyns++ piecesMulti <-+ case resourceMulti res of+ Nothing -> return $ ListE []+ Just{} -> do+ tmp <- [|toPathMultiPiece|]+ return $ tmp `AppE` VarE (last dyns)++ body <-+ case sub of+ [x] -> do+ rr <- [|renderRoute|]+ a <- newName "a"+ b <- newName "b"++ colon <- [|(:)|]+ let cons y ys = InfixE (Just y) colon (Just ys)+ let pieces = foldr cons (VarE a) piecesSingle++ return $ LamE [TupP [VarP a, VarP b]] (TupE [pieces, VarE b]) `AppE` (rr `AppE` VarE x)+ _ -> do+ colon <- [|(:)|]+ let cons a b = InfixE (Just a) colon (Just b)+ return $ TupE [foldr cons piecesMulti piecesSingle, ListE []]++ return $ Clause [pat] (NormalB body) []++ mkPieces _ _ [] _ = []+ mkPieces toText tsp (Static s:ps) dyns = toText s : mkPieces toText tsp ps dyns+ mkPieces toText tsp (Dynamic{}:ps) (d:dyns) = tsp `AppE` VarE d : mkPieces toText tsp ps dyns+ mkPieces _ _ ((Dynamic _) : _) [] = error "mkPieces 120"++-- | Generate the 'RenderRoute' instance.+--+-- This includes both the 'Route' associated type and the+-- 'renderRoute' method. This function uses both 'mkRouteCons' and+-- 'mkRenderRouteClasses'.+mkRenderRouteInstance :: Type -> [ResourceTree Type] -> Q [Dec]+mkRenderRouteInstance = mkRenderRouteInstance' []++-- | A more general version of 'mkRenderRouteInstance' which takes an+-- additional context.++mkRenderRouteInstance' :: Cxt -> Type -> [ResourceTree Type] -> Q [Dec]+mkRenderRouteInstance' cxt typ ress = do+ cls <- mkRenderRouteClauses ress+ let (cons, decs) = mkRouteCons ress+ return $ InstanceD cxt (ConT ''RenderRoute `AppT` typ)+ [ DataInstD [] ''Route [typ] cons clazzes+ , FunD (mkName "renderRoute") cls+ ] : decs+ where+ clazzes = [''Show, ''Eq, ''Read]
+ src/Network/Wai/Middleware/Routes/TH/RouteAttrs.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE RecordWildCards #-}+module Network.Wai.Middleware.Routes.TH.RouteAttrs+ ( mkRouteAttrsInstance+ ) where++import Network.Wai.Middleware.Routes.TH.Types+import Network.Wai.Middleware.Routes.Class+import Language.Haskell.TH.Syntax+import Data.Set (fromList)+import Data.Text (pack)++mkRouteAttrsInstance :: Type -> [ResourceTree a] -> Q Dec+mkRouteAttrsInstance typ ress = do+ clauses <- mapM (goTree id) ress+ return $ InstanceD [] (ConT ''RouteAttrs `AppT` typ)+ [ FunD 'routeAttrs $ concat clauses+ ]++goTree :: (Pat -> Pat) -> ResourceTree a -> Q [Clause]+goTree front (ResourceLeaf res) = fmap return $ goRes front res+goTree front (ResourceParent name _check pieces trees) =+ fmap concat $ mapM (goTree front') trees+ where+ ignored = ((replicate toIgnore WildP ++) . return)+ toIgnore = length $ filter isDynamic pieces+ isDynamic Dynamic{} = True+ isDynamic Static{} = False+ front' = front . ConP (mkName name) . ignored++goRes :: (Pat -> Pat) -> Resource a -> Q Clause+goRes front Resource {..} =+ return $ Clause+ [front $ RecP (mkName resourceName) []]+ (NormalB $ VarE 'fromList `AppE` ListE (map toText resourceAttrs))+ []+ where+ toText s = VarE 'pack `AppE` LitE (StringL s)
+ src/Network/Wai/Middleware/Routes/TH/Types.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE TemplateHaskell #-}+-- | Warning! This module is considered internal and may have breaking changes+module Network.Wai.Middleware.Routes.TH.Types+ ( -- * Data types+ Resource (..)+ , ResourceTree (..)+ , Piece (..)+ , Dispatch (..)+ , CheckOverlap+ , FlatResource (..)+ -- ** Helper functions+ , resourceMulti+ , resourceTreePieces+ , resourceTreeName+ , flatten+ ) where++import Language.Haskell.TH.Syntax++data ResourceTree typ+ = ResourceLeaf (Resource typ)+ | ResourceParent String CheckOverlap [Piece typ] [ResourceTree typ]+ deriving Functor++resourceTreePieces :: ResourceTree typ -> [Piece typ]+resourceTreePieces (ResourceLeaf r) = resourcePieces r+resourceTreePieces (ResourceParent _ _ x _) = x++resourceTreeName :: ResourceTree typ -> String+resourceTreeName (ResourceLeaf r) = resourceName r+resourceTreeName (ResourceParent x _ _ _) = x++instance Lift t => Lift (ResourceTree t) where+ lift (ResourceLeaf r) = [|ResourceLeaf $(lift r)|]+ lift (ResourceParent a b c d) = [|ResourceParent $(lift a) $(lift b) $(lift c) $(lift d)|]++data Resource typ = Resource+ { resourceName :: String+ , resourcePieces :: [Piece typ]+ , resourceDispatch :: Dispatch typ+ , resourceAttrs :: [String]+ , resourceCheck :: CheckOverlap+ }+ deriving (Show, Functor)++type CheckOverlap = Bool++instance Lift t => Lift (Resource t) where+ lift (Resource a b c d e) = [|Resource a b c d e|]++data Piece typ = Static String | Dynamic typ+ deriving Show++instance Functor Piece where+ fmap _ (Static s) = (Static s)+ fmap f (Dynamic t) = Dynamic (f t)++instance Lift t => Lift (Piece t) where+ lift (Static s) = [|Static $(lift s)|]+ lift (Dynamic t) = [|Dynamic $(lift t)|]++data Dispatch typ =+ Methods+ { methodsMulti :: Maybe typ -- ^ type of the multi piece at the end+ , methodsMethods :: [String] -- ^ supported request methods+ }+ | Subsite+ { subsiteType :: typ+ , subsiteFunc :: String+ }+ deriving Show++instance Functor Dispatch where+ fmap f (Methods a b) = Methods (fmap f a) b+ fmap f (Subsite a b) = Subsite (f a) b++instance Lift t => Lift (Dispatch t) where+ lift (Methods Nothing b) = [|Methods Nothing $(lift b)|]+ lift (Methods (Just t) b) = [|Methods (Just $(lift t)) $(lift b)|]+ lift (Subsite t b) = [|Subsite $(lift t) $(lift b)|]++resourceMulti :: Resource typ -> Maybe typ+resourceMulti Resource { resourceDispatch = Methods (Just t) _ } = Just t+resourceMulti _ = Nothing++data FlatResource a = FlatResource+ { frParentPieces :: [(String, [Piece a])]+ , frName :: String+ , frPieces :: [Piece a]+ , frDispatch :: Dispatch a+ , frCheck :: Bool+ }++flatten :: [ResourceTree a] -> [FlatResource a]+flatten =+ concatMap (go id True)+ where+ go front check' (ResourceLeaf (Resource a b c _ check)) = [FlatResource (front []) a b c (check' && check)]+ go front check' (ResourceParent name check pieces children) =+ concatMap (go (front . ((name, pieces):)) (check && check')) children
wai-routes.cabal view
@@ -1,6 +1,6 @@ name : wai-routes-version : 0.5.1-cabal-version : >=1.10+version : 0.6.0+cabal-version : >=1.18 build-type : Simple license : MIT license-file : LICENSE@@ -63,27 +63,36 @@ source-repository this type : git- location : http://github.com/ajnsit/wai-routes/tree/v0.5.1- tag : v0.5.1+ location : http://github.com/ajnsit/wai-routes/tree/v0.6+ tag : v0.6 library- build-depends: base >= 4.6.0.1 && < 4.7- , wai >= 2.0.0 && < 2.2- , text >= 0.11.3.1 && < 1.2- , bytestring >= 0.10.0.2 && < 0.11- , http-types >= 0.8.3 && < 0.9- , blaze-builder >= 0.3.3.2 && < 0.4- , template-haskell >= 2.8.0.0 && < 2.9- , yesod-routes >= 1.2.0.6 && < 1.3- , mtl >= 2.1.2 && < 2.2- , aeson >= 0.7.0.1 && < 0.8+ build-depends: base >= 4.7 && < 4.9+ , wai >= 3.0 && < 3.1+ , text >= 1.2 && < 1.3+ , template-haskell >= 2.9 && < 2.11+ , mtl >= 2.1 && < 2.3+ , aeson >= 0.8 && < 0.9+ , containers >= 0.5 && < 0.6+ , random >= 1.1 && < 1.2+ , path-pieces >= 0.2 && < 0.3+ , bytestring >= 0.10 && < 0.11+ , http-types >= 0.8 && < 0.9+ , blaze-builder >= 0.4 && < 0.5 exposed-modules: Network.Wai.Middleware.Routes+ Network.Wai.Middleware.Routes.Parse+ Network.Wai.Middleware.Routes.Overlap+ Network.Wai.Middleware.Routes.Class Network.Wai.Middleware.Routes.Routes Network.Wai.Middleware.Routes.Monad Network.Wai.Middleware.Routes.Handler Network.Wai.Middleware.Routes.ContentTypes+ Network.Wai.Middleware.Routes.TH.Types+ Network.Wai.Middleware.Routes.TH.Dispatch+ Network.Wai.Middleware.Routes.TH.ParseRoute+ Network.Wai.Middleware.Routes.TH.RenderRoute+ Network.Wai.Middleware.Routes.TH.RouteAttrs exposed : True buildable : True hs-source-dirs : src default-language : Haskell2010-