├── .gitignore ├── LICENSE ├── README.md ├── Setup.hs ├── logo.png ├── logo.svg ├── nested-routes.cabal ├── package.yaml ├── src └── Web │ └── Routes │ ├── Nested.hs │ └── Nested │ ├── Match.hs │ └── Types.hs ├── stack.yaml ├── stack.yaml.lock └── test ├── Spec.hs ├── Test.hs └── Web └── Routes ├── NestedSpec.hs └── NestedSpec └── Basic.hs /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | cabal-dev 3 | *.o 4 | *.hi 5 | *.chi 6 | *.chs.h 7 | *.dyn_o 8 | *.dyn_hi 9 | .virtualenv 10 | .hpc 11 | .hsenv 12 | .cabal-sandbox/ 13 | cabal.sandbox.config 14 | *.prof 15 | *.aux 16 | *.hp 17 | .stack-work/ 18 | .docker-sandbox/ 19 | Dockerfile 20 | target/ 21 | TAGS 22 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015, Athan Clark 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Athan Clark nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ![Logo](https://raw.githubusercontent.com/athanclark/nested-routes/269e8dd2105e9fea314b4374e19ecacca6f50659/logo.svg) 2 | 3 | ```haskell 4 | routes :: RouterT (MiddlewareT m) sec m () 5 | routes = do 6 | matchHere $ action $ do 7 | get $ do 8 | json ("some cool json", True, 12) -- application/json 9 | text "Yo" -- text/plain 10 | matchGroup (l_ "someChunk" o_) $ do 11 | match (p_ "some parser" Attoparsec.doube o_) $ \(d :: Double) -> -- "/someChunk/124.234" would match 12 | action $ ... 13 | matchGroup (r_ [regex|/^(\.)+(.*)/|] o_) $ \(matches :: [String]) -> -- "/someChunk/....huh?" would match 14 | action $ ... 15 | 16 | 17 | myMiddleware :: MiddlewareT m 18 | myMiddleware = route routes 19 | ``` 20 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /logo.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/athanclark/nested-routes/f5ce159b8d3fb81b07255dd722be488724c3e767/logo.png -------------------------------------------------------------------------------- /logo.svg: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 19 | 21 | 29 | 35 | 36 | 44 | 50 | 51 | 60 | 66 | 67 | 76 | 82 | 83 | 91 | 97 | 98 | 99 | 121 | 123 | 124 | 126 | image/svg+xml 127 | 129 | 130 | 131 | 132 | 133 | 138 | 144 | 150 | 156 | 162 | 167 | 168 | 169 | -------------------------------------------------------------------------------- /nested-routes.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.12 2 | 3 | -- This file has been generated from package.yaml by hpack version 0.35.2. 4 | -- 5 | -- see: https://github.com/sol/hpack 6 | -- 7 | -- hash: 40872453e434f8694f8801dfc1394a8ed0674e4dc6d8918b4906b0d03fee8f92 8 | 9 | name: nested-routes 10 | version: 10.0.0 11 | synopsis: Declarative, compositional Wai responses 12 | description: Please see the README on Github at 13 | category: Web 14 | homepage: https://github.com/athanclark/nested-routes#readme 15 | bug-reports: https://github.com/athanclark/nested-routes/issues 16 | maintainer: Athan Clark 17 | license: BSD3 18 | license-file: LICENSE 19 | build-type: Simple 20 | 21 | source-repository head 22 | type: git 23 | location: https://github.com/athanclark/nested-routes 24 | 25 | library 26 | exposed-modules: 27 | Web.Routes.Nested 28 | Web.Routes.Nested.Match 29 | Web.Routes.Nested.Types 30 | other-modules: 31 | Paths_nested_routes 32 | hs-source-dirs: 33 | src 34 | ghc-options: -Wall 35 | build-depends: 36 | attoparsec 37 | , base >=4.11 && <5 38 | , errors 39 | , exceptions 40 | , extractable-singleton 41 | , hashable 42 | , monad-control-aligned >=0.0.2 43 | , mtl 44 | , poly-arity >=0.0.7 45 | , pred-trie >=0.6.1 46 | , regex-compat 47 | , text 48 | , tries >=0.0.6 49 | , unordered-containers 50 | , wai >=3.2.1 51 | , wai-middleware-content-type >=0.7.0 52 | , wai-middleware-verbs >=0.4.0.1 53 | , wai-transformers >=0.1.0 54 | default-language: Haskell2010 55 | 56 | test-suite spec 57 | type: exitcode-stdio-1.0 58 | main-is: Test.hs 59 | other-modules: 60 | Spec 61 | Web.Routes.NestedSpec 62 | Web.Routes.NestedSpec.Basic 63 | Paths_nested_routes 64 | hs-source-dirs: 65 | test 66 | ghc-options: -Wall -threaded -rtsopts -Wall -with-rtsopts=-N 67 | build-depends: 68 | attoparsec 69 | , base 70 | , errors 71 | , exceptions 72 | , extractable-singleton 73 | , hashable 74 | , hspec 75 | , hspec-wai 76 | , http-types 77 | , monad-control-aligned >=0.0.2 78 | , mtl 79 | , nested-routes 80 | , poly-arity >=0.0.7 81 | , pred-trie >=0.6.1 82 | , regex-compat 83 | , tasty 84 | , tasty-hspec 85 | , text 86 | , tries >=0.0.6 87 | , unordered-containers 88 | , wai >=3.2.1 89 | , wai-middleware-content-type >=0.7.0 90 | , wai-middleware-verbs >=0.4.0.1 91 | , wai-transformers >=0.1.0 92 | default-language: Haskell2010 93 | -------------------------------------------------------------------------------- /package.yaml: -------------------------------------------------------------------------------- 1 | name: nested-routes 2 | version: 10.0.0 3 | synopsis: Declarative, compositional Wai responses 4 | description: Please see the README on Github at 5 | maintainer: Athan Clark 6 | license: BSD3 7 | github: athanclark/nested-routes 8 | category: Web 9 | 10 | ghc-options: -Wall 11 | 12 | dependencies: 13 | - base >= 4.11 && < 5 14 | - attoparsec 15 | - errors 16 | - exceptions 17 | - extractable-singleton 18 | - hashable 19 | - monad-control-aligned >= 0.0.2 20 | - mtl 21 | - poly-arity >= 0.0.7 22 | - pred-trie >= 0.6.1 23 | - regex-compat 24 | - text 25 | - tries >= 0.0.6 26 | - unordered-containers 27 | - wai >= 3.2.1 28 | - wai-transformers >= 0.1.0 29 | - wai-middleware-content-type >= 0.7.0 30 | - wai-middleware-verbs >= 0.4.0.1 31 | 32 | library: 33 | source-dirs: src 34 | 35 | tests: 36 | spec: 37 | ghc-options: 38 | - -threaded 39 | - -rtsopts 40 | - -Wall 41 | - -with-rtsopts=-N 42 | main: Test.hs 43 | source-dirs: 44 | - test 45 | dependencies: 46 | - base 47 | - nested-routes 48 | - http-types 49 | - hspec 50 | - hspec-wai 51 | - tasty 52 | - tasty-hspec 53 | -------------------------------------------------------------------------------- /src/Web/Routes/Nested.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE 2 | GADTs 3 | , PolyKinds 4 | , TypeFamilies 5 | , BangPatterns 6 | , TypeOperators 7 | , TupleSections 8 | , DoAndIfThenElse 9 | , ConstraintKinds 10 | , FlexibleContexts 11 | , OverloadedStrings 12 | , ScopedTypeVariables 13 | , NamedFieldPuns 14 | #-} 15 | 16 | {- | 17 | Module : Web.Routes.Nested 18 | Copyright : (c) 2015, 2016, 2017, 2018 Athan Clark 19 | 20 | License : BSD-style 21 | Maintainer : athan.clark@gmail.com 22 | Stability : experimental 23 | Portability : GHC 24 | 25 | This module exports most of what you'll need for sophisticated routing - 26 | all the tools from 27 | (routing for the incoming HTTP method) and 28 | 29 | (routing for the incoming Accept header, and implied file extension), 30 | itself, and 31 | - some simple 32 | type aliases wrapped around WAI's @Application@ and @Middleware@ types, allowing us 33 | to embed monad transformer stacks for our applications. 34 | 35 | To match a route, you have a few options - you can match against a string literal, 36 | a regular expression (via ), 37 | or an parser. This list 38 | will most likely grow in the future, depending on demand. 39 | 40 | There is also support for embedding security layers in your routes, in the same 41 | nested manner. By "tagging" a set of routes with an authorization role (with @auth@), 42 | you populate a list of roles breached during any request. The function argument to 43 | 'routeAuth' guards a Request to pass or fail at the high level, while 'auth' lets 44 | you create your authorization boundaries on a case-by-case basis. Both allow 45 | you to tap into the monad transformer stack for logging, STRefs, database queries, 46 | etc. 47 | -} 48 | 49 | 50 | module Web.Routes.Nested 51 | ( -- * Router Construction 52 | match 53 | , matchHere 54 | , matchAny 55 | , matchGroup 56 | , auth 57 | , -- * Routing Middleware 58 | route 59 | , routeAuth 60 | , -- ** Precise Route Extraction 61 | extractMatch 62 | , extractMatchAny 63 | , extractAuthSym 64 | , extractAuth 65 | , extractNearestVia 66 | , -- * Metadata 67 | SecurityToken (..) 68 | , AuthScope (..) 69 | , Match 70 | , MatchGroup 71 | , -- * Re-Exports 72 | module Web.Routes.Nested.Match 73 | , module Web.Routes.Nested.Types 74 | , module Network.Wai.Middleware.Verbs 75 | , module Network.Wai.Middleware.ContentType 76 | ) where 77 | 78 | import Web.Routes.Nested.Match (UrlChunks, origin_) 79 | import Web.Routes.Nested.Match 80 | import Web.Routes.Nested.Types (RouterT, execRouterT, Tries (..), ExtrudeSoundly) 81 | import Web.Routes.Nested.Types 82 | import Network.Wai (Request, pathInfo) 83 | import Network.Wai.Trans (MiddlewareT) 84 | import Network.Wai.Middleware.Verbs 85 | import Network.Wai.Middleware.ContentType hiding (responseStatus, responseHeaders, responseData) 86 | 87 | import Data.Trie.Pred.Base (RootedPredTrie (..), PredTrie (..)) 88 | import Data.Trie.Pred.Base.Step (PredStep (..), Pred (..)) 89 | import qualified Data.Trie.Pred.Interface as Interface 90 | import Data.Trie.Pred.Interface.Types (Singleton (..), Extrude (..), CatMaybes) 91 | import Data.Trie.HashMap (HashMapStep (..), HashMapChildren (..)) 92 | import Data.List.NonEmpty (NonEmpty (..), fromList) 93 | import qualified Data.Text as T 94 | import Data.Hashable (Hashable) 95 | import qualified Data.HashMap.Strict as HM 96 | import Data.Monoid ((<>), First (..)) 97 | import Data.Function.Poly (ArityTypeListIso) 98 | import Data.Bifunctor (bimap) 99 | 100 | import qualified Control.Monad.State as S 101 | import Control.Monad.Catch (MonadThrow) 102 | import Control.Monad.Trans (MonadTrans (..)) 103 | import Control.Monad.IO.Class (MonadIO (..)) 104 | import Control.Arrow (first) 105 | import Control.Monad.ST (stToIO) 106 | 107 | 108 | -- | The constraints necessary for 'match'. 109 | type Match xs' xs childContent resultContent = 110 | ( xs' ~ CatMaybes xs 111 | , Singleton (UrlChunks xs) childContent (RootedPredTrie T.Text resultContent) 112 | , ArityTypeListIso childContent xs' resultContent 113 | ) 114 | 115 | 116 | -- | The constraints necessary for 'matchGroup'. 117 | type MatchGroup xs' xs childContent resultContent childSec resultSec = 118 | ( ExtrudeSoundly xs' xs childContent resultContent 119 | , ExtrudeSoundly xs' xs childSec resultSec 120 | ) 121 | 122 | 123 | -- | Embed a 'Network.Wai.Trans.MiddlewareT' into a set of routes via a matching string. You should 124 | -- expect the match to create /arity/ in your handler - the @childContent@ variable. 125 | -- The arity of @childContent@ may grow or shrink, depending on the heterogeneous 126 | -- list created from the list of parsers, regular expressions, or arbitrary predicates 127 | -- /in the order written/ - so something like: 128 | -- 129 | -- > match (p_ "double-parser" double o_) 130 | -- > handler 131 | -- 132 | -- ...then @handler@ /must/ have arity @Double ->@. If this 133 | -- route was at the top level, then the total arity __must__ be @Double -> MiddlewareT m@. 134 | -- 135 | -- Generally, if the routes you are building get grouped 136 | -- by a predicate with 'matchGroup', 137 | -- then we would need another level of arity /before/ the @Double@. 138 | match :: Monad m 139 | => Match xs' xs childContent resultContent 140 | => UrlChunks xs -- ^ Predicative path to match against 141 | -> childContent -- ^ The response to send 142 | -> RouterT resultContent sec m () 143 | match !ts !vl = 144 | tell' $ Tries (singleton ts vl) 145 | mempty 146 | mempty 147 | 148 | 149 | {-# INLINEABLE match #-} 150 | 151 | -- | Create a handle for the /current/ route - an alias for @\h -> match o_ h@. 152 | matchHere :: Monad m 153 | => childContent -- ^ The response to send 154 | -> RouterT childContent sec m () 155 | matchHere = match origin_ 156 | 157 | {-# INLINEABLE matchHere #-} 158 | 159 | 160 | -- | Match against any route, as a last resort against all failing matches - 161 | -- use this for a catch-all at some level in their routes, something 162 | -- like a @not-found 404@ page is useful. 163 | matchAny :: Monad m 164 | => childContent -- ^ The response to send 165 | -> RouterT childContent sec m () 166 | matchAny !vl = 167 | tell' $ Tries mempty 168 | (singleton origin_ vl) 169 | mempty 170 | 171 | 172 | {-# INLINEABLE matchAny #-} 173 | 174 | 175 | -- | Prepends a common route to an existing set of routes. You should note that 176 | -- doing this with a parser or regular expression will necessitate the existing 177 | -- arity in the handlers before the progam can compile. 178 | matchGroup :: Monad m 179 | => MatchGroup xs' xs childContent resultContent childSec resultSec 180 | => UrlChunks xs -- ^ Predicative path to match against 181 | -> RouterT childContent childSec m () -- ^ Child routes to nest 182 | -> RouterT resultContent resultSec m () 183 | matchGroup !ts cs = do 184 | (Tries trieContent' trieNotFound trieSec) <- lift $ execRouterT cs 185 | tell' $ Tries (extrude ts trieContent') 186 | (extrude ts trieNotFound) 187 | (extrude ts trieSec) 188 | 189 | 190 | {-# INLINEABLE matchGroup #-} 191 | 192 | -- | Use a custom security token type and an 'AuthScope' to define 193 | -- /where/ and /what kind/ of security should take place. 194 | data SecurityToken s = SecurityToken 195 | { securityToken :: !s 196 | , securityScope :: !AuthScope 197 | } deriving (Show) 198 | 199 | -- | Designate the scope of security to the set of routes - either only the adjacent 200 | -- routes, or the adjacent /and/ the parent container node (root node if not 201 | -- declared). 202 | data AuthScope 203 | = ProtectHere 204 | | DontProtectHere 205 | deriving (Show, Eq) 206 | 207 | -- | Sets the security role and error handler for a set of routes, optionally 208 | -- including its parent route. 209 | auth :: Monad m 210 | => sec -- ^ Your security token 211 | -> AuthScope 212 | -> RouterT content (SecurityToken sec) m () 213 | auth !token !scope = 214 | tell' (Tries mempty 215 | mempty 216 | (singleton origin_ (SecurityToken token scope))) 217 | 218 | 219 | {-# INLINEABLE auth #-} 220 | 221 | 222 | -- * Routing --------------------------------------- 223 | 224 | -- | Use this function to run your 'RouterT' into a 'MiddlewareT'; 225 | -- making your router executable in WAI. Note that this only 226 | -- responds with content, and doesn't protect your routes with 227 | -- your calls to 'auth'; to protect routes, postcompose this 228 | -- with 'routeAuth': 229 | -- 230 | -- > route routes . routeAuth routes 231 | route :: MonadIO m 232 | => RouterT (MiddlewareT m) sec m a -- ^ The Router 233 | -> MiddlewareT m 234 | route hs app req resp = do 235 | let path = pathInfo req 236 | mightMatch <- extractMatch path hs 237 | case mightMatch of 238 | Nothing -> do 239 | mMatch <- extractMatchAny path hs 240 | maybe 241 | (app req resp) 242 | (\mid -> mid app req resp) 243 | mMatch 244 | Just mid -> mid app req resp 245 | 246 | 247 | -- | Supply a method to decide whether or not to 'Control.Monad.Catch.throwM' 248 | -- an exception based on the current 'Network.Wai.Middleware.Request' and 249 | -- the /layers/ of 'auth' tokens passed in your router, turn your router 250 | -- into a 'Control.Monad.guard' for middlewares, basically. 251 | routeAuth :: MonadIO m 252 | => MonadThrow m 253 | => (Request -> [sec] -> m ()) -- ^ authorization method 254 | -> RouterT (MiddlewareT m) (SecurityToken sec) m a -- ^ The Router 255 | -> MiddlewareT m 256 | routeAuth authorize hs app req resp = do 257 | extractAuth authorize req hs 258 | route hs app req resp 259 | 260 | -- * Extraction ------------------------------- 261 | 262 | -- | Extracts only the normal 'match', 'matchGroup' and 'matchHere' routes. 263 | extractMatch :: MonadIO m 264 | => [T.Text] -- ^ The path to match against 265 | -> RouterT r sec m a -- ^ The Router 266 | -> m (Maybe r) 267 | extractMatch path !hs = do 268 | Tries{trieContent} <- execRouterT hs 269 | let mResult = lookupWithLRPT trimFileExt path trieContent 270 | case mResult of 271 | Nothing -> 272 | if not (null path) 273 | && trimFileExt (last path) == "index" 274 | then pure $ Interface.lookup (init path) trieContent 275 | else pure Nothing 276 | Just (_,r) -> pure (Just r) 277 | 278 | {-# INLINEABLE extractMatch #-} 279 | 280 | 281 | -- | Extracts only the 'matchAny' responses; something like the greatest-lower-bound. 282 | extractMatchAny :: MonadIO m 283 | => [T.Text] -- ^ The path to match against 284 | -> RouterT r sec m a -- ^ The Router 285 | -> m (Maybe r) 286 | extractMatchAny path = extractNearestVia path (\x -> trieCatchAll <$> execRouterT x) 287 | 288 | {-# INLINEABLE extractMatchAny #-} 289 | 290 | 291 | 292 | -- | Find the security tokens / authorization roles affiliated with 293 | -- a request for a set of routes. 294 | extractAuthSym :: MonadIO m 295 | => [T.Text] -- ^ The path to match against 296 | -> RouterT x (SecurityToken sec) m a -- ^ The Router 297 | -> m [sec] 298 | extractAuthSym path hs = do 299 | Tries{trieSecurity} <- execRouterT hs 300 | liftIO . stToIO $ do 301 | let results = Interface.matches path trieSecurity 302 | pure $! foldr go [] results 303 | where 304 | go (_,SecurityToken _ DontProtectHere,[]) ys = ys 305 | go (_,SecurityToken x _ ,_ ) ys = x:ys 306 | 307 | {-# INLINEABLE extractAuthSym #-} 308 | 309 | -- | Extracts only the security handling logic, and turns it into a guard. 310 | extractAuth :: MonadIO m 311 | => MonadThrow m 312 | => (Request -> [sec] -> m ()) -- ^ authorization method 313 | -> Request 314 | -> RouterT x (SecurityToken sec) m a 315 | -> m () 316 | extractAuth authorize req hs = do 317 | ss <- extractAuthSym (pathInfo req) hs 318 | authorize req ss 319 | 320 | {-# INLINEABLE extractAuth #-} 321 | 322 | 323 | -- | Given a way to draw out a special-purpose trie from our route set, route 324 | -- to the responses based on a /furthest-route-reached/ method, or like a 325 | -- greatest-lower-bound. 326 | extractNearestVia :: MonadIO m 327 | => [T.Text] -- ^ The path to match against 328 | -> (RouterT r sec m a -> m (RootedPredTrie T.Text r)) 329 | -> RouterT r sec m a 330 | -> m (Maybe r) 331 | extractNearestVia path extr hs = do 332 | trie <- extr hs 333 | pure (mid <$> Interface.match path trie) 334 | where 335 | mid (_,r,_) = r 336 | 337 | {-# INLINEABLE extractNearestVia #-} 338 | 339 | 340 | 341 | -- * Pred-Trie related ----------------- 342 | 343 | -- | Removes @.txt@ from @foo.txt@ 344 | trimFileExt :: T.Text -> T.Text 345 | trimFileExt !s = 346 | case T.breakOnEnd "." s of 347 | (f,e) | f /= "" 348 | && e /= "" 349 | && T.length f > 0 -> T.dropEnd 1 f 350 | _ -> s 351 | 352 | {-# INLINEABLE trimFileExt #-} 353 | 354 | 355 | -- | A quirky function for processing the last element of a lookup path, only 356 | -- on /literal/ matches. 357 | lookupWithLPT :: Hashable s 358 | => Eq s 359 | => (s -> s) -> NonEmpty s -> PredTrie s a -> Maybe ([s], a) 360 | lookupWithLPT f tss (PredTrie (HashMapStep ls) (PredStep ps)) = 361 | getFirst $ First (goLit f tss ls) 362 | <> foldMap (First . goPred f tss) ps 363 | 364 | goLit :: Hashable s 365 | => Eq s 366 | => (s -> s) 367 | -> NonEmpty s 368 | -> HM.HashMap s (HashMapChildren PredTrie s a) 369 | -> Maybe ([s], a) 370 | goLit f (t:|ts) xs = do 371 | (HashMapChildren mx mxs) <- getFirst $ First (HM.lookup t xs) 372 | <> First ( if null ts 373 | then HM.lookup (f t) xs 374 | else Nothing) 375 | if null ts 376 | then ([f t],) <$> mx 377 | else first (t:) <$> (lookupWithLPT f (fromList ts) =<< mxs) 378 | 379 | goPred :: Hashable s 380 | => Eq s 381 | => (s -> s) 382 | -> NonEmpty s 383 | -> Pred PredTrie s a 384 | -> Maybe ([s], a) 385 | goPred f (t:|ts) (Pred predicate mx xs) = do 386 | d <- predicate t 387 | if null ts 388 | then (([t],) . ($ d)) <$> mx 389 | else bimap (t:) ($ d) <$> lookupWithLPT f (fromList ts) xs 390 | 391 | 392 | 393 | {-# INLINEABLE lookupWithLPT #-} 394 | 395 | 396 | lookupWithLRPT :: Hashable s 397 | => Eq s 398 | => (s -> s) -> [s] -> RootedPredTrie s a -> Maybe ([s], a) 399 | lookupWithLRPT _ [] (RootedPredTrie mx _) = ([],) <$> mx 400 | lookupWithLRPT f ts (RootedPredTrie _ xs) = lookupWithLPT f (fromList ts) xs 401 | 402 | 403 | 404 | {-# INLINEABLE lookupWithLRPT #-} 405 | 406 | 407 | tell' :: Monoid w => S.MonadState w m => w -> m () 408 | tell' x = S.modify' (<> x) 409 | 410 | {-# INLINEABLE tell' #-} 411 | 412 | -------------------------------------------------------------------------------- /src/Web/Routes/Nested/Match.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE 2 | GADTs 3 | , DataKinds 4 | , RankNTypes 5 | , TypeOperators 6 | , KindSignatures 7 | , OverloadedStrings 8 | , MultiParamTypeClasses 9 | , FunctionalDependencies 10 | #-} 11 | 12 | {- | 13 | Module : Web.Routes.Nested.Match 14 | Copyright : (c) 2015, 2016, 2017, 2018 Athan Clark 15 | 16 | License : BSD-style 17 | Maintainer : athan.clark@gmail.com 18 | Stability : experimental 19 | Portability : GHC 20 | -} 21 | 22 | module Web.Routes.Nested.Match 23 | ( -- * Path Combinators 24 | o_ 25 | , origin_ 26 | , l_ 27 | , literal_ 28 | , f_ 29 | , file_ 30 | , p_ 31 | , parse_ 32 | , r_ 33 | , regex_ 34 | , pred_ 35 | , () 36 | , -- ** Path Types 37 | EitherUrlChunk 38 | , UrlChunks 39 | , ToUrlChunks (..) 40 | ) where 41 | 42 | import Prelude hiding (pred) 43 | import Data.Attoparsec.Text (Parser, parseOnly) 44 | import Text.Regex (Regex, matchRegex) 45 | import qualified Data.Text as T 46 | import Control.Monad (guard) 47 | import Control.Error (hush) 48 | import Data.Trie.Pred (PathChunk, PathChunks, pred, nil, only, (./)) 49 | 50 | 51 | o_, origin_ :: UrlChunks '[] 52 | o_ = origin_ 53 | 54 | -- | The /Origin/ chunk - the equivalent to @[]@ 55 | origin_ = nil 56 | 57 | 58 | l_, literal_ :: T.Text -> EitherUrlChunk 'Nothing 59 | l_ = literal_ 60 | 61 | -- | Match against a /Literal/ chunk 62 | literal_ = only 63 | 64 | f_, file_ :: T.Text -> EitherUrlChunk ('Just T.Text) 65 | f_ = file_ 66 | 67 | -- | Removes file extension from the matchedhttp://hackage.haskell.org/package/nested-routes route 68 | file_ f = pred_ f (\t -> t <$ guard (fst (T.breakOn "." t) == f)) 69 | 70 | 71 | p_, parse_ :: T.Text -> Parser r -> EitherUrlChunk ('Just r) 72 | p_ = parse_ 73 | 74 | -- | Match against a /Parsed/ chunk, with . 75 | parse_ i q = pred_ i (hush . parseOnly q) 76 | 77 | 78 | r_, regex_ :: T.Text -> Regex -> EitherUrlChunk ('Just [String]) 79 | r_ = regex_ 80 | 81 | -- | Match against a /Regular expression/ chunk, with . 82 | regex_ i q = pred_ i (matchRegex q . T.unpack) 83 | 84 | -- | Match with a predicate against the url chunk directly. 85 | pred_ :: T.Text -> (T.Text -> Maybe r) -> EitherUrlChunk ('Just r) 86 | pred_ = pred 87 | 88 | 89 | -- | Constrained to AttoParsec, Regex-Compat and T.Text 90 | type EitherUrlChunk = PathChunk T.Text 91 | 92 | 93 | -- | Container when defining route paths 94 | type UrlChunks = PathChunks T.Text 95 | 96 | 97 | 98 | -- | Prefix a routable path by more predicative lookup data. 99 | () :: EitherUrlChunk mx -> UrlChunks xs -> UrlChunks (mx ': xs) 100 | () = (./) 101 | 102 | infixr 9 103 | 104 | 105 | 106 | class ToUrlChunks a (xs :: [Maybe *]) | a -> xs where 107 | toUrlChunks :: a -> UrlChunks xs 108 | -------------------------------------------------------------------------------- /src/Web/Routes/Nested/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE 2 | DeriveFunctor 3 | , ConstraintKinds 4 | , TypeFamilies 5 | , FlexibleContexts 6 | , GeneralizedNewtypeDeriving 7 | #-} 8 | 9 | {- | 10 | Module : Web.Routes.Nested.Types 11 | Copyright : (c) 2015, 2016, 2017, 2018 Athan Clark 12 | 13 | License : BSD-style 14 | Maintainer : athan.clark@gmail.com 15 | Stability : experimental 16 | Portability : GHC 17 | -} 18 | 19 | module Web.Routes.Nested.Types 20 | ( -- * Internal Structure 21 | Tries (..) 22 | , -- * Builder 23 | RouterT (..) 24 | , execRouterT 25 | , ActionT 26 | , action 27 | , -- * Book Keeping 28 | ExtrudeSoundly 29 | ) where 30 | 31 | import Web.Routes.Nested.Match (UrlChunks) 32 | import Network.Wai.Middleware.Verbs (VerbListenerT, execVerbListenerT, getVerbFromRequest) 33 | import Network.Wai.Middleware.ContentType (FileExtListenerT, fileExtsToMiddleware) 34 | import Network.Wai.Trans (MiddlewareT) 35 | import Network.Wai (strictRequestBody) 36 | import Data.Trie.Pred.Base (RootedPredTrie (..)) 37 | import Data.Trie.Pred.Interface.Types (Extrude (..), CatMaybes) 38 | 39 | import Data.Monoid ((<>)) 40 | import qualified Data.Text as T 41 | import Data.Function.Poly (ArityTypeListIso) 42 | import Data.Singleton.Class (Extractable) 43 | import qualified Data.HashMap.Lazy as HM 44 | import Control.Monad.Trans (MonadTrans) 45 | import Control.Monad.IO.Class (MonadIO) 46 | import qualified Control.Monad.State as S 47 | import Control.Monad.Trans.Control.Aligned (MonadBaseControl (liftBaseWith)) 48 | 49 | 50 | 51 | -- | The internal data structure built during route declaration. 52 | data Tries x s = Tries 53 | { trieContent :: !(RootedPredTrie T.Text x) 54 | , trieCatchAll :: !(RootedPredTrie T.Text x) 55 | , trieSecurity :: !(RootedPredTrie T.Text s) 56 | } 57 | 58 | 59 | instance Semigroup (Tries x s) where 60 | (Tries x1 x2 x3) <> (Tries y1 y2 y3) = 61 | Tries (x1 <> y1) (x2 <> y2) (x3 <> y3) 62 | 63 | instance Monoid (Tries x s) where 64 | mempty = Tries mempty mempty mempty 65 | 66 | -- | The (syntactic) monad for building a router with functions like 67 | -- "Web.Routes.Nested.match". 68 | -- it should have a shape of @RouterT (MiddlewareT m) (SecurityToken s) m a@ 69 | -- when used with "Web.Routes.Nested.route". 70 | newtype RouterT x sec m a = RouterT 71 | { runRouterT :: S.StateT (Tries x sec) m a 72 | } deriving ( Functor, Applicative, Monad, MonadIO, MonadTrans 73 | , S.MonadState (Tries x sec)) 74 | 75 | -- | Run the monad, only getting the built state and throwing away @a@. 76 | execRouterT :: Monad m => RouterT x sec m a -> m (Tries x sec) 77 | execRouterT hs = S.execStateT (runRouterT hs) mempty 78 | 79 | {-# INLINEABLE execRouterT #-} 80 | 81 | -- | Soundness constraint showing that a function's arity 82 | -- can be represented as a type-level list. 83 | type ExtrudeSoundly xs' xs c r = 84 | ( xs' ~ CatMaybes xs 85 | , ArityTypeListIso c xs' r 86 | , Extrude (UrlChunks xs) 87 | (RootedPredTrie T.Text c) 88 | (RootedPredTrie T.Text r) 89 | ) 90 | 91 | 92 | -- | The type of "content" builders; using the 93 | -- 94 | -- and 95 | -- packages. 96 | type ActionT urlbase m a = VerbListenerT (FileExtListenerT urlbase m a) m a 97 | 98 | -- | Run the content builder into a middleware that responds when the content 99 | -- is satisfiable (i.e. @Accept@ headers are O.K., etc.) 100 | action :: MonadBaseControl IO m stM 101 | => Extractable stM 102 | => ActionT urlbase m () 103 | -> MiddlewareT m 104 | action xs app req respond = do 105 | vmap <- execVerbListenerT xs 106 | case HM.lookup (getVerbFromRequest req) vmap of 107 | Nothing -> app req respond 108 | Just eR -> do 109 | c <- case eR of 110 | Left c' -> pure c' 111 | Right f -> f <$> liftBaseWith (\_ -> strictRequestBody req) 112 | fileExtsToMiddleware c app req respond 113 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # https://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # A warning or info to be displayed to the user on config load. 8 | 9 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 10 | # A snapshot resolver dictates the compiler version and the set of packages 11 | # to be used for project dependencies. For example: 12 | # 13 | # resolver: lts-3.5 14 | # resolver: nightly-2015-09-21 15 | # resolver: ghc-7.10.2 16 | # resolver: ghcjs-0.1.0_ghc-7.10.2 17 | # 18 | # The location of a snapshot can be provided as a file or url. Stack assumes 19 | # a snapshot provided as a file might change, whereas a url resource does not. 20 | # 21 | # resolver: ./custom-snapshot.yaml 22 | # resolver: https://example.com/snapshots/2018-01-01.yaml 23 | resolver: lts-21.12 24 | 25 | # User packages to be built. 26 | # Various formats can be used as shown in the example below. 27 | # 28 | # packages: 29 | # - some-directory 30 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 31 | # - location: 32 | # git: https://github.com/commercialhaskell/stack.git 33 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 34 | # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a 35 | # subdirs: 36 | # - auto-update 37 | # - wai 38 | packages: 39 | - . 40 | # Dependency packages to be pulled from upstream that are not in the resolver 41 | # using the same syntax as the packages field. 42 | # (e.g., acme-missiles-0.3) 43 | extra-deps: 44 | - wai-middleware-content-type-0.7.0 45 | - wai-middleware-verbs-0.4.0.1 46 | # - bytestring-trie-0.2.4.1 47 | - pred-set-0.0.1 48 | - HSet-0.0.2 49 | - rose-trees-0.0.4.4 50 | # - sets-0.0.6.2 51 | # - commutative-0.0.2 52 | - wai-transformers-0.1.0 53 | - urlpath-11.0.0 54 | # - websockets-0.12.4.0 55 | - path-extra-0.3.0 56 | - clay-0.14.0 57 | - attoparsec-uri-0.0.9 58 | - tries-0.0.6.1 59 | - pred-trie-0.6.1 60 | - monad-control-aligned-0.0.2 61 | 62 | # Override default flag values for local packages and extra-deps 63 | # flags: {} 64 | 65 | # Extra package databases containing global packages 66 | # extra-package-dbs: [] 67 | 68 | # Control whether we use the GHC we find on the path 69 | # system-ghc: true 70 | # 71 | # Require a specific version of stack, using version ranges 72 | # require-stack-version: -any # Default 73 | # require-stack-version: ">=1.7" 74 | # 75 | # Override the architecture used by stack, especially useful on Windows 76 | # arch: i386 77 | # arch: x86_64 78 | # 79 | # Extra directories used by stack for building 80 | # extra-include-dirs: [/path/to/dir] 81 | # extra-lib-dirs: [/path/to/dir] 82 | # 83 | # Allow a newer minor version of GHC than the snapshot specifies 84 | # compiler-check: newer-minor 85 | -------------------------------------------------------------------------------- /stack.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/lock_files 5 | 6 | packages: 7 | - completed: 8 | hackage: wai-middleware-content-type-0.7.0@sha256:67b9926c85f4d2a54a247cec44a4f4bea3f9f760a36ca60f8bcac496bd331b12,3113 9 | pantry-tree: 10 | sha256: e681598399c53ae0828dadf3399d5067a521432af43c1844262037fa7644e024 11 | size: 1322 12 | original: 13 | hackage: wai-middleware-content-type-0.7.0 14 | - completed: 15 | hackage: wai-middleware-verbs-0.4.0.1@sha256:dfe39d4a6fd082c53c97e5fba191868f8fd06aee0babc69c1d07819d718e36ab,1455 16 | pantry-tree: 17 | sha256: 9c3333c23c6f7660de4d81b5a5dfdaa6859aedf9dc4069872f349a604319e5b7 18 | size: 288 19 | original: 20 | hackage: wai-middleware-verbs-0.4.0.1 21 | - completed: 22 | hackage: pred-set-0.0.1@sha256:8b445d11aa46194f09adf0c91a9133280587e390a57dd7fe6fef909e33a07ace,788 23 | pantry-tree: 24 | sha256: 5b8b98909bff1abfeff90a1e954bf2b218612fd2afa7087d5284745e0fc9099b 25 | size: 219 26 | original: 27 | hackage: pred-set-0.0.1 28 | - completed: 29 | hackage: HSet-0.0.2@sha256:24f5ce6e45501634d24378f8e358f80dcd5a8e21ce6634e4da610648d85b1e0f,830 30 | pantry-tree: 31 | sha256: 95efca7afaa59941e8ff4d33059e231008a71d4aa4b05fadbdcb8f41e82d71e1 32 | size: 274 33 | original: 34 | hackage: HSet-0.0.2 35 | - completed: 36 | hackage: rose-trees-0.0.4.4@sha256:602b2ed25f1408605132ab00295539bfe93d47ebd1e594e4c44f7389d53dcd74,3392 37 | pantry-tree: 38 | sha256: e9d0d6dc33b07a6ec2d495b3b05d2fbb5e41fb9514a5a4b42049fbfff51ffb14 39 | size: 974 40 | original: 41 | hackage: rose-trees-0.0.4.4 42 | - completed: 43 | hackage: wai-transformers-0.1.0@sha256:82b47d17865904e436b71d497b6b71644ec5ed4169174ff488d1aeeeade31334,1253 44 | pantry-tree: 45 | sha256: 95718554d90b90bf5744d0d80affa8f4be66cc3ea813422efcd9c742e991227e 46 | size: 346 47 | original: 48 | hackage: wai-transformers-0.1.0 49 | - completed: 50 | hackage: urlpath-11.0.0@sha256:dae225c222714c42afffa61bdf9ea5e10b617692bf81b9788d7cb40f35dc1ad2,1353 51 | pantry-tree: 52 | sha256: 0c089ac3801dabe095610f181bdf5f48d8185b67c11a35fa0c21a9895d5e74e1 53 | size: 254 54 | original: 55 | hackage: urlpath-11.0.0 56 | - completed: 57 | hackage: path-extra-0.3.0@sha256:cafa9ff476edfe1ac005f7400de7c2640d5b07aaab89c3a2bbae42d12878f299,1545 58 | pantry-tree: 59 | sha256: 2fac399427c19a8cea6d08ea570b63fc2a660a57289e1a2489b15580f555353b 60 | size: 317 61 | original: 62 | hackage: path-extra-0.3.0 63 | - completed: 64 | hackage: clay-0.14.0@sha256:a50ba73137a39c55e89f24a7792107ec40ba07320b2c5ff7932049845c50ffc9,2204 65 | pantry-tree: 66 | sha256: 602a4a85e67324ad5117c88f73fdd449eedf57e57af292a361619e6144cf3d18 67 | size: 2256 68 | original: 69 | hackage: clay-0.14.0 70 | - completed: 71 | hackage: attoparsec-uri-0.0.9@sha256:fde52f7bbac8d94d443a795395b6c9574226c8d6c66eda892c9ae212d01fa1d9,1741 72 | pantry-tree: 73 | sha256: 6e7392e27e245673314dee0e7aba2f7cdaa8acc19639365629abb2152ef63985 74 | size: 442 75 | original: 76 | hackage: attoparsec-uri-0.0.9 77 | - completed: 78 | hackage: tries-0.0.6.1@sha256:ef04c155b7cae74f868dbd2fba67a3ebe990af6f751e8badf825cbec8351e1db,3105 79 | pantry-tree: 80 | sha256: 783cede5a2694305f5ebbf38d5f7dec33611e7e2374529e00796874acfcb55c9 81 | size: 920 82 | original: 83 | hackage: tries-0.0.6.1 84 | - completed: 85 | hackage: pred-trie-0.6.1@sha256:0676410199bcd5f9a55ee95ca325510254ac962e4c5a80682a7ff6a6f62a7647,2556 86 | pantry-tree: 87 | sha256: e0177df555cfa7793347026f4bd0fee2d5e221c41477d8b61b3bc79d37ba1aa3 88 | size: 724 89 | original: 90 | hackage: pred-trie-0.6.1 91 | - completed: 92 | hackage: monad-control-aligned-0.0.2@sha256:463cb1b6225fb0add887fd16d42be3e7857ab46b8d6e50d4e018335127759d4c,2409 93 | pantry-tree: 94 | sha256: 385d60a80eca8aec5442f6a440436ff5633641b1be20c61543df7d9d7acb95fb 95 | size: 308 96 | original: 97 | hackage: monad-control-aligned-0.0.2 98 | snapshots: 99 | - completed: 100 | sha256: 9313df78f49519315342f4c51ffc5da12659d3735f8ac3c54a1fb98ff874474e 101 | size: 640036 102 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/21/12.yaml 103 | original: lts-21.12 104 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-} 2 | -------------------------------------------------------------------------------- /test/Test.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Spec (spec) 4 | import Test.Tasty (defaultMain) 5 | import Test.Tasty.Hspec (testSpec) 6 | 7 | 8 | main :: IO () 9 | main = do 10 | r <- testSpec "basic" spec 11 | defaultMain r 12 | -------------------------------------------------------------------------------- /test/Web/Routes/NestedSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE 2 | OverloadedStrings 3 | #-} 4 | 5 | module Web.Routes.NestedSpec (spec) where 6 | 7 | import Web.Routes.NestedSpec.Basic (app) 8 | 9 | import Test.Hspec (Spec, describe, it) 10 | import Test.Hspec.Wai (get, shouldRespondWith, with) 11 | 12 | 13 | 14 | spec :: Spec 15 | spec = do 16 | describe "Literal Routes" $ 17 | with (return app) $ do 18 | describe "GET /" $ 19 | it "should respond with 200" $ 20 | get "/" `shouldRespondWith` 21 | 200 22 | describe "GET /foo" $ 23 | it "should respond with 200" $ 24 | get "/foo" `shouldRespondWith` 25 | 200 26 | describe "GET /baz" $ 27 | it "should respond with 200" $ 28 | get "/baz" `shouldRespondWith` 29 | 200 30 | describe "GET /borked" $ 31 | it "should respond with 404" $ 32 | get "/borked" `shouldRespondWith` 33 | 404 34 | describe "Attoparsec Routes" $ 35 | with (return app) $ do 36 | describe "GET /12.34" $ 37 | it "should respond with 200" $ 38 | get "/12.34" `shouldRespondWith` 39 | 200 40 | describe "Regex Routes" $ 41 | with (return app) $ do 42 | describe "GET /athan@emails.com" $ 43 | it "should respond with 200" $ 44 | get "/athan@emails.com" `shouldRespondWith` 45 | 200 46 | describe "Secure Routes" $ 47 | with (return app) $ do 48 | describe "GET /foo/bar" $ 49 | it "should respond with 401" $ 50 | get "/foo/bar" `shouldRespondWith` 51 | 401 52 | 53 | 54 | -------------------------------------------------------------------------------- /test/Web/Routes/NestedSpec/Basic.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE 2 | OverloadedStrings 3 | , ScopedTypeVariables 4 | , FlexibleContexts 5 | , DeriveGeneric 6 | #-} 7 | 8 | 9 | module Web.Routes.NestedSpec.Basic where 10 | 11 | import Web.Routes.Nested (o_, p_, l_, r_, (), match, matchHere, matchGroup, auth, AuthScope (..), textOnly, routeAuth) 12 | import Network.Wai (Middleware, Application, Request) 13 | import Network.Wai.Trans (catchMiddlewareT) 14 | import Network.HTTP.Types (status401, status404, status200) 15 | import Text.Regex (mkRegex) 16 | import Data.Attoparsec.Text (double) 17 | import Control.Monad.Catch (Exception, MonadThrow (throwM)) 18 | import GHC.Generics (Generic) 19 | 20 | 21 | data AuthRole = AuthRole deriving (Show, Eq) 22 | data AuthErr = NeedsAuth deriving (Show, Eq, Generic) 23 | 24 | instance Exception AuthErr 25 | 26 | -- | If you fail here and throw an AuthErr, then the user was not authorized to 27 | -- under the conditions set by @ss :: [AuthRole]@, and based on the authentication 28 | -- of that user's session from the @Request@ object. Note that we could have a 29 | -- shared cache of authenticated sessions, by adding more constraints on @m@ like 30 | -- @MonadIO@. 31 | -- For instance, even if there are [] auth roles, we could still include a header/timestamp 32 | -- pair to uniquely identify the guest. Or, we could equally change @Checksum ~ Maybe Token@, 33 | -- so a guest just returns Nothing, and we could handle the case in @putAuth@ to 34 | -- not do anything. 35 | authorize :: ( MonadThrow m 36 | ) => Request -> [AuthRole] -> m () 37 | -- authorize _ _ = return id -- uncomment to force constant authorization 38 | authorize req ss | null ss = return () 39 | | otherwise = throwM NeedsAuth 40 | 41 | defApp :: Application 42 | defApp _ respond = respond $ 43 | textOnly "404 :(" status404 [] 44 | 45 | successMiddleware :: Middleware 46 | successMiddleware _ _ respond = respond $ textOnly "200!" status200 [] 47 | 48 | app :: Application 49 | app = 50 | let yoDawgIHeardYouLikeYoDawgsYo = 51 | (routeAuth authorize routes) `catchMiddlewareT` unauthHandle 52 | routes = do 53 | matchHere successMiddleware 54 | matchGroup fooRoute $ do 55 | matchHere successMiddleware 56 | auth AuthRole DontProtectHere 57 | match barRoute successMiddleware 58 | match doubleRoute (\_ -> successMiddleware) 59 | match emailRoute (\_ -> successMiddleware) 60 | match bazRoute successMiddleware 61 | in yoDawgIHeardYouLikeYoDawgsYo defApp 62 | where 63 | -- `/foo` 64 | fooRoute = l_ "foo" o_ 65 | 66 | -- `/foo/bar` 67 | barRoute = l_ "bar" o_ 68 | 69 | -- `/foo/1234e12`, uses attoparsec 70 | doubleRoute = p_ "double" double o_ 71 | 72 | -- `/athan@foo.com` 73 | emailRoute = r_ "email" (mkRegex "(^[-a-zA-Z0-9_.]+@[-a-zA-Z0-9]+\\.[-a-zA-Z0-9.]+$)") o_ 74 | 75 | -- `/baz`, uses regex-compat 76 | bazRoute = l_ "baz" o_ 77 | 78 | unauthHandle :: AuthErr -> Middleware 79 | unauthHandle NeedsAuth _ _ respond = respond $ 80 | textOnly "Unauthorized!" status401 [] 81 | --------------------------------------------------------------------------------