Servantify brig's auth API (#2750)

* Servant Cookie combinator

* Parse authorization header

* Remove confusing type synonyms

* Create schemas for Wire.API.User.Auth types

* Fix build and golden tests

* Add Access(..)

* Add mkSomeAccess and mkSomeCookie & adapt

* Optional response headers in MultiVerb

* Replace SomeCookie with UserTokenCookie

* Finish servantification of access endpoint

* Servantify send-login-code

* Servantify login endpoint

* Servantify logout endpoint

* Servantify change-self-email endpoint

* Servantify list-cookies endpoint

* Servantify remove-cookies endpoint

* Change status code to 200

* Servantify legalhold-login endpoint

* Servantify sso-login endpoint

* Servantify login-code endpoint

* Servantify reauthenticate endpoint

* Fix build

* Add access_token query parameter

* Parse cookies leniently

* Adapt integration test to new error codes

* Add CanThrow annotations

* Document Bearer token in Swagger

* Add CHANGELOG entry

* Revert "Adapt integration test to new error codes"

This reverts commit 165340a.

* Make servant cookie parser lenient

* More leniency in Servant parsers

* Adapt some tests

* Remove redundant Brig error

* Redundant brackets

* lbl → label

* Reformat long line

* Remove empty routes

* Apply hlint suggestions

* Regenerate nix derivations

Co-authored-by: Stefan Matting <stefan@wire.com>

changelog.d/5-internal/auth-servant

@@ -0,0 +1 @@
+Convert brig's auth endpoints to servant

libs/api-bot/src/Network/Wire/Bot/Monad.hs

@@ -691,7 +691,7 @@ mkBot :: BotTag -> User -> PlainTextPassword -> BotNet Bot
 mkBot tag user pw = do
   log Info $ botLogFields (userId user) tag . msg (val "Login")
   let ident = fromMaybe (error "No email") (userEmail user)
-  let cred = PasswordLogin (LoginByEmail ident) pw Nothing Nothing
+  let cred = PasswordLogin (PasswordLoginData (LoginByEmail ident) pw Nothing Nothing)
   auth <- login cred >>= maybe (throwM LoginFailed) pure
   aref <- nextAuthRefresh auth
   env <- BotNet ask

libs/brig-types/brig-types.cabal

@@ -23,7 +23,6 @@ library
     Brig.Types.Team.LegalHold
     Brig.Types.Test.Arbitrary
     Brig.Types.User
-    Brig.Types.User.Auth
     Brig.Types.User.Event
 
   other-modules:      Paths_brig_types

libs/brig-types/src/Brig/Types/Intra.hs

@@ -24,14 +24,11 @@ module Brig.Types.Intra
     UserAccount (..),
     NewUserScimInvitation (..),
     UserSet (..),
-    ReAuthUser (..),
   )
 where
 
 import Data.Aeson as A
-import Data.Code as Code
 import Data.Id (TeamId)
-import Data.Misc (PlainTextPassword (..))
 import qualified Data.Schema as Schema
 import qualified Data.Swagger as S
 import Imports
@@ -134,27 +131,3 @@ instance ToJSON NewUserScimInvitation where
         "name" .= name,
         "email" .= email
       ]
-
--------------------------------------------------------------------------------
--- ReAuthUser
-
--- | Certain operations might require reauth of the user. These are available
--- only for users that have already set a password.
-data ReAuthUser = ReAuthUser
-  { reAuthPassword :: Maybe PlainTextPassword,
-    reAuthCode :: Maybe Code.Value,
-    reAuthCodeAction :: Maybe VerificationAction
-  }
-  deriving (Eq, Show, Generic)
-
-instance FromJSON ReAuthUser where
-  parseJSON = withObject "reauth-user" $ \o ->
-    ReAuthUser <$> o .:? "password" <*> o .:? "verification_code" <*> o .:? "action"
-
-instance ToJSON ReAuthUser where
-  toJSON ru =
-    object
-      [ "password" .= reAuthPassword ru,
-        "verification_code" .= reAuthCode ru,
-        "action" .= reAuthCodeAction ru
-      ]

libs/brig-types/test/unit/Test/Brig/Types/User.hs

@@ -26,7 +26,7 @@
 module Test.Brig.Types.User where
 
 import Brig.Types.Connection (UpdateConnectionsInternal (..))
-import Brig.Types.Intra (NewUserScimInvitation (..), ReAuthUser (..), UserAccount (..))
+import Brig.Types.Intra (NewUserScimInvitation (..), UserAccount (..))
 import Brig.Types.Search (SearchVisibilityInbound (..))
 import Brig.Types.User (ManagedByUpdate (..), RichInfoUpdate (..))
 import Data.Aeson
@@ -36,6 +36,7 @@ import Test.QuickCheck (Arbitrary (arbitrary))
 import Test.Tasty
 import Test.Tasty.HUnit
 import Wire.API.Routes.Internal.Brig.EJPD (EJPDRequestBody (..), EJPDResponseBody (..))
+import Wire.API.User.Auth.ReAuth
 
 tests :: TestTree
 tests = testGroup "User (types vs. aeson)" $ roundtripTests

libs/types-common/src/Data/CommaSeparatedList.hs

@@ -32,7 +32,8 @@ import Servant (FromHttpApiData (..))
 
 newtype CommaSeparatedList a = CommaSeparatedList {fromCommaSeparatedList :: [a]}
   deriving stock (Show, Eq)
-  deriving newtype (Bounds)
+  deriving (Functor, Foldable, Traversable)
+  deriving newtype (Bounds, Semigroup, Monoid)
 
 instance FromByteString (List a) => FromHttpApiData (CommaSeparatedList a) where
   parseUrlPiece t =

libs/wire-api/default.nix

@@ -22,7 +22,7 @@
 , tasty-hunit, tasty-quickcheck, text, time, types-common, unliftio
 , unordered-containers, uri-bytestring, utf8-string, uuid, vector
 , wai, wai-extra, wai-utilities, wai-websockets, websockets
-, wire-message-proto-lens, x509
+, wire-message-proto-lens, x509, zauth
 }:
 mkDerivation {
   pname = "wire-api";
@@ -45,7 +45,7 @@ mkDerivation {
     sop-core string-conversions swagger swagger2 tagged text time
     types-common unordered-containers uri-bytestring utf8-string uuid
     vector wai wai-extra wai-utilities wai-websockets websockets
-    wire-message-proto-lens x509
+    wire-message-proto-lens x509 zauth
   ];
   testHaskellDepends = [
     aeson aeson-pretty aeson-qq async base binary bytestring

libs/wire-api/src/Wire/API/Error/Brig.hs

@@ -55,6 +55,10 @@ data BrigError
   | MLSProtocolError
   | MLSDuplicatePublicKey
   | InvalidPhone
+  | PasswordExists
+  | AccountSuspended
+  | AccountEphemeral
+  | AccountPending
   | UserKeyExists
   | NameManagedByScim
   | HandleManagedByScim
@@ -162,6 +166,19 @@ type instance MapError 'MLSProtocolError = 'StaticError 400 "mls-protocol-error"
 
 type instance MapError 'InvalidPhone = 'StaticError 400 "invalid-phone" "Invalid mobile phone number"
 
+type instance
+  MapError 'PasswordExists =
+    'StaticError
+      403
+      "password-exists"
+      "The operation is not permitted because the user has a password set"
+
+type instance MapError 'AccountSuspended = 'StaticError 403 "suspended" "Account suspended"
+
+type instance MapError 'AccountEphemeral = 'StaticError 403 "ephemeral" "Account ephemeral"
+
+type instance MapError 'AccountPending = 'StaticError 403 "pending-activation" "Account pending activation"
+
 type instance MapError 'UserKeyExists = 'StaticError 409 "key-exists" "The given e-mail address or phone number is in use."
 
 type instance MapError 'NameManagedByScim = 'StaticError 403 "managed-by-scim" "Updating name is not allowed, because it is managed by SCIM"

libs/wire-api/src/Wire/API/Routes/Bearer.hs

@@ -0,0 +1,67 @@
+-- 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 qualified Data.ByteString as BS
+import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
+import Data.Metrics.Servant
+import Data.Swagger hiding (Header)
+import qualified Data.Text.Encoding as T
+import Imports
+import Servant
+import Servant.Swagger
+
+newtype Bearer a = Bearer {unBearer :: a}
+
+instance FromHttpApiData a => FromHttpApiData (Bearer a) where
+  parseHeader h = case BS.splitAt 7 h of
+    ("Bearer ", suffix) -> Bearer <$> parseHeader suffix
+    _ -> Left "Invalid authorization scheme"
+  parseUrlPiece = parseHeader . T.encodeUtf8
+
+type BearerHeader a = Header' '[Lenient] "Authorization" (Bearer a)
+
+type BearerQueryParam =
+  QueryParam'
+    [Lenient, Description "Access token"]
+    "access_token"
+
+instance HasSwagger api => HasSwagger (Bearer a :> api) where
+  toSwagger _ =
+    toSwagger (Proxy @api)
+      & security <>~ [SecurityRequirement $ InsOrdHashMap.singleton "ZAuth" []]
+
+instance RoutesToPaths api => RoutesToPaths (Bearer a :> api) where
+  getRoutes = 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 _ ctx action =
+    route
+      (Proxy @(BearerHeader a :> BearerQueryParam a :> api))
+      ctx
+      (fmap (\f u v -> f (fmap (fmap unBearer) u <|> v)) action)
+  hoistServerWithContext _ ctx f h = hoistServerWithContext (Proxy @api) ctx f . h

libs/wire-api/src/Wire/API/Routes/Cookies.hs

@@ -0,0 +1,124 @@
+-- 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.Cookies where
+
+import Data.List.NonEmpty (NonEmpty (..))
+import qualified Data.Map as M
+import Data.Metrics.Servant
+import Data.SOP
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as T
+import GHC.TypeLits
+import Imports
+import Servant
+import Servant.Swagger
+import Web.Cookie (parseCookies)
+
+data (:::) a b
+
+-- | A combinator to extract cookies from an HTTP request. The recommended way
+-- to use this combinator is to specify it exactly once in the description of
+-- an endpoint, passing a list of pairs of cookie name and type, separated by
+-- '(:::)'. Cookies are always optional.
+--
+-- For example:
+-- @@
+-- Cookies '["foo" ::: Int64, "bar" ::: Text]
+-- @@
+-- results in a cookie with name "foo" containing a 64-bit integer, and a
+-- cookie with name "bar" containing an arbitrary text value.
+data Cookies (cs :: [*])
+
+type CookieHeader cs = Header "Cookie" (CookieTuple cs)
+
+-- CookieTypes = map snd
+type family CookieTypes (cs :: [*]) :: [*]
+
+type instance CookieTypes '[] = '[]
+
+type instance CookieTypes ((label ::: x) ': cs) = ([Either Text x] ': CookieTypes cs)
+
+newtype CookieTuple cs = CookieTuple {unCookieTuple :: NP I (CookieTypes cs)}
+
+type CookieMap = Map ByteString (NonEmpty ByteString)
+
+instance HasSwagger api => HasSwagger (Cookies cs :> api) where
+  toSwagger _ = toSwagger (Proxy @api)
+
+class CookieArgs (cs :: [*]) where
+  -- example: AddArgs ["foo" :: Foo, "bar" :: Bar] a = Foo -> Bar -> a
+  type AddArgs cs a :: *
+
+  uncurryArgs :: AddArgs cs a -> CookieTuple cs -> a
+  mapArgs :: (a -> b) -> AddArgs cs a -> AddArgs cs b
+  mkTuple :: CookieMap -> Either Text (CookieTuple cs)
+  emptyTuple :: CookieTuple cs
+
+instance CookieArgs '[] where
+  type AddArgs '[] a = a
+  uncurryArgs a _ = a
+  mapArgs h = h
+  mkTuple _ = pure emptyTuple
+  emptyTuple = CookieTuple Nil
+
+instance
+  ( CookieArgs cs,
+    KnownSymbol label,
+    FromHttpApiData x
+  ) =>
+  CookieArgs ((label ::: (x :: *)) ': cs)
+  where
+  type AddArgs ((label ::: x) ': cs) a = [Either Text x] -> AddArgs cs a
+  uncurryArgs f (CookieTuple (I x :* xs)) = uncurryArgs @cs (f x) (CookieTuple xs)
+  mapArgs h f = mapArgs @cs h . f
+  mkTuple m = do
+    let k = T.pack (symbolVal (Proxy @label))
+    bs <- pure . maybe [] toList $ M.lookup (T.encodeUtf8 k) m
+    let vs = map parseHeader bs
+    CookieTuple t <- mkTuple @cs m
+    pure (CookieTuple (I vs :* t))
+  emptyTuple = CookieTuple (I [] :* unCookieTuple (emptyTuple @cs))
+
+mkCookieMap :: [(ByteString, ByteString)] -> CookieMap
+mkCookieMap = foldr (\(k, v) -> M.insertWith (<>) k (pure v)) mempty
+
+instance CookieArgs cs => FromHttpApiData (CookieTuple cs) where
+  parseHeader = mkTuple . mkCookieMap . parseCookies
+  parseUrlPiece = parseHeader . T.encodeUtf8
+
+instance
+  ( HasContextEntry (ctx .++ DefaultErrorFormatters) ErrorFormatters,
+    CookieArgs cs,
+    HasServer api ctx
+  ) =>
+  HasServer (Cookies cs :> api) ctx
+  where
+  type ServerT (Cookies cs :> api) m = AddArgs cs (ServerT api m)
+
+  route _ ctx action =
+    route
+      (Proxy @(CookieHeader cs :> api))
+      ctx
+      ( fmap
+          (\f -> uncurryArgs f . fromMaybe emptyTuple)
+          action
+      )
+  hoistServerWithContext _ ctx f = mapArgs @cs (hoistServerWithContext (Proxy @api) ctx f)
+
+instance RoutesToPaths api => RoutesToPaths (Cookies cs :> api) where
+  getRoutes = getRoutes @api