-- 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.QualifiedCapture
  ( QualifiedCapture,
    QualifiedCapture',
    WithDomain,
  )
where

import Data.Domain
import Data.Kind
import Data.Metrics.Servant
import Data.OpenApi hiding (HasServer, value)
import Data.Qualified
import GHC.TypeLits
import Imports
import Servant
import Servant.API.Description
import Servant.API.Modifiers
import Servant.Client.Core.HasClient
import Servant.OpenApi
import Servant.Server.Internal.ErrorFormatter
import Wire.API.Routes.Version

-- | Capture a value qualified by a domain, with modifiers.
data QualifiedCapture' (mods :: [Type]) (capture :: Symbol) (a :: Type)

-- | Capture a value qualified by a domain.
--
-- This works exactly like capturing a domain first then the value, but it
-- provides a 'Qualified' value to the handler, instead of both a domain and a
-- value.
type QualifiedCapture capture a = QualifiedCapture' '[] capture a

type WithDomain mods capture a api =
  Capture (AppendSymbol capture "_domain") Domain
    :> Capture' mods capture a
    :> api

type instance
  SpecialiseToVersion v (QualifiedCapture' mods capture a :> api) =
    QualifiedCapture' mods capture a :> SpecialiseToVersion v api

instance
  ( ToParamSchema a,
    HasOpenApi api,
    KnownSymbol capture,
    KnownSymbol (AppendSymbol capture "_domain"),
    KnownSymbol (FoldDescription mods)
  ) =>
  HasOpenApi (QualifiedCapture' mods capture a :> api)
  where
  toOpenApi :: Proxy (QualifiedCapture' mods capture a :> api) -> OpenApi
toOpenApi Proxy (QualifiedCapture' mods capture a :> api)
_ = Proxy
  (Capture (AppendSymbol capture "_domain") Domain
   :> (Capture' mods capture a :> api))
-> OpenApi
forall {k} (api :: k). HasOpenApi api => Proxy api -> OpenApi
toOpenApi (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(WithDomain mods capture a api))

instance
  ( KnownSymbol capture,
    Typeable a,
    FromHttpApiData a,
    HasServer api context,
    SBoolI (FoldLenient mods),
    KnownSymbol (AppendSymbol capture "_domain"),
    HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters
  ) =>
  HasServer (QualifiedCapture' mods capture a :> api) context
  where
  type
    ServerT (QualifiedCapture' mods capture a :> api) m =
      Qualified (If (FoldLenient mods) (Either String a) a) ->
      ServerT api m

  hoistServerWithContext :: forall (m :: * -> *) (n :: * -> *).
Proxy (QualifiedCapture' mods capture a :> api)
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT (QualifiedCapture' mods capture a :> api) m
-> ServerT (QualifiedCapture' mods capture a :> api) n
hoistServerWithContext Proxy (QualifiedCapture' mods capture a :> api)
_ Proxy context
pc forall x. m x -> n x
nt ServerT (QualifiedCapture' mods capture a :> 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)
-> (Qualified (If (FoldLenient mods) (Either String a) a)
    -> ServerT api m)
-> Qualified (If (FoldLenient mods) (Either String a) a)
-> ServerT api n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerT (QualifiedCapture' mods capture a :> api) m
Qualified (If (FoldLenient mods) (Either String a) a)
-> ServerT api m
s

  route :: forall env.
Proxy (QualifiedCapture' mods capture a :> api)
-> Context context
-> Delayed env (Server (QualifiedCapture' mods capture a :> api))
-> Router env
route Proxy (QualifiedCapture' mods capture a :> api)
_ Context context
pc Delayed env (Server (QualifiedCapture' mods capture a :> api))
m = Proxy
  (Capture (AppendSymbol capture "_domain") Domain
   :> (Capture' mods capture a :> api))
-> Context context
-> Delayed
     env
     (Server
        (Capture (AppendSymbol capture "_domain") Domain
         :> (Capture' mods capture a :> api)))
-> Router env
forall env.
Proxy
  (Capture (AppendSymbol capture "_domain") Domain
   :> (Capture' mods capture a :> api))
-> Context context
-> Delayed
     env
     (Server
        (Capture (AppendSymbol capture "_domain") Domain
         :> (Capture' mods capture a :> 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 @(WithDomain mods capture a api)) Context context
pc (((Qualified (If (FoldLenient mods) (Either String a) a)
  -> ServerT api Handler)
 -> Domain
 -> If (FoldLenient mods) (Either String a) a
 -> ServerT api Handler)
-> Delayed
     env
     (Qualified (If (FoldLenient mods) (Either String a) a)
      -> ServerT api Handler)
-> Delayed
     env
     (Domain
      -> If (FoldLenient mods) (Either String a) 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 (Qualified (If (FoldLenient mods) (Either String a) a)
 -> ServerT api Handler)
-> Domain
-> If (FoldLenient mods) (Either String a) a
-> ServerT api Handler
forall {a} {t}. (Qualified a -> t) -> Domain -> a -> t
qualify Delayed env (Server (QualifiedCapture' mods capture a :> api))
Delayed
  env
  (Qualified (If (FoldLenient mods) (Either String a) a)
   -> ServerT api Handler)
m)
    where
      qualify :: (Qualified a -> t) -> Domain -> a -> t
qualify Qualified a -> t
handler Domain
domain a
value = Qualified a -> t
handler (a -> Domain -> Qualified a
forall a. a -> Domain -> Qualified a
Qualified a
value Domain
domain)

instance
  ( KnownSymbol capture,
    ToHttpApiData a,
    HasClient m api,
    KnownSymbol (AppendSymbol capture "_domain")
  ) =>
  HasClient m (QualifiedCapture' mods capture a :> api)
  where
  type
    Client m (QualifiedCapture' mods capture a :> api) =
      Qualified a -> Client m api

  clientWithRoute :: Proxy m
-> Proxy (QualifiedCapture' mods capture a :> api)
-> Request
-> Client m (QualifiedCapture' mods capture a :> api)
clientWithRoute Proxy m
pm Proxy (QualifiedCapture' mods capture a :> api)
_ Request
req (Qualified a
value Domain
domain) =
    Proxy m
-> Proxy
     (Capture (AppendSymbol capture "_domain") Domain
      :> (Capture' mods capture a :> api))
-> Request
-> Client
     m
     (Capture (AppendSymbol capture "_domain") Domain
      :> (Capture' mods capture a :> 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 @(WithDomain mods capture a api)) Request
req Domain
domain a
value
  hoistClientMonad :: forall (mon :: * -> *) (mon' :: * -> *).
Proxy m
-> Proxy (QualifiedCapture' mods capture a :> api)
-> (forall x. mon x -> mon' x)
-> Client mon (QualifiedCapture' mods capture a :> api)
-> Client mon' (QualifiedCapture' mods capture a :> api)
hoistClientMonad Proxy m
pm Proxy (QualifiedCapture' mods capture a :> api)
_ forall x. mon x -> mon' x
f Client mon (QualifiedCapture' mods capture a :> api)
cl = 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 (Client mon api -> Client mon' api)
-> (Qualified a -> Client mon api)
-> Qualified a
-> Client mon' api
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Client mon (QualifiedCapture' mods capture a :> api)
Qualified a -> Client mon api
cl

instance (RoutesToPaths api, KnownSymbol (AppendSymbol capture "_domain"), KnownSymbol capture) => RoutesToPaths (QualifiedCapture' mods capture a :> api) where
  getRoutes :: Forest PathSegment
getRoutes =
    forall routes. RoutesToPaths routes => Forest PathSegment
forall {k} (routes :: k).
RoutesToPaths routes =>
Forest PathSegment
getRoutes
      @( Capture' mods (AppendSymbol capture "_domain") Domain
           :> Capture' mods capture a
           :> api
       )