web-routes-quasi (empty) → 0.0.0
raw patch · 5 files changed
+881/−0 lines, 5 filesdep +QuickCheckdep +basedep +bytestringsetup-changed
Dependencies added: QuickCheck, base, bytestring, template-haskell, wai, wai-extra, web-encodings, web-routes
Files
- LICENSE +25/−0
- Setup.hs +2/−0
- Web/Routes/Quasi.hs +658/−0
- runtests.hs +156/−0
- web-routes-quasi.cabal +40/−0
+ LICENSE view
@@ -0,0 +1,25 @@+The following license covers this documentation, and the source code, except+where otherwise indicated.++Copyright 2009, Michael Snoyman. All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++* Redistributions of source code must retain the above copyright notice, this+ list of conditions and the following disclaimer.++* Redistributions in binary form must reproduce the above copyright notice,+ this list of conditions and the following disclaimer in the documentation+ and/or other materials provided with the distribution.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO+EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT,+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT+NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,+OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE+OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF+ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ Web/Routes/Quasi.hs view
@@ -0,0 +1,658 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE TypeFamilies #-}+module Web.Routes.Quasi+ (+ -- * Quasi quoter+ parseRoutes+ , parseRoutesNoCheck+ -- * Template haskell+ -- ** Low level+ , createQuasiDispatch+ , createRender+ , createParse+ -- ** High level for 'QuasiSite's+ , createQuasiSite+ , QuasiSiteSettings (..)+ , QuasiSiteDecs (..)+ -- * Quasi site+ , QuasiDispatch+ , QuasiSite (..)+ , quasiFromSite+ , quasiToSite+ , Routes+ , BlankArgs (..)+ -- * Underlying data types+ , Resource (..)+ , Handler (..)+ , Piece (..)+#if TEST+ , testSuite+#endif+ ) where++import Data.Char+import Language.Haskell.TH.Syntax+import Language.Haskell.TH.Quote+import Data.Data+import Data.Maybe+import Control.Monad+import Web.Routes.Site+import Data.Either+import Data.List++#if TEST+import Test.Framework (testGroup, Test)+import Test.Framework.Providers.HUnit+import Test.HUnit hiding (Test)+#endif++-- | A single resource pattern.+--+-- First argument is the name of the constructor, second is that URL pattern to+-- match, third is how to dispatch.+data Resource = Resource String [Piece] Handler+ deriving (Read, Show, Eq, Data, Typeable)++-- | Defines how to dispatch a request for a specific resource.+--+-- ByMethod allows a different function to be called for each request method.+-- The first value in each pair is the method, the second is the name of the+-- handler.+--+-- Single dispatches to a single function for all methods.+--+-- SubSite passes dispatch to a different site. The first argument is the name+-- of the datatype for the routes. The second is a function returning a+-- 'QuasiSite' for that type of routes. The third is a function converting the+-- master argument to the subsite argument.+data Handler = ByMethod [(String, String)] -- ^ (method, handler)+ | Single String+ | SubSite String String String+ deriving (Read, Show, Eq, Data, Typeable)++-- | A single piece of a URL, delimited by slashes.+--+-- In the case of StaticPiece, the argument is the value of the piece; for the+-- other constructors, it is the name of the parameter represented by this+-- piece. That value is not used here, but may be useful elsewhere.+data Piece = StaticPiece String+ | StringPiece String+ | IntPiece String+ | SlurpPiece String+ deriving (Read, Show, Eq, Data, Typeable)++type family Routes a++-- | The type for quasiDispatch; separated out for clarity of Haddock docs.+type QuasiDispatch app sub master+ = (Routes master -> String)+ -> Routes sub+ -> (Routes sub -> Routes master)+ -> master+ -> (master -> sub)+ -> app -- ^ bad method handler+ -> String -- ^ method+ -> app++-- | Very similar in principle to 'Site', but with special support for+-- arguments and subsites.+data QuasiSite app sub master = QuasiSite+ { quasiDispatch :: QuasiDispatch app sub master+ , quasiRender :: Routes sub -> [String]+ , quasiParse :: [String] -> Either String (Routes sub)+ }++-- | Used for applications with no arguments. In particular, this facilitates a+-- translation from a 'Site' to a 'QuasiSite' via 'quasiFromSite'.+data BlankArgs routes = BlankArgs+type instance Routes (BlankArgs routes) = routes++-- | Convert a 'Site' to a 'QuasiSite'. 'quasiRender' and 'quasiParse' are+-- identical to 'formatPathSegments' and 'parsePathSegments'; for the+-- 'quasiDispatch' function, we just ignore the extra arguments that 'Site'+-- does not use.+quasiFromSite :: Site surl app -> QuasiSite app (BlankArgs surl) master+quasiFromSite (Site dispatch render parse) = QuasiSite+ { quasiDispatch = \mrender surl constr _ _ _ _ ->+ dispatch (mrender . constr) surl+ , quasiRender = render+ , quasiParse = parse+ }++-- | Convert a 'QuasiSite' to a 'Site'. 'quasiRender' and 'quasiParse' are+-- identical to 'formatPathSegments' and 'parsePathSegments'; for the+-- 'handleSite' function, we need some extra information passed to this+-- function. We also restrict the resulting 'QuasiSite' to cases where subsite+-- and master site are the same.+quasiToSite :: QuasiSite app sub sub+ -> ((String -> app) -> app) -- ^ grab method+ -> app -- ^ bad method+ -> sub+ -> Site (Routes sub) app+quasiToSite (QuasiSite dispatch render parse) grabMethod badMethod sub = Site+ { handleSite = \rend url -> grabMethod (dispatch+ rend+ url+ id+ sub+ id+ badMethod)+ , formatPathSegments = render+ , parsePathSegments = parse+ }++isStatic :: Piece -> Bool+isStatic (StaticPiece _) = True+isStatic _ = False++isSubSite :: Handler -> Bool+isSubSite (SubSite _ _ _) = True+isSubSite _ = False++isString :: Piece -> Bool+isString (StringPiece _) = True+isString _ = False++-- | Drop leading whitespace.+trim :: String -> String+trim = dropWhile isSpace++-- | 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 -> [Resource]+resourcesFromString = map go . filter (not . null) . map trim . lines where+ go s =+ case words s of+ (pattern:constr:rest) ->+ let pieces = piecesFromString $ drop1Slash pattern+ handler = go' constr rest+ in if all isStatic pieces || not (isSubSite handler)+ then Resource constr pieces handler+ else error "Subsites must have static pieces"+ _ -> error $ "Invalid resource line: " ++ s+ go' constr [] = Single $ "handle" ++ constr+ go' _ [routes, getSite@(x:_), grabArgs@(y:_)]+ | isLower x && isLower y = SubSite routes getSite grabArgs+ go' constr rest = ByMethod+ $ map (\x -> (x, map toLower x ++ constr)) rest++drop1Slash :: String -> String+drop1Slash ('/':x) = x+drop1Slash x = x++piecesFromString :: String -> [Piece]+piecesFromString "" = []+piecesFromString x =+ let (y, z) = break (== '/') x+ in pieceFromString y : piecesFromString (drop1Slash z)++pieceFromString :: String -> Piece+pieceFromString ('$':x) = StringPiece x+pieceFromString ('#':x) = IntPiece x+pieceFromString ('*':x) = SlurpPiece x+pieceFromString x = StaticPiece x++-- | 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 x y where+ x s = do+ let res = resourcesFromString s+ case findOverlaps res of+ [] -> liftResources res+ _ -> error $ "Overlapping routes: " ++ show res+ y = dataToPatQ (const Nothing) . resourcesFromString++-- | Same as 'parseRoutes', but performs no overlap checking.+parseRoutesNoCheck :: QuasiQuoter+parseRoutesNoCheck = QuasiQuoter x y where+ x = liftResources . resourcesFromString+ y = dataToPatQ (const Nothing) . resourcesFromString++liftResources :: [Resource] -> Q Exp+liftResources = fmap ListE . mapM go where+ go :: Resource -> Q Exp+ go (Resource s ps h) = do+ r <- [|Resource|]+ s' <- lift s+ ps' <- liftPieces ps+ h' <- liftHandler h+ return $ r `AppE` s' `AppE` ps' `AppE` h'++liftPieces :: [Piece] -> Q Exp+liftPieces = fmap ListE . mapM go where+ go (StaticPiece s) = do+ c <- [|StaticPiece|]+ s' <- lift s+ return $ c `AppE` s'+ go (StringPiece s) = do+ c <- [|StringPiece|]+ s' <- lift s+ return $ c `AppE` s'+ go (IntPiece s) = do+ c <- [|IntPiece|]+ s' <- lift s+ return $ c `AppE` s'+ go (SlurpPiece s) = do+ c <- [|SlurpPiece|]+ s' <- lift s+ return $ c `AppE` s'++liftHandler :: Handler -> Q Exp+liftHandler (ByMethod s) = do+ c <- [|ByMethod|]+ s' <- lift s+ return $ c `AppE` s'+liftHandler (Single s) = do+ c <- [|Single|]+ s' <- lift s+ return $ c `AppE` s'+liftHandler (SubSite x y z) = do+ c <- [|SubSite|]+ x' <- lift x+ y' <- lift y+ z' <- lift z+ return $ c `AppE` x' `AppE` y' `AppE` z'++dataTypeDec :: QuasiSiteSettings -> Q Dec+dataTypeDec set =+ return $ DataD [] (crRoutes set) []+ (map go $ crResources set) claz+ where+ go (Resource n pieces h) = NormalC (mkName n)+ $ mapMaybe go' pieces+ ++ go'' h+ go' (StringPiece _) = Just (NotStrict, ConT ''String)+ go' (IntPiece _) = Just (NotStrict, ConT ''Integer)+ go' (SlurpPiece _) = Just (NotStrict, AppT ListT $ ConT ''String)+ go' _ = Nothing+ go'' (SubSite t _ _) = [(NotStrict, ConT $ mkName t)]+ go'' _ = []+ claz = [''Show, ''Read, ''Eq]++findOverlaps :: [Resource] -> [(Resource, Resource)]+findOverlaps = gos . map justPieces+ where+ justPieces r@(Resource _ ps (SubSite{})) = (ps ++ [SlurpPiece ""], r)+ justPieces r@(Resource _ ps _) = (ps, r)+ gos [] = []+ gos (x:xs) = mapMaybe (go x) xs ++ gos xs+ go (StaticPiece x:xs, xr) (StaticPiece y:ys, yr)+ | x == y = go (xs, xr) (ys, yr)+ | otherwise = Nothing+ go (SlurpPiece _:_, xr) (_, yr) = Just (xr, yr)+ go (_, xr) (SlurpPiece _:_, yr) = Just (xr, yr)+ go (StaticPiece x:xs, xr) (IntPiece _:ys, yr)+ | isInt x = go (xs, xr) (ys, yr)+ | otherwise = Nothing+ go (IntPiece _:xs, xr) (StaticPiece y:ys, yr)+ | isInt y = go (xs, xr) (ys, yr)+ | otherwise = Nothing+ go ([], xr) ([], yr) = Just (xr, yr)+ go ([], _) (_, _) = Nothing+ go (_, _) ([], _) = Nothing+ go (_:xs, xr) (_:ys, yr) = go (xs, xr) (ys, yr)++-- | Whether the set of resources cover all possible URLs.+areResourcesComplete :: [Resource] -> Bool+areResourcesComplete res =+ let (slurps, noSlurps) = partitionEithers $ mapMaybe go res+ in case slurps of+ [] -> False+ _ -> let minSlurp = minimum slurps+ in helper minSlurp $ reverse $ sort noSlurps+ where+ go :: Resource -> Maybe (Either Int Int)+ go (Resource _ ps (SubSite _ _ _)) = go' Left ps+ go (Resource _ ps _) =+ case reverse ps of+ [] -> Just $ Right 0+ (SlurpPiece _:rest) -> go' Left rest+ x -> go' Right x+ go' b x = if all isString x then Just (b $ length x) else Nothing+ helper 0 _ = True+ helper _ [] = False+ helper m (i:is)+ | i >= m = helper m is+ | i + 1 == m = helper i is+ | otherwise = False++-- | Generates the set of clauses necesary to parse the given 'Resource's. See 'quasiParse'.+createParse :: [Resource] -> Q [Clause]+createParse res = do+ final' <- final+ clauses <- mapM go res+ return $ if areResourcesComplete res+ then clauses+ else clauses ++ [final']+ where+ final = do+ no <- [|Left "Invalid URL"|]+ return $ Clause [WildP] (NormalB no) []+ go (Resource n ps h) = do+ let ps' = zip [1..] ps+ let pat = mkPat ps' h+ bod <- foldM go' (ConE $ mkName n) ps'+ bod' <- case h of+ SubSite _ f _ -> do+ parse <- [|quasiParse|]+ let parse' = parse `AppE` VarE (mkName f)+ let rhs = parse' `AppE` VarE (mkName "var0")+ fm <- [|fmap|]+ return $ fm `AppE` bod `AppE` rhs+ _ -> do+ ri <- [|Right|]+ return $ AppE ri bod+ checkInts' <- checkInts ps'+ return $ Clause [pat]+ (GuardedB [(NormalG checkInts', bod')]) []+ mkPat [] (SubSite _ _ _) = VarP $ mkName "var0" -- FIXME use newName+ mkPat [] _ = ConP (mkName "[]") []+ mkPat ((_, StaticPiece t):rest) h =+ ConP (mkName ":") [ LitP (StringL t)+ , mkPat rest h+ ]+ mkPat ((i, SlurpPiece _):_) _ = VarP $ mkName $ "var" ++ show i+ mkPat ((i, _):rest) h = ConP (mkName ":")+ [ VarP $ mkName $ "var" ++ show (i :: Int)+ , mkPat rest h+ ]+ go' x (_, StaticPiece _) = return x+ go' x (i, SlurpPiece _) =+ return $ x `AppE` VarE (mkName $ "var" ++ show i)+ go' x (i, StringPiece _) =+ return $ x `AppE` VarE (mkName $ "var" ++ show i)+ go' x (i, IntPiece _) = do+ re <- [|read|]+ return $ x `AppE` (re `AppE` VarE (mkName $ "var" ++ show i))+ checkInts [] = [|True|]+ checkInts ((i, IntPiece _):rest) = do+ ii <- [|isInt|]+ a <- [|(&&)|]+ rest' <- checkInts rest+ return $ a `AppE` (ii `AppE` VarE (mkName $ "var" ++ show i))+ `AppE` rest'+ checkInts (_:rest) = checkInts rest++isInt :: String -> Bool+isInt [] = False+isInt ('-':rest) = all isDigit rest+isInt x = all isDigit x++-- | Generates the set of clauses necesary to render the given 'Resource's. See+-- 'quasiRender'.+createRender :: [Resource] -> Q [Clause]+createRender res = mapM go res+ where+ go (Resource n ps h) = do+ let ps' = zip [1..] ps+ let pat = ConP (mkName n) $ mapMaybe go' ps' ++ lastPat h+ bod <- mkBod ps' h+ return $ Clause [pat] (NormalB bod) []+ lastPat (SubSite _ _ _) = [VarP $ mkName "var0"]+ lastPat _ = []+ go' (_, StaticPiece _) = Nothing+ go' (i, _) = Just $ VarP $ mkName $ "var" ++ show (i :: Int)+ mkBod [] (SubSite _ f _) = do+ format <- [|quasiRender|]+ let format' = format `AppE` VarE (mkName f)+ return $ format' `AppE` VarE (mkName "var0")+ mkBod [] _ = lift ([] :: [String])+ mkBod ((_, StaticPiece x):xs) h = do+ x' <- lift x+ xs' <- mkBod xs h+ return $ ConE (mkName ":") `AppE` x' `AppE` xs'+ mkBod ((i, StringPiece _):xs) h = do+ let x' = VarE $ mkName $ "var" ++ show i+ xs' <- mkBod xs h+ return $ ConE (mkName ":") `AppE` x' `AppE` xs'+ mkBod ((i, IntPiece _):xs) h= do+ sh <- [|show|]+ let x' = AppE sh $ VarE $ mkName $ "var" ++ show i+ xs' <- mkBod xs h+ return $ ConE (mkName ":") `AppE` x' `AppE` xs'+ mkBod ((i, SlurpPiece _):_) _ = return $ VarE $ mkName $ "var" ++ show i++-- | Generate the set of clauses necesary to dispatch the given 'Resource's.+-- See 'quasiDispatch'.+createQuasiDispatch :: QuasiSiteSettings -> Q [Clause]+createQuasiDispatch set = do+ mrender <- newName "_mrender"+ tomurl <- newName "_tomurl"+ marg <- newName "_marg"+ tosarg <- newName "_tosarg"+ method <- newName "_method"+ badMethod <- newName "_badMethod"+ mapM (go mrender tomurl marg tosarg method badMethod) $ crResources set+ where+ go mrender tomurl marg tosarg method badMethod+ (Resource constr ps handler) = do+ conArgs <- go' ps handler+ url <- newName "_url"+ let pat = [ VarP mrender+ , AsP url $ ConP (mkName constr) $ map VarP conArgs+ , VarP tomurl+ , VarP marg+ , VarP tosarg+ , VarP badMethod+ , VarP method+ ]+ b <- case handler of+ Single s' -> do+ unexploded <- foldM go'' (VarE $ mkName s') conArgs+ let exploded = crExplode set `AppE` unexploded+ return $ exploded+ `AppE` VarE mrender+ `AppE` VarE url+ `AppE` VarE tomurl+ `AppE` VarE marg+ `AppE` VarE tosarg+ `AppE` VarE badMethod+ `AppE` VarE method+ ByMethod methods -> do+ matches <- forM methods $ \(m, f) -> do+ let pat' = LitP $ StringL m+ unexploded <- foldM go'' (VarE $ mkName f) conArgs+ let exploded = crExplode set `AppE` unexploded+ let bod = exploded+ `AppE` VarE mrender+ `AppE` VarE url+ `AppE` VarE tomurl+ `AppE` VarE marg+ `AppE` VarE tosarg+ `AppE` VarE badMethod+ `AppE` VarE method+ return $ Match pat' (NormalB bod) []+ let final =+ if length methods == 4+ then []+ else [Match WildP (NormalB $ VarE badMethod) []]+ return $ CaseE (VarE method) $ matches ++ final+ SubSite _ f getArg -> do+ qd <- [|quasiDispatch|]+ let disp = qd `AppE` VarE (mkName f)+ o <- [|(.)|]+ let tomurl' = InfixE (Just $ VarE tomurl) o+ $ Just $ ConE $ mkName constr+ let tosarg' = InfixE (Just $ VarE $ mkName getArg) o+ $ Just $ VarE tosarg+ return $ disp+ `AppE` VarE mrender+ `AppE` VarE (last conArgs)+ `AppE` tomurl'+ `AppE` VarE marg+ `AppE` tosarg'+ `AppE` VarE badMethod+ `AppE` VarE method+ return $ Clause pat (NormalB b) []+ go' [] (SubSite _ _ _) = do+ n <- newName "arg"+ return [n]+ go' [] _ = return []+ go' (StaticPiece _:rest) h = go' rest h+ go' (_:rest) h = do+ n <- newName "arg"+ ns <- go' rest h+ return $ n : ns+ go'' base arg = return $ base `AppE` VarE arg++siteDecType :: QuasiSiteSettings -> Q Dec+siteDecType set = do+ let core = ConT ''QuasiSite `AppT` crApplication set `AppT` crArgument set+ let ty = case crMaster set of+ Left master -> core `AppT` master+ Right classes ->+ let master = mkName "master"+ master' = VarT master+ cxt = map (flip ClassP [master']) classes+ in ForallT [PlainTV master] cxt $ core `AppT` master'+ return $ SigD (crSite set) ty++siteDec :: Name -- ^ name of resulting function+ -> [Clause] -- ^ parse+ -> [Clause] -- ^ render+ -> [Clause] -- ^ dispatch+ -> Q Dec+siteDec name parse render dispatch = do+ si <- [|QuasiSite|]+ dname <- newName "dispatch"+ rname <- newName "render"+ pname <- newName "parse"+ let body = si `AppE` VarE dname+ `AppE` VarE rname+ `AppE` VarE pname+ return $ FunD name+ [ Clause [] (NormalB body)+ [ FunD dname dispatch+ , FunD rname render+ , FunD pname parse+ ]+ ]++-- | Template haskell code to convert a list of 'Resource's into appropriate+-- declarations for a 'QuasiSite'. See the 'QuasiSiteSettings' and+-- 'QuasiSiteDecs' data types for an explanation for the input and output,+-- respectively, of this function.+createQuasiSite :: QuasiSiteSettings -> Q QuasiSiteDecs+createQuasiSite set = do+ dt <- dataTypeDec set+ let tySyn = TySynInstD ''Routes [crArgument set] $ ConT $ crRoutes set+ parseClauses <- createParse $ crResources set+ renderClauses <- createRender $ crResources set+ dispatchClauses <- createQuasiDispatch set+ st <- siteDecType set+ s <- siteDec (crSite set) parseClauses renderClauses dispatchClauses+ return QuasiSiteDecs+ { decRoutes = dt+ , decRoutesSyn = tySyn+ , decSiteType = st+ , decSite = s+ }++-- | The arguments passed to 'createQuasiSite' for generating applications+-- based on the 'QuasiSite' datatype.+data QuasiSiteSettings = QuasiSiteSettings+ { -- | The name for the URL data type to be created.+ crRoutes :: Name+ -- | The type for underlying applications.+ , crApplication :: Type+ -- | The type for the argument value to be passed to dispatch functions.+ , crArgument :: Type+ -- | Underlying applications will often want to program against some+ -- datatype. The explode function converts that datatype into a function+ -- that will generate an application ('crApplication'). In particular,+ -- the value of crExplode should have a type signature of:+ --+ -- > explode :: handler+ -- > -> ('Routes' master -> String)+ -- > -> 'Routes' sub+ -- > -> ('Routes' sub -> 'Routes' master)+ -- > -> master+ -- > -> (master -> sub)+ -- > -> app+ -- > -> String+ -- > -> app+ --+ -- handler is some datatype handled by the calling application;+ -- web-routes-quasi needn't know about it. sub and master are the+ -- arguments for the subsite and master site, respectively. app is the+ -- datatype for the underlying application; the app argument above is the+ -- handler for unsupported method. The 'String' argument is the request+ -- method.+ , crExplode :: Exp+ -- | The 'Resource's upon which we are building the set of URLs and+ -- dispatches. Usually generated by 'parseRoutes'.+ , crResources :: [Resource]+ -- | The name for the resulting function which will return the 'QuasiSite'.+ , crSite :: Name+ -- | Describes the type of the master argument. This can either be a+ -- 'Left' concrete datatype, or 'Right' a list of 'Pred's describing the+ -- context for master.+ , crMaster :: Either Type [Name]+ }++-- | The template Haskell declarations returned from 'createQuasiSite'.+data QuasiSiteDecs = QuasiSiteDecs+ { -- | Defines the actual URL datatype, which all its constructors.+ decRoutes :: Dec+ -- | Defines the 'Routes' type synonym instance between the argument+ -- ('crArgument') and URL datatype.+ , decRoutesSyn :: Dec+ -- | The type signature for the site function ('decSite').+ , decSiteType :: Dec+ -- | Function which returns a 'QuasiSite'. The type parameters for the+ -- 'QuasiSite' will be 'crApplication', 'crArgument' and a forall master.+ , decSite :: Dec+ }++#if TEST+testSuite :: Test+testSuite = testGroup "Web.Routes.Quasi"+ [ testCase "overlaps" caseOverlaps+ , testCase "complete" caseComplete+ ]++caseOverlaps :: Assertion+caseOverlaps = do+ assertBool "empty" $ null $ findOverlaps []+ assertBool "single" $ null $ findOverlaps+ [ Resource "Foo" [] $ Single "foo"+ ]+ assertBool "two empties" $ not $ null $ findOverlaps+ [ Resource "Foo" [] $ Single "foo"+ , Resource "Bar" [] $ Single "bar"+ ]+ assertBool "slurp versus empty" $ not $ null $ findOverlaps+ [ Resource "Foo" [] $ Single "foo"+ , Resource "Bar" [] $ SubSite "a" "b" "c"+ ]+ assertBool "int + slurp versus empty" $ null $ findOverlaps+ [ Resource "Foo" [] $ Single "foo"+ , Resource "Bar" [IntPiece ""] $ SubSite "a" "b" "c"+ ]++caseComplete :: Assertion+caseComplete = do+ assertBool "empty" $ not $ areResourcesComplete []+ assertBool "slurp" $ areResourcesComplete+ [ Resource "Foo" [SlurpPiece "foo"] $ Single "foo"+ ]+ assertBool "subsite" $ areResourcesComplete+ [ Resource "Foo" [] $ SubSite "a" "b" "c"+ ]+ assertBool "string + subsite" $ areResourcesComplete+ [ Resource "Foo" [StringPiece "x"] $ SubSite "a" "b" "c"+ , Resource "Bar" [] $ Single "bar"+ ]+ assertBool "int + subsite" $ not $ areResourcesComplete+ [ Resource "Foo" [IntPiece "x"] $ SubSite "a" "b" "c"+ ]+ assertBool "two pieces" $ not $ areResourcesComplete+ [ Resource "Foo" [StringPiece "x"] $ Single "foo"+ , Resource "Bar" [IntPiece "x"] $ SubSite "a" "b" "c"+ ]+#endif
+ runtests.hs view
@@ -0,0 +1,156 @@+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+module Main+ ( main+ , waiSite+ ) where++import Test.Framework (defaultMain)+import Test.Framework.Providers.QuickCheck2++import Web.Routes.Quasi+import Test.QuickCheck+import Control.Applicative+import Network.Wai+import Network.Wai.Enumerator+--import Network.Wai.Handler.SimpleServer+import Data.ByteString.Lazy.Char8 (pack)+import Data.ByteString.Char8 (unpack)+import Web.Routes.Site+import Web.Encodings+import Language.Haskell.TH.Syntax++data StaticArgs = StaticArgs++getStaticArgs :: Int -> StaticArgs+getStaticArgs _ = StaticArgs++data StaticRoutes = StaticRoutes { unStaticRoutes :: [String] }+ deriving (Show, Read, Eq)++type instance Routes StaticArgs = StaticRoutes++siteStatic :: QuasiSite Application StaticArgs marg+siteStatic = QuasiSite+ undefined+ unStaticRoutes+ (Right . StaticRoutes)++type Explode surl murl marg = (murl -> String)+ -> surl+ -> (surl -> murl)+ -> marg+ -> (marg -> Int)+ -> Application+ -> String+ -> Application+explode :: Explode surl murl marg -> Explode surl murl marg+explode = id++fmap (\(QuasiSiteDecs a b c d) -> [a, b, c, d])+ $ createQuasiSite QuasiSiteSettings+ { crRoutes = mkName "MyRoutes"+ , crApplication = ConT ''Application+ , crArgument = ConT ''Int+ , crExplode = VarE $ mkName "explode"+ , crResources = [$parseRoutes|+/ Home GET+/user/#userid User GET PUT DELETE+/static Static StaticRoutes siteStatic getStaticArgs+/foo/*slurp Foo+/bar/$barparam Bar+|]+ , crSite = mkName "theSite"+ }++handleFoo :: [String] -> Explode MyRoutes murl marg+handleFoo a mrender _surl tomurl _marg _tosarg _badmethod _method _req = return $ Response+ Status200+ []+ $ Right $ fromLBS $ pack $ show ("in foo", mrender $ tomurl $ User 78, a)++handleBar :: String -> Explode MyRoutes murl marg+handleBar a mrender _surl tomurl _marg _tosarg _badmethod _method _req = return $ Response+ Status200+ []+ $ Right $ fromLBS $ pack $ show ("in bar", mrender $ tomurl $ User 78, a)++getHome :: Explode MyRoutes murl marg+getHome mrender _surl tomurl marg tosarg _badmethod _method _req = return $ Response+ Status200+ []+ $ Right $ fromLBS $ pack $ show+ [ show $ tosarg marg+ , mrender $ tomurl $ Foo ["bar baz+bin"]+ ]++getUser :: Integer -> Explode MyRoutes murl marg+getUser uid mrender _surl tomurl marg tosarg _badmethod _method _req = return $ Response+ Status200+ []+ $ Right $ fromLBS $ pack $ unlines+ [ "Getting user"+ , show uid+ , show $ tosarg marg+ , mrender $ tomurl Home+ ]++putUser :: Integer -> Explode MyRoutes murl marg+putUser = undefined++deleteUser :: Integer -> Explode MyRoutes murl marg+deleteUser = undefined++msg404 :: String -> Application+msg404 s _ = return $ Response+ Status404+ []+ $ Right $ fromLBS $ pack $ "Not found: " ++ s++{-+badMethod :: Application+badMethod _ = return $ Response+ Status200+ []+ $ Right $ fromLBS $ pack "Bad method"+-}++main :: IO ()+main = defaultMain+ [ testSuite+ , testProperty "parse/render id" $+ \r -> quasiParse theSite (quasiRender theSite r) == Right r+ ]++instance Arbitrary MyRoutes where+ arbitrary = oneof+ [ return Home+ , User <$> arbitrary+ , Static . StaticRoutes <$> arbitrary+ , Foo <$> arbitrary+ , Bar <$> arbitrary+ ]++waiSite :: Site a Application -> Application+waiSite s req = do+ let pi' = unpack $ pathInfo req+ pis = splitPath $ drop1Slash pi'+ url = parsePathSegments s pis+ case url of+ Left s' -> msg404 s' req+ Right u -> handleSite s (joinPath "http://localhost:3000/" . formatPathSegments s) u req++joinPath :: String -> [String] -> String+joinPath s [] = s+joinPath s (x:xs) = joinPath (s ++ encodeUrl x ++ "/") xs++splitPath :: String -> [String]+splitPath "" = []+splitPath x =+ let (y, z) = break (== '/') x+ in y : splitPath (drop1Slash z)++drop1Slash :: String -> String+drop1Slash ('/':x) = x+drop1Slash x = x
+ web-routes-quasi.cabal view
@@ -0,0 +1,40 @@+name: web-routes-quasi+version: 0.0.0+license: BSD3+license-file: LICENSE+author: Michael Snoyman <michael@snoyman.com>+maintainer: Michael Snoyman <michael@snoyman.com>+synopsis: Define data types and parse/build functions for web-routes via a quasi-quoted DSL+category: Web+stability: unstable+cabal-version: >= 1.6+build-type: Simple+homepage: http://docs.yesodweb.com/web-routes-quasi/++flag buildtests+ description: Build the executable to run unit tests+ default: False++library+ build-depends: base >= 4 && < 5,+ web-routes >= 0.22 && < 0.23,+ template-haskell >= 2.4 && < 2.5+ exposed-modules: Web.Routes.Quasi+ ghc-options: -Wall++executable runtests+ if flag(buildtests)+ Buildable: True+ cpp-options: -DTEST+ build-depends: QuickCheck >= 2 && < 3,+ web-encodings,+ bytestring,+ wai,+ wai-extra+ else+ Buildable: False+ main-is: runtests.hs++source-repository head+ type: git+ location: git://github.com/snoyberg/web-routes-quasi.git