{-# LANGUAGE GADTs #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
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
newtype Server handlers k = Server { unServer ::
S.StateT ServerState
(ServerCheckT [ServerErrorBody]
(ServerCheckT [ServerErrorHeader]
(ServerCheckT [ServerErrorQuery]
(ServerCheckT [ServerErrorContentType]
(ServerCheckT [ServerErrorAccept]
(ServerCheckT [ServerErrorBasicAuth]
(ServerCheckT [ServerErrorMethod]
(ServerCheckT [ServerErrorPath]
IO))))))))
(handlers -> k)
}
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 =
re $ Wai.responseLBS st
( (HTTP.hContentType, Media.renderHeader $ mediaType @PlainText)
: hs
) (fromString $ show err)
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 e = ExceptT (Fail e)
type RouteResult e = Either (Fail e)
data Fail e
= Fail ServerState e
| FailFatal !ServerState !e
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)
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
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
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
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)
data ServerErrorMethod = ServerErrorMethod
deriving (Eq, Show)
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]
data ServerErrorAccept =
ServerErrorAccept
MediaTypes
(Maybe (Either BS.ByteString MediaType))
deriving (Eq, Show)
data ServerErrorContentType = ServerErrorContentType
deriving (Eq, Show)
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)
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
data ServerErrorBasicAuth =
ServerErrorBasicAuth BasicAuthRealm (BasicAuth ())
deriving (Show)
class ServerBasicAuth a where
serverBasicAuth ::
BasicAuthUser ->
BasicAuthPass ->
IO (BasicAuth a)
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
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)
newtype ServerErrorBody = ServerErrorBody String
deriving (Eq, Show)
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 =
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 $
case mimeDecode mt $ BSL.fromStrict bodyBS of
Left err -> Left $ Fail st [ServerErrorBody err]
Right a -> Right ($ ServerBodyArg a)
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 =
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
)
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
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
unless (List.null $ Wai.pathInfo req) $
MC.throw $ Fail st [ServerErrorPath "path is longer"]
let reqMethod = Wai.requestMethod $ serverState_request st
unless (reqMethod == expMethod
|| reqMethod == HTTP.methodHead
&& expMethod == HTTP.methodGet) $
MC.throw $ Fail st [ServerErrorMethod]
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 $
Wai.responseLBS sta
((HTTP.hContentType, Media.renderHeader $ mediaTypeFor reqAccept):hs)
(if reqMethod == HTTP.methodHead
then ""
else mimeEncode reqAccept a)
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))))
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
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
unless (List.null $ Wai.pathInfo req) $
MC.throw $ Fail st [ServerErrorPath "path is longer"]
let reqMethod = Wai.requestMethod $ serverState_request st
unless (reqMethod == expMethod
|| reqMethod == HTTP.methodHead
&& expMethod == HTTP.methodGet) $
MC.throw $ Fail st [ServerErrorMethod]
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 $
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
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
rank 405 = 1
rank 401 = 2
rank 415 = 3
rank 406 = 4
rank 400 = 5
rank _ = 6
instance Monoid HTTP.Status where
mempty = HTTP.status200
mappend = (<>)
data Router repr a b where
Router_Any :: repr a b -> Router repr a b
Router_Seg :: PathSegment -> Router repr k k
Router_Cat :: Router repr a b -> Router repr b c -> Router repr a c
Router_Map :: Map.Map PathSegment (Router repr a k) -> Router repr a k
Router_Alt :: Router repr a k -> Router repr b k -> Router repr (a:!:b) k
Router_Cap :: PathConstraint Server a => Name -> Router repr (a->k) k
Router_Caps :: Captures (Router repr) cs k -> Router repr (AltFromBinTree cs) k
Router_Union :: (b->a) -> Router repr a k -> Router repr b k
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
data BinTree a
= BinTree0 a
| BinTree2 (BinTree a) (BinTree a)
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 repr where
routing :: Map.Map PathSegment (repr a k) -> repr a k
captures :: Captures repr cs k -> repr (AltFromBinTree cs) k
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
router :: Router repr a b -> Router repr a b
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 ->
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)
router_Alt ::
Router repr a k ->
Router repr b k ->
Router repr (a:!:b) k
router_Alt = go
where
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
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
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
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
xy -> xy`router_Alt`z'
yz -> Router_Union (\((a:!:b):!:c) -> a:!:(b:!:c)) $ x`router_Alt`yz
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)
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 =
Router_Map $
Map.merge
(Map.traverseMissing $ const $ \case
Router_Union u r ->
return $ Router_Union (\(x:!:_y) -> u x) r
r -> return $ Router_Union (\(x:!:_y) -> x) r)
(Map.traverseMissing $ const $ \case
Router_Union u r ->
return $ Router_Union (\(_x:!:y) -> u y) r
r -> return $ Router_Union (\(_x:!:y) -> y) r)
(Map.zipWithAMatched $ const $ \case
Router_Union xu xr -> \case
Router_Union yu yr ->
return $ Router_Union (\(x:!:y) -> xu x:!:yu y) $ xr`router_Alt`yr
yr ->
return $ Router_Union (\(a:!:b) -> xu a:!:b) $ xr`router_Alt`yr
xr -> \case
Router_Union yu yr ->
return $ Router_Union (\(a:!:b) -> a:!:yu b) $ xr`router_Alt`yr
yr -> return $ xr`router_Alt`yr)
xs ys