content: -- 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 Data.Text qualified as Text
  import GHC.TypeLits
  import Imports
  import Servant
  import Servant.API.ContentTypes
  import Servant.OpenApi
  import Servant.OpenApi.Internal
  import Test.QuickCheck (Arbitrary)
  import Text.Regex.Base
  import Text.Regex.TDFA
  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 = 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 _p pc nt s = hoistServerWithContext p pc nt (s . unVersioned) . Versioned
      where
        p = Proxy :: Proxy (ReqBody cts (Versioned v a) :> api)
  
    route _p ctx d = route (Proxy :: Proxy (ReqBody cts (Versioned v a) :> api)) ctx (fmap (. unVersioned) 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 _ = toOpenApi (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 a = responseRender @cs @(Respond s desc (Versioned v a)) a . Versioned
  
    responseUnrender c = fmap unVersioned . responseUnrender @cs @(Respond s desc (Versioned v a)) c
  
  instance
    (KnownSymbol desc, S.ToSchema a, SingI v, ToSchema (Versioned v a), Typeable v) =>
    IsSwaggerResponse (VersionedRespond (v :: Version) s desc a)
    where
    responseSwagger = 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 {unVersioned :: a}
    deriving (Eq, Show)
    deriving newtype (Arbitrary)
  
  instance Functor (Versioned v) where
    fmap f (Versioned a) = Versioned (f 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 _ = do
      S.NamedSchema n s <- schemaToSwagger (Proxy @(Versioned v a))
      pure $
        S.NamedSchema
          { _namedSchemaName = fmap withVersionSuffix n,
            _namedSchemaSchema = s
          }
      where
        versionSuffix :: Text
        versionSuffix = Text.pack $ show (demote @v)
  
        withVersionSuffix :: Text -> Text
        withVersionSuffix origName =
          -- some types may already have a version suffix, in which case it will be replaced
          -- otherwise it will be appended
          let versionPattern :: Regex = makeRegex ("V[0-9]+$" :: String)
           in case matchOnceText versionPattern origName of
                Just (beforeVersion, _, afterVersion) | afterVersion == "" -> beforeVersion <> versionSuffix
                _ -> origName <> versionSuffix
  