module Wire.API.Routes.Internal.Gundeck where

import Control.Lens ((%~), (.~), (?~))
import Data.Aeson
import Data.CommaSeparatedList
import Data.HashMap.Strict.InsOrd qualified as InsOrdHashMap
import Data.Id
import Data.Metrics.Servant
import Data.OpenApi qualified as S hiding (HasServer, Header)
import Data.OpenApi.Declare qualified as S
import Data.Text qualified as Text
import Data.Typeable
import Imports
import Network.Wai
import Servant hiding (URI (..))
import Servant.API.Description
import Servant.OpenApi
import Servant.OpenApi.Internal
import Servant.Server.Internal.Delayed
import Servant.Server.Internal.DelayedIO
import Servant.Server.Internal.ErrorFormatter
import Wire.API.CannonId
import Wire.API.Presence
import Wire.API.Push.V2
import Wire.API.Routes.Public

-- | this can be replaced by `ReqBody '[JSON] Presence` once the fix in cannon from
-- https://github.com/wireapp/wire-server/pull/4246 has been deployed everywhere.
--
-- Background: Cannon.WS.regInfo called gundeck without setting the content-type header here.
-- wai-routes and wai-predicates were able to work with that; servant is less lenient.
data ReqBodyHack

-- | cloned from instance for ReqBody'.
instance
  ( HasServer api context,
    HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters
  ) =>
  HasServer (ReqBodyHack :> api) context
  where
  type ServerT (ReqBodyHack :> api) m = Presence -> ServerT api m

  hoistServerWithContext :: forall (m :: * -> *) (n :: * -> *).
Proxy (ReqBodyHack :> api)
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT (ReqBodyHack :> api) m
-> ServerT (ReqBodyHack :> api) n
hoistServerWithContext Proxy (ReqBodyHack :> api)
_ Proxy context
pc forall x. m x -> n x
nt ServerT (ReqBodyHack :> api) m
s = Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
forall {k} (api :: k) (context :: [*]) (m :: * -> *) (n :: * -> *).
HasServer api context =>
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
forall (m :: * -> *) (n :: * -> *).
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
hoistServerWithContext (Proxy api
forall {k} (t :: k). Proxy t
Proxy :: Proxy api) Proxy context
pc m x -> n x
forall x. m x -> n x
nt (ServerT api m -> ServerT api n)
-> (Presence -> ServerT api m) -> Presence -> ServerT api n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerT (ReqBodyHack :> api) m
Presence -> ServerT api m
s

  route :: forall env.
Proxy (ReqBodyHack :> api)
-> Context context
-> Delayed env (Server (ReqBodyHack :> api))
-> Router env
route Proxy (ReqBodyHack :> api)
Proxy Context context
context Delayed env (Server (ReqBodyHack :> api))
subserver =
    Proxy api
-> Context context -> Delayed env (Server api) -> Router env
forall env.
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
forall {k} (api :: k) (context :: [*]) env.
HasServer api context =>
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
route (Proxy api
forall {k} (t :: k). Proxy t
Proxy :: Proxy api) Context context
context (Delayed env (Server api) -> Router env)
-> Delayed env (Server api) -> Router env
forall a b. (a -> b) -> a -> b
$
      Delayed env (Presence -> Server api)
-> DelayedIO (ByteString -> Either String Presence)
-> ((ByteString -> Either String Presence) -> DelayedIO Presence)
-> Delayed env (Server api)
forall env a b c.
Delayed env (a -> b)
-> DelayedIO c -> (c -> DelayedIO a) -> Delayed env b
addBodyCheck Delayed env (Server (ReqBodyHack :> api))
Delayed env (Presence -> Server api)
subserver DelayedIO (ByteString -> Either String Presence)
ctCheck (ByteString -> Either String Presence) -> DelayedIO Presence
bodyCheck
    where
      rep :: TypeRep
rep = Proxy ReqBodyHack -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy ReqBodyHack
forall {k} (t :: k). Proxy t
Proxy :: Proxy ReqBodyHack)
      formatError :: ErrorFormatter
formatError = ErrorFormatters -> ErrorFormatter
bodyParserErrorFormatter (ErrorFormatters -> ErrorFormatter)
-> ErrorFormatters -> ErrorFormatter
forall a b. (a -> b) -> a -> b
$ Context (MkContextWithErrorFormatter context) -> ErrorFormatters
forall (context :: [*]) val.
HasContextEntry context val =>
Context context -> val
getContextEntry (Context context -> Context (MkContextWithErrorFormatter context)
forall (ctx :: [*]).
Context ctx -> Context (MkContextWithErrorFormatter ctx)
mkContextWithErrorFormatter Context context
context)

      ctCheck :: DelayedIO (ByteString -> Either String Presence)
ctCheck = (ByteString -> Either String Presence)
-> DelayedIO (ByteString -> Either String Presence)
forall a. a -> DelayedIO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString -> Either String Presence
forall a. FromJSON a => ByteString -> Either String a
eitherDecode

      -- Body check, we get a body parsing functions as the first argument.
      bodyCheck :: (ByteString -> Either String Presence) -> DelayedIO Presence
bodyCheck ByteString -> Either String Presence
f = (Request -> DelayedIO Presence) -> DelayedIO Presence
forall a. (Request -> DelayedIO a) -> DelayedIO a
withRequest ((Request -> DelayedIO Presence) -> DelayedIO Presence)
-> (Request -> DelayedIO Presence) -> DelayedIO Presence
forall a b. (a -> b) -> a -> b
$ \Request
request -> do
        Either String Presence
mrqbody <- ByteString -> Either String Presence
f (ByteString -> Either String Presence)
-> DelayedIO ByteString -> DelayedIO (Either String Presence)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO ByteString -> DelayedIO ByteString
forall a. IO a -> DelayedIO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Request -> IO ByteString
lazyRequestBody Request
request)
        case Either String Presence
mrqbody of
          Left String
e -> ServerError -> DelayedIO Presence
forall a. ServerError -> DelayedIO a
delayedFailFatal (ServerError -> DelayedIO Presence)
-> ServerError -> DelayedIO Presence
forall a b. (a -> b) -> a -> b
$ ErrorFormatter
formatError TypeRep
rep Request
request String
e
          Right Presence
v -> Presence -> DelayedIO Presence
forall a. a -> DelayedIO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Presence
v

-- | cloned from instance for ReqBody'.
instance (RoutesToPaths route) => RoutesToPaths (ReqBodyHack :> route) where
  getRoutes :: Forest PathSegment
getRoutes = forall route. RoutesToPaths route => Forest PathSegment
forall {k} (routes :: k).
RoutesToPaths routes =>
Forest PathSegment
getRoutes @route

-- | cloned from instance for ReqBody'.
instance (HasOpenApi sub) => HasOpenApi (ReqBodyHack :> sub) where
  toOpenApi :: Proxy (ReqBodyHack :> sub) -> OpenApi
toOpenApi Proxy (ReqBodyHack :> sub)
_ =
    Proxy sub -> OpenApi
forall {k} (api :: k). HasOpenApi api => Proxy api -> OpenApi
toOpenApi (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @sub)
      OpenApi -> (OpenApi -> OpenApi) -> OpenApi
forall a b. a -> (a -> b) -> b
& RequestBody -> OpenApi -> OpenApi
addRequestBody RequestBody
reqBody
      OpenApi -> (OpenApi -> OpenApi) -> OpenApi
forall a b. a -> (a -> b) -> b
& Text -> OpenApi -> OpenApi
addDefaultResponse400 Text
tname
      OpenApi -> (OpenApi -> OpenApi) -> OpenApi
forall a b. a -> (a -> b) -> b
& (Components -> Identity Components) -> OpenApi -> Identity OpenApi
forall s a. HasComponents s a => Lens' s a
Lens' OpenApi Components
S.components ((Components -> Identity Components)
 -> OpenApi -> Identity OpenApi)
-> ((Definitions Schema -> Identity (Definitions Schema))
    -> Components -> Identity Components)
-> (Definitions Schema -> Identity (Definitions Schema))
-> OpenApi
-> Identity OpenApi
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Definitions Schema -> Identity (Definitions Schema))
-> Components -> Identity Components
forall s a. HasSchemas s a => Lens' s a
Lens' Components (Definitions Schema)
S.schemas ((Definitions Schema -> Identity (Definitions Schema))
 -> OpenApi -> Identity OpenApi)
-> (Definitions Schema -> Definitions Schema) -> OpenApi -> OpenApi
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (Definitions Schema -> Definitions Schema -> Definitions Schema
forall a. Semigroup a => a -> a -> a
<> Definitions Schema
defs)
    where
      tname :: Text
tname = Text
"body"
      transDesc :: String -> Maybe Text
transDesc String
"" = Maybe Text
forall a. Maybe a
Nothing
      transDesc String
desc = Text -> Maybe Text
forall a. a -> Maybe a
Just (String -> Text
Text.pack String
desc)
      (Definitions Schema
defs, Referenced Schema
ref) = Declare (Definitions Schema) (Referenced Schema)
-> Definitions Schema -> (Definitions Schema, Referenced Schema)
forall d a. Declare d a -> d -> (d, a)
S.runDeclare (Proxy Presence -> Declare (Definitions Schema) (Referenced Schema)
forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) (Referenced Schema)
S.declareSchemaRef (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @Presence)) Definitions Schema
forall a. Monoid a => a
mempty
      reqBody :: RequestBody
reqBody =
        (RequestBody
forall a. Monoid a => a
mempty :: S.RequestBody)
          RequestBody -> (RequestBody -> RequestBody) -> RequestBody
forall a b. a -> (a -> b) -> b
& (Maybe Text -> Identity (Maybe Text))
-> RequestBody -> Identity RequestBody
forall s a. HasDescription s a => Lens' s a
Lens' RequestBody (Maybe Text)
S.description ((Maybe Text -> Identity (Maybe Text))
 -> RequestBody -> Identity RequestBody)
-> Maybe Text -> RequestBody -> RequestBody
forall s t a b. ASetter s t a b -> b -> s -> t
.~ String -> Maybe Text
transDesc (Proxy '[] -> String
forall (mods :: [*]).
KnownSymbol (FoldDescription mods) =>
Proxy mods -> String
reflectDescription (Proxy '[]
forall {k}. Proxy '[]
forall {k} (t :: k). Proxy t
Proxy :: Proxy '[]))
          RequestBody -> (RequestBody -> RequestBody) -> RequestBody
forall a b. a -> (a -> b) -> b
& (Maybe Bool -> Identity (Maybe Bool))
-> RequestBody -> Identity RequestBody
forall s a. HasRequired s a => Lens' s a
Lens' RequestBody (Maybe Bool)
S.required ((Maybe Bool -> Identity (Maybe Bool))
 -> RequestBody -> Identity RequestBody)
-> Bool -> RequestBody -> RequestBody
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Bool
True
          RequestBody -> (RequestBody -> RequestBody) -> RequestBody
forall a b. a -> (a -> b) -> b
& (InsOrdHashMap MediaType MediaTypeObject
 -> Identity (InsOrdHashMap MediaType MediaTypeObject))
-> RequestBody -> Identity RequestBody
forall s a. HasContent s a => Lens' s a
Lens' RequestBody (InsOrdHashMap MediaType MediaTypeObject)
S.content ((InsOrdHashMap MediaType MediaTypeObject
  -> Identity (InsOrdHashMap MediaType MediaTypeObject))
 -> RequestBody -> Identity RequestBody)
-> InsOrdHashMap MediaType MediaTypeObject
-> RequestBody
-> RequestBody
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [(MediaType, MediaTypeObject)]
-> InsOrdHashMap MediaType MediaTypeObject
forall k v. (Eq k, Hashable k) => [(k, v)] -> InsOrdHashMap k v
InsOrdHashMap.fromList [(MediaType
t, 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)
-> Referenced Schema -> MediaTypeObject -> MediaTypeObject
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Referenced Schema
ref) | MediaType
t <- Proxy '[JSON] -> [MediaType]
forall {k} (cs :: k). AllAccept cs => Proxy cs -> [MediaType]
allContentType (Proxy '[JSON]
forall {k} (t :: k). Proxy t
Proxy :: Proxy '[JSON])]

type InternalAPI =
  "i"
    :> ( ("status" :> Get '[JSON] NoContent)
           :<|> ("push" :> "v2" :> ReqBody '[JSON] [Push] :> Post '[JSON] NoContent)
           :<|> ( "presences"
                    :> ( (QueryParam' [Required, Strict] "ids" (CommaSeparatedList UserId) :> Get '[JSON] [Presence])
                           :<|> (Capture "uid" UserId :> Get '[JSON] [Presence])
                           :<|> (ReqBodyHack :> Verb 'POST 201 '[JSON] (Headers '[Header "Location" URI] NoContent))
                           :<|> (Capture "uid" UserId :> "devices" :> Capture "did" ConnId :> "cannons" :> Capture "cannon" CannonId :> Delete '[JSON] NoContent)
                       )
                )
           :<|> (ZUser :> "clients" :> Capture "cid" ClientId :> Delete '[JSON] NoContent)
           :<|> (ZUser :> "user" :> Delete '[JSON] NoContent)
           :<|> ("push-tokens" :> Capture "uid" UserId :> Get '[JSON] PushTokenList)
       )

swaggerDoc :: S.OpenApi
swaggerDoc :: OpenApi
swaggerDoc =
  Proxy InternalAPI -> OpenApi
forall {k} (api :: k). HasOpenApi api => Proxy api -> OpenApi
toOpenApi (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @InternalAPI)
    OpenApi -> (OpenApi -> OpenApi) -> OpenApi
forall a b. a -> (a -> b) -> b
& (Info -> Identity Info) -> OpenApi -> Identity OpenApi
forall s a. HasInfo s a => Lens' s a
Lens' OpenApi Info
S.info ((Info -> Identity Info) -> OpenApi -> Identity OpenApi)
-> ((Text -> Identity Text) -> Info -> Identity Info)
-> (Text -> Identity Text)
-> OpenApi
-> Identity OpenApi
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Identity Text) -> Info -> Identity Info
forall s a. HasTitle s a => Lens' s a
Lens' Info Text
S.title ((Text -> Identity Text) -> OpenApi -> Identity OpenApi)
-> Text -> OpenApi -> OpenApi
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Text
"Wire-Server internal gundeck API"