From 78dbdfb8bbf587f7de056a0e196b805b238c1321 Mon Sep 17 00:00:00 2001
From: Julien Moutinho <julm+symantic-http@autogeree.net>
Date: Tue, 5 Mar 2019 18:53:40 +0000
Subject: [PATCH] Replace megaparsec with a custom parser

This enables to prioritize errors independantly from
the actual sequence of combinators in the API.
---
 Symantic/HTTP.hs           |   2 +-
 Symantic/HTTP/API.hs       | 126 ++++--
 Symantic/HTTP/Client.hs    |  17 +-
 Symantic/HTTP/Command.hs   |  22 +-
 Symantic/HTTP/Layout.hs    |  23 +-
 Symantic/HTTP/Mime.hs      |  12 +
 Symantic/HTTP/Router.hs    | 836 +++++++++++++++++++++++++------------
 symantic-http.cabal        |  14 +-
 test/Hspec/API.hs          |  52 ++-
 test/Hspec/Router/Error.hs | 380 +++--------------
 10 files changed, 787 insertions(+), 697 deletions(-)

diff --git a/Symantic/HTTP.hs b/Symantic/HTTP.hs
index 1d499e2..8b07100 100644
--- a/Symantic/HTTP.hs
+++ b/Symantic/HTTP.hs
@@ -14,5 +14,5 @@ import Symantic.HTTP.Command
 import Symantic.HTTP.Layout
 import Symantic.HTTP.Media
 import Symantic.HTTP.Mime
-import Symantic.HTTP.Router
+import Symantic.HTTP.Router hiding (liftIO)
 import Symantic.HTTP.URI
diff --git a/Symantic/HTTP/API.hs b/Symantic/HTTP/API.hs
index db15273..a822148 100644
--- a/Symantic/HTTP/API.hs
+++ b/Symantic/HTTP/API.hs
@@ -1,5 +1,7 @@
+{-# LANGUAGE DefaultSignatures #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE StrictData #-}
+{-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeOperators #-}
 module Symantic.HTTP.API
@@ -7,8 +9,9 @@ module Symantic.HTTP.API
  ) where
 
 import Data.Bool
+import Prelude (and, pure)
 import Data.Eq (Eq(..))
-import Data.Maybe (Maybe(..))
+-- import Data.Maybe (Maybe(..))
 import Data.Ord (Ord(..))
 import Data.Proxy (Proxy(..))
 import Data.String (String)
@@ -23,15 +26,17 @@ import Symantic.HTTP.Mime
 
 -- * Class 'HTTP_API'
 class
- ( Cat            repr
- , Alt            repr
- , HTTP_Path      repr
- , HTTP_Method    repr
- , HTTP_Header    repr
- , HTTP_Accept    repr
- , HTTP_Query     repr
- , HTTP_Version   repr
- , HTTP_Endpoint  repr
+ ( Cat              repr
+ , Alt              repr
+ -- , Pro              repr
+ , HTTP_Version     repr
+ , HTTP_Path        repr
+ , HTTP_Method      repr
+ , HTTP_Header      repr
+ , HTTP_Accept      repr
+ -- , HTTP_ContentType repr
+ , HTTP_Query  repr
+ , HTTP_Response    repr
  ) => HTTP_API (repr:: * -> * -> *)
 
 -- * Class 'Cat'
@@ -46,7 +51,7 @@ class Alt repr where
 	(<!>) :: repr a b -> repr c d -> repr (a:!:c) (AltMerge repr b d); infixl 3 <!>
 	-}
 	(<!>) :: repr a k -> repr b k -> repr (a:!:b) k; infixl 3 <!>
-	try :: repr k k -> repr k k
+	-- try :: repr k k -> repr k k
 	-- option :: k -> repr k k -> repr k k
 
 -- ** Type ':!:'
@@ -54,18 +59,28 @@ class Alt repr where
 data (:!:) a b = a:!:b
 infixl 3 :!:
 
+-- * Class 'Pro'
+-- | Mainly useful to write a combinator which a specialization of another,
+-- by calling it instead of rewriting its logic.
+-- Because 'a' is asked in a client but given in a server,
+-- both @a->b@ and @b->a@ are used. This is reminiscent of a 'Profunctor'.
+-- Hence the names 'Pro' and 'dimap'.
+class Pro repr where
+	dimap :: (a -> b) -> (b -> a) -> repr (a -> k) k -> repr (b -> k) k
+
 -- * Class 'HTTP_Path'
 class HTTP_Path repr where
 	segment  :: Segment -> repr k k
-	capture' :: Web.FromHttpApiData a =>
-	            Web.ToHttpApiData a =>
-	            Name -> repr (a -> k) k
+	capture' ::
+	 Web.FromHttpApiData a =>
+	 Web.ToHttpApiData a =>
+	 Name -> repr (a -> k) k
 	captureAll :: repr ([Segment] -> k) k
 
 -- | Like |capture'| but with the type variable 'a' first instead or 'repr'
 -- so it can be passed using 'TypeApplications' without adding a '@_' for 'repr'.
 capture ::
- forall a repr k.
+ forall a k repr.
  HTTP_Path repr =>
  Web.FromHttpApiData a =>
  Web.ToHttpApiData a =>
@@ -104,6 +119,26 @@ class HTTP_Header repr where
 	header :: HTTP.HeaderName -> repr (HeaderValue -> k) k
 type HeaderValue = BS.ByteString
 
+-- * Class 'HTTP_Body'
+class HTTP_Body repr where
+	type BodyArg repr :: * -> * -> *
+	body' ::
+	 forall mt a k.
+	 MimeUnserialize mt a =>
+	 MimeSerialize mt a =>
+	 repr (BodyArg repr mt a -> k) k
+
+-- | Like |body'| but with the type variables 'a' and 'mt' first instead or 'repr'
+-- so it can be passed using 'TypeApplications' withs adding a '@_' for 'repr'.
+body ::
+ forall mt a k repr.
+ HTTP_Body repr =>
+ MimeUnserialize mt a =>
+ MimeSerialize mt a =>
+ repr (BodyArg repr mt a -> k) k
+body = body' @repr @mt
+{-# INLINE body #-}
+
 -- * Class 'HTTP_Accept'
 class HTTP_Accept repr where
 	accept :: MediaTypeable mt => Proxy mt -> repr k k
@@ -117,25 +152,30 @@ data AcceptResponse repr a =
  forall mt. MimeSerialize mt a =>
  AcceptResponse (Proxy mt, repr a)
 -}
+-- * Class 'HTTP_Content'
+class HTTP_ContentType repr where
+	contentType :: MediaTypeable mt => Proxy mt -> repr k k
 
 -- * Class 'HTTP_Query'
 class HTTP_Query repr where
-	query' ::
+	queryParams' ::
 	 Web.FromHttpApiData a =>
 	 Web.ToHttpApiData a =>
-	 QueryName -> repr ([Maybe a] -> k) k
+	 QueryName -> repr ([a] -> k) k
 	queryFlag :: QueryName -> repr (Bool -> k) k
+	default queryFlag :: Pro repr => QueryName -> repr (Bool -> k) k
+	queryFlag n = dimap and pure (queryParams' n)
 type QueryName   = BS.ByteString
 type QueryValue  = BS.ByteString
 
-query ::
- forall a repr k.
+queryParams ::
+ forall a k repr.
  HTTP_Query repr =>
  Web.FromHttpApiData a =>
  Web.ToHttpApiData a =>
- QueryName -> repr ([Maybe a] -> k) k
-query = query'
-{-# INLINE query #-}
+ QueryName -> repr ([a] -> k) k
+queryParams = queryParams'
+{-# INLINE queryParams #-}
 
 -- * Class 'HTTP_Version'
 class HTTP_Version repr where
@@ -165,33 +205,37 @@ statusIs = \case
 
 status200 :: HTTP.Status
 status200 = HTTP.mkStatus 200 "Success"
+status400 :: HTTP.Status
+status400 = HTTP.mkStatus 400 "Bad Request"
 status404 :: HTTP.Status
 status404 = HTTP.mkStatus 404 "Not Found"
 status405 :: HTTP.Status
 status405 = HTTP.mkStatus 405 "Method Not Allowed"
 status406 :: HTTP.Status
 status406 = HTTP.mkStatus 406 "Not Acceptable"
-
--- * Class 'HTTP_Endpoint'
-class HTTP_Endpoint repr where
-	type Endpoint repr :: *
-	type EndpointArg repr :: * -> * -> *
-	endpoint' ::
-	 MimeSerialize mt a =>
+status415 :: HTTP.Status
+status415 = HTTP.mkStatus 415 "Unsupported Media Type"
+
+-- * Class 'HTTP_Response'
+class HTTP_Response repr where
+	type Response repr :: *
+	type ResponseArg repr :: * -> * -> *
+	response' ::
 	 MimeUnserialize mt a =>
-	 k ~ Endpoint repr =>
+	 MimeSerialize mt a =>
+	 k ~ Response repr =>
 	 HTTP.Method ->
-	 repr (EndpointArg repr mt a -> k) k
+	 repr (ResponseArg repr mt a -> k) k
 
--- | Like |capture'| but with the type variables 'a' and 'mt' first instead or 'repr'
--- so it can be passed using 'TypeApplications' without adding a '@_' for 'repr'.
-endpoint ::
- forall a mt repr k.
- HTTP_Endpoint repr =>
- MimeSerialize mt a =>
+-- | Like |response'| but with the type variables 'a' and 'mt' first instead or 'repr'
+-- so it can be passed using 'TypeApplications' withs adding a '@_' for 'repr'.
+response ::
+ forall mt a k repr.
+ HTTP_Response repr =>
  MimeUnserialize mt a =>
- k ~ Endpoint repr =>
+ MimeSerialize mt a =>
+ k ~ Response repr =>
  HTTP.Method ->
- repr (EndpointArg repr mt a -> k) k
-endpoint = endpoint'
-{-# INLINE endpoint #-}
+ repr (ResponseArg repr mt a -> k) k
+response = response'
+{-# INLINE response #-}
diff --git a/Symantic/HTTP/Client.hs b/Symantic/HTTP/Client.hs
index 862fa2d..b84197f 100644
--- a/Symantic/HTTP/Client.hs
+++ b/Symantic/HTTP/Client.hs
@@ -78,7 +78,7 @@ client ::
  (ClientRequestType mt a -> ClientRequest) -> Client a
 client req = do
 	clientRes <- doClientRequest $ req ClientRequestType
-	mimeUnserializeResponse (Proxy::Proxy mt) clientRes
+	clientResMimeUnserialize (Proxy::Proxy mt) clientRes
 
 runClient :: ClientEnv -> Client a -> IO (Either ClientError a)
 runClient env (Client c) = E.runExceptT $ R.runReaderT c env
@@ -141,6 +141,8 @@ instance Default ClientRequest where
 	 , clientReqHeaders     = Seq.empty
 	 , clientReqBody        = Nothing
 	 }
+instance Show ClientRequest where
+	show _ = "ClientRequest"
 
 clientRequest :: URI -> ClientRequest -> Client.Request
 clientRequest baseURI req =
@@ -171,7 +173,8 @@ clientRequest baseURI req =
 		 Just (body, typ) -> (body, [(HTTP.hContentType, Media.renderHeader typ)])
 
 setClientRequestBodyLBS :: BSL.ByteString -> MediaType -> ClientRequest -> ClientRequest
-setClientRequestBodyLBS body mt req = req{ clientReqBody = Just (Client.RequestBodyLBS body, mt) }
+setClientRequestBodyLBS body mt req = req{ clientReqBody =
+	Just (Client.RequestBodyLBS body, mt) }
 
 setClientRequestBody :: Client.RequestBody -> MediaType -> ClientRequest -> ClientRequest
 setClientRequestBody body mt req = req{ clientReqBody = Just (body, mt) }
@@ -248,10 +251,10 @@ doClientRequestStreaming clientReq = do
 				Exn.throw $ ClientError_FailureResponse $ clientResponse res{Client.responseBody}
 			k $ clientResponse res
 
-getContentType ::
+clientResContentType ::
  MC.MonadExcept ClientError m =>
  ClientResponse -> m MediaType
-getContentType clientRes =
+clientResContentType clientRes =
 	case List.lookup "Content-Type" $ toList $ clientResHeaders clientRes of
 	 Nothing -> return $ "application"Media.//"octet-stream"
 	 Just mt ->
@@ -259,12 +262,12 @@ getContentType clientRes =
 		 Nothing -> MC.throw $ ClientError_InvalidContentTypeHeader clientRes
 		 Just mt' -> return mt'
 
-mimeUnserializeResponse ::
+clientResMimeUnserialize ::
  MimeUnserialize mt a =>
  MC.MonadExcept ClientError m =>
  Proxy mt -> ClientResponse -> m a
-mimeUnserializeResponse mt clientRes = do
-	mtRes <- getContentType clientRes
+clientResMimeUnserialize mt clientRes = do
+	mtRes <- clientResContentType clientRes
 	unless (any (Media.matches mtRes) $ mediaTypes mt) $
 		MC.throw $ ClientError_UnsupportedContentType mtRes clientRes
 	case mimeUnserialize mt $ clientResBody clientRes of
diff --git a/Symantic/HTTP/Command.hs b/Symantic/HTTP/Command.hs
index 5913f4f..336b162 100644
--- a/Symantic/HTTP/Command.hs
+++ b/Symantic/HTTP/Command.hs
@@ -55,7 +55,9 @@ instance Alt Command where
 		x (\cm -> let n:!:_ = k cm in n) :!:
 		y (\cm -> let _:!:n = k cm in n)
 	-}
-	try = id -- FIXME: see what to do
+	-- try = id -- FIXME: see what to do
+instance Pro Command where
+	dimap _a2b b2a r = Command $ \k -> unCommand r k . b2a
 
 instance HTTP_Path Command where
 	segment s  = Command $ \k -> k $ \req ->
@@ -80,10 +82,10 @@ instance HTTP_Accept Command where
 	accept mt = Command $ \k -> k $ \req ->
 		req{ clientReqAccept = clientReqAccept req Seq.|> mediaType mt }
 instance HTTP_Query Command where
-	query' n = Command $ \k vs -> k $ \req ->
+	queryParams' n = Command $ \k vs -> k $ \req ->
 		req{ clientReqQueryString =
 			clientReqQueryString req <>
-			fromList ((\v -> (n, Text.encodeUtf8 . Web.toQueryParam <$> v)) <$> vs) }
+			fromList ((\v -> (n, Just $ Text.encodeUtf8 $ Web.toQueryParam v)) <$> vs) }
 	queryFlag n = Command $ \k b -> k $ \req ->
 		if b
 		then req{ clientReqQueryString = clientReqQueryString req Seq.|> (n, Nothing) }
@@ -91,18 +93,18 @@ instance HTTP_Query Command where
 instance HTTP_Version Command where
 	version v = Command $ \k -> k $ \req ->
 		req{clientReqHttpVersion = v}
-instance HTTP_Endpoint Command where
-	type Endpoint    Command = ClientRequest
-	type EndpointArg Command = ClientRequestType
-	endpoint' ::
+instance HTTP_Response Command where
+	type Response    Command = ClientRequest
+	type ResponseArg Command = ClientRequestType
+	response' ::
 	 forall repr k mt a.
 	 MimeSerialize mt a =>
 	 MimeUnserialize mt a =>
-	 k ~ Endpoint repr =>
+	 k ~ Response repr =>
 	 repr ~ Command =>
 	 HTTP.Method ->
-	 repr (EndpointArg repr mt a -> k) k
-	endpoint' m = Command $ \k ClientRequestType -> k $ \req ->
+	 repr (ResponseArg repr mt a -> k) k
+	response' m = Command $ \k ClientRequestType -> k $ \req ->
 		req
 		 { clientReqMethod = m
 		 , clientReqAccept = clientReqAccept req Seq.|> mediaType (Proxy::Proxy mt)
diff --git a/Symantic/HTTP/Layout.hs b/Symantic/HTTP/Layout.hs
index 99a3157..37e7a6d 100644
--- a/Symantic/HTTP/Layout.hs
+++ b/Symantic/HTTP/Layout.hs
@@ -60,7 +60,7 @@ data LayoutNode
  |   LayoutNode_CaptureAll
  |   LayoutNode_Header      HTTP.HeaderName
  |   LayoutNode_Headers     HTTP.RequestHeaders
- |   LayoutNode_Query       QueryName
+ |   LayoutNode_QueryParams QueryName
  |   LayoutNode_QueryFlag   QueryName
  |   LayoutNode_QueryString HTTP.Query
  |   LayoutNode_Method      HTTP.Method
@@ -75,7 +75,6 @@ instance Cat Layout where
 instance Alt Layout where
 	Layout x <!> Layout y =
 		Layout [collapseApp x <> collapseApp y]
-	try = id
 instance HTTP_Path Layout where
 	segment    = layoutOfNode . LayoutNode_Segment
 	capture'   = layoutOfNode . LayoutNode_Capture
@@ -87,8 +86,8 @@ instance HTTP_Header Layout where
 instance HTTP_Accept Layout where
 	accept mt = layoutOfNode $ LayoutNode_Accept (mediaType mt)
 instance HTTP_Query Layout where
-	query'    = layoutOfNode . LayoutNode_Query
-	queryFlag = layoutOfNode . LayoutNode_QueryFlag
+	queryParams' = layoutOfNode . LayoutNode_QueryParams
+	queryFlag    = layoutOfNode . LayoutNode_QueryFlag
 instance HTTP_Version Layout where
 	version = layoutOfNode . LayoutNode_Version
 {-
@@ -99,17 +98,17 @@ instance HTTP_Response Layout where
 		) $
 			method me *> accept mt
 -}
-instance HTTP_Endpoint Layout where
-	type Endpoint Layout = ()
-	type EndpointArg Layout = EndpointArgLayout
-	endpoint' ::
+instance HTTP_Response Layout where
+	type Response Layout = ()
+	type ResponseArg Layout = ResponseArgLayout
+	response' ::
 	 forall repr k mt a.
 	 MimeSerialize mt a =>
 	 MimeUnserialize mt a =>
-	 k ~ Endpoint repr =>
+	 k ~ Response repr =>
 	 repr ~ Layout =>
 	 HTTP.Method ->
-	 repr (EndpointArg repr mt a -> k) k
-	endpoint' me = reLayout $ method me <.> accept (Proxy::Proxy mt)
+	 repr (ResponseArg repr mt a -> k) k
+	response' me = reLayout $ method me <.> accept (Proxy::Proxy mt)
 instance HTTP_API Layout
-data EndpointArgLayout mt body = EndpointArgLayout
+data ResponseArgLayout mt body = ResponseArgLayout
diff --git a/Symantic/HTTP/Mime.hs b/Symantic/HTTP/Mime.hs
index 70df2da..f55e437 100644
--- a/Symantic/HTTP/Mime.hs
+++ b/Symantic/HTTP/Mime.hs
@@ -18,6 +18,18 @@ import qualified Data.Text.Lazy.Encoding as TL
 import qualified Web.FormUrlEncoded as Web
 import Symantic.HTTP.Media
 
+{-
+-- * Type 'MimeType'
+data MimeType mt a where
+ MimeType ::
+  forall mt.
+  MimeSerialize mt a =>
+  MimeUnserialize mt a =>
+  MimeType mt a
+
+mimeType :: MediaType -> MimeType mt
+-}
+
 {-
 newtype AcceptHeader = AcceptHeader BS.ByteString
 	deriving (Eq, Show, Read, Typeable, Generic)
diff --git a/Symantic/HTTP/Router.hs b/Symantic/HTTP/Router.hs
index 9e8ec84..bd7919c 100644
--- a/Symantic/HTTP/Router.hs
+++ b/Symantic/HTTP/Router.hs
@@ -1,114 +1,558 @@
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveFunctor #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE InstanceSigs #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE StrictData #-}
 {-# LANGUAGE TypeFamilies #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
 module Symantic.HTTP.Router where
 
-import Control.Applicative (Applicative(..), Alternative(..))
-import Control.Monad (Monad(..), (>=>), forM)
+import Control.Arrow (first)
+import Control.Monad (Monad(..), unless, sequence)
+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.Foldable (toList)
-import Data.Function (($), (.), id, const)
-import Data.Functor (Functor, (<$>), (<$))
-import Data.List.NonEmpty (NonEmpty(..))
-import Data.Maybe (Maybe(..))
-import Data.Ord (Ord(..))
+import Data.Function (($), (.), id)
+import Data.Functor (Functor, (<$>))
+import Data.Int (Int)
+import Data.Maybe (Maybe(..), fromMaybe, catMaybes)
 import Data.Proxy (Proxy(..))
 import Data.Semigroup (Semigroup(..))
-import Data.String (IsString(..))
-import Data.Tuple (fst, snd)
-import Prelude (Num(..), max, undefined)
+import Data.String (String, IsString(..))
+import Data.Text (Text)
+import Prelude ((+))
 import System.IO (IO)
 import Text.Show (Show(..))
-import qualified Control.Monad.Trans.Reader as R
-import qualified Data.ByteString as BS
+import qualified Control.Monad.Classes as MC
+import qualified Control.Monad.Trans.State as S
+import qualified Data.ByteString.Lazy as BSL
 import qualified Data.List as List
-import qualified Data.Set as Set
-import qualified Data.Text as Text
 import qualified Data.Text.Encoding as Text
 import qualified Network.HTTP.Media as Media
 import qualified Network.HTTP.Types as HTTP
 import qualified Network.Wai as Wai
-import qualified Text.Megaparsec as P
 import qualified Web.HttpApiData as Web
 
+import Symantic.HTTP.API
 import Symantic.HTTP.Media
 import Symantic.HTTP.Mime
-import Symantic.HTTP.API
 
--- import Debug.Trace
+{-
+import Debug.Trace
+debug msg x = trace (msg<>": "<>show x) x
+-}
 
--- * Type 'Router'
--- | @Router f k@ is a recipe to produce an 'Wai.Application'
+-- | Convenient alias.
+liftIO :: MC.MonadExec IO m => IO a -> m a
+liftIO = MC.exec
+
+-- * Type 'RouterAPI'
+-- | @RouterAPI f k@ is a recipe to produce an 'Wai.Application'
 -- from handlers 'f' (one per number of alternative routes).
 --
--- 'Router' is analogous to a scanf using a format customized for HTTP routing.
-newtype Router f k = Router { unRouter ::
- f -> R.ReaderT Wai.Request
-               (P.Parsec RouteError RouteTokens)
-               k }
+-- 'RouterAPI' is analogous to a scanf using a format customized for HTTP routing.
+--
+-- The multiple 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 RouterAPI f k = RouterAPI { unRouterAPI ::
+	S.StateT RouterState
+	 (RouterCheckT [RouterErrorBody]          -- 8th check, 400 error
+	 (RouterCheckT [RouterErrorHeader]        -- 7th check, 400 error
+	 (RouterCheckT [RouterErrorQuery]         -- 6th check, 400 error
+	 (RouterCheckT [RouterErrorContentType]   -- 5th check, 415 error
+	 (RouterCheckT [RouterErrorAccept]        -- 4th check, 406 error
+	 (-- TODO: RouterCheckT [RouterErrorAuth] -- 3rd check, 401 error
+	 (RouterCheckT [RouterErrorMethod]        -- 2nd check, 405 error
+	 (RouterCheckT [RouterErrorPath]          -- 1st check, 404 error
+	 IO)))))))) (f -> k) }
  deriving (Functor {-, Applicative, Alternative, Monad, MonadPlus, P.MonadParsec RouteError RouteTokens-})
-instance Applicative (Router f) where
-	pure a = Router $ const $ return a
-	Router ma2b <*> Router mb = Router $ \f -> ma2b f <*> mb f
-instance Monad (Router f) where
-	return = pure
-	Router ma >>= a2mb = Router $ \f ->
-		ma f >>= ($ f) . unRouter . a2mb
+type Offset = Int
+
+runRouterAPI ::
+ S.StateT RouterState (ExceptT e1 (ExceptT e2 (ExceptT e3 (ExceptT e4 (ExceptT e5 (ExceptT e6 (ExceptT e7 IO))))))) a ->
+ RouterState -> IO (Either e7 (Either e6 (Either e5 (Either e4 (Either e3 (Either e2 (Either e1 (a, RouterState))))))))
+runRouterAPI s st =
+	runExceptT $
+	runExceptT $
+	runExceptT $
+	runExceptT $
+	runExceptT $
+	runExceptT $
+	runExceptT $
+	S.runStateT s st
 
+-- ** Type 'RouterCheckT'
+type RouterCheckT e = ExceptT (Fail e)
 
--- | Useful to constrain 'repr' to be 'Router'.
-router :: Router f k -> Router f k
-router = id
+-- *** Type 'RouteResult'
+type RouteResult e = Either (Fail e)
 
--- | Special case where the handler 'f' is 'id'.
--- Useful within a 'Router' to get the return value of another 'Router'.
-inRouter ::
- Router (a -> a) k ->
- R.ReaderT Wai.Request (P.Parsec RouteError RouteTokens) k
-inRouter = (`unRouter` id)
+-- *** Type 'Fail'
+data Fail e
+ =   Fail RouterState e -- ^ Keep trying other paths. 404, 405 or 406.
+ |   FailFatal !RouterState !e -- ^ Don't try other paths.
+ deriving (Show)
+failState :: Fail e -> RouterState
+failState (Fail st _)      = st
+failState (FailFatal st _) = st
+instance Semigroup e => Semigroup (Fail e) where
+	Fail _ x      <> Fail st y      = Fail      st (x<>y)
+	FailFatal _ x <> Fail st y      = FailFatal st (x<>y)
+	Fail _ x      <> FailFatal st y = FailFatal st (x<>y)
+	FailFatal _ x <> FailFatal st y = FailFatal st (x<>y)
 
--- | @'runRouter' rt api@ returns a 'Wai.Application'
+-- ** Type 'RouterState'
+data RouterState = RouterState
+ { routerState_offset  :: Offset
+ , routerState_request :: Wai.Request
+ } -- deriving (Show)
+instance Show RouterState where
+	show _ = "RouterState"
+instance Cat RouterAPI where
+	(<.>) ::
+	 forall a b c repr.
+	 repr ~ RouterAPI =>
+	 repr a b -> repr b c -> repr a c
+	-- NOTE: if x fails, run y to see if it fails on a more prioritized check.
+	-- And if so, fail with y instead of x.
+	-- 
+	-- This long spaghetti code may probably be avoided
+	-- with a more sophisticated RouterAPI using a binary tree
+	-- instead of nested Either, so that its Monad instance
+	-- would do the right thing, but to my mind,
+	-- with the very few priorities of checks currently needed,
+	-- this is currently not worth the cognitive pain to design it.
+	-- A copy/paste/modify will do for now.
+	RouterAPI x <.> RouterAPI y = RouterAPI $
+		S.StateT $ \st -> do
+			xPath <- liftIO $ runRouterAPI x st
+			case xPath of
+			 Left xe -> MC.throw xe
+			 Right xMethod ->
+				case xMethod of
+				 Left xe -> do
+					yPath <- liftIO $ runRouterAPI y (failState xe)
+					case yPath of
+					 Left ye -> MC.throw ye
+					 Right _yMethod -> MC.throw xe
+				 Right xAccept ->
+					case xAccept of
+					 Left xe -> do
+						yPath <- liftIO $ runRouterAPI y (failState xe)
+						case yPath of
+						 Left ye -> MC.throw ye
+						 Right yMethod ->
+							case yMethod of
+							 Left ye -> MC.throw ye
+							 Right _yAccept -> MC.throw xe
+					 Right xContentType ->
+						case xContentType of
+						 Left xe -> do
+							yPath <- liftIO $ runRouterAPI y (failState xe)
+							case yPath of
+							 Left ye -> MC.throw ye
+							 Right yMethod ->
+								case yMethod of
+								 Left ye -> MC.throw ye
+								 Right yAccept ->
+									case yAccept of
+									 Left ye -> MC.throw ye
+									 Right _yQuery -> MC.throw xe
+						 Right xQuery ->
+							case xQuery of
+							 Left xe -> do
+								yPath <- liftIO $ runRouterAPI y (failState xe)
+								case yPath of
+								 Left ye -> MC.throw ye
+								 Right yMethod ->
+									case yMethod of
+									 Left ye -> MC.throw ye
+									 Right yAccept ->
+										case yAccept of
+										 Left ye -> MC.throw ye
+										 Right yQuery ->
+											case yQuery of
+											 Left ye -> MC.throw ye
+											 Right _yHeader -> MC.throw xe
+							 Right xHeader ->
+								case xHeader of
+								 Left xe -> do
+									yPath <- liftIO $ runRouterAPI y (failState xe)
+									case yPath of
+									 Left ye -> MC.throw ye
+									 Right yMethod ->
+										case yMethod of
+										 Left ye -> MC.throw ye
+										 Right yAccept ->
+											case yAccept of
+											 Left ye -> MC.throw ye
+											 Right yQuery ->
+												case yQuery of
+												 Left ye -> MC.throw ye
+												 Right yHeader ->
+													case yHeader of
+													 Left ye -> MC.throw ye
+													 Right _yBody -> MC.throw xe
+								 Right xBody ->
+									case xBody of
+									 Left xe -> do
+										yPath <- liftIO $ runRouterAPI y (failState xe)
+										case yPath of
+										 Left ye -> MC.throw ye
+										 Right yMethod ->
+											case yMethod of
+											 Left ye -> MC.throw ye
+											 Right yAccept ->
+												case yAccept of
+												 Left ye -> MC.throw ye
+												 Right yQuery ->
+													case yQuery of
+													 Left ye -> MC.throw ye
+													 Right yHeader ->
+														case yHeader of
+														 Left ye -> MC.throw ye
+														 Right _yBody -> MC.throw xe
+									 Right (a2b, st') ->
+										(first (. a2b)) <$> S.runStateT y st'
+instance Alt RouterAPI where
+	RouterAPI x <!> RouterAPI y = RouterAPI $
+		S.StateT $ \st -> do
+			xPath <- liftIO $ runRouterAPI x st
+			yPath <- liftIO $ runRouterAPI y st
+			let fy = (first (\b2k (_a:!:b) -> b2k b) <$>)
+			case xPath of
+			 Left xe | FailFatal{} <- xe -> MC.throw xe
+			         | otherwise ->
+				case yPath of
+				 Left ye -> MC.throw (xe<>ye)
+				 Right yMethod ->
+					fy $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ ExceptT $
+						return $ Right yMethod
+			 Right xMethod ->
+				case xMethod of
+				 Left xe | FailFatal{} <- xe -> MC.throw xe
+				         | otherwise ->
+					case yPath of
+					 Left _ye -> MC.throw xe
+					 Right yMethod ->
+						case yMethod of
+						 Left ye -> MC.throw (xe<>ye)
+						 Right yAccept ->
+							fy $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ ExceptT $
+								return $ Right $ yAccept
+				 Right xAccept ->
+					case xAccept of
+					 Left xe | FailFatal{} <- xe -> MC.throw xe
+					         | otherwise ->
+						case yPath of
+						 Left _ye -> MC.throw xe
+						 Right yMethod ->
+							case yMethod of
+							 Left _ye -> MC.throw xe
+							 Right yAccept ->
+								case yAccept of
+								 Left ye -> MC.throw (xe<>ye)
+								 Right yContentType ->
+									fy $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ ExceptT $
+										return $ Right yContentType
+					 Right xContentType ->
+						case xContentType of
+						 Left xe | FailFatal{} <- xe -> MC.throw xe
+						         | otherwise ->
+							case yPath of
+							 Left _ye -> MC.throw xe
+							 Right yMethod ->
+								case yMethod of
+								 Left _ye -> MC.throw xe
+								 Right yAccept ->
+									case yAccept of
+									 Left _ye -> MC.throw xe
+									 Right yContentType ->
+										case yContentType of
+										 Left ye -> MC.throw (xe<>ye)
+										 Right yQuery ->
+											fy $ ExceptT $ ExceptT $ ExceptT $ ExceptT $
+												return $ Right yQuery
+						 Right xQuery ->
+							case xQuery of
+							 Left xe | FailFatal{} <- xe -> MC.throw xe
+							         | otherwise ->
+								case yPath of
+								 Left _ye -> MC.throw xe
+								 Right yMethod ->
+									case yMethod of
+									 Left _ye -> MC.throw xe
+									 Right yAccept ->
+										case yAccept of
+										 Left _ye -> MC.throw xe
+										 Right yContentType ->
+											case yContentType of
+											 Left _ye -> MC.throw xe
+											 Right yQuery ->
+												case yQuery of
+												 Left ye -> MC.throw (xe<>ye)
+												 Right yHeader ->
+													fy $ ExceptT $ ExceptT $ ExceptT $
+														return $ Right yHeader
+							 Right xHeader ->
+								case xHeader of
+								 Left xe | FailFatal{} <- xe -> MC.throw xe
+								         | otherwise ->
+									case yPath of
+									 Left _ye -> MC.throw xe
+									 Right yMethod ->
+										case yMethod of
+										 Left _ye -> MC.throw xe
+										 Right yAccept ->
+											case yAccept of
+											 Left _ye -> MC.throw xe
+											 Right yContentType ->
+												case yContentType of
+												 Left _ye -> MC.throw xe
+												 Right yQuery ->
+													case yQuery of
+													 Left _ye -> MC.throw xe
+													 Right yHeader ->
+														case yHeader of
+														 Left ye -> MC.throw (xe<>ye)
+														 Right yBody ->
+															fy $ ExceptT $ ExceptT $
+																return $ Right yBody
+								 Right xBody ->
+									case xBody of
+									 Left xe | FailFatal{} <- xe -> MC.throw xe
+									         | otherwise ->
+										case yPath of
+										 Left _ye -> MC.throw xe
+										 Right yMethod ->
+											case yMethod of
+											 Left _ye -> MC.throw xe
+											 Right yAccept ->
+												case yAccept of
+												 Left _ye -> MC.throw xe
+												 Right yContentType ->
+													case yContentType of
+													 Left _ye -> MC.throw xe
+													 Right yQuery ->
+														case yQuery of
+														 Left _ye -> MC.throw xe
+														 Right yHeader ->
+															case yHeader of
+															 Left _ye -> MC.throw xe
+															 Right yBody ->
+																case yBody of
+																 Left ye -> MC.throw (xe<>ye)
+																 Right yr ->
+																	fy $ ExceptT $
+																		return $ Right yr
+									 Right xr ->
+										return $ first (\a2k (a:!:_b) -> a2k a) xr
+
+instance Pro RouterAPI where
+	dimap a2b _b2a (RouterAPI r) = RouterAPI $ (\k b2k -> k (b2k . a2b)) <$> r
+
+-- | @'routerAPI' rt api@ returns a 'Wai.Application'
 -- ready to be given to @Warp.run 80@.
-runRouter :: Router api RouterResponse -> api -> Wai.Application
-runRouter (Router rt) api rq re =
-	let p = R.runReaderT (rt api) rq in
-	let r = RouteToken_Segment <$> Wai.pathInfo rq in
-	case P.runParser (p <* P.eof) "<Request>" r of
-	 Right (RouterResponse app) -> app rq re
-	 Left errs ->
-		-- trace (show rq) $
-		case P.bundleErrors errs of
-		 err:|_ ->
-			re $ Wai.responseLBS
-			 (case err of
-			  P.FancyError _o es | P.ErrorCustom e:_ <- toList es ->
-				case e of
-				 RouteError_Query_param{} -> status405
-				 RouteError_Accept_unsupported{} -> status406
-				 _ -> status404
-			  _ -> status404)
-			 [(HTTP.hContentType, Media.renderHeader $ mediaType mimePlainText)]
-			 (fromString $ P.errorBundlePretty errs)
+routerAPI ::
+ RouterAPI handlers RouterResponse ->
+ handlers ->
+ Wai.Application
+routerAPI (RouterAPI api) handlers rq re = do
+	lrPath <- liftIO $ runRouterAPI api (RouterState 0 rq)
+	case lrPath of
+	 Left err -> respondError status404 err
+	 Right lrMethod ->
+		case lrMethod of
+		 Left err -> respondError status405 err
+		 Right lrAccept ->
+			case lrAccept of
+			 Left err -> respondError status406 err
+			 Right lrContentType ->
+				case lrContentType of
+				 Left err -> respondError status415 err
+				 Right lrQuery ->
+					case lrQuery of
+					 Left err -> respondError status400 err
+					 Right lrHeader ->
+						case lrHeader of
+						 Left err -> respondError status400 err
+						 Right lrBody ->
+							case lrBody of
+							 Left err -> respondError status400 err
+							 Right (a2k, _st) ->
+								let RouterResponse app = a2k handlers in app rq re
+	where
+	respondError :: Show err => HTTP.Status -> err -> IO Wai.ResponseReceived
+	respondError st err =
+		re $ Wai.responseLBS st
+		 [(HTTP.hContentType, Media.renderHeader $ mediaType mimePlainText)]
+		 (fromString $ show err)
+
+-- ** Type 'RouterErrorPath'
+data RouterErrorPath = RouterErrorPath Offset Text
+ deriving (Eq, Show)
+instance HTTP_Path RouterAPI where
+	segment expSegment = RouterAPI $ do
+		st@RouterState
+		 { routerState_offset  = o
+		 , routerState_request = req
+		 } <- S.get
+		case Wai.pathInfo req of
+		 [] -> MC.throw $ Fail st [RouterErrorPath o "segment: empty"]
+		 [""] -> MC.throw $ Fail st [RouterErrorPath o "trailing slash"]
+		 curr:next
+		  | curr /= expSegment ->
+			MC.throw $ Fail st [RouterErrorPath o $ "expected: "<>expSegment<>" but got: "<>curr]
+		  | otherwise -> do
+			S.put st
+			 { routerState_offset  = o+1
+			 , routerState_request = req{ Wai.pathInfo = next }
+			 }
+			return id
+	capture' :: forall a k.
+	            Web.FromHttpApiData a =>
+	            Web.ToHttpApiData a =>
+	            Name -> RouterAPI (a -> k) k
+	capture' name = RouterAPI $ do
+		st@RouterState
+		 { routerState_offset  = o
+		 , routerState_request = req
+		 } <- S.get
+		case Wai.pathInfo req of
+		 [] -> MC.throw $ Fail st [RouterErrorPath o "empty"]
+		 [""] -> MC.throw $ Fail st [RouterErrorPath o "trailing slash"]
+		 curr:next ->
+			case Web.parseUrlPiece curr of
+			 Left err -> MC.throw $ Fail st [RouterErrorPath o $ "capture: "<>fromString name<>": "<>err]
+			 Right a -> do
+				S.put st
+				 { routerState_offset  = o+1
+				 , routerState_request = req{ Wai.pathInfo = next }
+				 }
+				return ($ a)
+	captureAll = RouterAPI $ do
+		req <- S.gets routerState_request
+		return ($ Wai.pathInfo req)
+
+-- ** Type 'RouterErrorMethod'
+data RouterErrorMethod = RouterErrorMethod
+ deriving (Eq, Show)
+instance HTTP_Method RouterAPI where
+	method exp = RouterAPI $ do
+		st <- S.get
+		let got = Wai.requestMethod $ routerState_request st
+		if  got == exp
+		 || got == HTTP.methodHead
+		 && exp == HTTP.methodGet
+		then return id
+		else MC.throw $ Fail st [RouterErrorMethod]
+
+-- | TODO: add its own error?
+instance HTTP_Version RouterAPI where
+	version exp = RouterAPI $ do
+		st <- S.get
+		let got = Wai.httpVersion $ routerState_request st
+		if got == exp
+		 then return id
+		 else MC.throw $ Fail st [RouterErrorMethod] -- FIXME: RouterErrorVersion
+
+-- ** Type 'RouterErrorAccept'
+data RouterErrorAccept = RouterErrorAccept
+ deriving (Eq, Show)
+instance HTTP_Accept RouterAPI where
+	accept exp = RouterAPI $ do
+		st <- S.get
+		let hs = Wai.requestHeaders $ routerState_request st
+		case List.lookup HTTP.hAccept hs of
+		 Nothing -> MC.throw $ Fail st [RouterErrorAccept]
+		 Just h ->
+			case Media.parseAccept h of
+			 Nothing -> MC.throw $ Fail st [RouterErrorAccept]
+			 Just got | mediaType exp`Media.matches`got -> return id
+			          | otherwise -> MC.throw $ Fail st [RouterErrorAccept]
+
+-- ** Type 'RouterErrorContentType'
+data RouterErrorContentType = RouterErrorContentType
+ deriving (Eq, Show)
+instance HTTP_ContentType RouterAPI where
+	contentType exp = RouterAPI $ do
+		st <- S.get
+		let hs = Wai.requestHeaders $ routerState_request st
+		let got =
+			-- DOC: http://www.w3.org/Protocols/rfc2616/rfc2616-sec7.html#sec7.2.1
+			-- DOC: http://www.w3.org/2001/tag/2002/0129-mime
+			fromMaybe "application/octet-stream" $
+			List.lookup HTTP.hContentType hs
+		case Media.mapContentMedia [(mediaType exp, ())] got of
+		 Nothing -> MC.throw $ Fail st [RouterErrorContentType]
+		 Just () -> return id -- TODO: mimeUnserialize
 
--- ** Type 'RouteError'
-data RouteError
- =   RouteError_Accept_unsupported {-expected-}MediaType {-got-}HeaderValue
- |   RouteError_Query_param_not_a_boolean QueryName [Maybe BS.ByteString]
- |   RouteError_Query_param QueryName (Maybe BS.ByteString)
- |   RouteError_HttpApiData Text.Text
- deriving (Eq, Ord, Show)
-instance P.ShowErrorComponent RouteError where
-	showErrorComponent = show
+-- ** Type 'RouterErrorQuery'
+newtype RouterErrorQuery = RouterErrorQuery Text
+ deriving (Show)
+instance HTTP_Query RouterAPI where
+	queryParams' name = RouterAPI $ do
+		st <- S.get
+		lift $ ExceptT $ ExceptT $ ExceptT $ return $
+			let qs = Wai.queryString $ routerState_request st in
+			let vals = catMaybes $ (<$> qs) $ \(n,v) ->
+				if n == name
+				 then Web.parseQueryParam . Text.decodeUtf8 <$> v
+				 else Nothing in
+			case sequence vals of
+			 Left err -> Left  $ Fail st [RouterErrorQuery err]
+			 Right vs -> Right $ Right $ Right ($ vs)
 
--- ** Type 'RoutingResult'
-type RoutingResult = Either RoutingError
-type RoutingError = P.ParseErrorBundle RouteTokens RouteError
+-- ** Type 'RouterErrorHeader'
+data RouterErrorHeader = RouterErrorHeader
+ deriving (Eq, Show)
+instance HTTP_Header RouterAPI where
+	header n = RouterAPI $ do
+		st <- S.get
+		lift $ ExceptT $ ExceptT $ return $
+			let hs = Wai.requestHeaders $ routerState_request st in
+			case List.lookup n hs of
+			 Nothing -> Left $ Fail st [RouterErrorHeader]
+			 Just v -> Right $ Right ($ v)
+
+-- ** Type 'RouterErrorBody'
+newtype RouterErrorBody = RouterErrorBody String
+ deriving (Eq, Show)
+-- *** Type 'RouterBodyArg'
+newtype RouterBodyArg mt a = RouterBodyArg a
+
+instance HTTP_Body RouterAPI where
+	type BodyArg RouterAPI = RouterBodyArg
+	body' ::
+	 forall mt a k repr.
+	 MimeUnserialize mt a =>
+	 MimeSerialize mt a =>
+	 repr ~ RouterAPI =>
+	 repr (BodyArg repr mt a -> k) k
+	body'= RouterAPI $ do
+		st <- S.get
+		lift $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ do
+			let hs = Wai.requestHeaders $ routerState_request st
+			let expContentType = (Proxy::Proxy mt)
+			let reqContentType =
+				-- DOC: http://www.w3.org/Protocols/rfc2616/rfc2616-sec7.html#sec7.2.1
+				-- DOC: http://www.w3.org/2001/tag/2002/0129-mime
+				fromMaybe "application/octet-stream" $
+				List.lookup HTTP.hContentType hs
+			case Media.mapContentMedia
+			 [ ( mediaType       expContentType
+			   , mimeUnserialize expContentType )
+			 ] reqContentType of
+			 Nothing -> return $ Left $ Fail st [RouterErrorContentType]
+			 Just unSerialize -> do
+				bodyBS <- liftIO $ Wai.requestBody $ routerState_request st
+				return $ Right $ Right $ Right $
+					-- NOTE: delay unSerialize after all checks
+					case unSerialize $ BSL.fromStrict bodyBS of
+					 Left err -> Left $ Fail st [RouterErrorBody err]
+					 Right a -> Right ($ RouterBodyArg a)
 
 -- ** Type 'RouterResponse'
 newtype RouterResponse = RouterResponse
@@ -118,209 +562,49 @@ newtype RouterResponse = RouterResponse
    (Wai.Response -> IO Wai.ResponseReceived) ->
    IO Wai.ResponseReceived
  )
+instance Show RouterResponse where
+	show _ = "RouterResponse"
 
--- * Type 'RouteTokens'
-type RouteTokens = [RouteToken]
-instance P.Stream RouteTokens where
-	type Token  RouteTokens = RouteToken
-	type Tokens RouteTokens = RouteTokens
-	take1_ = List.uncons
-	takeN_ n s | n <= 0 = Just ([], s)
-	           | List.null s = Nothing
-	           | otherwise = Just (List.splitAt n s)
-	takeWhile_ = List.span
-	tokenToChunk _ps = pure
-	tokensToChunk _ps = id
-	chunkToTokens _ps = id
-	chunkLength _ps = List.length
-	chunkEmpty _ps = List.null
-	showTokens _s toks = List.intercalate ", " $ toList $ show <$> toks
-	reachOffset o pos@P.PosState{..} =
-		( spos
-		, List.head $ (show <$> inp)<>["End"]
-		, pos
-		 { P.pstateInput     = inp
-		 , P.pstateOffset    = max o pstateOffset
-		 , P.pstateSourcePos = spos
-		 })
-		where
-		d    = o - pstateOffset
-		inp  = List.drop d pstateInput
-		line | d == 0    = P.sourceLine pstateSourcePos
-		     | otherwise = P.sourceLine pstateSourcePos <> P.mkPos d
-		spos = pstateSourcePos{P.sourceLine = line}
-instance P.Stream Path where
-	type Token  Path = Segment
-	type Tokens Path = [Segment]
-	take1_ = List.uncons
-	takeN_ n s | n <= 0 = Just ([], s)
-	           | List.null s = Nothing
-	           | otherwise = Just (List.splitAt n s)
-	takeWhile_ = List.span
-	tokenToChunk _ps = pure
-	tokensToChunk _ps = id
-	chunkToTokens _ps = id
-	chunkLength _ps = List.length
-	chunkEmpty _ps = List.null
-	showTokens _s toks = List.intercalate ", " $ toList $ Text.unpack <$> toks
-	reachOffset o pos@P.PosState{..} =
-		( spos
-		, List.head $ (show <$> inp)<>["End"]
-		, pos
-		 { P.pstateInput     = inp
-		 , P.pstateOffset    = max o pstateOffset
-		 , P.pstateSourcePos = spos
-		 }
-		)
-		where
-		d    = o - pstateOffset
-		inp  = List.drop d pstateInput
-		spos = pstateSourcePos{P.sourceLine = P.sourceLine pstateSourcePos <> P.mkPos d}
-
--- ** Type 'RouteToken'
-data RouteToken
- =   RouteToken_Segment     Segment
- |   RouteToken_Header      HTTP.HeaderName
- |   RouteToken_Headers     HTTP.RequestHeaders
- |   RouteToken_Query       QueryName
- |   RouteToken_QueryString HTTP.Query
- |   RouteToken_Method      HTTP.Method
- |   RouteToken_Version     HTTP.HttpVersion
- deriving (Eq, Ord, Show)
-
-unRouteToken_Segment :: RouteToken -> Segment
-unRouteToken_Segment (RouteToken_Segment x) = x
-unRouteToken_Segment _ = undefined
-
-instance Cat Router where
-	Router x <.> Router y = Router $ x >=> y
-instance Alt Router where
-	Router x <!> Router y = Router $ \(b:!:c) ->
-		P.try (x b) <|> y c
-	{-
-	type AltMerge Router = Either
-	Router x <!> Router y = Router $ \(b:!:c) ->
-		P.try (Left <$> x b)
-		<|> (Right <$> y c)
-	-}
-	try (Router r) = Router (P.try <$> r)
-instance HTTP_Path Router where
-	segment s  = Router $ \f -> f <$ P.single (RouteToken_Segment s)
-	capture' _n = Router $ \f -> do
-		ret <- unRouteToken_Segment <$> P.anySingle
-		case Web.parseUrlPiece ret of
-		 Right ok -> return (f ok)
-		 Left err -> P.fancyFailure $ Set.singleton $
-			P.ErrorCustom $ RouteError_HttpApiData err
-	captureAll = Router $ \f -> f <$> P.many (unRouteToken_Segment <$> P.anySingle)
-instance HTTP_Method Router where
-	method exp = Router $ \f -> do
-		got <- R.asks Wai.requestMethod
-		inp <- P.getInput
-		P.setInput [RouteToken_Method got]
-		(`P.token` Set.singleton (P.Tokens $ pure $ RouteToken_Method exp)) $ \_tok ->
-			if got == exp
-			 then Just ()
-			 else Nothing
-		P.setInput inp
-		return f
-instance HTTP_Header Router where
-	header exp = Router $ \f -> do
-		got <- R.asks Wai.requestHeaders
-		inp <- P.getInput
-		P.setInput [RouteToken_Headers got]
-		ret <- (`P.token` Set.singleton (P.Tokens $ pure $ RouteToken_Header exp)) $ \_tok ->
-			List.lookup exp got
-		P.setInput inp
-		return (f ret)
-instance HTTP_Accept Router where
-	accept exp = Router $ \f -> do
-		hdr <- inRouter $ header HTTP.hAccept
-		case Media.parseAccept hdr of
-		 Just got | mediaType exp`Media.matches`got -> return f
-		 _ -> P.fancyFailure $ Set.singleton $
-			P.ErrorCustom $ RouteError_Accept_unsupported (mediaType exp) hdr
-instance HTTP_Query Router where
-	query' name = Router $ \f -> do
-		got <- R.asks Wai.queryString
-		inp <- P.getInput
-		P.setInput [RouteToken_QueryString got]
-		vals <- (`P.token` Set.singleton (P.Tokens $ pure $ RouteToken_Query name)) $ \_tok ->
-			case List.filter ((== name) . fst) got of
-			 [] -> Nothing
-			 hs -> Just $ snd <$> hs
-		P.setInput inp
-		ret <- forM vals $ \mayVal ->
-			case mayVal of
-			 Nothing -> return Nothing
-			 Just val ->
-				case Web.parseQueryParam $ Text.decodeUtf8 val of
-				 Right ret -> return (Just ret)
-				 Left err -> P.fancyFailure $ Set.singleton $
-					P.ErrorCustom $ RouteError_Query_param name mayVal
-		return (f ret)
-	{-
-	queryFlag n = Router $ \f -> do
-		vs <- inRouter $ query' n
-		f <$> case vs of
-		 [] -> return True
-		 [Nothing] -> return True
-		 [Just "0"] -> return False
-		 [Just "false"] -> return False
-		 [Just "1"] -> return True
-		 [Just "true"] -> return True
-		 _ -> P.fancyFailure $ Set.singleton $
-			P.ErrorCustom $ RouteError_Query_param_not_a_boolean n vs
-	-}
-instance HTTP_Version Router where
-	version exp = Router $ \f -> do
-		got <- R.asks Wai.httpVersion
-		inp <- P.getInput
-		P.setInput [RouteToken_Version got]
-		(`P.token` Set.singleton (P.Tokens $ pure $ RouteToken_Version exp)) $ \_tok ->
-			if got == exp
-			 then Just ()
-			 else Nothing
-		P.setInput inp
-		return f
--- ** Type 'RouterEndpointArg'
-newtype RouterEndpointArg mt a = RouterEndpointArg
+-- *** Type 'RouterResponseArg'
+newtype RouterResponseArg mt a = RouterResponseArg
  (HTTP.Status ->
   HTTP.ResponseHeaders ->
   a -> Wai.Response)
-instance HTTP_Endpoint Router where
-	type Endpoint Router = RouterResponse
-	type EndpointArg Router = RouterEndpointArg
-	endpoint' ::
-	 forall repr k mt a.
-	 MimeSerialize mt a =>
+
+instance HTTP_Response RouterAPI where
+	type Response    RouterAPI = RouterResponse
+	type ResponseArg RouterAPI = RouterResponseArg
+	response' ::
+	 forall mt a k repr.
 	 MimeUnserialize mt a =>
-	 k ~ Endpoint repr =>
-	 repr ~ Router =>
+	 MimeSerialize mt a =>
+	 k ~ Response repr =>
+	 repr ~ RouterAPI =>
 	 HTTP.Method ->
-	 repr (EndpointArg repr mt a -> k) k
-	endpoint' expMethod = Router $ \f -> do
-		meth <-
-			if expMethod == HTTP.methodGet
-			then
-				-- (unEither <$>) $
-				(`unRouter` (HTTP.methodHead:!:HTTP.methodGet)) $
-				method HTTP.methodHead <!> method HTTP.methodGet
-			else (`unRouter` expMethod) $ method expMethod
-		hAccept <- (`unRouter` (id:!:id)) $ header HTTP.hAccept <!> pure "*/*"
-		let mt = mediaType (Proxy::Proxy mt)
-		case Media.parseAccept hAccept of
-		 Just reqAccept | mt`Media.matches`reqAccept ->
-			return $ f $ RouterEndpointArg $ \st hs a ->
-				Wai.responseLBS st
-				 ((HTTP.hContentType, Media.renderHeader mt):hs)
-				 (if meth == HTTP.methodHead then "" else mimeSerialize (Proxy::Proxy mt) a)
-		 _ -> P.fancyFailure $ Set.singleton $
-			P.ErrorCustom $ RouteError_Accept_unsupported mt hAccept
-instance HTTP_API Router
-
-{-
-unEither :: Either a a -> a
-unEither (Left a) = a
-unEither (Right a) = a
--}
+	 repr (ResponseArg repr mt a -> k) k
+	response' expMethod = RouterAPI $ do
+		st <- S.get
+		let reqMethod = Wai.requestMethod $ routerState_request st
+		unless (reqMethod == expMethod
+		 || reqMethod == HTTP.methodHead
+		 && expMethod == HTTP.methodGet) $
+			MC.throw $ Fail st [RouterErrorMethod]
+		
+		let reqHeaders = Wai.requestHeaders $ routerState_request st
+		let expAccept = (Proxy::Proxy mt)
+		reqAccept <- do
+			case List.lookup HTTP.hAccept reqHeaders of
+			 Nothing -> MC.throw $ Fail st [RouterErrorAccept]
+			 Just h ->
+				case Media.parseAccept h of
+				 Nothing -> MC.throw $ Fail st [RouterErrorAccept]
+				 Just got | mediaType expAccept`Media.matches`got ->
+					return expAccept -- FIXME: return got, maybe with GADTs
+				          | otherwise -> MC.throw $ Fail st [RouterErrorAccept]
+		
+		return ($ RouterResponseArg $ \s hs a ->
+			Wai.responseLBS s
+			 ((HTTP.hContentType, Media.renderHeader $ mediaType reqAccept):hs)
+			 (if reqMethod == HTTP.methodHead
+				then ""
+				else mimeSerialize reqAccept a))
diff --git a/symantic-http.cabal b/symantic-http.cabal
index fbefc84..bf0c7a2 100644
--- a/symantic-http.cabal
+++ b/symantic-http.cabal
@@ -2,10 +2,12 @@ name: symantic-http
 -- PVP:  +-+------- breaking API changes
 --       | | +----- non-breaking API additions
 --       | | | +--- code changes with no API change
-version: 0.0.0.20190223
+version: 0.0.0.20190305
 category: Protocol
-synopsis: Library for reading, validating and writing a subset of the HTTP format.
-description: Symantics for an approximative implementation of HTTP.
+synopsis: Symantic combinators for deriving HTTP clients, servers and docs from an API.
+description: An experimental library trying to be as powerful
+             as [servant](https://hackage.haskell.org/package/servant),
+             but using symantics instead of an advanced type-level DSL.
 extra-doc-files:
 license: GPL-3
 license-file: COPYING
@@ -36,6 +38,7 @@ Library
     Symantic.HTTP.Media
     Symantic.HTTP.Mime
     Symantic.HTTP.Router
+    -- Symantic.HTTP.Server
     Symantic.HTTP.URI
   default-language: Haskell2010
   default-extensions:
@@ -66,10 +69,9 @@ Library
     , http-client >= 0.5.12
     , http-types >= 0.12
     , http-media >= 0.7
-    , megaparsec >= 7.0.4
     , monad-classes >= 0.3.2
     , network-uri >= 2.6
-    -- , resourcet >= 1.1.11
+    , resourcet >= 1.1.11
     -- , safe >= 0.3
     , stm >= 2.4.5
     , text >= 1.2
@@ -119,12 +121,12 @@ Test-Suite symantic-http-test
     , containers >= 0.5
     , deepseq >= 1.4
     , filepath >= 1.4
+    , hspec
     , hspec-wai >= 0.9
     , http-api-data >= 0.4
     , http-client >= 0.5.12
     , http-media >= 0.7
     , http-types >= 0.12
-    , hspec
     , megaparsec >= 6.3
     , network-uri >= 2.6
     , tasty >= 0.11
diff --git a/test/Hspec/API.hs b/test/Hspec/API.hs
index 919133b..d336c23 100644
--- a/test/Hspec/API.hs
+++ b/test/Hspec/API.hs
@@ -72,23 +72,23 @@ cliEnv = clientEnv <$> manager <*> pure baseURI
 api1
  =   segment "time"
  <.> capture @Time.TimeZone "timezone"
- <.> endpoint @TL.Text @PlainText HTTP.methodGet
+ <.> response @PlainText @TL.Text HTTP.methodGet
  
  <!> segment "date"
- <.> endpoint @TL.Text @PlainText HTTP.methodGet
+ <.> response @PlainText @TL.Text HTTP.methodGet
  
  <!> segment "echo"
  <.> captureAll
- <.> endpoint @TL.Text @PlainText HTTP.methodGet
+ <.> response @PlainText @TL.Text HTTP.methodGet
  
  <!> segment "succ"
  <.> capture @Int "n"
- <.> endpoint @Int @PlainText HTTP.methodGet
+ <.> response @PlainText @Int HTTP.methodGet
  
  <!>
  segment "info"
- <.> (  endpoint @TL.Text @PlainText HTTP.methodHead
-    <!> endpoint @TL.Text @PlainText HTTP.methodGet
+ <.> (  response @PlainText @TL.Text HTTP.methodHead
+    <!> response @PlainText @TL.Text HTTP.methodGet
      )
 instance MimeSerialize PlainText () where
 	mimeSerialize _mt = fromString . show
@@ -115,40 +115,40 @@ lay1 = layout api1
  api1_info
  ) = runCommand api1
 
-rou1 = runRouter api1 $
+rou1 = routerAPI api1 $
 	route_time :!:
 	route_date :!:
 	route_echo :!:
 	route_succ :!:
 	route_info
 	where
-	route_time tz (RouterEndpointArg respond) =
+	route_time tz (RouterResponseArg respond) =
 		RouterResponse $ \_req res -> do
 			time <- Time.utcToZonedTime tz <$> Time.getCurrentTime
 			res $ respond status200 [] $
 				TL.pack $ show time <> "\n"
 	
-	route_date (RouterEndpointArg respond) =
+	route_date (RouterResponseArg respond) =
 		RouterResponse $ \_req res -> do
 			date <- Time.utctDay <$> Time.getCurrentTime
 			res $ respond status200 [] $
 				TL.pack $ show date <> "\n"
 	
-	route_echo path (RouterEndpointArg respond) =
+	route_echo path (RouterResponseArg respond) =
 		RouterResponse $ \_req res -> do
 			res $ respond status200 [] $ TL.pack $ show path <> "\n"
 	
-	route_succ n (RouterEndpointArg respond) =
+	route_succ n (RouterResponseArg respond) =
 		RouterResponse $ \_req res -> do
 			res $ respond status200 [] $ n+1
 	
 	route_info = route_head :!: route_get
 		where
-		route_head (RouterEndpointArg respond) =
+		route_head (RouterResponseArg respond) =
 			RouterResponse $ \req res -> do
 				res $ respond (HTTP.mkStatus 201 "") [] $ TL.pack $ show req <> "\n"
 		
-		route_get (RouterEndpointArg respond) =
+		route_get (RouterResponseArg respond) =
 			RouterResponse $ \req res -> do
 				res $ respond status200 [] $ TL.pack $ show req <> "\n"
 
@@ -160,3 +160,29 @@ hspec =
 	with (return rou1) $
 		it "allows running arbitrary monads" $ do
 			get "/date" `shouldRespondWith` 200
+
+api2
+ =   segment "time"
+ <.> response @PlainText @TL.Text HTTP.methodGet
+
+ <!> segment "date"
+ <.> response @PlainText @TL.Text HTTP.methodGet
+
+rou2 = routerAPI api2 $
+	route_time :!:
+	route_date
+	where
+	route_time (RouterResponseArg respond) =
+		RouterResponse $ \_req res -> do
+			time <- Time.getCurrentTime
+			res $ respond status200 [] $
+				TL.pack $ show time <> "\n"
+	
+	route_date (RouterResponseArg respond) =
+		RouterResponse $ \_req res -> do
+			date <- Time.utctDay <$> Time.getCurrentTime
+			res $ respond status200 [] $
+				TL.pack $ show date <> "\n"
+
+srv2 :: IO ()
+srv2 = Warp.run 8080 rou2
diff --git a/test/Hspec/Router/Error.hs b/test/Hspec/Router/Error.hs
index eb49ca3..2696dbe 100644
--- a/test/Hspec/Router/Error.hs
+++ b/test/Hspec/Router/Error.hs
@@ -1,20 +1,22 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TypeApplications #-}
 module Hspec.Router.Error where
-import Control.Monad (Monad(..))
-import Data.Int (Int)
+
+import Control.Monad (Monad(..), when)
 import Data.Either (Either(..))
-import Data.Maybe (Maybe(..))
+import Data.Eq (Eq(..))
 import Data.Function (($), (.))
+import Data.Int (Int)
+import Data.Maybe (Maybe(..))
+import Data.Semigroup (Semigroup(..))
 import System.IO (IO)
-import Text.Show (Show(..))
-import Text.Read (readMaybe)
 import Test.Hspec
 import Test.Hspec.Wai
 import Test.Tasty
 import Test.Tasty
 import Test.Tasty.Hspec
-import Data.Semigroup (Semigroup(..))
+import Text.Read (readMaybe)
+import Text.Show (Show(..))
 import qualified Data.ByteString.Lazy as BSL
 import qualified Data.Text as Text
 import qualified Data.Text.Encoding as Text
@@ -27,15 +29,19 @@ import Symantic.HTTP
 
 api = segment "good"
   <.> capture @Int "i"
-  <.> query @Int "param"
-  <.> endpoint @Int @PlainText HTTP.methodPost
-rtr = runRouter api $ route_good
+  <.> queryParams @Int "param"
+  <.> body @PlainText @Int
+  <.> response @PlainText @Int HTTP.methodPost
+
+rtr = routerAPI api $ route_good
 	where
-	route_good i qry (RouterEndpointArg respond) =
+	route_good i params (RouterBodyArg b) (RouterResponseArg respond) =
 		RouterResponse $ \_req res -> do
 			res $ respond status200 [] i
+
 srv :: IO ()
 srv = Warp.run 8080 rtr
+
 instance MimeSerialize PlainText Int where
 	mimeSerialize _mt = BSL.fromStrict . Text.encodeUtf8 . Text.pack . show
 instance MimeUnserialize PlainText Int where
@@ -47,341 +53,53 @@ instance MimeUnserialize PlainText Int where
 hspec =
 	testSpec "Error order" $
 		with (return rtr) $ do
-			it "has 404 as its highest priority error" $ do
-				request badMethod badURI [badAuth, badContentType, badAccept] badBody
+			it "has 404 as its highest priority error (path)" $ do
+				request badMethod badURI [badAuth, badAccept, badContentType] badBody
 				`shouldRespondWith` 404
-			it "has 405 as its second highest priority error" $ do
-				request badMethod badParam [badAuth, badContentType, badAccept] badBody
+			it "has 405 as its second highest priority error (method)" $ do
+				request badMethod badParam [badAuth, badAccept, badContentType] badBody
 				`shouldRespondWith` 405
 			it "has 401 as its third highest priority error (auth)" $ do
-				request goodMethod badParam [badAuth, badContentType, badAccept] badBody
+				request goodMethod badParam [badAuth, badAccept, badContentType] badBody
 				`shouldRespondWith` 401
-			it "has 406 as its fourth highest priority error" $ do
-				request goodMethod badParam [goodAuth, badContentType, badAccept] badBody
+			it "has 406 as its fourth highest priority error (accept)" $ do
+				request goodMethod badParam [goodAuth, badAccept, badContentType] badBody
 				`shouldRespondWith` 406
+			it "has 415 as its fifth highest priority error (content type)" $ do
+				request goodMethod badParam [goodAuth, goodAccept, badContentType] badBody
+				`shouldRespondWith` 415
+			it "has 400 as its sixth highest priority error (query and body)" $ do
+				let goodHeaders = [goodAuth, goodAccept, goodContentType]
+				badParamsRes <- request goodMethod badParam goodHeaders goodBody
+				badBodyRes   <- request goodMethod goodURI  goodHeaders badBody
+				
+				-- Both bad body and bad params result in 400
+				return badParamsRes `shouldRespondWith` 400
+				return badBodyRes   `shouldRespondWith` 400
+				
+				-- Param check should occur before body checks
+				badBothRes <- request goodMethod badParam
+				 [goodAuth, goodAccept, goodContentType] badBody
+				when (badBothRes /= badParamsRes) $ liftIO $
+					expectationFailure $ "badParam + badBody /= badParam: "
+					 <> show badBothRes <> ", " <> show badParamsRes
+				when (badBothRes == badBodyRes) $ liftIO $
+					expectationFailure $ "badParam + badBody == badBody: "
+					 <> show badBothRes
 
 
 badContentType  = (HTTP.hContentType, "application/json")
-badAccept       = (HTTP.hAccept, "text/plain")
+badAccept       = (HTTP.hAccept, "application/json")
 badMethod       = HTTP.methodGet
 badURI          = "bad"
 badBody         = "bad"
 badAuth         = (HTTP.hAuthorization, "Basic foofoofoo")
-goodContentType = (HTTP.hContentType, "text/plain")
+goodContentType = (HTTP.hContentType, "text/plain;charset=utf-8")
 goodAccept      = (HTTP.hAccept, "text/plain")
 goodMethod      = HTTP.methodPost
 goodPath        = "good/4"
 goodURI         = goodPath<>"?param=2"
 badParam        = goodPath<>"?param=foo"
-goodBody        = {-encode-} (42::Int)
--- username:password = servant:server
-goodAuth        = (HTTP.hAuthorization, "Basic c2VydmFudDpzZXJ2ZXI=")
-
-
-{-
-{-# LANGUAGE DataKinds             #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE OverloadedStrings     #-}
-{-# LANGUAGE TypeFamilies          #-}
-{-# LANGUAGE TypeOperators         #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-module Servant.Server.ErrorSpec (spec) where
-
-import           Control.Monad
-                 (when)
-import           Data.Aeson
-                 (encode)
-import qualified Data.ByteString.Char8      as BC
-import qualified Data.ByteString.Lazy.Char8 as BCL
-import           Data.Monoid
-                 ((<>))
-import           Data.Proxy
-import           Network.HTTP.Types
-                 (hAccept, hAuthorization, hContentType, methodGet, methodPost,
-                 methodPut)
-import           Safe
-                 (readMay)
-import           Test.Hspec
-import           Test.Hspec.Wai
-
-import           Servant
-
-spec :: Spec
-spec = describe "HTTP Errors" $ do
-    errorOrderSpec
-    prioErrorsSpec
-    errorRetrySpec
-    errorChoiceSpec
-
--- * Auth machinery (reused throughout)
-
--- | 'BasicAuthCheck' holds the handler we'll use to verify a username and password.
-errorOrderAuthCheck :: BasicAuthCheck ()
-errorOrderAuthCheck =
-  let check (BasicAuthData username password) =
-        if username == "servant" && password == "server"
-        then return (Authorized ())
-        else return Unauthorized
-  in BasicAuthCheck check
-
-------------------------------------------------------------------------------
--- * Error Order {{{
-
-type ErrorOrderApi = "home"
-                  :> BasicAuth "error-realm" ()
-                  :> ReqBody '[JSON] Int
-                  :> Capture "t" Int
-                  :> QueryParam "param" Int
-                  :> Post '[JSON] Int
-
-errorOrderApi :: Proxy ErrorOrderApi
-errorOrderApi = Proxy
-
-errorOrderServer :: Server ErrorOrderApi
-errorOrderServer = \_ _ _ _ -> throwError err402
-
--- On error priorities:
---
--- We originally had
---
--- 404, 405, 401, 415, 400, 406, 402
---
--- but we changed this to
---
--- 404, 405, 401, 406, 415, 400, 402
---
--- for servant-0.7.
---
--- This change is due to the body check being irreversible (to support
--- streaming). Any check done after the body check has to be made fatal,
--- breaking modularity. We've therefore moved the accept check before
--- the body check, to allow it being recoverable and modular, and this
--- goes along with promoting the error priority of 406.
-errorOrderSpec :: Spec
-errorOrderSpec =
-  describe "HTTP error order" $
-    with (return $ serveWithContext errorOrderApi
-                   (errorOrderAuthCheck :. EmptyContext)
-                   errorOrderServer
-         ) $ do
-  let badContentType  = (hContentType, "text/plain")
-      badAccept       = (hAccept, "text/plain")
-      badMethod       = methodGet
-      badUrl          = "nonexistent"
-      badBody         = "nonsense"
-      badAuth         = (hAuthorization, "Basic foofoofoo")
-      goodContentType = (hContentType, "application/json")
-      goodAccept      = (hAccept, "application/json")
-      goodMethod      = methodPost
-      goodUrl         = "home/2?param=55"
-      badParams       = goodUrl <> "?param=foo"
-      goodBody        = encode (5 :: Int)
-      -- username:password = servant:server
-      goodAuth        = (hAuthorization, "Basic c2VydmFudDpzZXJ2ZXI=")
-
-  it "has 404 as its highest priority error" $ do
-    request badMethod badUrl [badAuth, badContentType, badAccept] badBody
-      `shouldRespondWith` 404
-
-  it "has 405 as its second highest priority error" $ do
-    request badMethod badParams [badAuth, badContentType, badAccept] badBody
-      `shouldRespondWith` 405
-
-  it "has 401 as its third highest priority error (auth)" $ do
-    request goodMethod badParams [badAuth, badContentType, badAccept] badBody
-      `shouldRespondWith` 401
-
-  it "has 406 as its fourth highest priority error" $ do
-    request goodMethod badParams [goodAuth, badContentType, badAccept] badBody
-      `shouldRespondWith` 406
-
-  it "has 415 as its fifth highest priority error" $ do
-    request goodMethod badParams [goodAuth, badContentType, goodAccept] badBody
-      `shouldRespondWith` 415
-
-  it "has 400 as its sixth highest priority error" $ do
-    badParamsRes <- request goodMethod badParams [goodAuth, goodContentType, goodAccept] goodBody
-    badBodyRes <- request goodMethod goodUrl [goodAuth, goodContentType, goodAccept] badBody
-
-    -- Both bad body and bad params result in 400
-    return badParamsRes `shouldRespondWith` 400
-    return badBodyRes `shouldRespondWith` 400
-
-    -- Param check should occur before body checks
-    both <- request goodMethod badParams [goodAuth, goodContentType, goodAccept ] badBody
-    when (both /= badParamsRes) $ liftIO $
-        expectationFailure $ "badParams + badBody /= badParams: " ++ show both ++ ", " ++ show badParamsRes
-    when (both == badBodyRes) $ liftIO $
-        expectationFailure $ "badParams + badBody == badBody: " ++ show both
-
-  it "has handler-level errors as last priority" $ do
-    request goodMethod goodUrl [goodAuth, goodContentType, goodAccept] goodBody
-      `shouldRespondWith` 402
-
-type PrioErrorsApi = ReqBody '[JSON] Integer :> "foo" :> Get '[JSON] Integer
-
-prioErrorsApi :: Proxy PrioErrorsApi
-prioErrorsApi = Proxy
-
--- Check whether matching continues even if a 'ReqBody' or similar construct
--- is encountered early in a path. We don't want to see a complaint about the
--- request body unless the path actually matches.
-prioErrorsSpec :: Spec
-prioErrorsSpec = describe "PrioErrors" $ do
-  let server = return
-  with (return $ serve prioErrorsApi server) $ do
-    let check (mdescr, method) path (cdescr, ctype, body) resp =
-          it fulldescr $
-            Test.Hspec.Wai.request method path [(hContentType, ctype)] body
-              `shouldRespondWith` resp
-          where
-            fulldescr = "returns " ++ show (matchStatus resp) ++ " on " ++ mdescr
-                     ++ " " ++ BC.unpack path ++ " (" ++ cdescr ++ ")"
-
-        get' = ("GET", methodGet)
-        put' = ("PUT", methodPut)
-
-        txt   = ("text"        , "text/plain;charset=utf8"      , "42"        )
-        ijson = ("invalid json", "application/json;charset=utf8", "invalid"   )
-        vjson = ("valid json"  , "application/json;charset=utf8", encode (5 :: Int))
-
-    check get' "/"    txt   404
-    check get' "/bar" txt   404
-    check get' "/foo" txt   415
-    check put' "/"    txt   404
-    check put' "/bar" txt   404
-    check put' "/foo" txt   405
-    check get' "/"    ijson 404
-    check get' "/bar" ijson 404
-    check get' "/foo" ijson 400
-    check put' "/"    ijson 404
-    check put' "/bar" ijson 404
-    check put' "/foo" ijson 405
-    check get' "/"    vjson 404
-    check get' "/bar" vjson 404
-    check get' "/foo" vjson 200
-    check put' "/"    vjson 404
-    check put' "/bar" vjson 404
-    check put' "/foo" vjson 405
-
--- }}}
-------------------------------------------------------------------------------
--- * Error Retry {{{
-
-type ErrorRetryApi
-     = "a" :> ReqBody '[JSON] Int      :> Post '[JSON] Int                -- err402
-  :<|> "a" :> ReqBody '[PlainText] Int :> Post '[JSON] Int                -- 1
-  :<|> "a" :> ReqBody '[JSON] Int      :> Post '[PlainText] Int           -- 2
-  :<|> "a" :> ReqBody '[JSON] String   :> Post '[JSON] Int                -- 3
-  :<|> "a" :> ReqBody '[JSON] Int      :> Get  '[JSON] Int                -- 4
-  :<|> "a" :> BasicAuth "bar-realm" ()
-           :> ReqBody '[JSON] Int      :> Get  '[PlainText] Int           -- 5
-  :<|> "a" :> ReqBody '[JSON] Int      :> Get  '[PlainText] Int           -- 6
-
-  :<|>        ReqBody '[JSON] Int      :> Get  '[JSON] Int                -- 7
-  :<|>        ReqBody '[JSON] Int      :> Post '[JSON] Int                -- 8
-
-errorRetryApi :: Proxy ErrorRetryApi
-errorRetryApi = Proxy
-
-errorRetryServer :: Server ErrorRetryApi
-errorRetryServer
-     = (\_ -> throwError err402)
-  :<|> (\_ -> return 1)
-  :<|> (\_ -> return 2)
-  :<|> (\_ -> return 3)
-  :<|> (\_ -> return 4)
-  :<|> (\_ _ -> return 5)
-  :<|> (\_ -> return 6)
-  :<|> (\_ -> return 7)
-  :<|> (\_ -> return 8)
-
-errorRetrySpec :: Spec
-errorRetrySpec =
-  describe "Handler search" $
-    with (return $ serveWithContext errorRetryApi
-                         (errorOrderAuthCheck :. EmptyContext)
-                         errorRetryServer
-         ) $ do
-
-  let jsonCT      = (hContentType, "application/json")
-      jsonAccept  = (hAccept, "application/json")
-      jsonBody    = encode (1797 :: Int)
-
-  it "should continue when URLs don't match" $ do
-    request methodPost "" [jsonCT, jsonAccept] jsonBody
-     `shouldRespondWith` 200 { matchBody = mkBody $ encode (8 :: Int) }
-
-  it "should continue when methods don't match" $ do
-    request methodGet "a" [jsonCT, jsonAccept] jsonBody
-     `shouldRespondWith` 200 { matchBody = mkBody $ encode (4 :: Int) }
-  where
-    mkBody b = MatchBody $ \_ b' ->
-      if b == b'
-        then Nothing
-        else Just "body not correct\n"
-
--- }}}
-------------------------------------------------------------------------------
--- * Error Choice {{{
-
-type ErrorChoiceApi
-     = "path0" :> Get '[JSON] Int                                     -- 0
-  :<|> "path1" :> Post '[JSON] Int                                    -- 1
-  :<|> "path2" :> Post '[PlainText] Int                               -- 2
-  :<|> "path3" :> ReqBody '[JSON] Int :> Post '[PlainText] Int        -- 3
-  :<|> "path4" :> (ReqBody '[PlainText] Int :> Post '[PlainText] Int  -- 4
-             :<|>  ReqBody '[PlainText] Int :> Post '[JSON] Int)      -- 5
-  :<|> "path5" :> (ReqBody '[JSON] Int      :> Post '[PlainText] Int  -- 6
-             :<|>  ReqBody '[PlainText] Int :> Post '[PlainText] Int) -- 7
-
-errorChoiceApi :: Proxy ErrorChoiceApi
-errorChoiceApi = Proxy
-
-errorChoiceServer :: Server ErrorChoiceApi
-errorChoiceServer = return 0
-               :<|> return 1
-               :<|> return 2
-               :<|> (\_ -> return 3)
-               :<|> ((\_ -> return 4) :<|> (\_ -> return 5))
-               :<|> ((\_ -> return 6) :<|> (\_ -> return 7))
-
-
-errorChoiceSpec :: Spec
-errorChoiceSpec = describe "Multiple handlers return errors"
-                $ with (return $ serve errorChoiceApi errorChoiceServer) $ do
-
-  it "should respond with 404 if no path matches" $ do
-    request methodGet "" [] "" `shouldRespondWith` 404
-
-  it "should respond with 405 if a path but not method matches" $ do
-    request methodGet "path2" [] "" `shouldRespondWith` 405
-
-  it "should respond with the corresponding error if path and method match" $ do
-    request methodPost "path3" [(hContentType, "text/plain;charset=utf-8")] ""
-      `shouldRespondWith` 415
-    request methodPost "path3" [(hContentType, "application/json")] ""
-      `shouldRespondWith` 400
-    request methodPost "path4" [(hContentType, "text/plain;charset=utf-8"),
-                                (hAccept, "blah")] "5"
-      `shouldRespondWith` 406
-  it "should respond with 415 only if none of the subservers supports the request's content type" $ do
-    request methodPost "path5" [(hContentType, "text/plain;charset=utf-8")] "1"
-      `shouldRespondWith` 200
-    request methodPost "path5" [(hContentType, "application/json")] "1"
-      `shouldRespondWith` 200
-    request methodPost "path5" [(hContentType, "application/not-supported")] ""
-      `shouldRespondWith` 415
-
-
--- }}}
-------------------------------------------------------------------------------
--- * Instances {{{
-
-instance MimeUnrender PlainText Int where
-    mimeUnrender _ x = maybe (Left "no parse") Right (readMay $ BCL.unpack x)
-
-instance MimeRender PlainText Int where
-    mimeRender _ = BCL.pack . show
--- }}}
--}
+goodBody        = "42" -- {-encode-} (42::Int)
+-- username:password = user:pass
+-- goodAuth        = (HTTP.hAuthorization, "Basic XXXXXXXXXXXXXXXXXXX=")
-- 
2.47.0