{-# LANGUAGE GADTs #-} -- for 'Router' and 'Router_Union'
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-} -- for 'BinTree'
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# 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.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, 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(..))
import Data.Proxy (Proxy(..))
import Data.Semigroup (Semigroup(..))
import Data.String (String, IsString(..))
import Data.Text (Text)
import System.IO (IO)
import Text.Show (Show(..))
import qualified Control.Monad.Classes as MC
import qualified Control.Monad.Trans.Cont as C
import qualified Control.Monad.Trans.Reader as R
import qualified Control.Monad.Trans.State.Strict as S
import qualified Control.Monad.Trans.Writer.Strict as W
import qualified Data.ByteString as BS
import qualified Data.ByteString.Base64 as BS64
import qualified Data.ByteString.Builder as BSB
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
import qualified Network.HTTP.Types as HTTP
import qualified Network.HTTP.Types.Header as HTTP
import qualified Network.Wai as Wai
import qualified Web.HttpApiData as Web

import Symantic.HTTP

-- * Type 'Server'
-- | (@'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 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 handlers k = Server { unServer ::
	S.StateT ServerState
	 (ServerCheckT [ServerErrorBody]        -- 8th check, 400 error
	 (ServerCheckT [ServerErrorHeader]      -- 7th check, 400 error
	 (ServerCheckT [ServerErrorQuery]       -- 6th check, 400 error
	 (ServerCheckT [ServerErrorContentType] -- 5th check, 415 error
	 (ServerCheckT [ServerErrorAccept]      -- 4th check, 406 error
	 (ServerCheckT [ServerErrorBasicAuth]   -- 3rd check, 401 or 403 error
	 (ServerCheckT [ServerErrorMethod]      -- 2nd check, 405 error
	 (ServerCheckT [ServerErrorPath]        -- 1st check, 404 error
	 IO))))))))
	 (handlers -> k)
 }

-- | (@'server' api handlers@) returns an 'Wai.Application'
-- ready to be given to @Warp.run 80@.
server ::
 Router Server handlers (Response Server) ->
 handlers ->
 Wai.Application
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 ->
		case lrMethod of
		 Left err -> respondError HTTP.status405 [] err
		 Right lrBasicAuth ->
			case lrBasicAuth of
			 Left err ->
				case failError err of
				 [] -> respondError HTTP.status500 [] err
				 ServerErrorBasicAuth realm ba:_ ->
					case ba of
					 BasicAuth_Unauthorized ->
						respondError HTTP.status403 [] err
					 _ ->
						respondError HTTP.status401
						 [ ( HTTP.hWWWAuthenticate
						   , "Basic realm=\""<>Web.toHeader realm<>"\""
						   ) ] err
			 Right lrAccept ->
				case lrAccept of
				 Left err -> respondError HTTP.status406 [] err
				 Right lrContentType ->
					case lrContentType of
					 Left err -> respondError HTTP.status415 [] err
					 Right lrQuery ->
						case lrQuery of
						 Left err -> respondError HTTP.status400 [] err
						 Right lrHeader ->
							case lrHeader of
							 Left err -> respondError HTTP.status400 [] err
							 Right lrBody ->
								case lrBody of
								 Left err -> respondError HTTP.status400 [] err
								 Right (app, st) ->
									app handlers (serverState_request st) re
	where
	respondError ::
	 Show err =>
	 HTTP.Status ->
	 [(HTTP.HeaderName, HeaderValue)] ->
	 err -> IO Wai.ResponseReceived
	respondError st hs err =
		-- Trace.trace (show err) $
		re $ Wai.responseLBS st
		 ( (HTTP.hContentType, Media.renderHeader $ mediaType @PlainText)
		 : hs
		 ) (fromString $ show err) -- TODO: see what to return in the body

-- | Unwrap the 'ExceptT' constructors to reach the 'Either' constructors.
runServerChecks ::
 S.StateT ServerState (ExceptT e1 (ExceptT e2 (ExceptT e3 (ExceptT e4 (ExceptT e5 (ExceptT e6 (ExceptT e7 (ExceptT e8 IO)))))))) a ->
 ServerState -> IO (Either e8 (Either e7 (Either e6 (Either e5 (Either e4 (Either e3 (Either e2 (Either e1 (a, ServerState)))))))))
runServerChecks s st =
	runExceptT $
	runExceptT $
	runExceptT $
	runExceptT $
	runExceptT $
	runExceptT $
	runExceptT $
	runExceptT $
	S.runStateT s st

-- ** Type 'ServerCheckT'
type ServerCheckT e = ExceptT (Fail e)

-- *** Type 'RouteResult'
type RouteResult e = Either (Fail e)

-- *** Type 'Fail'
data Fail e
 =   Fail ServerState e -- ^ Keep trying other paths. 404, 405 or 406.
 |   FailFatal !ServerState !e -- ^ Don't try other paths.
 deriving (Show)
failState :: Fail e -> ServerState
failState (Fail st _)      = st
failState (FailFatal st _) = st
failError :: Fail e -> e
failError (Fail _st e)      = e
failError (FailFatal _st e) = e
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)

-- ** Type 'ServerState'
newtype ServerState = ServerState
 { serverState_request :: Wai.Request
 } -- deriving (Show)
instance Show ServerState where
	show _ = "ServerState"

instance Cat Server where
	(<.>) ::
	 forall a b c repr.
	 repr ~ Server =>
	 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 'Server' using a binary tree
	-- instead of nested 'Either's, 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 not worth the cognitive pain to design it.
	-- Some copying/pasting/adapting will do for now.
	Server x <.> Server y = Server $
		S.StateT $ \st -> do
			xPath <- MC.exec @IO $ runServerChecks x st
			case xPath of
			 Left xe -> MC.throw xe
			 Right xMethod ->
				case xMethod of
				 Left xe -> do
					yPath <- MC.exec @IO $ runServerChecks y (failState xe)
					case yPath of
					 Left ye -> MC.throw ye
					 Right _yMethod -> MC.throw xe
				 Right xBasicAuth ->
					case xBasicAuth of
					 Left xe -> do
						yPath <- MC.exec @IO $ runServerChecks y (failState xe)
						case yPath of
						 Left ye -> MC.throw ye
						 Right yMethod ->
							case yMethod of
							 Left ye -> MC.throw ye
							 Right _yBasicAuth -> MC.throw xe
					 Right xAccept ->
						case xAccept of
						 Left xe -> do
							yPath <- MC.exec @IO $ runServerChecks y (failState xe)
							case yPath of
							 Left ye -> MC.throw ye
							 Right yMethod ->
								case yMethod of
								 Left ye -> MC.throw ye
								 Right yBasicAuth ->
									case yBasicAuth of
									 Left ye -> MC.throw ye
									 Right _yAccept -> MC.throw xe
						 Right xContentType ->
							case xContentType of
							 Left xe -> do
								yPath <- MC.exec @IO $ runServerChecks y (failState xe)
								case yPath of
								 Left ye -> MC.throw ye
								 Right yMethod ->
									case yMethod of
									 Left ye -> MC.throw ye
									 Right yBasicAuth ->
										case yBasicAuth 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 <- MC.exec @IO $ runServerChecks y (failState xe)
									case yPath of
									 Left ye -> MC.throw ye
									 Right yMethod ->
										case yMethod of
										 Left ye -> MC.throw ye
										 Right yBasicAuth ->
											case yBasicAuth 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 <- MC.exec @IO $ runServerChecks y (failState xe)
										case yPath of
										 Left ye -> MC.throw ye
										 Right yMethod ->
											case yMethod of
											 Left ye -> MC.throw ye
											 Right yBasicAuth ->
												case yBasicAuth 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 <- MC.exec @IO $ runServerChecks y (failState xe)
											case yPath of
											 Left ye -> MC.throw ye
											 Right yMethod ->
												case yMethod of
												 Left ye -> MC.throw ye
												 Right yBasicAuth ->
													case yBasicAuth 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 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
			let fy = (first (\b2k (_a:!:b) -> b2k b) <$>)
			case xPath of
			 Left xe | FailFatal{} <- xe -> MC.throw xe
			         | otherwise -> do
				yPath <- MC.exec @IO $ runServerChecks y st
				case yPath of
				 Left ye -> MC.throw (xe<>ye)
				 Right yMethod ->
					fy $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ ExceptT $
						return $ Right yMethod
			 Right xMethod ->
				case xMethod of
				 Left xe | FailFatal{} <- xe -> MC.throw xe
				         | otherwise -> do
					yPath <- MC.exec @IO $ runServerChecks y st
					case yPath of
					 Left _ye -> MC.throw xe
					 Right yMethod ->
						case yMethod of
						 Left ye -> MC.throw (xe<>ye)
						 Right yBasicAuth ->
							fy $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ ExceptT $
								return $ Right $ yBasicAuth
				 Right xBasicAuth ->
					case xBasicAuth of
					 Left xe | FailFatal{} <- xe -> MC.throw xe
					         | otherwise -> do
						yPath <- MC.exec @IO $ runServerChecks y st
						case yPath of
						 Left _ye -> MC.throw xe
						 Right yMethod ->
							case yMethod of
							 Left _ye -> MC.throw xe
							 Right yBasicAuth ->
								case yBasicAuth 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 -> do
							yPath <- MC.exec @IO $ runServerChecks y st
							case yPath of
							 Left _ye -> MC.throw xe
							 Right yMethod ->
								case yMethod of
								 Left _ye -> MC.throw xe
								 Right yBasicAuth ->
									case yBasicAuth 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 -> do
								yPath <- MC.exec @IO $ runServerChecks y st
								case yPath of
								 Left _ye -> MC.throw xe
								 Right yMethod ->
									case yMethod of
									 Left _ye -> MC.throw xe
									 Right yBasicAuth ->
										case yBasicAuth 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 -> do
									yPath <- MC.exec @IO $ runServerChecks y st
									case yPath of
									 Left _ye -> MC.throw xe
									 Right yMethod ->
										case yMethod of
										 Left _ye -> MC.throw xe
										 Right yBasicAuth ->
											case yBasicAuth 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 -> do
										yPath <- MC.exec @IO $ runServerChecks y st
										case yPath of
										 Left _ye -> MC.throw xe
										 Right yMethod ->
											case yMethod of
											 Left _ye -> MC.throw xe
											 Right yBasicAuth ->
												case yBasicAuth 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 -> do
											yPath <- MC.exec @IO $ runServerChecks y st
											case yPath of
											 Left _ye -> MC.throw xe
											 Right yMethod ->
												case yMethod of
												 Left _ye -> MC.throw xe
												 Right yBasicAuth ->
													case yBasicAuth 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 Server where
	dimap a2b _b2a (Server r) = Server $ (\k b2k -> k (b2k . a2b)) <$> r

-- ** 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
		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
		  | curr /= expSegment ->
			MC.throw $ Fail st [ServerErrorPath $ "expected: "<>expSegment<>" but got: "<>curr]
		  | otherwise -> do
			S.put st
			 { serverState_request = req{ Wai.pathInfo = next }
			 }
			return id
	capture' :: forall a k. PathConstraint Server a => Name -> Server (a -> k) k
	capture' name = 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"]
		 curr:next ->
			case Web.parseUrlPiece curr of
			 Left err -> MC.throw $ Fail st [ServerErrorPath $ "capture: "<>fromString name<>": "<>err]
			 Right a -> do
				S.put st
				 { serverState_request = req{ Wai.pathInfo = next }
				 }
				return ($ a)
	captureAll = Server $ do
		req <- S.gets serverState_request
		return ($ Wai.pathInfo req)

-- ** Type 'ServerErrorMethod'
data ServerErrorMethod = ServerErrorMethod
 deriving (Eq, Show)

-- | TODO: add its own error?
instance HTTP_Version Server where
	version exp = Server $ do
		st <- S.get
		let got = Wai.httpVersion $ serverState_request st
		if got == exp
		 then return id
		 else MC.throw $ Fail st [ServerErrorMethod] -- FIXME: ServerErrorVersion

-- ** Type 'ServerErrorAccept'
data ServerErrorAccept =
 ServerErrorAccept
  MediaTypes
  (Maybe (Either BS.ByteString MediaType))
 deriving (Eq, Show)

-- ** Type 'ServerErrorContentType'
data ServerErrorContentType = ServerErrorContentType
 deriving (Eq, Show)

-- ** Type 'ServerErrorQuery'
newtype ServerErrorQuery = ServerErrorQuery Text
 deriving (Show)
instance HTTP_Query Server where
	type QueryConstraint Server a = Web.FromHttpApiData a
	queryParams' name = Server $ do
		st <- S.get
		lift $ ExceptT $ ExceptT $ ExceptT $ return $
			let qs = Wai.queryString $ serverState_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 [ServerErrorQuery err]
			 Right vs -> Right $ Right $ Right ($ vs)

-- ** Type 'ServerErrorHeader'
data ServerErrorHeader = ServerErrorHeader
 deriving (Eq, Show)
instance HTTP_Header Server where
	header n = Server $ do
		st <- S.get
		lift $ ExceptT $ ExceptT $ return $
			let hs = Wai.requestHeaders $ serverState_request st in
			case List.lookup n hs of
			 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 ->
	 BasicAuthPass ->
	 IO (BasicAuth a)

-- | WARNING: current implementation of Basic Access Authentication
-- 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
	type BasicAuthArgs Server a k = a -> k
	basicAuth' realm = Server $ do
		st <- S.get
		let err e = MC.throw $ Fail st [ServerErrorBasicAuth realm e]
		case decodeAuthorization $ serverState_request st of
		 Nothing -> err BasicAuth_BadPassword
		 Just (user, pass) -> do
			MC.exec @IO (serverBasicAuth user pass) >>= \case
			 BasicAuth_BadPassword  -> err BasicAuth_BadPassword
			 BasicAuth_NoSuchUser   -> err BasicAuth_NoSuchUser
			 BasicAuth_Unauthorized -> err BasicAuth_Unauthorized
			 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)
		decodeAuthorization req = do
			hAuthorization <- List.lookup "Authorization" $ Wai.requestHeaders req
			let (basic, rest) = BS.break Word8.isSpace hAuthorization
			guard (BS.map Word8.toLower basic == "basic")
			let decoded = BS64.decodeLenient (BS.dropWhile Word8.isSpace rest)
			let (user, colon_pass) = BS.break (== Word8._colon) decoded
			(_, pass) <- BS.uncons colon_pass
			return (Text.decodeUtf8 user, Text.decodeUtf8 pass)

-- ** Type 'ServerErrorBody'
newtype ServerErrorBody = ServerErrorBody String
 deriving (Eq, Show)

-- *** Type 'ServerBodyArg'
newtype ServerBodyArg (ts::[Type]) a = ServerBodyArg a

instance HTTP_Body Server where
	type BodyConstraint Server a ts = MimeTypes ts (MimeDecodable a)
	type BodyArg Server a ts = ServerBodyArg ts a
	body' ::
	 forall a ts k repr.
	 BodyConstraint repr a ts =>
	 repr ~ Server =>
	 repr (BodyArg repr a ts -> k) k
	body'= Server $ do
		st <- S.get
		lift $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ do
			let hs = Wai.requestHeaders $ serverState_request st
			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 matchContent @ts @(MimeDecodable a) reqContentType of
			 Nothing -> return $ Left $ Fail st [ServerErrorContentType]
			 Just (MimeType mt) -> do
				bodyBS <- MC.exec @IO $ Wai.requestBody $ serverState_request st
				return $ Right $ Right $ Right $
					-- 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::[Type]) framing
 =      ServerBodyStreamArg as
instance HTTP_BodyStream Server where
	type BodyStreamConstraint Server as ts framing =
	 ( FramingDecode framing as
	 , MC.MonadExec IO (FramingMonad as)
	 , MimeTypes ts (MimeDecodable (FramingYield as))
	 )
	type BodyStreamArg Server as ts framing =
	 ServerBodyStreamArg as ts framing
	bodyStream' ::
	 forall as ts framing k repr.
	 BodyStreamConstraint repr as ts framing =>
	 repr ~ Server =>
	 repr (BodyStreamArg repr as ts framing -> k) k
	bodyStream'= Server $ do
		st <- S.get
		lift $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ do
			let hs = Wai.requestHeaders $ serverState_request st
			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 matchContent @ts @(MimeDecodable (FramingYield as)) reqContentType of
			 Nothing -> return $ Left $ Fail st [ServerErrorContentType]
			 Just (MimeType mt) -> do
				let bodyBS = Wai.requestBody $ serverState_request st
				return $ Right $ Right $ Right $
					Right ($ ServerBodyStreamArg $
						framingDecode (Proxy @framing) (mimeDecode mt) $
							MC.exec @IO bodyBS
					 )

-- * Type 'ServerResponse'
-- | 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::[Type]) m a
 =      ServerResponse
 {    unServerResponse :: m a
 } deriving (Functor, Applicative, Monad)
type ServerResponse ts m = ServerRes ts
 (R.ReaderT Wai.Request
 (W.WriterT HTTP.ResponseHeaders
 (W.WriterT HTTP.Status
 (C.ContT Wai.Response m))))
instance MonadTrans (ServerRes ts) where
	lift = ServerResponse
-- | All supported effects are handled by nested 'Monad's.
type instance MC.CanDo (ServerResponse ts m) eff = 'False
type instance MC.CanDo (C.ContT ts m) (MC.EffExec eff) = 'False

instance HTTP_Response Server where
	type ResponseConstraint Server a ts = MimeTypes ts (MimeEncodable a)
	type ResponseArgs Server a ts = ServerResponse ts IO a
	type Response Server =
	 Wai.Request ->
	 (Wai.Response -> IO Wai.ResponseReceived) ->
	 IO Wai.ResponseReceived
	response ::
	 forall a ts repr.
	 ResponseConstraint repr a ts =>
	 repr ~ Server =>
	 HTTP.Method ->
	 repr (ResponseArgs repr a ts)
	      (Response repr)
	response expMethod = Server $ do
		st@ServerState
		 { serverState_request = req
		 } <- S.get
		
		-- Check the path has been fully consumed
		unless (List.null $ Wai.pathInfo req) $
			MC.throw $ Fail st [ServerErrorPath "path is longer"]
		
		-- Check the method
		let reqMethod = Wai.requestMethod $ serverState_request st
		unless (reqMethod == expMethod
		 || reqMethod == HTTP.methodHead
		 && expMethod == HTTP.methodGet) $
			MC.throw $ Fail st [ServerErrorMethod]
		
		-- Check the Accept header
		let reqHeaders = Wai.requestHeaders $ serverState_request st
		MimeType reqAccept <- do
			case List.lookup HTTP.hAccept reqHeaders of
			 Nothing ->
				return $ NonEmpty.head $ mimeTypes @ts @(MimeEncodable a)
			 Just h ->
				case matchAccept @ts @(MimeEncodable a) h of
				 Nothing -> MC.throw $ Fail st [ServerErrorAccept (mediaTypes @ts @(MimeEncodable a)) (Just (Left h))]
				 Just mt -> return mt
		
		return $ \(ServerResponse k) rq re -> re =<< do
			C.runContT (W.runWriterT $ W.runWriterT $ R.runReaderT k rq) $ \((a,hs),sta) ->
				return{-IO-} $
					Wai.responseLBS sta
					 ((HTTP.hContentType, Media.renderHeader $ mediaTypeFor reqAccept):hs)
					 (if reqMethod == HTTP.methodHead
						then ""
						else mimeEncode reqAccept a)

-- * 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::[Type]) m as
 =      ServerResponseStream
 {    unServerResponseStream :: m as
 } deriving (Functor, Applicative, Monad)
instance MonadTrans (ServerResStream framing ts) where
	lift = ServerResponseStream
type ServerResponseStream framing ts m = ServerResStream framing ts
 (R.ReaderT Wai.Request
 (W.WriterT HTTP.ResponseHeaders
 (W.WriterT HTTP.Status
 (C.ContT Wai.Response m))))
-- | All supported effects are handled by nested 'Monad's.
type instance MC.CanDo (ServerResponseStream framing ts m) eff = 'False

instance HTTP_ResponseStream Server where
	type ResponseStreamConstraint Server as ts framing =
	 ( FramingEncode framing as
	 , MimeTypes ts (MimeEncodable (FramingYield as))
	 )
	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 =>
	 repr ~ Server =>
	 HTTP.Method ->
	 repr (ResponseStreamArgs repr as ts framing)
	      (ResponseStream repr)
	responseStream expMethod = Server $ do
		st@ServerState
		 { serverState_request = req
		 } <- S.get
		
		-- Check the path has been fully consumed
		unless (List.null $ Wai.pathInfo req) $
			MC.throw $ Fail st [ServerErrorPath "path is longer"]
		
		-- Check the method
		let reqMethod = Wai.requestMethod $ serverState_request st
		unless (reqMethod == expMethod
		 || reqMethod == HTTP.methodHead
		 && expMethod == HTTP.methodGet) $
			MC.throw $ Fail st [ServerErrorMethod]
		
		-- Check the Accept header
		let reqHeaders = Wai.requestHeaders $ serverState_request st
		MimeType reqAccept <- do
			case List.lookup HTTP.hAccept reqHeaders of
			 Nothing ->
				return $ NonEmpty.head $ mimeTypes @ts @(MimeEncodable (FramingYield as))
			 Just h ->
				case matchAccept @ts @(MimeEncodable (FramingYield as)) h of
				 Nothing -> MC.throw $ Fail st [ServerErrorAccept (mediaTypes @ts @(MimeEncodable (FramingYield as))) (Just (Left h))]
				 Just mt -> return mt
		
		return $ \(ServerResponseStream k) rq re -> re =<< do
			C.runContT (W.runWriterT $ W.runWriterT $ R.runReaderT k rq) $ \((as,hs),sta) ->
				return{-IO-} $
					Wai.responseStream sta
					 ( (HTTP.hContentType, Media.renderHeader $ mediaTypeFor reqAccept)
					 : hs
					 ) $ \write flush ->
						if reqMethod == HTTP.methodHead
						then flush
						else
							let enc = framingEncode (Proxy @framing) (mimeEncode reqAccept) in
							let go curr =
								case curr of
								 Left _end -> flush
								 Right (bsl, next) -> do
									unless (BSL.null bsl) $ do
										write (BSB.lazyByteString bsl)
										flush
									enc next >>= go
							in enc as >>= go

-- | Return worse 'HTTP.Status'.
instance Semigroup HTTP.Status where
	x <> y =
		if rank (HTTP.statusCode x) < rank (HTTP.statusCode y)
		then x
		else y
		where
		rank :: Int -> Int
		rank 404 = 0 -- Not Found
		rank 405 = 1 -- Method Not Allowed
		rank 401 = 2 -- Unauthorized
		rank 415 = 3 -- Unsupported Media Type
		rank 406 = 4 -- Not Acceptable
		rank 400 = 5 -- Bad Request
		rank _   = 6
-- | Useful when 'HTTP.Status' is within a 'W.WriterT'.
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 nesting them,
	-- such that 'unTrans' 'Router_Union' applies them all at once.
	Router_Map $
	Map.merge
	 (Map.mapMissing $ const $ \case
		 Router_Union u r -> Router_Union (\(x:!:_y) -> u x) r
		 r -> Router_Union (\(x:!:_y) -> x) r)
	 (Map.mapMissing $ const $ \case
		 Router_Union u r -> Router_Union (\(_x:!:y) -> u y) r
		 r -> Router_Union (\(_x:!:y) -> y) r)
	 (Map.zipWithMatched $ const $ \case
		 Router_Union xu xr -> \case
			 Router_Union yu yr -> Router_Union (\(x:!:y) -> xu x:!:yu y) $ xr`router_Alt`yr
			 yr -> Router_Union (\(a:!:b) -> xu a:!:b) $ xr`router_Alt`yr
		 xr -> \case
			 Router_Union yu yr -> Router_Union (\(a:!:b) -> a:!:yu b) $ xr`router_Alt`yr
			 yr -> 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
-}