symantic-http-server 0.0.0.20190324 → 0.1.1.20190410

raw patch · 2 files changed

+361/−49 lines, 2 filesdep ~base64-bytestringdep ~symantic-httpPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: base64-bytestring, symantic-http

API changes (from Hackage documentation)

Files

• Symantic/HTTP/Server.hs +357/−45
• symantic-http-server.cabal +4/−4

@@ -1,26 +1,28 @@-{-# LANGUAGE GADTs #-}+{-# LANGUAGE GADTs #-} -- for 'Router' and 'RouterUnion' {-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DataKinds #-} -- for 'BinTree'+{-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE UndecidableInstances #-} -- for nested type family application,+                                      -- eg. in 'BodyStreamConstraint' {-# OPTIONS_GHC -fno-warn-orphans #-} -- | See <https://hackage.haskell.org/package/symantic-http-demo symantic-http-demo> -- for an example of how to use this module. module Symantic.HTTP.Server where -import Control.Arrow (first) import Control.Applicative (Applicative(..))+import Control.Arrow (first) import Control.Monad (Monad(..), unless, sequence, guard, (=<<)) import Control.Monad.Trans.Class (MonadTrans(..)) import Control.Monad.Trans.Except (ExceptT(..), runExceptT) import Data.Bool import Data.Either (Either(..)) import Data.Eq (Eq(..))-import Data.Function (($), (.), id)+import Data.Function (($), (.), id, const) import Data.Functor (Functor(..), (<$>)) import Data.Int (Int)+import Data.Kind (Type) import Data.Maybe (Maybe(..), fromMaybe, catMaybes) import Data.Monoid (Monoid(..)) import Data.Ord (Ord(..))@@ -41,6 +43,9 @@ import qualified Data.ByteString.Lazy as BSL import qualified Data.List as List import qualified Data.List.NonEmpty as NonEmpty+import qualified Data.Map.Merge.Strict as Map+import qualified Data.Map.Strict as Map+import qualified Data.Text as Text import qualified Data.Text.Encoding as Text import qualified Data.Word8 as Word8 import qualified Network.HTTP.Media as Media@@ -52,16 +57,16 @@ import Symantic.HTTP  -- * Type 'Server'--- | @'Server' responses k@ is a recipe to produce an 'Wai.Application'--- from arguments 'responses' (one per number of alternative routes),+-- | (@'Server' handlers k@) is a recipe to produce an 'Wai.Application'+-- from given ('handlers') (one per number of alternative routes), -- separated by (':!:'). ----- 'Server' is analogous to a scanf using a format customized for HTTP routing.+-- 'Server' is analogous to a scanf using the API as a format customized for HTTP routing. -- -- The multiple 'ServerCheckT' monad transformers are there -- to prioritize the errors according to the type of check raising them, -- instead of the order of the combinators within an actual API specification.-newtype Server responses k = Server { unServer ::+newtype Server handlers k = Server { unServer :: 	S.StateT ServerState 	 (ServerCheckT [ServerErrorBody]        -- 8th check, 400 error 	 (ServerCheckT [ServerErrorHeader]      -- 7th check, 400 error@@ -72,17 +77,17 @@ 	 (ServerCheckT [ServerErrorMethod]      -- 2nd check, 405 error 	 (ServerCheckT [ServerErrorPath]        -- 1st check, 404 error 	 IO))))))))-	 (responses -> k)- } deriving (Functor)+	 (handlers -> k)+ } --- | @'server' api responses@ returns a 'Wai.Application'+-- | (@'server' api handlers@) returns an 'Wai.Application' -- ready to be given to @Warp.run 80@. server ::- Server responses (Response Server) ->- responses ->+ Router Server handlers (Response Server) ->+ handlers ->  Wai.Application-server (Server api) responses rq re = do-	lrPath <- runServerChecks api $ ServerState rq+server api handlers rq re = do+	lrPath <- runServerChecks (unServer $ unTrans $ router api) $ ServerState rq 	case lrPath of 	 Left err -> respondError HTTP.status404 [] err 	 Right lrMethod ->@@ -117,8 +122,8 @@ 							 Right lrBody -> 								case lrBody of 								 Left err -> respondError HTTP.status400 [] err-								 Right (app, _st) ->-									app responses rq re+								 Right (app, st) ->+									app handlers (serverState_request st) re 	where 	respondError :: 	 Show err =>@@ -173,7 +178,7 @@ -- ** Type 'ServerState' newtype ServerState = ServerState  { serverState_request :: Wai.Request- }+ } -- deriving (Show) instance Show ServerState where 	show _ = "ServerState" @@ -307,16 +312,17 @@ 																 Left ye -> MC.throw ye 																 Right _yBody -> MC.throw xe 										 Right (a2b, st') ->-											(first (. a2b)) <$> S.runStateT y st'+											first (. a2b) <$> S.runStateT y st' instance Alt Server where+	-- (<!>) :: repr a k -> repr b k -> repr (a:!:b) k 	Server x <!> Server y = Server $ 		S.StateT $ \st -> do 			xPath <- MC.exec @IO $ runServerChecks x st-			yPath <- MC.exec @IO $ runServerChecks y st 			let fy = (first (\b2k (_a:!:b) -> b2k b) <$>) 			case xPath of 			 Left xe | FailFatal{} <- xe -> MC.throw xe-			         | otherwise ->+			         | otherwise -> do+				yPath <- MC.exec @IO $ runServerChecks y st 				case yPath of 				 Left ye -> MC.throw (xe<>ye) 				 Right yMethod ->@@ -325,7 +331,8 @@ 			 Right xMethod -> 				case xMethod of 				 Left xe | FailFatal{} <- xe -> MC.throw xe-				         | otherwise ->+				         | otherwise -> do+					yPath <- MC.exec @IO $ runServerChecks y st 					case yPath of 					 Left _ye -> MC.throw xe 					 Right yMethod ->@@ -337,7 +344,8 @@ 				 Right xBasicAuth -> 					case xBasicAuth of 					 Left xe | FailFatal{} <- xe -> MC.throw xe-					         | otherwise ->+					         | otherwise -> do+						yPath <- MC.exec @IO $ runServerChecks y st 						case yPath of 						 Left _ye -> MC.throw xe 						 Right yMethod ->@@ -352,7 +360,8 @@ 					 Right xAccept -> 						case xAccept of 						 Left xe | FailFatal{} <- xe -> MC.throw xe-						         | otherwise ->+						         | otherwise -> do+							yPath <- MC.exec @IO $ runServerChecks y st 							case yPath of 							 Left _ye -> MC.throw xe 							 Right yMethod ->@@ -370,7 +379,8 @@ 						 Right xContentType -> 							case xContentType of 							 Left xe | FailFatal{} <- xe -> MC.throw xe-							         | otherwise ->+							         | otherwise -> do+								yPath <- MC.exec @IO $ runServerChecks y st 								case yPath of 								 Left _ye -> MC.throw xe 								 Right yMethod ->@@ -391,7 +401,8 @@ 							 Right xQuery -> 								case xQuery of 								 Left xe | FailFatal{} <- xe -> MC.throw xe-								         | otherwise ->+								         | otherwise -> do+									yPath <- MC.exec @IO $ runServerChecks y st 									case yPath of 									 Left _ye -> MC.throw xe 									 Right yMethod ->@@ -415,7 +426,8 @@ 								 Right xHeader -> 									case xHeader of 									 Left xe | FailFatal{} <- xe -> MC.throw xe-									         | otherwise ->+									         | otherwise -> do+										yPath <- MC.exec @IO $ runServerChecks y st 										case yPath of 										 Left _ye -> MC.throw xe 										 Right yMethod ->@@ -442,7 +454,8 @@ 									 Right xBody -> 										case xBody of 										 Left xe | FailFatal{} <- xe -> MC.throw xe-										         | otherwise ->+										         | otherwise -> do+											yPath <- MC.exec @IO $ runServerChecks y st 											case yPath of 											 Left _ye -> MC.throw xe 											 Right yMethod ->@@ -477,6 +490,7 @@ -- ** Type 'ServerErrorPath' newtype ServerErrorPath = ServerErrorPath Text  deriving (Eq, Show)+ instance HTTP_Path Server where 	type PathConstraint Server a = Web.FromHttpApiData a 	segment expSegment = Server $ do@@ -567,12 +581,19 @@ 			 Nothing -> Left $ Fail st [ServerErrorHeader] 			 Just v -> Right $ Right ($ v) +instance HTTP_Raw Server where+	type RawConstraint Server = ()+	type RawArgs Server = Wai.Application+	type Raw Server = Wai.Application+	raw = Server $ return id+ -- ** Type 'ServerErrorBasicAuth' data ServerErrorBasicAuth =      ServerErrorBasicAuth BasicAuthRealm (BasicAuth ())  deriving (Show)  -- ** Class 'ServerBasicAuth'+-- | Custom 'BasicAuth' check. class ServerBasicAuth a where 	serverBasicAuth :: 	 BasicAuthUser ->@@ -580,7 +601,7 @@ 	 IO (BasicAuth a)  -- | WARNING: current implementation of Basic Access Authentication--- is not immune to certian kinds of timing attacks.+-- is not immune to certain kinds of timing attacks. -- Decoding payloads does not take a fixed amount of time. instance HTTP_BasicAuth Server where 	type BasicAuthConstraint Server a = ServerBasicAuth a@@ -595,7 +616,7 @@ 			 BasicAuth_BadPassword  -> err BasicAuth_BadPassword 			 BasicAuth_NoSuchUser   -> err BasicAuth_NoSuchUser 			 BasicAuth_Unauthorized -> err BasicAuth_Unauthorized-			 BasicAuth_Authorized a -> return ($ a)+			 BasicAuth_Authorized u -> return ($ u) 		where 		-- | Find and decode an 'Authorization' header from the request as a Basic Auth 		decodeAuthorization :: Wai.Request -> Maybe (BasicAuthUser, BasicAuthPass)@@ -613,7 +634,7 @@  deriving (Eq, Show)  -- *** Type 'ServerBodyArg'-newtype ServerBodyArg (ts::[*]) a = ServerBodyArg a+newtype ServerBodyArg (ts::[Type]) a = ServerBodyArg a  instance HTTP_Body Server where 	type BodyConstraint Server a ts = MimeTypes ts (MimeDecodable a)@@ -637,13 +658,13 @@ 			 Just (MimeType mt) -> do 				bodyBS <- MC.exec @IO $ Wai.requestBody $ serverState_request st 				return $ Right $ Right $ Right $-					-- NOTE: delay 'mimeDecode' after all checks+					-- NOTE: delay 'mimeDecode' after all checks. 					case mimeDecode mt $ BSL.fromStrict bodyBS of 					 Left err -> Left $ Fail st [ServerErrorBody err] 					 Right a -> Right ($ ServerBodyArg a)  -- *** Type 'ServerBodyStreamArg'-newtype ServerBodyStreamArg as (ts::[*]) framing+newtype ServerBodyStreamArg as (ts::[Type]) framing  =      ServerBodyStreamArg as instance HTTP_BodyStream Server where 	type BodyStreamConstraint Server as ts framing =@@ -678,13 +699,14 @@ 					 )  -- * Type 'ServerResponse'--- | A continuation for |server|'s users to respond.+-- | A continuation for 'server''s users to respond. -- -- This newtype has two uses :--- * Carrying the 'ts' type variable to 'server'.--- * Providing a 'return' for the simple response case---   of 'HTTP.status200' and no extra headers.-newtype ServerRes (ts::[*]) m a+--+--   * Carrying the 'ts' type variable to 'server'.+--   * Providing a 'return' for the simple response case+--     of 'HTTP.status200' and no extra headers.+newtype ServerRes (ts::[Type]) m a  =      ServerResponse  {    unServerResponse :: m a  } deriving (Functor, Applicative, Monad)@@ -752,11 +774,12 @@ -- * Type 'ServerResponseStream' -- -- This newtype has three uses :--- * Carrying the 'framing' type variable to 'server'.--- * Carrying the 'ts' type variable to 'server'.--- * Providing a 'return' for the simple response case---   of 'HTTP.status200' and no extra headers.-newtype ServerResStream framing (ts::[*]) m as+--+--   * Carrying the 'framing' type variable to 'server'.+--   * Carrying the 'ts' type variable to 'server'.+--   * Providing a 'return' for the simple response case+--     of 'HTTP.status200' and no extra headers.+newtype ServerResStream framing (ts::[Type]) m as  =      ServerResponseStream  {    unServerResponseStream :: m as  } deriving (Functor, Applicative, Monad)@@ -778,9 +801,12 @@ 	type ResponseStreamArgs Server as ts framing = 	 ServerResponseStream framing ts IO as 	type ResponseStream Server =+	 Wai.Application+	 {- 	 Wai.Request -> 	 (Wai.Response -> IO Wai.ResponseReceived) -> 	 IO Wai.ResponseReceived+	 -} 	responseStream :: 	 forall as ts framing repr. 	 ResponseStreamConstraint repr as ts framing =>@@ -855,3 +881,289 @@ instance Monoid HTTP.Status where 	mempty  = HTTP.status200 	mappend = (<>)++-- * Type 'Router'+-- | 'Trans'form a 'Server' to merge 'Alt'ernative 'segment's into a 'routing'.+data Router repr a b where+ -- | Lift any @(repr)@ into 'Router', those not useful to segregate+ -- wrt. the 'Trans'formation performed, aka. 'noTrans'.+ Router_Any :: repr a b -> Router repr a b+ -- | Represent 'segment'.+ Router_Seg :: PathSegment -> Router repr k k+ -- | Represent ('<.>').+ Router_Cat :: Router repr a b -> Router repr b c -> Router repr a c+ -- | Represent 'routing'.+ Router_Map :: Map.Map PathSegment (Router repr a k) -> Router repr a k+ -- | Represent ('<!>').+ Router_Alt :: Router repr a k -> Router repr b k -> Router repr (a:!:b) k+ -- | Represent 'capture''.+ Router_Cap :: PathConstraint Server a => Name -> Router repr (a->k) k+ -- | Represent 'captures'.+ Router_Caps :: Captures (Router repr) cs k -> Router repr (AltFromBinTree cs) k+ -- | Unify 'Router's which have different 'handlers'.+ -- Useful to put alternative 'Router's in a 'Map.Map' as in 'Router_Map'.+ Router_Union :: (b->a) -> Router repr a k -> Router repr b k++-- ** Type 'Captures'+data Captures repr (cs::BinTree Type) k where+ Captures0 :: PathConstraint Server a =>+              Proxy a -> Name -> repr x k ->+              Captures repr ('BinTree0 (a->x)) k+ Captures2 :: Captures repr x k ->+              Captures repr y k ->+              Captures repr ('BinTree2 x y) k++-- *** Type 'BinTree'+-- | Use @DataKinds@ to define a 'BinTree' of 'Type's.+-- Useful for gathering together 'capture's of different 'Type's.+data BinTree a+ =   BinTree0 a+ |   BinTree2 (BinTree a) (BinTree a)++-- *** Type family 'AltFromBinTree'+type family AltFromBinTree (cs::BinTree Type) :: Type where+ AltFromBinTree ('BinTree0 x)   = x+ AltFromBinTree ('BinTree2 x y) = AltFromBinTree x :!: AltFromBinTree y++instance Trans (Router Server) where+	type UnTrans (Router Server) = Server+	noTrans = Router_Any+	unTrans (Router_Any x)   = x+	unTrans (Router_Seg s)   = segment s+	unTrans (Router_Cat x y) = unTrans x <.> unTrans y+	unTrans (Router_Alt x y) = unTrans x <!> unTrans y+	unTrans (Router_Map ms)  = routing (unTrans <$> ms)+	unTrans (Router_Cap n)   = capture' n+	unTrans (Router_Caps xs) = captures $ unTransCaptures xs+		where+		unTransCaptures :: Captures (Router Server) cs k -> Captures Server cs k+		unTransCaptures (Captures0 a n r) = Captures0 a n (unTrans r)+		unTransCaptures (Captures2 x y)   = unTransCaptures x `Captures2` unTransCaptures y+	unTrans (Router_Union u x) = Server $ (. u) <$> unServer (unTrans x)++instance Cat (Router Server) where+	(<.>) = Router_Cat+instance Alt (Router Server) where+	(<!>) = Router_Alt+instance repr ~ Server => HTTP_Path (Router repr) where+	type PathConstraint (Router repr) a = PathConstraint repr a+	segment  = Router_Seg+	capture' = Router_Cap+instance HTTP_Routing (Router Server) where+	routing  = Router_Map+	captures = Router_Caps+instance HTTP_Raw (Router Server)+instance Pro (Router Server)+instance HTTP_Query (Router Server)+instance HTTP_Header (Router Server)+instance HTTP_Body (Router Server)+instance HTTP_BodyStream (Router Server)+instance HTTP_BasicAuth (Router Server)+instance HTTP_Response (Router Server)+instance HTTP_ResponseStream (Router Server)++-- ** Class 'HTTP_Routing'+class HTTP_Routing repr where+	routing  :: Map.Map PathSegment (repr a k) -> repr a k+	captures :: Captures repr cs k -> repr (AltFromBinTree cs) k+	-- Trans defaults+	default routing ::+	 Trans repr =>+	 HTTP_Routing (UnTrans repr) =>+	 Map.Map PathSegment (repr a k) -> repr a k+	routing = noTrans . routing . (unTrans <$>)+	default captures ::+	 Trans repr =>+	 HTTP_Routing (UnTrans repr) =>+	 Captures repr cs k -> repr (AltFromBinTree cs) k+	captures = noTrans . captures . unTransCaptures+		where+		unTransCaptures :: Captures repr cs k -> Captures (UnTrans repr) cs k+		unTransCaptures (Captures0 a n r) = Captures0 a n (unTrans r)+		unTransCaptures (Captures2 x y)   = Captures2 (unTransCaptures x) (unTransCaptures y)++instance HTTP_Routing Server where+	routing ms = Server $ do+		st@ServerState+		 { serverState_request = req+		 } <- S.get+		case Wai.pathInfo req of+		 []   -> MC.throw $ Fail st [ServerErrorPath "empty path segment"]+		 [""] -> MC.throw $ Fail st [ServerErrorPath "trailing slash"]+		 curr:next ->+			case Map.lookup curr ms of+			 Nothing -> MC.throw $ Fail st [ServerErrorPath $ "expected: "<>Text.pack (show (Map.keys ms))<>" but got: "<>curr]+			 Just x -> do+				S.put st+				 { serverState_request = req{ Wai.pathInfo = next }+				 }+				unServer x+	+	captures :: Captures Server cs k -> Server (AltFromBinTree cs) k+	captures cs = Server $ do+		st@ServerState+		 { serverState_request = req+		 } <- S.get+		case Wai.pathInfo req of+		 []   -> MC.throw $ Fail st [ServerErrorPath "empty"]+		 [""] -> MC.throw $ Fail st [ServerErrorPath "trailing slash"]+		 currSeg:nextSeg ->+			case go cs of+			 Left errs -> MC.throw $ Fail st+				 [ServerErrorPath $ "captures: "<>+					fromString (List.intercalate "|" ((\(name,err) -> name) <$> errs))]+			 Right a -> unServer a+			where+			go :: forall cs k. Captures Server cs k -> Either [(Name,Text)] (Server (AltFromBinTree cs) k)+			go (Captures0 (Proxy::Proxy a) name currRepr) =+				case Web.parseUrlPiece currSeg of+				 Left err -> Left [(name,err)]+				 Right (a::a) ->+					Right $ Server $ do+						S.put st { serverState_request = req{ Wai.pathInfo = nextSeg } }+						(\x2k a2x -> x2k (a2x a)) <$> unServer currRepr+			go (Captures2 x y) =+				case go x of+				 Left xe ->+					case go y of+					 Left ye -> Left (xe<>ye)+					 Right a -> Right $ Server $ (\r2k (_l:!:r) -> r2k r) <$> unServer a+				 Right a   -> Right $ Server $ (\l2k (l:!:_r) -> l2k l) <$> unServer a++-- | Traverse a 'Router' to transform it:+--+--   * Associate 'Router_Cat' to the right.+--   * Replace 'Router_Seg' with 'Router_Map'.+--   * Replace 'Router_Cap' with 'Router_Caps'.+--+-- Used in 'server' on the 'Router' inferred from the given API.+router :: Router repr a b -> Router repr a b+router = {-debug1 "router" $-} \case+ x@Router_Any{} -> x+ x@Router_Seg{} -> x+ Router_Seg x `Router_Cat` y -> Router_Map $ Map.singleton x $ router y+ Router_Alt x y -> x`router_Alt`y+ Router_Map xs -> Router_Map $ router <$> xs+ Router_Cap xn `Router_Cat` x -> Router_Caps $ Captures0 Proxy xn x+ Router_Cap n -> Router_Cap n+ Router_Caps cs -> Router_Caps (go cs)+	where+	go :: Captures (Router repr) cs k -> Captures (Router repr) cs k+	go (Captures0 a n r) = Captures0 a n (router r)+	go (Captures2 x y)   = Captures2 (go x) (go y)+ Router_Cat xy z ->+	case xy of+	 Router_Cat x y ->+		-- Associate to the right+		Router_Cat (router x) $+		Router_Cat (router y) (router z)+	 _ -> router xy `Router_Cat` router z+ Router_Union u x -> Router_Union u (router x)++-- | Merge/reorder alternatives if possible or default to a 'Router_Alt'.+router_Alt ::+ Router repr a k ->+ Router repr b k ->+ Router repr (a:!:b) k+router_Alt = {-debug2 "router_Alt"-} go+	where+	-- Merge alternative segments together.+	go (Router_Seg x `Router_Cat` xt) (Router_Seg y `Router_Cat` yt) =+		Map.singleton x (router xt)+		`router_Map`+		Map.singleton y (router yt)+	go (Router_Seg x `Router_Cat` xt) (Router_Map ys) =+		Map.singleton x (router xt)+		`router_Map` ys+	go (Router_Map xs) (Router_Seg y `Router_Cat` yt) =+		xs `router_Map`+		Map.singleton y (router yt)+	go (Router_Map xs) (Router_Map ys) =+		xs`router_Map`ys+	+	-- Merge alternative 'segment's or alternative 'capture''s together.+	go (Router_Cap xn `Router_Cat` x) (Router_Cap yn `Router_Cat` y) =+		Router_Caps $+			Captures0 Proxy xn x+			`Captures2`+			Captures0 Proxy yn y+	go (Router_Caps xs) (Router_Caps ys) =+		Router_Caps $ xs`Captures2`ys+	go (Router_Cap xn `Router_Cat` x) (Router_Caps ys) =+		Router_Caps $ Captures0 Proxy xn x `Captures2` ys+	go (Router_Caps xs) (Router_Cap yn `Router_Cat` y) =+		Router_Caps $ xs `Captures2` Captures0 Proxy yn y+	+	-- Merge left first or right first, depending on which removes 'Router_Alt'.+	go x (y`Router_Alt`z) =+		case x`router_Alt`y of+		 Router_Alt x' y' ->+			case y'`router_Alt`z of+			 yz@(Router_Alt _y z') ->+				case x'`router_Alt`z' of+				 Router_Alt{} -> router x'`Router_Alt`yz+				 xz -> Router_Union (\(a:!:(b:!:c)) -> (a:!:c):!:b) $ xz`router_Alt`y+					-- NOTE: prioritize the merged router 'xz' over over the non-mergeable 'y'.+			 yz -> x'`router_Alt`yz+		 xy -> Router_Union (\(a:!:(b:!:c)) -> (a:!:b):!:c) $ xy`router_Alt`z+	go (x`Router_Alt`y) z =+		case y`router_Alt`z of+		 Router_Alt y' z' ->+			case x`router_Alt`y' of+			 xy@(Router_Alt x' _y) ->+				case x'`router_Alt`z' of+				 Router_Alt{} -> xy`Router_Alt`router z'+				 xz -> Router_Union (\((a:!:b):!:c) -> (a:!:c):!:b) $ xz`router_Alt`y+					-- NOTE: prioritize the merged router 'xz' over the non-mergeable 'y'.+			 xy -> xy`router_Alt`z'+		 yz -> Router_Union (\((a:!:b):!:c) -> a:!:(b:!:c)) $ x`router_Alt`yz+	+	-- Merge through 'Router_Union'.+	go (Router_Union u x) y = Router_Union (\(a:!:b) -> u a:!:b) (x`router_Alt`y)+	go x (Router_Union u y) = Router_Union (\(a:!:b) -> a:!:u b) (x`router_Alt`y)+	+	-- No merging, but apply 'router' on both alternatives.+	go x y = router x `Router_Alt` router y++router_Map ::+ Map.Map PathSegment (Router repr a k) ->+ Map.Map PathSegment (Router repr b k) ->+ Router repr (a:!:b) k+router_Map xs ys =+	-- NOTE: a little bit more complex than required+	-- in order to merge 'Router_Union's instead of stacking them,+	-- such that 'unTrans' 'Router_Union' applies them all at once.+	Router_Map $+	Map.merge+	 (Map.traverseMissing $ const $ \case+		 Router_Union u r ->+			return $ Router_Union (\(x:!:_y) -> u x) r+		 r -> return $ Router_Union (\(x:!:_y) -> x) r)+	 (Map.traverseMissing $ const $ \case+		 Router_Union u r ->+			return $ Router_Union (\(_x:!:y) -> u y) r+		 r -> return $ Router_Union (\(_x:!:y) -> y) r)+	 (Map.zipWithAMatched $ const $ \case+		 Router_Union xu xr -> \case+			 Router_Union yu yr ->+				return $ Router_Union (\(x:!:y) -> xu x:!:yu y) $ xr`router_Alt`yr+			 yr ->+				return $ Router_Union (\(a:!:b) -> xu a:!:b) $ xr`router_Alt`yr+		 xr -> \case+			 Router_Union yu yr ->+				return $ Router_Union (\(a:!:b) -> a:!:yu b) $ xr`router_Alt`yr+			 yr -> return $ xr`router_Alt`yr)+	 xs ys++{-+debug0 :: Show a => String -> a -> a+debug0 n a = Debug.trace (" {"<>n<>": "<>show a) a+debug1 :: Show a => Show b => String -> (a->b) -> (a->b)+debug1 n a2b a = Debug.trace ("} "<>n<>": r: "<>show b) b+	where b = a2b $ Debug.trace ("{ "<>n<>": a: "<>show a) a+debug2 :: Show a => Show b => Show c => String -> (a->b->c) -> (a->b->c)+debug2 n a2b2c a b = Debug.trace ("} "<>n<>": r: "<>show c) c+	where+	b2c = a2b2c $ Debug.trace ("{ "<>n<>": a: "<>show a) a+	c   = b2c   $ Debug.trace (n<>": b: "<>show b) b+-}

@@ -2,12 +2,12 @@ -- PVP:  +-+------- breaking API changes --       | | +----- non-breaking API additions --       | | | +--- code changes with no API change-version: 0.0.0.20190324+version: 0.1.1.20190410 category: Protocol synopsis: symantic-http applied to the derivation of HTTP servers description:    This library applies <https://hackage.haskell.org/package/symantic-http symantic-http>-  to the building of an HTTP server (request routing and decoding)+  to the building of an HTTP server (request routing and response building)   based upon <https://hackage.haskell.org/package/warp warp>,   .   For learning how to use this library,@@ -60,9 +60,9 @@     -fno-warn-tabs     -- -fhide-source-paths   build-depends:-      symantic-http >= 0.0+      symantic-http >= 0.1.1     , base >= 4.10 && < 5-    , base64-bytestring >= 1.0.0.1+    , base64-bytestring >= 1.0     , bytestring >= 0.10     , containers >= 0.5     , http-api-data >= 0.4