{-# LANGUAGE RecordWildCards #-}

-- 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.VersionInfo
  ( -- * Version info
    vinfoObjectSchema,

    -- * Version utilities
    versionHeader,
    VersionHeader,

    -- * Servant combinators
    From,
    Until,
    VersionedMonad (..),
  )
where

import Data.ByteString.Char8 qualified as B8
import Data.CaseInsensitive qualified as CI
import Data.Metrics.Servant
import Data.Schema
import Data.Singletons
import GHC.TypeLits
import Imports
import Network.Wai qualified as Wai
import Servant
import Servant.Client.Core
import Servant.Server.Internal.Delayed
import Servant.Server.Internal.DelayedIO
import Wire.API.Routes.ClientAlgebra

vinfoObjectSchema :: ValueSchema NamedSwaggerDoc v -> ObjectSchema SwaggerDoc [v]
vinfoObjectSchema :: forall v.
ValueSchema NamedSwaggerDoc v -> ObjectSchema SwaggerDoc [v]
vinfoObjectSchema ValueSchema NamedSwaggerDoc v
sch = Text
-> SchemaP SwaggerDoc Value Value [v] [v]
-> SchemaP SwaggerDoc Object [Pair] [v] [v]
forall doc' doc a b.
HasField doc' doc =>
Text
-> SchemaP doc' Value Value a b -> SchemaP doc Object [Pair] a b
field Text
"supported" (ValueSchema NamedSwaggerDoc v
-> SchemaP SwaggerDoc Value Value [v] [v]
forall ndoc doc a.
(HasArray ndoc doc, HasName ndoc) =>
ValueSchema ndoc a -> ValueSchema doc [a]
array ValueSchema NamedSwaggerDoc v
sch)

type VersionHeader = "X-Wire-API-Version"

versionHeader :: CI.CI ByteString
versionHeader :: CI ByteString
versionHeader = ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
CI.mk (ByteString -> CI ByteString)
-> (String -> ByteString) -> String -> CI ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
B8.pack (String -> CI ByteString) -> String -> CI ByteString
forall a b. (a -> b) -> a -> b
$ Proxy VersionHeader -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @VersionHeader)

--------------------------------------------------------------------------------
-- Servant combinators

data Until v

data From v

instance
  ( SingI n,
    Ord (Demote v),
    Enum (Demote v),
    SingKind v,
    HasServer api ctx
  ) =>
  HasServer (Until (n :: v) :> api) ctx
  where
  type ServerT (Until n :> api) m = ServerT api m

  route :: forall env.
Proxy (Until n :> api)
-> Context ctx
-> Delayed env (Server (Until n :> api))
-> Router env
route Proxy (Until n :> api)
_ Context ctx
ctx Delayed env (Server (Until n :> api))
action =
    Proxy api -> Context ctx -> Delayed env (Server api) -> Router env
forall env.
Proxy api -> Context ctx -> 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 (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @api) Context ctx
ctx (Delayed env (Server api) -> Router env)
-> Delayed env (Server api) -> Router env
forall a b. (a -> b) -> a -> b
$
      Delayed env (Server api)
Delayed env (Server (Until n :> api))
action Delayed env (Server api)
-> DelayedIO () -> Delayed env (Server api)
forall env b. Delayed env b -> DelayedIO () -> Delayed env b
`addVersionCheck` (Request -> DelayedIO ()) -> DelayedIO ()
forall a. (Request -> DelayedIO a) -> DelayedIO a
withRequest Request -> DelayedIO ()
headerCheck
    where
      headerCheck :: Wai.Request -> DelayedIO ()
      headerCheck :: Request -> DelayedIO ()
headerCheck Request
req = do
        let v :: Demote v
v =
              Int -> Demote v
forall a. Enum a => Int -> a
toEnum (Int -> Demote v) -> Int -> Demote v
forall a b. (a -> b) -> a -> b
$
                Int -> (ByteString -> Int) -> Maybe ByteString -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
                  Int
0
                  (Int -> Either Text Int -> Int
forall b a. b -> Either a b -> b
fromRight Int
0 (Either Text Int -> Int)
-> (ByteString -> Either Text Int) -> ByteString -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either Text Int
forall a. FromHttpApiData a => ByteString -> Either Text a
parseHeader)
                  (CI ByteString -> [(CI ByteString, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup CI ByteString
versionHeader (Request -> [(CI ByteString, ByteString)]
Wai.requestHeaders Request
req))
        Bool -> DelayedIO () -> DelayedIO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Demote v
v Demote v -> Demote v -> Bool
forall a. Ord a => a -> a -> Bool
>= forall (a :: v). (SingKind v, SingI a) => Demote v
forall {k} (a :: k). (SingKind k, SingI a) => Demote k
demote @n) (DelayedIO () -> DelayedIO ()) -> DelayedIO () -> DelayedIO ()
forall a b. (a -> b) -> a -> b
$
          ServerError -> DelayedIO ()
forall a. ServerError -> DelayedIO a
delayedFail ServerError
err404

      -- this hack makes sure that the version check is executed before the method check
      addVersionCheck :: Delayed env b -> DelayedIO () -> Delayed env b
      addVersionCheck :: forall env b. Delayed env b -> DelayedIO () -> Delayed env b
addVersionCheck Delayed {DelayedIO auth
DelayedIO contentType
DelayedIO params
DelayedIO headers
DelayedIO ()
env -> DelayedIO captures
captures
-> params -> headers -> auth -> body -> Request -> RouteResult b
contentType -> DelayedIO body
capturesD :: env -> DelayedIO captures
methodD :: DelayedIO ()
authD :: DelayedIO auth
acceptD :: DelayedIO ()
contentD :: DelayedIO contentType
paramsD :: DelayedIO params
headersD :: DelayedIO headers
bodyD :: contentType -> DelayedIO body
serverD :: captures
-> params -> headers -> auth -> body -> Request -> RouteResult b
capturesD :: ()
methodD :: forall env c. Delayed env c -> DelayedIO ()
authD :: ()
acceptD :: forall env c. Delayed env c -> DelayedIO ()
contentD :: ()
paramsD :: ()
headersD :: ()
bodyD :: ()
serverD :: ()
..} DelayedIO ()
new =
        Delayed
          { capturesD :: env -> DelayedIO captures
capturesD = \env
env -> env -> DelayedIO captures
capturesD env
env DelayedIO captures -> DelayedIO () -> DelayedIO captures
forall a b. DelayedIO a -> DelayedIO b -> DelayedIO a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* DelayedIO ()
new,
            DelayedIO auth
DelayedIO contentType
DelayedIO params
DelayedIO headers
DelayedIO ()
captures
-> params -> headers -> auth -> body -> Request -> RouteResult b
contentType -> DelayedIO body
methodD :: DelayedIO ()
authD :: DelayedIO auth
acceptD :: DelayedIO ()
contentD :: DelayedIO contentType
paramsD :: DelayedIO params
headersD :: DelayedIO headers
bodyD :: contentType -> DelayedIO body
serverD :: captures
-> params -> headers -> auth -> body -> Request -> RouteResult b
methodD :: DelayedIO ()
authD :: DelayedIO auth
acceptD :: DelayedIO ()
contentD :: DelayedIO contentType
paramsD :: DelayedIO params
headersD :: DelayedIO headers
bodyD :: contentType -> DelayedIO body
serverD :: captures
-> params -> headers -> auth -> body -> Request -> RouteResult b
..
          }

  hoistServerWithContext :: forall (m :: * -> *) (n :: * -> *).
Proxy (Until n :> api)
-> Proxy ctx
-> (forall x. m x -> n x)
-> ServerT (Until n :> api) m
-> ServerT (Until n :> api) n
hoistServerWithContext Proxy (Until n :> api)
_ Proxy ctx
ctx forall x. m x -> n x
f =
    Proxy api
-> Proxy ctx
-> (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 ctx
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
hoistServerWithContext (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @api) Proxy ctx
ctx m x -> n x
forall x. m x -> n x
f

class VersionedMonad v m where
  guardVersion :: (v -> Bool) -> m ()

instance
  ( VersionedMonad (Demote v) m,
    SingI n,
    Ord (Demote v),
    SingKind v,
    HasClientAlgebra m api
  ) =>
  HasClient m (Until (n :: v) :> api)
  where
  type Client m (Until n :> api) = Client m api
  clientWithRoute :: Proxy m
-> Proxy (Until n :> api) -> Request -> Client m (Until n :> api)
clientWithRoute Proxy m
pm Proxy (Until n :> api)
_ Request
req = forall (m :: * -> *) api a.
HasClientAlgebra m api =>
m a -> (a -> Client m api) -> Client m api
bindClient @m @api
    ((Demote v -> Bool) -> m ()
forall v (m :: * -> *). VersionedMonad v m => (v -> Bool) -> m ()
guardVersion (\Demote v
v -> Demote v
v Demote v -> Demote v -> Bool
forall a. Ord a => a -> a -> Bool
< forall (a :: v). (SingKind v, SingI a) => Demote v
forall {k} (a :: k). (SingKind k, SingI a) => Demote k
demote @n))
    ((() -> Client m api) -> Client m api)
-> (() -> Client m api) -> Client m api
forall a b. (a -> b) -> a -> b
$ \()
_ ->
      Proxy m -> Proxy api -> Request -> Client m api
forall (m :: * -> *) api.
HasClient m api =>
Proxy m -> Proxy api -> Request -> Client m api
clientWithRoute Proxy m
pm (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @api) Request
req
  hoistClientMonad :: forall (mon :: * -> *) (mon' :: * -> *).
Proxy m
-> Proxy (Until n :> api)
-> (forall x. mon x -> mon' x)
-> Client mon (Until n :> api)
-> Client mon' (Until n :> api)
hoistClientMonad Proxy m
pm Proxy (Until n :> api)
_ forall x. mon x -> mon' x
f = Proxy m
-> Proxy api
-> (forall x. mon x -> mon' x)
-> Client mon api
-> Client mon' api
forall (m :: * -> *) api (mon :: * -> *) (mon' :: * -> *).
HasClient m api =>
Proxy m
-> Proxy api
-> (forall x. mon x -> mon' x)
-> Client mon api
-> Client mon' api
forall (mon :: * -> *) (mon' :: * -> *).
Proxy m
-> Proxy api
-> (forall x. mon x -> mon' x)
-> Client mon api
-> Client mon' api
hoistClientMonad Proxy m
pm (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @api) mon x -> mon' x
forall x. mon x -> mon' x
f

instance (RoutesToPaths api) => RoutesToPaths (Until v :> api) where
  getRoutes :: Forest PathSegment
getRoutes = forall routes. RoutesToPaths routes => Forest PathSegment
forall {k} (routes :: k).
RoutesToPaths routes =>
Forest PathSegment
getRoutes @api

instance
  ( SingI n,
    Ord (Demote v),
    Enum (Demote v),
    SingKind v,
    HasServer api ctx
  ) =>
  HasServer (From (n :: v) :> api) ctx
  where
  type ServerT (From n :> api) m = ServerT api m

  route :: forall env.
Proxy (From n :> api)
-> Context ctx
-> Delayed env (Server (From n :> api))
-> Router env
route Proxy (From n :> api)
_ Context ctx
ctx Delayed env (Server (From n :> api))
action =
    Proxy api -> Context ctx -> Delayed env (Server api) -> Router env
forall env.
Proxy api -> Context ctx -> 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 (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @api) Context ctx
ctx (Delayed env (Server api) -> Router env)
-> Delayed env (Server api) -> Router env
forall a b. (a -> b) -> a -> b
$
      (Server api -> () -> Server api)
-> Delayed env (Server api) -> Delayed env (() -> Server api)
forall a b. (a -> b) -> Delayed env a -> Delayed env b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Server api -> () -> Server api
forall a b. a -> b -> a
const Delayed env (Server api)
Delayed env (Server (From n :> api))
action Delayed env (() -> Server api)
-> DelayedIO () -> Delayed env (Server api)
forall env a b.
Delayed env (a -> b) -> DelayedIO a -> Delayed env b
`addHeaderCheck` (Request -> DelayedIO ()) -> DelayedIO ()
forall a. (Request -> DelayedIO a) -> DelayedIO a
withRequest Request -> DelayedIO ()
headerCheck
    where
      headerCheck :: Wai.Request -> DelayedIO ()
      headerCheck :: Request -> DelayedIO ()
headerCheck Request
req = do
        let v :: Demote v
v =
              Int -> Demote v
forall a. Enum a => Int -> a
toEnum (Int -> Demote v) -> Int -> Demote v
forall a b. (a -> b) -> a -> b
$
                Int -> (ByteString -> Int) -> Maybe ByteString -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
                  Int
0
                  (Int -> Either Text Int -> Int
forall b a. b -> Either a b -> b
fromRight Int
0 (Either Text Int -> Int)
-> (ByteString -> Either Text Int) -> ByteString -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either Text Int
forall a. FromHttpApiData a => ByteString -> Either Text a
parseHeader)
                  (CI ByteString -> [(CI ByteString, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup CI ByteString
versionHeader (Request -> [(CI ByteString, ByteString)]
Wai.requestHeaders Request
req))
        Bool -> DelayedIO () -> DelayedIO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Demote v
v Demote v -> Demote v -> Bool
forall a. Ord a => a -> a -> Bool
< forall (a :: v). (SingKind v, SingI a) => Demote v
forall {k} (a :: k). (SingKind k, SingI a) => Demote k
demote @n) (DelayedIO () -> DelayedIO ()) -> DelayedIO () -> DelayedIO ()
forall a b. (a -> b) -> a -> b
$
          ServerError -> DelayedIO ()
forall a. ServerError -> DelayedIO a
delayedFail ServerError
err404

  hoistServerWithContext :: forall (m :: * -> *) (n :: * -> *).
Proxy (From n :> api)
-> Proxy ctx
-> (forall x. m x -> n x)
-> ServerT (From n :> api) m
-> ServerT (From n :> api) n
hoistServerWithContext Proxy (From n :> api)
_ Proxy ctx
ctx forall x. m x -> n x
f =
    Proxy api
-> Proxy ctx
-> (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 ctx
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
hoistServerWithContext (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @api) Proxy ctx
ctx m x -> n x
forall x. m x -> n x
f

instance
  ( VersionedMonad (Demote v) m,
    SingI n,
    Ord (Demote v),
    SingKind v,
    HasClientAlgebra m api
  ) =>
  HasClient m (From (n :: v) :> api)
  where
  type Client m (From n :> api) = Client m api
  clientWithRoute :: Proxy m
-> Proxy (From n :> api) -> Request -> Client m (From n :> api)
clientWithRoute Proxy m
pm Proxy (From n :> api)
_ Request
req = forall (m :: * -> *) api a.
HasClientAlgebra m api =>
m a -> (a -> Client m api) -> Client m api
bindClient @m @api
    ((Demote v -> Bool) -> m ()
forall v (m :: * -> *). VersionedMonad v m => (v -> Bool) -> m ()
guardVersion (\Demote v
v -> Demote v
v Demote v -> Demote v -> Bool
forall a. Ord a => a -> a -> Bool
>= forall (a :: v). (SingKind v, SingI a) => Demote v
forall {k} (a :: k). (SingKind k, SingI a) => Demote k
demote @n))
    ((() -> Client m api) -> Client m api)
-> (() -> Client m api) -> Client m api
forall a b. (a -> b) -> a -> b
$ \()
_ ->
      Proxy m -> Proxy api -> Request -> Client m api
forall (m :: * -> *) api.
HasClient m api =>
Proxy m -> Proxy api -> Request -> Client m api
clientWithRoute Proxy m
pm (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @api) Request
req
  hoistClientMonad :: forall (mon :: * -> *) (mon' :: * -> *).
Proxy m
-> Proxy (From n :> api)
-> (forall x. mon x -> mon' x)
-> Client mon (From n :> api)
-> Client mon' (From n :> api)
hoistClientMonad Proxy m
pm Proxy (From n :> api)
_ forall x. mon x -> mon' x
f = Proxy m
-> Proxy api
-> (forall x. mon x -> mon' x)
-> Client mon api
-> Client mon' api
forall (m :: * -> *) api (mon :: * -> *) (mon' :: * -> *).
HasClient m api =>
Proxy m
-> Proxy api
-> (forall x. mon x -> mon' x)
-> Client mon api
-> Client mon' api
forall (mon :: * -> *) (mon' :: * -> *).
Proxy m
-> Proxy api
-> (forall x. mon x -> mon' x)
-> Client mon api
-> Client mon' api
hoistClientMonad Proxy m
pm (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @api) mon x -> mon' x
forall x. mon x -> mon' x
f

instance (RoutesToPaths api) => RoutesToPaths (From v :> api) where
  getRoutes :: Forest PathSegment
getRoutes = forall routes. RoutesToPaths routes => Forest PathSegment
forall {k} (routes :: k).
RoutesToPaths routes =>
Forest PathSegment
getRoutes @api