module Web.Wheb.Routes
(
(</>)
, grabInt
, grabText
, pT
, pS
, patRoute
, compilePat
, rootPat
, getParam
, matchUrl
, generateUrl
, findUrlMatch
, testUrlParser
) where
import qualified Data.Text.Lazy as T
import Data.Text.Lazy.Read
import Data.Maybe (isJust)
import Data.Typeable
import Network.HTTP.Types.Method
import Network.HTTP.Types.URI
import Data.Maybe (fromJust)
import Data.Monoid ((<>))
import Web.Wheb.Types
import Web.Wheb.Utils
patRoute :: (Maybe T.Text) ->
StdMethod ->
UrlPat ->
WhebHandlerT g s m ->
Route g s m
patRoute n m p = Route n (==m) (compilePat p)
compilePat :: UrlPat -> UrlParser
compilePat (Composed a) = UrlParser (matchPat a) (buildPat a)
compilePat a = UrlParser (matchPat [a]) (buildPat [a])
rootPat :: UrlPat
rootPat = Chunk $ T.pack ""
(</>) :: UrlPat -> UrlPat -> UrlPat
(Composed a) </> (Composed b) = Composed (a ++ b)
a </> (Composed b) = Composed (a:b)
(Composed a) </> b = Composed (a ++ [b])
a </> b = Composed [a, b]
grabInt :: T.Text -> UrlPat
grabInt key = FuncChunk key f IntChunk
where rInt = decimal :: Reader Int
f = ((either (const Nothing) (Just . MkChunk . fst)) . rInt)
grabText :: T.Text -> UrlPat
grabText key = FuncChunk key (Just . MkChunk) TextChunk
pT :: T.Text -> UrlPat
pT = Chunk
pS :: String -> UrlPat
pS = pT . T.pack
getParam :: Typeable a => T.Text -> RouteParamList -> Maybe a
getParam k l = (lookup k l) >>= unwrap
where unwrap :: Typeable a => ParsedChunk -> Maybe a
unwrap (MkChunk a) = cast a
matchUrl :: [T.Text] -> UrlParser -> Maybe RouteParamList
matchUrl url (UrlParser f _) = f url
generateUrl :: UrlParser -> RouteParamList -> Either UrlBuildError T.Text
generateUrl (UrlParser _ f) = f
findUrlMatch :: StdMethod ->
[T.Text] ->
[Route g s m] ->
Maybe (WhebHandlerT g s m, RouteParamList)
findUrlMatch _ _ [] = Nothing
findUrlMatch rmtd path ((Route _ methodMatch (UrlParser f _) h):rs)
| not (methodMatch rmtd) = findUrlMatch rmtd path rs
| otherwise = case f path of
Just params -> Just (h, params)
Nothing -> findUrlMatch rmtd path rs
testUrlParser :: UrlParser -> RouteParamList -> Bool
testUrlParser up rpl =
case generateUrl up rpl of
Left _ -> False
Right t -> case (matchUrl (fmap T.fromStrict $ decodeUrl t) up) of
Just params -> either (const False) (==t) (generateUrl up params)
Nothing -> False
where decodeUrl = decodePathSegments . lazyTextToSBS
matchPat :: [UrlPat] -> [T.Text] -> Maybe RouteParamList
matchPat chunks [] = matchPat chunks [T.pack ""]
matchPat chunks t = parse t chunks []
where parse [] [] params = Just params
parse [] c params = Nothing
parse (u:[]) [] params | T.null u = Just params
| otherwise = Nothing
parse (u:us) [] _ = Nothing
parse (u:us) ((Chunk c):cs) params | T.null c = parse (u:us) cs params
| u == c = parse us cs params
| otherwise = Nothing
parse (u:us) ((FuncChunk k f _):cs) params = do
val <- f u
parse us cs ((k, val):params)
parse us ((Composed xs):cs) params = parse us (xs ++ cs) params
buildPat :: [UrlPat] -> RouteParamList -> Either UrlBuildError T.Text
buildPat pats params = fmap addSlashes $ build [] pats
where build acc [] = Right acc
build acc ((Chunk c):[]) = build (acc <> [c]) []
build acc ((Chunk c):cs) | T.null c = build acc cs
| otherwise = build (acc <> [c]) cs
build acc ((Composed xs):cs) = build acc (xs <> cs)
build acc ((FuncChunk k _ t):cs) =
case (showParam t k params) of
(Right v) -> build (acc <> [v]) cs
(Left err) -> Left err
addSlashes [] = T.pack "/"
addSlashes list = builderToText $
encodePathSegments (fmap T.toStrict list)
showParam :: ChunkType -> T.Text -> RouteParamList -> Either UrlBuildError T.Text
showParam chunkType k l =
case (lookup k l) of
Just (MkChunk v) -> case chunkType of
IntChunk -> toEither $ fmap spack (cast v :: Maybe Int)
TextChunk -> toEither (cast v :: Maybe T.Text)
Nothing -> Left NoParam
where toEither v = case v of
Just b -> Right b
Nothing -> Left $ ParamTypeMismatch k