module Wire.API.Routes.LowLevelStream where
import Control.Lens (at, (.~), (?~), _Just)
import Control.Monad.Codensity
import Control.Monad.Trans.Resource
import Data.ByteString.Char8 as B8
import Data.CaseInsensitive qualified as CI
import Data.HashMap.Strict.InsOrd qualified as InsOrdHashMap
import Data.Metrics.Servant
import Data.OpenApi qualified as S
import Data.Proxy
import Data.Text qualified as Text
import GHC.TypeLits
import Imports
import Network.HTTP.Media qualified as HTTP
import Network.HTTP.Types
import Network.Wai
import Servant.API
import Servant.API.ContentTypes
import Servant.API.Status
import Servant.OpenApi as S
import Servant.OpenApi.Internal as S
import Servant.Server hiding (respond)
import Servant.Server.Internal
import Wire.API.Routes.Version
type LowLevelStreamingBody = Codensity IO StreamingBody
data LowLevelStream method status (headers :: [(Symbol, Symbol)]) desc ctype
class (headers :: [(Symbol, Symbol)]) where
:: [(HeaderName, ByteString)]
instance RenderHeaders '[] where
renderHeaders :: [(HeaderName, ByteString)]
renderHeaders = []
instance
(KnownSymbol name, KnownSymbol value, RenderHeaders headers) =>
RenderHeaders ('(name, value) ': headers)
where
renderHeaders :: [(HeaderName, ByteString)]
renderHeaders = (HeaderName
name, ByteString
value) (HeaderName, ByteString)
-> [(HeaderName, ByteString)] -> [(HeaderName, ByteString)]
forall a. a -> [a] -> [a]
: forall (headers :: [(Symbol, Symbol)]).
RenderHeaders headers =>
[(HeaderName, ByteString)]
renderHeaders @headers
where
name :: HeaderName
name :: HeaderName
name = ByteString -> HeaderName
forall s. FoldCase s => s -> CI s
CI.mk (String -> ByteString
B8.pack (Proxy name -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @name)))
value :: ByteString
value :: ByteString
value = String -> ByteString
B8.pack (Proxy value -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @value))
instance
(ReflectMethod method, KnownNat status, RenderHeaders headers, Accept ctype) =>
HasServer (LowLevelStream method status headers desc ctype) context
where
type
ServerT (LowLevelStream method status headers desc ctype) m =
m LowLevelStreamingBody
hoistServerWithContext :: forall (m :: * -> *) (n :: * -> *).
Proxy (LowLevelStream method status headers desc ctype)
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT (LowLevelStream method status headers desc ctype) m
-> ServerT (LowLevelStream method status headers desc ctype) n
hoistServerWithContext Proxy (LowLevelStream method status headers desc ctype)
_ Proxy context
_ forall x. m x -> n x
nt ServerT (LowLevelStream method status headers desc ctype) m
s = m LowLevelStreamingBody -> n LowLevelStreamingBody
forall x. m x -> n x
nt m LowLevelStreamingBody
ServerT (LowLevelStream method status headers desc ctype) m
s
route :: forall env.
Proxy (LowLevelStream method status headers desc ctype)
-> Context context
-> Delayed
env (Server (LowLevelStream method status headers desc ctype))
-> Router env
route Proxy (LowLevelStream method status headers desc ctype)
Proxy Context context
_ Delayed
env (Server (LowLevelStream method status headers desc ctype))
action = (env -> RoutingApplication) -> Router' env RoutingApplication
forall env a. (env -> a) -> Router' env a
leafRouter ((env -> RoutingApplication) -> Router' env RoutingApplication)
-> (env -> RoutingApplication) -> Router' env RoutingApplication
forall a b. (a -> b) -> a -> b
$ \env
env Request
request RouteResult Response -> IO ResponseReceived
respond ->
let AcceptHeader ByteString
accH = Request -> AcceptHeader
getAcceptHeader Request
request
cmediatype :: Maybe MediaType
cmediatype = [MediaType] -> ByteString -> Maybe MediaType
forall a. Accept a => [a] -> ByteString -> Maybe a
HTTP.matchAccept [Proxy ctype -> MediaType
forall {k} (ctype :: k). Accept ctype => Proxy ctype -> MediaType
contentType (forall (t :: k). Proxy t
forall {k} (t :: k). Proxy t
Proxy @ctype)] ByteString
accH
accCheck :: DelayedIO ()
accCheck = Bool -> DelayedIO () -> DelayedIO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe MediaType -> Bool
forall a. Maybe a -> Bool
isNothing Maybe MediaType
cmediatype) (DelayedIO () -> DelayedIO ()) -> DelayedIO () -> DelayedIO ()
forall a b. (a -> b) -> a -> b
$ ServerError -> DelayedIO ()
forall a. ServerError -> DelayedIO a
delayedFail ServerError
err406
contentHeader :: (HeaderName, ByteString)
contentHeader = (HeaderName
hContentType, [MediaType] -> ByteString
forall h. RenderHeader h => h -> ByteString
HTTP.renderHeader ([MediaType] -> ByteString)
-> (Maybe MediaType -> [MediaType])
-> Maybe MediaType
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe MediaType -> [MediaType]
forall a. Maybe a -> [a]
maybeToList (Maybe MediaType -> ByteString) -> Maybe MediaType -> ByteString
forall a b. (a -> b) -> a -> b
$ Maybe MediaType
cmediatype)
in ResourceT IO ResponseReceived -> IO ResponseReceived
forall (m :: * -> *) a. MonadUnliftIO m => ResourceT m a -> m a
runResourceT (ResourceT IO ResponseReceived -> IO ResponseReceived)
-> ResourceT IO ResponseReceived -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ do
RouteResult (Handler LowLevelStreamingBody)
r <-
Delayed env (Handler LowLevelStreamingBody)
-> env
-> Request
-> ResourceT IO (RouteResult (Handler LowLevelStreamingBody))
forall env a.
Delayed env a -> env -> Request -> ResourceT IO (RouteResult a)
runDelayed
( Delayed env (Handler LowLevelStreamingBody)
Delayed
env (Server (LowLevelStream method status headers desc ctype))
action
Delayed env (Handler LowLevelStreamingBody)
-> DelayedIO () -> Delayed env (Handler LowLevelStreamingBody)
forall env a. Delayed env a -> DelayedIO () -> Delayed env a
`addMethodCheck` ByteString -> Request -> DelayedIO ()
methodCheck ByteString
method Request
request
Delayed env (Handler LowLevelStreamingBody)
-> DelayedIO () -> Delayed env (Handler LowLevelStreamingBody)
forall env a. Delayed env a -> DelayedIO () -> Delayed env a
`addAcceptCheck` DelayedIO ()
accCheck
)
env
env
Request
request
IO ResponseReceived -> ResourceT IO ResponseReceived
forall a. IO a -> ResourceT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ResponseReceived -> ResourceT IO ResponseReceived)
-> IO ResponseReceived -> ResourceT IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ case RouteResult (Handler LowLevelStreamingBody)
r of
Route Handler LowLevelStreamingBody
h ->
Handler LowLevelStreamingBody
-> IO (Either ServerError LowLevelStreamingBody)
forall a. Handler a -> IO (Either ServerError a)
runHandler Handler LowLevelStreamingBody
h IO (Either ServerError LowLevelStreamingBody)
-> (Either ServerError LowLevelStreamingBody
-> IO ResponseReceived)
-> IO ResponseReceived
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Left ServerError
e -> RouteResult Response -> IO ResponseReceived
respond (RouteResult Response -> IO ResponseReceived)
-> RouteResult Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ ServerError -> RouteResult Response
forall a. ServerError -> RouteResult a
FailFatal ServerError
e
Right LowLevelStreamingBody
getStreamingBody -> Codensity IO ResponseReceived -> IO ResponseReceived
forall (f :: * -> *) a. Applicative f => Codensity f a -> f a
lowerCodensity (Codensity IO ResponseReceived -> IO ResponseReceived)
-> Codensity IO ResponseReceived -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ do
StreamingBody
body <- LowLevelStreamingBody
getStreamingBody
let resp :: Response
resp = Status -> [(HeaderName, ByteString)] -> StreamingBody -> Response
responseStream Status
status ((HeaderName, ByteString)
contentHeader (HeaderName, ByteString)
-> [(HeaderName, ByteString)] -> [(HeaderName, ByteString)]
forall a. a -> [a] -> [a]
: [(HeaderName, ByteString)]
extraHeaders) StreamingBody
body
IO ResponseReceived -> Codensity IO ResponseReceived
forall (m :: * -> *) a. Monad m => m a -> Codensity m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO ResponseReceived -> Codensity IO ResponseReceived)
-> IO ResponseReceived -> Codensity IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ RouteResult Response -> IO ResponseReceived
respond (RouteResult Response -> IO ResponseReceived)
-> RouteResult Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ Response -> RouteResult Response
forall a. a -> RouteResult a
Route Response
resp
Fail ServerError
e -> RouteResult Response -> IO ResponseReceived
respond (RouteResult Response -> IO ResponseReceived)
-> RouteResult Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ ServerError -> RouteResult Response
forall a. ServerError -> RouteResult a
Fail ServerError
e
FailFatal ServerError
e -> RouteResult Response -> IO ResponseReceived
respond (RouteResult Response -> IO ResponseReceived)
-> RouteResult Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ ServerError -> RouteResult Response
forall a. ServerError -> RouteResult a
FailFatal ServerError
e
where
method :: ByteString
method = Proxy method -> ByteString
forall {k} (a :: k). ReflectMethod a => Proxy a -> ByteString
reflectMethod (Proxy method
forall {k} (t :: k). Proxy t
Proxy :: Proxy method)
status :: Status
status = Proxy status -> Status
forall (a :: Nat) (proxy :: Nat -> *).
KnownNat a =>
proxy a -> Status
statusFromNat (Proxy status
forall {k} (t :: k). Proxy t
Proxy :: Proxy status)
extraHeaders :: [(HeaderName, ByteString)]
extraHeaders = forall (headers :: [(Symbol, Symbol)]).
RenderHeaders headers =>
[(HeaderName, ByteString)]
renderHeaders @headers
type instance
SpecialiseToVersion v (LowLevelStream m s h d t) =
LowLevelStream m s h d t
instance
(S.ToSchema ctype, Accept ctype, KnownNat status, KnownSymbol desc, OpenApiMethod method) =>
HasOpenApi (LowLevelStream method status headers desc ctype)
where
toOpenApi :: Proxy (LowLevelStream method status headers desc ctype) -> OpenApi
toOpenApi Proxy (LowLevelStream method status headers desc ctype)
_ =
OpenApi
forall a. Monoid a => a
mempty
OpenApi -> (OpenApi -> OpenApi) -> OpenApi
forall a b. a -> (a -> b) -> b
& (InsOrdHashMap String PathItem
-> Identity (InsOrdHashMap String PathItem))
-> OpenApi -> Identity OpenApi
forall s a. HasPaths s a => Lens' s a
Lens' OpenApi (InsOrdHashMap String PathItem)
S.paths
((InsOrdHashMap String PathItem
-> Identity (InsOrdHashMap String PathItem))
-> OpenApi -> Identity OpenApi)
-> ((Maybe (IxValue (InsOrdHashMap String PathItem))
-> Identity (Maybe PathItem))
-> InsOrdHashMap String PathItem
-> Identity (InsOrdHashMap String PathItem))
-> (Maybe (IxValue (InsOrdHashMap String PathItem))
-> Identity (Maybe PathItem))
-> OpenApi
-> Identity OpenApi
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (InsOrdHashMap String PathItem)
-> Lens'
(InsOrdHashMap String PathItem)
(Maybe (IxValue (InsOrdHashMap String PathItem)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index (InsOrdHashMap String PathItem)
"/"
((Maybe (IxValue (InsOrdHashMap String PathItem))
-> Identity (Maybe PathItem))
-> OpenApi -> Identity OpenApi)
-> PathItem -> OpenApi -> OpenApi
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ ( PathItem
forall a. Monoid a => a
mempty
PathItem -> (PathItem -> PathItem) -> PathItem
forall a b. a -> (a -> b) -> b
& (Maybe Operation -> Identity (Maybe Operation))
-> PathItem -> Identity PathItem
method
((Maybe Operation -> Identity (Maybe Operation))
-> PathItem -> Identity PathItem)
-> Operation -> PathItem -> PathItem
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ ( Operation
forall a. Monoid a => a
mempty
Operation -> (Operation -> Operation) -> Operation
forall a b. a -> (a -> b) -> b
& (Responses -> Identity Responses)
-> Operation -> Identity Operation
forall s a. HasResponses s a => Lens' s a
Lens' Operation Responses
S.responses ((Responses -> Identity Responses)
-> Operation -> Identity Operation)
-> ((InsOrdHashMap HttpStatusCode (Referenced Response)
-> Identity (InsOrdHashMap HttpStatusCode (Referenced Response)))
-> Responses -> Identity Responses)
-> (InsOrdHashMap HttpStatusCode (Referenced Response)
-> Identity (InsOrdHashMap HttpStatusCode (Referenced Response)))
-> Operation
-> Identity Operation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (InsOrdHashMap HttpStatusCode (Referenced Response)
-> Identity (InsOrdHashMap HttpStatusCode (Referenced Response)))
-> Responses -> Identity Responses
forall s a. HasResponses s a => Lens' s a
Lens'
Responses (InsOrdHashMap HttpStatusCode (Referenced Response))
S.responses ((InsOrdHashMap HttpStatusCode (Referenced Response)
-> Identity (InsOrdHashMap HttpStatusCode (Referenced Response)))
-> Operation -> Identity Operation)
-> InsOrdHashMap HttpStatusCode (Referenced Response)
-> Operation
-> Operation
forall s t a b. ASetter s t a b -> b -> s -> t
.~ (Response -> Referenced Response)
-> InsOrdHashMap HttpStatusCode Response
-> InsOrdHashMap HttpStatusCode (Referenced Response)
forall a b.
(a -> b)
-> InsOrdHashMap HttpStatusCode a -> InsOrdHashMap HttpStatusCode b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Response -> Referenced Response
forall a. a -> Referenced a
S.Inline InsOrdHashMap HttpStatusCode Response
responses
)
)
where
method :: (Maybe Operation -> Identity (Maybe Operation))
-> PathItem -> Identity PathItem
method = Proxy method -> Lens' PathItem (Maybe Operation)
forall {k} (method :: k) (proxy :: k -> *).
OpenApiMethod method =>
proxy method -> Lens' PathItem (Maybe Operation)
forall (proxy :: k -> *).
proxy method -> Lens' PathItem (Maybe Operation)
S.openApiMethod (forall (t :: k). Proxy t
forall {k} (t :: k). Proxy t
Proxy @method)
responses :: InsOrdHashMap HttpStatusCode Response
responses =
HttpStatusCode -> Response -> InsOrdHashMap HttpStatusCode Response
forall k v. Hashable k => k -> v -> InsOrdHashMap k v
InsOrdHashMap.singleton
(Integer -> HttpStatusCode
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Proxy status -> Integer
forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Integer
natVal (forall (t :: Nat). Proxy t
forall {k} (t :: k). Proxy t
Proxy @status)))
(Response -> InsOrdHashMap HttpStatusCode Response)
-> Response -> InsOrdHashMap HttpStatusCode Response
forall a b. (a -> b) -> a -> b
$ Response
forall a. Monoid a => a
mempty
Response -> (Response -> Response) -> Response
forall a b. a -> (a -> b) -> b
& (Text -> Identity Text) -> Response -> Identity Response
forall s a. HasDescription s a => Lens' s a
Lens' Response Text
S.description ((Text -> Identity Text) -> Response -> Identity Response)
-> Text -> Response -> Response
forall s t a b. ASetter s t a b -> b -> s -> t
.~ String -> Text
Text.pack (Proxy desc -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @desc))
Response -> (Response -> Response) -> Response
forall a b. a -> (a -> b) -> b
& (InsOrdHashMap MediaType MediaTypeObject
-> Identity (InsOrdHashMap MediaType MediaTypeObject))
-> Response -> Identity Response
forall s a. HasContent s a => Lens' s a
Lens' Response (InsOrdHashMap MediaType MediaTypeObject)
S.content
((InsOrdHashMap MediaType MediaTypeObject
-> Identity (InsOrdHashMap MediaType MediaTypeObject))
-> Response -> Identity Response)
-> InsOrdHashMap MediaType MediaTypeObject -> Response -> Response
forall s t a b. ASetter s t a b -> b -> s -> t
.~ MediaType
-> MediaTypeObject -> InsOrdHashMap MediaType MediaTypeObject
forall k v. Hashable k => k -> v -> InsOrdHashMap k v
InsOrdHashMap.singleton
(Proxy ctype -> MediaType
forall {k} (ctype :: k). Accept ctype => Proxy ctype -> MediaType
contentType (Proxy ctype -> MediaType) -> Proxy ctype -> MediaType
forall a b. (a -> b) -> a -> b
$ forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @ctype)
(MediaTypeObject
forall a. Monoid a => a
mempty MediaTypeObject
-> (MediaTypeObject -> MediaTypeObject) -> MediaTypeObject
forall a b. a -> (a -> b) -> b
& (Maybe (Referenced Schema) -> Identity (Maybe (Referenced Schema)))
-> MediaTypeObject -> Identity MediaTypeObject
forall s a. HasSchema s a => Lens' s a
Lens' MediaTypeObject (Maybe (Referenced Schema))
S.schema ((Maybe (Referenced Schema)
-> Identity (Maybe (Referenced Schema)))
-> MediaTypeObject -> Identity MediaTypeObject)
-> ((Schema -> Identity Schema)
-> Maybe (Referenced Schema)
-> Identity (Maybe (Referenced Schema)))
-> (Schema -> Identity Schema)
-> MediaTypeObject
-> Identity MediaTypeObject
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Referenced Schema -> Identity (Referenced Schema))
-> Maybe (Referenced Schema)
-> Identity (Maybe (Referenced Schema))
forall a b (p :: * -> * -> *) (f :: * -> *).
(Choice p, Applicative f) =>
p a (f b) -> p (Maybe a) (f (Maybe b))
_Just ((Referenced Schema -> Identity (Referenced Schema))
-> Maybe (Referenced Schema)
-> Identity (Maybe (Referenced Schema)))
-> ((Schema -> Identity Schema)
-> Referenced Schema -> Identity (Referenced Schema))
-> (Schema -> Identity Schema)
-> Maybe (Referenced Schema)
-> Identity (Maybe (Referenced Schema))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Schema -> Identity Schema)
-> Referenced Schema -> Identity (Referenced Schema)
forall a1 a2 (p :: * -> * -> *) (f :: * -> *).
(Choice p, Applicative f) =>
p a1 (f a2) -> p (Referenced a1) (f (Referenced a2))
S._Inline ((Schema -> Identity Schema)
-> MediaTypeObject -> Identity MediaTypeObject)
-> Schema -> MediaTypeObject -> MediaTypeObject
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Proxy ctype -> Schema
forall a. ToSchema a => Proxy a -> Schema
S.toSchema (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @ctype))
instance RoutesToPaths (LowLevelStream method status headers desc ctype) where
getRoutes :: Forest PathSegment
getRoutes = []