diff --git a/changelog.d/5-internal/pr-2633 b/changelog.d/5-internal/pr-2633 new file mode 100644 index 00000000000..a42da1ae9b0 --- /dev/null +++ b/changelog.d/5-internal/pr-2633 @@ -0,0 +1 @@ +`LoginId` migrated to schema-profunctor diff --git a/libs/wire-api/src/Wire/API/User/Auth.hs b/libs/wire-api/src/Wire/API/User/Auth.hs index d81da1511f3..ec0ebf0a96a 100644 --- a/libs/wire-api/src/Wire/API/User/Auth.hs +++ b/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 diff --git a/libs/wire-api/src/Wire/API/User/Auth2.hs b/libs/wire-api/src/Wire/API/User/Auth2.hs new file mode 100644 index 00000000000..9f8d88dd868 --- /dev/null +++ b/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 +-- +-- 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 . + +-- 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) diff --git a/libs/wire-api/test/unit/Main.hs b/libs/wire-api/test/unit/Main.hs index 8bd8aeefb91..2ef34990100 100644 --- a/libs/wire-api/test/unit/Main.hs +++ b/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, diff --git a/libs/wire-api/test/unit/Test/Wire/API/User/Auth.hs b/libs/wire-api/test/unit/Test/Wire/API/User/Auth.hs new file mode 100644 index 00000000000..cae20e5e557 --- /dev/null +++ b/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 +-- +-- 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 . +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 diff --git a/libs/wire-api/wire-api.cabal b/libs/wire-api/wire-api.cabal index d99d652103c..5dfed27cb9a 100644 --- a/libs/wire-api/wire-api.cabal +++ b/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