{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module Symantic.HTTP.Server where

import Control.Arrow (first)
import Control.Monad (Monad(..), unless, sequence, guard)
import Control.Monad.Trans.Class (MonadTrans(..))
import Control.Monad.Trans.Except (ExceptT(..), runExceptT)
import Data.Bool
import Data.Either (Either(..))
import Data.Eq (Eq(..))
import Data.Function (($), (.), id)
import Data.Functor (Functor, (<$>))
import Data.Int (Int)
import Data.Maybe (Maybe(..), fromMaybe, catMaybes)
import Data.Semigroup (Semigroup(..))
import Data.String (String, IsString(..))
import Data.Text (Text)
import Prelude ((+))
import System.IO (IO)
import Text.Show (Show(..))
import qualified Control.Monad.Classes as MC
import qualified Control.Monad.Trans.State as S
import qualified Data.ByteString as BS
import qualified Data.ByteString.Base64 as BS64
import qualified Data.ByteString.Lazy as BSL
import qualified Data.List as List
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.API
import Symantic.HTTP.Mime

-- * Type 'Server'
-- | @Server f k@ is a recipe to produce an 'Wai.Application'
-- from handlers 'f' (one per number of alternative routes).
--
-- 'Server' 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 Server f 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 error
	 (ServerCheckT [ServerErrorMethod]      -- 2nd check, 405 error
	 (ServerCheckT [ServerErrorPath]        -- 1st check, 404 error
	 IO))))))))
	 (f -> k)
 } deriving (Functor)

-- | @'server' api handlers@ returns a 'Wai.Application'
-- ready to be given to @Warp.run 80@.
server ::
 Server handlers ServerResponse ->
 handlers ->
 Wai.Application
server (Server api) handlers rq re = do
	lrPath <- runServerChecks api $ ServerState 0 rq
	case lrPath of
	 Left err -> respondError status404 [] err
	 Right lrMethod ->
		case lrMethod of
		 Left err -> respondError status405 [] err
		 Right lrBasicAuth ->
			case lrBasicAuth of
			 Left err ->
				case failError err of
				 [] -> respondError status500 [] err
				 ServerErrorBasicAuth realm ba:_ ->
					case ba of
					 BasicAuth_Unauthorized ->
						respondError status403 [] err
					 _ ->
						respondError status401
						 [ ( HTTP.hWWWAuthenticate
						   , "Basic realm=\""<>Web.toHeader realm<>"\""
						   ) ] 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 ServerResponse app = a2k handlers in
									app rq 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 mimePlainText)
		 : 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'
data ServerState = ServerState
 { serverState_offset  :: Offset -- TODO: remove
 , serverState_request :: Wai.Request
 } -- deriving (Show)
type Offset = Int

instance Show ServerState where
	show _ = "ServerState"

type instance HttpApiData Server = Web.FromHttpApiData
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.
	-- A copy/paste/adapt will do for now.
	Server x <.> Server y = Server $
		S.StateT $ \st -> do
			xPath <- liftIO $ runServerChecks x st
			case xPath of
			 Left xe -> MC.throw xe
			 Right xMethod ->
				case xMethod of
				 Left xe -> do
					yPath <- liftIO $ 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 <- liftIO $ 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 <- liftIO $ 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 <- liftIO $ 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 <- liftIO $ 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 <- liftIO $ 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 <- liftIO $ 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
	Server x <!> Server y = Server $
		S.StateT $ \st -> do
			xPath <- liftIO $ runServerChecks x st
			yPath <- liftIO $ runServerChecks 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 $ 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 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 ->
						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 ->
							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 ->
								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 ->
									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 ->
										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 ->
											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'
data ServerErrorPath = ServerErrorPath Offset Text
 deriving (Eq, Show)
instance HTTP_Path Server where
	segment expSegment = Server $ do
		st@ServerState
		 { serverState_offset  = o
		 , serverState_request = req
		 } <- S.get
		case Wai.pathInfo req of
		 []   -> MC.throw $ Fail st [ServerErrorPath o "segment: empty"]
		 [""] -> MC.throw $ Fail st [ServerErrorPath o "trailing slash"]
		 curr:next
		  | curr /= expSegment ->
			MC.throw $ Fail st [ServerErrorPath o $ "expected: "<>expSegment<>" but got: "<>curr]
		  | otherwise -> do
			S.put st
			 { serverState_offset  = o+1
			 , serverState_request = req{ Wai.pathInfo = next }
			 }
			return id
	capture' :: forall a k. HttpApiData Server a => Name -> Server (a -> k) k
	capture' name = Server $ do
		st@ServerState
		 { serverState_offset  = o
		 , serverState_request = req
		 } <- S.get
		case Wai.pathInfo req of
		 []   -> MC.throw $ Fail st [ServerErrorPath o "empty"]
		 [""] -> MC.throw $ Fail st [ServerErrorPath o "trailing slash"]
		 curr:next ->
			case Web.parseUrlPiece curr of
			 Left err -> MC.throw $ Fail st [ServerErrorPath o $ "capture: "<>fromString name<>": "<>err]
			 Right a -> do
				S.put st
				 { serverState_offset  = o+1
				 , 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
  [MediaType]
  (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
	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)

-- ** Type 'ServerErrorBasicAuth'
data ServerErrorBasicAuth =
     ServerErrorBasicAuth BasicAuthRealm (BasicAuth ())
 deriving (Show)

-- ** Class 'ServerBasicAuth'
class ServerBasicAuth a where
	serverBasicAuth ::
	 BasicAuthUser ->
	 BasicAuthPass ->
	 IO (BasicAuth a)

data Dict a where Dict :: a => Dict a

-- | WARNING: current implementation of Basic Access Authentication
-- is not immune to certian kinds of timing attacks.
-- Decoding payloads does not take a fixed amount of time.
instance HTTP_BasicAuth Server where
	type BasicAuthConstraint Server = ServerBasicAuth
	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
			liftIO (serverBasicAuth user pass) >>= \case
			 BasicAuth_BadPassword  -> err BasicAuth_BadPassword
			 BasicAuth_NoSuchUser   -> err BasicAuth_NoSuchUser
			 BasicAuth_Unauthorized -> err BasicAuth_Unauthorized
			 BasicAuth_Authorized a -> return ($ a)
		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 a (ts::[*]) = ServerBodyArg a

instance HTTP_Body Server where
	type BodyArg Server = ServerBodyArg
	type BodyConstraint Server a ts = MimeTypes ts (MimeDecodable 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 <- liftIO $ Wai.requestBody $ serverState_request st
				return $ Right $ Right $ Right $
					-- NOTE: delay unSerialize after all checks
					case mimeDecode mt $ BSL.fromStrict bodyBS of
					 Left err -> Left $ Fail st [ServerErrorBody err]
					 Right a -> Right ($ ServerBodyArg a)

-- ** Type 'ServerResponse'
newtype ServerResponse = ServerResponse
 ( -- the request made to the server
   Wai.Request ->
   -- the continuation for the server to respond
   (Wai.Response -> IO Wai.ResponseReceived) ->
   IO Wai.ResponseReceived
 )
instance Show ServerResponse where
	show _ = "ServerResponse"

-- *** Type 'ServerRespond'
newtype ServerRespond a (ts::[*]) = ServerRespond
  (HTTP.Status ->
   HTTP.ResponseHeaders ->
   a -> Wai.Response)

instance HTTP_Response Server where
	type ResponseConstraint Server a ts = MimeTypes ts (MimeEncodable a)
	type ResponseArgs       Server a ts = ServerRespond a ts -> ServerResponse
	type Response           Server a ts = ServerResponse
	response ::
	 forall a ts repr.
	 ResponseConstraint repr a ts =>
	 repr ~ Server =>
	 HTTP.Method ->
	 repr (ResponseArgs repr a ts)
	      (Response repr a ts)
	response expMethod = Server $ do
		st@ServerState
		 { serverState_offset  = o
		 , serverState_request = req
		 } <- S.get
		
		-- Check the path has been fully consumed
		unless (List.null $ Wai.pathInfo req) $
			MC.throw $ Fail st [ServerErrorPath o "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 $ List.head $ listMimeTypes @ts @(MimeEncodable a)
			 Just h ->
				case matchAccept @ts @(MimeEncodable a) h of
				 Nothing -> MC.throw $ Fail st [ServerErrorAccept (listMediaTypes @ts @(MimeEncodable a)) (Just (Left h))]
				 Just mt -> return mt
				{-
				case Media.parseAccept h of
				 Nothing -> MC.throw $ Fail st [ServerErrorAccept (mediaType expAccept) (Just (Left h))]
				 Just gotAccept
				  | mediaType expAccept`Media.matches`gotAccept -> return expAccept
					-- FIXME: return gotAccept, maybe with GADTs
				  | otherwise -> MC.throw $ Fail st
					 [ServerErrorAccept (mediaType expAccept) (Just (Right gotAccept))]
				-}
		
		-- Respond
		return ($ ServerRespond $ \s hs a ->
			Wai.responseLBS s
			 ((HTTP.hContentType, Media.renderHeader $ mediaType reqAccept):hs)
			 (if reqMethod == HTTP.methodHead
				then ""
				else mimeEncode reqAccept a))

-- * Status
status200 :: HTTP.Status
status200 = HTTP.mkStatus 200 "Success"
status400 :: HTTP.Status
status400 = HTTP.mkStatus 400 "Bad Request"
status401 :: HTTP.Status
status401 = HTTP.mkStatus 401 "Unauthorized"
status403 :: HTTP.Status
status403 = HTTP.mkStatus 403 "Forbidden"
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"
status415 :: HTTP.Status
status415 = HTTP.mkStatus 415 "Unsupported Media Type"
status500 :: HTTP.Status
status500 = HTTP.mkStatus 500 "Server Error"

-- * Utils
liftIO :: MC.MonadExec IO m => IO a -> m a
liftIO = MC.exec
{-# INLINE liftIO #-}