-- 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.WebSocket where

import Control.Lens
import Control.Monad.Trans.Resource
import Data.HashMap.Strict.InsOrd
import Data.Metrics.Servant
import Data.OpenApi hiding (HasServer)
import Data.Proxy
import Imports
import Network.Wai.Handler.WebSockets
import Network.WebSockets
import Servant.OpenApi
import Servant.Server hiding (respond)
import Servant.Server.Internal.Delayed
import Servant.Server.Internal.RouteResult
import Servant.Server.Internal.Router
import Wire.API.Routes.Version

-- | A websocket that relates to a 'PendingConnection'
-- Copied and adapted from: <https://hackage.haskell.org/package/servant-websockets-2.0.0/docs/Servant-API-WebSocket.html#t:WebSocketPending>
data WebSocketPending

instance HasServer WebSocketPending ctx where
  type ServerT WebSocketPending m = PendingConnection -> m ()

  hoistServerWithContext :: forall (m :: * -> *) (n :: * -> *).
Proxy WebSocketPending
-> Proxy ctx
-> (forall x. m x -> n x)
-> ServerT WebSocketPending m
-> ServerT WebSocketPending n
hoistServerWithContext Proxy WebSocketPending
_ Proxy ctx
_ forall x. m x -> n x
nat ServerT WebSocketPending m
svr = m () -> n ()
forall x. m x -> n x
nat (m () -> n ())
-> (PendingConnection -> m ()) -> PendingConnection -> n ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerT WebSocketPending m
PendingConnection -> m ()
svr

  route :: forall env.
Proxy WebSocketPending
-> Context ctx
-> Delayed env (Server WebSocketPending)
-> Router env
route Proxy WebSocketPending
Proxy Context ctx
_ Delayed env (Server WebSocketPending)
app = (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 ->
    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
$
      Delayed env (PendingConnection -> Handler ())
-> env
-> Request
-> ResourceT IO (RouteResult (PendingConnection -> Handler ()))
forall env a.
Delayed env a -> env -> Request -> ResourceT IO (RouteResult a)
runDelayed Delayed env (Server WebSocketPending)
Delayed env (PendingConnection -> Handler ())
app env
env Request
request ResourceT IO (RouteResult (PendingConnection -> Handler ()))
-> (RouteResult (PendingConnection -> Handler ())
    -> ResourceT IO ResponseReceived)
-> ResourceT IO ResponseReceived
forall a b.
ResourceT IO a -> (a -> ResourceT IO b) -> ResourceT IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= 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)
-> (RouteResult (PendingConnection -> Handler ())
    -> IO ResponseReceived)
-> RouteResult (PendingConnection -> Handler ())
-> ResourceT IO ResponseReceived
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request
-> (RouteResult Response -> IO ResponseReceived)
-> RouteResult (PendingConnection -> Handler ())
-> IO ResponseReceived
forall {a}.
Request
-> (RouteResult Response -> IO ResponseReceived)
-> RouteResult (PendingConnection -> Handler a)
-> IO ResponseReceived
go Request
request RouteResult Response -> IO ResponseReceived
respond
    where
      go :: Request
-> (RouteResult Response -> IO ResponseReceived)
-> RouteResult (PendingConnection -> Handler a)
-> IO ResponseReceived
go Request
request RouteResult Response -> IO ResponseReceived
respond (Route PendingConnection -> Handler a
app') =
        ConnectionOptions -> ServerApp -> Application -> Application
websocketsOr ConnectionOptions
defaultConnectionOptions ((PendingConnection -> Handler a) -> ServerApp
forall {t} {a}. (t -> Handler a) -> t -> IO ()
runApp PendingConnection -> Handler a
app') ((RouteResult Response -> IO ResponseReceived) -> Application
forall {a} {b} {p} {p}. (RouteResult a -> b) -> p -> p -> b
backupApp RouteResult Response -> IO ResponseReceived
respond) Request
request (RouteResult Response -> IO ResponseReceived
respond (RouteResult Response -> IO ResponseReceived)
-> (Response -> RouteResult Response)
-> Response
-> IO ResponseReceived
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response -> RouteResult Response
forall a. a -> RouteResult a
Route)
      go Request
_ RouteResult Response -> IO ResponseReceived
respond (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
      go Request
_ RouteResult Response -> IO ResponseReceived
respond (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

      runApp :: (t -> Handler a) -> t -> IO ()
runApp t -> Handler a
a t
c = IO (Either ServerError a) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Handler a -> IO (Either ServerError a)
forall a. Handler a -> IO (Either ServerError a)
runHandler (Handler a -> IO (Either ServerError a))
-> Handler a -> IO (Either ServerError a)
forall a b. (a -> b) -> a -> b
$ t -> Handler a
a t
c)

      backupApp :: (RouteResult a -> b) -> p -> p -> b
backupApp RouteResult a -> b
respond p
_ p
_ =
        RouteResult a -> b
respond (RouteResult a -> b) -> RouteResult a -> b
forall a b. (a -> b) -> a -> b
$
          ServerError -> RouteResult a
forall a. ServerError -> RouteResult a
FailFatal
            ServerError
              { errHTTPCode :: Int
errHTTPCode = Int
426,
                errReasonPhrase :: String
errReasonPhrase = String
"Upgrade Required",
                errBody :: ByteString
errBody = ByteString
forall a. Monoid a => a
mempty,
                errHeaders :: [Header]
errHeaders = [Header]
forall a. Monoid a => a
mempty
              }

type instance SpecialiseToVersion v WebSocketPending = WebSocketPending

instance HasOpenApi WebSocketPending where
  toOpenApi :: Proxy WebSocketPending -> OpenApi
toOpenApi Proxy WebSocketPending
_ =
    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)
paths
        ((InsOrdHashMap String PathItem
  -> Identity (InsOrdHashMap String PathItem))
 -> OpenApi -> Identity OpenApi)
-> ((Maybe (IxValue (InsOrdHashMap String PathItem))
     -> Identity (Maybe (IxValue (InsOrdHashMap String PathItem))))
    -> InsOrdHashMap String PathItem
    -> Identity (InsOrdHashMap String PathItem))
-> (Maybe (IxValue (InsOrdHashMap String PathItem))
    -> Identity (Maybe (IxValue (InsOrdHashMap String 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 (IxValue (InsOrdHashMap String PathItem))))
 -> OpenApi -> Identity OpenApi)
-> IxValue (InsOrdHashMap String PathItem) -> OpenApi -> OpenApi
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ ( IxValue (InsOrdHashMap String PathItem)
forall a. Monoid a => a
mempty
               IxValue (InsOrdHashMap String PathItem)
-> (IxValue (InsOrdHashMap String PathItem)
    -> IxValue (InsOrdHashMap String PathItem))
-> IxValue (InsOrdHashMap String PathItem)
forall a b. a -> (a -> b) -> b
& (Maybe Operation -> Identity (Maybe Operation))
-> IxValue (InsOrdHashMap String PathItem)
-> Identity (IxValue (InsOrdHashMap String PathItem))
forall s a. HasGet s a => Lens' s a
Lens' (IxValue (InsOrdHashMap String PathItem)) (Maybe Operation)
get
                 ((Maybe Operation -> Identity (Maybe Operation))
 -> IxValue (InsOrdHashMap String PathItem)
 -> Identity (IxValue (InsOrdHashMap String PathItem)))
-> Operation
-> IxValue (InsOrdHashMap String PathItem)
-> IxValue (InsOrdHashMap String 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
responses ((Responses -> Identity Responses)
 -> Operation -> Identity Operation)
-> ((InsOrdHashMap Int (Referenced Response)
     -> Identity (InsOrdHashMap Int (Referenced Response)))
    -> Responses -> Identity Responses)
-> (InsOrdHashMap Int (Referenced Response)
    -> Identity (InsOrdHashMap Int (Referenced Response)))
-> Operation
-> Identity Operation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (InsOrdHashMap Int (Referenced Response)
 -> Identity (InsOrdHashMap Int (Referenced Response)))
-> Responses -> Identity Responses
forall s a. HasResponses s a => Lens' s a
Lens' Responses (InsOrdHashMap Int (Referenced Response))
responses ((InsOrdHashMap Int (Referenced Response)
  -> Identity (InsOrdHashMap Int (Referenced Response)))
 -> Operation -> Identity Operation)
-> InsOrdHashMap Int (Referenced Response)
-> Operation
-> Operation
forall s t a b. ASetter s t a b -> b -> s -> t
.~ InsOrdHashMap Int (Referenced Response)
resps
                        Operation -> (Operation -> Operation) -> Operation
forall a b. a -> (a -> b) -> b
& (Maybe ExternalDocs -> Identity (Maybe ExternalDocs))
-> Operation -> Identity Operation
forall s a. HasExternalDocs s a => Lens' s a
Lens' Operation (Maybe ExternalDocs)
externalDocs
                          ((Maybe ExternalDocs -> Identity (Maybe ExternalDocs))
 -> Operation -> Identity Operation)
-> ExternalDocs -> Operation -> Operation
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ ( ExternalDocs
forall a. Monoid a => a
mempty
                                 ExternalDocs -> (ExternalDocs -> ExternalDocs) -> ExternalDocs
forall a b. a -> (a -> b) -> b
& (Maybe Text -> Identity (Maybe Text))
-> ExternalDocs -> Identity ExternalDocs
forall s a. HasDescription s a => Lens' s a
Lens' ExternalDocs (Maybe Text)
description ((Maybe Text -> Identity (Maybe Text))
 -> ExternalDocs -> Identity ExternalDocs)
-> Text -> ExternalDocs -> ExternalDocs
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Text
"RFC 6455"
                                 ExternalDocs -> (ExternalDocs -> ExternalDocs) -> ExternalDocs
forall a b. a -> (a -> b) -> b
& (URL -> Identity URL) -> ExternalDocs -> Identity ExternalDocs
forall s a. HasUrl s a => Lens' s a
Lens' ExternalDocs URL
url ((URL -> Identity URL) -> ExternalDocs -> Identity ExternalDocs)
-> URL -> ExternalDocs -> ExternalDocs
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Text -> URL
URL Text
"https://datatracker.ietf.org/doc/html/rfc6455"
                             )
                    )
           )
    where
      resps :: InsOrdHashMap HttpStatusCode (Referenced Data.OpenApi.Response)
      resps :: InsOrdHashMap Int (Referenced Response)
resps =
        InsOrdHashMap Int (Referenced Response)
forall a. Monoid a => a
mempty
          InsOrdHashMap Int (Referenced Response)
-> (InsOrdHashMap Int (Referenced Response)
    -> InsOrdHashMap Int (Referenced Response))
-> InsOrdHashMap Int (Referenced Response)
forall a b. a -> (a -> b) -> b
& Index (InsOrdHashMap Int (Referenced Response))
-> Lens'
     (InsOrdHashMap Int (Referenced Response))
     (Maybe (IxValue (InsOrdHashMap Int (Referenced Response))))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Int
Index (InsOrdHashMap Int (Referenced Response))
101 ((Maybe (Referenced Response)
  -> Identity (Maybe (Referenced Response)))
 -> InsOrdHashMap Int (Referenced Response)
 -> Identity (InsOrdHashMap Int (Referenced Response)))
-> Referenced Response
-> InsOrdHashMap Int (Referenced Response)
-> InsOrdHashMap Int (Referenced Response)
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Response -> Referenced Response
forall a. a -> Referenced a
Inline (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
description ((Text -> Identity Text) -> Response -> Identity Response)
-> Text -> Response -> Response
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Text
"Connection upgraded.")
          InsOrdHashMap Int (Referenced Response)
-> (InsOrdHashMap Int (Referenced Response)
    -> InsOrdHashMap Int (Referenced Response))
-> InsOrdHashMap Int (Referenced Response)
forall a b. a -> (a -> b) -> b
& Index (InsOrdHashMap Int (Referenced Response))
-> Lens'
     (InsOrdHashMap Int (Referenced Response))
     (Maybe (IxValue (InsOrdHashMap Int (Referenced Response))))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Int
Index (InsOrdHashMap Int (Referenced Response))
426 ((Maybe (Referenced Response)
  -> Identity (Maybe (Referenced Response)))
 -> InsOrdHashMap Int (Referenced Response)
 -> Identity (InsOrdHashMap Int (Referenced Response)))
-> Referenced Response
-> InsOrdHashMap Int (Referenced Response)
-> InsOrdHashMap Int (Referenced Response)
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Response -> Referenced Response
forall a. a -> Referenced a
Inline (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
description ((Text -> Identity Text) -> Response -> Identity Response)
-> Text -> Response -> Response
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Text
"Upgrade required.")

instance RoutesToPaths WebSocketPending where
  getRoutes :: Forest PathSegment
getRoutes = []