packages feed

web-inv-route (empty) → 0.1

raw patch · 40 files changed

+2442/−0 lines, 40 filesdep +HUnitdep +basedep +bytestringsetup-changed

Dependencies added: HUnit, base, bytestring, case-insensitive, containers, happstack-server, hashable, http-types, invertible, network-uri, snap-core, text, transformers, unordered-containers, wai, web-inv-route

Files

+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ Web/Route/Invertible.hs view
@@ -0,0 +1,45 @@+-- |+-- This provides a generic, framework-agnostic interface to routing.+-- If you have a 'RouteMap' (see "Web.Route.Invertible.Common"), make a 'Request' to describe an incoming request, and call 'lookupRoute' or 'routeRequest' to find the route.+-- See 'RouteRequest' for handling errors or the result.+--+-- You can also use 'requestActionRoute' to produce a 'Request' from a route endpoint.+module Web.Route.Invertible+  ( module Web.Route.Invertible.Common+  , normRoute+    -- * Request representation+  , HostString+  , PathString+  , normalizePath+  , Method(..)+  , IsMethod(..)+  , Request(..)+    -- * Forward routing+  , RouteResult(..)+  , lookupRoute+  , routeRequest+    -- * Reverse routing+  , requestActionRoute+  ) where++import Control.Invertible.Monoidal+import Network.HTTP.Types.Header (ResponseHeaders)+import Network.HTTP.Types.Status (Status)++import Web.Route.Invertible.Parameter+import Web.Route.Invertible.Placeholder+import Web.Route.Invertible.Sequence+import Web.Route.Invertible.Host+import Web.Route.Invertible.Path+import Web.Route.Invertible.Method+import Web.Route.Invertible.Query+import Web.Route.Invertible.Route+import Web.Route.Invertible.Request+import Web.Route.Invertible.Result+import Web.Route.Invertible.Map.Route+import Web.Route.Invertible.Common++-- |Lookup a request in a routing table and transform errors to appropriate HTTP status and headers.+-- It is up to the user to provide an appropriate body (if any).+routeRequest :: Request -> RouteMap a -> Either (Status, ResponseHeaders) a+routeRequest q = routeResult . lookupRoute q
+ Web/Route/Invertible/Common.hs view
@@ -0,0 +1,98 @@+-- |+-- The basic routing API, sufficient for route and routing map construction.+-- There is usually no need to import this module directly as it is re-exported by most other exposed interfaces.+--+-- This package supports route construction as follows:+--+--   1. Endpoint specification, which consists of a 'Route' /key/ and action /value/.+--+--       * Describe the parameters of each endpoint using 'Route', which is constructed by composing the @route*@ functions ('routeHost', 'routePath', 'routeMethod', 'routeQuery', etc.) using "Control.Invertible.Monoidal" operators.  Typically these predicates should be specified in order for sensible routing, but you can also use 'normRoute' to reorder them automatically.+--       * Join the route with a target using @\`RouteAction\`@.  This target action is the /value/ associated with the route /key/, and is usually an action to produce a response in your preferred framework (but could be anything).+--       * The 'RouteAction' should typically be assigned to a top-level variable.  While the type of the @Route@ parameter can differ for each route, all action values must have the same result type.+--+--       @+--       getThing :: 'RouteAction' Int (IO Response)+--       getThing =+--         'routePath' ("thing" *\< 'parameter') \>*+--         'routeMethod' GET+--         \`RouteAction\` \\thingId -> do+--           return Response{..}+--+--       postThingValue :: 'RouteAction' (Int, String) (IO Response)+--       postThingValue =+--         'routeSecure' True *\<+--         'routePath' ("thing" *\< 'parameter' \>* "value" \>*\< 'parameter') \>*+--         'routeMethod' POST+--         `RouteAction` \\(thingId, attribute) ->+--           set thingId attribute =<< getRequestBody+--           return Response{..}+--       @+--+--   2. Route Map specification.+--+--       * Apply each of the 'RouteAction's in your program to 'routeCase' (or 'routeNormCase' -- see 'normRoute').+--       * Apply 'routes' to a list of the resulting 'RouteCase's to form a 'RouteMap'.+--+--       @+--       myRoutes = 'routes'+--         [ 'routeCase' getThing+--         , 'routeCase' postThingValue+--         , ..+--         ]+--       @+--+--  You can also add support for new parameter types by creating your own instances of 'Parameter'.+module Web.Route.Invertible.Common+  ( +    -- * Route construction+    Route+  , routeHost+  , routeSecure+  , routePath+  , routeMethod+  , routeMethods+  , routeQuery+  , routeAccept+  , routeAccepts+  , routeCustom+  , routePriority+  , RouteAction(..)+  , mapActionRoute+    -- ** Supporting types+  , Host+  , Path+  , IsMethod+  , QueryString+  , ContentType+    -- ** Parser construction+  , module Control.Invertible.Monoidal+  , wildcard+    -- ** Placeholder parameters+  , RouteString+  , Parameter(..)+  , Parameterized+  , parameter+  , param+  , Placeholder+    -- * Forward routing+  , RouteCase+  , routeCase+  , routeNormCase+  , RouteMap+  , routes+  , fallbackHEADtoGET+  ) where++import Control.Invertible.Monoidal++import Web.Route.Invertible.String+import Web.Route.Invertible.Parameter+import Web.Route.Invertible.Placeholder+import Web.Route.Invertible.Sequence+import Web.Route.Invertible.Host+import Web.Route.Invertible.Path+import Web.Route.Invertible.Method+import Web.Route.Invertible.Query+import Web.Route.Invertible.ContentType+import Web.Route.Invertible.Route+import Web.Route.Invertible.Map.Route
+ Web/Route/Invertible/ContentType.hs view
@@ -0,0 +1,8 @@+module Web.Route.Invertible.ContentType+  ( ContentType+  ) where++import qualified Data.ByteString as BS++-- |String representation of content types, e.g., from HTTP \"Content-type\" headers.+type ContentType = BS.ByteString
+ Web/Route/Invertible/Dynamics.hs view
@@ -0,0 +1,25 @@+-- |+-- As keys are looked up in maps, dynamic parsed placeholders are collected as a list of 'Dynamic's.+module Web.Route.Invertible.Dynamics+  ( Dynamics+  , DynamicState+  , DynamicResult+  , getDynamic+  ) where++import Data.Dynamic (Dynamic, fromDyn)+import Data.Typeable (Typeable)+import Control.Monad.Trans.State (StateT(..), State)++-- |Uncons the current state, leaving the tail in the state and returning the head.+-- (This should probably be moved to some other module.)+unconsState' :: State [a] a+unconsState' = StateT $ \(~(x:l)) -> return (x, l)++type Dynamics = [Dynamic]+type DynamicState = State Dynamics+type DynamicResult a = (Dynamics, a)++getDynamic :: Typeable a => DynamicState a+getDynamic = (`fromDyn` error "Web.Route.Invertible.getDynamic: internal type error") <$> unconsState'+
+ Web/Route/Invertible/Happstack.hs view
@@ -0,0 +1,36 @@+-- |A compatibility routing layer for Happstack applications.+module Web.Route.Invertible.Happstack+  ( module Web.Route.Invertible.Common+  , routeHappstack+  ) where++import Control.Arrow ((***), left)+import qualified Data.ByteString.Char8 as BSC+import qualified Data.ByteString.Lazy as BSL+import qualified Data.CaseInsensitive as CI+import Data.Maybe (fromMaybe)+import qualified Data.Text as T+import Network.HTTP.Types.Header (hHost, hContentType)+import Network.HTTP.Types.Status (statusCode)+import qualified Happstack.Server.Types as HS++import Web.Route.Invertible.Internal+import Web.Route.Invertible.Common+import Web.Route.Invertible++happstackRequest :: HS.Request -> Request+happstackRequest q = Request+  { requestHost = maybe [] splitHost $ HS.getHeaderBS (CI.original hHost) q+  , requestSecure = HS.rqSecure q+  , requestMethod = toMethod $ HS.rqMethod q+  , requestPath = map T.pack $ HS.rqPaths q+  , requestQuery = simpleQueryParams $ map (BSC.pack *** either BSC.pack BSL.toStrict . HS.inputValue) $ HS.rqInputsQuery q+  , requestContentType = fromMaybe mempty $ HS.getHeaderBS (CI.original hContentType) q+  }++-- |Lookup a Happstack request in a route map, returning either an empty error response or a successful result.+routeHappstack :: HS.Request -> RouteMap a -> Either HS.Response a+routeHappstack q = left err . routeRequest (happstackRequest q) where+  err (s, h) = foldr (\(n,v) -> HS.setHeaderBS (CI.original n) v)+    (HS.resultBS (statusCode s) BSL.empty)+    h
+ Web/Route/Invertible/Host.hs view
@@ -0,0 +1,57 @@+-- |+-- Domainname parsers (specialization of "Web.Route.Invertible.Sequence").+-- These can be used for virtual hosting or otherwise matching on hostnames.+{-# LANGUAGE GeneralizedNewtypeDeriving, StandaloneDeriving, FlexibleInstances, FlexibleContexts #-}+module Web.Route.Invertible.Host+  ( HostString+  , splitHost+  , joinHost+  , Host(..)+  , renderHost+  ) where++import Prelude hiding (lookup)++import Control.Invertible.Monoidal+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BSC+import qualified Data.Invertible as I+import Data.String (IsString(..))++import Web.Route.Invertible.Parameter+import Web.Route.Invertible.Placeholder+import Web.Route.Invertible.Sequence++-- |The representation for domain names or domain name segments (after 'splitHost').+type HostString = BS.ByteString++-- |Split (and reverse) a domainname on \".\" for use with 'Host'.+splitHost :: BS.ByteString -> [HostString]+splitHost = reverse . BSC.split '.'++-- |Reverse and join a hostname with \".\".+joinHost :: [HostString] -> BS.ByteString+joinHost = BS.intercalate (BSC.singleton '.') . reverse++-- |A hostname matcher.+-- These should typically be constructed using the 'IsString' and 'Parameterized' instances.+-- This matches hostnames in reverse order (from TLD down), but the 'Monoidal' instance and 'splitHost' automatically deal with this for you.+-- Example:+--+-- > parameter >* "domain" >* "com" :: Host String+--+-- matches (or generates) @*.domain.com@ and returns the @*@ component.+newtype Host a = HostRev { hostSequence :: Sequence HostString a }+  deriving (I.Functor, MonoidalAlt, Parameterized HostString, Show)++instance Monoidal Host where+  unit = HostRev unit+  HostRev p >*< HostRev q = I.swap >$< HostRev (q >*< p)++-- |Since domain components cannot contain \".\", @"foo.com"@ is equivalent to @"foo" *< "com"@ (unlike other 'Sequence's).+instance IsString (Host ()) where+  fromString s = HostRev $ mapI_ (placeholderSequence . PlaceholderFixed) $ splitHost $ fromString s++-- |Instantiate a host with a value and render it as a domainname.+renderHost :: Host a -> a -> BS.ByteString+renderHost (HostRev p) a = joinHost $ renderSequence p a
+ Web/Route/Invertible/Internal.hs view
@@ -0,0 +1,46 @@+-- |+-- This module exposes more of the inner workings of route construction for extensiblity and direct access.+-- You may need interfaces like 'IsMethod' or 'QueryParams' to add support for a new web framework, for example.+-- In particular, functions like 'foldRoute' and 'pathValues' can be used to extract low-level information about individual routes.+module Web.Route.Invertible.Internal+  ( -- * General+    RouteString(..)+  , Placeholder(..)+  , PlaceholderValue(..)+  , Sequence(..)+    -- * Path+  , Path(..)+  , normalizePath+  , pathValues+  , renderPath+  , urlPathBuilder+    -- * Host+  , Host(..)+  , splitHost+  , joinHost+  , renderHost+    -- * Method+  , IsMethod(..)+    -- * Query+  , QueryParams+  , paramsQuerySimple+  , simpleQueryParams+    -- * Route+  , blankRequest+  , RoutePredicate(..)+  , Route(..)+  , normRoute+  , foldRoute+  , requestRoute'+  , requestRoute+  ) where++import Web.Route.Invertible.String+import Web.Route.Invertible.Placeholder+import Web.Route.Invertible.Sequence+import Web.Route.Invertible.Host+import Web.Route.Invertible.Path+import Web.Route.Invertible.Method+import Web.Route.Invertible.Query+import Web.Route.Invertible.Request+import Web.Route.Invertible.Route
+ Web/Route/Invertible/Map.hs view
@@ -0,0 +1,34 @@+-- |+module Web.Route.Invertible.Map+  ( lookupParameter+  , reduce+  , lookupExactly+  , fallback+  ) where++import Prelude hiding (lookup)++import Control.Monad ((<=<))+import qualified Data.Map.Strict as M++import Web.Route.Invertible.Monoid.Exactly+import Web.Route.Invertible.Parameter++-- |Combine 'parseParameter' and 'M.lookup'.+lookupParameter :: (Ord p, Parameter s p) => s -> M.Map p a -> Maybe a+lookupParameter s m = parseParameter s >>= (`M.lookup` m)++-- |Eliminate 'Blank' values, and (strictly) produce an error for 'Conflict' values.+reduce :: M.Map k (Exactly a) -> M.Map k a+reduce = M.mapMaybe exactlyToMaybe++-- |Combine 'exactlyToMaybe' and 'M.lookup'.+lookupExactly :: Ord k => k -> M.Map k (Exactly a) -> Maybe a+lookupExactly k = exactlyToMaybe <=< M.lookup k++-- |When the first key is not in the map, produce a new map that falls back to the second key instead.+-- That is, create a new map where the second key's value is copied to the first key without overwriting.+fallback :: Ord k => k -> k -> M.Map k a -> M.Map k a+fallback from to m+  | Just v <- M.lookup to m = M.insertWith (\_ -> id) from v m+  | otherwise = m
+ Web/Route/Invertible/Map/Bool.hs view
@@ -0,0 +1,39 @@+-- |Trivial map from boolean-valued keys to values, which just stores both possible values.+{-# LANGUAGE FlexibleContexts #-}+module Web.Route.Invertible.Map.Bool+  ( BoolMap(..)+  , emptyBoolMap+  , singletonBool+  , lookupBool+  ) where++import Data.Monoid ((<>))++-- |A trivial, flat representation of a 'Bool'-keyed map.+-- Value existance (but not the values themselves) is strict.+data BoolMap v = BoolMap+  { boolMapFalse :: !(Maybe v) -- ^The value associated with 'False'.+  , boolMapTrue :: !(Maybe v) -- ^The value associated with 'True'.+  } deriving (Eq, Show)++instance Functor BoolMap where+  fmap f (BoolMap a b) = BoolMap (fmap f a) (fmap f b)++instance (Monoid v) => Monoid (BoolMap v) where+  mempty = emptyBoolMap+  mappend (BoolMap a1 b1) (BoolMap a2 b2) = BoolMap (a1 <> a2) (b1 <> b2)++-- |The empty map.+emptyBoolMap :: BoolMap a+emptyBoolMap = BoolMap Nothing Nothing++-- |A map with a single element, or if the key is @Nothing@, with both elements with same value.+singletonBool :: Maybe Bool -> a -> BoolMap a+singletonBool Nothing a = BoolMap (Just a) (Just a)+singletonBool (Just False) a = BoolMap (Just a) Nothing+singletonBool (Just True) a = BoolMap Nothing (Just a)++-- |Lookup the value at a key in the map.+lookupBool :: Bool -> BoolMap a -> Maybe a+lookupBool False (BoolMap a _) = a+lookupBool True (BoolMap _ a) = a
+ Web/Route/Invertible/Map/Const.hs view
@@ -0,0 +1,58 @@+-- |+-- A map transformer that allows all keys to (additionally) map to a constant value.+{-# LANGUAGE FlexibleContexts #-}+module Web.Route.Invertible.Map.Const+  ( ConstMap(..)+  , withConstMap+  , constantMap+  , constantValue+  , lookupConst+  , flattenConstMap+  , ConstDefaultMap+  , flattenConstDefaultMap+  ) where++import Data.Monoid ((<>))++import Web.Route.Invertible.Map.Default++-- |A monoid map where every key (additionally) maps to the same constant value, parameterized over the type of the map.+data ConstMap m v = ConstMap+  { constMap :: !(m v) -- ^The underlying map.+  , constValue :: !v } -- ^The constant value to return for any key.+  deriving (Show)++instance Functor m => Functor (ConstMap m) where+  fmap f (ConstMap m v) = ConstMap (fmap f m) (f v)++instance (Monoid v, Monoid (m v)) => Monoid (ConstMap m v) where+  mempty = ConstMap mempty mempty+  mappend (ConstMap m1 v1) (ConstMap m2 v2) = ConstMap (m1 <> m2) (v1 <> v2)++-- |Transform the underlying map.+withConstMap :: (m v -> n v) -> ConstMap m v -> ConstMap n v+withConstMap f (ConstMap m v) = ConstMap (f m) v++-- |A simple map that has no constant value (or rather, has a constant value of 'mempty') so acts just like the given monoid map.+constantMap :: Monoid v => m v -> ConstMap m v+constantMap m = ConstMap m mempty++-- |A trivial map that maps all keys to the same value.+constantValue :: Monoid (m v) => v -> ConstMap m v+constantValue = ConstMap mempty++-- |Given a lookup function for the underlying map, add the constant value to the result (using 'mappend').+lookupConst :: Monoid v => (m v -> v) -> ConstMap m v -> v+lookupConst l (ConstMap m v) = l m <> v++-- |Convert a 'ConstMap' to an equivalent but more efficient 'DefaultMap'.+-- Although the resulting map will return the same value for lookups, combining it with other maps will have different results (this operation is not distributive).+flattenConstMap :: (Functor m, Monoid v) => ConstMap m v -> DefaultMap m v+flattenConstMap (ConstMap m v) = DefaultMap (fmap (<> v) m) (Just v)++-- |A 'DefaultMap' wrapped in a 'ConstMap', for when you want both a constant and default value.+type ConstDefaultMap m = ConstMap (DefaultMap m)++-- |Do the same as 'flattenConstMap' but for 'ConstDefaultMap' by merging the resulting 'DefaultMap' layers.+flattenConstDefaultMap :: (Functor m, Monoid v) => ConstDefaultMap m v -> DefaultMap m v+flattenConstDefaultMap (ConstMap (DefaultMap m d) v) = DefaultMap (fmap (<> v) m) (d <> Just v)
+ Web/Route/Invertible/Map/Custom.hs view
@@ -0,0 +1,21 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, TupleSections #-}+module Web.Route.Invertible.Map.Custom+  ( CustomMap+  , singletonCustom+  , lookupCustom+  ) where++import Data.Maybe (mapMaybe)+import Text.Show.Functions ()++newtype CustomMap q a b = CustomMap [(q -> Maybe a, b)]+  deriving (Show, Monoid)++instance Functor (CustomMap q a) where+  fmap f (CustomMap l) = CustomMap $ map (fmap f) l++singletonCustom :: (q -> Maybe a) -> b -> CustomMap q a b+singletonCustom f x = CustomMap [(f, x)]++lookupCustom :: q -> CustomMap q a b -> [(a, b)]+lookupCustom q (CustomMap l) = mapMaybe (\(f, r) -> (, r) <$> f q) l
+ Web/Route/Invertible/Map/Default.hs view
@@ -0,0 +1,42 @@+-- |+-- A map transformer that allows unknown keys to map to a default value.+{-# LANGUAGE FlexibleContexts #-}+module Web.Route.Invertible.Map.Default+  ( DefaultMap(..)+  , defaultingMap+  , defaultingValue+  , withDefaultMap+  , lookupDefault+  ) where++import Control.Applicative ((<|>))+import Data.Monoid ((<>))++-- |A map that also provides a default value, for when a key is not found in the underlying map, parameterized over the type of the map.+data DefaultMap m v = DefaultMap+  { defaultMap :: !(m v)+  , defaultValue :: !(Maybe v)+  } deriving (Eq, Show)++instance Functor m => Functor (DefaultMap m) where+  fmap f (DefaultMap m d) = DefaultMap (fmap f m) (fmap f d)++instance (Monoid v, Monoid (m v)) => Monoid (DefaultMap m v) where+  mempty = DefaultMap mempty Nothing+  mappend (DefaultMap m1 d1) (DefaultMap m2 d2) = DefaultMap (m1 <> m2) (d1 <> d2)++-- |A simple map with no default value.+defaultingMap :: m v -> DefaultMap m v+defaultingMap m = DefaultMap m Nothing++-- |A trivial map with only a default value.+defaultingValue :: Monoid (m v) => v -> DefaultMap m v+defaultingValue = DefaultMap mempty . Just++-- |Transform the underlying map.+withDefaultMap :: (m v -> n v) -> DefaultMap m v -> DefaultMap n v+withDefaultMap f (DefaultMap m v) = DefaultMap (f m) v++-- |Given a lookup function for the underlying map, return the default value instead if the value is not in the map.+lookupDefault :: (m v -> Maybe v) -> DefaultMap m v -> Maybe v+lookupDefault l (DefaultMap m d) = l m <|> d
+ Web/Route/Invertible/Map/Host.hs view
@@ -0,0 +1,14 @@+-- |+-- An efficient routing map for host names.+module Web.Route.Invertible.Map.Host+  ( HostMap+  ) where++import Prelude hiding (lookup)++import Web.Route.Invertible.Host+import Web.Route.Invertible.Map.Sequence++-- |Map over 'Host' values.+type HostMap = SequenceMap HostString+
+ Web/Route/Invertible/Map/Method.hs view
@@ -0,0 +1,44 @@+-- |+-- Functionality specific to 'MonoidMap's over 'Method's.+module Web.Route.Invertible.Map.Method+  ( MethodMap+  , fallbackMethodHEADtoGET+  , fallbackDefaultMethodHEADtoGET+  , lookupMethod+  , lookupDefaultMethod+  ) where++import Prelude hiding (lookup)++import qualified Data.Map.Strict as M++import Web.Route.Invertible.Method+import Web.Route.Invertible.Map+import Web.Route.Invertible.Map.Monoid+import Web.Route.Invertible.Map.Default++-- |A 'MonoidMap' keyed on 'Method'+type MethodMap = MonoidMap Method++-- |If there is no value associated with 'HEAD', 'fallback' to the value associated with 'GET'.+fallbackMethodHEADtoGET :: MethodMap a -> MethodMap a+fallbackMethodHEADtoGET = MonoidMap . fallback HEAD GET . monoidMap++-- |'fallbackMethodHEADtoGET' over 'DefaultMap'.+fallbackDefaultMethodHEADtoGET :: DefaultMap MethodMap a -> DefaultMap MethodMap a+fallbackDefaultMethodHEADtoGET = withDefaultMap fallbackMethodHEADtoGET++-- |Either the given value or the list of keys.+orKeys :: MethodMap a -> Maybe a -> Either [Method] a+orKeys (MonoidMap m) = maybe (Left $ M.keys m) Right++-- |Lookup a method in the map, returning either the associated value, or the list of keys.+-- This is useful for generating 405 results.+lookupMethod :: Method -> MethodMap a -> Either [Method] a+lookupMethod s m =+  orKeys m $ M.lookup s $ monoidMap m++-- |'lookupMethod' over 'DefaultMap'.+lookupDefaultMethod :: Method -> DefaultMap MethodMap a -> Either [Method] a+lookupDefaultMethod s d =+  orKeys (defaultMap d) $ lookupDefault (M.lookup s . monoidMap) d
+ Web/Route/Invertible/Map/Monoid.hs view
@@ -0,0 +1,40 @@+-- |+-- A newtyped version of "Data.Map.Strict" with a 'Monoid' instance providing @'mappend' = 'M.unionWith' 'mappend'@.+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module Web.Route.Invertible.Map.Monoid+  ( MonoidMap(..)+  , insertMonoid+  , fromMonoidList+  , lookupMonoid+  ) where++import Prelude hiding (lookup)++import Data.Foldable (fold)+import qualified Data.Map.Strict as M++-- |A specialized version of 'M.Map'.+newtype MonoidMap k a = MonoidMap { monoidMap :: M.Map k a }+  deriving (Eq, Foldable, Show)++-- |'mappend' is equivalent to @'M.unionWith' 'mappend'@.+instance (Ord k, Monoid a) => Monoid (MonoidMap k a) where+  mempty = MonoidMap M.empty+  mappend (MonoidMap a) (MonoidMap b) = MonoidMap $ M.unionWith mappend a b+  mconcat = MonoidMap . M.unionsWith mappend . map monoidMap++instance Functor (MonoidMap k) where+  fmap f (MonoidMap m) = MonoidMap $ M.map f m++-- |Insert a new key and value in the map. If the key is already present in the map, the associated value is combined with the supplied value. Equivalent to @'M.insertWith' 'mappend'@.+insertMonoid :: (Ord k, Monoid a) => k -> a -> MonoidMap k a -> MonoidMap k a+insertMonoid k a (MonoidMap m) = MonoidMap $ M.insertWith mappend k a m++-- |Build a map from a list of key/value pairs. If the list contains more than one value for the same key, the values are combined. Equivalent to @'M.fromListWith' 'mappend'@.+fromMonoidList :: (Ord k, Monoid a) => [(k, a)] -> MonoidMap k a+fromMonoidList = MonoidMap . M.fromListWith mappend++-- |Lookup the value at a key in the map, returning 'mempty' if the key isn't in the map.+lookupMonoid :: (Ord k, Monoid a) => k -> MonoidMap k a -> a+lookupMonoid k (MonoidMap m) = fold $ M.lookup k m+
+ Web/Route/Invertible/Map/MonoidHash.hs view
@@ -0,0 +1,40 @@+-- |+-- A newtyped version of "Data.HashMap.Strict" with a 'Monoid' instance providing @'mappend' = 'M.unionWith' 'mappend'@.+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module Web.Route.Invertible.Map.MonoidHash+  ( MonoidHashMap(..)+  , insertMonoidHash+  , fromMonoidHashList+  , lookupMonoidHash+  ) where++import Prelude hiding (lookup)++import Data.Foldable (fold)+import Data.Hashable (Hashable)+import qualified Data.HashMap.Strict as M++-- |A specialized version of 'M.HashMap'.+newtype MonoidHashMap k a = MonoidHashMap { monoidHashMap :: M.HashMap k a }+  deriving (Eq, Foldable, Show)++-- |'mappend' is equivalent to @'M.unionWith' 'mappend'@.+instance (Eq k, Hashable k, Monoid a) => Monoid (MonoidHashMap k a) where+  mempty = MonoidHashMap M.empty+  mappend (MonoidHashMap a) (MonoidHashMap b) = MonoidHashMap $ M.unionWith mappend a b++instance Functor (MonoidHashMap k) where+  fmap f (MonoidHashMap m) = MonoidHashMap $ M.map f m++-- |Insert a new key and value in the map. If the key is already present in the map, the associated value is combined with the supplied value. Equivalent to @'M.insertWith' 'mappend'@.+insertMonoidHash :: (Eq k, Hashable k, Monoid a) => k -> a -> MonoidHashMap k a -> MonoidHashMap k a+insertMonoidHash k a (MonoidHashMap m) = MonoidHashMap $ M.insertWith mappend k a m++-- |Build a map from a list of key/value pairs. If the list contains more than one value for the same key, the values are combined. Equivalent to @'M.fromListWith' 'mappend'@.+fromMonoidHashList :: (Eq k, Hashable k, Monoid a) => [(k, a)] -> MonoidHashMap k a+fromMonoidHashList = MonoidHashMap . M.fromListWith mappend++-- |Lookup the value at a key in the map, returning 'mempty' if the key isn't in the map.+lookupMonoidHash :: (Eq k, Hashable k, Monoid a) => k -> MonoidHashMap k a -> a+lookupMonoidHash k (MonoidHashMap m) = fold $ M.lookup k m+
+ Web/Route/Invertible/Map/ParameterType.hs view
@@ -0,0 +1,35 @@+-- |+-- A dynamic parameter-parsing map.+module Web.Route.Invertible.Map.ParameterType+  ( ParameterTypeMap+  , singletonParameterType+  , insertParameterType+  , lookupParameterType+  ) where++import Prelude hiding (lookup)++import Data.Dynamic (Dynamic, toDyn)+import qualified Data.Map.Strict as M+import Data.Maybe (maybeToList)++import Web.Route.Invertible.Parameter+import Web.Route.Invertible.Map.Monoid++-- |A map of 'ParameterType's.+type ParameterTypeMap s a = MonoidMap (ParameterType s) a++-- |Equivalent to @'MM.singleton' . 'parameterTypeOf'@+singletonParameterType :: Parameter s p => proxy p -> a -> ParameterTypeMap s a+singletonParameterType p = MonoidMap . M.singleton (parameterTypeOf p)++-- |Equivalent to @'MM.insert' . 'parameterTypeOf'@+insertParameterType :: Parameter s p => proxy p -> a -> ParameterTypeMap s a -> ParameterTypeMap s a+insertParameterType p a (MonoidMap m) = MonoidMap $ M.insert (parameterTypeOf p) a m++-- |/O(n)/. Find all types in the map that can parse the given string data, returning 'toDyn' of the parsed string (the result of 'parseParameter') and the associated map value.+lookupParameterType :: s -> ParameterTypeMap s a -> [(Dynamic, a)]+lookupParameterType s (MonoidMap m) = do+  (ParameterType t, nt) <- M.toList m+  x <- maybeToList $ parseParameterAs t s+  return (toDyn x, nt)
+ Web/Route/Invertible/Map/Path.hs view
@@ -0,0 +1,13 @@+-- |+-- An efficient routing map for URL paths.+module Web.Route.Invertible.Map.Path+  ( PathMap+  ) where++import Prelude hiding (lookup)++import Web.Route.Invertible.Path+import Web.Route.Invertible.Map.Sequence++-- |Map over 'Path' values.+type PathMap = SequenceMap PathString
+ Web/Route/Invertible/Map/Placeholder.hs view
@@ -0,0 +1,78 @@+-- |+-- Hybrid maps keyed on 'Placeholder', using "Data.HashMap.Strict" and "Web.Route.Invertible.Map.ParameterType".+{-# LANGUAGE GADTs #-}+module Web.Route.Invertible.Map.Placeholder+  ( PlaceholderMap(..)+  , emptyPlaceholderMap+  , unionPlaceholderWith+  , singletonPlaceholder+  , singletonPlaceholderState+  , insertPlaceholder+  , lookupPlaceholder+  , lookupPlaceholderWith+  ) where++import Prelude hiding (lookup)++import Control.Arrow (first)+import Data.Dynamic (Dynamic)+import qualified Data.HashMap.Strict as HM+import qualified Data.Map.Strict as M++import Web.Route.Invertible.String+import Web.Route.Invertible.Placeholder+import Web.Route.Invertible.Dynamics+import Web.Route.Invertible.Map.Monoid+import Web.Route.Invertible.Map.ParameterType++-- |A map from 'Placeholder' keys to values, allowing lookups on @s@ strings.+-- 'PlaceholderFixed' keys represent normal keys, always take precedence, and provide /O(log n)/ operations.+-- 'PlaceholderParameter' keys represent types and allow multiple, dynamic parser-based lookups, at most /O(n)/.+data PlaceholderMap s a = PlaceholderMap+  { placeholderMapFixed :: !(HM.HashMap s a)+  , placeholderMapParameter :: !(ParameterTypeMap s a)+  } deriving (Eq, Show)++-- |Values are combined using 'mappend'.+instance (RouteString s, Monoid a) => Monoid (PlaceholderMap s a) where+  mempty = emptyPlaceholderMap+  mappend = unionPlaceholderWith mappend++instance Functor (PlaceholderMap s) where+  fmap f (PlaceholderMap s p) = PlaceholderMap (fmap f s) (fmap f p)++-- |The empty map.+emptyPlaceholderMap :: PlaceholderMap s a+emptyPlaceholderMap = PlaceholderMap HM.empty (MonoidMap M.empty)++-- |Union with a combining function.+unionPlaceholderWith :: RouteString s => (a -> a -> a) -> PlaceholderMap s a -> PlaceholderMap s a -> PlaceholderMap s a+unionPlaceholderWith f (PlaceholderMap s1 (MonoidMap p1)) (PlaceholderMap s2 (MonoidMap p2)) =+  PlaceholderMap (HM.unionWith f s1 s2) (MonoidMap $ M.unionWith f p1 p2)++-- |A map with a single element.+singletonPlaceholder :: RouteString s => Placeholder s p -> a -> PlaceholderMap s a+singletonPlaceholder (PlaceholderFixed t) v = PlaceholderMap (HM.singleton t v) (MonoidMap M.empty)+singletonPlaceholder t@PlaceholderParameter v = PlaceholderMap HM.empty (singletonParameterType t v)++placeholderState :: Placeholder s a -> DynamicState a+placeholderState (PlaceholderFixed _) = pure ()+placeholderState PlaceholderParameter = getDynamic++singletonPlaceholderState :: RouteString s => Placeholder s a -> PlaceholderMap s (DynamicState a)+singletonPlaceholderState p = singletonPlaceholder p $ placeholderState p++-- |Insert a new key and value in the map.+insertPlaceholder :: RouteString s => Placeholder s p -> a -> PlaceholderMap s a -> PlaceholderMap s a+insertPlaceholder (PlaceholderFixed t) v (PlaceholderMap s p) = PlaceholderMap (HM.insert t v s) p+insertPlaceholder t@PlaceholderParameter v (PlaceholderMap s p) = PlaceholderMap s (insertParameterType t v p)++-- |Lookup a string in the map, returning either the value associated with a 'PlaceholderFixed' key, or the list of matching 'PlaceholderParameter' keys, parsed into a 'Dynamic' representation (the result of 'parseParameter') and the associated value, if any.+-- If no keys match, the result is @Right []@.+lookupPlaceholder :: RouteString s => s -> PlaceholderMap s a -> Either a [(Dynamic, a)]+lookupPlaceholder t (PlaceholderMap s p) =+  maybe (Right $ lookupParameterType t p) Left $ HM.lookup t s++lookupPlaceholderWith :: RouteString s => s -> PlaceholderMap s a -> (a -> [DynamicResult b]) -> [DynamicResult b]+lookupPlaceholderWith t (PlaceholderMap s p) f =+  maybe (concatMap (\(x,n) -> first (x:) <$> f n) $ lookupParameterType t p) f $ HM.lookup t s
+ Web/Route/Invertible/Map/Query.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE FlexibleContexts #-}+module Web.Route.Invertible.Map.Query+  ( QueryMap(..)+  , defaultQueryMap+  , singletonQuery+  , singletonQueryState+  , lookupQuery+  ) where++import qualified Data.HashMap.Lazy as HM+import Data.Monoid ((<>))++import Web.Route.Invertible.Placeholder+import Web.Route.Invertible.Map.Placeholder+import Web.Route.Invertible.Query+import Web.Route.Invertible.Dynamics++-- |A map for parsing query parameters as 'Placeholder's by name, kept in alphabetical order to ensure consistent unions.+data QueryMap a = QueryFinal (Maybe a) | QueryMap+  { queryParam :: !QueryString+  , queryMap :: !(PlaceholderMap QueryString (QueryMap a))+  , queryMissing :: !(QueryMap a)+  } deriving (Eq, Show)++instance Functor QueryMap where+  fmap f (QueryFinal v) = QueryFinal (fmap f v)+  fmap f (QueryMap n m d) = QueryMap n (fmap (fmap f) m) (fmap f d)++instance Monoid a => Monoid (QueryMap a) where+  mempty = QueryFinal mempty+  mappend (QueryFinal a) (QueryFinal b) = QueryFinal (mappend a b)+  mappend q@(QueryFinal _) (QueryMap n m d) = QueryMap n m (q <> d)+  mappend (QueryMap n m d) q@(QueryFinal _) = QueryMap n m (d <> q)+  mappend q1@(QueryMap n1 m1 d1) q2@(QueryMap n2 m2 d2) = case compare n1 n2 of+    LT -> QueryMap n1 m1 (d1 <> q2)+    EQ -> QueryMap n1 (m1 <> m2) (d1 <> d2)+    GT -> QueryMap n2 m2 (q1 <> d2)++-- |The empty query map.+emptyQueryMap :: QueryMap a+emptyQueryMap = QueryFinal Nothing++-- |The constant query map, always returning the same value.+defaultQueryMap :: a -> QueryMap a+defaultQueryMap = QueryFinal . Just++-- |The query map with a single item, which maps queries containing the given query variable matching the placeholder to the specified @a@ value.+singletonQuery :: QueryString -> Placeholder QueryString p -> a -> QueryMap a+singletonQuery n p v = QueryMap n (singletonPlaceholder p $ defaultQueryMap v) emptyQueryMap++-- |A 'singletonQuery' map with a 'DynamicState' value to parse the placeholder.+singletonQueryState :: QueryString -> Placeholder QueryString p -> QueryMap (DynamicState p)+singletonQueryState n p = QueryMap n (defaultQueryMap <$> singletonPlaceholderState p) emptyQueryMap++-- |Lookup a URL query in the query map and return all matching results.+lookupQuery :: QueryParams -> QueryMap a -> [DynamicResult a]+lookupQuery _ (QueryFinal Nothing) = []+lookupQuery _ (QueryFinal (Just a)) = [([], a)]+lookupQuery q (QueryMap n m d)+  | Just qv <- HM.lookup n q = do+    s <- qv+    lookupPlaceholderWith s m $ lookupQuery q+  | otherwise = lookupQuery q d
+ Web/Route/Invertible/Map/Route.hs view
@@ -0,0 +1,199 @@+-- |Routing tables.+-- Once you have a number of endpoints defined, you can create a routing table of them using 'routeCase' and 'routes', dynamically combining the various Map representations as necessary to create a single, efficient map.+{-# LANGUAGE DeriveFunctor, RecordWildCards, GADTs, Rank2Types, TupleSections #-}+module Web.Route.Invertible.Map.Route+  ( RouteCase+  , RouteMap+  , routeCase+  , routeNormCase+  , routes+  , fallbackHEADtoGET+  , lookupRoute+  ) where++import Prelude hiding (lookup)++import Control.Applicative (Alternative(..))+import Control.Invertible.Monoidal.Free+import Control.Monad.Trans.Class (MonadTrans(..))+import Control.Monad.Trans.State (evalState)+import Data.Dynamic (Dynamic, toDyn)+import qualified Data.HashMap.Strict as HM+import qualified Data.Map.Strict as Map+import Data.Monoid ((<>))++import Web.Route.Invertible.String+import Web.Route.Invertible.Sequence+import Web.Route.Invertible.Path+import Web.Route.Invertible.Host+import Web.Route.Invertible.ContentType+import Web.Route.Invertible.Dynamics+import Web.Route.Invertible.Route+import Web.Route.Invertible.Request+import Web.Route.Invertible.Result+import Web.Route.Invertible.Monoid.Exactly+import Web.Route.Invertible.Monoid.Prioritized+import Web.Route.Invertible.Map.Monoid+import Web.Route.Invertible.Map.MonoidHash+import Web.Route.Invertible.Map.Default+import Web.Route.Invertible.Map.Const+import Web.Route.Invertible.Map.Bool+import Web.Route.Invertible.Map.Sequence+import Web.Route.Invertible.Map.Path+import Web.Route.Invertible.Map.Host+import Web.Route.Invertible.Map.Method+import Web.Route.Invertible.Map.Query+import Web.Route.Invertible.Map.Custom++-- |A routing table mapping 'Request's to values (actions) @a@.+data RouteMapT m a+  -- These constructors are expected to be nested in order for normalized routes+  = RouteMapHost      !(DefaultMap HostMap (RouteMapT m a))+  | RouteMapSecure    !(BoolMap (RouteMapT m a))+  | RouteMapPath      !(DefaultMap PathMap (RouteMapT m a))+  | RouteMapMethod    !(DefaultMap MethodMap (RouteMapT m a))+  | RouteMapQuery     !(QueryMap (RouteMapT m a))+  | RouteMapAccept    !(DefaultMap (MonoidHashMap ContentType) (RouteMapT m a))+  | RouteMapCustom    !(ConstMap (CustomMap Request Dynamic) (RouteMapT m a))+  | RouteMapPriority  !(Prioritized (RouteMapT m a))+  | RouteMapExactly   !(Exactly (m a))+  deriving (Show)++instance Monoid (RouteMapT m a) where+  mempty = RouteMapExactly Blank+  mappend m (RouteMapExactly Blank) = m+  mappend (RouteMapExactly Blank) m = m+  mappend (RouteMapHost     a) (RouteMapHost     b) = RouteMapHost     (mappend a b)+  mappend (RouteMapSecure   a) (RouteMapSecure   b) = RouteMapSecure   (mappend a b)+  mappend (RouteMapPath     a) (RouteMapPath     b) = RouteMapPath     (mappend a b)+  mappend (RouteMapMethod   a) (RouteMapMethod   b) = RouteMapMethod   (mappend a b)+  mappend (RouteMapQuery    a) (RouteMapQuery    b) = RouteMapQuery    (mappend a b)+  mappend (RouteMapAccept   a) (RouteMapAccept   b) = RouteMapAccept   (mappend a b)+  mappend (RouteMapCustom   a) (RouteMapCustom   b) = RouteMapCustom   (mappend a b)+  mappend (RouteMapPriority a) (RouteMapPriority b) = RouteMapPriority (mappend a b)+  mappend (RouteMapExactly  a) (RouteMapExactly  b) = RouteMapExactly  (mappend a b)+  mappend   a@(RouteMapHost     _) b = mappend a (RouteMapHost (defaultingValue b))+  mappend a b@(RouteMapHost     _)   = mappend   (RouteMapHost (defaultingValue a)) b+  mappend   a@(RouteMapSecure   _) b = mappend a (RouteMapSecure (singletonBool Nothing b))+  mappend a b@(RouteMapSecure   _)   = mappend   (RouteMapSecure (singletonBool Nothing a)) b+  mappend   a@(RouteMapPath     _) b = mappend a (RouteMapPath   (defaultingValue b))+  mappend a b@(RouteMapPath     _)   = mappend   (RouteMapPath   (defaultingValue a)) b+  mappend   a@(RouteMapMethod   _) b = mappend a (RouteMapMethod (defaultingValue b))+  mappend a b@(RouteMapMethod   _)   = mappend   (RouteMapMethod (defaultingValue a)) b+  mappend   a@(RouteMapQuery    _) b = mappend a (RouteMapQuery  (defaultQueryMap b))+  mappend a b@(RouteMapQuery    _)   = mappend   (RouteMapQuery  (defaultQueryMap a)) b+  mappend   a@(RouteMapAccept   _) b = mappend a (RouteMapAccept (defaultingValue b))+  mappend a b@(RouteMapAccept   _)   = mappend   (RouteMapAccept (defaultingValue a)) b+  mappend   a@(RouteMapCustom   _) b = mappend a (RouteMapCustom (constantValue b))+  mappend a b@(RouteMapCustom   _)   = mappend   (RouteMapCustom (constantValue a)) b+  mappend   a@(RouteMapPriority _) b = mappend a (RouteMapPriority (Prioritized 0 b)) +  mappend a b@(RouteMapPriority _)   = mappend   (RouteMapPriority (Prioritized 0 a)) b ++exactlyMap :: m a -> RouteMapT m a+exactlyMap = RouteMapExactly . Exactly++mapRoutes :: (m a -> RouteMapT n b) -> (RouteMapT m a -> RouteMapT n b) -> RouteMapT m a -> RouteMapT n b+mapRoutes _ f (RouteMapHost     m) = RouteMapHost     $ f <$> m+mapRoutes _ f (RouteMapSecure   m) = RouteMapSecure   $ f <$> m+mapRoutes _ f (RouteMapPath     m) = RouteMapPath     $ f <$> m+mapRoutes _ f (RouteMapMethod   m) = RouteMapMethod   $ f <$> m+mapRoutes _ f (RouteMapQuery    m) = RouteMapQuery    $ f <$> m+mapRoutes _ f (RouteMapAccept   m) = RouteMapAccept   $ f <$> m+mapRoutes _ f (RouteMapCustom   m) = RouteMapCustom   $ f <$> m+mapRoutes _ f (RouteMapPriority m) = RouteMapPriority $ f <$> m+mapRoutes f _ (RouteMapExactly (Exactly a)) = f a+mapRoutes _ _ (RouteMapExactly Blank) = RouteMapExactly Blank+mapRoutes _ _ (RouteMapExactly Conflict) = RouteMapExactly Conflict++mapTails :: (m a -> RouteMapT n b) -> RouteMapT m a -> RouteMapT n b+mapTails f = mapRoutes f (mapTails f)++mapRoute :: (m a -> n b) -> RouteMapT m a -> RouteMapT n b+mapRoute f = mapTails (exactlyMap . f)++instance Functor f => Functor (RouteMapT f) where+  fmap f = mapRoute (fmap f)++instance Applicative f => Applicative (RouteMapT f) where+  pure = exactlyMap . pure+  f <*> m = mapTails (\f' -> mapRoute (f' <*>) m) f+  f  *> m = mapTails (\f' -> mapRoute (f'  *>) m) f++instance Applicative f => Alternative (RouteMapT f) where+  empty = RouteMapExactly $ empty+  (<|>) = mappend++instance MonadTrans RouteMapT where+  lift = exactlyMap++type RouteState = RouteMapT DynamicState+-- |The type of a route map element created from a single 'Route'.+-- These may be combined into a final 'RouteMap'.+-- (Currently these are in fact the same representation, but this may change.)+type RouteCase = RouteMapT ((->) Dynamics)+-- |A map for efficiently looking up requests based on a set of individual route specifications.+type RouteMap = RouteCase++sequenceState :: RouteString s => Sequence s a -> DefaultMap (SequenceMap s) (RouteState a)+sequenceState s = defaultingMap $ RouteMapExactly . Exactly <$> singletonSequence s++predicateState :: RoutePredicate a -> RouteState a+predicateState (RouteHost (HostRev s)) = RouteMapHost $ sequenceState s+predicateState (RouteSecure s) = RouteMapSecure $ singletonBool (Just s) $ pure ()+predicateState (RoutePath (Path s)) = RouteMapPath $ sequenceState s+predicateState (RouteMethod m) = RouteMapMethod $ defaultingMap $ MonoidMap $ Map.singleton m $ pure ()+predicateState (RouteQuery n p) = RouteMapQuery $ RouteMapExactly . Exactly <$> singletonQueryState n p+predicateState (RouteAccept t) = RouteMapAccept $ defaultingMap $ MonoidHashMap $ HM.singleton t $ pure ()+predicateState (RouteCustom f _) = RouteMapCustom $ constantMap $ singletonCustom (fmap toDyn . f) $+  RouteMapExactly $ Exactly $ getDynamic+predicateState (RoutePriority p) = RouteMapPriority $ Prioritized p $ pure ()++routeState :: Route a -> RouteState a+routeState (Route r) = runFree $ mapFree predicateState r++-- |Convert a 'Route' and result generator to a single entry in the routing table.+routeCase :: RouteAction a b -> RouteCase b+routeCase (RouteAction r f) = mapRoute (\s -> f . evalState s) $ routeState r++-- |Combine 'routeCase' and 'normRoute'.+-- See the description of 'normRoute' for an explaination.+routeNormCase :: RouteAction a b -> RouteCase b+routeNormCase (RouteAction r f) = mapRoute (\s -> f . evalState s) $ routeState $ normRoute r++-- |Combine a list of routes to a single map.+routes :: [RouteCase a] -> RouteMap a+routes = mconcat++-- |Make any handler for a 'GET' method in the map also apply to 'HEAD' requests, provided there is not an existing handler.+-- A number of frameworks can automatically convert your @GET@ responses into @HEAD@ responses, so this is useful (if slightly wasteful) in those cases.+fallbackHEADtoGET :: RouteMap a -> RouteMap a+fallbackHEADtoGET (RouteMapMethod m) = RouteMapMethod $ fallbackDefaultMethodHEADtoGET $ fallbackHEADtoGET <$> m+fallbackHEADtoGET m = mapRoutes exactlyMap fallbackHEADtoGET m++-- |Lookup a value in a routing table based on a 'Request'.+-- This returns the action returned by the 'route' that can handle this request, wrapped in a 'RouteResult' in case of error.+lookupRoute :: Request -> RouteMap a -> RouteResult a+lookupRoute q@Request{..} = rr id where+  rr :: (Dynamics -> Dynamics) -> RouteMap a -> RouteResult a+  rr _ (RouteMapExactly Blank) = RouteNotFound+  rr p (RouteMapExactly (Exactly a)) = RouteResult $ a $ p []+  rr _ (RouteMapExactly Conflict) = MultipleRoutes+  rr p (RouteMapPriority (Prioritized _ r)) = rr p r+  rr p (RouteMapCustom (ConstMap m cm)) =+    foldMap (\(x, rm) -> rr (p . (x:)) rm) (lookupCustom q m) <> rr p cm+  rr p (RouteMapAccept m) = mayber p $ lookupDefault (HM.lookup requestContentType . monoidHashMap) m+  rr p (RouteMapQuery m) = dynr p $ lookupQuery requestQuery m+  rr p (RouteMapMethod m) = either AllowedMethods (rr p)+    $ lookupDefaultMethod requestMethod m+  rr p (RouteMapPath m) = seqr p requestPath m+  rr p (RouteMapSecure m) = mayber p+    $ lookupBool requestSecure m+  rr p (RouteMapHost m) = seqr p requestHost m+  mayber :: (Dynamics -> Dynamics) -> Maybe (RouteMap a) -> RouteResult a+  mayber p = maybe RouteNotFound (rr p)+  dynr :: (Dynamics -> Dynamics) -> [DynamicResult (RouteMap a)] -> RouteResult a+  dynr p = foldMap (\(x, rm) -> rr (p . (x ++)) rm)+  seqr :: RouteString s => (Dynamics -> Dynamics) -> [s] -> DefaultMap (SequenceMap s) (RouteMap a) -> RouteResult a+  seqr p k (DefaultMap m d) = case lookupSequence k m of+    [] -> mayber p d+    l -> dynr p l
+ Web/Route/Invertible/Map/Sequence.hs view
@@ -0,0 +1,134 @@+-- |+-- An efficient map for sequences.+-- This is the core of the routing infrastructure.+-- If you have a set of routes represented as 'Sequence's, you can create a routing table using 'mconcat' and 'singletonSequenceApp':+-- +-- >>> :set -XOverloadedStrings+-- >>> import Control.Invertible.Monoidal+-- >>> import Web.Route.Invertible.Parameter+-- >>> let p1 = "item" *< parameter :: Sequence String Int+-- >>> let p2 = "object" *< parameter :: Sequence String String+-- >>> let r = mconcat [singletonSequenceApp p1 [Left], singletonSequenceApp p2 [Right] {- ... -}] :: SequenceMapApp String [] (Either Int String)+-- >>> lookupSequenceApp ["object", "foo"] r+-- [Right "foo"]+-- >>> lookupSequenceApp ["item", "123"] r+-- [Left 123]+-- >>> lookupSequenceApp ["item", "bar"] r+-- []+--+{-# LANGUAGE GADTs, ScopedTypeVariables #-}+module Web.Route.Invertible.Map.Sequence+  ( SequenceMap(..)+  , singletonSequence+  , lookupSequence+  -- * Example usage+  , SequenceMapApp+  , singletonSequenceApp+  , lookupSequenceApp+  ) where++import Prelude hiding (lookup)++import Control.Applicative (Alternative(..))+import Control.Invertible.Monoidal.Free+import Control.Monad (MonadPlus(..))+import Control.Monad.Trans.State (evalState)++import Web.Route.Invertible.String+import Web.Route.Invertible.Placeholder+import Web.Route.Invertible.Sequence+import Web.Route.Invertible.Dynamics+import Web.Route.Invertible.Map.Placeholder++-- |A routing map for 'Sequence' parsers.+-- Each joined ('Control.Invertible.Monoidal.>*<') component in the 'Sequence' becomes a level of the map.+data SequenceMap s a = SequenceMap+  { sequenceMapPlaceholder :: PlaceholderMap s (SequenceMap s a)+  , sequenceMapValue :: !(Maybe a)+  } deriving (Eq, Show)++unionSequenceWith :: RouteString s => (Maybe a -> Maybe a -> Maybe a) -> SequenceMap s a -> SequenceMap s a -> SequenceMap s a+unionSequenceWith f (SequenceMap m1 v1) (SequenceMap m2 v2) =+  SequenceMap (unionPlaceholderWith (unionSequenceWith f) m1 m2) (f v1 v2)++-- |Values are combined using 'mappend'.+instance (RouteString s, Monoid a) => Monoid (SequenceMap s a) where+  mempty = empty+  mappend = unionSequenceWith mappend++instance Functor (SequenceMap s) where+  fmap f (SequenceMap m v) = SequenceMap (fmap f <$> m) (f <$> v)++leaf :: Maybe a -> SequenceMap s a+leaf = SequenceMap emptyPlaceholderMap++instance RouteString s => Applicative (SequenceMap s) where+  pure = leaf . Just+  SequenceMap fm fv <*> a = maybe id (\f -> (f <$> a <|>)) fv+    $ SequenceMap ((<*> a) <$> fm) Nothing+  SequenceMap am Nothing *> b =+    SequenceMap ((*> b) <$> am) Nothing+  SequenceMap am (Just _) *> b = b <|>+    SequenceMap ((*> b) <$> am) Nothing++instance RouteString s => Alternative (SequenceMap s) where+  empty = leaf Nothing+  (<|>) = unionSequenceWith (<|>)++instance RouteString s => Monad (SequenceMap s) where+  SequenceMap mm mv >>= f = maybe id ((<|>) . f) mv+    $ SequenceMap ((>>= f) <$> mm) Nothing+  (>>) = (*>)++instance RouteString s => MonadPlus (SequenceMap s)++newtype SequenceMapP s a = SequenceMapP { sequenceMapP :: SequenceMap s (DynamicState a) }++instance Functor (SequenceMapP s) where+  fmap f (SequenceMapP m) = SequenceMapP $ fmap (fmap f) m++instance RouteString s => Applicative (SequenceMapP s) where+  pure = SequenceMapP . pure . pure+  SequenceMapP f <*> SequenceMapP m = SequenceMapP $ ((<*>) <$> f) <*> m+  SequenceMapP a  *> SequenceMapP b = SequenceMapP $ ( (*>) <$> a)  *> b++instance RouteString s => Alternative (SequenceMapP s) where+  empty = SequenceMapP empty+  SequenceMapP a <|> SequenceMapP b = SequenceMapP $ a <|> b++placeholderMap :: RouteString s => Placeholder s a -> SequenceMapP s a+placeholderMap p = SequenceMapP $+  SequenceMap (pure <$> singletonPlaceholderState p) Nothing++singletonSequenceP :: RouteString s => Sequence s a -> SequenceMapP s a+singletonSequenceP = runFree . mapFree placeholderMap . freeSequence++-- |A sequence representing a single 'Sequence', with underlying @s@ strings as keys mapping to functions that convert from the resulting parsed parameters to the associated 'Sequence' value.+-- Note that a single 'Sequence' can create multiple elements in the map, so this is not strictly a /singleton/.+singletonSequence :: RouteString s => Sequence s a -> SequenceMap s (DynamicState a)+singletonSequence = sequenceMapP . singletonSequenceP++-- |Lookup a list of strings in a 'SequenceMap', returning all the associated values as tuples of the parsed dynamic placeholders and the associated value.+-- Note that if this map was created by 'singletonSequence', those values are themselves functions, so applying the first element to the second result will produce the original sequence value.+-- This is the equivalent of 'parseSequence':+--+-- > parseSequence q s === map (uncurry ($)) (lookupSequence s (singletonSequence q))+--+-- Except that 'lookupSequence' is far more efficient, especially when there are large number of alternatives.+lookupSequence :: RouteString s => [s] -> SequenceMap s a -> [DynamicResult a]+lookupSequence (s:l) (SequenceMap m _) = lookupPlaceholderWith s m $ lookupSequence l+lookupSequence [] (SequenceMap _ Nothing) = mzero+lookupSequence [] (SequenceMap _ (Just x)) = return ([], x)++-- |An example way to use 'SequenceMap' to abstract over and thus union multiple heterogeneous sequences.+type SequenceMapApp s m a = SequenceMap s (m (Dynamics -> a))++-- |Create a map from a single 'Sequence' parser.  Since this abstracts the type of the sequence @p@ (but not @a@), sequences with different underlying types can be combined in the same map.+singletonSequenceApp :: (RouteString s, Functor m) => Sequence s a -> m (a -> b) -> SequenceMapApp s m b+singletonSequenceApp p m = (\f -> fmap (. evalState f) m) <$> singletonSequence p++-- |Lookup a sequence in the map and return the value, combining ambiguous sequences using the 'Monoid' instance on their values.+-- Generally /O(log n)/ in the total number of sequences, except /O(n)/ in the length of the sequence and the number of different (ambiguous) 'SequenceParameter' types at each level (from 'PM.lookup').+-- However, it also incurs the cost of an 'fmap' on @m@, which it may be better to defer pending later lookups.+lookupSequenceApp :: (RouteString s, Functor m, Monoid (m a)) => [s] -> SequenceMapApp s m a -> m a+lookupSequenceApp l = foldMap (\(x, f) -> fmap ($ x) f) . lookupSequence l
+ Web/Route/Invertible/Method.hs view
@@ -0,0 +1,108 @@+-- |Representation of HTTP request methods.+{-# LANGUAGE CPP, MultiParamTypeClasses, FlexibleInstances, OverloadedStrings #-}+module Web.Route.Invertible.Method+  ( Method(..)+  , IsMethod(..)+  ) where++import Prelude hiding (lookup)++import Data.ByteString (ByteString)+import qualified Network.HTTP.Types.Method as H+#ifdef VERSION_snap_core+import qualified Snap.Core as Snap+#endif+#ifdef VERSION_happstack_server+import qualified Happstack.Server.Types as HS+#endif++import Web.Route.Invertible.Parameter++-- |Standard HTTP methods.+-- These are defined a number of places already, but the http-types version (which is the only thing we import by default) is too cumbersome.+data Method+  = OPTIONS+  | GET+  | HEAD+  | POST+  | PUT+  | DELETE+  | TRACE+  | CONNECT+  | PATCH+  | ExtensionMethod !ByteString+  deriving (Eq, Ord, Read, Show)++instance Parameter ByteString Method where+  parseParameter = Just . toMethod+  renderParameter OPTIONS = "OPTIONS"+  renderParameter GET = "GET"+  renderParameter HEAD = "HEAD"+  renderParameter POST = "POST"+  renderParameter PUT = "PUT"+  renderParameter DELETE = "DELETE"+  renderParameter TRACE = "TRACE"+  renderParameter CONNECT = "CONNECT"+  renderParameter PATCH = "PATCH"+  renderParameter (ExtensionMethod m) = m++-- |Any types that represent an HTTP method.+class IsMethod m where+  toMethod :: m -> Method++instance IsMethod Method where+  toMethod = id++instance IsMethod H.StdMethod where+  toMethod H.GET = GET+  toMethod H.POST = POST+  toMethod H.HEAD = HEAD+  toMethod H.PUT = PUT+  toMethod H.DELETE = DELETE+  toMethod H.TRACE = TRACE+  toMethod H.CONNECT = CONNECT+  toMethod H.OPTIONS = OPTIONS+  toMethod H.PATCH = PATCH++instance IsMethod (Either ByteString H.StdMethod) where+  toMethod = either ExtensionMethod toMethod++instance IsMethod ByteString where+  toMethod "OPTIONS" = OPTIONS+  toMethod "GET" = GET+  toMethod "HEAD" = HEAD+  toMethod "POST" = POST+  toMethod "PUT" = PUT+  toMethod "DELETE" = DELETE+  toMethod "TRACE" = TRACE+  toMethod "CONNECT" = CONNECT+  toMethod "PATCH" = PATCH+  toMethod m = ExtensionMethod m++#ifdef VERSION_snap_core+instance IsMethod Snap.Method where+  toMethod Snap.GET = GET+  toMethod Snap.HEAD = HEAD+  toMethod Snap.POST = POST+  toMethod Snap.PUT = PUT+  toMethod Snap.DELETE = DELETE+  toMethod Snap.TRACE = TRACE+  toMethod Snap.OPTIONS = OPTIONS+  toMethod Snap.CONNECT = CONNECT+  toMethod Snap.PATCH = PATCH+  toMethod (Snap.Method m) = ExtensionMethod m+#endif++#ifdef VERSION_happstack_server+instance IsMethod HS.Method where+  toMethod HS.GET = GET+  toMethod HS.HEAD = HEAD+  toMethod HS.POST = POST+  toMethod HS.PUT = PUT+  toMethod HS.DELETE = DELETE+  toMethod HS.TRACE = TRACE+  toMethod HS.OPTIONS = OPTIONS+  toMethod HS.CONNECT = CONNECT+  toMethod HS.PATCH = PATCH+  toMethod (HS.EXTENSION m) = ExtensionMethod m+#endif
+ Web/Route/Invertible/Monoid/Exactly.hs view
@@ -0,0 +1,87 @@+-- |+-- A monoid that only admits a single value.+module Web.Route.Invertible.Monoid.Exactly+  ( Exactly(..)+  , maybeToExactly+  , exactlyToMaybe+  , listToExactly+  , exactlyToList+  ) where++import Control.Applicative (Alternative(..))+import Control.Monad (MonadPlus(..))++-- |A 'Maybe'-like monoid that only allows one value, overflowing into 'Conflict' when more than one 'Exactly' are combined (with '<|>' or 'Data.Monoid.<>', which thus function identically).+data Exactly a+  = Blank -- ^ 'Nothing'+  | Exactly a -- ^ 'Just'+  | Conflict -- ^ 'fail': 'error' in most cases that attempt to access a value+  deriving (Eq, Ord, Show, Read)++instance Functor Exactly where+  fmap _ Blank = Blank+  fmap f (Exactly a) = Exactly (f a)+  fmap _ Conflict = Conflict+-- |Conflict always overrides other values.+instance Applicative Exactly where+  pure = Exactly+  Exactly f <*> Exactly x = Exactly (f x)+  _ <*> Conflict = Conflict+  Conflict <*> _ = Conflict+  _ <*> _ = Blank+-- |Same as for 'Maybe', except that @Exactly _ <|> Exactly _ = Conflict@.+instance Alternative Exactly where+  empty = Blank+  Blank <|> e = e+  e <|> Blank = e+  _ <|> _ = Conflict  +instance Monad Exactly where+  Blank >>= _ = Blank+  Exactly x >>= f = f x+  Conflict >>= _ = Conflict+  Exactly _ >> e = e+  Conflict >> _ = Conflict+  _ >> Conflict = Conflict+  _ >> _ = Blank+  fail _ = Conflict+instance MonadPlus Exactly++-- |Combines using the 'Alternative' instance, similar to an @'Data.Monoid.Alt' 'Maybe'@.+instance Monoid (Exactly a) where+  mempty = Blank+  mappend = (<|>)++instance Foldable Exactly where+  foldr _ z Blank = z+  foldr f z (Exactly x) = f x z+  foldr f z Conflict = f (error "foldr: Conflict") z+  foldl _ z Blank = z+  foldl f z (Exactly x) = f z x +  foldl f z Conflict = f z (error "foldl: Conflict")+instance Traversable Exactly where+  traverse _ Blank = pure Blank+  traverse f (Exactly x) = Exactly <$> f x +  traverse _ Conflict = pure Conflict++-- |@exactlyToMaybe . maybeToExactly == id@+maybeToExactly :: Maybe a -> Exactly a+maybeToExactly Nothing = Blank+maybeToExactly (Just x) = Exactly x++-- |@exactlyToMaybe Conflict@ is an error.+exactlyToMaybe :: Exactly a -> Maybe a+exactlyToMaybe Blank = Nothing+exactlyToMaybe (Exactly x) = Just x+exactlyToMaybe Conflict = error "exactlyToMaybe: Conflict"++-- |Conflict for any list with more than one element.+listToExactly :: [a] -> Exactly a+listToExactly [] = Blank+listToExactly [x] = Exactly x+listToExactly _ = Conflict++-- |@exactlyToList Conflict@ is an error.+exactlyToList :: Exactly a -> [a]+exactlyToList Blank = []+exactlyToList (Exactly x) = [x]+exactlyToList Conflict = error "exactlyToList: Conflict"
+ Web/Route/Invertible/Monoid/Prioritized.hs view
@@ -0,0 +1,25 @@+-- |+-- A monoid that combines according to priorities, allowing some values to take precedence over others.+module Web.Route.Invertible.Monoid.Prioritized+  ( Prioritized(..)+  ) where++import Data.Monoid ((<>))++-- |A trival monoid allowing each item to be given a priority when combining.+data Prioritized a = Prioritized+  { priority :: !Int -- ^ The priority this value, where larger numeric values have higher priority and take precedence over lower priorities.+  , prioritized :: !a -- ^ The prioritized value.+  } deriving (Eq, Show)++instance Functor Prioritized where+  fmap f (Prioritized p x) = Prioritized p (f x)++-- |Combining two values with the same priority combines the values, otherwise it discards the value with a smaller priority.+instance Monoid a => Monoid (Prioritized a) where+  mempty = Prioritized minBound mempty+  mappend a1@(Prioritized p1 x1) a2@(Prioritized p2 x2) = case compare p1 p2 of+    LT -> a2+    GT -> a1+    EQ -> Prioritized p1 (x1 <> x2)+
+ Web/Route/Invertible/Parameter.hs view
@@ -0,0 +1,138 @@+-- |Representations of values that can serve as placeholders, being parsed from "Web.Route.Invertible.String" data.+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, TypeSynonymInstances, ScopedTypeVariables, ExistentialQuantification, EmptyCase, DefaultSignatures, FunctionalDependencies #-}+module Web.Route.Invertible.Parameter +  ( Parameter(..)+  , Parameterized(..)+  , param+  , ParameterType(..)+  , parameterTypeOf+  , parseParameterAs+  ) where++import Control.Monad (guard)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BSC+import Data.Hashable (Hashable(..))+import Data.Int (Int8, Int16, Int32, Int64)+import Data.Word (Word8, Word16, Word32, Word64)+import Data.Proxy (Proxy(Proxy))+import Data.String (IsString(..))+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import qualified Data.Text.Read as T+import Data.Typeable (Typeable, typeRep)+import Data.Void (Void, absurd)+import Text.Read (readMaybe)++import Web.Route.Invertible.String++-- |A parameter value @a@ that can be parsed from or rendered into string data @s@.+-- @parseParameter@ must invert @renderParameter@:+--+--   * @parseParameter . renderParameter == Just@+--   +class (RouteString s, Typeable a) => Parameter s a where+  -- |Parse string data into a value.+  -- Often equivalent (and defaults) to 'readMaybe'.+  parseParameter :: s -> Maybe a+  -- |Render a value into a string.+  -- Often equivalent (and defaults) to 'show'.+  renderParameter :: a -> s++  default parseParameter :: Read a => s -> Maybe a+  parseParameter = readMaybe . toString+  default renderParameter :: Show a => a -> s+  renderParameter = fromString . show++instance {-# OVERLAPPABLE #-} (RouteString s) => Parameter s String where+  parseParameter = Just . toString+  renderParameter = fromString+instance Parameter T.Text T.Text where+  parseParameter = Just+  renderParameter = id+instance Parameter BS.ByteString BS.ByteString where+  parseParameter = Just+  renderParameter = id+instance Parameter T.Text BS.ByteString where+  parseParameter = Just . TE.encodeUtf8+  renderParameter = TE.decodeUtf8+instance Parameter BS.ByteString T.Text where+  parseParameter = either (const Nothing) Just . TE.decodeUtf8'+  renderParameter = TE.encodeUtf8++instance Parameter String Char where+  parseParameter [c] = Just c+  parseParameter _ = Nothing+  renderParameter c = [c]+instance Parameter T.Text Char where+  parseParameter = parseParameter . T.unpack+  renderParameter = T.singleton+instance Parameter BS.ByteString Char where+  parseParameter = parseParameter . BSC.unpack+  renderParameter = BSC.singleton++instance {-# OVERLAPPABLE #-} RouteString s => Parameter s Integer+instance {-# OVERLAPPABLE #-} RouteString s => Parameter s Int+instance {-# OVERLAPPABLE #-} RouteString s => Parameter s Int8+instance {-# OVERLAPPABLE #-} RouteString s => Parameter s Int16+instance {-# OVERLAPPABLE #-} RouteString s => Parameter s Int32+instance {-# OVERLAPPABLE #-} RouteString s => Parameter s Int64+instance {-# OVERLAPPABLE #-} RouteString s => Parameter s Word+instance {-# OVERLAPPABLE #-} RouteString s => Parameter s Word8+instance {-# OVERLAPPABLE #-} RouteString s => Parameter s Word16+instance {-# OVERLAPPABLE #-} RouteString s => Parameter s Word32+instance {-# OVERLAPPABLE #-} RouteString s => Parameter s Word64+instance {-# OVERLAPPABLE #-} RouteString s => Parameter s Float+instance {-# OVERLAPPABLE #-} RouteString s => Parameter s Double++readText :: T.Reader a -> T.Text -> Maybe a+readText = (.) $ either (const Nothing) (\(a, t) -> a <$ guard (T.null t))++instance Parameter T.Text Integer where parseParameter = readText (T.signed T.decimal)+instance Parameter T.Text Int     where parseParameter = readText (T.signed T.decimal)+instance Parameter T.Text Int8    where parseParameter = readText (T.signed T.decimal)+instance Parameter T.Text Int16   where parseParameter = readText (T.signed T.decimal)+instance Parameter T.Text Int32   where parseParameter = readText (T.signed T.decimal)+instance Parameter T.Text Int64   where parseParameter = readText (T.signed T.decimal)+instance Parameter T.Text Word    where parseParameter = readText T.decimal+instance Parameter T.Text Word8   where parseParameter = readText T.decimal+instance Parameter T.Text Word16  where parseParameter = readText T.decimal+instance Parameter T.Text Word32  where parseParameter = readText T.decimal+instance Parameter T.Text Word64  where parseParameter = readText T.decimal+instance Parameter T.Text Float   where parseParameter = readText T.rational+instance Parameter T.Text Double  where parseParameter = readText T.double++instance RouteString s => Parameter s Void where+  parseParameter _ = Nothing+  renderParameter = absurd+++-- |Parsers 'p' that operate over string data 's', and so can parse placeholder 'Parameter' values.+class Parameterized s p | p -> s where+  -- |Create a parser for a parameter of type 'a'.+  parameter :: Parameter s a => p a++-- |Create a placeholder 'parameter' with the type of the argument, which is ignored.+param :: (Parameterized s p, Parameter s a) => a -> p a+param _ = parameter++-- |An existential representation of an instance of @'Parameter' s@, that functions similarly to 'Data.Typeable.TypeRep' but also provides witness to a concrete instance.+data ParameterType s = forall a . Parameter s a => ParameterType !(Proxy a)++instance Eq (ParameterType s) where+  ParameterType a == ParameterType b = typeRep a == typeRep b+instance Ord (ParameterType s) where+  ParameterType a `compare` ParameterType b = typeRep a `compare` typeRep b+instance Hashable (ParameterType s) where+  hashWithSalt s (ParameterType d) = hashWithSalt s (typeRep d)+instance Show (ParameterType s) where+  showsPrec d (ParameterType p) = showParen (d > 10) $+    showString "ParameterType " . showsPrec 11 (typeRep p)++-- |Similar to 'typeRep'.+parameterTypeOf :: forall s proxy a . Parameter s a => proxy a -> ParameterType s+parameterTypeOf _ = ParameterType (Proxy :: Proxy a)++-- |Constrain the type of 'parseParameter', ignoring the first parameter.+parseParameterAs :: forall s proxy a . Parameter s a => proxy a -> s -> Maybe a+parseParameterAs _ = parseParameter
+ Web/Route/Invertible/Path.hs view
@@ -0,0 +1,65 @@+-- |+-- Single-route path parsers (specialization of "Web.Route.Invertible.Sequence").+-- The most important type here is 'Path', which can be used to represent a single path endpoint within your application, including placeholders.+-- For example, the following represents a path of @\/item\/$id@ where @$id@ is an integer placeholder:+--+-- > Path ("item" *< parameter) :: Path Int+--+{-# LANGUAGE GeneralizedNewtypeDeriving, StandaloneDeriving, FlexibleInstances, FlexibleContexts #-}+module Web.Route.Invertible.Path+  ( PathString+  , normalizePath+  , Path(..)+  , pathValues+  , renderPath+  , urlPathBuilder+  ) where++import Prelude hiding (lookup)++import Control.Invertible.Monoidal+import qualified Data.ByteString.Builder as B+import Data.Monoid ((<>))+import qualified Data.Invertible as I+import Data.String (IsString(..))+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import qualified Network.HTTP.Types.URI as H++import Web.Route.Invertible.Parameter+import Web.Route.Invertible.Placeholder+import Web.Route.Invertible.Sequence++-- |A component of a path, such that paths are represented by @['PathString']@ (after splitting on \'/\').+-- Paths can be created by 'H.decodePath'.+type PathString = T.Text++-- |Remove double- and trailing-slashes (i.e., empty path segments).+normalizePath :: [PathString] -> [PathString]+normalizePath = filter (not . T.null)++-- |A URL path parser/generator.+-- These should typically be constructed using the 'IsString' and 'Parameterized' instances.+-- Note that the individual components are /decoded/ path segments, so a literal slash in a component (e.g., as produced with 'fromString') will match \"%2F\".+-- Example:+--+-- > "get" *< parameter >*< "value" *< parameter :: Path (String, Int)+--+-- matches (or generates) @\/get\/$x\/value\/$y@ for any string @$x@ and any int @$y@ and returns those values.+newtype Path a = Path { pathSequence :: Sequence PathString a }+  deriving (I.Functor, Monoidal, MonoidalAlt, Parameterized PathString, Show)++deriving instance IsString (Path ())++-- |Render a 'Path' as instantiated by a value to a list of placeholder values.+pathValues :: Path a -> a -> [PlaceholderValue PathString]+pathValues (Path p) = sequenceValues p++-- |Render a 'Path' as instantiated by a value to a list of string segments.+renderPath :: Path a -> a -> [PathString]+renderPath (Path p) = renderSequence p++-- |Build a 'Path' as applied to a value into a bytestring 'B.Builder' by encoding the segments with 'urlEncodePath' and joining them with \"/\".+urlPathBuilder :: Path a -> a -> B.Builder+urlPathBuilder p a = foldMap es $ renderPath p a where+  es s = B.char7 '/' <> H.urlEncodeBuilder False (TE.encodeUtf8 s)
+ Web/Route/Invertible/Placeholder.hs view
@@ -0,0 +1,74 @@+-- |Allow more general "Web.Route.Invertible.Parameter" placeholders that include fixed strings.+{-# LANGUAGE GADTs, FlexibleInstances, MultiParamTypeClasses #-}+module Web.Route.Invertible.Placeholder+  ( Placeholder(..)+  , renderPlaceholder+  , PlaceholderValue(..)+  , renderPlaceholderValue+  ) where++import Data.Function (on)+import Data.String (IsString(..))+import Data.Typeable (typeRep, typeOf)++import Web.Route.Invertible.String+import Web.Route.Invertible.Parameter++-- |A segment of a parser over strings @s@, which may be a fixed string (usually created through 'IsString'), only accepting a single fixed value, or a dynamic parameter (created through 'Parameterized'), which encapsulates a 'Parameter' type.+data Placeholder s a where+  PlaceholderFixed :: !s -> Placeholder s ()+  PlaceholderParameter :: Parameter s a => Placeholder s a++instance Eq s => Eq (Placeholder s a) where+  PlaceholderFixed x == PlaceholderFixed y = x == y+  PlaceholderParameter == PlaceholderParameter = True+  _ == _ = False++instance Ord s => Ord (Placeholder s a) where+  PlaceholderFixed x `compare` PlaceholderFixed y = x `compare` y+  PlaceholderFixed _ `compare` PlaceholderParameter = LT+  PlaceholderParameter `compare` PlaceholderFixed _ = GT+  PlaceholderParameter `compare` PlaceholderParameter = EQ++instance Show s => Show (Placeholder s a) where+  showsPrec d (PlaceholderFixed s) = showParen (d > 10) $+    showString "PlaceholderFixed " . showsPrec 11 s+  showsPrec d p@PlaceholderParameter = showParen (d > 10) $+    showString "PlaceholderParameter " . showsPrec 11 (typeRep p)++instance IsString s => IsString (Placeholder s ()) where+  fromString = PlaceholderFixed . fromString++instance RouteString s => Parameterized s (Placeholder s) where+  parameter = PlaceholderParameter++-- |Render a placeholder into a string, as fixed text or using 'renderParameter'.+renderPlaceholder :: Placeholder s a -> a -> s+renderPlaceholder (PlaceholderFixed s) () = s+renderPlaceholder PlaceholderParameter a = renderParameter a++-- |A concrete, untyped representation of a parsed 'Placeholder' value, distinguishing fixed components from parameters but abstracting over the parsed type.+data PlaceholderValue s where+  PlaceholderValueFixed :: !s -> PlaceholderValue s+  PlaceholderValueParameter :: Parameter s a => a -> PlaceholderValue s++instance Eq s => Eq (PlaceholderValue s) where+  (==) = on (==) renderPlaceholderValue++instance Ord s => Ord (PlaceholderValue s) where+  compare = on compare renderPlaceholderValue++instance (RouteString s, Show s) => Show (PlaceholderValue s) where+  showsPrec d (PlaceholderValueFixed s) = showParen (d > 10) $+    showString "PlaceholderValueFixed " . showsPrec 11 s+  showsPrec d p@(PlaceholderValueParameter a) = showParen (d > 10) $+    showString "PlaceholderValueParameter (" .+    showString (toString $ renderPlaceholderValue p) .+    showString " :: " .+    shows (typeOf a) .+    showChar ')'++-- |Render a placeholder into a string, as fixed text or using 'renderParameter'.+renderPlaceholderValue :: PlaceholderValue s -> s+renderPlaceholderValue (PlaceholderValueFixed s) = s+renderPlaceholderValue (PlaceholderValueParameter a) = renderParameter a
+ Web/Route/Invertible/Query.hs view
@@ -0,0 +1,22 @@+module Web.Route.Invertible.Query+  ( QueryString+  , QueryParams+  , simpleQueryParams+  , paramsQuerySimple+  ) where++import Control.Arrow (second)+import qualified Data.ByteString as BS+import qualified Data.HashMap.Lazy as HM+import Network.HTTP.Types.URI (SimpleQuery)++-- |The type of URL query strings, variables, and parameters, after URI decoding but before UTF-8 decoding.+type QueryString = BS.ByteString+-- |A map from query variables to values, based on 'SimpleQuery'.+type QueryParams = HM.HashMap QueryString [QueryString]++simpleQueryParams :: SimpleQuery -> QueryParams+simpleQueryParams = HM.fromListWith (++) . map (second return)++paramsQuerySimple :: QueryParams -> SimpleQuery+paramsQuerySimple q = [ (n, v) | (n, vl) <- HM.toList q, v <- vl ]
+ Web/Route/Invertible/Request.hs view
@@ -0,0 +1,34 @@+-- |Representation of HTTP requests.+module Web.Route.Invertible.Request+  ( Request(..)+  , blankRequest+  ) where++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++-- |A reduced representation of an HTTP request, sufficient for routing.+-- This lets us both pre-process/parse the request to optimize routing, and be agnostic about the incoming request representation.+-- These can be created with one of the framework-specific layers.+data Request = Request+  { requestSecure :: Bool+  , requestHost :: [HostString]+  , requestMethod :: Method+  , requestPath :: [PathString]+  , requestQuery :: QueryParams+  , requestContentType :: ContentType+  } deriving (Show, Eq)++-- |A blank/unknown request; effectively the default value+blankRequest :: Request+blankRequest = Request+  { requestSecure = False+  , requestHost = []+  , requestMethod = ExtensionMethod mempty+  , requestPath = []+  , requestQuery = mempty+  , requestContentType = mempty+  }
+ Web/Route/Invertible/Result.hs view
@@ -0,0 +1,53 @@+-- |Results of route table lookups.+module Web.Route.Invertible.Result+  ( RouteResult(..)+  , routeResult+  ) where++import qualified Data.ByteString.Char8 as BSC+import Data.Typeable (Typeable)+import Network.HTTP.Types.Header (ResponseHeaders, hAllow)+import Network.HTTP.Types.Status (Status, notFound404, methodNotAllowed405, internalServerError500)++import Web.Route.Invertible.Parameter+import Web.Route.Invertible.Method++-- |The result of looking up a request in a routing map.+data RouteResult a+  = RouteNotFound -- ^No route was found to handle this request: 404+  | AllowedMethods [Method] -- ^No route was found to handle this request, but there are routes for other methods: 405+  | RouteResult a -- ^A route was found to handle this request+  | MultipleRoutes -- ^Multiple (conflicting) routes were found to handle this request: 500+  deriving (Eq, Show, Typeable)++instance Functor RouteResult where+  fmap _ RouteNotFound = RouteNotFound+  fmap _ (AllowedMethods m) = AllowedMethods m+  fmap f (RouteResult x) = RouteResult (f x)+  fmap _ MultipleRoutes = MultipleRoutes++instance Monoid (RouteResult a) where+  mempty = RouteNotFound+  mappend RouteNotFound r = r+  mappend (AllowedMethods _) r@(RouteResult _) = r+  mappend (AllowedMethods a) (AllowedMethods b) = AllowedMethods $ unionSorted a b+  mappend r@(RouteResult _) (AllowedMethods _) = r+  mappend MultipleRoutes _ = MultipleRoutes+  mappend r RouteNotFound = r+  mappend _ _ = MultipleRoutes++unionSorted :: Ord a => [a] -> [a] -> [a]+unionSorted al@(a:ar) bl@(b:br) = case compare a b of+  LT -> a:unionSorted ar bl+  EQ -> a:unionSorted ar br+  GT -> b:unionSorted al br+unionSorted [] l = l+unionSorted l [] = l++-- |Convert a result to an appropriate HTTP status and headers.+-- It is up to the user to provide an appropriate body (if any).+routeResult :: RouteResult a -> Either (Status, ResponseHeaders) a+routeResult RouteNotFound = Left (notFound404, [])+routeResult (AllowedMethods m) = Left (methodNotAllowed405, [(hAllow, BSC.intercalate (BSC.singleton ',') $ map renderParameter m)])+routeResult (RouteResult a) = Right a+routeResult MultipleRoutes = Left (internalServerError500, [])
+ Web/Route/Invertible/Route.hs view
@@ -0,0 +1,206 @@+-- |Single-route construction.+-- This package lets you describe the individual end-points for routing and their associated values, essentially packaging up 'Host', 'Path', 'Method' and others with a value ('Action') to represent an entry in your routing table.+{-# 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++-- |A term, qualifier, or component of a route, each specifying one filter/attribute/parser/generator for a 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++-- |A 'Monoidal' collection of routing predicates.+-- For example:+--+-- > routeHost ("www" >* "domain.com") *< routePath ("object" *< parameter) :: Route Int+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++-- |Limit a route to matching hosts.+-- By default, routes apply to any hosts not matched by any other routes in the map.+-- When combining (with 'Web.Route.Invertible.Map.Route.routes') or normalizing (with 'normRoute') routes, this has the highest precedence.+routeHost :: Host h -> Route h+routeHost = Route . Free . RouteHost++-- |Limit a route to only secure (https:) or insecure (http:) protocols.+-- By default, routes apply to both.+routeSecure :: Bool -> Route ()+routeSecure = Route . Free . RouteSecure++-- |Limit a route to matching paths.+-- By default, routes apply to any paths not matched by any other routes in the map (e.g., 404 handler, though it can be more general to handle a 'Web.Route.Invertible.Result.RouteNotFound' result directly) that also match all previous predicates. +routePath :: Path p -> Route p+routePath = Route . Free . RoutePath++-- |Limit a route to a method.+-- By default, routes apply to all methods not handled by any other routes for the same earlier matching predicates (e.g., within the same path).+routeMethod :: IsMethod m => m -> Route ()+routeMethod = Route . Free . RouteMethod . toMethod++-- |Limit a route to a list of methods and return that method.+-- Supplying a method not in this list when generating (reverse) routes will result in a run-time error.+routeMethods :: (Eq m, IsMethod m) => [m] -> Route m+routeMethods = oneOfI routeMethod++-- |Limit a route to requests with a matching URL query parameter.+-- By default, other routes match only when the given parameter is missing.+routeQuery :: QueryString -> Placeholder QueryString a -> Route a+routeQuery q = Route . Free . RouteQuery q++-- |Limit a route to requests with the given \"Content-type\" header, i.e., POST requests containing a request body of a certain type.+-- Note that this does not relate to the type of the response or the \"Accept\" header.+-- By default, routes match only requests without bodies or with content-type headers not matched by any other routes.+routeAccept :: ContentType -> Route ()+routeAccept = Route . Free . RouteAccept++-- |Limit a route to a list of methods and return that method.+-- Supplying a method not in this list when generating (reverse) routes will result in a run-time error.+routeAccepts :: [ContentType] -> Route ContentType+routeAccepts = oneOfI routeAccept++-- |A custom routing predicate that can perform arbitrary tests on the request and reverse routing.+-- The first argument is used in forward routing to check the request, and only passes if it returns 'Just'.+-- The second argument is used in reverse routing to modify the request according to the parameter.+-- By default, routes match all requests -- unlike other predicates, matching a custom rule does not exclude other routes.+-- This should be used sparingly and towards the end of a route as, unlike most other predicates, it only provides /O(n)/ lookups, as these functions must be called for every route candidate (those where all previous predicates match).+routeCustom :: Typeable a => (Request -> Maybe a) -> (a -> Request -> Request) -> Route a+routeCustom fwd rev = Route $ Free $ RouteCustom fwd rev++-- |A simpler version of 'routeCustom' that just takes a filter function to check again the request.+routeFilter :: (Request -> Bool) -> Route ()+routeFilter f = routeCustom (guard . f) (\() -> id)++-- |Set the priority of a route.  Routes with higher priority take precedence when there is a conflict.+-- By default, routes have priority 0.+-- When combining (with 'Web.Route.Invertible.Map.Route.routes') or normalizing (with 'normRoute') routes, this has the lowest precedence (so that conflicts are handled only after matching all other predicates).+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)++-- |By default, route predicates are matched in the order they are specified, so each test is done only if all preceding tests succeed.+-- However, in most cases routing rules should be tested in a specific order in order to produce sensible errors (e.g., a 405 error that offers available methods should only apply to other routes with the same path).+-- This re-orders the predicates in a route in order of the constructors in 'RoutePredicate' (i.e., host, secure, path, method, ...), allowing you to construct your routes in any order but still produce sensible matching behavior.+-- Alternatively, since there are cases you may watch to match in a different order (e.g., for 'routePriority'), you can specify your routes in specific order and avoid this function (which would also be more efficient).+-- Note that there are some \"de-normalized\" cases that this will not correct, such as having duplicate 'routeMethod' specifications (in which case all must match, but each is done independently).+normRoute :: Route a -> Route a+normRoute = Route . sortFreeTDNF comparePredicate . freeRoute++-- |Fold over the predicates in an instatiated route.+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++-- |Given an instantiation of a 'Route' with its value, add the relevant reverse-route information to a 'Request'.+requestRoute' :: Route a -> a -> Request -> Request+requestRoute' r = appEndo . foldRoute (\p -> Endo . requestRoutePredicate p) r++-- |Apply 'requestRoute'' to 'blankRequest'.+requestRoute :: Route a -> a -> Request+requestRoute r a = requestRoute' r a blankRequest++-- |Specify the action to take for a given route, often used as an infix operator between the route specification and the function used to produce the result (which usually generates the HTTP response, but could be anything).+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++-- |'RouteAction' is invariant in its first argument.+-- Apply a bijection to the routing argument, leaving the action alone.+mapActionRoute :: (a I.<-> b) -> RouteAction a r -> RouteAction b r+mapActionRoute f (RouteAction r a) = RouteAction (f >$< r) (a . I.biFrom f)++-- |Apply 'requestRoute' to 'actionRoute'.+requestActionRoute :: RouteAction a b -> a -> Request+requestActionRoute = requestRoute . actionRoute
+ Web/Route/Invertible/Sequence.hs view
@@ -0,0 +1,92 @@+-- |+-- The internal representation for sequences of placeholders, such as paths.+-- For example, the following represents a sequence of @['PlaceholderFixed' "item", 'PlaceholderParameter']@:+--+-- >>> :set -XOverloadedStrings+-- >>> import Control.Invertible.Monoidal+-- >>> import Web.Route.Invertible.Parameter+-- >>> let p = "item" *< parameter :: Sequence String Int+-- >>> parseSequence p ["item", "123"]+-- 123+-- >>> renderSequence p 123+-- ["item","123"]+--+-- These are used as the basis for path routers and other sequential/nested types.+{-# LANGUAGE GeneralizedNewtypeDeriving, MultiParamTypeClasses, FlexibleInstances, ScopedTypeVariables, GADTs #-}+module Web.Route.Invertible.Sequence+  ( Sequence(..)+  , placeholderSequence+  , wildcard+  , sequenceValues+  , renderSequence+  , readsSequence+  , parseSequence+  , reverseSequence+  ) where++import Control.Invertible.Monoidal+import Control.Invertible.Monoidal.Free+import Control.Monad (MonadPlus, mzero, guard)+import qualified Data.Invertible as I+import Data.String (IsString(..))++import Web.Route.Invertible.Parameter+import Web.Route.Invertible.Placeholder++-- |A parser/reverse-router isomorphism between sequences of strings (represented as @[s]@) and a value @a@.+-- These can be constructed using:+--+--   * @'fromString' s@ (or simply @s@ with OverloadedStrings), which matches a single literal component.+--   * @'parameter'@ (or @'param' (undefined :: T)@ for an explicit type), which matches a place-holder component for a 'Parameter' type.+--+-- Sequence values can then be composed using 'Monoidal' and 'MonoidalAlt'.+newtype Sequence s a = Sequence { freeSequence :: Free (Placeholder s) a }+  deriving (I.Functor, Monoidal, MonoidalAlt)++instance Show s => Show (Sequence s a) where+  showsPrec d (Sequence s) = showParen (d > 10) $+    showString "Sequence " . showsFree (showsPrec 11) s++-- |Make a singleton 'Sequence' out of a 'Placeholder'.+placeholderSequence :: Placeholder s a -> Sequence s a+placeholderSequence = Sequence . Free++instance Parameterized s (Sequence s) where+  parameter = placeholderSequence parameter++instance IsString s => IsString (Sequence s ()) where+  fromString = placeholderSequence . fromString++-- |Ignore an arbitrary sequence of parameters (usually as a tail), always generating the same thing.+wildcard :: (Parameterized s f, MonoidalAlt f, Parameter s a) => [a] -> f ()+wildcard d = d >$ manyI parameter++-- |Realize a 'Sequence' as instantiated by a value to a sequence of 'PlaceholderValue's.+sequenceValues :: Sequence s a -> a -> [PlaceholderValue s]+sequenceValues = produceFree f . freeSequence where+  f :: Placeholder s a' -> a' -> PlaceholderValue s+  f (PlaceholderFixed t) () = PlaceholderValueFixed t+  f PlaceholderParameter a = PlaceholderValueParameter a++-- |Render a 'Sequence' as instantiated by a value to a list of string segments.+renderSequence :: Sequence s a -> a -> [s]+renderSequence p = map renderPlaceholderValue . sequenceValues p++-- |Attempt to parse sequence segments into a value and remaining (unparsed) segments, ala 'reads'.+readsSequence :: forall m s a . (MonadPlus m, Eq s) => Sequence s a -> [s] -> m (a, [s])+readsSequence = parseFree f . freeSequence where+  f :: Placeholder s a' -> s -> m a'+  f (PlaceholderFixed t) a = guard (a == t)+  f PlaceholderParameter a = maybe mzero return (parseParameter a)++-- |Parse a sequence into possible values.  Can return all possible values as a list or (usually) a single value as 'Maybe'.+parseSequence :: (MonadPlus m, Eq s) => Sequence s a -> [s] -> m a+parseSequence p l = do+  (a, []) <- readsSequence p l+  return a++-- |Reverse the order of a sequence, such that @reverseSequence p@ parses/produces @reverse l@ iff @p@ parses/produces @l@.+-- Since sequences are matched left-to-right, this lets you match them right-to-left.+-- It probably goes without saying, but this won't work for infinite sequences, such as those produced by 'while'.+reverseSequence :: Sequence s a -> Sequence s a+reverseSequence = Sequence . reverseFree . freeSequence
+ Web/Route/Invertible/Snap.hs view
@@ -0,0 +1,42 @@+-- |A compatibility routing layer for Snap applications.+module Web.Route.Invertible.Snap+  ( module Web.Route.Invertible.Common+  , routeSnap+  , routeMonadSnap+  ) where++import Control.Arrow (left)+import qualified Data.HashMap.Lazy as HM+import Data.Maybe (fromMaybe)+import qualified Data.Map.Lazy as M+import Network.HTTP.Types.Header (hContentType)+import Network.HTTP.Types.URI (decodePath)+import Network.HTTP.Types.Status (statusCode)+import qualified Snap.Core as Snap++import Web.Route.Invertible.Internal+import Web.Route.Invertible.Common+import Web.Route.Invertible++snapRequest :: Snap.Request -> Request+snapRequest q = Request+  { requestHost = splitHost $ Snap.rqServerName q+  , requestSecure = Snap.rqIsSecure q+  , requestMethod = toMethod $ Snap.rqMethod q+  , requestPath = fst $ decodePath $ Snap.rqPathInfo q+  , requestQuery = HM.fromList $ M.toList $ Snap.rqQueryParams q+  , requestContentType = fromMaybe mempty $ Snap.getHeader hContentType q+  }++-- |Lookup a snap request in a route map, returning either an empty error response or a successful result.+routeSnap :: Snap.Request -> RouteMap a -> Either Snap.Response a+routeSnap q = left err . routeRequest (snapRequest q) where+  err (s, h) = foldr (\(n,v) -> Snap.setHeader n v)+    (Snap.setResponseCode (statusCode s) $ Snap.emptyResponse)+    h+  +-- |Combine a set of snap actions in a routing map into a single action, pre-setting an empty response.and returning Nothing in case of error.+routeMonadSnap :: Snap.MonadSnap m => RouteMap (m a) -> m (Maybe a)+routeMonadSnap m = do+  q <- Snap.getRequest+  either ((<$) Nothing . Snap.putResponse) (Just <$>) $ routeSnap q m
+ Web/Route/Invertible/String.hs view
@@ -0,0 +1,22 @@+-- |Representations of (string) data that can be routed/parsed.+{-# LANGUAGE FlexibleInstances #-}+module Web.Route.Invertible.String+  ( RouteString(..)+  ) where++import qualified Data.ByteString.Char8 as BS+import Data.Hashable (Hashable(..))+import Data.String (IsString(..))+import qualified Data.Text as T++-- |Representions of request data that can be used in routing+class (Eq s, IsString s, Hashable s, Monoid s) => RouteString s where+  -- |Must be the inverse of 'fromString'+  toString :: s -> String++instance RouteString String where+  toString = id+instance RouteString T.Text where+  toString = T.unpack+instance RouteString BS.ByteString where+  toString = BS.unpack
+ Web/Route/Invertible/URI.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE RecordWildCards #-}+-- |+-- Conversion between "Network.URI" and routable representations such as 'Request'.+--+-- The most useful function here is 'routeActionURI' which performs reverse routing.+-- If you have an action already defined:+--+-- > getThing :: 'RouteAction' Int (IO Response)+--+-- Then @routeActionURI getThing 123@ will return the method and URI for that route, filling in the placeholders appropriately, e.g., @(GET, \"\/thing\/123\")@.+module Web.Route.Invertible.URI+  ( requestURI +  , uriRequest+  , uriGETRequest+  , routeActionURI+  ) where++import Control.Arrow ((&&&))+import qualified Data.ByteString.Char8 as BSC+import qualified Data.Text as T+import Network.HTTP.Types.URI (parseSimpleQuery, renderSimpleQuery)+import Network.URI++import Web.Route.Invertible.Host+import Web.Route.Invertible.Method+import Web.Route.Invertible.Query+import Web.Route.Invertible.Request+import Web.Route.Invertible.Route++-- |Convert a request to a URI, ignoring the method.+requestURI :: Request -> URI+requestURI Request{..} = nullURI+  { uriScheme = if requestSecure then "https:" else "http:"+  , uriAuthority = if null requestHost then Nothing else Just URIAuth+    { uriUserInfo = ""+    , uriRegName = BSC.unpack $ joinHost requestHost+    , uriPort = ""+    }+  , uriPath = concatMap ((:) '/' . escapeURIString isUnescapedInURIComponent . T.unpack) requestPath+  , uriQuery = BSC.unpack $ renderSimpleQuery True $ paramsQuerySimple requestQuery+  }++-- |Convert a method and URI to a request.+uriRequest :: IsMethod m => m -> URI -> Request+uriRequest m u = Request+  { requestMethod = toMethod m+  , requestSecure = uriScheme u == "https:"+  , requestHost = maybe [] (splitHost . BSC.pack . uriRegName) $ uriAuthority u+  , requestPath = map (T.pack . unEscapeString) $ pathSegments u+  , requestQuery = simpleQueryParams $ parseSimpleQuery $ BSC.pack $ uriQuery u+  , requestContentType = mempty+  }++-- |Convert a GET URI to a request.+uriGETRequest :: URI -> Request+uriGETRequest = uriRequest GET++-- |Reverse a route action to a URI.+routeActionURI :: RouteAction r a -> r -> (Method, URI)+routeActionURI r = (requestMethod &&& requestURI) . requestActionRoute r
+ Web/Route/Invertible/Wai.hs view
@@ -0,0 +1,39 @@+-- |A compatibility routing layer for WAI applications.+module Web.Route.Invertible.Wai+  ( module Web.Route.Invertible.Common+  , routeWai+  , routeWaiApplicationError+  , routeWaiApplication+  ) where++import Control.Arrow (second)+import Data.Maybe (fromMaybe)+import qualified Network.Wai as Wai+import Network.HTTP.Types.Header (ResponseHeaders, hContentType)+import Network.HTTP.Types.Status (Status)++import Web.Route.Invertible.Internal+import Web.Route.Invertible.Common+import Web.Route.Invertible++waiRequest :: Wai.Request -> Request+waiRequest q = Request+  { requestHost = maybe [] splitHost $ Wai.requestHeaderHost q+  , requestSecure = Wai.isSecure q+  , requestMethod = toMethod $ Wai.requestMethod q+  , requestPath = Wai.pathInfo q+  , requestQuery = simpleQueryParams $ map (second $ fromMaybe mempty) $ Wai.queryString q+  , requestContentType = fromMaybe mempty $ lookup hContentType headers+  } where headers = Wai.requestHeaders q++-- |Lookup a wai request in a route map, returning either an error code and headers or a successful result.+routeWai :: Wai.Request -> RouteMap a -> Either (Status, ResponseHeaders) a+routeWai = routeRequest . waiRequest++-- |Combine a set of applications in a routing map into a single application, calling a custom error handler in case of routing error.+routeWaiApplicationError :: (Status -> ResponseHeaders -> Wai.Application) -> RouteMap Wai.Application -> Wai.Application+routeWaiApplicationError e m q r = either (\(s, h) -> e s h q r) (\a -> a q r) $ routeWai q m++-- |Combine a set of applications in a routing map into a single application, returning an empty error response in case of routing error.+routeWaiApplication :: RouteMap Wai.Application -> Wai.Application+routeWaiApplication = routeWaiApplicationError $ \s h _ r -> r $ Wai.responseBuilder s h mempty
+ test/Main.hs view
@@ -0,0 +1,85 @@+{-# LANGUAGE OverloadedStrings #-}+module Main (main) where++import Data.Maybe (fromJust)+import Network.URI (parseURI)+import System.Exit (exitSuccess, exitFailure)+import qualified Test.HUnit as U++import Web.Route.Invertible+import Web.Route.Invertible.URI++getThing :: RouteAction Int String+getThing = routeMethod GET *< routePath ("thing" *< parameter) `RouteAction` \i ->+  "get thing" ++ show i++getThingQ :: RouteAction (Int, Char) String+getThingQ = routeMethod GET *< routePath ("thing" *< parameter) >*< routeQuery "type" parameter `RouteAction` \(i, c) ->+  "get thing" ++ show i ++ ":" ++ [c]++getThing2 :: RouteAction (Int, Int) String+getThing2 = routeMethod GET *< routePath ("thing" *< parameter >*< parameter) `RouteAction` \(i, sub) ->+  "get thing" ++ show i ++ "." ++ show sub++putThing :: RouteAction Int String+putThing = routeMethod PUT *< routePath ("thing" *< parameter) `RouteAction` \i ->+  "put thing" ++ show i++postThing :: RouteAction String String+postThing = routeMethod POST *< routePath ("thing" *< parameter) `RouteAction` \i ->+  "post thing=" ++ i++anyThingSub :: RouteAction (Int, [Int]) String+anyThingSub = routePath ("thing" *< parameter >* "sub" >*< manyI parameter) `RouteAction` \(i, l) ->+  "thing" ++ show i ++ " sub" ++ concatMap ((' ' :) . show) l++ignoredThing :: RouteAction Int String+ignoredThing = routeMethod GET *< routePath ("things" *< parameter >* wildcard ["ign" :: String]) `RouteAction` \i ->+  "ignore thing" ++ show i++complex :: RouteAction () String+complex = (routeMethod GET *< routeSecure False) *< (routePath "foo" *< routeHost ("foo" *< "com")) `RouteAction` \() ->+  "complex"++things :: RouteMap String+things = routes+  [ routeNormCase getThing+  , routeNormCase getThingQ+  , routeNormCase putThing+  , routeNormCase postThing+  , routeNormCase getThing2+  , routeNormCase anyThingSub+  , routeNormCase ignoredThing+  , routeNormCase complex+  ]++-- req :: Method -> String -> Request+-- req m = uriRequest m . fromJust . parseURI++rte :: Method -> String -> RouteResult String+rte m u = lookupRoute (uriRequest m $ fromJust $ parseURI u) things++req :: RouteAction r a -> r -> (Method, String)+req a = fmap show . routeActionURI a++tests :: U.Test+tests = U.test+  [ rte GET "http:/thing/0"           U.~?= RouteResult "get thing0"+  , rte GET "http:/thing/-3?type=x"   U.~?= RouteResult "get thing-3:x"+  , req getThingQ (98, '=')           U.~?= (GET, "http:/thing/98?type=%3D")+  , rte PUT "http:/thing/09"          U.~?= RouteResult "put thing9"+  , req postThing "foo"               U.~?= (POST, "http:/thing/foo")+  , rte OPTIONS "http:/thing/xxx"     U.~?= AllowedMethods [POST]+  , rte PUT "http:/thing/0/sub/12/34" U.~?= RouteResult "thing0 sub 12 34"+  , rte GET "http:/things/0/12/34"    U.~?= RouteResult "ignore thing0"+  , req ignoredThing (-3)             U.~?= (GET, "http:/things/-3/ign")+  , rte POST "http://foo.com/foo"     U.~?= AllowedMethods [GET]+  , rte POST "http:/foo"              U.~?= RouteNotFound+  ]++main :: IO ()+main = do+  r <- U.runTestTT tests+  if U.errors r == 0 && U.failures r == 0+    then exitSuccess+    else exitFailure
+ web-inv-route.cabal view
@@ -0,0 +1,119 @@+name:                web-inv-route+version:             0.1+synopsis:            Composable, reversible, efficient web routing based on invertible invariants and bijections+description:+  Utilities to route HTTP requests, mainly focused on path components.  Routes are specified using bijections and invariant functors, allowing run-time composition (routes can be distributed across modules), reverse and forward routing derived from the same specification, and O(log n) lookups.+  .+  There are four steps/components of this package.+  .+    1. Route endpoint specification: "Web.Route.Invertible.Common"+    2. Route map construction: "Web.Route.Invertible.Common"+    3. Route map lookup: "Web.Route.Invertible" (for the generic interface), "Web.Route.Invertible.Wai", "Web.Route.Invertible.Snap", or "Web.Route.Invertible.Happstack"+    4. Reverse routing: "Web.Route.Invertible" or "Web.Route.Invertible.URI"+  .+  Most users will just want to import a framework-specific module like "Web.Route.Invertible.Wai" (or the generic "Web.Route.Invertible"), each of which re-exports "Web.Route.Invertible.Common".+  See test/Main.hs for some examples.+license:             BSD3+author:              Dylan Simon+maintainer:          dylan@dylex.net+copyright:           2016+category:            Web+build-type:          Simple+cabal-version:       >=1.20++source-repository head+  type: git+  location: https://github.com/dylex/web-inv-route++flag uri+  description: Support constructing URIs from routes++flag wai+  description: Provide WAI-compatible interfaces++flag snap+  description: Provide Snap-compatible interfaces++flag happstack+  description: Provide Happstack-compatible interfaces++library+  exposed-modules:     +    Web.Route.Invertible+    Web.Route.Invertible.Common+    Web.Route.Invertible.Internal+  other-modules:+    Web.Route.Invertible.String+    Web.Route.Invertible.Parameter+    Web.Route.Invertible.Placeholder+    Web.Route.Invertible.Sequence+    Web.Route.Invertible.Path+    Web.Route.Invertible.Host+    Web.Route.Invertible.Method+    Web.Route.Invertible.Query+    Web.Route.Invertible.ContentType+    Web.Route.Invertible.Dynamics+    Web.Route.Invertible.Route+    Web.Route.Invertible.Request+    Web.Route.Invertible.Result+    Web.Route.Invertible.Monoid.Exactly+    Web.Route.Invertible.Monoid.Prioritized+    Web.Route.Invertible.Map+    Web.Route.Invertible.Map.Monoid+    Web.Route.Invertible.Map.MonoidHash+    Web.Route.Invertible.Map.Default+    Web.Route.Invertible.Map.Const+    Web.Route.Invertible.Map.Bool+    Web.Route.Invertible.Map.ParameterType+    Web.Route.Invertible.Map.Placeholder+    Web.Route.Invertible.Map.Sequence+    Web.Route.Invertible.Map.Path+    Web.Route.Invertible.Map.Host+    Web.Route.Invertible.Map.Method+    Web.Route.Invertible.Map.Query+    Web.Route.Invertible.Map.Custom+    Web.Route.Invertible.Map.Route++  build-depends:       +    base >= 4.8 && <5,+    containers >= 0.5,+    transformers,+    hashable,+    unordered-containers,+    text >= 0.10,+    bytestring >= 0.10,+    case-insensitive,+    http-types >= 0.9,+    invertible > 0.1+  default-language: Haskell2010+  ghc-options: -Wall++  if flag(uri)+    exposed-modules: Web.Route.Invertible.URI+    build-depends: network-uri++  if flag(wai)+    exposed-modules: Web.Route.Invertible.Wai+    build-depends: wai >= 1++  if flag(snap)+    exposed-modules: Web.Route.Invertible.Snap+    build-depends: snap-core >= 0.9++  if flag(happstack)+    exposed-modules: Web.Route.Invertible.Happstack+    build-depends: happstack-server >= 7++test-suite tests+  type: exitcode-stdio-1.0+  hs-source-dirs: test+  main-is: Main.hs+  default-language: Haskell2010+  ghc-options: -Wall+  build-depends:+    base,+    bytestring,+    text,+    network-uri,+    HUnit,+    web-inv-route