SQSERVICES-1645-backend-servantify-brig-auth-api

changelog.d/5-internal/pr-2633

@@ -0,0 +1 @@
+`LoginId` migrated to schema-profunctor

libs/wire-api/src/Wire/API/User/Auth.hs

@@ -56,7 +56,6 @@ import Data.Aeson
 import qualified Data.Aeson.Types as Aeson
 import Data.ByteString.Conversion
 import Data.Code as Code
-import Data.Handle (Handle)
 import Data.Id (UserId)
 import Data.Misc (PlainTextPassword (..))
 import Data.Schema (ToSchema)
@@ -66,7 +65,8 @@ import Data.Text.Lazy.Encoding (decodeUtf8, encodeUtf8)
 import Data.Time.Clock (UTCTime)
 import Imports
 import Wire.API.Arbitrary (Arbitrary (arbitrary), GenericUniform (..))
-import Wire.API.User.Identity (Email, Phone)
+import Wire.API.User.Auth2
+import Wire.API.User.Identity (Phone)
 
 --------------------------------------------------------------------------------
 -- Login
@@ -131,42 +131,12 @@ loginLabel :: Login -> Maybe CookieLabel
 loginLabel (PasswordLogin _ _ l _) = l
 loginLabel (SmsLogin _ _ l) = l
 
---------------------------------------------------------------------------------
--- LoginId
-
-data LoginId
-  = LoginByEmail Email
-  | LoginByPhone Phone
-  | LoginByHandle Handle
-  deriving stock (Eq, Show, Generic)
-  deriving (Arbitrary) via (GenericUniform LoginId)
-
-instance FromJSON LoginId where
-  parseJSON = withObject "LoginId" $ \o -> do
-    email <- fmap LoginByEmail <$> (o .:? "email")
-    phone <- fmap LoginByPhone <$> (o .:? "phone")
-    handle <- fmap LoginByHandle <$> (o .:? "handle")
-    maybe
-      (fail "'email', 'phone' or 'handle' required")
-      pure
-      (email <|> phone <|> handle)
-
--- NB. You might be tempted to rewrite this by applying (<|>) to
--- parsers themselves. However, the code as it is right now has a
--- property that if (e.g.) the email is present but unparseable,
--- parsing will fail. If you change it to use (<|>), unparseable
--- email (or phone, etc) will just cause the next parser to be
--- chosen, instead of failing early.
-
 loginIdPair :: LoginId -> Aeson.Pair
 loginIdPair = \case
   LoginByEmail s -> "email" .= s
   LoginByPhone s -> "phone" .= s
   LoginByHandle s -> "handle" .= s
 
-instance ToJSON LoginId where
-  toJSON loginId = object [loginIdPair loginId]
-
 --------------------------------------------------------------------------------
 -- LoginCode
 

libs/wire-api/src/Wire/API/User/Auth2.hs

@@ -0,0 +1,65 @@
+{-# LANGUAGE StrictData #-}
+
+-- 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/>.
+
+-- FUTUREWORK: replace `Wire.API.User.Auth` with this module once everything in `Auth` is migrated to schema-profunctor
+module Wire.API.User.Auth2 where
+
+import Data.Aeson (FromJSON (..), ToJSON (..))
+import qualified Data.Aeson.Types as A
+import Data.Handle (Handle)
+import Data.Schema
+import qualified Data.Swagger as S
+import Data.Tuple.Extra (fst3, snd3, thd3)
+import Imports
+import Wire.API.Arbitrary (Arbitrary, GenericUniform (..))
+import Wire.API.User.Identity (Email, Phone)
+
+--------------------------------------------------------------------------------
+-- LoginId
+
+data LoginId
+  = LoginByEmail Email
+  | LoginByPhone Phone
+  | LoginByHandle Handle
+  deriving stock (Eq, Show, Generic)
+  deriving (Arbitrary) via (GenericUniform LoginId)
+  deriving (ToJSON, FromJSON, S.ToSchema) via (Schema LoginId)
+
+-- NB. this should fail if (e.g.) the email is present but unparseable even if the JSON contains a valid phone number or handle.
+-- See tests in `Test.Wire.API.User.Auth`.
+instance ToSchema LoginId where
+  schema =
+    object "LoginId" $
+      fromLoginId .= tupleSchema `withParser` validate
+    where
+      fromLoginId :: LoginId -> (Maybe Email, Maybe Phone, Maybe Handle)
+      fromLoginId = \case
+        LoginByEmail e -> (Just e, Nothing, Nothing)
+        LoginByPhone p -> (Nothing, Just p, Nothing)
+        LoginByHandle h -> (Nothing, Nothing, Just h)
+      tupleSchema :: ObjectSchema SwaggerDoc (Maybe Email, Maybe Phone, Maybe Handle)
+      tupleSchema =
+        (,,)
+          <$> fst3 .= maybe_ (optField "email" schema)
+          <*> snd3 .= maybe_ (optField "phone" schema)
+          <*> thd3 .= maybe_ (optField "handle" schema)
+      validate :: (Maybe Email, Maybe Phone, Maybe Handle) -> A.Parser LoginId
+      validate (mEmail, mPhone, mHandle) =
+        maybe (fail "'email', 'phone' or 'handle' required") pure $
+          (LoginByEmail <$> mEmail) <|> (LoginByPhone <$> mPhone) <|> (LoginByHandle <$> mHandle)

libs/wire-api/test/unit/Main.hs

@@ -33,6 +33,7 @@ import qualified Test.Wire.API.Swagger as Swagger
 import qualified Test.Wire.API.Team.Export as Team.Export
 import qualified Test.Wire.API.Team.Member as Team.Member
 import qualified Test.Wire.API.User as User
+import qualified Test.Wire.API.User.Auth as User.Auth
 import qualified Test.Wire.API.User.RichInfo as User.RichInfo
 import qualified Test.Wire.API.User.Search as User.Search
 
@@ -47,6 +48,7 @@ main =
         User.tests,
         User.Search.tests,
         User.RichInfo.tests,
+        User.Auth.tests,
         Roundtrip.Aeson.tests,
         Roundtrip.ByteString.tests,
         Swagger.tests,

libs/wire-api/test/unit/Test/Wire/API/User/Auth.hs

@@ -0,0 +1,39 @@
+-- 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 Test.Wire.API.User.Auth where
+
+import qualified Data.Aeson as Aeson
+import Imports
+import qualified Test.Tasty as T
+import Test.Tasty.HUnit
+import Wire.API.User
+import Wire.API.User.Auth
+
+tests :: T.TestTree
+tests = T.testGroup "Auth" [loginIdHappyCase, loginIdFailFast]
+
+loginIdHappyCase :: T.TestTree
+loginIdHappyCase = testCase "LoginId parser: valid email" $ do
+  let actual :: Maybe LoginId = Aeson.decode "{\"email\":\"foo@bar.com\"}"
+  let expected = Just $ LoginByEmail (Email {emailLocal = "foo", emailDomain = "bar.com"})
+  assertEqual "should succeed" expected actual
+
+loginIdFailFast :: T.TestTree
+loginIdFailFast = testCase "LoginId parser: invalid email, valid phone" $ do
+  let actual :: Maybe LoginId = Aeson.decode "{\"email\":\"invalid-email\",\"phone\":\"+123456789\"}"
+  let expected = Nothing
+  assertEqual "should fail if any provided login id is invalid" expected actual

libs/wire-api/wire-api.cabal

@@ -107,6 +107,7 @@ library
     Wire.API.User
     Wire.API.User.Activation
     Wire.API.User.Auth
+    Wire.API.User.Auth2
     Wire.API.User.Client
     Wire.API.User.Client.Prekey
     Wire.API.User.Handle
@@ -617,6 +618,7 @@ test-suite wire-api-tests
     Test.Wire.API.Team.Export
     Test.Wire.API.Team.Member
     Test.Wire.API.User
+    Test.Wire.API.User.Auth
     Test.Wire.API.User.RichInfo
     Test.Wire.API.User.Search