]> Git — Sourcephile - haskell/symantic-http.git/blob - symantic-http-server/Symantic/HTTP/Server.hs
server: fix the recursion into Router
[haskell/symantic-http.git] / symantic-http-server / Symantic / HTTP / Server.hs
1 {-# LANGUAGE GADTs #-} -- for 'Router' and 'Router_Union'
2 {-# LANGUAGE ConstraintKinds #-}
3 {-# LANGUAGE DataKinds #-} -- for 'BinTree'
4 {-# LANGUAGE DefaultSignatures #-}
5 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
6 {-# LANGUAGE OverloadedStrings #-}
7 {-# LANGUAGE UndecidableInstances #-} -- for nested type family application,
8 -- eg. in 'BodyStreamConstraint'
9 {-# OPTIONS_GHC -fno-warn-orphans #-}
10 -- | See <https://hackage.haskell.org/package/symantic-http-demo symantic-http-demo>
11 -- for an example of how to use this module.
12 module Symantic.HTTP.Server where
13
14 import Control.Applicative (Applicative(..))
15 import Control.Arrow (first)
16 import Control.Monad (Monad(..), unless, sequence, guard, (=<<))
17 import Control.Monad.Trans.Class (MonadTrans(..))
18 import Control.Monad.Trans.Except (ExceptT(..), runExceptT)
19 import Data.Bool
20 import Data.Either (Either(..))
21 import Data.Eq (Eq(..))
22 import Data.Function (($), (.), id, const)
23 import Data.Functor (Functor(..), (<$>))
24 import Data.Int (Int)
25 import Data.Kind (Type)
26 import Data.Maybe (Maybe(..), fromMaybe, catMaybes)
27 import Data.Monoid (Monoid(..))
28 import Data.Ord (Ord(..))
29 import Data.Proxy (Proxy(..))
30 import Data.Semigroup (Semigroup(..))
31 import Data.String (String, IsString(..))
32 import Data.Text (Text)
33 import System.IO (IO)
34 import Text.Show (Show(..))
35 import qualified Control.Monad.Classes as MC
36 import qualified Control.Monad.Trans.Cont as C
37 import qualified Control.Monad.Trans.Reader as R
38 import qualified Control.Monad.Trans.State.Strict as S
39 import qualified Control.Monad.Trans.Writer.Strict as W
40 import qualified Data.ByteString as BS
41 import qualified Data.ByteString.Base64 as BS64
42 import qualified Data.ByteString.Builder as BSB
43 import qualified Data.ByteString.Lazy as BSL
44 import qualified Data.List as List
45 import qualified Data.List.NonEmpty as NonEmpty
46 import qualified Data.Map.Merge.Strict as Map
47 import qualified Data.Map.Strict as Map
48 import qualified Data.Text as Text
49 import qualified Data.Text.Encoding as Text
50 import qualified Data.Word8 as Word8
51 import qualified Network.HTTP.Media as Media
52 import qualified Network.HTTP.Types as HTTP
53 import qualified Network.HTTP.Types.Header as HTTP
54 import qualified Network.Wai as Wai
55 import qualified Web.HttpApiData as Web
56
57 import Symantic.HTTP
58
59 -- * Type 'Server'
60 -- | (@'Server' handlers k@) is a recipe to produce an 'Wai.Application'
61 -- from given ('handlers') (one per number of alternative routes),
62 -- separated by (':!:').
63 --
64 -- 'Server' is analogous to a scanf using the API as a format customized for HTTP routing.
65 --
66 -- The multiple 'ServerCheckT' monad transformers are there
67 -- to prioritize the errors according to the type of check raising them,
68 -- instead of the order of the combinators within an actual API specification.
69 newtype Server handlers k = Server { unServer ::
70 S.StateT ServerState
71 (ServerCheckT [ServerErrorBody] -- 8th check, 400 error
72 (ServerCheckT [ServerErrorHeader] -- 7th check, 400 error
73 (ServerCheckT [ServerErrorQuery] -- 6th check, 400 error
74 (ServerCheckT [ServerErrorContentType] -- 5th check, 415 error
75 (ServerCheckT [ServerErrorAccept] -- 4th check, 406 error
76 (ServerCheckT [ServerErrorBasicAuth] -- 3rd check, 401 or 403 error
77 (ServerCheckT [ServerErrorMethod] -- 2nd check, 405 error
78 (ServerCheckT [ServerErrorPath] -- 1st check, 404 error
79 IO))))))))
80 (handlers -> k)
81 }
82
83 -- | (@'server' api handlers@) returns an 'Wai.Application'
84 -- ready to be given to @Warp.run 80@.
85 server ::
86 Router Server handlers (Response Server) ->
87 handlers ->
88 Wai.Application
89 server api handlers rq re = do
90 lrPath <- runServerChecks (unServer $ unTrans $ router api) $ ServerState rq
91 case lrPath of
92 Left err -> respondError HTTP.status404 [] err
93 Right lrMethod ->
94 case lrMethod of
95 Left err -> respondError HTTP.status405 [] err
96 Right lrBasicAuth ->
97 case lrBasicAuth of
98 Left err ->
99 case failError err of
100 [] -> respondError HTTP.status500 [] err
101 ServerErrorBasicAuth realm ba:_ ->
102 case ba of
103 BasicAuth_Unauthorized ->
104 respondError HTTP.status403 [] err
105 _ ->
106 respondError HTTP.status401
107 [ ( HTTP.hWWWAuthenticate
108 , "Basic realm=\""<>Web.toHeader realm<>"\""
109 ) ] err
110 Right lrAccept ->
111 case lrAccept of
112 Left err -> respondError HTTP.status406 [] err
113 Right lrContentType ->
114 case lrContentType of
115 Left err -> respondError HTTP.status415 [] err
116 Right lrQuery ->
117 case lrQuery of
118 Left err -> respondError HTTP.status400 [] err
119 Right lrHeader ->
120 case lrHeader of
121 Left err -> respondError HTTP.status400 [] err
122 Right lrBody ->
123 case lrBody of
124 Left err -> respondError HTTP.status400 [] err
125 Right (app, st) ->
126 app handlers (serverState_request st) re
127 where
128 respondError ::
129 Show err =>
130 HTTP.Status ->
131 [(HTTP.HeaderName, HeaderValue)] ->
132 err -> IO Wai.ResponseReceived
133 respondError st hs err =
134 -- Trace.trace (show err) $
135 re $ Wai.responseLBS st
136 ( (HTTP.hContentType, Media.renderHeader $ mediaType @PlainText)
137 : hs
138 ) (fromString $ show err) -- TODO: see what to return in the body
139
140 -- | Unwrap the 'ExceptT' constructors to reach the 'Either' constructors.
141 runServerChecks ::
142 S.StateT ServerState (ExceptT e1 (ExceptT e2 (ExceptT e3 (ExceptT e4 (ExceptT e5 (ExceptT e6 (ExceptT e7 (ExceptT e8 IO)))))))) a ->
143 ServerState -> IO (Either e8 (Either e7 (Either e6 (Either e5 (Either e4 (Either e3 (Either e2 (Either e1 (a, ServerState)))))))))
144 runServerChecks s st =
145 runExceptT $
146 runExceptT $
147 runExceptT $
148 runExceptT $
149 runExceptT $
150 runExceptT $
151 runExceptT $
152 runExceptT $
153 S.runStateT s st
154
155 -- ** Type 'ServerCheckT'
156 type ServerCheckT e = ExceptT (Fail e)
157
158 -- *** Type 'RouteResult'
159 type RouteResult e = Either (Fail e)
160
161 -- *** Type 'Fail'
162 data Fail e
163 = Fail ServerState e -- ^ Keep trying other paths. 404, 405 or 406.
164 | FailFatal !ServerState !e -- ^ Don't try other paths.
165 deriving (Show)
166 failState :: Fail e -> ServerState
167 failState (Fail st _) = st
168 failState (FailFatal st _) = st
169 failError :: Fail e -> e
170 failError (Fail _st e) = e
171 failError (FailFatal _st e) = e
172 instance Semigroup e => Semigroup (Fail e) where
173 Fail _ x <> Fail st y = Fail st (x<>y)
174 FailFatal _ x <> Fail st y = FailFatal st (x{-<>y-})
175 Fail _ x <> FailFatal st y = FailFatal st ({-x<>-}y)
176 FailFatal _ x <> FailFatal st y = FailFatal st (x<>y)
177
178 -- ** Type 'ServerState'
179 newtype ServerState = ServerState
180 { serverState_request :: Wai.Request
181 } -- deriving (Show)
182 instance Show ServerState where
183 show _ = "ServerState"
184
185 instance Cat Server where
186 (<.>) ::
187 forall a b c repr.
188 repr ~ Server =>
189 repr a b -> repr b c -> repr a c
190 -- NOTE: if x fails, run y to see if it fails on a more prioritized check.
191 -- And if so, fail with y instead of x.
192 --
193 -- This long spaghetti code may probably be avoided
194 -- with a more sophisticated 'Server' using a binary tree
195 -- instead of nested 'Either's, so that its 'Monad' instance
196 -- would do the right thing. But to my mind,
197 -- with the very few priorities of checks currently needed,
198 -- this is not worth the cognitive pain to design it.
199 -- Some copying/pasting/adapting will do for now.
200 Server x <.> Server y = Server $
201 S.StateT $ \st -> do
202 xPath <- MC.exec @IO $ runServerChecks x st
203 case xPath of
204 Left xe -> MC.throw xe
205 Right xMethod ->
206 case xMethod of
207 Left xe -> do
208 yPath <- MC.exec @IO $ runServerChecks y (failState xe)
209 case yPath of
210 Left ye -> MC.throw ye
211 Right _yMethod -> MC.throw xe
212 Right xBasicAuth ->
213 case xBasicAuth of
214 Left xe -> do
215 yPath <- MC.exec @IO $ runServerChecks y (failState xe)
216 case yPath of
217 Left ye -> MC.throw ye
218 Right yMethod ->
219 case yMethod of
220 Left ye -> MC.throw ye
221 Right _yBasicAuth -> MC.throw xe
222 Right xAccept ->
223 case xAccept of
224 Left xe -> do
225 yPath <- MC.exec @IO $ runServerChecks y (failState xe)
226 case yPath of
227 Left ye -> MC.throw ye
228 Right yMethod ->
229 case yMethod of
230 Left ye -> MC.throw ye
231 Right yBasicAuth ->
232 case yBasicAuth of
233 Left ye -> MC.throw ye
234 Right _yAccept -> MC.throw xe
235 Right xContentType ->
236 case xContentType of
237 Left xe -> do
238 yPath <- MC.exec @IO $ runServerChecks y (failState xe)
239 case yPath of
240 Left ye -> MC.throw ye
241 Right yMethod ->
242 case yMethod of
243 Left ye -> MC.throw ye
244 Right yBasicAuth ->
245 case yBasicAuth of
246 Left ye -> MC.throw ye
247 Right yAccept ->
248 case yAccept of
249 Left ye -> MC.throw ye
250 Right _yQuery -> MC.throw xe
251 Right xQuery ->
252 case xQuery of
253 Left xe -> do
254 yPath <- MC.exec @IO $ runServerChecks y (failState xe)
255 case yPath of
256 Left ye -> MC.throw ye
257 Right yMethod ->
258 case yMethod of
259 Left ye -> MC.throw ye
260 Right yBasicAuth ->
261 case yBasicAuth of
262 Left ye -> MC.throw ye
263 Right yAccept ->
264 case yAccept of
265 Left ye -> MC.throw ye
266 Right yQuery ->
267 case yQuery of
268 Left ye -> MC.throw ye
269 Right _yHeader -> MC.throw xe
270 Right xHeader ->
271 case xHeader of
272 Left xe -> do
273 yPath <- MC.exec @IO $ runServerChecks y (failState xe)
274 case yPath of
275 Left ye -> MC.throw ye
276 Right yMethod ->
277 case yMethod of
278 Left ye -> MC.throw ye
279 Right yBasicAuth ->
280 case yBasicAuth of
281 Left ye -> MC.throw ye
282 Right yAccept ->
283 case yAccept of
284 Left ye -> MC.throw ye
285 Right yQuery ->
286 case yQuery of
287 Left ye -> MC.throw ye
288 Right yHeader ->
289 case yHeader of
290 Left ye -> MC.throw ye
291 Right _yBody -> MC.throw xe
292 Right xBody ->
293 case xBody of
294 Left xe -> do
295 yPath <- MC.exec @IO $ runServerChecks y (failState xe)
296 case yPath of
297 Left ye -> MC.throw ye
298 Right yMethod ->
299 case yMethod of
300 Left ye -> MC.throw ye
301 Right yBasicAuth ->
302 case yBasicAuth of
303 Left ye -> MC.throw ye
304 Right yAccept ->
305 case yAccept of
306 Left ye -> MC.throw ye
307 Right yQuery ->
308 case yQuery of
309 Left ye -> MC.throw ye
310 Right yHeader ->
311 case yHeader of
312 Left ye -> MC.throw ye
313 Right _yBody -> MC.throw xe
314 Right (a2b, st') ->
315 first (. a2b) <$> S.runStateT y st'
316 instance Alt Server where
317 -- (<!>) :: repr a k -> repr b k -> repr (a:!:b) k
318 Server x <!> Server y = Server $
319 S.StateT $ \st -> do
320 xPath <- MC.exec @IO $ runServerChecks x st
321 let fy = (first (\b2k (_a:!:b) -> b2k b) <$>)
322 case xPath of
323 Left xe | FailFatal{} <- xe -> MC.throw xe
324 | otherwise -> do
325 yPath <- MC.exec @IO $ runServerChecks y st
326 case yPath of
327 Left ye -> MC.throw (xe<>ye)
328 Right yMethod ->
329 fy $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ ExceptT $
330 return $ Right yMethod
331 Right xMethod ->
332 case xMethod of
333 Left xe | FailFatal{} <- xe -> MC.throw xe
334 | otherwise -> do
335 yPath <- MC.exec @IO $ runServerChecks y st
336 case yPath of
337 Left _ye -> MC.throw xe
338 Right yMethod ->
339 case yMethod of
340 Left ye -> MC.throw (xe<>ye)
341 Right yBasicAuth ->
342 fy $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ ExceptT $
343 return $ Right $ yBasicAuth
344 Right xBasicAuth ->
345 case xBasicAuth of
346 Left xe | FailFatal{} <- xe -> MC.throw xe
347 | otherwise -> do
348 yPath <- MC.exec @IO $ runServerChecks y st
349 case yPath of
350 Left _ye -> MC.throw xe
351 Right yMethod ->
352 case yMethod of
353 Left _ye -> MC.throw xe
354 Right yBasicAuth ->
355 case yBasicAuth of
356 Left ye -> MC.throw (xe<>ye)
357 Right yAccept ->
358 fy $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ ExceptT $
359 return $ Right yAccept
360 Right xAccept ->
361 case xAccept of
362 Left xe | FailFatal{} <- xe -> MC.throw xe
363 | otherwise -> do
364 yPath <- MC.exec @IO $ runServerChecks y st
365 case yPath of
366 Left _ye -> MC.throw xe
367 Right yMethod ->
368 case yMethod of
369 Left _ye -> MC.throw xe
370 Right yBasicAuth ->
371 case yBasicAuth of
372 Left _ye -> MC.throw xe
373 Right yAccept ->
374 case yAccept of
375 Left ye -> MC.throw (xe<>ye)
376 Right yContentType ->
377 fy $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ ExceptT $
378 return $ Right yContentType
379 Right xContentType ->
380 case xContentType of
381 Left xe | FailFatal{} <- xe -> MC.throw xe
382 | otherwise -> do
383 yPath <- MC.exec @IO $ runServerChecks y st
384 case yPath of
385 Left _ye -> MC.throw xe
386 Right yMethod ->
387 case yMethod of
388 Left _ye -> MC.throw xe
389 Right yBasicAuth ->
390 case yBasicAuth of
391 Left _ye -> MC.throw xe
392 Right yAccept ->
393 case yAccept of
394 Left _ye -> MC.throw xe
395 Right yContentType ->
396 case yContentType of
397 Left ye -> MC.throw (xe<>ye)
398 Right yQuery ->
399 fy $ ExceptT $ ExceptT $ ExceptT $ ExceptT $
400 return $ Right yQuery
401 Right xQuery ->
402 case xQuery of
403 Left xe | FailFatal{} <- xe -> MC.throw xe
404 | otherwise -> do
405 yPath <- MC.exec @IO $ runServerChecks y st
406 case yPath of
407 Left _ye -> MC.throw xe
408 Right yMethod ->
409 case yMethod of
410 Left _ye -> MC.throw xe
411 Right yBasicAuth ->
412 case yBasicAuth of
413 Left _ye -> MC.throw xe
414 Right yAccept ->
415 case yAccept of
416 Left _ye -> MC.throw xe
417 Right yContentType ->
418 case yContentType of
419 Left _ye -> MC.throw xe
420 Right yQuery ->
421 case yQuery of
422 Left ye -> MC.throw (xe<>ye)
423 Right yHeader ->
424 fy $ ExceptT $ ExceptT $ ExceptT $
425 return $ Right yHeader
426 Right xHeader ->
427 case xHeader of
428 Left xe | FailFatal{} <- xe -> MC.throw xe
429 | otherwise -> do
430 yPath <- MC.exec @IO $ runServerChecks y st
431 case yPath of
432 Left _ye -> MC.throw xe
433 Right yMethod ->
434 case yMethod of
435 Left _ye -> MC.throw xe
436 Right yBasicAuth ->
437 case yBasicAuth of
438 Left _ye -> MC.throw xe
439 Right yAccept ->
440 case yAccept of
441 Left _ye -> MC.throw xe
442 Right yContentType ->
443 case yContentType of
444 Left _ye -> MC.throw xe
445 Right yQuery ->
446 case yQuery of
447 Left _ye -> MC.throw xe
448 Right yHeader ->
449 case yHeader of
450 Left ye -> MC.throw (xe<>ye)
451 Right yBody ->
452 fy $ ExceptT $ ExceptT $
453 return $ Right yBody
454 Right xBody ->
455 case xBody of
456 Left xe | FailFatal{} <- xe -> MC.throw xe
457 | otherwise -> do
458 yPath <- MC.exec @IO $ runServerChecks y st
459 case yPath of
460 Left _ye -> MC.throw xe
461 Right yMethod ->
462 case yMethod of
463 Left _ye -> MC.throw xe
464 Right yBasicAuth ->
465 case yBasicAuth of
466 Left _ye -> MC.throw xe
467 Right yAccept ->
468 case yAccept of
469 Left _ye -> MC.throw xe
470 Right yContentType ->
471 case yContentType of
472 Left _ye -> MC.throw xe
473 Right yQuery ->
474 case yQuery of
475 Left _ye -> MC.throw xe
476 Right yHeader ->
477 case yHeader of
478 Left _ye -> MC.throw xe
479 Right yBody ->
480 case yBody of
481 Left ye -> MC.throw (xe<>ye)
482 Right yr ->
483 fy $ ExceptT $
484 return $ Right yr
485 Right xr ->
486 return $ first (\a2k (a:!:_b) -> a2k a) xr
487 instance Pro Server where
488 dimap a2b _b2a (Server r) = Server $ (\k b2k -> k (b2k . a2b)) <$> r
489
490 -- ** Type 'ServerErrorPath'
491 newtype ServerErrorPath = ServerErrorPath Text
492 deriving (Eq, Show)
493
494 instance HTTP_Path Server where
495 type PathConstraint Server a = Web.FromHttpApiData a
496 segment expSegment = Server $ do
497 st@ServerState
498 { serverState_request = req
499 } <- S.get
500 case Wai.pathInfo req of
501 [] -> MC.throw $ Fail st [ServerErrorPath "empty path segment"]
502 [""] -> MC.throw $ Fail st [ServerErrorPath "trailing slash"]
503 curr:next
504 | curr /= expSegment ->
505 MC.throw $ Fail st [ServerErrorPath $ "expected: "<>expSegment<>" but got: "<>curr]
506 | otherwise -> do
507 S.put st
508 { serverState_request = req{ Wai.pathInfo = next }
509 }
510 return id
511 capture' :: forall a k. PathConstraint Server a => Name -> Server (a -> k) k
512 capture' name = Server $ do
513 st@ServerState
514 { serverState_request = req
515 } <- S.get
516 case Wai.pathInfo req of
517 [] -> MC.throw $ Fail st [ServerErrorPath "empty"]
518 [""] -> MC.throw $ Fail st [ServerErrorPath "trailing slash"]
519 curr:next ->
520 case Web.parseUrlPiece curr of
521 Left err -> MC.throw $ Fail st [ServerErrorPath $ "capture: "<>fromString name<>": "<>err]
522 Right a -> do
523 S.put st
524 { serverState_request = req{ Wai.pathInfo = next }
525 }
526 return ($ a)
527 captureAll = Server $ do
528 req <- S.gets serverState_request
529 return ($ Wai.pathInfo req)
530
531 -- ** Type 'ServerErrorMethod'
532 data ServerErrorMethod = ServerErrorMethod
533 deriving (Eq, Show)
534
535 -- | TODO: add its own error?
536 instance HTTP_Version Server where
537 version exp = Server $ do
538 st <- S.get
539 let got = Wai.httpVersion $ serverState_request st
540 if got == exp
541 then return id
542 else MC.throw $ Fail st [ServerErrorMethod] -- FIXME: ServerErrorVersion
543
544 -- ** Type 'ServerErrorAccept'
545 data ServerErrorAccept =
546 ServerErrorAccept
547 MediaTypes
548 (Maybe (Either BS.ByteString MediaType))
549 deriving (Eq, Show)
550
551 -- ** Type 'ServerErrorContentType'
552 data ServerErrorContentType = ServerErrorContentType
553 deriving (Eq, Show)
554
555 -- ** Type 'ServerErrorQuery'
556 newtype ServerErrorQuery = ServerErrorQuery Text
557 deriving (Show)
558 instance HTTP_Query Server where
559 type QueryConstraint Server a = Web.FromHttpApiData a
560 queryParams' name = Server $ do
561 st <- S.get
562 lift $ ExceptT $ ExceptT $ ExceptT $ return $
563 let qs = Wai.queryString $ serverState_request st in
564 let vals = catMaybes $ (<$> qs) $ \(n,v) ->
565 if n == name
566 then Web.parseQueryParam . Text.decodeUtf8 <$> v
567 else Nothing in
568 case sequence vals of
569 Left err -> Left $ Fail st [ServerErrorQuery err]
570 Right vs -> Right $ Right $ Right ($ vs)
571
572 -- ** Type 'ServerErrorHeader'
573 data ServerErrorHeader = ServerErrorHeader
574 deriving (Eq, Show)
575 instance HTTP_Header Server where
576 header n = Server $ do
577 st <- S.get
578 lift $ ExceptT $ ExceptT $ return $
579 let hs = Wai.requestHeaders $ serverState_request st in
580 case List.lookup n hs of
581 Nothing -> Left $ Fail st [ServerErrorHeader]
582 Just v -> Right $ Right ($ v)
583
584 instance HTTP_Raw Server where
585 type RawConstraint Server = ()
586 type RawArgs Server = Wai.Application
587 type Raw Server = Wai.Application
588 raw = Server $ return id
589
590 -- ** Type 'ServerErrorBasicAuth'
591 data ServerErrorBasicAuth =
592 ServerErrorBasicAuth BasicAuthRealm (BasicAuth ())
593 deriving (Show)
594
595 -- ** Class 'ServerBasicAuth'
596 -- | Custom 'BasicAuth' check.
597 class ServerBasicAuth a where
598 serverBasicAuth ::
599 BasicAuthUser ->
600 BasicAuthPass ->
601 IO (BasicAuth a)
602
603 -- | WARNING: current implementation of Basic Access Authentication
604 -- is not immune to certain kinds of timing attacks.
605 -- Decoding payloads does not take a fixed amount of time.
606 instance HTTP_BasicAuth Server where
607 type BasicAuthConstraint Server a = ServerBasicAuth a
608 type BasicAuthArgs Server a k = a -> k
609 basicAuth' realm = Server $ do
610 st <- S.get
611 let err e = MC.throw $ Fail st [ServerErrorBasicAuth realm e]
612 case decodeAuthorization $ serverState_request st of
613 Nothing -> err BasicAuth_BadPassword
614 Just (user, pass) -> do
615 MC.exec @IO (serverBasicAuth user pass) >>= \case
616 BasicAuth_BadPassword -> err BasicAuth_BadPassword
617 BasicAuth_NoSuchUser -> err BasicAuth_NoSuchUser
618 BasicAuth_Unauthorized -> err BasicAuth_Unauthorized
619 BasicAuth_Authorized u -> return ($ u)
620 where
621 -- | Find and decode an 'Authorization' header from the request as a Basic Auth
622 decodeAuthorization :: Wai.Request -> Maybe (BasicAuthUser, BasicAuthPass)
623 decodeAuthorization req = do
624 hAuthorization <- List.lookup "Authorization" $ Wai.requestHeaders req
625 let (basic, rest) = BS.break Word8.isSpace hAuthorization
626 guard (BS.map Word8.toLower basic == "basic")
627 let decoded = BS64.decodeLenient (BS.dropWhile Word8.isSpace rest)
628 let (user, colon_pass) = BS.break (== Word8._colon) decoded
629 (_, pass) <- BS.uncons colon_pass
630 return (Text.decodeUtf8 user, Text.decodeUtf8 pass)
631
632 -- ** Type 'ServerErrorBody'
633 newtype ServerErrorBody = ServerErrorBody String
634 deriving (Eq, Show)
635
636 -- *** Type 'ServerBodyArg'
637 newtype ServerBodyArg (ts::[Type]) a = ServerBodyArg a
638
639 instance HTTP_Body Server where
640 type BodyConstraint Server a ts = MimeTypes ts (MimeDecodable a)
641 type BodyArg Server a ts = ServerBodyArg ts a
642 body' ::
643 forall a ts k repr.
644 BodyConstraint repr a ts =>
645 repr ~ Server =>
646 repr (BodyArg repr a ts -> k) k
647 body'= Server $ do
648 st <- S.get
649 lift $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ do
650 let hs = Wai.requestHeaders $ serverState_request st
651 let reqContentType =
652 -- DOC: http://www.w3.org/Protocols/rfc2616/rfc2616-sec7.html#sec7.2.1
653 -- DOC: http://www.w3.org/2001/tag/2002/0129-mime
654 fromMaybe "application/octet-stream" $
655 List.lookup HTTP.hContentType hs
656 case matchContent @ts @(MimeDecodable a) reqContentType of
657 Nothing -> return $ Left $ Fail st [ServerErrorContentType]
658 Just (MimeType mt) -> do
659 bodyBS <- MC.exec @IO $ Wai.requestBody $ serverState_request st
660 return $ Right $ Right $ Right $
661 -- NOTE: delay 'mimeDecode' after all checks.
662 case mimeDecode mt $ BSL.fromStrict bodyBS of
663 Left err -> Left $ Fail st [ServerErrorBody err]
664 Right a -> Right ($ ServerBodyArg a)
665
666 -- *** Type 'ServerBodyStreamArg'
667 newtype ServerBodyStreamArg as (ts::[Type]) framing
668 = ServerBodyStreamArg as
669 instance HTTP_BodyStream Server where
670 type BodyStreamConstraint Server as ts framing =
671 ( FramingDecode framing as
672 , MC.MonadExec IO (FramingMonad as)
673 , MimeTypes ts (MimeDecodable (FramingYield as))
674 )
675 type BodyStreamArg Server as ts framing =
676 ServerBodyStreamArg as ts framing
677 bodyStream' ::
678 forall as ts framing k repr.
679 BodyStreamConstraint repr as ts framing =>
680 repr ~ Server =>
681 repr (BodyStreamArg repr as ts framing -> k) k
682 bodyStream'= Server $ do
683 st <- S.get
684 lift $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ do
685 let hs = Wai.requestHeaders $ serverState_request st
686 let reqContentType =
687 -- DOC: http://www.w3.org/Protocols/rfc2616/rfc2616-sec7.html#sec7.2.1
688 -- DOC: http://www.w3.org/2001/tag/2002/0129-mime
689 fromMaybe "application/octet-stream" $
690 List.lookup HTTP.hContentType hs
691 case matchContent @ts @(MimeDecodable (FramingYield as)) reqContentType of
692 Nothing -> return $ Left $ Fail st [ServerErrorContentType]
693 Just (MimeType mt) -> do
694 let bodyBS = Wai.requestBody $ serverState_request st
695 return $ Right $ Right $ Right $
696 Right ($ ServerBodyStreamArg $
697 framingDecode (Proxy @framing) (mimeDecode mt) $
698 MC.exec @IO bodyBS
699 )
700
701 -- * Type 'ServerResponse'
702 -- | A continuation for 'server''s users to respond.
703 --
704 -- This newtype has two uses :
705 --
706 -- * Carrying the 'ts' type variable to 'server'.
707 -- * Providing a 'return' for the simple response case
708 -- of 'HTTP.status200' and no extra headers.
709 newtype ServerRes (ts::[Type]) m a
710 = ServerResponse
711 { unServerResponse :: m a
712 } deriving (Functor, Applicative, Monad)
713 type ServerResponse ts m = ServerRes ts
714 (R.ReaderT Wai.Request
715 (W.WriterT HTTP.ResponseHeaders
716 (W.WriterT HTTP.Status
717 (C.ContT Wai.Response m))))
718 instance MonadTrans (ServerRes ts) where
719 lift = ServerResponse
720 -- | All supported effects are handled by nested 'Monad's.
721 type instance MC.CanDo (ServerResponse ts m) eff = 'False
722 type instance MC.CanDo (C.ContT ts m) (MC.EffExec eff) = 'False
723
724 instance HTTP_Response Server where
725 type ResponseConstraint Server a ts = MimeTypes ts (MimeEncodable a)
726 type ResponseArgs Server a ts = ServerResponse ts IO a
727 type Response Server =
728 Wai.Request ->
729 (Wai.Response -> IO Wai.ResponseReceived) ->
730 IO Wai.ResponseReceived
731 response ::
732 forall a ts repr.
733 ResponseConstraint repr a ts =>
734 repr ~ Server =>
735 HTTP.Method ->
736 repr (ResponseArgs repr a ts)
737 (Response repr)
738 response expMethod = Server $ do
739 st@ServerState
740 { serverState_request = req
741 } <- S.get
742
743 -- Check the path has been fully consumed
744 unless (List.null $ Wai.pathInfo req) $
745 MC.throw $ Fail st [ServerErrorPath "path is longer"]
746
747 -- Check the method
748 let reqMethod = Wai.requestMethod $ serverState_request st
749 unless (reqMethod == expMethod
750 || reqMethod == HTTP.methodHead
751 && expMethod == HTTP.methodGet) $
752 MC.throw $ Fail st [ServerErrorMethod]
753
754 -- Check the Accept header
755 let reqHeaders = Wai.requestHeaders $ serverState_request st
756 MimeType reqAccept <- do
757 case List.lookup HTTP.hAccept reqHeaders of
758 Nothing ->
759 return $ NonEmpty.head $ mimeTypes @ts @(MimeEncodable a)
760 Just h ->
761 case matchAccept @ts @(MimeEncodable a) h of
762 Nothing -> MC.throw $ Fail st [ServerErrorAccept (mediaTypes @ts @(MimeEncodable a)) (Just (Left h))]
763 Just mt -> return mt
764
765 return $ \(ServerResponse k) rq re -> re =<< do
766 C.runContT (W.runWriterT $ W.runWriterT $ R.runReaderT k rq) $ \((a,hs),sta) ->
767 return{-IO-} $
768 Wai.responseLBS sta
769 ((HTTP.hContentType, Media.renderHeader $ mediaTypeFor reqAccept):hs)
770 (if reqMethod == HTTP.methodHead
771 then ""
772 else mimeEncode reqAccept a)
773
774 -- * Type 'ServerResponseStream'
775 --
776 -- This newtype has three uses :
777 --
778 -- * Carrying the 'framing' type variable to 'server'.
779 -- * Carrying the 'ts' type variable to 'server'.
780 -- * Providing a 'return' for the simple response case
781 -- of 'HTTP.status200' and no extra headers.
782 newtype ServerResStream framing (ts::[Type]) m as
783 = ServerResponseStream
784 { unServerResponseStream :: m as
785 } deriving (Functor, Applicative, Monad)
786 instance MonadTrans (ServerResStream framing ts) where
787 lift = ServerResponseStream
788 type ServerResponseStream framing ts m = ServerResStream framing ts
789 (R.ReaderT Wai.Request
790 (W.WriterT HTTP.ResponseHeaders
791 (W.WriterT HTTP.Status
792 (C.ContT Wai.Response m))))
793 -- | All supported effects are handled by nested 'Monad's.
794 type instance MC.CanDo (ServerResponseStream framing ts m) eff = 'False
795
796 instance HTTP_ResponseStream Server where
797 type ResponseStreamConstraint Server as ts framing =
798 ( FramingEncode framing as
799 , MimeTypes ts (MimeEncodable (FramingYield as))
800 )
801 type ResponseStreamArgs Server as ts framing =
802 ServerResponseStream framing ts IO as
803 type ResponseStream Server =
804 Wai.Application
805 {-
806 Wai.Request ->
807 (Wai.Response -> IO Wai.ResponseReceived) ->
808 IO Wai.ResponseReceived
809 -}
810 responseStream ::
811 forall as ts framing repr.
812 ResponseStreamConstraint repr as ts framing =>
813 repr ~ Server =>
814 HTTP.Method ->
815 repr (ResponseStreamArgs repr as ts framing)
816 (ResponseStream repr)
817 responseStream expMethod = Server $ do
818 st@ServerState
819 { serverState_request = req
820 } <- S.get
821
822 -- Check the path has been fully consumed
823 unless (List.null $ Wai.pathInfo req) $
824 MC.throw $ Fail st [ServerErrorPath "path is longer"]
825
826 -- Check the method
827 let reqMethod = Wai.requestMethod $ serverState_request st
828 unless (reqMethod == expMethod
829 || reqMethod == HTTP.methodHead
830 && expMethod == HTTP.methodGet) $
831 MC.throw $ Fail st [ServerErrorMethod]
832
833 -- Check the Accept header
834 let reqHeaders = Wai.requestHeaders $ serverState_request st
835 MimeType reqAccept <- do
836 case List.lookup HTTP.hAccept reqHeaders of
837 Nothing ->
838 return $ NonEmpty.head $ mimeTypes @ts @(MimeEncodable (FramingYield as))
839 Just h ->
840 case matchAccept @ts @(MimeEncodable (FramingYield as)) h of
841 Nothing -> MC.throw $ Fail st [ServerErrorAccept (mediaTypes @ts @(MimeEncodable (FramingYield as))) (Just (Left h))]
842 Just mt -> return mt
843
844 return $ \(ServerResponseStream k) rq re -> re =<< do
845 C.runContT (W.runWriterT $ W.runWriterT $ R.runReaderT k rq) $ \((as,hs),sta) ->
846 return{-IO-} $
847 Wai.responseStream sta
848 ( (HTTP.hContentType, Media.renderHeader $ mediaTypeFor reqAccept)
849 : hs
850 ) $ \write flush ->
851 if reqMethod == HTTP.methodHead
852 then flush
853 else
854 let enc = framingEncode (Proxy @framing) (mimeEncode reqAccept) in
855 let go curr =
856 case curr of
857 Left _end -> flush
858 Right (bsl, next) -> do
859 unless (BSL.null bsl) $ do
860 write (BSB.lazyByteString bsl)
861 flush
862 enc next >>= go
863 in enc as >>= go
864
865 -- | Return worse 'HTTP.Status'.
866 instance Semigroup HTTP.Status where
867 x <> y =
868 if rank (HTTP.statusCode x) < rank (HTTP.statusCode y)
869 then x
870 else y
871 where
872 rank :: Int -> Int
873 rank 404 = 0 -- Not Found
874 rank 405 = 1 -- Method Not Allowed
875 rank 401 = 2 -- Unauthorized
876 rank 415 = 3 -- Unsupported Media Type
877 rank 406 = 4 -- Not Acceptable
878 rank 400 = 5 -- Bad Request
879 rank _ = 6
880 -- | Useful when 'HTTP.Status' is within a 'W.WriterT'.
881 instance Monoid HTTP.Status where
882 mempty = HTTP.status200
883 mappend = (<>)
884
885 -- * Type 'Router'
886 -- | 'Trans'form a 'Server' to merge 'Alt'ernative 'segment's into a 'routing'.
887 data Router repr a b where
888 -- | Lift any @(repr)@ into 'Router', those not useful to segregate
889 -- wrt. the 'Trans'formation performed, aka. 'noTrans'.
890 Router_Any :: repr a b -> Router repr a b
891 -- | Represent 'segment'.
892 Router_Seg :: PathSegment -> Router repr k k
893 -- | Represent ('<.>').
894 Router_Cat :: Router repr a b -> Router repr b c -> Router repr a c
895 -- | Represent 'routing'.
896 Router_Map :: Map.Map PathSegment (Router repr a k) -> Router repr a k
897 -- | Represent ('<!>').
898 Router_Alt :: Router repr a k -> Router repr b k -> Router repr (a:!:b) k
899 -- | Represent 'capture''.
900 Router_Cap :: PathConstraint Server a => Name -> Router repr (a->k) k
901 -- | Represent 'captures'.
902 Router_Caps :: Captures (Router repr) cs k -> Router repr (AltFromBinTree cs) k
903 -- | Unify 'Router's which have different 'handlers'.
904 -- Useful to put alternative 'Router's in a 'Map.Map' as in 'Router_Map'.
905 Router_Union :: (b->a) -> Router repr a k -> Router repr b k
906
907 -- ** Type 'Captures'
908 data Captures repr (cs::BinTree Type) k where
909 Captures0 :: PathConstraint Server a =>
910 Proxy a -> Name -> repr x k ->
911 Captures repr ('BinTree0 (a->x)) k
912 Captures2 :: Captures repr x k ->
913 Captures repr y k ->
914 Captures repr ('BinTree2 x y) k
915
916 -- *** Type 'BinTree'
917 -- | Use @DataKinds@ to define a 'BinTree' of 'Type's.
918 -- Useful for gathering together 'capture's of different 'Type's.
919 data BinTree a
920 = BinTree0 a
921 | BinTree2 (BinTree a) (BinTree a)
922
923 -- *** Type family 'AltFromBinTree'
924 type family AltFromBinTree (cs::BinTree Type) :: Type where
925 AltFromBinTree ('BinTree0 x) = x
926 AltFromBinTree ('BinTree2 x y) = AltFromBinTree x :!: AltFromBinTree y
927
928 instance Trans (Router Server) where
929 type UnTrans (Router Server) = Server
930 noTrans = Router_Any
931 unTrans (Router_Any x) = x
932 unTrans (Router_Seg s) = segment s
933 unTrans (Router_Cat x y) = unTrans x <.> unTrans y
934 unTrans (Router_Alt x y) = unTrans x <!> unTrans y
935 unTrans (Router_Map ms) = routing (unTrans <$> ms)
936 unTrans (Router_Cap n) = capture' n
937 unTrans (Router_Caps xs) = captures $ unTransCaptures xs
938 where
939 unTransCaptures :: Captures (Router Server) cs k -> Captures Server cs k
940 unTransCaptures (Captures0 a n r) = Captures0 a n (unTrans r)
941 unTransCaptures (Captures2 x y) = unTransCaptures x `Captures2` unTransCaptures y
942 unTrans (Router_Union u x) = Server $ (. u) <$> unServer (unTrans x)
943
944 instance Cat (Router Server) where
945 (<.>) = Router_Cat
946 instance Alt (Router Server) where
947 (<!>) = Router_Alt
948 instance repr ~ Server => HTTP_Path (Router repr) where
949 type PathConstraint (Router repr) a = PathConstraint repr a
950 segment = Router_Seg
951 capture' = Router_Cap
952 instance HTTP_Routing (Router Server) where
953 routing = Router_Map
954 captures = Router_Caps
955 instance HTTP_Raw (Router Server)
956 instance Pro (Router Server)
957 instance HTTP_Query (Router Server)
958 instance HTTP_Header (Router Server)
959 instance HTTP_Body (Router Server)
960 instance HTTP_BodyStream (Router Server)
961 instance HTTP_BasicAuth (Router Server)
962 instance HTTP_Response (Router Server)
963 instance HTTP_ResponseStream (Router Server)
964
965 -- ** Class 'HTTP_Routing'
966 class HTTP_Routing repr where
967 routing :: Map.Map PathSegment (repr a k) -> repr a k
968 captures :: Captures repr cs k -> repr (AltFromBinTree cs) k
969 -- Trans defaults
970 default routing ::
971 Trans repr =>
972 HTTP_Routing (UnTrans repr) =>
973 Map.Map PathSegment (repr a k) -> repr a k
974 routing = noTrans . routing . (unTrans <$>)
975 default captures ::
976 Trans repr =>
977 HTTP_Routing (UnTrans repr) =>
978 Captures repr cs k -> repr (AltFromBinTree cs) k
979 captures = noTrans . captures . unTransCaptures
980 where
981 unTransCaptures :: Captures repr cs k -> Captures (UnTrans repr) cs k
982 unTransCaptures (Captures0 a n r) = Captures0 a n (unTrans r)
983 unTransCaptures (Captures2 x y) = Captures2 (unTransCaptures x) (unTransCaptures y)
984
985 instance HTTP_Routing Server where
986 routing ms = Server $ do
987 st@ServerState
988 { serverState_request = req
989 } <- S.get
990 case Wai.pathInfo req of
991 [] -> MC.throw $ Fail st [ServerErrorPath "empty path segment"]
992 [""] -> MC.throw $ Fail st [ServerErrorPath "trailing slash"]
993 curr:next ->
994 case Map.lookup curr ms of
995 Nothing -> MC.throw $ Fail st [ServerErrorPath $ "expected: "<>Text.pack (show (Map.keys ms))<>" but got: "<>curr]
996 Just x -> do
997 S.put st
998 { serverState_request = req{ Wai.pathInfo = next }
999 }
1000 unServer x
1001
1002 captures :: Captures Server cs k -> Server (AltFromBinTree cs) k
1003 captures cs = Server $ do
1004 st@ServerState
1005 { serverState_request = req
1006 } <- S.get
1007 case Wai.pathInfo req of
1008 [] -> MC.throw $ Fail st [ServerErrorPath "empty"]
1009 [""] -> MC.throw $ Fail st [ServerErrorPath "trailing slash"]
1010 currSeg:nextSeg ->
1011 case go cs of
1012 Left errs -> MC.throw $ Fail st
1013 [ServerErrorPath $ "captures: "<>
1014 fromString (List.intercalate "|" ((\(name,err) -> name) <$> errs))]
1015 Right a -> unServer a
1016 where
1017 go :: forall cs k. Captures Server cs k -> Either [(Name,Text)] (Server (AltFromBinTree cs) k)
1018 go (Captures0 (Proxy::Proxy a) name currRepr) =
1019 case Web.parseUrlPiece currSeg of
1020 Left err -> Left [(name,err)]
1021 Right (a::a) ->
1022 Right $ Server $ do
1023 S.put st { serverState_request = req{ Wai.pathInfo = nextSeg } }
1024 (\x2k a2x -> x2k (a2x a)) <$> unServer currRepr
1025 go (Captures2 x y) =
1026 case go x of
1027 Left xe ->
1028 case go y of
1029 Left ye -> Left (xe<>ye)
1030 Right a -> Right $ Server $ (\r2k (_l:!:r) -> r2k r) <$> unServer a
1031 Right a -> Right $ Server $ (\l2k (l:!:_r) -> l2k l) <$> unServer a
1032
1033 -- | Traverse a 'Router' to transform it:
1034 --
1035 -- * Associate 'Router_Cat' to the right.
1036 -- * Replace 'Router_Seg' with 'Router_Map'.
1037 -- * Replace 'Router_Cap' with 'Router_Caps'.
1038 --
1039 -- Used in 'server' on the 'Router' inferred from the given API.
1040 router :: Router repr a b -> Router repr a b
1041 router = {-debug1 "router" $-} \case
1042 x@Router_Any{} -> x
1043 x@Router_Seg{} -> x
1044 Router_Seg x `Router_Cat` y -> Router_Map $ Map.singleton x $ router y
1045 Router_Alt x y -> router x`router_Alt` router y
1046 Router_Map xs -> Router_Map $ router <$> xs
1047 Router_Cap xn `Router_Cat` x -> Router_Caps $ Captures0 Proxy xn x
1048 Router_Cap n -> Router_Cap n
1049 Router_Caps cs -> Router_Caps (go cs)
1050 where
1051 go :: Captures (Router repr) cs k -> Captures (Router repr) cs k
1052 go (Captures0 a n r) = Captures0 a n (router r)
1053 go (Captures2 x y) = Captures2 (go x) (go y)
1054 Router_Cat xy z ->
1055 case xy of
1056 Router_Cat x y ->
1057 -- Associate to the right
1058 Router_Cat (router x) $
1059 Router_Cat (router y) (router z)
1060 _ -> router xy `Router_Cat` router z
1061 Router_Union u x -> Router_Union u (router x)
1062
1063 -- | Merge/reorder alternatives if possible or default to a 'Router_Alt'.
1064 router_Alt ::
1065 Router repr a k ->
1066 Router repr b k ->
1067 Router repr (a:!:b) k
1068 router_Alt = {-debug2 "router_Alt"-} go
1069 where
1070 -- Merge alternative segments together.
1071 go (Router_Seg x `Router_Cat` xt) (Router_Seg y `Router_Cat` yt) =
1072 Map.singleton x (router xt)
1073 `router_Map`
1074 Map.singleton y (router yt)
1075 go (Router_Seg x `Router_Cat` xt) (Router_Map ys) =
1076 Map.singleton x (router xt)
1077 `router_Map` ys
1078 go (Router_Map xs) (Router_Seg y `Router_Cat` yt) =
1079 xs `router_Map`
1080 Map.singleton y (router yt)
1081 go (Router_Map xs) (Router_Map ys) =
1082 xs`router_Map`ys
1083
1084 -- Merge alternative 'capture''s together.
1085 go (Router_Cap xn `Router_Cat` x) (Router_Cap yn `Router_Cat` y) =
1086 Router_Caps $
1087 Captures0 Proxy xn x
1088 `Captures2`
1089 Captures0 Proxy yn y
1090 go (Router_Caps xs) (Router_Caps ys) =
1091 Router_Caps $ xs`Captures2`ys
1092 go (Router_Cap xn `Router_Cat` x) (Router_Caps ys) =
1093 Router_Caps $ Captures0 Proxy xn x `Captures2` ys
1094 go (Router_Caps xs) (Router_Cap yn `Router_Cat` y) =
1095 Router_Caps $ xs `Captures2` Captures0 Proxy yn y
1096
1097 -- Merge left first or right first, depending on which removes 'Router_Alt'.
1098 go x (y`Router_Alt`z) =
1099 case x`router_Alt`y of
1100 Router_Alt x' y' ->
1101 case y'`router_Alt`z of
1102 yz@(Router_Alt _y z') ->
1103 case x'`router_Alt`z' of
1104 Router_Alt{} -> router x'`Router_Alt`yz
1105 xz -> Router_Union (\(a:!:(b:!:c)) -> (a:!:c):!:b) $ xz`router_Alt`y
1106 -- NOTE: prioritize the merged router 'xz' over over the non-mergeable 'y'.
1107 yz -> x'`router_Alt`yz
1108 xy -> Router_Union (\(a:!:(b:!:c)) -> (a:!:b):!:c) $ xy`router_Alt`z
1109 go (x`Router_Alt`y) z =
1110 case y`router_Alt`z of
1111 Router_Alt y' z' ->
1112 case x`router_Alt`y' of
1113 xy@(Router_Alt x' _y) ->
1114 case x'`router_Alt`z' of
1115 Router_Alt{} -> xy`Router_Alt`router z'
1116 xz -> Router_Union (\((a:!:b):!:c) -> (a:!:c):!:b) $ xz`router_Alt`y
1117 -- NOTE: prioritize the merged router 'xz' over the non-mergeable 'y'.
1118 xy -> xy`router_Alt`z'
1119 yz -> Router_Union (\((a:!:b):!:c) -> a:!:(b:!:c)) $ x`router_Alt`yz
1120
1121 -- Merge through 'Router_Union'.
1122 go (Router_Union u x) y = Router_Union (\(a:!:b) -> u a:!:b) (x`router_Alt`y)
1123 go x (Router_Union u y) = Router_Union (\(a:!:b) -> a:!:u b) (x`router_Alt`y)
1124
1125 -- No merging.
1126 go x y = x`Router_Alt`y
1127
1128 router_Map ::
1129 Map.Map PathSegment (Router repr a k) ->
1130 Map.Map PathSegment (Router repr b k) ->
1131 Router repr (a:!:b) k
1132 router_Map xs ys =
1133 -- NOTE: a little bit more complex than required
1134 -- in order to merge 'Router_Union's instead of nesting them,
1135 -- such that 'unTrans' 'Router_Union' applies them all at once.
1136 Router_Map $
1137 Map.merge
1138 (Map.mapMissing $ const $ \case
1139 Router_Union u r -> Router_Union (\(x:!:_y) -> u x) r
1140 r -> Router_Union (\(x:!:_y) -> x) r)
1141 (Map.mapMissing $ const $ \case
1142 Router_Union u r -> Router_Union (\(_x:!:y) -> u y) r
1143 r -> Router_Union (\(_x:!:y) -> y) r)
1144 (Map.zipWithMatched $ const $ \case
1145 Router_Union xu xr -> \case
1146 Router_Union yu yr -> Router_Union (\(x:!:y) -> xu x:!:yu y) $ xr`router_Alt`yr
1147 yr -> Router_Union (\(a:!:b) -> xu a:!:b) $ xr`router_Alt`yr
1148 xr -> \case
1149 Router_Union yu yr -> Router_Union (\(a:!:b) -> a:!:yu b) $ xr`router_Alt`yr
1150 yr -> xr`router_Alt`yr)
1151 xs ys
1152
1153 {-
1154 debug0 :: Show a => String -> a -> a
1155 debug0 n a = Debug.trace (" {"<>n<>": "<>show a) a
1156 debug1 :: Show a => Show b => String -> (a->b) -> (a->b)
1157 debug1 n a2b a = Debug.trace ("} "<>n<>": r: "<>show b) b
1158 where b = a2b $ Debug.trace ("{ "<>n<>": a: "<>show a) a
1159 debug2 :: Show a => Show b => Show c => String -> (a->b->c) -> (a->b->c)
1160 debug2 n a2b2c a b = Debug.trace ("} "<>n<>": r: "<>show c) c
1161 where
1162 b2c = a2b2c $ Debug.trace ("{ "<>n<>": a: "<>show a) a
1163 c = b2c $ Debug.trace (n<>": b: "<>show b) b
1164 -}