{-# 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 ''Routes `AppT` 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 :: QuasiSiteSettings -> [Resource] -> Q [Clause]
createParse set 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 argType f _ -> do
parse <- [|quasiParse|]
let siteType = ConT ''QuasiSite
`AppT` crApplication set
`AppT` ConT (mkName argType)
`AppT` crArgument set
siteVar = VarE (mkName f) `SigE` siteType
let parse' = parse `AppE` siteVar
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 :: QuasiSiteSettings -> [Resource] -> Q [Clause]
createRender set 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 argType f _) = do
format <- [|quasiRender|]
let siteType = ConT ''QuasiSite
`AppT` crApplication set
`AppT` ConT (mkName argType)
`AppT` crArgument set
siteVar = VarE (mkName f) `SigE` siteType
let format' = format `AppE` siteVar
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 argType f getArg -> do
qd <- [|quasiDispatch|]
let siteType = ConT ''QuasiSite
`AppT` crApplication set
`AppT` ConT (mkName argType)
`AppT` crArgument set
siteVar = VarE (mkName f) `SigE` siteType
let disp = qd `AppE` siteVar
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 set $ crResources set
renderClauses <- createRender set $ 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