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

import Control.Lens ((<>~))
import Data.ByteString qualified as BS
import Data.HashMap.Strict.InsOrd qualified as InsOrdHashMap
import Data.Metrics.Servant
import Data.OpenApi hiding (HasServer, Header)
import Data.Text.Encoding qualified as T
import Imports
import Servant
import Servant.OpenApi
import Wire.API.Routes.Version

newtype Bearer a = Bearer {forall a. Bearer a -> a
unBearer :: a}

instance (FromHttpApiData a) => FromHttpApiData (Bearer a) where
  parseHeader :: ByteString -> Either Text (Bearer a)
parseHeader ByteString
h = case Int -> ByteString -> (ByteString, ByteString)
BS.splitAt Int
7 ByteString
h of
    (ByteString
"Bearer ", ByteString
suffix) -> a -> Bearer a
forall a. a -> Bearer a
Bearer (a -> Bearer a) -> Either Text a -> Either Text (Bearer a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> Either Text a
forall a. FromHttpApiData a => ByteString -> Either Text a
parseHeader ByteString
suffix
    (ByteString, ByteString)
_ -> Text -> Either Text (Bearer a)
forall a b. a -> Either a b
Left Text
"Invalid authorization scheme"
  parseUrlPiece :: Text -> Either Text (Bearer a)
parseUrlPiece = ByteString -> Either Text (Bearer a)
forall a. FromHttpApiData a => ByteString -> Either Text a
parseHeader (ByteString -> Either Text (Bearer a))
-> (Text -> ByteString) -> Text -> Either Text (Bearer a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
T.encodeUtf8

type BearerHeader a = Header' '[Lenient] "Authorization" (Bearer a)

type BearerQueryParam =
  QueryParam'
    [Lenient, Description "Access token"]
    "access_token"

type instance
  SpecialiseToVersion v (Bearer a :> api) =
    Bearer a :> SpecialiseToVersion v api

instance (HasOpenApi api) => HasOpenApi (Bearer a :> api) where
  toOpenApi :: Proxy (Bearer a :> api) -> OpenApi
toOpenApi Proxy (Bearer a :> api)
_ =
    Proxy api -> OpenApi
forall {k} (api :: k). HasOpenApi api => Proxy api -> OpenApi
toOpenApi (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @api)
      OpenApi -> (OpenApi -> OpenApi) -> OpenApi
forall a b. a -> (a -> b) -> b
& ([SecurityRequirement] -> Identity [SecurityRequirement])
-> OpenApi -> Identity OpenApi
forall s a. HasSecurity s a => Lens' s a
Lens' OpenApi [SecurityRequirement]
security (([SecurityRequirement] -> Identity [SecurityRequirement])
 -> OpenApi -> Identity OpenApi)
-> [SecurityRequirement] -> OpenApi -> OpenApi
forall a s t. Semigroup a => ASetter s t a a -> a -> s -> t
<>~ [InsOrdHashMap Text [Text] -> SecurityRequirement
SecurityRequirement (InsOrdHashMap Text [Text] -> SecurityRequirement)
-> InsOrdHashMap Text [Text] -> SecurityRequirement
forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> InsOrdHashMap Text [Text]
forall k v. Hashable k => k -> v -> InsOrdHashMap k v
InsOrdHashMap.singleton Text
"ZAuth" []]

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

instance
  ( HasContextEntry (ctx .++ DefaultErrorFormatters) ErrorFormatters,
    FromHttpApiData a,
    HasServer api ctx
  ) =>
  HasServer (Bearer a :> api) ctx
  where
  type ServerT (Bearer a :> api) m = Maybe (Either Text a) -> ServerT api m

  route :: forall env.
Proxy (Bearer a :> api)
-> Context ctx
-> Delayed env (Server (Bearer a :> api))
-> Router env
route Proxy (Bearer a :> api)
_ Context ctx
ctx Delayed env (Server (Bearer a :> api))
action =
    Proxy (BearerHeader a :> (BearerQueryParam a :> api))
-> Context ctx
-> Delayed
     env (Server (BearerHeader a :> (BearerQueryParam a :> api)))
-> Router env
forall env.
Proxy (BearerHeader a :> (BearerQueryParam a :> api))
-> Context ctx
-> Delayed
     env (Server (BearerHeader a :> (BearerQueryParam 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 @(BearerHeader a :> BearerQueryParam a :> api))
      Context ctx
ctx
      (((Maybe (Either Text a) -> ServerT api Handler)
 -> Maybe (Either Text (Bearer a))
 -> Maybe (Either Text a)
 -> ServerT api Handler)
-> Delayed env (Maybe (Either Text a) -> ServerT api Handler)
-> Delayed
     env
     (Maybe (Either Text (Bearer a))
      -> Maybe (Either Text 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 (\Maybe (Either Text a) -> ServerT api Handler
f Maybe (Either Text (Bearer a))
u Maybe (Either Text a)
v -> Maybe (Either Text a) -> ServerT api Handler
f ((Either Text (Bearer a) -> Either Text a)
-> Maybe (Either Text (Bearer a)) -> Maybe (Either Text a)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Bearer a -> a) -> Either Text (Bearer a) -> Either Text a
forall a b. (a -> b) -> Either Text a -> Either Text b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bearer a -> a
forall a. Bearer a -> a
unBearer) Maybe (Either Text (Bearer a))
u Maybe (Either Text a)
-> Maybe (Either Text a) -> Maybe (Either Text a)
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe (Either Text a)
v)) Delayed env (Server (Bearer a :> api))
Delayed env (Maybe (Either Text a) -> ServerT api Handler)
action)
  hoistServerWithContext :: forall (m :: * -> *) (n :: * -> *).
Proxy (Bearer a :> api)
-> Proxy ctx
-> (forall x. m x -> n x)
-> ServerT (Bearer a :> api) m
-> ServerT (Bearer a :> api) n
hoistServerWithContext Proxy (Bearer a :> api)
_ Proxy ctx
ctx forall x. m x -> n x
f ServerT (Bearer a :> api) m
h = 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 (ServerT api m -> ServerT api n)
-> (Maybe (Either Text a) -> ServerT api m)
-> Maybe (Either Text a)
-> ServerT api n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerT (Bearer a :> api) m
Maybe (Either Text a) -> ServerT api m
h