{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, DeriveDataTypeable, RankNTypes, TypeOperators, QuasiQuotes #-}
module Web.Route.Invertible.Route
( RoutePredicate(..)
, Route(..)
, routeHost
, routeSecure
, routePath
, routeMethod
, routeMethods
, routeQuery
, routeAccept
, routeAccepts
, routeCustom
, routeFilter
, routePriority
, normRoute
, foldRoute
, requestRoute'
, requestRoute
, RouteAction(..)
, mapActionRoute
, requestActionRoute
) where
import Control.Invertible.Monoidal
import Control.Invertible.Monoidal.Free
import Control.Monad (guard)
import qualified Data.HashMap.Lazy as HM
import qualified Data.Invertible as I
import Data.Monoid (Endo(..))
import Data.Typeable (Typeable)
import Web.Route.Invertible.Placeholder
import Web.Route.Invertible.Sequence
import Web.Route.Invertible.Host
import Web.Route.Invertible.Method
import Web.Route.Invertible.Path
import Web.Route.Invertible.Query
import Web.Route.Invertible.ContentType
import Web.Route.Invertible.Request
data RoutePredicate a where
RouteHost :: !(Host h) -> RoutePredicate h
RouteSecure :: !Bool -> RoutePredicate ()
RoutePath :: !(Path p) -> RoutePredicate p
RouteMethod :: !Method -> RoutePredicate ()
RouteQuery :: !QueryString -> !(Placeholder QueryString a) -> RoutePredicate a
RouteAccept :: !ContentType -> RoutePredicate ()
RouteCustom :: Typeable a => (Request -> Maybe a) -> (a -> Request -> Request) -> RoutePredicate a
RoutePriority :: !Int -> RoutePredicate ()
instance Show (RoutePredicate a) where
showsPrec d (RouteHost h) = showParen (d > 10) $
showString "RouteHost " . showsPrec 11 h
showsPrec d (RouteSecure s) = showParen (d > 10) $
showString "RouteSecure " . showsPrec 11 s
showsPrec d (RoutePath p) = showParen (d > 10) $
showString "RoutePath " . showsPrec 11 p
showsPrec d (RouteMethod m) = showParen (d > 10) $
showString "RouteMethod " . showsPrec 11 m
showsPrec d (RouteQuery q p) = showParen (d > 10) $
showString "RouteQuery " . showsPrec 11 q . showString " " . showsPrec 11 p
showsPrec d (RouteAccept t) = showParen (d > 10) $
showString "RouteAccept " . showsPrec 11 t
showsPrec d (RouteCustom _ _) = showParen (d > 10) $
showString "RouteCustom <function> <function>"
showsPrec d (RoutePriority p) = showParen (d > 10) $
showString "RoutePriority " . showsPrec 11 p
newtype Route a = Route { freeRoute :: Free RoutePredicate a }
deriving (I.Functor, Monoidal, MonoidalAlt)
instance Show (Route a) where
showsPrec d (Route s) = showParen (d > 10) $
showString "Route " . showsFree (showsPrec 11) s
routeHost :: Host h -> Route h
routeHost = Route . Free . RouteHost
routeSecure :: Bool -> Route ()
routeSecure = Route . Free . RouteSecure
routePath :: Path p -> Route p
routePath = Route . Free . RoutePath
routeMethod :: IsMethod m => m -> Route ()
routeMethod = Route . Free . RouteMethod . toMethod
routeMethods :: (Eq m, IsMethod m) => [m] -> Route m
routeMethods = oneOfI routeMethod
routeQuery :: QueryString -> Placeholder QueryString a -> Route a
routeQuery q = Route . Free . RouteQuery q
routeAccept :: ContentType -> Route ()
routeAccept = Route . Free . RouteAccept
routeAccepts :: [ContentType] -> Route ContentType
routeAccepts = oneOfI routeAccept
routeCustom :: Typeable a => (Request -> Maybe a) -> (a -> Request -> Request) -> Route a
routeCustom fwd rev = Route $ Free $ RouteCustom fwd rev
routeFilter :: (Request -> Bool) -> Route ()
routeFilter f = routeCustom (guard . f) (\() -> id)
routePriority :: Int -> Route ()
routePriority = Route . Free . RoutePriority
predicateOrder :: RoutePredicate a -> Int
predicateOrder (RouteHost _) = 1
predicateOrder (RouteSecure _) = 2
predicateOrder (RoutePath _) = 3
predicateOrder (RouteMethod _) = 4
predicateOrder (RouteQuery _ _) = 5
predicateOrder (RouteAccept _) = 6
predicateOrder (RouteCustom _ _) = 7
predicateOrder (RoutePriority _) = 8
comparePredicate :: RoutePredicate a -> RoutePredicate b -> Ordering
comparePredicate (RouteQuery p _) (RouteQuery q _) = compare p q
comparePredicate p q = compare (predicateOrder p) (predicateOrder q)
normRoute :: Route a -> Route a
normRoute = Route . sortFreeTDNF comparePredicate . freeRoute
foldRoute :: Monoid b => (forall a' . RoutePredicate a' -> a' -> b) -> Route a -> a -> b
foldRoute f (Route r) = foldFree f r
requestRoutePredicate :: RoutePredicate a -> a -> Request -> Request
requestRoutePredicate (RouteHost (HostRev s)) h q = q{ requestHost = renderSequence s h }
requestRoutePredicate (RouteSecure s) () q = q{ requestSecure = s }
requestRoutePredicate (RoutePath (Path s)) p q = q{ requestPath = renderSequence s p }
requestRoutePredicate (RouteMethod m) () q = q{ requestMethod = m }
requestRoutePredicate (RouteQuery n p) v q = q{ requestQuery = HM.insertWith (++) n [renderPlaceholder p v] $ requestQuery q }
requestRoutePredicate (RouteAccept t) () q = q{ requestContentType = t }
requestRoutePredicate (RouteCustom _ f) a q = f a q
requestRoutePredicate (RoutePriority _) () q = q
requestRoute' :: Route a -> a -> Request -> Request
requestRoute' r = appEndo . foldRoute (\p -> Endo . requestRoutePredicate p) r
requestRoute :: Route a -> a -> Request
requestRoute r a = requestRoute' r a blankRequest
data RouteAction a b = RouteAction
{ actionRoute :: !(Route a)
, routeAction :: !(a -> b)
}
infix 1 `RouteAction`
instance Functor (RouteAction a) where
fmap f (RouteAction r a) = RouteAction r $ f . a
mapActionRoute :: (a I.<-> b) -> RouteAction a r -> RouteAction b r
mapActionRoute f (RouteAction r a) = RouteAction (f >$< r) (a . I.biFrom f)
requestActionRoute :: RouteAction a b -> a -> Request
requestActionRoute = requestRoute . actionRoute