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

import Data.Aeson (FromJSON, ToJSON)
import Data.Kind
import Data.Metrics.Servant
import Data.OpenApi qualified as S
import Data.Schema
import Data.Singletons
import GHC.TypeLits
import Imports
import Servant
import Servant.API.ContentTypes
import Servant.OpenApi
import Servant.OpenApi.Internal
import Test.QuickCheck (Arbitrary)
import Wire.API.Routes.MultiVerb
import Wire.API.Routes.Version

--------------------------------------
-- Versioned requests

data VersionedReqBody' v (mods :: [Type]) (ct :: [Type]) (a :: Type)

type VersionedReqBody v = VersionedReqBody' v '[Required, Strict]

instance (RoutesToPaths rest) => RoutesToPaths (VersionedReqBody' v mods ct a :> rest) where
  getRoutes :: Forest PathSegment
getRoutes = forall routes. RoutesToPaths routes => Forest PathSegment
forall {k} (routes :: k).
RoutesToPaths routes =>
Forest PathSegment
getRoutes @rest

instance
  ( AllCTUnrender cts (Versioned v a),
    HasServer api context,
    HasContextEntry (context .++ DefaultErrorFormatters) ErrorFormatters
  ) =>
  HasServer (VersionedReqBody' v mods cts a :> api) context
  where
  type ServerT (VersionedReqBody' v mods cts a :> api) m = a -> ServerT api m

  hoistServerWithContext :: forall (m :: * -> *) (n :: * -> *).
Proxy (VersionedReqBody' v mods cts a :> api)
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT (VersionedReqBody' v mods cts a :> api) m
-> ServerT (VersionedReqBody' v mods cts a :> api) n
hoistServerWithContext Proxy (VersionedReqBody' v mods cts a :> api)
_p Proxy context
pc forall x. m x -> n x
nt ServerT (VersionedReqBody' v mods cts a :> api) m
s = Proxy (ReqBody cts (Versioned v a) :> api)
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT (ReqBody cts (Versioned v a) :> api) m
-> ServerT (ReqBody cts (Versioned v a) :> 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 (ReqBody cts (Versioned v a) :> api)
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT (ReqBody cts (Versioned v a) :> api) m
-> ServerT (ReqBody cts (Versioned v a) :> api) n
hoistServerWithContext Proxy (ReqBody cts (Versioned v a) :> api)
p Proxy context
pc m x -> n x
forall x. m x -> n x
nt (ServerT (VersionedReqBody' v mods cts a :> api) m
a -> ServerT api m
s (a -> ServerT api m)
-> (Versioned v a -> a) -> Versioned v a -> ServerT api m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Versioned v a -> a
forall (v :: Version) a. Versioned v a -> a
unVersioned) (Versioned v a -> ServerT api n)
-> (a -> Versioned v a) -> a -> ServerT api n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Versioned v a
forall (v :: Version) a. a -> Versioned v a
Versioned
    where
      p :: Proxy (ReqBody cts (Versioned v a) :> api)
p = Proxy (ReqBody cts (Versioned v a) :> api)
forall {k} (t :: k). Proxy t
Proxy :: Proxy (ReqBody cts (Versioned v a) :> api)

  route :: forall env.
Proxy (VersionedReqBody' v mods cts a :> api)
-> Context context
-> Delayed env (Server (VersionedReqBody' v mods cts a :> api))
-> Router env
route Proxy (VersionedReqBody' v mods cts a :> api)
_p Context context
ctx Delayed env (Server (VersionedReqBody' v mods cts a :> api))
d = Proxy (ReqBody cts (Versioned v a) :> api)
-> Context context
-> Delayed env (Server (ReqBody cts (Versioned v a) :> api))
-> Router env
forall env.
Proxy (ReqBody cts (Versioned v a) :> api)
-> Context context
-> Delayed env (Server (ReqBody cts (Versioned v a) :> api))
-> Router env
forall {k} (api :: k) (context :: [*]) env.
HasServer api context =>
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
route (Proxy (ReqBody cts (Versioned v a) :> api)
forall {k} (t :: k). Proxy t
Proxy :: Proxy (ReqBody cts (Versioned v a) :> api)) Context context
ctx (((a -> ServerT api Handler)
 -> Versioned v a -> ServerT api Handler)
-> Delayed env (a -> ServerT api Handler)
-> Delayed env (Versioned v a -> ServerT api Handler)
forall a b. (a -> b) -> Delayed env a -> Delayed env b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> ServerT api Handler)
-> (Versioned v a -> a) -> Versioned v a -> ServerT api Handler
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Versioned v a -> a
forall (v :: Version) a. Versioned v a -> a
unVersioned) Delayed env (Server (VersionedReqBody' v mods cts a :> api))
Delayed env (a -> ServerT api Handler)
d)

type instance
  SpecialiseToVersion w (VersionedReqBody v cts a :> api) =
    VersionedReqBody v cts a :> SpecialiseToVersion w api

instance
  ( S.ToSchema (Versioned v a),
    HasOpenApi api,
    AllAccept cts
  ) =>
  HasOpenApi (VersionedReqBody v cts a :> api)
  where
  toOpenApi :: Proxy (VersionedReqBody v cts a :> api) -> OpenApi
toOpenApi Proxy (VersionedReqBody v cts a :> api)
_ = Proxy (ReqBody cts (Versioned v a) :> api) -> OpenApi
forall {k} (api :: k). HasOpenApi api => Proxy api -> OpenApi
toOpenApi (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(ReqBody cts (Versioned v a) :> api))

--------------------------------------------------------------------------------
-- Versioned responses

data VersionedRespond v (s :: Nat) (desc :: Symbol) (a :: Type)

type instance ResponseType (VersionedRespond v s desc a) = a

instance
  (IsResponse cs (Respond s desc (Versioned v a))) =>
  IsResponse cs (VersionedRespond v s desc a)
  where
  type ResponseStatus (VersionedRespond v s desc a) = ResponseStatus (Respond s desc a)
  type ResponseBody (VersionedRespond v s desc a) = ResponseBody (Respond s desc a)

  responseRender :: AcceptHeader
-> ResponseType (VersionedRespond v s desc a)
-> Maybe (ResponseF (ResponseBody (VersionedRespond v s desc a)))
responseRender AcceptHeader
a = forall (cs :: k) a.
IsResponse cs a =>
AcceptHeader
-> ResponseType a -> Maybe (ResponseF (ResponseBody a))
forall {k} (cs :: k) a.
IsResponse cs a =>
AcceptHeader
-> ResponseType a -> Maybe (ResponseF (ResponseBody a))
responseRender @cs @(Respond s desc (Versioned v a)) AcceptHeader
a (Versioned v a -> Maybe (ResponseF LByteString))
-> (a -> Versioned v a) -> a -> Maybe (ResponseF LByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Versioned v a
forall (v :: Version) a. a -> Versioned v a
Versioned

  responseUnrender :: MediaType
-> ResponseF (ResponseBody (VersionedRespond v s desc a))
-> UnrenderResult (ResponseType (VersionedRespond v s desc a))
responseUnrender MediaType
c = (Versioned v a -> a)
-> UnrenderResult (Versioned v a) -> UnrenderResult a
forall a b. (a -> b) -> UnrenderResult a -> UnrenderResult b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Versioned v a -> a
forall (v :: Version) a. Versioned v a -> a
unVersioned (UnrenderResult (Versioned v a) -> UnrenderResult a)
-> (ResponseF LByteString -> UnrenderResult (Versioned v a))
-> ResponseF LByteString
-> UnrenderResult a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (cs :: k) a.
IsResponse cs a =>
MediaType
-> ResponseF (ResponseBody a) -> UnrenderResult (ResponseType a)
forall {k} (cs :: k) a.
IsResponse cs a =>
MediaType
-> ResponseF (ResponseBody a) -> UnrenderResult (ResponseType a)
responseUnrender @cs @(Respond s desc (Versioned v a)) MediaType
c

instance
  (KnownSymbol desc, S.ToSchema a, SingI v, ToSchema (Versioned v a), Typeable v) =>
  IsSwaggerResponse (VersionedRespond (v :: Version) s desc a)
  where
  responseSwagger :: Declare Response
responseSwagger = forall a (cs :: [*]) (desc :: Symbol).
(ToSchema a, KnownSymbol desc, AllMime cs) =>
Declare Response
simpleResponseSwagger @(Versioned v a) @'[JSON] @desc

-------------------------------------------------------------------------------
-- Versioned newtype wrapper

-- Use this type to provide several JSON/swagger instances for a given type.
-- Use VersionedReqBody and VersionedRespond to select the instance to use in
-- Servant.
newtype Versioned (v :: Version) a = Versioned {forall (v :: Version) a. Versioned v a -> a
unVersioned :: a}
  deriving (Versioned v a -> Versioned v a -> Bool
(Versioned v a -> Versioned v a -> Bool)
-> (Versioned v a -> Versioned v a -> Bool) -> Eq (Versioned v a)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (v :: Version) a.
Eq a =>
Versioned v a -> Versioned v a -> Bool
$c== :: forall (v :: Version) a.
Eq a =>
Versioned v a -> Versioned v a -> Bool
== :: Versioned v a -> Versioned v a -> Bool
$c/= :: forall (v :: Version) a.
Eq a =>
Versioned v a -> Versioned v a -> Bool
/= :: Versioned v a -> Versioned v a -> Bool
Eq, Int -> Versioned v a -> ShowS
[Versioned v a] -> ShowS
Versioned v a -> String
(Int -> Versioned v a -> ShowS)
-> (Versioned v a -> String)
-> ([Versioned v a] -> ShowS)
-> Show (Versioned v a)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (v :: Version) a. Show a => Int -> Versioned v a -> ShowS
forall (v :: Version) a. Show a => [Versioned v a] -> ShowS
forall (v :: Version) a. Show a => Versioned v a -> String
$cshowsPrec :: forall (v :: Version) a. Show a => Int -> Versioned v a -> ShowS
showsPrec :: Int -> Versioned v a -> ShowS
$cshow :: forall (v :: Version) a. Show a => Versioned v a -> String
show :: Versioned v a -> String
$cshowList :: forall (v :: Version) a. Show a => [Versioned v a] -> ShowS
showList :: [Versioned v a] -> ShowS
Show)
  deriving newtype (Gen (Versioned v a)
Gen (Versioned v a)
-> (Versioned v a -> [Versioned v a]) -> Arbitrary (Versioned v a)
Versioned v a -> [Versioned v a]
forall a. Gen a -> (a -> [a]) -> Arbitrary a
forall (v :: Version) a. Arbitrary a => Gen (Versioned v a)
forall (v :: Version) a.
Arbitrary a =>
Versioned v a -> [Versioned v a]
$carbitrary :: forall (v :: Version) a. Arbitrary a => Gen (Versioned v a)
arbitrary :: Gen (Versioned v a)
$cshrink :: forall (v :: Version) a.
Arbitrary a =>
Versioned v a -> [Versioned v a]
shrink :: Versioned v a -> [Versioned v a]
Arbitrary)

instance Functor (Versioned v) where
  fmap :: forall a b. (a -> b) -> Versioned v a -> Versioned v b
fmap a -> b
f (Versioned a
a) = b -> Versioned v b
forall (v :: Version) a. a -> Versioned v a
Versioned (a -> b
f a
a)

deriving via Schema (Versioned v a) instance (ToSchema (Versioned v a)) => FromJSON (Versioned v a)

deriving via Schema (Versioned v a) instance (ToSchema (Versioned v a)) => ToJSON (Versioned v a)

-- add version suffix to swagger schema to prevent collisions
instance (SingI v, ToSchema (Versioned v a), Typeable a, Typeable v) => S.ToSchema (Versioned v a) where
  declareNamedSchema :: Proxy (Versioned v a) -> Declare (Definitions Schema) NamedSchema
declareNamedSchema Proxy (Versioned v a)
_ = do
    S.NamedSchema Maybe Text
n Schema
s <- Proxy (Versioned v a) -> Declare (Definitions Schema) NamedSchema
forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) NamedSchema
schemaToSwagger (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(Versioned v a))
    NamedSchema -> Declare (Definitions Schema) NamedSchema
forall a. a -> DeclareT (Definitions Schema) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NamedSchema -> Declare (Definitions Schema) NamedSchema)
-> NamedSchema -> Declare (Definitions Schema) NamedSchema
forall a b. (a -> b) -> a -> b
$ Maybe Text -> Schema -> NamedSchema
S.NamedSchema ((Text -> Text) -> Maybe Text -> Maybe Text
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Version -> Text
forall a. ToHttpApiData a => a -> Text
toUrlPiece (forall {k} (a :: k). (SingKind k, SingI a) => Demote k
forall (a :: Version).
(SingKind Version, SingI a) =>
Demote Version
demote @v)) Maybe Text
n) Schema
s