{-# LANGUAGE GADTs #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-- | See <https://hackage.haskell.org/package/symantic-http-demo symantic-http-demo>
-- for an example of how to use this module.
module Symantic.HTTP.Server where

import Control.Arrow (first)
import Control.Applicative (Applicative(..))
import Control.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.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.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' responses k@ is a recipe to produce an 'Wai.Application'
-- from arguments 'responses' (one per number of alternative routes),
-- separated by (':!:').
--
-- 'Server' is analogous to a scanf using a format customized for HTTP routing.
--
-- The multiple 'ServerCheckT' monad transformers are there
-- to prioritize the errors according to the type of check raising them,
-- instead of the order of the combinators within an actual API specification.
newtype Server responses k = Server { unServer ::
        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))))))))
         (responses -> k)
 } deriving (Functor)

-- | @'server' api responses@ returns a 'Wai.Application'
-- ready to be given to @Warp.run 80@.
server ::
 Server responses (Response Server) ->
 responses ->
 Wai.Application
server (Server api) responses rq re = do
        lrPath <- runServerChecks 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 responses 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 @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
 }
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
        Server x <!> Server y = Server $
                S.StateT $ \st -> do
                        xPath <- MC.exec @IO $ runServerChecks x st
                        yPath <- MC.exec @IO $ runServerChecks y st
                        let fy = (first (\b2k (_a:!:b) -> b2k b) <$>)
                        case xPath of
                         Left xe | FailFatal{} <- xe -> MC.throw xe
                                 | otherwise ->
                                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'
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)

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

-- ** Class 'ServerBasicAuth'
class ServerBasicAuth a where
        serverBasicAuth ::
         BasicAuthUser ->
         BasicAuthPass ->
         IO (BasicAuth 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 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 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 (ts::[*]) 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::[*]) 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::[*]) 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::[*]) 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.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 = (<>)