-- 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.API
  ( ServiceAPI (..),
    API,
    hoistAPIHandler,
    hoistAPI,
    mkAPI,
    mkNamedAPI,
    (<@>),
    ServerEffect (..),
    ServerEffects (..),
    hoistServerWithDomain,
  )
where

import Data.Domain
import Data.Kind
import Data.OpenApi qualified as S
import Data.Proxy
import Imports
import Polysemy
import Polysemy.Error
import Polysemy.Internal
import Servant hiding (Union)
import Servant.OpenApi
import Wire.API.Error
import Wire.API.Routes.Named
import Wire.API.Routes.Version

class ServiceAPI service (v :: Version) where
  type ServiceAPIRoutes service
  type SpecialisedAPIRoutes v service :: Type
  type SpecialisedAPIRoutes v service = SpecialiseToVersion v (ServiceAPIRoutes service)
  serviceSwagger :: (HasOpenApi (SpecialisedAPIRoutes v service)) => S.OpenApi
  serviceSwagger = Proxy (SpecialisedAPIRoutes v service) -> OpenApi
forall {k} (api :: k). HasOpenApi api => Proxy api -> OpenApi
toOpenApi (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(SpecialisedAPIRoutes v service))

instance ServiceAPI VersionAPITag v where
  type ServiceAPIRoutes VersionAPITag = VersionAPI

-- | A Servant handler on a polysemy stack. This is used to help with type inference.
newtype API api r = API {forall {k} (api :: k) (r :: EffectRow).
API api r -> ServerT api (Sem r)
unAPI :: ServerT api (Sem r)}

-- | Convert a polysemy handler to an 'API' value.
mkAPI ::
  forall r0 api.
  (HasServer api '[Domain], ServerEffects (DeclaredErrorEffects api) r0) =>
  ServerT api (Sem (Append (DeclaredErrorEffects api) r0)) ->
  API api r0
mkAPI :: forall (r0 :: EffectRow) api.
(HasServer api '[Domain],
 ServerEffects (DeclaredErrorEffects api) r0) =>
ServerT api (Sem (Append (DeclaredErrorEffects api) r0))
-> API api r0
mkAPI ServerT api (Sem (Append (DeclaredErrorEffects api) r0))
h = ServerT api (Sem r0) -> API api r0
forall {k} (api :: k) (r :: EffectRow).
ServerT api (Sem r) -> API api r
API (ServerT api (Sem r0) -> API api r0)
-> ServerT api (Sem r0) -> API api r0
forall a b. (a -> b) -> a -> b
$ forall {k} (api :: k) (m :: * -> *) (n :: * -> *).
HasServer api '[Domain] =>
(forall x. m x -> n x) -> ServerT api m -> ServerT api n
forall api (m :: * -> *) (n :: * -> *).
HasServer api '[Domain] =>
(forall x. m x -> n x) -> ServerT api m -> ServerT api n
hoistServerWithDomain @api (forall (r :: EffectRow) (r1 :: EffectRow) a.
ServerEffects r r1 =>
Sem (Append r r1) a -> Sem r1 a
interpretServerEffects @(DeclaredErrorEffects api) @r0) ServerT api (Sem (Append (DeclaredErrorEffects api) r0))
h

-- | Convert a polysemy handler to a named 'API' value.
mkNamedAPI ::
  forall name r0 api.
  (HasServer api '[Domain], ServerEffects (DeclaredErrorEffects api) r0) =>
  ServerT api (Sem (Append (DeclaredErrorEffects api) r0)) ->
  API (Named name api) r0
mkNamedAPI :: forall {k} (name :: k) (r0 :: EffectRow) api.
(HasServer api '[Domain],
 ServerEffects (DeclaredErrorEffects api) r0) =>
ServerT api (Sem (Append (DeclaredErrorEffects api) r0))
-> API (Named name api) r0
mkNamedAPI = ServerT (Named name api) (Sem r0) -> API (Named name api) r0
Named name (ServerT api (Sem r0)) -> API (Named name api) r0
forall {k} (api :: k) (r :: EffectRow).
ServerT api (Sem r) -> API api r
API (Named name (ServerT api (Sem r0)) -> API (Named name api) r0)
-> (ServerT api (Sem (Append (DeclaredErrorEffects api) r0))
    -> Named name (ServerT api (Sem r0)))
-> ServerT api (Sem (Append (DeclaredErrorEffects api) r0))
-> API (Named name api) r0
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerT api (Sem r0) -> Named name (ServerT api (Sem r0))
forall {k} (name :: k) x. x -> Named name x
Named (ServerT api (Sem r0) -> Named name (ServerT api (Sem r0)))
-> (ServerT api (Sem (Append (DeclaredErrorEffects api) r0))
    -> ServerT api (Sem r0))
-> ServerT api (Sem (Append (DeclaredErrorEffects api) r0))
-> Named name (ServerT api (Sem r0))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. API api r0 -> ServerT api (Sem r0)
forall {k} (api :: k) (r :: EffectRow).
API api r -> ServerT api (Sem r)
unAPI (API api r0 -> ServerT api (Sem r0))
-> (ServerT api (Sem (Append (DeclaredErrorEffects api) r0))
    -> API api r0)
-> ServerT api (Sem (Append (DeclaredErrorEffects api) r0))
-> ServerT api (Sem r0)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (r0 :: EffectRow) api.
(HasServer api '[Domain],
 ServerEffects (DeclaredErrorEffects api) r0) =>
ServerT api (Sem (Append (DeclaredErrorEffects api) r0))
-> API api r0
mkAPI @r0 @api

-- | Combine APIs.
(<@>) :: API api1 r -> API api2 r -> API (api1 :<|> api2) r
<@> :: forall api1 (r :: EffectRow) api2.
API api1 r -> API api2 r -> API (api1 :<|> api2) r
(<@>) (API ServerT api1 (Sem r)
h1) (API ServerT api2 (Sem r)
h2) = ServerT (api1 :<|> api2) (Sem r) -> API (api1 :<|> api2) r
forall {k} (api :: k) (r :: EffectRow).
ServerT api (Sem r) -> API api r
API (ServerT api1 (Sem r)
h1 ServerT api1 (Sem r)
-> ServerT api2 (Sem r)
-> ServerT api1 (Sem r) :<|> ServerT api2 (Sem r)
forall a b. a -> b -> a :<|> b
:<|> ServerT api2 (Sem r)
h2)

infixr 3 <@>

-- Servant needs a context type argument here that contains *at least* the
-- context types required by all the HasServer instances. In reality, this should
-- not be necessary, because the contexts are only used by the @route@ functions,
-- but unfortunately the 'hoistServerWithContext' function is also part of the
-- 'HasServer' typeclass, even though it cannot possibly make use of its @context@
-- type argument.
hoistServerWithDomain ::
  forall api m n.
  (HasServer api '[Domain]) =>
  (forall x. m x -> n x) ->
  ServerT api m ->
  ServerT api n
hoistServerWithDomain :: forall {k} (api :: k) (m :: * -> *) (n :: * -> *).
HasServer api '[Domain] =>
(forall x. m x -> n x) -> ServerT api m -> ServerT api n
hoistServerWithDomain = Proxy api
-> Proxy '[Domain]
-> (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 '[Domain]
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
hoistServerWithContext (forall (t :: k). Proxy t
forall {k} (t :: k). Proxy t
Proxy @api) (forall (t :: [*]). Proxy t
forall {k} (t :: k). Proxy t
Proxy @'[Domain])

hoistAPIHandler ::
  forall api r n.
  (HasServer api '[Domain]) =>
  (forall x. Sem r x -> n x) ->
  API api r ->
  ServerT api n
hoistAPIHandler :: forall {k} (api :: k) (r :: EffectRow) (n :: * -> *).
HasServer api '[Domain] =>
(forall x. Sem r x -> n x) -> API api r -> ServerT api n
hoistAPIHandler forall x. Sem r x -> n x
f = forall (api :: k) (m :: * -> *) (n :: * -> *).
HasServer api '[Domain] =>
(forall x. m x -> n x) -> ServerT api m -> ServerT api n
forall {k} (api :: k) (m :: * -> *) (n :: * -> *).
HasServer api '[Domain] =>
(forall x. m x -> n x) -> ServerT api m -> ServerT api n
hoistServerWithDomain @api Sem r x -> n x
forall x. Sem r x -> n x
f (ServerT api (Sem r) -> ServerT api n)
-> (API api r -> ServerT api (Sem r)) -> API api r -> ServerT api n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. API api r -> ServerT api (Sem r)
forall {k} (api :: k) (r :: EffectRow).
API api r -> ServerT api (Sem r)
unAPI

hoistAPI ::
  forall api1 api2 r1 r2.
  (ServerT api1 (Sem r1) -> ServerT api2 (Sem r2)) ->
  API api1 r1 ->
  API api2 r2
hoistAPI :: forall {k} {k} (api1 :: k) (api2 :: k) (r1 :: EffectRow)
       (r2 :: EffectRow).
(ServerT api1 (Sem r1) -> ServerT api2 (Sem r2))
-> API api1 r1 -> API api2 r2
hoistAPI ServerT api1 (Sem r1) -> ServerT api2 (Sem r2)
f = ServerT api2 (Sem r2) -> API api2 r2
forall {k} (api :: k) (r :: EffectRow).
ServerT api (Sem r) -> API api r
API (ServerT api2 (Sem r2) -> API api2 r2)
-> (API api1 r1 -> ServerT api2 (Sem r2))
-> API api1 r1
-> API api2 r2
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerT api1 (Sem r1) -> ServerT api2 (Sem r2)
f (ServerT api1 (Sem r1) -> ServerT api2 (Sem r2))
-> (API api1 r1 -> ServerT api1 (Sem r1))
-> API api1 r1
-> ServerT api2 (Sem r2)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. API api1 r1 -> ServerT api1 (Sem r1)
forall {k} (api :: k) (r :: EffectRow).
API api r -> ServerT api (Sem r)
unAPI

class ServerEffect eff r where
  interpretServerEffect :: Sem (eff ': r) a -> Sem r a

class ServerEffects r r1 where
  interpretServerEffects :: Sem (Append r r1) a -> Sem r1 a

instance ServerEffects '[] r where
  interpretServerEffects :: forall a. Sem (Append '[] r) a -> Sem r a
interpretServerEffects = Sem r a -> Sem r a
Sem (Append '[] r) a -> Sem r a
forall a. a -> a
id

instance (ServerEffects r r1, ServerEffect eff (Append r r1)) => ServerEffects (eff ': r) r1 where
  interpretServerEffects :: forall a. Sem (Append (eff : r) r1) a -> Sem r1 a
interpretServerEffects = forall (r :: EffectRow) (r1 :: EffectRow) a.
ServerEffects r r1 =>
Sem (Append r r1) a -> Sem r1 a
interpretServerEffects @r @r1 (Sem (Append r r1) a -> Sem r1 a)
-> (Sem (eff : Append r r1) a -> Sem (Append r r1) a)
-> Sem (eff : Append r r1) a
-> Sem r1 a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (eff :: Effect) (r :: EffectRow) a.
ServerEffect eff r =>
Sem (eff : r) a -> Sem r a
interpretServerEffect @eff @(Append r r1)

instance (KnownError (MapError e), Member (Error DynError) r) => ServerEffect (ErrorS e) r where
  interpretServerEffect :: forall a. Sem (ErrorS e : r) a -> Sem r a
interpretServerEffect = Sem (ErrorS e : r) a -> Sem r a
forall {k} (e :: k) (r :: EffectRow) a.
(Member (Error DynError) r, KnownError (MapError e)) =>
Sem (ErrorS e : r) a -> Sem r a
mapToDynamicError

instance (KnownError (MapError e), Member (Error DynError) r) => ServerEffect (Error (Tagged e Text)) r where
  interpretServerEffect :: forall a. Sem (Error (Tagged e Text) : r) a -> Sem r a
interpretServerEffect = (Tagged e Text -> DynError)
-> Sem (Error (Tagged e Text) : r) a -> Sem r a
forall e1 e2 (r :: EffectRow) a.
Member (Error e2) r =>
(e1 -> e2) -> Sem (Error e1 : r) a -> Sem r a
mapError ((Tagged e Text -> DynError)
 -> Sem (Error (Tagged e Text) : r) a -> Sem r a)
-> (Tagged e Text -> DynError)
-> Sem (Error (Tagged e Text) : r) a
-> Sem r a
forall a b. (a -> b) -> a -> b
$ \Tagged e Text
msg -> (forall (e :: StaticError). KnownError e => DynError
dynError @(MapError e)) {eMessage = unTagged msg}