snap-routes (empty) → 0.0.1
raw patch · 15 files changed
+1392/−0 lines, 15 filesdep +basedep +blaze-builderdep +bytestringsetup-changed
Dependencies added: base, blaze-builder, bytestring, containers, filepath, http-types, mime-types, path-pieces, random, snap, template-haskell, text
Files
- LICENSE +7/−0
- README.md +22/−0
- Setup.hs +2/−0
- snap-routes.cabal +48/−0
- src/Routes/Class.hs +24/−0
- src/Routes/ContentTypes.hs +95/−0
- src/Routes/Overlap.hs +88/−0
- src/Routes/Parse.hs +254/−0
- src/Routes/TH.hs +16/−0
- src/Routes/TH/Dispatch.hs +202/−0
- src/Routes/TH/ParseRoute.hs +44/−0
- src/Routes/TH/RenderRoute.hs +174/−0
- src/Routes/TH/RouteAttrs.hs +38/−0
- src/Routes/TH/Types.hs +101/−0
- src/Snap/Routes.hs +277/−0
+ LICENSE view
@@ -0,0 +1,7 @@+Copyright (c) 2016 Anupam Jain++Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ README.md view
@@ -0,0 +1,22 @@+Snap-Routes+===========++Snap-routes provides typesafe routing for snap applications.++Features+========++Snap-routes adds the following features on top of Snap -++ - Typesafe URLs, including automatic boilerplate generation using TH. Including features such as -+ - Nested Routes+ - Subsites+ - Route Annotations+ - Seamlessly mix and match "unrouted" request handlers with typesafe routing.+ - Sitewide Master data which is passed to all handlers and can be used for persistent data (like DB connections)+++Changelog+=========++* 0.0.1 : Intial release
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ snap-routes.cabal view
@@ -0,0 +1,48 @@+name : snap-routes+version : 0.0.1+cabal-version : >=1.18+build-type : Simple+license : MIT+license-file : LICENSE+maintainer : ajnsit@gmail.com+stability : Experimental+synopsis : Typesafe URLs for Snap applications.+description : Provides easy to use typesafe URLs for Snap Applications.+category : Network+author : Anupam Jain+data-dir : ""+extra-source-files : README.md++source-repository head+ type : git+ location : http://github.com/ajnsit/snap-routes++library+ build-depends : base >= 4.7 && < 4.9+ , text+ , template-haskell+ , containers+ , random+ , path-pieces+ , bytestring+ , http-types+ , blaze-builder+ , mime-types+ , filepath+ , snap+ exposed-modules : Snap.Routes+ other-modules : Routes.Parse+ Routes.Overlap+ Routes.Class+ Routes.ContentTypes+ Routes.TH+ Routes.TH.Types+ Routes.TH.Dispatch+ Routes.TH.ParseRoute+ Routes.TH.RenderRoute+ Routes.TH.RouteAttrs+ exposed : True+ buildable : True+ hs-source-dirs : src+ default-language : Haskell2010+ ghc-options : -Wall
+ src/Routes/Class.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+module 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/Routes/ContentTypes.hs view
@@ -0,0 +1,95 @@+{-# LANGUAGE OverloadedStrings, TypeFamilies #-}++{- |+Module : Routes.ContentTypes+Copyright : (c) Anupam Jain 2013+License : MIT (see the file LICENSE)++Maintainer : ajnsit@gmail.com+Stability : experimental+Portability : non-portable (uses ghc extensions)++Defines the commonly used content types+-}+module Routes.ContentTypes+ ( -- * Construct content Type+ acceptContentType+ , contentType, contentTypeFromFile+ -- * Various common content types+ , typeAll+ , typeHtml, typePlain, typeJson+ , typeXml, typeAtom, typeRss+ , typeJpeg, typePng, typeGif+ , typeSvg, typeJavascript, typeCss+ , typeFlv, typeOgv, typeOctet+ )+ where++import qualified Data.Text as T (pack)+import Data.ByteString (ByteString)+import Data.ByteString.Char8 () -- Import IsString instance for ByteString+import Network.HTTP.Types.Header (HeaderName())+import Network.Mime (defaultMimeLookup)+import System.FilePath (takeFileName)++-- | The request header for accpetable content types+acceptContentType :: HeaderName+acceptContentType = "Accept"++-- | Construct an appropriate content type header from a file name+contentTypeFromFile :: FilePath -> ByteString+contentTypeFromFile = defaultMimeLookup . T.pack . takeFileName++-- | Creates a content type header+-- Ready to be passed to `responseLBS`+contentType :: HeaderName+contentType = "Content-Type"++typeAll :: ByteString+typeAll = "*/*"++typeHtml :: ByteString+typeHtml = "text/html; charset=utf-8"++typePlain :: ByteString+typePlain = "text/plain; charset=utf-8"++typeJson :: ByteString+typeJson = "application/json; charset=utf-8"++typeXml :: ByteString+typeXml = "text/xml"++typeAtom :: ByteString+typeAtom = "application/atom+xml"++typeRss :: ByteString+typeRss = "application/rss+xml"++typeJpeg :: ByteString+typeJpeg = "image/jpeg"++typePng :: ByteString+typePng = "image/png"++typeGif :: ByteString+typeGif = "image/gif"++typeSvg :: ByteString+typeSvg = "image/svg+xml"++typeJavascript :: ByteString+typeJavascript = "text/javascript; charset=utf-8"++typeCss :: ByteString+typeCss = "text/css; charset=utf-8"++typeFlv :: ByteString+typeFlv = "video/x-flv"++typeOgv :: ByteString+typeOgv = "video/ogg"++typeOctet :: ByteString+typeOctet = "application/octet-stream"+
+ src/Routes/Overlap.hs view
@@ -0,0 +1,88 @@+-- | Check for overlapping routes.+module Routes.Overlap+ ( findOverlapNames+ , Overlap (..)+ ) where++import 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 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/Routes/Parse.hs view
@@ -0,0 +1,254 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE PatternGuards #-}+{-# OPTIONS_GHC -fno-warn-missing-fields #-} -- QuasiQuoter+module 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 Routes.TH+import Routes.Overlap (findOverlapNames)+import Data.List (foldl', isPrefixOf)+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 (not . isPrefixOf "--") $ 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/Routes/TH.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE TemplateHaskell #-}+module Routes.TH+ ( module Routes.TH.Types+ -- * Functions+ , module Routes.TH.RenderRoute+ , module Routes.TH.ParseRoute+ , module Routes.TH.RouteAttrs+ -- ** Dispatch+ , module Routes.TH.Dispatch+ ) where++import Routes.TH.Types+import Routes.TH.RenderRoute+import Routes.TH.ParseRoute+import Routes.TH.RouteAttrs+import Routes.TH.Dispatch
+ src/Routes/TH/Dispatch.hs view
@@ -0,0 +1,202 @@+{-# LANGUAGE RecordWildCards, TemplateHaskell, ViewPatterns #-}+module 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 Routes.TH.Types+import Data.Char (toLower)++data MkDispatchSettings b site c = 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+ , mdsUnwrapper :: Exp -> Q Exp+ }++data SDC = SDC+ { clause404 :: Clause+ , extraParams :: [Exp]+ , extraCons :: [Exp]+ , envExp :: Exp+ , reqExp :: Exp+ }++-- | A simpler version of Routes.TH.Dispatch.mkDispatchClause, based on+-- view patterns.+--+-- Since 1.4.0+mkDispatchClause :: MkDispatchSettings b site c -> [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+ handlerE <- mdsUnwrapper $ 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 allDyns = extraParams ++ dyns+ sroute <- newName "sroute"+ let sub2 = LamE [VarP sub]+ (foldl' (\a b -> a `AppE` b) (VarE (mkName getSub) `AppE` VarE sub) allDyns)+ let reqExp' = setPathInfoE `AppE` VarE restPath `AppE` reqExp+ route' = foldl' AppE (ConE (mkName name)) dyns+ route = LamE [VarP sroute] $ foldr AppE (AppE route' $ VarE sroute) 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/Routes/TH/ParseRoute.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE TemplateHaskell #-}+module Routes.TH.ParseRoute+ ( -- ** ParseRoute+ mkParseRouteInstance+ ) where++import Routes.TH.Types+import Language.Haskell.TH.Syntax+import Data.Text (Text)+import Routes.Class+import 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|]+ , mdsUnwrapper = return+ }+ (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/Routes/TH/RenderRoute.hs view
@@ -0,0 +1,174 @@+{-# LANGUAGE TemplateHaskell, CPP #-}+module Routes.TH.RenderRoute+ ( -- ** RenderRoute+ mkRenderRouteInstance+ , mkRenderRouteInstance'+ , mkRouteCons+ , mkRenderRouteClauses+ ) where++import Routes.TH.Types+#if MIN_VERSION_template_haskell(2,11,0)+import Language.Haskell.TH (conT)+#endif+import Language.Haskell.TH.Syntax+import Data.Maybe (maybeToList)+import Control.Monad (replicateM)+import Data.Text (pack)+import Web.PathPieces (PathPiece (..), PathMultiPiece (..))+import Routes.Class+#if __GLASGOW_HASKELL__ < 710+import Control.Applicative ((<$>))+import Data.Monoid (mconcat)+#endif++-- | Generate the constructors of a route data type.+mkRouteCons :: [ResourceTree Type] -> Q ([Con], [Dec])+mkRouteCons rttypes =+ mconcat <$> mapM mkRouteCon rttypes+ where+ mkRouteCon (ResourceLeaf res) =+ return ([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) = do+ (cons, decs) <- mkRouteCons children+#if MIN_VERSION_template_haskell(2,11,0)+ dec <- DataD [] (mkName name) [] Nothing cons <$> mapM conT [''Show, ''Read, ''Eq]+#else+ let dec = DataD [] (mkName name) [] cons [''Show, ''Read, ''Eq]+#endif+ return ([con], dec : decs)+ where+ con = NormalC (mkName name)+ $ map (\x -> (notStrict, x))+ $ concat [singles, [ConT $ mkName name]]++ 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+ (cons, decs) <- mkRouteCons ress+#if MIN_VERSION_template_haskell(2,11,0)+ did <- DataInstD [] ''Route [typ] Nothing cons <$> mapM conT clazzes+#else+ let did = DataInstD [] ''Route [typ] cons clazzes+#endif+ return $ InstanceD cxt (ConT ''RenderRoute `AppT` typ)+ [ did+ , FunD (mkName "renderRoute") cls+ ] : decs+ where+ clazzes = [''Show, ''Eq, ''Read]++#if MIN_VERSION_template_haskell(2,11,0)+notStrict :: Bang+notStrict = Bang NoSourceUnpackedness NoSourceStrictness+#else+notStrict :: Strict+notStrict = NotStrict+#endif
+ src/Routes/TH/RouteAttrs.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE RecordWildCards #-}+module Routes.TH.RouteAttrs+ ( mkRouteAttrsInstance+ ) where++import Routes.TH.Types+import 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/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 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
+ src/Snap/Routes.hs view
@@ -0,0 +1,277 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}+{-# LANGUAGE TemplateHaskell, QuasiQuotes #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE CPP #-}+{- |+Module : Snap.Routes+Copyright : (c) Anupam Jain 2016+License : MIT (see the file LICENSE)++Maintainer : ajnsit@gmail.com+Stability : experimental+Portability : non-portable (uses ghc extensions)++This package provides typesafe URLs for Snap applications.+-}+module Snap.Routes+ ( module Snap.Routes+ , module Routes.Class+ , module Routes.Parse+ , module Snap+ )+where++-- Snap+import Snap++-- Routes+import Routes.Class (Route, RenderRoute(..), ParseRoute(..), RouteAttrs(..))+import Routes.Parse (parseRoutes, parseRoutesNoCheck, parseRoutesFile, parseRoutesFileNoCheck, parseType)+import Routes.TH (mkRenderRouteInstance, mkParseRouteInstance, mkRouteAttrsInstance, mkDispatchClause, ResourceTree(..), MkDispatchSettings(..), defaultGetHandler)++-- Text and Bytestring+import Data.ByteString (ByteString)+import Data.Text (Text)+import qualified Data.Text as T+import Data.Text.Encoding (encodeUtf8, decodeUtf8)+import Blaze.ByteString.Builder (toByteString)++import Network.HTTP.Types (encodePath, queryTextToQuery, decodePath, queryToQueryText, Query)++-- TH+import Language.Haskell.TH.Syntax++-- Convenience+import Control.Arrow (second)+import Data.Maybe (fromMaybe)++-- Abstract request data needed for routing+data RequestData master = RequestData+ { requestPathInfo :: [Text]+ , requestMethod :: ByteString+ }++-- The type of our response handler+type ResponseHandler m = MonadSnap m => m ()++-- Environment data+data Env sub master = Env+ { envMaster :: master+ , envSub :: sub+ , envToMaster :: Route sub -> Route master+ , currentRoute :: Maybe (Route master)+ }++-- | A `Handler` generates an App from the master datatype+type RouteHandler sub = forall master m. RenderRoute master => HandlerS m sub master+type HandlerS m sub master = MonadSnap m => Env sub master -> ResponseHandler m++-- | Generates everything except actual dispatch+mkRouteData :: String -> [ResourceTree String] -> Q [Dec]+mkRouteData typName routes = do+ let typ = parseType typName+ let rname = mkName $ "_resources" ++ typName+ let resourceTrees = map (fmap parseType) routes+ eres <- lift routes+ let resourcesDec =+ [ SigD rname $ ListT `AppT` (ConT ''ResourceTree `AppT` ConT ''String)+ , FunD rname [Clause [] (NormalB eres) []]+ ]+ rinst <- mkRenderRouteInstance typ resourceTrees+ pinst <- mkParseRouteInstance typ resourceTrees+ ainst <- mkRouteAttrsInstance typ resourceTrees+ return $ concat [ [ainst]+ , [pinst]+ , resourcesDec+ , rinst+ ]++-- | Generates a 'Routable' instance and dispatch function+mkRouteDispatch :: String -> [ResourceTree String] -> Q [Dec]+mkRouteDispatch typName routes = do+ let typ = parseType typName+ m <- newName "m"+ disp <- mkRouteDispatchClause routes+ return [InstanceD []+ (ConT ''Routable `AppT` VarT m `AppT` typ `AppT` typ)+ [FunD (mkName "dispatcher") [disp]]]++-- | Same as mkRouteDispatch but for subsites+mkRouteSubDispatch :: String -> String -> [ResourceTree a] -> Q [Dec]+mkRouteSubDispatch typName constraint routes = do+ let typ = parseType typName+ disp <- mkRouteDispatchClause routes+ master <- newName "master"+ m <- newName "m"+ -- We don't simply use parseType for GHC 7.8 (TH-2.9) compatibility+ -- ParseType only works on Type (not Pred)+ -- In GHC 7.10 (TH-2.10) onwards, Pred is aliased to Type+ className <- lookupTypeName constraint+ -- Check if this is a classname or a type+ let contract = maybe (error $ "Unknown typeclass " ++ show constraint) (getContract master) className+ return [InstanceD [contract]+ (ConT ''Routable `AppT` VarT m `AppT` typ `AppT` VarT master)+ [FunD (mkName "dispatcher") [disp]]]+ where+ getContract master className =+#if MIN_VERSION_template_haskell(2,10,0)+ ConT className `AppT` VarT master+#else+ ClassP className [VarT master]+#endif++-- Helper that creates the dispatch clause+mkRouteDispatchClause :: [ResourceTree a] -> Q Clause+mkRouteDispatchClause =+ mkDispatchClause MkDispatchSettings+ { mdsRunHandler = [| runHandler |]+ , mdsSubDispatcher = [| subDispatcher |]+ , mdsGetPathInfo = [| requestPathInfo |]+ , mdsMethod = [| requestMethod |]+ , mdsSetPathInfo = [| setPathInfo |]+ , mds404 = [| app404 |]+ , mds405 = [| app405 |]+ , mdsGetHandler = defaultGetHandler+ , mdsUnwrapper = return+ }+++-- | Generates all the things needed for efficient routing.+-- Including your application's `Route` datatype,+-- `RenderRoute`, `ParseRoute`, `RouteAttrs`, and `Routable` instances.+-- Use this for everything except subsites+mkRoute :: String -> [ResourceTree String] -> Q [Dec]+mkRoute typName routes = do+ dat <- mkRouteData typName routes+ disp <- mkRouteDispatch typName routes+ return (disp++dat)++-- TODO: Also allow using the master datatype name directly, instead of a constraint class+-- | Same as mkRoute, but for subsites+mkRouteSub :: String -> String -> [ResourceTree String] -> Q [Dec]+mkRouteSub typName constraint routes = do+ dat <- mkRouteData typName routes+ disp <- mkRouteSubDispatch typName constraint routes+ return (disp++dat)++-- | A `Routable` instance can be used in dispatching.+-- An appropriate instance for your site datatype is+-- automatically generated by `mkRoute`.+class Routable m sub master where+ dispatcher :: HandlerS m sub master++-- | Generates the application middleware from a `Routable` master datatype+routeDispatch :: Routable m master master => Request -> master -> ResponseHandler m+routeDispatch req = customRouteDispatch dispatcher req++-- | Like routeDispatch but generates the application middleware from a custom dispatcher+customRouteDispatch :: HandlerS m master master -> Request -> master -> ResponseHandler m+-- TODO: Should this have master master instead of sub master?+-- TODO: Verify that this plays well with subsites+-- Env master master is converted to Env sub master by subDispatcher+-- Route information is filled in by runHandler+customRouteDispatch customDispatcher req master =+ customDispatcher+ (_masterToEnv master)+ RequestData+ { requestPathInfo = parsePathInfo $ decodeUtf8 $ rqPathInfo req+ , requestMethod = showMethod $ rqMethod req+ }+ where+ -- Don't want to depend on the Show instance+ showMethod :: Method -> ByteString+ showMethod GET = "GET"+ showMethod HEAD = "HEAD"+ showMethod POST = "POST"+ showMethod PUT = "PUT"+ showMethod DELETE = "DELETE"+ showMethod TRACE = "TRACE"+ showMethod OPTIONS = "OPTIONS"+ showMethod CONNECT = "CONNECT"+ showMethod PATCH = "PATCH"+ showMethod (Method meth) = meth++-- | Render a `Route` and Query parameters to Text+showRouteQuery :: RenderRoute master => Route master -> [(Text,Text)] -> Text+showRouteQuery r q = uncurry _encodePathInfo $ second (map (second Just) . (++ q)) $ renderRoute r++-- | Renders a `Route` as Text+showRoute :: RenderRoute master => Route master -> Text+showRoute = uncurry _encodePathInfo . second (map $ second Just) . renderRoute++_encodePathInfo :: [Text] -> [(Text, Maybe Text)] -> Text+-- Slightly hackish: Convert "" into "/"+_encodePathInfo [] = _encodePathInfo [""]+_encodePathInfo segments = decodeUtf8 . toByteString . encodePath segments . queryTextToQuery++-- | Read a route from Text+-- Returns Nothing if Route reading failed. Just route otherwise+readRoute :: ParseRoute master => Text -> Maybe (Route master)+readRoute = parseRoute . second readQueryString . decodePath . encodeUtf8++-- | Convert a Query to the format expected by parseRoute+readQueryString :: Query -> [(Text, Text)]+readQueryString = map (second (fromMaybe "")) . queryToQueryText++-- PRIVATE++-- Slightly hacky: manually split path into components+parsePathInfo :: Text -> [Text]+-- Hacky, map "" to []+parsePathInfo "" = []+parsePathInfo other = T.splitOn "/" other++-- Set the path info in a RequestData+setPathInfo :: [Text] -> RequestData master -> RequestData master+setPathInfo p reqData = reqData { requestPathInfo = p }++-- Baked in applications that handle 404 and 405 errors+-- On no matching route, skip to next application+app404 :: HandlerS m sub master+app404 _env _rd = pass++-- On matching route, but no matching http method, skip to next application+-- This allows a later route to handle methods not implemented by the previous routes+app405 :: HandlerS m sub master+app405 _env _rd = pass++-- Run a route handler function+-- Currently all this does is populate the route into RequestData+-- But it may do more in the future+runHandler+ :: MonadSnap m+ => HandlerS m sub master+ -> Env sub master+ -> Maybe (Route sub)+ -> ResponseHandler m+runHandler h env rout reqdata = h env reqdata{currentRoute=rout}++-- Run a route subsite handler function+subDispatcher+ :: MonadSnap m+ => Routable m sub master+ => (HandlerS m sub master -> Env sub master -> Maybe (Route sub) -> ResponseHandler m)+ -> (master -> sub)+ -> (Route sub -> Route master)+ -> Env master master+ -> ResponseHandler m+subDispatcher _runhandler getSub toMasterRoute env reqData = dispatcher env' reqData'+ where+ env' = _envToSub getSub toMasterRoute env+ reqData' = reqData{currentRoute=Nothing}++_masterToEnv :: master -> Env master master+_masterToEnv master = Env master master id++_envToSub :: (master -> sub) -> (Route sub -> Route master) -> Env master master -> Env sub master+_envToSub getSub toMasterRoute env = Env master sub toMasterRoute+ where+ master = envMaster env+ sub = getSub master++-- Convenience function to hook in a route+serveRoute :: (Routable m master master, MonadSnap m) => master -> m ()+serveRoute master = getRequest >>= flip routeDispatch master