├── .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 | 
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 |
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 |
--------------------------------------------------------------------------------