-- This file is part of the Wire Server implementation.
--
-- Copyright (C) 2022 Wire Swiss GmbH <opensource@wire.com>
--
-- This program is free software: you can redistribute it and/or modify it under
-- the terms of the GNU Affero General Public License as published by the Free
-- Software Foundation, either version 3 of the License, or (at your option) any
-- later version.
--
-- This program is distributed in the hope that it will be useful, but WITHOUT
-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more
-- details.
--
-- You should have received a copy of the GNU Affero General Public License along
-- with this program. If not, see <https://www.gnu.org/licenses/>.

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

-- | Used as the return type of a streaming handler. The 'Codensity' wrapper
-- makes it possible to add finalisation logic to the streaming action.
type LowLevelStreamingBody = Codensity IO StreamingBody

-- FUTUREWORK: make it possible to generate headers at runtime
data LowLevelStream method status (headers :: [(Symbol, Symbol)]) desc ctype

class RenderHeaders (headers :: [(Symbol, Symbol)]) where
  renderHeaders :: [(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 = []