From 0e5719f870dc55d9aa9506a8b342655cfa59433a Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Wed, 9 Feb 2022 17:33:00 +0100 Subject: [PATCH 01/18] [WIP] Brig: Servantify `POST /register` endpoint --- .../src/Wire/API/Routes/Public/Brig.hs | 14 ++ libs/wire-api/src/Wire/API/Team.hs | 32 +-- libs/wire-api/src/Wire/API/User.hs | 221 ++++++++++-------- libs/wire-api/src/Wire/API/User/Activation.hs | 5 +- libs/wire-api/src/Wire/API/User/Identity.hs | 71 +++--- libs/wire-api/src/Wire/API/User/Orphans.hs | 4 + libs/wire-api/src/Wire/API/Util/Aeson.hs | 6 + 7 files changed, 203 insertions(+), 150 deletions(-) diff --git a/libs/wire-api/src/Wire/API/Routes/Public/Brig.hs b/libs/wire-api/src/Wire/API/Routes/Public/Brig.hs index 9181305a43..b7bd5d78c6 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Brig.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Brig.hs @@ -312,6 +312,19 @@ type SelfAPI = :> MultiVerb 'PUT '[JSON] ChangeHandleResponses (Maybe ChangeHandleError) ) +type AccountAPI = + Named + "register" + ( Summary "Register a new user." + :> Description + "If the environment where the registration takes \ + \place is private and a registered email address or phone \ + \number is not whitelisted, a 403 error is returned." + :> "register" + :> ReqBody '[JSON] NewUserPublic + :> MultiVerb 'POST '[JSON] RegisterResponses (Either RegisterError SelfProfile) + ) + type PrekeyAPI = Named "get-users-prekeys-client-unqualified" @@ -714,6 +727,7 @@ type MLSAPI = LiftNamed (ZLocalUser :> "mls" :> MLSKeyPackageAPI) type BrigAPI = UserAPI :<|> SelfAPI + :<|> AccountAPI :<|> ClientAPI :<|> PrekeyAPI :<|> UserClientAPI diff --git a/libs/wire-api/src/Wire/API/Team.hs b/libs/wire-api/src/Wire/API/Team.hs index 5b3563e181..ed773095b0 100644 --- a/libs/wire-api/src/Wire/API/Team.hs +++ b/libs/wire-api/src/Wire/API/Team.hs @@ -39,6 +39,7 @@ module Wire.API.Team -- * NewTeam BindingNewTeam (..), + bindingNewTeamObjectSchema, NonBindingNewTeam (..), NewTeam (..), newNewTeam, @@ -193,12 +194,13 @@ modelNewBindingTeam = Doc.defineModel "NewBindingTeam" $ do Doc.optional instance ToSchema BindingNewTeam where - schema = BindingNewTeam <$> unwrap .= newTeamSchema "BindingNewTeam" sch - where - unwrap (BindingNewTeam nt) = nt + schema = object "BindingNewTeam" bindingNewTeamObjectSchema - sch :: ValueSchema SwaggerDoc () - sch = null_ +bindingNewTeamObjectSchema :: ObjectSchema SwaggerDoc BindingNewTeam +bindingNewTeamObjectSchema = + BindingNewTeam <$> unwrap .= newTeamObjectSchema null_ + where + unwrap (BindingNewTeam nt) = nt -- FUTUREWORK: since new team members do not get serialized, we zero them here. -- it may be worth looking into how this can be solved in the types. @@ -214,7 +216,10 @@ newtype NonBindingNewTeam = NonBindingNewTeam (NewTeam (Range 1 127 [TeamMember] deriving (FromJSON, ToJSON, S.ToSchema) via (Schema NonBindingNewTeam) instance ToSchema NonBindingNewTeam where - schema = NonBindingNewTeam <$> unwrap .= newTeamSchema "NonBindingNewTeam" sch + schema = + object "NonBindingNewTeam" $ + NonBindingNewTeam + <$> unwrap .= newTeamObjectSchema sch where unwrap (NonBindingNewTeam nt) = nt @@ -247,14 +252,13 @@ data NewTeam a = NewTeam newNewTeam :: Range 1 256 Text -> Range 1 256 Text -> NewTeam a newNewTeam nme ico = NewTeam nme ico Nothing Nothing -newTeamSchema :: HasSchemaRef d => Text -> ValueSchema d a -> ValueSchema NamedSwaggerDoc (NewTeam a) -newTeamSchema name sch = - object name $ - NewTeam - <$> _newTeamName .= field "name" schema - <*> _newTeamIcon .= field "icon" schema - <*> _newTeamIconKey .= maybe_ (optField "icon_key" schema) - <*> _newTeamMembers .= maybe_ (optField "members" sch) +newTeamObjectSchema :: ValueSchema SwaggerDoc a -> ObjectSchema SwaggerDoc (NewTeam a) +newTeamObjectSchema sch = + NewTeam + <$> _newTeamName .= field "name" schema + <*> _newTeamIcon .= field "icon" schema + <*> _newTeamIconKey .= maybe_ (optField "icon_key" schema) + <*> _newTeamMembers .= maybe_ (optField "members" sch) -------------------------------------------------------------------------------- -- TeamUpdateData diff --git a/libs/wire-api/src/Wire/API/User.hs b/libs/wire-api/src/Wire/API/User.hs index f097607fd7..0b2f994b35 100644 --- a/libs/wire-api/src/Wire/API/User.hs +++ b/libs/wire-api/src/Wire/API/User.hs @@ -37,6 +37,8 @@ module Wire.API.User -- * NewUser NewUserPublic (..), + RegisterError (..), + RegisterResponses, NewUser (..), emptyNewUser, ExpiresIn, @@ -107,7 +109,7 @@ where import Control.Applicative import Control.Error.Safe (rightMay) -import Control.Lens (over, view, (.~), (?~)) +import Control.Lens (dimap, over, view, (.~), (?~), _1, _2, _3, _4) import Data.Aeson (FromJSON (..), ToJSON (..)) import qualified Data.Aeson.KeyMap as KeyMap import qualified Data.Aeson.Types as A @@ -143,11 +145,12 @@ import Wire.API.Arbitrary (Arbitrary (arbitrary), GenericUniform (..)) import Wire.API.ErrorDescription import Wire.API.Provider.Service (ServiceRef, modelServiceRef) import Wire.API.Routes.MultiVerb -import Wire.API.Team (BindingNewTeam (BindingNewTeam), NewTeam (..), modelNewBindingTeam) +import Wire.API.Team (BindingNewTeam, bindingNewTeamObjectSchema, modelNewBindingTeam) import Wire.API.User.Activation (ActivationCode) import Wire.API.User.Auth (CookieLabel) import Wire.API.User.Identity import Wire.API.User.Profile +import Wire.API.Util.Aeson (eitherToParser) -------------------------------------------------------------------------------- -- UserIdList @@ -502,7 +505,7 @@ publicProfile u legalHoldStatus = -- SCIM-managed user) newtype NewUserPublic = NewUserPublic NewUser deriving stock (Eq, Show, Generic) - deriving newtype (ToJSON) + deriving (ToJSON, FromJSON, S.ToSchema) via (Schema NewUserPublic) modelNewUser :: Doc.Model modelNewUser = Doc.defineModel "NewUser" $ do @@ -548,10 +551,11 @@ modelNewUser = Doc.defineModel "NewUser" $ do Doc.description "New team information. Mutually exclusive with team_code|invitation_code" Doc.optional -instance FromJSON NewUserPublic where - parseJSON val = do - nu <- parseJSON val - either fail pure $ validateNewUserPublic nu +instance ToSchema NewUserPublic where + schema = + unwrap .= withParser schema (eitherToParser . validateNewUserPublic) + where + unwrap (NewUserPublic nu) = nu validateNewUserPublic :: NewUser -> Either String NewUserPublic validateNewUserPublic nu @@ -586,6 +590,10 @@ isNewUserTeamMember u = case newUserTeam u of instance Arbitrary NewUserPublic where arbitrary = arbitrary `QC.suchThatMap` (rightMay . validateNewUserPublic) +data RegisterError = RegisterError + +type RegisterResponses = '[] + data NewUser = NewUser { newUserDisplayName :: Name, -- | use this as 'UserId' (if 'Nothing', call 'Data.UUID.nextRandom'). @@ -605,6 +613,7 @@ data NewUser = NewUser newUserManagedBy :: Maybe ManagedBy } deriving stock (Eq, Show, Generic) + deriving (ToJSON, FromJSON, S.ToSchema) via (Schema NewUser) emptyNewUser :: Name -> NewUser emptyNewUser name = @@ -628,47 +637,49 @@ emptyNewUser name = -- | 1 second - 1 week type ExpiresIn = Range 1 604800 Integer -instance ToJSON NewUser where - toJSON u = - A.object $ - "name" A..= newUserDisplayName u - # "uuid" A..= newUserUUID u - # "email" A..= newUserEmail u - # "email_code" A..= newUserEmailCode u - # "picture" A..= newUserPict u - # "assets" A..= newUserAssets u - # "phone" A..= newUserPhone u - # "phone_code" A..= newUserPhoneCode u - # "accent_id" A..= newUserAccentId u - # "label" A..= newUserLabel u - # "locale" A..= newUserLocale u - # "password" A..= newUserPassword u - # "expires_in" A..= newUserExpiresIn u - # "sso_id" A..= newUserSSOId u - # "managed_by" A..= newUserManagedBy u - # maybe [] jsonNewUserOrigin (newUserOrigin u) - -instance FromJSON NewUser where - parseJSON = A.withObject "new-user" $ \o -> do - ssoid <- o A..:? "sso_id" - newUserDisplayName <- o A..: "name" - newUserUUID <- o A..:? "uuid" - newUserIdentity <- parseIdentity ssoid o - newUserPict <- o A..:? "picture" - newUserAssets <- o A..:? "assets" A..!= [] - newUserAccentId <- o A..:? "accent_id" - newUserEmailCode <- o A..:? "email_code" - newUserPhoneCode <- o A..:? "phone_code" - newUserLabel <- o A..:? "label" - newUserLocale <- o A..:? "locale" - newUserPassword <- o A..:? "password" - newUserOrigin <- parseNewUserOrigin newUserPassword newUserIdentity ssoid o - newUserExpires <- o A..:? "expires_in" - newUserExpiresIn <- case (newUserExpires, newUserIdentity) of - (Just _, Just _) -> fail "Only users without an identity can expire" - _ -> return newUserExpires - newUserManagedBy <- o A..:? "managed_by" - return NewUser {..} +newtype BoolPair = BoolPair {boolUnpair :: (Bool, Bool)} + deriving (Bounded) + +instance Enum BoolPair where + toEnum n + | n < 2 = BoolPair (toEnum n, False) + | otherwise = BoolPair (toEnum (n - 2), True) + fromEnum (BoolPair (b1, b2)) = fromEnum b1 + fromEnum b2 + +boolPairSchema :: (Monoid doc, Monoid w) => SchemaP doc v w Bool Bool -> SchemaP doc v w Bool Bool -> SchemaP doc v w BoolPair BoolPair +boolPairSchema sch1 sch2 = + dimap boolUnpair BoolPair $ + (,) + <$> fst .= sch1 + <*> snd .= sch2 + +mkBoolPair :: Bool -> Bool -> BoolPair +mkBoolPair b1 b2 = BoolPair (b1, b2) + +instance ToSchema NewUser where + schema = + object "NewUser" + . dimap (\nu -> (mkBoolPair (isJust (newUserPassword nu)) (isJust (newUserSSOId nu)), nu)) snd + $ bind + (fst .= boolPairSchema (isJust <$> optField "password" schema) (isJust <$> optField "sso_id" schema)) + (snd .= dispatch newUserObjectSchema) + where + newUserObjectSchema (BoolPair (hasPassword, hasSSO)) = + NewUser + <$> newUserDisplayName .= field "name" schema + <*> newUserUUID .= maybe_ (optField "uuid" genericToSchema) + <*> newUserIdentity .= maybeUserIdentityObjectSchema + <*> newUserPict .= maybe_ (optField "picture" schema) + <*> newUserAssets .= (fromMaybe [] <$> optField "assets" (array schema)) + <*> newUserAccentId .= maybe_ (optField "accent_id" schema) + <*> newUserEmailCode .= maybe_ (optField "email_code" schema) + <*> newUserPhoneCode .= maybe_ (optField "phone_code" schema) + <*> newUserOrigin .= maybeNewUserOriginObjectSchema hasPassword hasSSO + <*> newUserLabel .= maybe_ (optField "label" schema) + <*> newUserLocale .= maybe_ (optField "locale" schema) + <*> newUserPassword .= maybe_ (optField "password" schema) + <*> newUserExpiresIn .= maybe_ (optField "expires_in" schema) + <*> newUserManagedBy .= pure Nothing -- FUTUREWORK: align more with FromJSON instance? instance Arbitrary NewUser where @@ -739,43 +750,67 @@ data NewUserOrigin deriving stock (Eq, Show, Generic) deriving (Arbitrary) via (GenericUniform NewUserOrigin) -jsonNewUserOrigin :: NewUserOrigin -> [A.Pair] -jsonNewUserOrigin = \case - NewUserOriginInvitationCode inv -> ["invitation_code" A..= inv] - NewUserOriginTeamUser (NewTeamMember tc) -> ["team_code" A..= tc] - NewUserOriginTeamUser (NewTeamCreator team) -> ["team" A..= team] - NewUserOriginTeamUser (NewTeamMemberSSO ti) -> ["team_id" A..= ti] - -parseNewUserOrigin :: - Maybe PlainTextPassword -> - Maybe UserIdentity -> - Maybe UserSSOId -> - A.Object -> - A.Parser (Maybe NewUserOrigin) -parseNewUserOrigin pass uid ssoid o = do - invcode <- o A..:? "invitation_code" - teamcode <- o A..:? "team_code" - team <- o A..:? "team" - teamid <- o A..:? "team_id" - result <- case (invcode, teamcode, team, ssoid, teamid) of - (Just a, Nothing, Nothing, Nothing, Nothing) -> return . Just . NewUserOriginInvitationCode $ a - (Nothing, Just a, Nothing, Nothing, Nothing) -> return . Just . NewUserOriginTeamUser $ NewTeamMember a - (Nothing, Nothing, Just a, Nothing, Nothing) -> return . Just . NewUserOriginTeamUser $ NewTeamCreator a - (Nothing, Nothing, Nothing, Just _, Just t) -> return . Just . NewUserOriginTeamUser $ NewTeamMemberSSO t - (Nothing, Nothing, Nothing, Nothing, Nothing) -> return Nothing - (_, _, _, Just _, Nothing) -> fail "sso_id, team_id must be either both present or both absent." - (_, _, _, Nothing, Just _) -> fail "sso_id, team_id must be either both present or both absent." - _ -> fail "team_code, team, invitation_code, sso_id, and the pair (sso_id, team_id) are mutually exclusive" - case (result, pass, uid) of - (_, _, Just SSOIdentity {}) -> pure result - (Just (NewUserOriginTeamUser _), Nothing, _) -> fail "all team users must set a password on creation" +type NewUserOriginComponents = (Maybe InvitationCode, Maybe InvitationCode, Maybe BindingNewTeamUser, Maybe TeamId) + +maybeNewUserOriginObjectSchema :: + -- | Has password + Bool -> + -- | Has SSOId + Bool -> + ObjectSchema SwaggerDoc (Maybe NewUserOrigin) +maybeNewUserOriginObjectSchema hasPassword hasSSO = + flip withParser eitherToParser $ + dimap + maybeNewUserOriginToComponents + (maybeNewUserOriginFromComponents hasPassword hasSSO) + newUserOriginComponentsObjectSchema + +newUserOriginComponentsObjectSchema :: ObjectSchema SwaggerDoc NewUserOriginComponents +newUserOriginComponentsObjectSchema = + (,,,) + <$> view _1 .= maybe_ (optField "invitation_code" schema) + <*> view _2 .= maybe_ (optField "team_code" schema) + <*> view _3 .= maybe_ (optField "team" schema) + <*> view _4 .= maybe_ (optField "team_id" schema) + +maybeNewUserOriginToComponents :: Maybe NewUserOrigin -> NewUserOriginComponents +maybeNewUserOriginToComponents = + \case + Nothing -> (Nothing, Nothing, Nothing, Nothing) + Just (NewUserOriginInvitationCode ic) -> (Just ic, Nothing, Nothing, Nothing) + Just (NewUserOriginTeamUser ntu) -> case ntu of + NewTeamMember tc -> (Nothing, Just tc, Nothing, Nothing) + NewTeamCreator bntu -> (Nothing, Nothing, Just bntu, Nothing) + NewTeamMemberSSO tid -> (Nothing, Nothing, Nothing, Just tid) + +maybeNewUserOriginFromComponents :: + -- | Does the user have a password + Bool -> + -- | Does the user have an SSO Identity + Bool -> + NewUserOriginComponents -> + Either String (Maybe NewUserOrigin) +maybeNewUserOriginFromComponents hasPassword hasSSO (invcode, teamcode, team, teamid) = do + result <- case (invcode, teamcode, team, hasSSO, teamid) of + (Just a, Nothing, Nothing, False, Nothing) -> Right . Just . NewUserOriginInvitationCode $ a + (Nothing, Just a, Nothing, False, Nothing) -> Right . Just . NewUserOriginTeamUser $ NewTeamMember a + (Nothing, Nothing, Just a, False, Nothing) -> Right . Just . NewUserOriginTeamUser $ NewTeamCreator a + (Nothing, Nothing, Nothing, True, Just t) -> Right . Just . NewUserOriginTeamUser $ NewTeamMemberSSO t + (Nothing, Nothing, Nothing, False, Nothing) -> Right Nothing + (_, _, _, True, Nothing) -> Left "sso_id, team_id must be either both present or both absent." + (_, _, _, False, Just _) -> Left "sso_id, team_id must be either both present or both absent." + _ -> Left "team_code, team, invitation_code, sso_id, and the pair (sso_id, team_id) are mutually exclusive" + case (result, hasPassword, hasSSO) of + (_, _, True) -> Right result + (Just (NewUserOriginTeamUser _), False, _) -> Left "all team users must set a password on creation" _ -> pure result -- | A random invitation code for use during registration newtype InvitationCode = InvitationCode {fromInvitationCode :: AsciiBase64Url} deriving stock (Eq, Show, Generic) - deriving newtype (FromJSON, ToJSON, ToByteString, FromByteString, Arbitrary) + deriving newtype (ToSchema, ToByteString, FromByteString, Arbitrary) + deriving (FromJSON, ToJSON, S.ToSchema) via Schema InvitationCode -------------------------------------------------------------------------------- -- helpers @@ -810,28 +845,14 @@ data BindingNewTeamUser = BindingNewTeamUser } deriving stock (Eq, Show, Generic) deriving (Arbitrary) via (GenericUniform BindingNewTeamUser) + deriving (ToJSON, FromJSON, S.ToSchema) via (Schema BindingNewTeamUser) -instance ToJSON BindingNewTeamUser where - toJSON (BindingNewTeamUser (BindingNewTeam t) c) = - A.object $ - "currency" A..= c - # newTeamJson t - where - -- FUTUREWORK(leif): this was originally defined in libs/wire-api/src/Wire/API/Team.hs and I moved it here - -- during the process of servantifying, it should go away when servantification is complete - newTeamJson :: NewTeam a -> [A.Pair] - newTeamJson (NewTeam n i ik _) = - "name" A..= fromRange n - # "icon" A..= fromRange i - # "icon_key" A..= (fromRange <$> ik) - # [] - -instance FromJSON BindingNewTeamUser where - parseJSON j@(A.Object o) = do - c <- o A..:? "currency" - t <- parseJSON j - return $ BindingNewTeamUser t c - parseJSON _ = fail "parseJSON BindingNewTeamUser: must be an object" +instance ToSchema BindingNewTeamUser where + schema = + object "BindingNewTeamUser" $ + BindingNewTeamUser + <$> bnuTeam .= bindingNewTeamObjectSchema + <*> bnuCurrency .= maybe_ (optField "currenncy" genericToSchema) -------------------------------------------------------------------------------- -- Profile Updates diff --git a/libs/wire-api/src/Wire/API/User/Activation.hs b/libs/wire-api/src/Wire/API/User/Activation.hs index a4a2f2a056..50f6b025da 100644 --- a/libs/wire-api/src/Wire/API/User/Activation.hs +++ b/libs/wire-api/src/Wire/API/User/Activation.hs @@ -43,6 +43,8 @@ where import Data.Aeson import Data.ByteString.Conversion import Data.Json.Util ((#)) +import Data.Schema (Schema (..), ToSchema) +import qualified Data.Swagger as S import qualified Data.Swagger.Build.Api as Doc import Data.Text.Ascii import Imports @@ -84,7 +86,8 @@ newtype ActivationKey = ActivationKey newtype ActivationCode = ActivationCode {fromActivationCode :: AsciiBase64Url} deriving stock (Eq, Show, Generic) - deriving newtype (ToByteString, FromByteString, ToJSON, FromJSON, Arbitrary) + deriving newtype (ToByteString, FromByteString, ToSchema, Arbitrary) + deriving (ToJSON, FromJSON, S.ToSchema) via Schema ActivationCode -------------------------------------------------------------------------------- -- Activate diff --git a/libs/wire-api/src/Wire/API/User/Identity.hs b/libs/wire-api/src/Wire/API/User/Identity.hs index 07ca0f4bc9..6721340613 100644 --- a/libs/wire-api/src/Wire/API/User/Identity.hs +++ b/libs/wire-api/src/Wire/API/User/Identity.hs @@ -46,11 +46,12 @@ module Wire.API.User.Identity emailFromSAMLNameID, mkSampleUref, mkSimpleSampleUref, + maybeUserIdentityObjectSchema, ) where import Control.Applicative (optional) -import Control.Lens (over, (.~), (?~), (^.)) +import Control.Lens (dimap, over, (.~), (?~), (^.)) import Data.Aeson (FromJSON (..), ToJSON (..)) import qualified Data.Aeson as A import qualified Data.Aeson.Types as A @@ -65,6 +66,7 @@ import qualified Data.Swagger as S import qualified Data.Text as Text import Data.Text.Encoding (decodeUtf8', encodeUtf8) import Data.Time.Clock +import Data.Tuple.Extra (fst3, snd3, thd3) import Imports import SAML2.WebSSO.Test.Arbitrary () import qualified SAML2.WebSSO.Types as SAML @@ -90,41 +92,40 @@ data UserIdentity | SSOIdentity UserSSOId (Maybe Email) (Maybe Phone) deriving stock (Eq, Show, Generic) deriving (Arbitrary) via (GenericUniform UserIdentity) + deriving (ToJSON, FromJSON, S.ToSchema) via (Schema UserIdentity) -instance S.ToSchema UserIdentity where - declareNamedSchema _ = do - emailSchema <- S.declareSchemaRef (Proxy @Email) - phoneSchema <- S.declareSchemaRef (Proxy @Phone) - ssoSchema <- S.declareSchemaRef (Proxy @UserSSOId) - return $ - S.NamedSchema (Just "userIdentity") $ - mempty - & S.type_ ?~ S.SwaggerObject - & S.properties - .~ [ ("email", emailSchema), - ("phone", phoneSchema), - ("sso_id", ssoSchema) - ] - -instance ToJSON UserIdentity where - toJSON = \case - FullIdentity em ph -> go (Just em) (Just ph) Nothing - EmailIdentity em -> go (Just em) Nothing Nothing - PhoneIdentity ph -> go Nothing (Just ph) Nothing - SSOIdentity si em ph -> go em ph (Just si) - where - go :: Maybe Email -> Maybe Phone -> Maybe UserSSOId -> A.Value - go em ph si = A.object ["email" A..= em, "phone" A..= ph, "sso_id" A..= si] - -instance FromJSON UserIdentity where - parseJSON = A.withObject "UserIdentity" $ \o -> do - email <- o A..:? "email" - phone <- o A..:? "phone" - ssoid <- o A..:? "sso_id" - maybe - (fail "Missing 'email' or 'phone' or 'sso_id'.") - return - (newIdentity email phone ssoid) +instance ToSchema UserIdentity where + schema = + object "UserIdentity" $ + Just .= withParser maybeUserIdentityObjectSchema (maybe (fail "Missing 'email' or 'phone' or 'sso_id'.") pure) + +maybeUserIdentityObjectSchema :: ObjectSchema SwaggerDoc (Maybe UserIdentity) +maybeUserIdentityObjectSchema = + dimap maybeUserIdentityToComponents maybeUserIdentityFromComponents userIdentityComponentsObjectSchema + +type UserIdentityComponents = (Maybe Email, Maybe Phone, Maybe UserSSOId) + +userIdentityComponentsObjectSchema :: ObjectSchema SwaggerDoc UserIdentityComponents +userIdentityComponentsObjectSchema = + (,,) + <$> fst3 .= maybe_ (optField "email" schema) + <*> snd3 .= maybe_ (optField "phone" schema) + <*> thd3 .= maybe_ (optField "sso_id" genericToSchema) + +maybeUserIdentityFromComponents :: UserIdentityComponents -> Maybe UserIdentity +maybeUserIdentityFromComponents = \case + (maybeEmail, maybePhone, Just ssoid) -> Just $ SSOIdentity ssoid maybeEmail maybePhone + (Just email, Just phone, Nothing) -> Just $ FullIdentity email phone + (Just email, Nothing, Nothing) -> Just $ EmailIdentity email + (Nothing, Just phone, Nothing) -> Just $ PhoneIdentity phone + (Nothing, Nothing, Nothing) -> Nothing + +maybeUserIdentityToComponents :: Maybe UserIdentity -> UserIdentityComponents +maybeUserIdentityToComponents Nothing = (Nothing, Nothing, Nothing) +maybeUserIdentityToComponents (Just (FullIdentity email phone)) = (Just email, Just phone, Nothing) +maybeUserIdentityToComponents (Just (EmailIdentity email)) = (Just email, Nothing, Nothing) +maybeUserIdentityToComponents (Just (PhoneIdentity phone)) = (Nothing, Just phone, Nothing) +maybeUserIdentityToComponents (Just (SSOIdentity ssoid m_email m_phone)) = (m_email, m_phone, Just ssoid) newIdentity :: Maybe Email -> Maybe Phone -> Maybe UserSSOId -> Maybe UserIdentity newIdentity email phone (Just sso) = Just $! SSOIdentity sso email phone diff --git a/libs/wire-api/src/Wire/API/User/Orphans.hs b/libs/wire-api/src/Wire/API/User/Orphans.hs index 232d4f1f85..7dd5e5dfd2 100644 --- a/libs/wire-api/src/Wire/API/User/Orphans.hs +++ b/libs/wire-api/src/Wire/API/User/Orphans.hs @@ -21,6 +21,7 @@ module Wire.API.User.Orphans where import Control.Lens +import qualified Data.Currency as Currency import Data.ISO3166_CountryCodes import Data.LanguageCodes import Data.Proxy @@ -121,3 +122,6 @@ instance ToParamSchema URI where instance ToSchema X509.SignedCertificate where declareNamedSchema _ = declareNamedSchema (Proxy @String) + +instance ToSchema Currency.Alpha where + declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions diff --git a/libs/wire-api/src/Wire/API/Util/Aeson.hs b/libs/wire-api/src/Wire/API/Util/Aeson.hs index 4b0f3ad2d7..6ea1515069 100644 --- a/libs/wire-api/src/Wire/API/Util/Aeson.hs +++ b/libs/wire-api/src/Wire/API/Util/Aeson.hs @@ -18,10 +18,12 @@ module Wire.API.Util.Aeson ( customEncodingOptions, CustomEncoded (..), + eitherToParser, ) where import Data.Aeson +import Data.Aeson.Types (Parser) import qualified Data.Char as Char import GHC.Generics (Rep) import Imports hiding (All) @@ -43,3 +45,7 @@ instance (Generic a, GToJSON Zero (Rep a)) => ToJSON (CustomEncoded a) where instance (Generic a, GFromJSON Zero (Rep a)) => FromJSON (CustomEncoded a) where parseJSON = fmap CustomEncoded . genericParseJSON @a customEncodingOptions + +eitherToParser :: Either String a -> Parser a +eitherToParser (Left e) = fail e +eitherToParser (Right a) = pure a From fff043f8d7deafbce72e0eff704f401b8d09e895 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Thu, 10 Feb 2022 16:45:20 +0100 Subject: [PATCH 02/18] Add some comments about complicated things I did --- libs/wire-api/src/Wire/API/User.hs | 29 ++++++++++++++++------------- 1 file changed, 16 insertions(+), 13 deletions(-) diff --git a/libs/wire-api/src/Wire/API/User.hs b/libs/wire-api/src/Wire/API/User.hs index 0b2f994b35..1419123156 100644 --- a/libs/wire-api/src/Wire/API/User.hs +++ b/libs/wire-api/src/Wire/API/User.hs @@ -637,34 +637,37 @@ emptyNewUser name = -- | 1 second - 1 week type ExpiresIn = Range 1 604800 Integer -newtype BoolPair = BoolPair {boolUnpair :: (Bool, Bool)} +-- | 'bind'/'dispatch' needs an Enum. +newtype EnumBoolPair = EnumBoolPair {boolUnpair :: (Bool, Bool)} deriving (Bounded) -instance Enum BoolPair where +-- TODO: Test for lawfulness +instance Enum EnumBoolPair where toEnum n - | n < 2 = BoolPair (toEnum n, False) - | otherwise = BoolPair (toEnum (n - 2), True) - fromEnum (BoolPair (b1, b2)) = fromEnum b1 + fromEnum b2 + | n < 2 = EnumBoolPair (toEnum n, False) + | otherwise = EnumBoolPair (toEnum (n - 2), True) + fromEnum (EnumBoolPair (b1, b2)) = fromEnum b1 + fromEnum b2 -boolPairSchema :: (Monoid doc, Monoid w) => SchemaP doc v w Bool Bool -> SchemaP doc v w Bool Bool -> SchemaP doc v w BoolPair BoolPair -boolPairSchema sch1 sch2 = - dimap boolUnpair BoolPair $ +enumBoolPairSchema :: (Monoid doc, Monoid w) => SchemaP doc v w Bool Bool -> SchemaP doc v w Bool Bool -> SchemaP doc v w EnumBoolPair EnumBoolPair +enumBoolPairSchema sch1 sch2 = + dimap boolUnpair EnumBoolPair $ (,) <$> fst .= sch1 <*> snd .= sch2 -mkBoolPair :: Bool -> Bool -> BoolPair -mkBoolPair b1 b2 = BoolPair (b1, b2) +mkEnumBoolPair :: Bool -> Bool -> EnumBoolPair +mkEnumBoolPair b1 b2 = EnumBoolPair (b1, b2) +-- TODO: Maybe bind/dispatch is not needed? instance ToSchema NewUser where schema = object "NewUser" - . dimap (\nu -> (mkBoolPair (isJust (newUserPassword nu)) (isJust (newUserSSOId nu)), nu)) snd + . dimap (\nu -> (mkEnumBoolPair (isJust (newUserPassword nu)) (isJust (newUserSSOId nu)), nu)) snd $ bind - (fst .= boolPairSchema (isJust <$> optField "password" schema) (isJust <$> optField "sso_id" schema)) + (fst .= enumBoolPairSchema (isJust <$> optField "password" schema) (isJust <$> optField "sso_id" schema)) (snd .= dispatch newUserObjectSchema) where - newUserObjectSchema (BoolPair (hasPassword, hasSSO)) = + newUserObjectSchema (EnumBoolPair (hasPassword, hasSSO)) = NewUser <$> newUserDisplayName .= field "name" schema <*> newUserUUID .= maybe_ (optField "uuid" genericToSchema) From a1f90dd41f84177d181636b798076fc2e1556fb2 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Mon, 14 Feb 2022 10:01:52 +0100 Subject: [PATCH 03/18] WIP --- libs/wire-api/src/Wire/API/Routes/Public/Brig.hs | 5 +++++ services/brig/src/Brig/API/Public.hs | 6 +++++- 2 files changed, 10 insertions(+), 1 deletion(-) diff --git a/libs/wire-api/src/Wire/API/Routes/Public/Brig.hs b/libs/wire-api/src/Wire/API/Routes/Public/Brig.hs index b7bd5d78c6..1d814310c4 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Brig.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Brig.hs @@ -313,6 +313,11 @@ type SelfAPI = ) type AccountAPI = + -- docs/reference/user/registration.md {#RefRegistration} + -- + -- This endpoint can lead to the following events being sent: + -- - UserActivated event to created user, if it is a team invitation or user has an SSO ID + -- - UserIdentityUpdated event to created user, if email code or phone code is provided Named "register" ( Summary "Register a new user." diff --git a/services/brig/src/Brig/API/Public.hs b/services/brig/src/Brig/API/Public.hs index 30d3d4b1df..22829c9358 100644 --- a/services/brig/src/Brig/API/Public.hs +++ b/services/brig/src/Brig/API/Public.hs @@ -162,7 +162,7 @@ swaggerDocsAPI = . (S.enum_ . _Just %~ nub) servantSitemap :: ServerT BrigAPI (Handler r) -servantSitemap = userAPI :<|> selfAPI :<|> clientAPI :<|> prekeyAPI :<|> userClientAPI :<|> connectionAPI :<|> mlsAPI +servantSitemap = userAPI :<|> selfAPI :<|> accountAPI :<|> clientAPI :<|> prekeyAPI :<|> userClientAPI :<|> connectionAPI :<|> mlsAPI where userAPI :: ServerT UserAPI (Handler r) userAPI = @@ -188,7 +188,11 @@ servantSitemap = userAPI :<|> selfAPI :<|> clientAPI :<|> prekeyAPI :<|> userCli :<|> Named @"change-locale" changeLocale :<|> Named @"change-handle" changeHandle + accountAPI :: ServerT AccountAPI (Handler r) + accountAPI = undefined + clientAPI :: ServerT ClientAPI (Handler r) + clientAPI :: ServerT ClientAPI Handler clientAPI = Named @"get-user-clients-unqualified" getUserClientsUnqualified :<|> Named @"get-user-clients-qualified" getUserClientsQualified From 36fb13d1c4a9cfb004b73d72a29b0cfc1ac4c75b Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Mon, 14 Feb 2022 16:55:39 +0100 Subject: [PATCH 04/18] Avoid using bind/dispatch for schema of NewUser --- libs/wire-api/src/Wire/API/User.hs | 198 ++++++++++++-------- libs/wire-api/src/Wire/API/User/Identity.hs | 2 +- 2 files changed, 123 insertions(+), 77 deletions(-) diff --git a/libs/wire-api/src/Wire/API/User.hs b/libs/wire-api/src/Wire/API/User.hs index 1419123156..5bfe698ef8 100644 --- a/libs/wire-api/src/Wire/API/User.hs +++ b/libs/wire-api/src/Wire/API/User.hs @@ -85,9 +85,6 @@ module Wire.API.User -- * List Users ListUsersQuery (..), - -- * helpers - parseIdentity, - -- * re-exports module Wire.API.User.Identity, module Wire.API.User.Profile, @@ -109,7 +106,7 @@ where import Control.Applicative import Control.Error.Safe (rightMay) -import Control.Lens (dimap, over, view, (.~), (?~), _1, _2, _3, _4) +import Control.Lens (over, view, (.~), (?~)) import Data.Aeson (FromJSON (..), ToJSON (..)) import qualified Data.Aeson.KeyMap as KeyMap import qualified Data.Aeson.Types as A @@ -637,52 +634,104 @@ emptyNewUser name = -- | 1 second - 1 week type ExpiresIn = Range 1 604800 Integer --- | 'bind'/'dispatch' needs an Enum. -newtype EnumBoolPair = EnumBoolPair {boolUnpair :: (Bool, Bool)} - deriving (Bounded) - --- TODO: Test for lawfulness -instance Enum EnumBoolPair where - toEnum n - | n < 2 = EnumBoolPair (toEnum n, False) - | otherwise = EnumBoolPair (toEnum (n - 2), True) - fromEnum (EnumBoolPair (b1, b2)) = fromEnum b1 + fromEnum b2 - -enumBoolPairSchema :: (Monoid doc, Monoid w) => SchemaP doc v w Bool Bool -> SchemaP doc v w Bool Bool -> SchemaP doc v w EnumBoolPair EnumBoolPair -enumBoolPairSchema sch1 sch2 = - dimap boolUnpair EnumBoolPair $ - (,) - <$> fst .= sch1 - <*> snd .= sch2 +-- | Raw representation of 'NewUser' to help with writing Schema instances. +data NewUserRaw = NewUserRaw + { newUserRawDisplayName :: Name, + newUserRawUUID :: Maybe UUID, + newUserRawEmail :: Maybe Email, + newUserRawPhone :: Maybe Phone, + newUserRawSSOId :: Maybe UserSSOId, + -- | DEPRECATED + newUserRawPict :: Maybe Pict, + newUserRawAssets :: [Asset], + newUserRawAccentId :: Maybe ColourId, + newUserRawEmailCode :: Maybe ActivationCode, + newUserRawPhoneCode :: Maybe ActivationCode, + newUserRawInvitationCode :: Maybe InvitationCode, + newUserRawTeamCode :: Maybe InvitationCode, + newUserRawTeam :: Maybe BindingNewTeamUser, + newUserRawTeamId :: Maybe TeamId, + newUserRawLabel :: Maybe CookieLabel, + newUserRawLocale :: Maybe Locale, + newUserRawPassword :: Maybe PlainTextPassword, + newUserRawExpiresIn :: Maybe ExpiresIn + } -mkEnumBoolPair :: Bool -> Bool -> EnumBoolPair -mkEnumBoolPair b1 b2 = EnumBoolPair (b1, b2) +newUserRawObjectSchema :: ObjectSchema SwaggerDoc NewUserRaw +newUserRawObjectSchema = + NewUserRaw + <$> newUserRawDisplayName .= field "name" schema + <*> newUserRawUUID .= maybe_ (optField "uuid" genericToSchema) + <*> newUserRawEmail .= maybe_ (optField "email" schema) + <*> newUserRawPhone .= maybe_ (optField "phone" schema) + <*> newUserRawSSOId .= maybe_ (optField "sso_id" genericToSchema) + <*> newUserRawPict .= maybe_ (optField "picture" schema) + <*> newUserRawAssets .= (fromMaybe [] <$> optField "assets" (array schema)) + <*> newUserRawAccentId .= maybe_ (optField "accent_id" schema) + <*> newUserRawEmailCode .= maybe_ (optField "email_code" schema) + <*> newUserRawPhoneCode .= maybe_ (optField "phone_code" schema) + <*> newUserRawInvitationCode .= maybe_ (optField "invitation_code" schema) + <*> newUserRawTeamCode .= maybe_ (optField "team_code" schema) + <*> newUserRawTeam .= maybe_ (optField "team" schema) + <*> newUserRawTeamId .= maybe_ (optField "team_id" schema) + <*> newUserRawLabel .= maybe_ (optField "label" schema) + <*> newUserRawLocale .= maybe_ (optField "locale" schema) + <*> newUserRawPassword .= maybe_ (optField "password" schema) + <*> newUserRawExpiresIn .= maybe_ (optField "expires_in" schema) --- TODO: Maybe bind/dispatch is not needed? instance ToSchema NewUser where schema = - object "NewUser" - . dimap (\nu -> (mkEnumBoolPair (isJust (newUserPassword nu)) (isJust (newUserSSOId nu)), nu)) snd - $ bind - (fst .= enumBoolPairSchema (isJust <$> optField "password" schema) (isJust <$> optField "sso_id" schema)) - (snd .= dispatch newUserObjectSchema) - where - newUserObjectSchema (EnumBoolPair (hasPassword, hasSSO)) = - NewUser - <$> newUserDisplayName .= field "name" schema - <*> newUserUUID .= maybe_ (optField "uuid" genericToSchema) - <*> newUserIdentity .= maybeUserIdentityObjectSchema - <*> newUserPict .= maybe_ (optField "picture" schema) - <*> newUserAssets .= (fromMaybe [] <$> optField "assets" (array schema)) - <*> newUserAccentId .= maybe_ (optField "accent_id" schema) - <*> newUserEmailCode .= maybe_ (optField "email_code" schema) - <*> newUserPhoneCode .= maybe_ (optField "phone_code" schema) - <*> newUserOrigin .= maybeNewUserOriginObjectSchema hasPassword hasSSO - <*> newUserLabel .= maybe_ (optField "label" schema) - <*> newUserLocale .= maybe_ (optField "locale" schema) - <*> newUserPassword .= maybe_ (optField "password" schema) - <*> newUserExpiresIn .= maybe_ (optField "expires_in" schema) - <*> newUserManagedBy .= pure Nothing + object "NewUser" $ newUserToRaw .= withParser newUserRawObjectSchema newUserFromRaw + +newUserToRaw :: NewUser -> NewUserRaw +newUserToRaw NewUser {..} = + let maybeOriginNTU = newUserOriginNewTeamUser =<< newUserOrigin + in NewUserRaw + { newUserRawDisplayName = newUserDisplayName, + newUserRawUUID = newUserUUID, + newUserRawEmail = emailIdentity =<< newUserIdentity, + newUserRawPhone = phoneIdentity =<< newUserIdentity, + newUserRawSSOId = ssoIdentity =<< newUserIdentity, + newUserRawPict = newUserPict, + newUserRawAssets = newUserAssets, + newUserRawAccentId = newUserAccentId, + newUserRawEmailCode = newUserEmailCode, + newUserRawPhoneCode = newUserPhoneCode, + newUserRawInvitationCode = newUserOriginInvitationCode =<< newUserOrigin, + newUserRawTeamCode = newTeamUserCode =<< maybeOriginNTU, + newUserRawTeam = newTeamUserCreator =<< maybeOriginNTU, + newUserRawTeamId = newTeamUserTeamId =<< maybeOriginNTU, + newUserRawLabel = newUserLabel, + newUserRawLocale = newUserLocale, + newUserRawPassword = newUserPassword, + newUserRawExpiresIn = newUserExpiresIn + } + +newUserFromRaw :: NewUserRaw -> A.Parser NewUser +newUserFromRaw NewUserRaw {..} = do + origin <- + eitherToParser $ + maybeNewUserOriginFromComponents + (isJust newUserRawPassword) + (isJust newUserRawSSOId) + (newUserRawInvitationCode, newUserRawTeamCode, newUserRawTeam, newUserRawTeamId) + pure $ + NewUser + { newUserDisplayName = newUserRawDisplayName, + newUserUUID = newUserRawUUID, + newUserIdentity = maybeUserIdentityFromComponents (newUserRawEmail, newUserRawPhone, newUserRawSSOId), + newUserPict = newUserRawPict, + newUserAssets = newUserRawAssets, + newUserAccentId = newUserRawAccentId, + newUserEmailCode = newUserRawEmailCode, + newUserPhoneCode = newUserRawPhoneCode, + newUserOrigin = origin, + newUserLabel = newUserRawLabel, + newUserLocale = newUserRawLocale, + newUserPassword = newUserRawPassword, + newUserExpiresIn = newUserRawExpiresIn, + newUserManagedBy = Nothing + } -- FUTUREWORK: align more with FromJSON instance? instance Arbitrary NewUser where @@ -755,36 +804,15 @@ data NewUserOrigin type NewUserOriginComponents = (Maybe InvitationCode, Maybe InvitationCode, Maybe BindingNewTeamUser, Maybe TeamId) -maybeNewUserOriginObjectSchema :: - -- | Has password - Bool -> - -- | Has SSOId - Bool -> - ObjectSchema SwaggerDoc (Maybe NewUserOrigin) -maybeNewUserOriginObjectSchema hasPassword hasSSO = - flip withParser eitherToParser $ - dimap - maybeNewUserOriginToComponents - (maybeNewUserOriginFromComponents hasPassword hasSSO) - newUserOriginComponentsObjectSchema - -newUserOriginComponentsObjectSchema :: ObjectSchema SwaggerDoc NewUserOriginComponents -newUserOriginComponentsObjectSchema = - (,,,) - <$> view _1 .= maybe_ (optField "invitation_code" schema) - <*> view _2 .= maybe_ (optField "team_code" schema) - <*> view _3 .= maybe_ (optField "team" schema) - <*> view _4 .= maybe_ (optField "team_id" schema) - -maybeNewUserOriginToComponents :: Maybe NewUserOrigin -> NewUserOriginComponents -maybeNewUserOriginToComponents = - \case - Nothing -> (Nothing, Nothing, Nothing, Nothing) - Just (NewUserOriginInvitationCode ic) -> (Just ic, Nothing, Nothing, Nothing) - Just (NewUserOriginTeamUser ntu) -> case ntu of - NewTeamMember tc -> (Nothing, Just tc, Nothing, Nothing) - NewTeamCreator bntu -> (Nothing, Nothing, Just bntu, Nothing) - NewTeamMemberSSO tid -> (Nothing, Nothing, Nothing, Just tid) +newUserOriginInvitationCode :: NewUserOrigin -> Maybe InvitationCode +newUserOriginInvitationCode = \case + NewUserOriginInvitationCode ic -> Just ic + NewUserOriginTeamUser _ -> Nothing + +newUserOriginNewTeamUser :: NewUserOrigin -> Maybe NewTeamUser +newUserOriginNewTeamUser = \case + NewUserOriginInvitationCode _ -> Nothing + NewUserOriginTeamUser ntu -> Just ntu maybeNewUserOriginFromComponents :: -- | Does the user have a password @@ -840,6 +868,24 @@ data NewTeamUser deriving stock (Eq, Show, Generic) deriving (Arbitrary) via (GenericUniform NewTeamUser) +newTeamUserCode :: NewTeamUser -> Maybe InvitationCode +newTeamUserCode = \case + NewTeamMember ic -> Just ic + NewTeamCreator _ -> Nothing + NewTeamMemberSSO _ -> Nothing + +newTeamUserCreator :: NewTeamUser -> Maybe BindingNewTeamUser +newTeamUserCreator = \case + NewTeamMember _ -> Nothing + NewTeamCreator bntu -> Just bntu + NewTeamMemberSSO _ -> Nothing + +newTeamUserTeamId :: NewTeamUser -> Maybe TeamId +newTeamUserTeamId = \case + NewTeamMember _ -> Nothing + NewTeamCreator _ -> Nothing + NewTeamMemberSSO tid -> Just tid + data BindingNewTeamUser = BindingNewTeamUser { bnuTeam :: BindingNewTeam, bnuCurrency :: Maybe Currency.Alpha diff --git a/libs/wire-api/src/Wire/API/User/Identity.hs b/libs/wire-api/src/Wire/API/User/Identity.hs index 6721340613..0ad495919c 100644 --- a/libs/wire-api/src/Wire/API/User/Identity.hs +++ b/libs/wire-api/src/Wire/API/User/Identity.hs @@ -26,6 +26,7 @@ module Wire.API.User.Identity emailIdentity, phoneIdentity, ssoIdentity, + maybeUserIdentityFromComponents, -- * Email Email (..), @@ -46,7 +47,6 @@ module Wire.API.User.Identity emailFromSAMLNameID, mkSampleUref, mkSimpleSampleUref, - maybeUserIdentityObjectSchema, ) where From 256f50d23b1ebd952041fb20a2fc59eb5637d9c9 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Tue, 15 Feb 2022 11:29:07 +0100 Subject: [PATCH 05/18] Remove ToJSON/FromJSON for UserIdentity, use Schema for User The ToJSON for UserIdentity encoded nulls, but every other object which used it didn't encode nulls. So, it was better to remove it --- libs/wire-api/package.yaml | 1 + libs/wire-api/src/Wire/API/User.hs | 127 +++++----------- libs/wire-api/src/Wire/API/User/Activation.hs | 4 +- libs/wire-api/src/Wire/API/User/Identity.hs | 10 +- libs/wire-api/src/Wire/API/User/Profile.hs | 21 +-- .../golden/Test/Wire/API/Golden/Generated.hs | 3 - .../API/Golden/Generated/UserIdentity_user.hs | 137 ------------------ .../testObject_UserIdentity_user_1.json | 5 - .../testObject_UserIdentity_user_10.json | 5 - .../testObject_UserIdentity_user_11.json | 5 - .../testObject_UserIdentity_user_12.json | 5 - .../testObject_UserIdentity_user_13.json | 5 - .../testObject_UserIdentity_user_14.json | 5 - .../testObject_UserIdentity_user_15.json | 5 - .../testObject_UserIdentity_user_17.json | 7 - .../testObject_UserIdentity_user_18.json | 5 - .../testObject_UserIdentity_user_19.json | 5 - .../testObject_UserIdentity_user_2.json | 5 - .../testObject_UserIdentity_user_20.json | 5 - .../testObject_UserIdentity_user_3.json | 5 - .../testObject_UserIdentity_user_4.json | 5 - .../testObject_UserIdentity_user_6.json | 5 - .../testObject_UserIdentity_user_7.json | 5 - .../testObject_UserIdentity_user_9.json | 5 - .../unit/Test/Wire/API/Roundtrip/Aeson.hs | 1 - libs/wire-api/test/unit/Test/Wire/API/User.hs | 25 ++-- libs/wire-api/wire-api.cabal | 2 +- 27 files changed, 66 insertions(+), 352 deletions(-) delete mode 100644 libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/UserIdentity_user.hs delete mode 100644 libs/wire-api/test/golden/testObject_UserIdentity_user_1.json delete mode 100644 libs/wire-api/test/golden/testObject_UserIdentity_user_10.json delete mode 100644 libs/wire-api/test/golden/testObject_UserIdentity_user_11.json delete mode 100644 libs/wire-api/test/golden/testObject_UserIdentity_user_12.json delete mode 100644 libs/wire-api/test/golden/testObject_UserIdentity_user_13.json delete mode 100644 libs/wire-api/test/golden/testObject_UserIdentity_user_14.json delete mode 100644 libs/wire-api/test/golden/testObject_UserIdentity_user_15.json delete mode 100644 libs/wire-api/test/golden/testObject_UserIdentity_user_17.json delete mode 100644 libs/wire-api/test/golden/testObject_UserIdentity_user_18.json delete mode 100644 libs/wire-api/test/golden/testObject_UserIdentity_user_19.json delete mode 100644 libs/wire-api/test/golden/testObject_UserIdentity_user_2.json delete mode 100644 libs/wire-api/test/golden/testObject_UserIdentity_user_20.json delete mode 100644 libs/wire-api/test/golden/testObject_UserIdentity_user_3.json delete mode 100644 libs/wire-api/test/golden/testObject_UserIdentity_user_4.json delete mode 100644 libs/wire-api/test/golden/testObject_UserIdentity_user_6.json delete mode 100644 libs/wire-api/test/golden/testObject_UserIdentity_user_7.json delete mode 100644 libs/wire-api/test/golden/testObject_UserIdentity_user_9.json diff --git a/libs/wire-api/package.yaml b/libs/wire-api/package.yaml index 02215683ab..2620d9b381 100644 --- a/libs/wire-api/package.yaml +++ b/libs/wire-api/package.yaml @@ -123,6 +123,7 @@ tests: - pretty - proto-lens - QuickCheck + - schema-profunctor - string-conversions - swagger2 - tasty diff --git a/libs/wire-api/src/Wire/API/User.hs b/libs/wire-api/src/Wire/API/User.hs index 5bfe698ef8..5a47163e2b 100644 --- a/libs/wire-api/src/Wire/API/User.hs +++ b/libs/wire-api/src/Wire/API/User.hs @@ -106,7 +106,7 @@ where import Control.Applicative import Control.Error.Safe (rightMay) -import Control.Lens (over, view, (.~), (?~)) +import Control.Lens (over, (.~), (?~)) import Data.Aeson (FromJSON (..), ToJSON (..)) import qualified Data.Aeson.KeyMap as KeyMap import qualified Data.Aeson.Types as A @@ -120,7 +120,6 @@ import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap import Data.Id import Data.Json.Util (UTCTimeMillis, (#)) import Data.LegalHold (UserLegalHoldStatus) -import qualified Data.List as List import Data.Misc (PlainTextPassword (..)) import Data.Qualified import Data.Range @@ -338,77 +337,28 @@ data User = User } deriving stock (Eq, Show, Generic) deriving (Arbitrary) via (GenericUniform User) + deriving (ToJSON, FromJSON, S.ToSchema) via (Schema User) --- Cannot use deriving (ToSchema) via (CustomSwagger ...) because we need to --- mark 'deleted' as optional, but it is not a 'Maybe' --- and we need to manually add the identity schema fields at the top level --- instead of nesting them under the 'identity' field. -instance S.ToSchema User where - declareNamedSchema _ = do - identityProperties <- view (S.schema . S.properties) <$> S.declareNamedSchema (Proxy @UserIdentity) - genericSchema <- - S.genericDeclareNamedSchema - ( swaggerOptions - @'[ FieldLabelModifier - ( StripPrefix "user", - CamelToSnake, - LabelMappings - '[ "pict" ':-> "picture", - "expire" ':-> "expires_at", - "display_name" ':-> "name" - ] - ) - ] - ) - (Proxy @User) - pure $ - genericSchema - & over (S.schema . S.required) (List.delete "deleted") - -- The UserIdentity fields need to be flat-included, not be in a sub-object - & over (S.schema . S.properties) (InsOrdHashMap.delete "identity") - & over (S.schema . S.properties) (InsOrdHashMap.union identityProperties) - --- FUTUREWORK: --- disentangle json serializations for 'User', 'NewUser', 'UserIdentity', 'NewUserOrigin'. -instance ToJSON User where - toJSON u = - A.object $ - "id" A..= userId u - # "qualified_id" A..= userQualifiedId u - # "name" A..= userDisplayName u - # "picture" A..= userPict u - # "assets" A..= userAssets u - # "email" A..= userEmail u - # "phone" A..= userPhone u - # "accent_id" A..= userAccentId u - # "deleted" A..= (if userDeleted u then Just True else Nothing) - # "locale" A..= userLocale u - # "service" A..= userService u - # "handle" A..= userHandle u - # "expires_at" A..= userExpire u - # "team" A..= userTeam u - # "sso_id" A..= userSSOId u - # "managed_by" A..= userManagedBy u - # [] - -instance FromJSON User where - parseJSON = A.withObject "user" $ \o -> do - ssoid <- o A..:? "sso_id" - User - <$> o A..: "id" - <*> o A..: "qualified_id" - <*> parseIdentity ssoid o - <*> o A..: "name" - <*> o A..:? "picture" A..!= noPict - <*> o A..:? "assets" A..!= [] - <*> o A..: "accent_id" - <*> o A..:? "deleted" A..!= False - <*> o A..: "locale" - <*> o A..:? "service" - <*> o A..:? "handle" - <*> o A..:? "expires_at" - <*> o A..:? "team" - <*> o A..:? "managed_by" A..!= ManagedByWire +-- -- FUTUREWORK: +-- -- disentangle json serializations for 'User', 'NewUser', 'UserIdentity', 'NewUserOrigin'. +instance ToSchema User where + schema = + object "User" $ + User + <$> userId .= field "id" schema + <*> userQualifiedId .= field "qualified_id" schema + <*> userIdentity .= maybeUserIdentityObjectSchema + <*> userDisplayName .= field "name" schema + <*> userPict .= (fromMaybe noPict <$> optField "picture" schema) + <*> userAssets .= (fromMaybe [] <$> optField "assets" (array schema)) + <*> userAccentId .= field "accent_id" schema + <*> (fromMaybe False <$> (\u -> if userDeleted u then Just True else Nothing) .= maybe_ (optField "deleted" schema)) + <*> userLocale .= field "locale" schema + <*> userService .= maybe_ (optField "service" schema) + <*> userHandle .= maybe_ (optField "handle" schema) + <*> userExpire .= maybe_ (optField "expires_at" schema) + <*> userTeam .= maybe_ (optField "team" schema) + <*> userManagedBy .= (fromMaybe ManagedByWire <$> optField "managed_by" schema) userEmail :: User -> Maybe Email userEmail = emailIdentity <=< userIdentity @@ -654,7 +604,8 @@ data NewUserRaw = NewUserRaw newUserRawLabel :: Maybe CookieLabel, newUserRawLocale :: Maybe Locale, newUserRawPassword :: Maybe PlainTextPassword, - newUserRawExpiresIn :: Maybe ExpiresIn + newUserRawExpiresIn :: Maybe ExpiresIn, + newUserRawManagedBy :: Maybe ManagedBy } newUserRawObjectSchema :: ObjectSchema SwaggerDoc NewUserRaw @@ -678,6 +629,7 @@ newUserRawObjectSchema = <*> newUserRawLocale .= maybe_ (optField "locale" schema) <*> newUserRawPassword .= maybe_ (optField "password" schema) <*> newUserRawExpiresIn .= maybe_ (optField "expires_in" schema) + <*> newUserRawManagedBy .= maybe_ (optField "managed_by" schema) instance ToSchema NewUser where schema = @@ -704,7 +656,8 @@ newUserToRaw NewUser {..} = newUserRawLabel = newUserLabel, newUserRawLocale = newUserLocale, newUserRawPassword = newUserPassword, - newUserRawExpiresIn = newUserExpiresIn + newUserRawExpiresIn = newUserExpiresIn, + newUserRawManagedBy = newUserManagedBy } newUserFromRaw :: NewUserRaw -> A.Parser NewUser @@ -715,11 +668,16 @@ newUserFromRaw NewUserRaw {..} = do (isJust newUserRawPassword) (isJust newUserRawSSOId) (newUserRawInvitationCode, newUserRawTeamCode, newUserRawTeam, newUserRawTeamId) + let identity = maybeUserIdentityFromComponents (newUserRawEmail, newUserRawPhone, newUserRawSSOId) + expiresIn <- + case (newUserRawExpiresIn, identity) of + (Just _, Just _) -> fail "Only users without an identity can expire" + _ -> pure newUserRawExpiresIn pure $ NewUser { newUserDisplayName = newUserRawDisplayName, newUserUUID = newUserRawUUID, - newUserIdentity = maybeUserIdentityFromComponents (newUserRawEmail, newUserRawPhone, newUserRawSSOId), + newUserIdentity = identity, newUserPict = newUserRawPict, newUserAssets = newUserRawAssets, newUserAccentId = newUserRawAccentId, @@ -729,8 +687,8 @@ newUserFromRaw NewUserRaw {..} = do newUserLabel = newUserRawLabel, newUserLocale = newUserRawLocale, newUserPassword = newUserRawPassword, - newUserExpiresIn = newUserRawExpiresIn, - newUserManagedBy = Nothing + newUserExpiresIn = expiresIn, + newUserManagedBy = newUserRawManagedBy } -- FUTUREWORK: align more with FromJSON instance? @@ -843,19 +801,6 @@ newtype InvitationCode = InvitationCode deriving newtype (ToSchema, ToByteString, FromByteString, Arbitrary) deriving (FromJSON, ToJSON, S.ToSchema) via Schema InvitationCode --------------------------------------------------------------------------------- --- helpers - --- | Fails if email or phone or ssoid are present but invalid. --- If neither are present, it will not fail, but return Nothing. --- --- FUTUREWORK: Why is the SSO ID passed separately? -parseIdentity :: Maybe UserSSOId -> A.Object -> A.Parser (Maybe UserIdentity) -parseIdentity ssoid o = - if isJust (KeyMap.lookup "email" o <|> KeyMap.lookup "phone" o) || isJust ssoid - then Just <$> parseJSON (A.Object o) - else pure Nothing - -------------------------------------------------------------------------------- -- NewTeamUser @@ -901,7 +846,7 @@ instance ToSchema BindingNewTeamUser where object "BindingNewTeamUser" $ BindingNewTeamUser <$> bnuTeam .= bindingNewTeamObjectSchema - <*> bnuCurrency .= maybe_ (optField "currenncy" genericToSchema) + <*> bnuCurrency .= maybe_ (optField "currency" genericToSchema) -------------------------------------------------------------------------------- -- Profile Updates diff --git a/libs/wire-api/src/Wire/API/User/Activation.hs b/libs/wire-api/src/Wire/API/User/Activation.hs index 50f6b025da..d97b12eb70 100644 --- a/libs/wire-api/src/Wire/API/User/Activation.hs +++ b/libs/wire-api/src/Wire/API/User/Activation.hs @@ -43,7 +43,7 @@ where import Data.Aeson import Data.ByteString.Conversion import Data.Json.Util ((#)) -import Data.Schema (Schema (..), ToSchema) +import Data.Schema (Schema (..), ToSchema, schemaIn) import qualified Data.Swagger as S import qualified Data.Swagger.Build.Api as Doc import Data.Text.Ascii @@ -184,7 +184,7 @@ instance ToJSON ActivationResponse where instance FromJSON ActivationResponse where parseJSON = withObject "ActivationResponse" $ \o -> ActivationResponse - <$> parseJSON (Object o) + <$> schemaIn userIdentityObjectSchema o <*> o .:? "first" .!= False -------------------------------------------------------------------------------- diff --git a/libs/wire-api/src/Wire/API/User/Identity.hs b/libs/wire-api/src/Wire/API/User/Identity.hs index 0ad495919c..4b1e2fcc27 100644 --- a/libs/wire-api/src/Wire/API/User/Identity.hs +++ b/libs/wire-api/src/Wire/API/User/Identity.hs @@ -26,6 +26,8 @@ module Wire.API.User.Identity emailIdentity, phoneIdentity, ssoIdentity, + userIdentityObjectSchema, + maybeUserIdentityObjectSchema, maybeUserIdentityFromComponents, -- * Email @@ -92,12 +94,10 @@ data UserIdentity | SSOIdentity UserSSOId (Maybe Email) (Maybe Phone) deriving stock (Eq, Show, Generic) deriving (Arbitrary) via (GenericUniform UserIdentity) - deriving (ToJSON, FromJSON, S.ToSchema) via (Schema UserIdentity) -instance ToSchema UserIdentity where - schema = - object "UserIdentity" $ - Just .= withParser maybeUserIdentityObjectSchema (maybe (fail "Missing 'email' or 'phone' or 'sso_id'.") pure) +userIdentityObjectSchema :: ObjectSchema SwaggerDoc UserIdentity +userIdentityObjectSchema = + Just .= withParser maybeUserIdentityObjectSchema (maybe (fail "Missing 'email' or 'phone' or 'sso_id'.") pure) maybeUserIdentityObjectSchema :: ObjectSchema SwaggerDoc (Maybe UserIdentity) maybeUserIdentityObjectSchema = diff --git a/libs/wire-api/src/Wire/API/User/Profile.hs b/libs/wire-api/src/Wire/API/User/Profile.hs index b5950500fe..5327fce297 100644 --- a/libs/wire-api/src/Wire/API/User/Profile.hs +++ b/libs/wire-api/src/Wire/API/User/Profile.hs @@ -67,7 +67,6 @@ import Data.Schema import qualified Data.Swagger as S import qualified Data.Swagger.Build.Api as Doc import qualified Data.Text as Text -import Deriving.Swagger (CamelToSnake, ConstructorTagModifier, CustomSwagger, StripPrefix) import Imports import Wire.API.Arbitrary (Arbitrary (arbitrary), GenericUniform (..)) import Wire.API.User.Orphans () @@ -252,7 +251,7 @@ data ManagedBy ManagedByScim deriving stock (Eq, Bounded, Enum, Show, Generic) deriving (Arbitrary) via (GenericUniform ManagedBy) - deriving (S.ToSchema) via (CustomSwagger '[ConstructorTagModifier (StripPrefix "ManagedBy", CamelToSnake)] ManagedBy) + deriving (ToJSON, FromJSON, S.ToSchema) via (Schema ManagedBy) typeManagedBy :: Doc.DataType typeManagedBy = @@ -262,17 +261,13 @@ typeManagedBy = "scim" ] -instance ToJSON ManagedBy where - toJSON = - A.String . \case - ManagedByWire -> "wire" - ManagedByScim -> "scim" - -instance FromJSON ManagedBy where - parseJSON = A.withText "ManagedBy" $ \case - "wire" -> pure ManagedByWire - "scim" -> pure ManagedByScim - other -> fail $ "Invalid ManagedBy: " ++ show other +instance ToSchema ManagedBy where + schema = + enum @Text "ManagedBy" $ + mconcat + [ element "wire" ManagedByWire, + element "scim" ManagedByScim + ] instance ToByteString ManagedBy where builder ManagedByWire = "wire" diff --git a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated.hs index f0f20bc7e3..798a88c877 100644 --- a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated.hs +++ b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated.hs @@ -225,7 +225,6 @@ import qualified Test.Wire.API.Golden.Generated.UserClients_user import qualified Test.Wire.API.Golden.Generated.UserConnectionList_user import qualified Test.Wire.API.Golden.Generated.UserConnection_user import qualified Test.Wire.API.Golden.Generated.UserHandleInfo_user -import qualified Test.Wire.API.Golden.Generated.UserIdentity_user import qualified Test.Wire.API.Golden.Generated.UserLegalHoldStatusResponse_team import qualified Test.Wire.API.Golden.Generated.UserProfile_user import qualified Test.Wire.API.Golden.Generated.UserSSOId_user @@ -1028,8 +1027,6 @@ tests = testObjects [(Test.Wire.API.Golden.Generated.Phone_user.testObject_Phone_user_1, "testObject_Phone_user_1.json"), (Test.Wire.API.Golden.Generated.Phone_user.testObject_Phone_user_2, "testObject_Phone_user_2.json"), (Test.Wire.API.Golden.Generated.Phone_user.testObject_Phone_user_3, "testObject_Phone_user_3.json"), (Test.Wire.API.Golden.Generated.Phone_user.testObject_Phone_user_4, "testObject_Phone_user_4.json"), (Test.Wire.API.Golden.Generated.Phone_user.testObject_Phone_user_5, "testObject_Phone_user_5.json"), (Test.Wire.API.Golden.Generated.Phone_user.testObject_Phone_user_6, "testObject_Phone_user_6.json"), (Test.Wire.API.Golden.Generated.Phone_user.testObject_Phone_user_7, "testObject_Phone_user_7.json"), (Test.Wire.API.Golden.Generated.Phone_user.testObject_Phone_user_8, "testObject_Phone_user_8.json"), (Test.Wire.API.Golden.Generated.Phone_user.testObject_Phone_user_9, "testObject_Phone_user_9.json"), (Test.Wire.API.Golden.Generated.Phone_user.testObject_Phone_user_10, "testObject_Phone_user_10.json"), (Test.Wire.API.Golden.Generated.Phone_user.testObject_Phone_user_11, "testObject_Phone_user_11.json"), (Test.Wire.API.Golden.Generated.Phone_user.testObject_Phone_user_12, "testObject_Phone_user_12.json"), (Test.Wire.API.Golden.Generated.Phone_user.testObject_Phone_user_13, "testObject_Phone_user_13.json"), (Test.Wire.API.Golden.Generated.Phone_user.testObject_Phone_user_14, "testObject_Phone_user_14.json"), (Test.Wire.API.Golden.Generated.Phone_user.testObject_Phone_user_15, "testObject_Phone_user_15.json"), (Test.Wire.API.Golden.Generated.Phone_user.testObject_Phone_user_16, "testObject_Phone_user_16.json"), (Test.Wire.API.Golden.Generated.Phone_user.testObject_Phone_user_17, "testObject_Phone_user_17.json"), (Test.Wire.API.Golden.Generated.Phone_user.testObject_Phone_user_18, "testObject_Phone_user_18.json"), (Test.Wire.API.Golden.Generated.Phone_user.testObject_Phone_user_19, "testObject_Phone_user_19.json"), (Test.Wire.API.Golden.Generated.Phone_user.testObject_Phone_user_20, "testObject_Phone_user_20.json")], testGroup "Golden: UserSSOId_user" $ testObjects [(Test.Wire.API.Golden.Generated.UserSSOId_user.testObject_UserSSOId_user_2, "testObject_UserSSOId_user_2.json"), (Test.Wire.API.Golden.Generated.UserSSOId_user.testObject_UserSSOId_user_9, "testObject_UserSSOId_user_9.json"), (Test.Wire.API.Golden.Generated.UserSSOId_user.testObject_UserSSOId_user_13, "testObject_UserSSOId_user_13.json")], - testGroup "Golden: UserIdentity_user" $ - testObjects [(Test.Wire.API.Golden.Generated.UserIdentity_user.testObject_UserIdentity_user_1, "testObject_UserIdentity_user_1.json"), (Test.Wire.API.Golden.Generated.UserIdentity_user.testObject_UserIdentity_user_2, "testObject_UserIdentity_user_2.json"), (Test.Wire.API.Golden.Generated.UserIdentity_user.testObject_UserIdentity_user_3, "testObject_UserIdentity_user_3.json"), (Test.Wire.API.Golden.Generated.UserIdentity_user.testObject_UserIdentity_user_4, "testObject_UserIdentity_user_4.json"), (Test.Wire.API.Golden.Generated.UserIdentity_user.testObject_UserIdentity_user_6, "testObject_UserIdentity_user_6.json"), (Test.Wire.API.Golden.Generated.UserIdentity_user.testObject_UserIdentity_user_7, "testObject_UserIdentity_user_7.json"), (Test.Wire.API.Golden.Generated.UserIdentity_user.testObject_UserIdentity_user_9, "testObject_UserIdentity_user_9.json"), (Test.Wire.API.Golden.Generated.UserIdentity_user.testObject_UserIdentity_user_10, "testObject_UserIdentity_user_10.json"), (Test.Wire.API.Golden.Generated.UserIdentity_user.testObject_UserIdentity_user_11, "testObject_UserIdentity_user_11.json"), (Test.Wire.API.Golden.Generated.UserIdentity_user.testObject_UserIdentity_user_12, "testObject_UserIdentity_user_12.json"), (Test.Wire.API.Golden.Generated.UserIdentity_user.testObject_UserIdentity_user_13, "testObject_UserIdentity_user_13.json"), (Test.Wire.API.Golden.Generated.UserIdentity_user.testObject_UserIdentity_user_14, "testObject_UserIdentity_user_14.json"), (Test.Wire.API.Golden.Generated.UserIdentity_user.testObject_UserIdentity_user_15, "testObject_UserIdentity_user_15.json"), (Test.Wire.API.Golden.Generated.UserIdentity_user.testObject_UserIdentity_user_17, "testObject_UserIdentity_user_17.json"), (Test.Wire.API.Golden.Generated.UserIdentity_user.testObject_UserIdentity_user_18, "testObject_UserIdentity_user_18.json"), (Test.Wire.API.Golden.Generated.UserIdentity_user.testObject_UserIdentity_user_19, "testObject_UserIdentity_user_19.json"), (Test.Wire.API.Golden.Generated.UserIdentity_user.testObject_UserIdentity_user_20, "testObject_UserIdentity_user_20.json")], testGroup "Golden: NewPasswordReset_user" $ testObjects [(Test.Wire.API.Golden.Generated.NewPasswordReset_user.testObject_NewPasswordReset_user_1, "testObject_NewPasswordReset_user_1.json"), (Test.Wire.API.Golden.Generated.NewPasswordReset_user.testObject_NewPasswordReset_user_2, "testObject_NewPasswordReset_user_2.json"), (Test.Wire.API.Golden.Generated.NewPasswordReset_user.testObject_NewPasswordReset_user_3, "testObject_NewPasswordReset_user_3.json"), (Test.Wire.API.Golden.Generated.NewPasswordReset_user.testObject_NewPasswordReset_user_4, "testObject_NewPasswordReset_user_4.json"), (Test.Wire.API.Golden.Generated.NewPasswordReset_user.testObject_NewPasswordReset_user_5, "testObject_NewPasswordReset_user_5.json"), (Test.Wire.API.Golden.Generated.NewPasswordReset_user.testObject_NewPasswordReset_user_6, "testObject_NewPasswordReset_user_6.json"), (Test.Wire.API.Golden.Generated.NewPasswordReset_user.testObject_NewPasswordReset_user_7, "testObject_NewPasswordReset_user_7.json"), (Test.Wire.API.Golden.Generated.NewPasswordReset_user.testObject_NewPasswordReset_user_8, "testObject_NewPasswordReset_user_8.json"), (Test.Wire.API.Golden.Generated.NewPasswordReset_user.testObject_NewPasswordReset_user_9, "testObject_NewPasswordReset_user_9.json"), (Test.Wire.API.Golden.Generated.NewPasswordReset_user.testObject_NewPasswordReset_user_10, "testObject_NewPasswordReset_user_10.json"), (Test.Wire.API.Golden.Generated.NewPasswordReset_user.testObject_NewPasswordReset_user_11, "testObject_NewPasswordReset_user_11.json"), (Test.Wire.API.Golden.Generated.NewPasswordReset_user.testObject_NewPasswordReset_user_12, "testObject_NewPasswordReset_user_12.json"), (Test.Wire.API.Golden.Generated.NewPasswordReset_user.testObject_NewPasswordReset_user_13, "testObject_NewPasswordReset_user_13.json"), (Test.Wire.API.Golden.Generated.NewPasswordReset_user.testObject_NewPasswordReset_user_14, "testObject_NewPasswordReset_user_14.json"), (Test.Wire.API.Golden.Generated.NewPasswordReset_user.testObject_NewPasswordReset_user_15, "testObject_NewPasswordReset_user_15.json"), (Test.Wire.API.Golden.Generated.NewPasswordReset_user.testObject_NewPasswordReset_user_16, "testObject_NewPasswordReset_user_16.json"), (Test.Wire.API.Golden.Generated.NewPasswordReset_user.testObject_NewPasswordReset_user_17, "testObject_NewPasswordReset_user_17.json"), (Test.Wire.API.Golden.Generated.NewPasswordReset_user.testObject_NewPasswordReset_user_18, "testObject_NewPasswordReset_user_18.json"), (Test.Wire.API.Golden.Generated.NewPasswordReset_user.testObject_NewPasswordReset_user_19, "testObject_NewPasswordReset_user_19.json"), (Test.Wire.API.Golden.Generated.NewPasswordReset_user.testObject_NewPasswordReset_user_20, "testObject_NewPasswordReset_user_20.json")], testGroup "Golden: PasswordResetKey_user" $ diff --git a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/UserIdentity_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/UserIdentity_user.hs deleted file mode 100644 index 27eb136725..0000000000 --- a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/UserIdentity_user.hs +++ /dev/null @@ -1,137 +0,0 @@ -{-# LANGUAGE OverloadedLists #-} - --- 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.Golden.Generated.UserIdentity_user where - -import Imports (Maybe (Just, Nothing)) -import Wire.API.User - ( Email (Email, emailDomain, emailLocal), - Phone (Phone, fromPhone), - UserIdentity (..), - UserSSOId (UserSSOId, UserScimExternalId), - ) -import Wire.API.User.Identity (mkSimpleSampleUref) - -testObject_UserIdentity_user_1 :: UserIdentity -testObject_UserIdentity_user_1 = - EmailIdentity (Email {emailLocal = "S\ENQX\1076723$\STX\"\1110507e\1015716\24831\1031964L\ETB", emailDomain = "P.b"}) - -testObject_UserIdentity_user_2 :: UserIdentity -testObject_UserIdentity_user_2 = - EmailIdentity - ( Email - { emailLocal = "\1061008\1068189\1013266\EOT\vE\ENQW\SYNO\DC3X_F\9141\STX $}\179559\USJ3\128480S?", - emailDomain = "4WL;'\DLEl1]x\119077" - } - ) - -testObject_UserIdentity_user_3 :: UserIdentity -testObject_UserIdentity_user_3 = - EmailIdentity - ( Email - { emailLocal = "\10821:\DC4E\60072i\1074224P\1054022\1037567\&6phe\DC3\ETXH,\CAN\v\145604\v>", - emailDomain = "bwtC\1110390z2RT28\STX\1049837<3Y" - } - ) - -testObject_UserIdentity_user_4 :: UserIdentity -testObject_UserIdentity_user_4 = - FullIdentity - (Email {emailLocal = "\rH)\65718", emailDomain = ")\1107842\US\27126\t\ACK\1111725_{\154804\&7#"}) - (Phone {fromPhone = "+2559583362"}) - -testObject_UserIdentity_user_5 :: UserIdentity -testObject_UserIdentity_user_5 = - SSOIdentity (UserSSOId mkSimpleSampleUref) Nothing (Just (Phone {fromPhone = "+49198172826"})) - -testObject_UserIdentity_user_6 :: UserIdentity -testObject_UserIdentity_user_6 = PhoneIdentity (Phone {fromPhone = "+03038459796465"}) - -testObject_UserIdentity_user_7 :: UserIdentity -testObject_UserIdentity_user_7 = PhoneIdentity (Phone {fromPhone = "+805676294"}) - -testObject_UserIdentity_user_8 :: UserIdentity -testObject_UserIdentity_user_8 = SSOIdentity (UserSSOId mkSimpleSampleUref) Nothing (Just (Phone {fromPhone = "+149548802116267"})) - -testObject_UserIdentity_user_9 :: UserIdentity -testObject_UserIdentity_user_9 = - EmailIdentity - ( Email - { emailLocal = "'\ACKB\1000542\&90\NAKKK\EOTin\1096701r\EOT", - emailDomain = "Jj\\\172302>nY\9522\987654VO\DC2Q\r_:$\7618\EOTc~H8e}{g" - } - ) - -testObject_UserIdentity_user_10 :: UserIdentity -testObject_UserIdentity_user_10 = - EmailIdentity - ( Email - { emailLocal = "No\b\1006784b=`yl\133702p.w\1048001\142089\DC4\149735lm\183993&j9\a", - emailDomain = "\1054243.1\1031882\ETB_\1053320Q\1087931z.Ywe\1016096\39626>" - } - ) - -testObject_UserIdentity_user_11 :: UserIdentity -testObject_UserIdentity_user_11 = PhoneIdentity (Phone {fromPhone = "+755837448"}) - -testObject_UserIdentity_user_12 :: UserIdentity -testObject_UserIdentity_user_12 = - EmailIdentity (Email {emailLocal = "K\1012027\DC2", emailDomain = "\DC4N0Q\4986rva\NAK5\1080896+S\1070062;\FS%\NAK"}) - -testObject_UserIdentity_user_13 :: UserIdentity -testObject_UserIdentity_user_13 = - FullIdentity - (Email {emailLocal = "e\ACK\1036331\1062258vN:%\1058229\SUBSi\1035816Qq", emailDomain = ""}) - (Phone {fromPhone = "+387350906"}) - -testObject_UserIdentity_user_14 :: UserIdentity -testObject_UserIdentity_user_14 = - FullIdentity - ( Email - { emailLocal = "\1004575\184062\CAN\92545\&3\US<=gg", - emailDomain = "\1035369\1022539Nbo\tQ:\1085902f\136614L\1009643" - } - ) - (Phone {fromPhone = "+79378139213406"}) - -testObject_UserIdentity_user_15 :: UserIdentity -testObject_UserIdentity_user_15 = PhoneIdentity (Phone {fromPhone = "+092380942233194"}) - -testObject_UserIdentity_user_16 :: UserIdentity -testObject_UserIdentity_user_16 = - SSOIdentity - (UserSSOId mkSimpleSampleUref) - (Just (Email {emailLocal = "%x\DC3\1049873\EOT.", emailDomain = "G\48751t.6"})) - (Just (Phone {fromPhone = "+298116118047"})) - -testObject_UserIdentity_user_17 :: UserIdentity -testObject_UserIdentity_user_17 = - SSOIdentity (UserScimExternalId "") (Just (Email {emailLocal = "\GS\FS1k", emailDomain = "CV7\147439K"})) Nothing - -testObject_UserIdentity_user_18 :: UserIdentity -testObject_UserIdentity_user_18 = PhoneIdentity (Phone {fromPhone = "+7322674905"}) - -testObject_UserIdentity_user_19 :: UserIdentity -testObject_UserIdentity_user_19 = PhoneIdentity (Phone {fromPhone = "+133514352685272"}) - -testObject_UserIdentity_user_20 :: UserIdentity -testObject_UserIdentity_user_20 = - FullIdentity - (Email {emailLocal = "\133292A", emailDomain = "|\1083873\1005880N<\DC3z9\NAKV;^\1015230"}) - (Phone {fromPhone = "+926403020"}) diff --git a/libs/wire-api/test/golden/testObject_UserIdentity_user_1.json b/libs/wire-api/test/golden/testObject_UserIdentity_user_1.json deleted file mode 100644 index 029c472a9d..0000000000 --- a/libs/wire-api/test/golden/testObject_UserIdentity_user_1.json +++ /dev/null @@ -1,5 +0,0 @@ -{ - "email": "S\u0005X􆷳$\u0002\"􏇫e󷾤惿󻼜L\u0017@P.b", - "phone": null, - "sso_id": null -} diff --git a/libs/wire-api/test/golden/testObject_UserIdentity_user_10.json b/libs/wire-api/test/golden/testObject_UserIdentity_user_10.json deleted file mode 100644 index 0142780ab7..0000000000 --- a/libs/wire-api/test/golden/testObject_UserIdentity_user_10.json +++ /dev/null @@ -1,5 +0,0 @@ -{ - "email": "No\u0008󵳀b=`yl𠩆p.w󿷁𢬉\u0014𤣧lm𬺹&j9\u0007@􁘣.1󻻊\u0017_􁊈Q􉦻z.Ywe󸄠髊>", - "phone": null, - "sso_id": null -} diff --git a/libs/wire-api/test/golden/testObject_UserIdentity_user_11.json b/libs/wire-api/test/golden/testObject_UserIdentity_user_11.json deleted file mode 100644 index bff6512261..0000000000 --- a/libs/wire-api/test/golden/testObject_UserIdentity_user_11.json +++ /dev/null @@ -1,5 +0,0 @@ -{ - "email": null, - "phone": "+755837448", - "sso_id": null -} diff --git a/libs/wire-api/test/golden/testObject_UserIdentity_user_12.json b/libs/wire-api/test/golden/testObject_UserIdentity_user_12.json deleted file mode 100644 index 6d4144937f..0000000000 --- a/libs/wire-api/test/golden/testObject_UserIdentity_user_12.json +++ /dev/null @@ -1,5 +0,0 @@ -{ - "email": "K󷄻\u0012@\u0014N0Q፺rva\u00155􇹀+S􅏮;\u001c%\u0015", - "phone": null, - "sso_id": null -} diff --git a/libs/wire-api/test/golden/testObject_UserIdentity_user_13.json b/libs/wire-api/test/golden/testObject_UserIdentity_user_13.json deleted file mode 100644 index c4632b61e5..0000000000 --- a/libs/wire-api/test/golden/testObject_UserIdentity_user_13.json +++ /dev/null @@ -1,5 +0,0 @@ -{ - "email": "e\u0006󽀫􃕲vN:%􂖵\u001aSi󼸨Qq@", - "phone": "+387350906", - "sso_id": null -} diff --git a/libs/wire-api/test/golden/testObject_UserIdentity_user_14.json b/libs/wire-api/test/golden/testObject_UserIdentity_user_14.json deleted file mode 100644 index 5d2a9ce392..0000000000 --- a/libs/wire-api/test/golden/testObject_UserIdentity_user_14.json +++ /dev/null @@ -1,5 +0,0 @@ -{ - "email": "󵐟𬻾\u0018𖦁3\u001f<=gg@󼱩󹩋Nbo\tQ:􉇎f𡖦L󶟫", - "phone": "+79378139213406", - "sso_id": null -} diff --git a/libs/wire-api/test/golden/testObject_UserIdentity_user_15.json b/libs/wire-api/test/golden/testObject_UserIdentity_user_15.json deleted file mode 100644 index 35fa355d0f..0000000000 --- a/libs/wire-api/test/golden/testObject_UserIdentity_user_15.json +++ /dev/null @@ -1,5 +0,0 @@ -{ - "email": null, - "phone": "+092380942233194", - "sso_id": null -} diff --git a/libs/wire-api/test/golden/testObject_UserIdentity_user_17.json b/libs/wire-api/test/golden/testObject_UserIdentity_user_17.json deleted file mode 100644 index de51e10642..0000000000 --- a/libs/wire-api/test/golden/testObject_UserIdentity_user_17.json +++ /dev/null @@ -1,7 +0,0 @@ -{ - "email": "\u001d\u001c1k@CV7𣿯K", - "phone": null, - "sso_id": { - "scim_external_id": "" - } -} diff --git a/libs/wire-api/test/golden/testObject_UserIdentity_user_18.json b/libs/wire-api/test/golden/testObject_UserIdentity_user_18.json deleted file mode 100644 index 4c7aa3559a..0000000000 --- a/libs/wire-api/test/golden/testObject_UserIdentity_user_18.json +++ /dev/null @@ -1,5 +0,0 @@ -{ - "email": null, - "phone": "+7322674905", - "sso_id": null -} diff --git a/libs/wire-api/test/golden/testObject_UserIdentity_user_19.json b/libs/wire-api/test/golden/testObject_UserIdentity_user_19.json deleted file mode 100644 index 2d276e9f0a..0000000000 --- a/libs/wire-api/test/golden/testObject_UserIdentity_user_19.json +++ /dev/null @@ -1,5 +0,0 @@ -{ - "email": null, - "phone": "+133514352685272", - "sso_id": null -} diff --git a/libs/wire-api/test/golden/testObject_UserIdentity_user_2.json b/libs/wire-api/test/golden/testObject_UserIdentity_user_2.json deleted file mode 100644 index ed26790334..0000000000 --- a/libs/wire-api/test/golden/testObject_UserIdentity_user_2.json +++ /dev/null @@ -1,5 +0,0 @@ -{ - "email": "􃂐􄲝󷘒\u0004\u000bE\u0005W\u0016O\u0013X_F⎵\u0002 $}𫵧\u001fJ3🗠S?@4WL;'\u0010l1]x𝄥", - "phone": null, - "sso_id": null -} diff --git a/libs/wire-api/test/golden/testObject_UserIdentity_user_20.json b/libs/wire-api/test/golden/testObject_UserIdentity_user_20.json deleted file mode 100644 index c2b067e0ec..0000000000 --- a/libs/wire-api/test/golden/testObject_UserIdentity_user_20.json +++ /dev/null @@ -1,5 +0,0 @@ -{ - "email": "𠢬A@|􈧡󵤸N<\u0013z9\u0015V;^󷶾", - "phone": "+926403020", - "sso_id": null -} diff --git a/libs/wire-api/test/golden/testObject_UserIdentity_user_3.json b/libs/wire-api/test/golden/testObject_UserIdentity_user_3.json deleted file mode 100644 index 12387a4c4e..0000000000 --- a/libs/wire-api/test/golden/testObject_UserIdentity_user_3.json +++ /dev/null @@ -1,5 +0,0 @@ -{ - "email": "⩅:\u0014Ei􆐰P􁕆󽓿6phe\u0013\u0003H,\u0018\u000b𣣄\u000b>@bwtC􏅶z2RT28\u0002􀓭<3Y", - "phone": null, - "sso_id": null -} diff --git a/libs/wire-api/test/golden/testObject_UserIdentity_user_4.json b/libs/wire-api/test/golden/testObject_UserIdentity_user_4.json deleted file mode 100644 index 19e7f13385..0000000000 --- a/libs/wire-api/test/golden/testObject_UserIdentity_user_4.json +++ /dev/null @@ -1,5 +0,0 @@ -{ - "email": "\rH)𐂶@)􎞂\u001f槶\t\u0006􏚭_{𥲴7#", - "phone": "+2559583362", - "sso_id": null -} diff --git a/libs/wire-api/test/golden/testObject_UserIdentity_user_6.json b/libs/wire-api/test/golden/testObject_UserIdentity_user_6.json deleted file mode 100644 index c841bfca76..0000000000 --- a/libs/wire-api/test/golden/testObject_UserIdentity_user_6.json +++ /dev/null @@ -1,5 +0,0 @@ -{ - "email": null, - "phone": "+03038459796465", - "sso_id": null -} diff --git a/libs/wire-api/test/golden/testObject_UserIdentity_user_7.json b/libs/wire-api/test/golden/testObject_UserIdentity_user_7.json deleted file mode 100644 index 5edc20024a..0000000000 --- a/libs/wire-api/test/golden/testObject_UserIdentity_user_7.json +++ /dev/null @@ -1,5 +0,0 @@ -{ - "email": null, - "phone": "+805676294", - "sso_id": null -} diff --git a/libs/wire-api/test/golden/testObject_UserIdentity_user_9.json b/libs/wire-api/test/golden/testObject_UserIdentity_user_9.json deleted file mode 100644 index 2500b91fd2..0000000000 --- a/libs/wire-api/test/golden/testObject_UserIdentity_user_9.json +++ /dev/null @@ -1,5 +0,0 @@ -{ - "email": "'\u0006B󴑞90\u0015KK\u0004in􋯽r\u0004@Jj\\𪄎>nY┲󱈆VO\u0012Q\r_:$᷂\u0004c~H8e}{g", - "phone": null, - "sso_id": null -} diff --git a/libs/wire-api/test/unit/Test/Wire/API/Roundtrip/Aeson.hs b/libs/wire-api/test/unit/Test/Wire/API/Roundtrip/Aeson.hs index 5ff334d8a1..b63079c202 100644 --- a/libs/wire-api/test/unit/Test/Wire/API/Roundtrip/Aeson.hs +++ b/libs/wire-api/test/unit/Test/Wire/API/Roundtrip/Aeson.hs @@ -297,7 +297,6 @@ tests = testRoundTrip @User.Identity.Email, testRoundTrip @User.Identity.Phone, testRoundTrip @User.Identity.UserSSOId, - testRoundTrip @User.Identity.UserIdentity, testRoundTrip @User.Password.NewPasswordReset, testRoundTrip @User.Password.PasswordResetKey, -- FUTUREWORK: this should probably be tested individually, diff --git a/libs/wire-api/test/unit/Test/Wire/API/User.hs b/libs/wire-api/test/unit/Test/Wire/API/User.hs index 2b23905559..5c05e6a619 100644 --- a/libs/wire-api/test/unit/Test/Wire/API/User.hs +++ b/libs/wire-api/test/unit/Test/Wire/API/User.hs @@ -26,6 +26,7 @@ import Data.Domain import Data.Id import Data.LegalHold (UserLegalHoldStatus (UserLegalHoldNoConsent)) import Data.Qualified +import Data.Schema (schemaIn) import qualified Data.UUID.V4 as UUID import Imports import Test.Tasty @@ -53,28 +54,28 @@ testUserProfile = do parseIdentityTests :: [TestTree] parseIdentityTests = - [ let (=#=) :: Either String (Maybe UserIdentity) -> (Maybe UserSSOId, [Pair]) -> Assertion - (=#=) uid (mssoid, object -> Object obj) = assertEqual "=#=" uid (parseEither (parseIdentity mssoid) obj) + [ let (=#=) :: Either String (Maybe UserIdentity) -> [Pair] -> Assertion + (=#=) uid (object -> Object obj) = assertEqual "=#=" uid (parseEither (schemaIn maybeUserIdentityObjectSchema) obj) (=#=) _ bad = error $ "=#=: impossible: " <> show bad in testGroup "parseIdentity" [ testCase "FullIdentity" $ - Right (Just (FullIdentity hemail hphone)) =#= (Nothing, [email, phone]), + Right (Just (FullIdentity hemail hphone)) =#= [email, phone], testCase "EmailIdentity" $ - Right (Just (EmailIdentity hemail)) =#= (Nothing, [email]), + Right (Just (EmailIdentity hemail)) =#= [email], testCase "PhoneIdentity" $ - Right (Just (PhoneIdentity hphone)) =#= (Nothing, [phone]), + Right (Just (PhoneIdentity hphone)) =#= [phone], testCase "SSOIdentity" $ do - Right (Just (SSOIdentity hssoid Nothing Nothing)) =#= (Just hssoid, [ssoid]) - Right (Just (SSOIdentity hssoid Nothing (Just hphone))) =#= (Just hssoid, [ssoid, phone]) - Right (Just (SSOIdentity hssoid (Just hemail) Nothing)) =#= (Just hssoid, [ssoid, email]) - Right (Just (SSOIdentity hssoid (Just hemail) (Just hphone))) =#= (Just hssoid, [ssoid, email, phone]), + Right (Just (SSOIdentity hssoid Nothing Nothing)) =#= [ssoid] + Right (Just (SSOIdentity hssoid Nothing (Just hphone))) =#= [ssoid, phone] + Right (Just (SSOIdentity hssoid (Just hemail) Nothing)) =#= [ssoid, email] + Right (Just (SSOIdentity hssoid (Just hemail) (Just hphone))) =#= [ssoid, email, phone], testCase "Bad phone" $ - Left "Error in $.phone: Invalid phone number. Expected E.164 format." =#= (Nothing, [badphone]), + Left "Error in $.phone: Invalid phone number. Expected E.164 format." =#= [badphone], testCase "Bad email" $ - Left "Error in $.email: Invalid email. Expected '@'." =#= (Nothing, [bademail]), + Left "Error in $.email: Invalid email. Expected '@'." =#= [bademail], testCase "Nothing" $ - Right Nothing =#= (Nothing, [("something_unrelated", "#")]) + Right Nothing =#= [("something_unrelated", "#")] ] ] where diff --git a/libs/wire-api/wire-api.cabal b/libs/wire-api/wire-api.cabal index 8fd943c89c..caabffd61a 100644 --- a/libs/wire-api/wire-api.cabal +++ b/libs/wire-api/wire-api.cabal @@ -452,7 +452,6 @@ test-suite wire-api-golden-tests Test.Wire.API.Golden.Generated.UserConnection_user Test.Wire.API.Golden.Generated.UserConnectionList_user Test.Wire.API.Golden.Generated.UserHandleInfo_user - Test.Wire.API.Golden.Generated.UserIdentity_user Test.Wire.API.Golden.Generated.UserLegalHoldStatusResponse_team Test.Wire.API.Golden.Generated.UserProfile_user Test.Wire.API.Golden.Generated.UserSSOId_user @@ -656,6 +655,7 @@ test-suite wire-api-tests , pretty , proto-lens , saml2-web-sso + , schema-profunctor , servant , servant-swagger-ui , string-conversions From f59aad6d50dc0509daa4d88caab81d2830202478 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Tue, 15 Feb 2022 17:30:44 +0100 Subject: [PATCH 06/18] WIP --- .../wire-api/src/Wire/API/ErrorDescription.hs | 25 ++++++ .../src/Wire/API/Routes/Public/Brig.hs | 2 +- libs/wire-api/src/Wire/API/User.hs | 57 ++++++++++++- services/brig/src/Brig/API/Error.hs | 3 +- services/brig/src/Brig/API/Handler.hs | 21 +++-- services/brig/src/Brig/API/Public.hs | 79 ++++++++----------- services/brig/src/Brig/API/User.hs | 56 +++++++------ services/brig/src/Brig/Data/Activation.hs | 7 +- services/brig/src/Brig/User/Auth/Cookie.hs | 33 ++++---- 9 files changed, 184 insertions(+), 99 deletions(-) diff --git a/libs/wire-api/src/Wire/API/ErrorDescription.hs b/libs/wire-api/src/Wire/API/ErrorDescription.hs index 49870a480f..8b2ca722c0 100644 --- a/libs/wire-api/src/Wire/API/ErrorDescription.hs +++ b/libs/wire-api/src/Wire/API/ErrorDescription.hs @@ -387,3 +387,28 @@ type MLSIdentityMismatch = 403 "mls-identity-mismatch" "Prekey credential does not match qualified client ID" + +type WhitelistError = ErrorDescription 403 "unauthorized" "Unauthorized e-mail address or phone number." + +type InvalidInvitationCode = ErrorDescription 400 "invalid-invitation-code" "Invalid invitation code." + +type MissingIdentity = ErrorDescription 403 "missing-identity" "Using an invitation code requires registering the given email and/or phone." + +type BlacklistedEmail = + ErrorDescription + 403 + "blacklisted-email" + "The given e-mail address has been blacklisted due to a permanent bounce \ + \or a complaint." + +type InvalidEmail = ErrorDescription 400 "invalid-email" "Invalid e-mail address." + +type InvalidActivationCode msg = ErrorDescription 404 "invalid-code" msg + +type InvalidActivationCodeWrongUser = InvalidActivationCode "User does not exist." + +type InvalidActivationCodeWrongCode = InvalidActivationCode "Invalid activation code" + +type TooManyTeamMembers = ErrorDescription 403 "too-many-team-members" "Too many members in this team." + +type UserCreationRestricted = ErrorDescription 403 "user-creation-restricted" "This instance does not allow creation of personal users or teams." diff --git a/libs/wire-api/src/Wire/API/Routes/Public/Brig.hs b/libs/wire-api/src/Wire/API/Routes/Public/Brig.hs index 1d814310c4..83463b2133 100644 --- a/libs/wire-api/src/Wire/API/Routes/Public/Brig.hs +++ b/libs/wire-api/src/Wire/API/Routes/Public/Brig.hs @@ -327,7 +327,7 @@ type AccountAPI = \number is not whitelisted, a 403 error is returned." :> "register" :> ReqBody '[JSON] NewUserPublic - :> MultiVerb 'POST '[JSON] RegisterResponses (Either RegisterError SelfProfile) + :> MultiVerb 'POST '[JSON] RegisterResponses (Either RegisterError RegisterSuccess) ) type PrekeyAPI = diff --git a/libs/wire-api/src/Wire/API/User.hs b/libs/wire-api/src/Wire/API/User.hs index 5a47163e2b..fbc86e820b 100644 --- a/libs/wire-api/src/Wire/API/User.hs +++ b/libs/wire-api/src/Wire/API/User.hs @@ -38,6 +38,7 @@ module Wire.API.User -- * NewUser NewUserPublic (..), RegisterError (..), + RegisterSuccess (..), RegisterResponses, NewUser (..), emptyNewUser, @@ -137,6 +138,7 @@ import Imports import qualified SAML2.WebSSO as SAML import Servant (type (.++)) import qualified Test.QuickCheck as QC +import qualified Web.Cookie as Web import Wire.API.Arbitrary (Arbitrary (arbitrary), GenericUniform (..)) import Wire.API.ErrorDescription import Wire.API.Provider.Service (ServiceRef, modelServiceRef) @@ -537,9 +539,58 @@ isNewUserTeamMember u = case newUserTeam u of instance Arbitrary NewUserPublic where arbitrary = arbitrary `QC.suchThatMap` (rightMay . validateNewUserPublic) -data RegisterError = RegisterError - -type RegisterResponses = '[] +data RegisterError + = RegisterErrorWhitelistError + | RegisterErrorInvalidInvitationCode + | RegisterErrorMissingIdentity + | RegisterErrorUserKeyExists + | RegisterErrorInvalidActivationCodeWrongUser + | RegisterErrorInvalidActivationCodeWrongCode + | RegisterErrorInvalidEmail + | RegisterErrorInvalidPhone + | RegisterErrorBlacklistedPhone + | RegisterErrorBlacklistedEmail + | RegisterErrorTooManyTeamMembers + | RegisterErrorUserCreationRestricted + deriving (Generic) + deriving (AsUnion RegisterErrorResponses) via GenericAsUnion RegisterErrorResponses RegisterError + +instance GSOP.Generic RegisterError + +type RegisterErrorResponses = + '[ WhitelistError, + InvalidInvitationCode, + MissingIdentity, + UserKeyExists, + InvalidActivationCodeWrongUser, + InvalidActivationCodeWrongCode, + InvalidEmail, + InvalidPhone, + BlacklistedPhone, + BlacklistedEmail, + TooManyTeamMembers, + UserCreationRestricted + ] + +type RegisterResponses = + RegisterErrorResponses + .++ '[ WithHeaders + '[ DescHeader "Set-Cookie" "Cookie" Web.SetCookie, + DescHeader "Location" "UserId" UserId + ] + RegisterSuccess + (Respond 201 "User created and pending activation" SelfProfile) + ] + +instance AsHeaders '[Web.SetCookie, UserId] SelfProfile RegisterSuccess where + fromHeaders (I cookie :* (_ :* Nil), sp) = RegisterSuccess cookie sp + toHeaders (RegisterSuccess cookie sp) = (I cookie :* (I (userId (selfUser sp)) :* Nil), sp) + +data RegisterSuccess = RegisterSuccess Web.SetCookie SelfProfile + +instance (res ~ RegisterResponses) => AsUnion res (Either RegisterError RegisterSuccess) where + toUnion = eitherToUnion (toUnion @RegisterErrorResponses) (Z . I) + fromUnion = eitherFromUnion (fromUnion @RegisterErrorResponses) (unI . unZ) data NewUser = NewUser { newUserDisplayName :: Name, diff --git a/services/brig/src/Brig/API/Error.hs b/services/brig/src/Brig/API/Error.hs index bb97ae837a..b2f31b2a26 100644 --- a/services/brig/src/Brig/API/Error.hs +++ b/services/brig/src/Brig/API/Error.hs @@ -120,7 +120,8 @@ connError (ConnectFederationError e) = fedError e actError :: ActivationError -> Error actError (UserKeyExists _) = StdError (errorDescriptionTypeToWai @UserKeyExists) -actError (InvalidActivationCode e) = StdError (invalidActivationCode e) +actError InvalidActivationCodeWrongUser = StdError (errorDescriptionTypeToWai @InvalidActivationCodeWrongUser) +actError InvalidActivationCodeWrongCode = StdError (errorDescriptionTypeToWai @InvalidActivationCodeWrongCode) actError (InvalidActivationEmail _ _) = StdError invalidEmail actError (InvalidActivationPhone _) = StdError (errorDescriptionTypeToWai @InvalidPhone) diff --git a/services/brig/src/Brig/API/Handler.hs b/services/brig/src/Brig/API/Handler.hs index 967e2afefb..47ad3e621c 100644 --- a/services/brig/src/Brig/API/Handler.hs +++ b/services/brig/src/Brig/API/Handler.hs @@ -25,10 +25,12 @@ module Brig.API.Handler JSON, parseJsonBody, checkWhitelist, + checkWhitelistWithError, + isWhiteListed, ) where -import Bilge (RequestId (..)) +import Bilge (MonadHttp, RequestId (..)) import Brig.API.Error import qualified Brig.AWS as AWS import Brig.App (AppIO, Env, applog, requestId, runAppT, settings) @@ -40,6 +42,7 @@ import Control.Error import Control.Lens (set, view) import Control.Monad.Catch (catches, throwM) import qualified Control.Monad.Catch as Catch +import Control.Monad.Except (MonadError, throwError) import Data.Aeson (FromJSON) import qualified Data.Aeson as Aeson import Data.Default (def) @@ -140,10 +143,16 @@ parseJsonBody req = parseBody req !>> StdError . badRequest -- | If a whitelist is configured, consult it, otherwise a no-op. {#RefActivationWhitelist} checkWhitelist :: Either Email Phone -> (Handler r) () -checkWhitelist key = do +checkWhitelist = checkWhitelistWithError (StdError whitelistError) + +checkWhitelistWithError :: (Monad m, MonadReader Env m, MonadIO m, Catch.MonadMask m, MonadHttp m, MonadError e m) => e -> Either Email Phone -> m () +checkWhitelistWithError e key = do + ok <- isWhiteListed key + unless ok (throwError e) + +isWhiteListed :: (Monad m, MonadReader Env m, MonadIO m, Catch.MonadMask m, MonadHttp m) => Either Email Phone -> m Bool +isWhiteListed key = do eb <- setWhitelist <$> view settings case eb of - Nothing -> return () - Just b -> do - ok <- lift $ Whitelist.verify b key - unless ok (throwStd whitelistError) + Nothing -> pure True + Just b -> Whitelist.verify b key diff --git a/services/brig/src/Brig/API/Public.hs b/services/brig/src/Brig/API/Public.hs index 22829c9358..649ee03405 100644 --- a/services/brig/src/Brig/API/Public.hs +++ b/services/brig/src/Brig/API/Public.hs @@ -61,7 +61,6 @@ import Control.Error hiding (bool) import Control.Lens (view, (%~), (.~), (?~), (^.), _Just) import Control.Monad.Catch (throwM) import Data.Aeson hiding (json) -import Data.ByteString.Conversion import qualified Data.ByteString.Lazy as Lazy import qualified Data.ByteString.Lazy.Char8 as LBS import qualified Data.Code as Code @@ -113,6 +112,7 @@ import Wire.API.Routes.Version import qualified Wire.API.Swagger as Public.Swagger (models) import qualified Wire.API.Team as Public import Wire.API.Team.LegalHold (LegalholdProtectee (..)) +import Wire.API.User (RegisterError (RegisterErrorWhitelistError)) import qualified Wire.API.User as Public import qualified Wire.API.User.Activation as Public import qualified Wire.API.User.Auth as Public @@ -189,7 +189,7 @@ servantSitemap = userAPI :<|> selfAPI :<|> accountAPI :<|> clientAPI :<|> prekey :<|> Named @"change-handle" changeHandle accountAPI :: ServerT AccountAPI (Handler r) - accountAPI = undefined + accountAPI = Named @"register" createUser clientAPI :: ServerT ClientAPI (Handler r) clientAPI :: ServerT ClientAPI Handler @@ -376,27 +376,27 @@ sitemap = do -- This endpoint can lead to the following events being sent: -- - UserActivated event to created user, if it is a team invitation or user has an SSO ID -- - UserIdentityUpdated event to created user, if email code or phone code is provided - post "/register" (continue createUserH) $ - accept "application" "json" - .&. jsonRequest @Public.NewUserPublic - document "POST" "register" $ do - Doc.summary "Register a new user." - Doc.notes - "If the environment where the registration takes \ - \place is private and a registered email address or phone \ - \number is not whitelisted, a 403 error is returned." - Doc.body (Doc.ref Public.modelNewUser) $ - Doc.description "JSON body" - -- FUTUREWORK: I think this should be 'Doc.self' instead of 'user' - Doc.returns (Doc.ref Public.modelUser) - Doc.response 201 "User created and pending activation." Doc.end - Doc.errorResponse whitelistError - Doc.errorResponse invalidInvitationCode - Doc.errorResponse missingIdentity - Doc.errorResponse (errorDescriptionTypeToWai @UserKeyExists) - Doc.errorResponse activationCodeNotFound - Doc.errorResponse blacklistedEmail - Doc.errorResponse (errorDescriptionTypeToWai @BlacklistedPhone) + -- post "/register" (continue createUserH) $ + -- accept "application" "json" + -- .&. jsonRequest @Public.NewUserPublic + -- document "POST" "register" $ do + -- Doc.summary "Register a new user." + -- Doc.notes + -- "If the environment where the registration takes \ + -- \place is private and a registered email address or phone \ + -- \number is not whitelisted, a 403 error is returned." + -- Doc.body (Doc.ref Public.modelNewUser) $ + -- Doc.description "JSON body" + -- -- FUTUREWORK: I think this should be 'Doc.self' instead of 'user' + -- Doc.returns (Doc.ref Public.modelUser) + -- Doc.response 201 "User created and pending activation." Doc.end + -- Doc.errorResponse whitelistError + -- Doc.errorResponse invalidInvitationCode + -- Doc.errorResponse missingIdentity + -- Doc.errorResponse (errorDescriptionTypeToWai @UserKeyExists) + -- Doc.errorResponse activationCodeNotFound + -- Doc.errorResponse blacklistedEmail + -- Doc.errorResponse (errorDescriptionTypeToWai @BlacklistedPhone) -- This endpoint can lead to the following events being sent: -- - UserActivated event to the user, if account gets activated @@ -679,23 +679,12 @@ getRichInfo self user = do getClientPrekeys :: UserId -> ClientId -> (Handler r) [Public.PrekeyId] getClientPrekeys usr clt = lift (API.lookupPrekeyIds usr clt) --- docs/reference/user/registration.md {#RefRegistration} -createUserH :: JSON ::: JsonRequest Public.NewUserPublic -> (Handler r) Response -createUserH (_ ::: req) = do - CreateUserResponse cok loc prof <- createUser =<< parseJsonBody req - lift . Auth.setResponseCookie cok - . setStatus status201 - . addHeader "Location" (toByteString' loc) - $ json prof - -data CreateUserResponse - = CreateUserResponse (Public.Cookie (ZAuth.Token ZAuth.User)) UserId Public.SelfProfile - -createUser :: Public.NewUserPublic -> (Handler r) CreateUserResponse -createUser (Public.NewUserPublic new) = do - API.checkRestrictedUserCreation new !>> newUserError - for_ (Public.newUserEmail new) $ checkWhitelist . Left - for_ (Public.newUserPhone new) $ checkWhitelist . Right +-- | docs/reference/user/registration.md {#RefRegistration} +createUser :: Public.NewUserPublic -> (Handler r) (Either Public.RegisterError Public.RegisterSuccess) +createUser (Public.NewUserPublic new) = runExceptT $ do + API.checkRestrictedUserCreation new -- !>> newUserError + for_ (Public.newUserEmail new) $ checkWhitelistWithError RegisterErrorWhitelistError . Left + for_ (Public.newUserPhone new) $ checkWhitelistWithError RegisterErrorWhitelistError . Right result <- API.createUser new !>> newUserError let acc = createdAccount result @@ -730,10 +719,12 @@ createUser (Public.NewUserPublic new) = do sendActivationSms p c (Just userLocale) for_ (liftM3 (,,) userEmail (createdUserTeam result) newUserTeam) $ \(e, ct, ut) -> sendWelcomeEmail e ct ut (Just userLocale) - cok <- case acc of - UserAccount _ Ephemeral -> lift $ Auth.newCookie @ZAuth.User userId Public.SessionCookie newUserLabel - UserAccount _ _ -> lift $ Auth.newCookie @ZAuth.User userId Public.PersistentCookie newUserLabel - pure $ CreateUserResponse cok userId (Public.SelfProfile usr) + cok <- + Auth.toWebCookie =<< case acc of + UserAccount _ Ephemeral -> lift $ Auth.newCookie @ZAuth.User userId Public.SessionCookie newUserLabel + UserAccount _ _ -> lift $ Auth.newCookie @ZAuth.User userId Public.PersistentCookie newUserLabel + -- pure $ CreateUserResponse cok userId (Public.SelfProfile usr) + pure $ Right (Public.RegisterSuccess cok (Public.SelfProfile usr)) where sendActivationEmail :: Public.Email -> Public.Name -> ActivationPair -> Maybe Public.Locale -> Maybe Public.NewTeamUser -> (AppIO r) () sendActivationEmail e u p l mTeamUser diff --git a/services/brig/src/Brig/API/User.hs b/services/brig/src/Brig/API/User.hs index 447cc3b3ef..10101cd2a8 100644 --- a/services/brig/src/Brig/API/User.hs +++ b/services/brig/src/Brig/API/User.hs @@ -163,21 +163,20 @@ data AllowSCIMUpdates ------------------------------------------------------------------------------- -- Create User -verifyUniquenessAndCheckBlacklist :: UserKey -> ExceptT CreateUserError (AppIO r) () +verifyUniquenessAndCheckBlacklist :: UserKey -> ExceptT RegisterError (AppIO r) () verifyUniquenessAndCheckBlacklist uk = do checkKey Nothing uk blacklisted <- lift $ Blacklist.exists uk when blacklisted $ - throwE (BlacklistedUserKey uk) + throwE (foldKey (const RegisterErrorBlacklistedEmail) (const RegisterErrorBlacklistedPhone) uk) where checkKey u k = do av <- lift $ Data.keyAvailable k u unless av $ - throwE $ - DuplicateUserKey k + throwE RegisterErrorUserKeyExists -- docs/reference/user/registration.md {#RefRegistration} -createUser :: NewUser -> ExceptT CreateUserError (AppIO r) CreateUserResult +createUser :: NewUser -> ExceptT RegisterError (AppIO r) CreateUserResult createUser new = do (email, phone) <- validateEmailAndPhone new @@ -276,19 +275,19 @@ createUser new = do where -- NOTE: all functions in the where block don't use any arguments of createUser - validateEmailAndPhone :: NewUser -> ExceptT CreateUserError (AppT r IO) (Maybe Email, Maybe Phone) + validateEmailAndPhone :: NewUser -> ExceptT RegisterError (AppT r IO) (Maybe Email, Maybe Phone) validateEmailAndPhone newUser = do -- Validate e-mail email <- for (newUserEmail newUser) $ \e -> either - (throwE . InvalidEmail e) + (const $ throwE RegisterErrorInvalidEmail) return (validateEmail e) -- Validate phone phone <- for (newUserPhone newUser) $ \p -> maybe - (throwE (InvalidPhone p)) + (throwE RegisterErrorInvalidPhone) return =<< lift (validatePhone p) @@ -297,8 +296,8 @@ createUser new = do pure (email, phone) - findTeamInvitation :: Maybe UserKey -> InvitationCode -> ExceptT CreateUserError (AppIO r) (Maybe (Team.Invitation, Team.InvitationInfo, TeamId)) - findTeamInvitation Nothing _ = throwE MissingIdentity + findTeamInvitation :: Maybe UserKey -> InvitationCode -> ExceptT RegisterError (AppIO r) (Maybe (Team.Invitation, Team.InvitationInfo, TeamId)) + findTeamInvitation Nothing _ = throwE RegisterErrorMissingIdentity findTeamInvitation (Just e) c = lift (Team.lookupInvitationInfo c) >>= \case Just ii -> do @@ -308,20 +307,20 @@ createUser new = do | e == userEmailKey em -> do _ <- ensureMemberCanJoin (Team.iiTeam ii) return $ Just (invite, ii, Team.iiTeam ii) - _ -> throwE InvalidInvitationCode - Nothing -> throwE InvalidInvitationCode + _ -> throwE RegisterErrorInvalidInvitationCode + Nothing -> throwE RegisterErrorInvalidInvitationCode - ensureMemberCanJoin :: TeamId -> ExceptT CreateUserError (AppIO r) () + ensureMemberCanJoin :: TeamId -> ExceptT RegisterError (AppIO r) () ensureMemberCanJoin tid = do maxSize <- fromIntegral . setMaxTeamSize <$> view settings (TeamSize teamSize) <- TeamSize.teamSize tid when (teamSize >= maxSize) $ - throwE TooManyTeamMembers + throwE RegisterErrorTooManyTeamMembers -- FUTUREWORK: The above can easily be done/tested in the intra call. -- Remove after the next release. canAdd <- lift $ Intra.checkUserCanJoinTeam tid case canAdd of - Just e -> throwE (ExternalPreconditionFailed e) + Just e -> undefined -- TODO: How do we do this: throwE (ExternalPreconditionFailed e) Nothing -> pure () acceptTeamInvitation :: @@ -330,18 +329,17 @@ createUser new = do Team.InvitationInfo -> UserKey -> UserIdentity -> - ExceptT CreateUserError (AppT r IO) () + ExceptT RegisterError (AppT r IO) () acceptTeamInvitation account inv ii uk ident = do let uid = userId (accountUser account) ok <- lift $ Data.claimKey uk uid unless ok $ - throwE $ - DuplicateUserKey uk + throwE RegisterErrorUserKeyExists let minvmeta :: (Maybe (UserId, UTCTimeMillis), Team.Role) minvmeta = ((,inCreatedAt inv) <$> inCreatedBy inv, Team.inRole inv) added <- lift $ Intra.addTeamMember uid (Team.iiTeam ii) minvmeta unless added $ - throwE TooManyTeamMembers + throwE RegisterErrorTooManyTeamMembers lift $ do activateUser uid ident -- ('insertAccount' sets column activated to False; here it is set to True.) void $ onActivated (AccountActivated account) @@ -352,12 +350,12 @@ createUser new = do Data.usersPendingActivationRemove uid Team.deleteInvitation (Team.inTeam inv) (Team.inInvitation inv) - addUserToTeamSSO :: UserAccount -> TeamId -> UserIdentity -> ExceptT CreateUserError (AppIO r) CreateUserTeam + addUserToTeamSSO :: UserAccount -> TeamId -> UserIdentity -> ExceptT RegisterError (AppIO r) CreateUserTeam addUserToTeamSSO account tid ident = do let uid = userId (accountUser account) added <- lift $ Intra.addTeamMember uid tid (Nothing, Team.defaultRole) unless added $ - throwE TooManyTeamMembers + throwE RegisterErrorTooManyTeamMembers lift $ do activateUser uid ident void $ onActivated (AccountActivated account) @@ -369,7 +367,7 @@ createUser new = do pure $ CreateUserTeam tid nm -- Handle e-mail activation (deprecated, see #RefRegistrationNoPreverification in /docs/reference/user/registration.md) - handleEmailActivation :: Maybe Email -> UserId -> Maybe BindingNewTeamUser -> ExceptT CreateUserError (AppT r IO) (Maybe Activation) + handleEmailActivation :: Maybe Email -> UserId -> Maybe BindingNewTeamUser -> ExceptT RegisterError (AppT r IO) (Maybe Activation) handleEmailActivation email uid newTeam = do fmap join . for (userEmailKey <$> email) $ \ek -> case newUserEmailCode new of Nothing -> do @@ -382,7 +380,14 @@ createUser new = do return $ Just edata Just c -> do ak <- liftIO $ Data.mkActivationKey ek - void $ activateWithCurrency (ActivateKey ak) c (Just uid) (bnuCurrency =<< newTeam) !>> EmailActivationError + void $ + activateWithCurrency (ActivateKey ak) c (Just uid) (bnuCurrency =<< newTeam) + !>> ( \case + UserKeyExists _ -> RegisterErrorUserKeyExists + InvalidActivationCode txt -> _ + InvalidActivationEmail em s -> _ + InvalidActivationPhone ph -> _ + ) return Nothing -- Handle phone activation (deprecated, see #RefRegistrationNoPreverification in /docs/reference/user/registration.md) @@ -428,7 +433,6 @@ createUserInviteViaScim uid (NewUserScimInvitation tid loc name rawEmail) = (`ca lift $ Data.usersPendingActivationAdd (UserPendingActivation uid expiresAt) let activated = - -- It would be nice to set this to 'False' to make sure we're not accidentally -- treating 'PendingActivation' as 'Active', but then 'Brig.Data.User.toIdentity' -- would not produce an identity, and so we won't have the email address to construct -- the SCIM user. @@ -438,7 +442,7 @@ createUserInviteViaScim uid (NewUserScimInvitation tid loc name rawEmail) = (`ca return account -- | docs/reference/user/registration.md {#RefRestrictRegistration}. -checkRestrictedUserCreation :: NewUser -> ExceptT CreateUserError (AppIO r) () +checkRestrictedUserCreation :: NewUser -> ExceptT RegisterError (AppIO r) () checkRestrictedUserCreation new = do restrictPlease <- lift . asks $ fromMaybe False . setRestrictUserCreation . view settings when @@ -446,7 +450,7 @@ checkRestrictedUserCreation new = do && not (isNewUserTeamMember new) && not (isNewUserEphemeral new) ) - $ throwE UserCreationRestricted + $ throwE RegisterErrorUserCreationRestricted ------------------------------------------------------------------------------- -- Update Profile diff --git a/services/brig/src/Brig/Data/Activation.hs b/services/brig/src/Brig/Data/Activation.hs index 919f93df76..d4a63a78b4 100644 --- a/services/brig/src/Brig/Data/Activation.hs +++ b/services/brig/src/Brig/Data/Activation.hs @@ -60,7 +60,8 @@ data Activation = Activation data ActivationError = UserKeyExists !LT.Text - | InvalidActivationCode !LT.Text + | InvalidActivationCodeWrongUser + | InvalidActivationCodeWrongCode | InvalidActivationEmail !Email !String | InvalidActivationPhone !Phone @@ -189,10 +190,10 @@ deleteActivationPair :: ActivationKey -> (AppIO r) () deleteActivationPair = write keyDelete . params LocalQuorum . Identity invalidUser :: ActivationError -invalidUser = InvalidActivationCode "User does not exist." +invalidUser = InvalidActivationCodeWrongUser -- "User does not exist." invalidCode :: ActivationError -invalidCode = InvalidActivationCode "Invalid activation code" +invalidCode = InvalidActivationCodeWrongCode -- "Invalid activation code" keyInsert :: PrepQuery W (ActivationKey, Text, Text, ActivationCode, Maybe UserId, Int32, Int32) () keyInsert = diff --git a/services/brig/src/Brig/User/Auth/Cookie.hs b/services/brig/src/Brig/User/Auth/Cookie.hs index 28023f5863..2cd821f9af 100644 --- a/services/brig/src/Brig/User/Auth/Cookie.hs +++ b/services/brig/src/Brig/User/Auth/Cookie.hs @@ -32,6 +32,7 @@ module Brig.User.Auth.Cookie -- * HTTP setResponseCookie, + toWebCookie, -- * Re-exports Cookie (..), @@ -226,22 +227,24 @@ setResponseCookie :: Response -> m Response setResponseCookie c r = do - s <- view settings - let hdr = toByteString' (WebCookie.renderSetCookie (cookie s)) + hdr <- toByteString' . WebCookie.renderSetCookie <$> toWebCookie c return (addHeader "Set-Cookie" hdr r) - where - cookie s = - WebCookie.def - { WebCookie.setCookieName = "zuid", - WebCookie.setCookieValue = toByteString' (cookieValue c), - WebCookie.setCookiePath = Just "/access", - WebCookie.setCookieExpires = - if cookieType c == PersistentCookie - then Just (cookieExpires c) - else Nothing, - WebCookie.setCookieSecure = not (setCookieInsecure s), - WebCookie.setCookieHttpOnly = True - } + +toWebCookie :: (Monad m, MonadReader Env m, ZAuth.UserTokenLike u) => Cookie (ZAuth.Token u) -> m WebCookie.SetCookie +toWebCookie c = do + s <- view settings + pure $ + WebCookie.def + { WebCookie.setCookieName = "zuid", + WebCookie.setCookieValue = toByteString' (cookieValue c), + WebCookie.setCookiePath = Just "/access", + WebCookie.setCookieExpires = + if cookieType c == PersistentCookie + then Just (cookieExpires c) + else Nothing, + WebCookie.setCookieSecure = not (setCookieInsecure s), + WebCookie.setCookieHttpOnly = True + } -------------------------------------------------------------------------------- -- Tracking From db1871aae7b1fc2bbfc9f89d62cc0168ca0a0f61 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Wed, 16 Feb 2022 11:16:40 +0100 Subject: [PATCH 07/18] Things compile, with 1 thing undefined --- .../src/Wire/API/Routes/Internal/Brig.hs | 33 +++++++++--- libs/wire-api/src/Wire/API/Routes/Named.hs | 6 +++ libs/wire-api/src/Wire/API/User.hs | 17 ++++++ services/brig/src/Brig/API/Internal.hs | 36 +++++-------- services/brig/src/Brig/API/Public.hs | 8 +-- services/brig/src/Brig/API/User.hs | 53 ++++++++++++------- services/brig/src/Brig/Data/Activation.hs | 10 ++++ services/galley/src/Galley/Intra/User.hs | 7 +-- 8 files changed, 114 insertions(+), 56 deletions(-) diff --git a/libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs b/libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs index 8665d12ca7..e8747fb173 100644 --- a/libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs +++ b/libs/wire-api/src/Wire/API/Routes/Internal/Brig.hs @@ -17,6 +17,8 @@ module Wire.API.Routes.Internal.Brig ( API, + EJPD_API, + AccountAPI, EJPDRequest, GetAccountFeatureConfig, PutAccountFeatureConfig, @@ -39,7 +41,10 @@ import Servant.Swagger.UI import Wire.API.Connection import Wire.API.Routes.Internal.Brig.Connection import Wire.API.Routes.Internal.Brig.EJPD +import Wire.API.Routes.MultiVerb +import Wire.API.Routes.Named import qualified Wire.API.Team.Feature as ApiFt +import Wire.API.User type EJPDRequest = Summary @@ -109,15 +114,29 @@ type GetAllConnections = :> ReqBody '[Servant.JSON] ConnectionsStatusRequestV2 :> Post '[Servant.JSON] [ConnectionStatusV2] +type EJPD_API = + ( EJPDRequest + :<|> GetAccountFeatureConfig + :<|> PutAccountFeatureConfig + :<|> DeleteAccountFeatureConfig + :<|> GetAllConnectionsUnqualified + :<|> GetAllConnections + ) + +type AccountAPI = + -- This endpoint can lead to the following events being sent: + -- - UserActivated event to created user, if it is a team invitation or user has an SSO ID + -- - UserIdentityUpdated event to created user, if email or phone get activated + Named + "createUserNoVerify" + ( "users" + :> ReqBody '[Servant.JSON] NewUser + :> MultiVerb 'POST '[Servant.JSON] RegisterInternalResponses (Either RegisterError SelfProfile) + ) + type API = "i" - :> ( EJPDRequest - :<|> GetAccountFeatureConfig - :<|> PutAccountFeatureConfig - :<|> DeleteAccountFeatureConfig - :<|> GetAllConnectionsUnqualified - :<|> GetAllConnections - ) + :> (EJPD_API :<|> AccountAPI) type SwaggerDocsAPI = "api" :> "internal" :> SwaggerSchemaUI "swagger-ui" "swagger.json" diff --git a/libs/wire-api/src/Wire/API/Routes/Named.hs b/libs/wire-api/src/Wire/API/Routes/Named.hs index 9688ef75f1..4e132b7f76 100644 --- a/libs/wire-api/src/Wire/API/Routes/Named.hs +++ b/libs/wire-api/src/Wire/API/Routes/Named.hs @@ -22,6 +22,7 @@ import Data.Proxy import GHC.TypeLits import Imports import Servant +import Servant.Client import Servant.Swagger newtype Named named x = Named {unnamed :: x} @@ -40,6 +41,11 @@ instance HasServer api ctx => HasServer (Named name api) ctx where instance RoutesToPaths api => RoutesToPaths (Named name api) where getRoutes = getRoutes @api +instance HasClient m api => HasClient m (Named n api) where + type Client m (Named n api) = Client m api + clientWithRoute pm _ req = clientWithRoute pm (Proxy @api) req + hoistClientMonad pm _ f = hoistClientMonad pm (Proxy @api) f + type family FindName n (api :: *) :: (n, *) where FindName n (Named name api) = '(name, api) FindName n (x :> api) = AddPrefix x (FindName n api) diff --git a/libs/wire-api/src/Wire/API/User.hs b/libs/wire-api/src/Wire/API/User.hs index fbc86e820b..0d47f497b3 100644 --- a/libs/wire-api/src/Wire/API/User.hs +++ b/libs/wire-api/src/Wire/API/User.hs @@ -40,6 +40,7 @@ module Wire.API.User RegisterError (..), RegisterSuccess (..), RegisterResponses, + RegisterInternalResponses, NewUser (..), emptyNewUser, ExpiresIn, @@ -592,6 +593,22 @@ instance (res ~ RegisterResponses) => AsUnion res (Either RegisterError Register toUnion = eitherToUnion (toUnion @RegisterErrorResponses) (Z . I) fromUnion = eitherFromUnion (fromUnion @RegisterErrorResponses) (unI . unZ) +type RegisterInternalResponses = + RegisterErrorResponses + .++ '[ WithHeaders + '[DescHeader "Location" "UserId" UserId] + SelfProfile + (Respond 201 "User created and pending activation" SelfProfile) + ] + +instance AsHeaders '[UserId] SelfProfile SelfProfile where + fromHeaders (_ :* Nil, sp) = sp + toHeaders sp = (I (userId (selfUser sp)) :* Nil, sp) + +instance (res ~ RegisterInternalResponses) => AsUnion res (Either RegisterError SelfProfile) where + toUnion = eitherToUnion (toUnion @RegisterErrorResponses) (Z . I) + fromUnion = eitherFromUnion (fromUnion @RegisterErrorResponses) (unI . unZ) + data NewUser = NewUser { newUserDisplayName :: Name, -- | use this as 'UserId' (if 'Nothing', call 'Data.UUID.nextRandom'). diff --git a/services/brig/src/Brig/API/Internal.hs b/services/brig/src/Brig/API/Internal.hs index 7e21804bf7..62d3ba2df1 100644 --- a/services/brig/src/Brig/API/Internal.hs +++ b/services/brig/src/Brig/API/Internal.hs @@ -32,6 +32,7 @@ import Brig.API.Types import qualified Brig.API.User as API import Brig.API.Util (validateHandle) import Brig.App +import Brig.Data.Activation import qualified Brig.Data.Client as Data import qualified Brig.Data.Connection as Data import qualified Brig.Data.User as Data @@ -73,6 +74,7 @@ import qualified System.Logger.Class as Log import Wire.API.ErrorDescription import qualified Wire.API.Routes.Internal.Brig as BrigIRoutes import Wire.API.Routes.Internal.Brig.Connection +import Wire.API.Routes.Named import qualified Wire.API.Team.Feature as ApiFt import Wire.API.User import Wire.API.User.Client (UserClientsFull (..)) @@ -82,7 +84,10 @@ import Wire.API.User.RichInfo -- Sitemap (servant) servantSitemap :: ServerT BrigIRoutes.API (Handler r) -servantSitemap = +servantSitemap = ejpdAPI :<|> accountAPI + +ejpdAPI :: ServerT BrigIRoutes.EJPD_API (Handler r) +ejpdAPI = Brig.User.EJPD.ejpdRequest :<|> getAccountFeatureConfig :<|> putAccountFeatureConfig @@ -90,6 +95,9 @@ servantSitemap = :<|> getConnectionsStatusUnqualified :<|> getConnectionsStatus +accountAPI :: ServerT BrigIRoutes.AccountAPI Handler +accountAPI = Named @"createUserNoVerify" createUserNoVerify + -- | Responds with 'Nothing' if field is NULL in existing user or user does not exist. getAccountFeatureConfig :: UserId -> (Handler r) ApiFt.TeamFeatureStatusNoConfig getAccountFeatureConfig uid = @@ -115,13 +123,6 @@ sitemap = do get "/i/status" (continue $ const $ return empty) true head "/i/status" (continue $ const $ return empty) true - -- This endpoint can lead to the following events being sent: - -- - UserActivated event to created user, if it is a team invitation or user has an SSO ID - -- - UserIdentityUpdated event to created user, if email or phone get activated - post "/i/users" (continue createUserNoVerifyH) $ - accept "application" "json" - .&. jsonRequest @NewUser - -- internal email activation (used in tests and in spar for validating emails obtained as -- SAML user identifiers). if the validate query parameter is false or missing, only set -- the activation timeout, but do not send an email, and do not do anything about activating @@ -316,18 +317,9 @@ internalListFullClients :: UserSet -> (AppIO r) UserClientsFull internalListFullClients (UserSet usrs) = UserClientsFull <$> Data.lookupClientsBulk (Set.toList usrs) -createUserNoVerifyH :: JSON ::: JsonRequest NewUser -> (Handler r) Response -createUserNoVerifyH (_ ::: req) = do - CreateUserNoVerifyResponse uid prof <- createUserNoVerify =<< parseJsonBody req - return . setStatus status201 - . addHeader "Location" (toByteString' uid) - $ json prof - -data CreateUserNoVerifyResponse = CreateUserNoVerifyResponse UserId SelfProfile - -createUserNoVerify :: NewUser -> (Handler r) CreateUserNoVerifyResponse -createUserNoVerify uData = do - result <- API.createUser uData !>> newUserError +createUserNoVerify :: NewUser -> (Handler r) (Either RegisterError SelfProfile) +createUserNoVerify uData = lift . runExceptT $ do + result <- API.createUser uData let acc = createdAccount result let usr = accountUser acc let uid = userId usr @@ -336,8 +328,8 @@ createUserNoVerify uData = do for_ (catMaybes [eac, pac]) $ \adata -> let key = ActivateKey $ activationKey adata code = activationCode adata - in API.activate key code (Just uid) !>> actError - return $ CreateUserNoVerifyResponse uid (SelfProfile usr) + in API.activate key code (Just uid) !>> activationErrorToRegisterError + pure (SelfProfile usr) deleteUserNoVerifyH :: UserId -> (Handler r) Response deleteUserNoVerifyH uid = do diff --git a/services/brig/src/Brig/API/Public.hs b/services/brig/src/Brig/API/Public.hs index 649ee03405..62621dc5ba 100644 --- a/services/brig/src/Brig/API/Public.hs +++ b/services/brig/src/Brig/API/Public.hs @@ -681,11 +681,11 @@ getClientPrekeys usr clt = lift (API.lookupPrekeyIds usr clt) -- | docs/reference/user/registration.md {#RefRegistration} createUser :: Public.NewUserPublic -> (Handler r) (Either Public.RegisterError Public.RegisterSuccess) -createUser (Public.NewUserPublic new) = runExceptT $ do - API.checkRestrictedUserCreation new -- !>> newUserError +createUser (Public.NewUserPublic new) = lift . runExceptT $ do + API.checkRestrictedUserCreation new for_ (Public.newUserEmail new) $ checkWhitelistWithError RegisterErrorWhitelistError . Left for_ (Public.newUserPhone new) $ checkWhitelistWithError RegisterErrorWhitelistError . Right - result <- API.createUser new !>> newUserError + result <- API.createUser new let acc = createdAccount result let eac = createdEmailActivation result @@ -724,7 +724,7 @@ createUser (Public.NewUserPublic new) = runExceptT $ do UserAccount _ Ephemeral -> lift $ Auth.newCookie @ZAuth.User userId Public.SessionCookie newUserLabel UserAccount _ _ -> lift $ Auth.newCookie @ZAuth.User userId Public.PersistentCookie newUserLabel -- pure $ CreateUserResponse cok userId (Public.SelfProfile usr) - pure $ Right (Public.RegisterSuccess cok (Public.SelfProfile usr)) + pure $ Public.RegisterSuccess cok (Public.SelfProfile usr) where sendActivationEmail :: Public.Email -> Public.Name -> ActivationPair -> Maybe Public.Locale -> Maybe Public.NewTeamUser -> (AppIO r) () sendActivationEmail e u p l mTeamUser diff --git a/services/brig/src/Brig/API/User.hs b/services/brig/src/Brig/API/User.hs index 10101cd2a8..503d5c169e 100644 --- a/services/brig/src/Brig/API/User.hs +++ b/services/brig/src/Brig/API/User.hs @@ -88,13 +88,14 @@ module Brig.API.User ) where +import Brig.API.Error (errorDescriptionTypeToWai) import qualified Brig.API.Error as Error import qualified Brig.API.Handler as API (Handler) import Brig.API.Types import Brig.API.Util import Brig.App import qualified Brig.Code as Code -import Brig.Data.Activation (ActivationEvent (..)) +import Brig.Data.Activation (ActivationEvent (..), activationErrorToRegisterError) import qualified Brig.Data.Activation as Data import qualified Brig.Data.Blacklist as Blacklist import qualified Brig.Data.Client as Data @@ -150,6 +151,7 @@ import Network.Wai.Utilities import qualified System.Logger.Class as Log import System.Logger.Message import UnliftIO.Async +import Wire.API.ErrorDescription import Wire.API.Federation.Error import Wire.API.Routes.Internal.Brig.Connection import Wire.API.Team.Member (legalHoldStatus) @@ -163,17 +165,34 @@ data AllowSCIMUpdates ------------------------------------------------------------------------------- -- Create User -verifyUniquenessAndCheckBlacklist :: UserKey -> ExceptT RegisterError (AppIO r) () +data IdentityError + = IdentityErrorBlacklistedEmail + | IdentityErrorBlacklistedPhone + | IdentityErrorUserKeyExists + +identityErrorToRegisterError :: IdentityError -> RegisterError +identityErrorToRegisterError = \case + IdentityErrorBlacklistedEmail -> RegisterErrorBlacklistedEmail + IdentityErrorBlacklistedPhone -> RegisterErrorBlacklistedPhone + IdentityErrorUserKeyExists -> RegisterErrorUserKeyExists + +identityErrorToBrigError :: IdentityError -> Error.Error +identityErrorToBrigError = \case + IdentityErrorBlacklistedEmail -> Error.StdError $ errorDescriptionTypeToWai @BlacklistedEmail + IdentityErrorBlacklistedPhone -> Error.StdError $ errorDescriptionTypeToWai @BlacklistedPhone + IdentityErrorUserKeyExists -> Error.StdError $ errorDescriptionTypeToWai @UserKeyExists + +verifyUniquenessAndCheckBlacklist :: UserKey -> ExceptT IdentityError (AppIO r) () verifyUniquenessAndCheckBlacklist uk = do checkKey Nothing uk blacklisted <- lift $ Blacklist.exists uk when blacklisted $ - throwE (foldKey (const RegisterErrorBlacklistedEmail) (const RegisterErrorBlacklistedPhone) uk) + throwE (foldKey (const IdentityErrorBlacklistedEmail) (const IdentityErrorBlacklistedPhone) uk) where checkKey u k = do av <- lift $ Data.keyAvailable k u unless av $ - throwE RegisterErrorUserKeyExists + throwE IdentityErrorUserKeyExists -- docs/reference/user/registration.md {#RefRegistration} createUser :: NewUser -> ExceptT RegisterError (AppIO r) CreateUserResult @@ -291,8 +310,8 @@ createUser new = do return =<< lift (validatePhone p) - for_ (catMaybes [userEmailKey <$> email, userPhoneKey <$> phone]) $ do - verifyUniquenessAndCheckBlacklist + for_ (catMaybes [userEmailKey <$> email, userPhoneKey <$> phone]) $ \k -> + verifyUniquenessAndCheckBlacklist k !>> identityErrorToRegisterError pure (email, phone) @@ -320,7 +339,7 @@ createUser new = do -- Remove after the next release. canAdd <- lift $ Intra.checkUserCanJoinTeam tid case canAdd of - Just e -> undefined -- TODO: How do we do this: throwE (ExternalPreconditionFailed e) + Just _ -> undefined -- TODO: How do we do this: throwE (ExternalPreconditionFailed e) Nothing -> pure () acceptTeamInvitation :: @@ -382,18 +401,13 @@ createUser new = do ak <- liftIO $ Data.mkActivationKey ek void $ activateWithCurrency (ActivateKey ak) c (Just uid) (bnuCurrency =<< newTeam) - !>> ( \case - UserKeyExists _ -> RegisterErrorUserKeyExists - InvalidActivationCode txt -> _ - InvalidActivationEmail em s -> _ - InvalidActivationPhone ph -> _ - ) + !>> activationErrorToRegisterError return Nothing -- Handle phone activation (deprecated, see #RefRegistrationNoPreverification in /docs/reference/user/registration.md) - handlePhoneActivation :: Maybe Phone -> UserId -> ExceptT CreateUserError (AppT r IO) (Maybe Activation) + handlePhoneActivation :: Maybe Phone -> UserId -> ExceptT RegisterError (AppT r IO) (Maybe Activation) handlePhoneActivation phone uid = do - pdata <- fmap join . for (userPhoneKey <$> phone) $ \pk -> case newUserPhoneCode new of + fmap join . for (userPhoneKey <$> phone) $ \pk -> case newUserPhoneCode new of Nothing -> do timeout <- setActivationTimeout <$> view settings pdata <- lift $ Data.newActivation pk timeout (Just uid) @@ -404,9 +418,8 @@ createUser new = do return $ Just pdata Just c -> do ak <- liftIO $ Data.mkActivationKey pk - void $ activate (ActivateKey ak) c (Just uid) !>> PhoneActivationError + void $ activate (ActivateKey ak) c (Just uid) !>> activationErrorToRegisterError return Nothing - pure pdata initAccountFeatureConfig :: UserId -> (AppIO r) () initAccountFeatureConfig uid = do @@ -417,10 +430,10 @@ initAccountFeatureConfig uid = do -- all over the place there, we add a new function that handles just the one new flow where -- users are invited to the team via scim. createUserInviteViaScim :: UserId -> NewUserScimInvitation -> ExceptT Error.Error (AppIO r) UserAccount -createUserInviteViaScim uid (NewUserScimInvitation tid loc name rawEmail) = (`catchE` (throwE . Error.newUserError)) $ do - email <- either (throwE . InvalidEmail rawEmail) pure (validateEmail rawEmail) +createUserInviteViaScim uid (NewUserScimInvitation tid loc name rawEmail) = do + email <- either (const . throwE . Error.StdError $ errorDescriptionTypeToWai @InvalidEmail) pure (validateEmail rawEmail) let emKey = userEmailKey email - verifyUniquenessAndCheckBlacklist emKey + verifyUniquenessAndCheckBlacklist emKey !>> identityErrorToBrigError account <- lift $ newAccountInviteViaScim uid tid loc name email Log.debug $ field "user" (toByteString . userId . accountUser $ account) . field "action" (Log.val "User.createUserInviteViaScim") diff --git a/services/brig/src/Brig/Data/Activation.hs b/services/brig/src/Brig/Data/Activation.hs index d4a63a78b4..41c99b08b0 100644 --- a/services/brig/src/Brig/Data/Activation.hs +++ b/services/brig/src/Brig/Data/Activation.hs @@ -22,6 +22,7 @@ module Brig.Data.Activation ActivationCode (..), ActivationEvent (..), ActivationError (..), + activationErrorToRegisterError, newActivation, mkActivationKey, lookupActivationCode, @@ -48,6 +49,7 @@ import Imports import OpenSSL.BN (randIntegerZeroToNMinusOne) import OpenSSL.EVP.Digest (digestBS, getDigestByName) import Text.Printf (printf) +import Wire.API.User -- | The information associated with the pending activation of a 'UserKey'. data Activation = Activation @@ -65,6 +67,14 @@ data ActivationError | InvalidActivationEmail !Email !String | InvalidActivationPhone !Phone +activationErrorToRegisterError :: ActivationError -> RegisterError +activationErrorToRegisterError = \case + UserKeyExists _ -> RegisterErrorUserKeyExists + InvalidActivationCodeWrongUser -> RegisterErrorInvalidActivationCodeWrongUser + InvalidActivationCodeWrongCode -> RegisterErrorInvalidActivationCodeWrongCode + InvalidActivationEmail _ _ -> RegisterErrorInvalidEmail + InvalidActivationPhone _ -> RegisterErrorInvalidPhone + data ActivationEvent = AccountActivated !UserAccount | EmailActivated !UserId !Email diff --git a/services/galley/src/Galley/Intra/User.hs b/services/galley/src/Galley/Intra/User.hs index ad4482370f..efc2597b3d 100644 --- a/services/galley/src/Galley/Intra/User.hs +++ b/services/galley/src/Galley/Intra/User.hs @@ -234,9 +234,10 @@ getAccountFeatureConfigClient uid = getAccountFeatureConfigClientM :: UserId -> Client.ClientM TeamFeatureStatusNoConfig -( _ - :<|> getAccountFeatureConfigClientM - :<|> _ +( ( _ + :<|> getAccountFeatureConfigClientM + :<|> _ + ) :<|> _ ) = Client.client (Proxy @IAPI.API) From ed8ba10621436f9dd431509b25d85a34daa84ed4 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Wed, 16 Feb 2022 15:39:58 +0100 Subject: [PATCH 08/18] Broken test for user not being allowed to join a team --- .../brig/test/integration/API/User/Account.hs | 64 ++++++++++++++----- 1 file changed, 47 insertions(+), 17 deletions(-) diff --git a/services/brig/test/integration/API/User/Account.hs b/services/brig/test/integration/API/User/Account.hs index 808f075999..5483a76403 100644 --- a/services/brig/test/integration/API/User/Account.hs +++ b/services/brig/test/integration/API/User/Account.hs @@ -1,20 +1,4 @@ {-# LANGUAGE NumericUnderscores #-} --- This file is part of the Wire Server implementation. --- --- Copyright (C) 2020 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 . {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -- This file is part of the Wire Server implementation. @@ -73,6 +57,7 @@ import Data.Range (Range (fromRange)) import qualified Data.Set as Set import Data.String.Conversions (cs) import qualified Data.Text as T +import qualified Data.Text as Text import qualified Data.Text.Encoding as T import Data.Time (UTCTime, getCurrentTime) import Data.Time.Clock (diffUTCTime) @@ -84,21 +69,24 @@ import Federator.MockServer (FederatedRequest (..), MockException (..)) import Galley.Types.Teams (noPermissions) import Gundeck.Types.Notification import Imports hiding (head) +import qualified Network.HTTP.Types as HTTP import qualified Network.HTTP.Types as Http import qualified Network.Wai as Wai import qualified Network.Wai.Utilities.Error as Error +import qualified Network.Wai.Utilities.Error as Wai import Test.Tasty hiding (Timeout) import Test.Tasty.Cannon hiding (Cannon) import qualified Test.Tasty.Cannon as WS import Test.Tasty.HUnit import UnliftIO (mapConcurrently_) -import Util as Util +import Util import Util.AWS as Util import Web.Cookie (parseSetCookie) import qualified Wire.API.Asset as Asset import Wire.API.Federation.API.Brig (UserDeletedConnectionsNotification (..)) import qualified Wire.API.Federation.API.Brig as FedBrig import Wire.API.Federation.API.Common (EmptyResponse (EmptyResponse)) +import Wire.API.Team.Invitation (Invitation (inInvitation)) import Wire.API.User (ListUsersQuery (..)) import Wire.API.User.Identity (mkSampleUref, mkSimpleSampleUref) @@ -121,6 +109,7 @@ tests _ at opts p b c ch g aws = test' aws p "post /register - 403 blacklist" $ testCreateUserBlacklist opts b aws, test' aws p "post /register - 400 external-SSO" $ testCreateUserExternalSSO b, test' aws p "post /register - 403 restricted user creation" $ testRestrictedUserCreation opts b, + test' aws p "post /register - 403 too many members for legalhold" $ testTooManyMembersForLegalhold opts b, test' aws p "post /activate - 200/204 + expiry" $ testActivateWithExpiry opts b at, test' aws p "get /users/:uid - 404" $ testNonExistingUserUnqualified b, test' aws p "get /users//:uid - 404" $ testNonExistingUser b, @@ -1586,6 +1575,47 @@ testRestrictedUserCreation opts brig = do ] postUserRegister' ssoUser brig !!! const 400 === statusCode +-- | FUTUREWORK: @setRestrictUserCreation@ perhaps needs to be tested in one place only, since it's the +-- first thing that we check on the /register endpoint. Other tests that make use of @setRestrictUserCreation@ +-- can probably be removed and simplified. It's probably a good candidate for Quickcheck. +testTooManyMembersForLegalhold :: Opt.Opts -> Brig -> Http () +testTooManyMembersForLegalhold opts brig = do + (owner, tid) <- createUserWithTeam brig + + -- Invite a user with mocked galley which tells us that the user cannot be + -- added. We cannot use real galley here as the real galley has legalhold set + -- to "whitelist-teams-and-implicit-consent". In this mode this error is not + -- thrown, so in order to emulate other modes, we just emulate what galley + -- would return in that case. + inviteeEmail <- randomEmail + let invite = stdInvitationRequest inviteeEmail + inv <- + responseJsonError =<< postInvitation brig tid owner invite + Cannon -> User -> [UserId] -> AWS.Env -> (UserId -> HttpT IO ()) -> Http () From 91cc4c7782eea50262872ee602d0a40b3922e615 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Wed, 16 Feb 2022 15:40:17 +0100 Subject: [PATCH 09/18] Throw error in IO and catch it in handler to respond correctly This error cannot be easily encoding in the servant type as it is "dynamic" from the perspective of brig. Once we servantify galley's internal API, we can know about this error statically. This way we can catch it and throw it as a `RegisterError` and it will show up in brigs a `RegisterError` and it will show up in brig's swagger. --- services/brig/src/Brig/API/Handler.hs | 10 +++++++++- services/brig/src/Brig/API/User.hs | 4 ++-- 2 files changed, 11 insertions(+), 3 deletions(-) diff --git a/services/brig/src/Brig/API/Handler.hs b/services/brig/src/Brig/API/Handler.hs index 47ad3e621c..14ba258437 100644 --- a/services/brig/src/Brig/API/Handler.hs +++ b/services/brig/src/Brig/API/Handler.hs @@ -27,6 +27,7 @@ module Brig.API.Handler checkWhitelist, checkWhitelistWithError, isWhiteListed, + UserNotAllowedToJoinTeam (..), ) where @@ -99,6 +100,11 @@ toServantHandler env action = do Servant.throwError $ Servant.ServerError (mkCode werr) (mkPhrase (WaiError.code werr)) (Aeson.encode body) headers +newtype UserNotAllowedToJoinTeam = UserNotAllowedToJoinTeam WaiError.Error + deriving (Show) + +instance Exception UserNotAllowedToJoinTeam + brigErrorHandlers :: [Catch.Handler IO (Either Error a)] brigErrorHandlers = [ Catch.Handler $ \(ex :: PhoneException) -> @@ -108,7 +114,9 @@ brigErrorHandlers = Catch.Handler $ \(ex :: AWS.Error) -> case ex of AWS.SESInvalidDomain -> pure (Left (StdError invalidEmail)) - _ -> throwM ex + _ -> throwM ex, + Catch.Handler $ \(UserNotAllowedToJoinTeam e) -> + pure (Left $ StdError e) ] onError :: Logger -> Request -> Continue IO -> Error -> IO ResponseReceived diff --git a/services/brig/src/Brig/API/User.hs b/services/brig/src/Brig/API/User.hs index 503d5c169e..1598be9006 100644 --- a/services/brig/src/Brig/API/User.hs +++ b/services/brig/src/Brig/API/User.hs @@ -90,7 +90,7 @@ where import Brig.API.Error (errorDescriptionTypeToWai) import qualified Brig.API.Error as Error -import qualified Brig.API.Handler as API (Handler) +import qualified Brig.API.Handler as API (Handler, UserNotAllowedToJoinTeam (..)) import Brig.API.Types import Brig.API.Util import Brig.App @@ -339,7 +339,7 @@ createUser new = do -- Remove after the next release. canAdd <- lift $ Intra.checkUserCanJoinTeam tid case canAdd of - Just _ -> undefined -- TODO: How do we do this: throwE (ExternalPreconditionFailed e) + Just e -> throwM $ API.UserNotAllowedToJoinTeam e Nothing -> pure () acceptTeamInvitation :: From 68f35d45583071cf10b25746dff71807c3d678c3 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Wed, 16 Feb 2022 15:52:05 +0100 Subject: [PATCH 10/18] Add futurework to cleanup throwing in IO and better swagger --- services/galley/src/Galley/API/Teams.hs | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/services/galley/src/Galley/API/Teams.hs b/services/galley/src/Galley/API/Teams.hs index bac8563893..00a6947684 100644 --- a/services/galley/src/Galley/API/Teams.hs +++ b/services/galley/src/Galley/API/Teams.hs @@ -1429,6 +1429,18 @@ canUserJoinTeamH :: canUserJoinTeamH tid = canUserJoinTeam tid >> pure empty -- This could be extended for more checks, for now we test only legalhold +-- +-- Brig's `POST /register` endpoint throws the errors returned by this endpoint +-- verbatim. +-- +-- FUTUREWORK: When this enpoint gets Servantified, it should have a more +-- precise list of errors, LegalHoldError is too wide, currently this can +-- actaully only error with TooManyTeamMembersOnTeamWithLegalhold. Once we have +-- a more precise list of errors and the endpoint is servantified, we can use +-- those to enrich 'Wire.API.User.RegisterError' and ensure that these errors +-- also show up in swagger. Currently, the error returned by this endpoint is +-- thrown in IO, we could then refactor that to be thrown in `ExceptT +-- RegisterError`. canUserJoinTeam :: Members '[ BrigAccess, From dd1dd990885abc991f2e435a0f3fadc285961221 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Wed, 16 Feb 2022 15:54:14 +0100 Subject: [PATCH 11/18] Changelog --- changelog.d/5-internal/servantify-register | 1 + 1 file changed, 1 insertion(+) create mode 100644 changelog.d/5-internal/servantify-register diff --git a/changelog.d/5-internal/servantify-register b/changelog.d/5-internal/servantify-register new file mode 100644 index 0000000000..f2c8d856df --- /dev/null +++ b/changelog.d/5-internal/servantify-register @@ -0,0 +1 @@ +Servantify `POST /register` and `POST /i/users` endpoints \ No newline at end of file From b4df4e8e58b2b0416731ddda48f9e9501551d732 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Wed, 16 Feb 2022 16:19:37 +0100 Subject: [PATCH 12/18] Deduplicate errors --- .../wire-api/src/Wire/API/ErrorDescription.hs | 1 + services/brig/src/Brig/API/Error.hs | 37 ++----------------- services/brig/src/Brig/API/Handler.hs | 3 +- services/brig/src/Brig/API/Public.hs | 2 +- services/brig/src/Brig/Provider/API.hs | 6 +-- services/brig/src/Brig/Team/API.hs | 10 ++--- services/brig/src/Brig/User/API/Auth.hs | 2 +- 7 files changed, 17 insertions(+), 44 deletions(-) diff --git a/libs/wire-api/src/Wire/API/ErrorDescription.hs b/libs/wire-api/src/Wire/API/ErrorDescription.hs index 8b2ca722c0..73301bda8e 100644 --- a/libs/wire-api/src/Wire/API/ErrorDescription.hs +++ b/libs/wire-api/src/Wire/API/ErrorDescription.hs @@ -411,4 +411,5 @@ type InvalidActivationCodeWrongCode = InvalidActivationCode "Invalid activation type TooManyTeamMembers = ErrorDescription 403 "too-many-team-members" "Too many members in this team." +-- | docs/reference/user/registration.md {#RefRestrictRegistration}. type UserCreationRestricted = ErrorDescription 403 "user-creation-restricted" "This instance does not allow creation of personal users or teams." diff --git a/services/brig/src/Brig/API/Error.hs b/services/brig/src/Brig/API/Error.hs index b2f31b2a26..f1f4ef9773 100644 --- a/services/brig/src/Brig/API/Error.hs +++ b/services/brig/src/Brig/API/Error.hs @@ -112,7 +112,7 @@ connError NotConnected {} = StdError (errorDescriptionTypeToWai @NotConnected) connError InvalidUser {} = StdError (errorDescriptionTypeToWai @InvalidUser) connError ConnectNoIdentity {} = StdError (errorDescriptionToWai (noIdentity 0)) connError (ConnectBlacklistedUserKey k) = StdError $ foldKey (const blacklistedEmail) (const (errorDescriptionTypeToWai @BlacklistedPhone)) k -connError (ConnectInvalidEmail _ _) = StdError invalidEmail +connError (ConnectInvalidEmail _ _) = StdError (errorDescriptionTypeToWai @InvalidEmail) connError ConnectInvalidPhone {} = StdError (errorDescriptionTypeToWai @InvalidPhone) connError ConnectSameBindingTeamUsers = StdError sameBindingTeamUsers connError ConnectMissingLegalholdConsent = StdError (errorDescriptionTypeToWai @MissingLegalholdConsent) @@ -122,7 +122,7 @@ actError :: ActivationError -> Error actError (UserKeyExists _) = StdError (errorDescriptionTypeToWai @UserKeyExists) actError InvalidActivationCodeWrongUser = StdError (errorDescriptionTypeToWai @InvalidActivationCodeWrongUser) actError InvalidActivationCodeWrongCode = StdError (errorDescriptionTypeToWai @InvalidActivationCodeWrongCode) -actError (InvalidActivationEmail _ _) = StdError invalidEmail +actError (InvalidActivationEmail _ _) = StdError (errorDescriptionTypeToWai @InvalidEmail) actError (InvalidActivationPhone _) = StdError (errorDescriptionTypeToWai @InvalidPhone) pwResetError :: PasswordResetError -> Error @@ -136,30 +136,17 @@ pwResetError (PasswordResetInProgress (Just t)) = [("Retry-After", toByteString' t)] pwResetError ResetPasswordMustDiffer = StdError resetPasswordMustDiffer -newUserError :: CreateUserError -> Error -newUserError InvalidInvitationCode = StdError invalidInvitationCode -newUserError MissingIdentity = StdError missingIdentity -newUserError (InvalidEmail _ _) = StdError invalidEmail -newUserError (InvalidPhone _) = StdError (errorDescriptionTypeToWai @InvalidPhone) -newUserError (DuplicateUserKey _) = StdError (errorDescriptionTypeToWai @UserKeyExists) -newUserError (EmailActivationError e) = actError e -newUserError (PhoneActivationError e) = actError e -newUserError (BlacklistedUserKey k) = StdError $ foldKey (const blacklistedEmail) (const (errorDescriptionTypeToWai @BlacklistedPhone)) k -newUserError TooManyTeamMembers = StdError tooManyTeamMembers -newUserError UserCreationRestricted = StdError userCreationRestricted -newUserError (ExternalPreconditionFailed e) = StdError e - sendLoginCodeError :: SendLoginCodeError -> Error sendLoginCodeError (SendLoginInvalidPhone _) = StdError (errorDescriptionTypeToWai @InvalidPhone) sendLoginCodeError SendLoginPasswordExists = StdError passwordExists sendActCodeError :: SendActivationCodeError -> Error -sendActCodeError (InvalidRecipient k) = StdError $ foldKey (const invalidEmail) (const (errorDescriptionTypeToWai @InvalidPhone)) k +sendActCodeError (InvalidRecipient k) = StdError $ foldKey (const (errorDescriptionTypeToWai @InvalidEmail)) (const (errorDescriptionTypeToWai @InvalidPhone)) k sendActCodeError (UserKeyInUse _) = StdError (errorDescriptionTypeToWai @UserKeyExists) sendActCodeError (ActivationBlacklistedUserKey k) = StdError $ foldKey (const blacklistedEmail) (const (errorDescriptionTypeToWai @BlacklistedPhone)) k changeEmailError :: ChangeEmailError -> Error -changeEmailError (InvalidNewEmail _ _) = StdError invalidEmail +changeEmailError (InvalidNewEmail _ _) = StdError (errorDescriptionTypeToWai @InvalidEmail) changeEmailError (EmailExists _) = StdError (errorDescriptionTypeToWai @UserKeyExists) changeEmailError (ChangeBlacklistedEmail _) = StdError blacklistedEmail changeEmailError EmailManagedByScim = StdError $ propertyManagedByScim "email" @@ -268,21 +255,12 @@ clientCapabilitiesCannotBeRemoved = Wai.mkError status409 "client-capabilities-c noEmail :: Wai.Error noEmail = Wai.mkError status403 "no-email" "This operation requires the user to have a verified email address." -invalidEmail :: Wai.Error -invalidEmail = Wai.mkError status400 "invalid-email" "Invalid e-mail address." - invalidPwResetKey :: Wai.Error invalidPwResetKey = Wai.mkError status400 "invalid-key" "Invalid email or mobile number for password reset." resetPasswordMustDiffer :: Wai.Error resetPasswordMustDiffer = Wai.mkError status409 "password-must-differ" "For password reset, new and old password must be different." -invalidInvitationCode :: Wai.Error -invalidInvitationCode = Wai.mkError status400 "invalid-invitation-code" "Invalid invitation code." - -missingIdentity :: Wai.Error -missingIdentity = Wai.mkError status403 "missing-identity" "Using an invitation code requires registering the given email and/or phone." - invalidPwResetCode :: Wai.Error invalidPwResetCode = Wai.mkError status400 "invalid-code" "Invalid password reset code." @@ -415,13 +393,6 @@ sameBindingTeamUsers = Wai.mkError status403 "same-binding-team-users" "Operatio tooManyTeamInvitations :: Wai.Error tooManyTeamInvitations = Wai.mkError status403 "too-many-team-invitations" "Too many team invitations for this team." -tooManyTeamMembers :: Wai.Error -tooManyTeamMembers = Wai.mkError status403 "too-many-team-members" "Too many members in this team." - --- | docs/reference/user/registration.md {#RefRestrictRegistration}. -userCreationRestricted :: Wai.Error -userCreationRestricted = Wai.mkError status403 "user-creation-restricted" "This instance does not allow creation of personal users or teams." - -- | In contrast to 'tooManyFailedLogins', this is about too many *successful* logins. loginsTooFrequent :: Wai.Error loginsTooFrequent = Wai.mkError status429 "client-error" "Logins too frequent" diff --git a/services/brig/src/Brig/API/Handler.hs b/services/brig/src/Brig/API/Handler.hs index 14ba258437..9cbfec7a6a 100644 --- a/services/brig/src/Brig/API/Handler.hs +++ b/services/brig/src/Brig/API/Handler.hs @@ -64,6 +64,7 @@ import Network.Wai.Utilities.Response (addHeader, json, setStatus) import qualified Network.Wai.Utilities.Server as Server import qualified Servant import System.Logger.Class (Logger) +import Wire.API.ErrorDescription (InvalidEmail) ------------------------------------------------------------------------------- -- HTTP Handler Monad @@ -113,7 +114,7 @@ brigErrorHandlers = pure (Left (zauthError ex)), Catch.Handler $ \(ex :: AWS.Error) -> case ex of - AWS.SESInvalidDomain -> pure (Left (StdError invalidEmail)) + AWS.SESInvalidDomain -> pure (Left (StdError (errorDescriptionTypeToWai @InvalidEmail))) _ -> throwM ex, Catch.Handler $ \(UserNotAllowedToJoinTeam e) -> pure (Left $ StdError e) diff --git a/services/brig/src/Brig/API/Public.hs b/services/brig/src/Brig/API/Public.hs index 62621dc5ba..56ce7428c6 100644 --- a/services/brig/src/Brig/API/Public.hs +++ b/services/brig/src/Brig/API/Public.hs @@ -444,7 +444,7 @@ sitemap = do Doc.body (Doc.ref Public.modelSendActivationCode) $ Doc.description "JSON body" Doc.response 200 "Activation code sent." Doc.end - Doc.errorResponse invalidEmail + Doc.errorResponse (errorDescriptionTypeToWai @InvalidEmail) Doc.errorResponse (errorDescriptionTypeToWai @InvalidPhone) Doc.errorResponse (errorDescriptionTypeToWai @UserKeyExists) Doc.errorResponse blacklistedEmail diff --git a/services/brig/src/Brig/Provider/API.hs b/services/brig/src/Brig/Provider/API.hs index 8c50699662..f6028eafba 100644 --- a/services/brig/src/Brig/Provider/API.hs +++ b/services/brig/src/Brig/Provider/API.hs @@ -324,7 +324,7 @@ newAccount :: Public.NewProvider -> (Handler r) Public.NewProviderResponse newAccount new = do email <- case validateEmail (Public.newProviderEmail new) of Right em -> return em - Left _ -> throwStd invalidEmail + Left _ -> throwStd (errorDescriptionTypeToWai @InvalidEmail) let name = Public.newProviderName new let pass = Public.newProviderPassword new let descr = fromRange (Public.newProviderDescr new) @@ -386,7 +386,7 @@ getActivationCode :: Public.Email -> (Handler r) FoundActivationCode getActivationCode e = do email <- case validateEmail e of Right em -> return em - Left _ -> throwStd invalidEmail + Left _ -> throwStd (errorDescriptionTypeToWai @InvalidEmail) gen <- Code.mkGen (Code.ForEmail email) code <- Code.lookup (Code.genKey gen) Code.IdentityVerification maybe (throwStd activationKeyNotFound) (return . FoundActivationCode) code @@ -496,7 +496,7 @@ updateAccountEmail :: ProviderId -> Public.EmailUpdate -> (Handler r) () updateAccountEmail pid (Public.EmailUpdate new) = do email <- case validateEmail new of Right em -> return em - Left _ -> throwStd invalidEmail + Left _ -> throwStd (errorDescriptionTypeToWai @InvalidEmail) let emailKey = mkEmailKey email DB.lookupKey emailKey >>= mapM_ (const $ throwStd emailExists) gen <- Code.mkGen (Code.ForEmail email) diff --git a/services/brig/src/Brig/Team/API.hs b/services/brig/src/Brig/Team/API.hs index 4ebdb9c2f9..5b18709bf0 100644 --- a/services/brig/src/Brig/Team/API.hs +++ b/services/brig/src/Brig/Team/API.hs @@ -90,7 +90,7 @@ routesPublic = do Doc.response 201 "Invitation was created and sent." Doc.end Doc.errorResponse noEmail Doc.errorResponse (errorDescriptionToWai (noIdentity 6)) - Doc.errorResponse invalidEmail + Doc.errorResponse (errorDescriptionTypeToWai @InvalidEmail) Doc.errorResponse blacklistedEmail Doc.errorResponse tooManyTeamInvitations @@ -149,7 +149,7 @@ routesPublic = do Doc.description "Invitation code" Doc.returns (Doc.ref Public.modelTeamInvitation) Doc.response 200 "Invitation successful." Doc.end - Doc.errorResponse invalidInvitationCode + Doc.errorResponse (errorDescriptionTypeToWai @InvalidInvitationCode) -- FUTUREWORK: Add another endpoint to allow resending of invitation codes head "/teams/invitations/by-email" (continue headInvitationByEmailH) $ @@ -228,7 +228,7 @@ getInvitationCodeH (_ ::: t ::: r) = do getInvitationCode :: TeamId -> InvitationId -> (Handler r) FoundInvitationCode getInvitationCode t r = do code <- lift $ DB.lookupInvitationCode t r - maybe (throwStd invalidInvitationCode) (return . FoundInvitationCode) code + maybe (throwStd $ errorDescriptionTypeToWai @InvalidInvitationCode) (return . FoundInvitationCode) code data FoundInvitationCode = FoundInvitationCode InvitationCode deriving (Eq, Show, Generic) @@ -321,7 +321,7 @@ createInvitation' tid inviteeRole mbInviterUid fromEmail body = do -- sendActivationCode. Refactor this to a single place -- Validate e-mail - inviteeEmail <- either (const $ throwStd invalidEmail) return (Email.validateEmail (irInviteeEmail body)) + inviteeEmail <- either (const $ throwStd (errorDescriptionTypeToWai @InvalidEmail)) return (Email.validateEmail (irInviteeEmail body)) let uke = userEmailKey inviteeEmail blacklistedEm <- lift $ Blacklist.exists uke when blacklistedEm $ @@ -404,7 +404,7 @@ getInvitationByCodeH (_ ::: c) = do getInvitationByCode :: Public.InvitationCode -> (Handler r) Public.Invitation getInvitationByCode c = do inv <- lift $ DB.lookupInvitationByCode c - maybe (throwStd invalidInvitationCode) return inv + maybe (throwStd $ errorDescriptionTypeToWai @InvalidInvitationCode) return inv headInvitationByEmailH :: JSON ::: Email -> (Handler r) Response headInvitationByEmailH (_ ::: e) = do diff --git a/services/brig/src/Brig/User/API/Auth.hs b/services/brig/src/Brig/User/API/Auth.hs index fdd67fd5fd..101c0e46e9 100644 --- a/services/brig/src/Brig/User/API/Auth.hs +++ b/services/brig/src/Brig/User/API/Auth.hs @@ -155,7 +155,7 @@ routesPublic = do Doc.description "JSON body" Doc.response 202 "Update accepted and pending activation of the new email." Doc.end Doc.response 204 "No update, current and new email address are the same." Doc.end - Doc.errorResponse invalidEmail + Doc.errorResponse (errorDescriptionTypeToWai @InvalidEmail) Doc.errorResponse (errorDescriptionTypeToWai @UserKeyExists) Doc.errorResponse blacklistedEmail Doc.errorResponse (errorDescriptionTypeToWai @BlacklistedPhone) From 6ec48bdb8bf6550ba3a2a5ce427aca2921f6d1f7 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Wed, 16 Feb 2022 16:19:51 +0100 Subject: [PATCH 13/18] Delete unused swagger --- libs/wire-api/src/Wire/API/Swagger.hs | 2 -- libs/wire-api/src/Wire/API/Team.hs | 12 ------- libs/wire-api/src/Wire/API/User.hs | 47 +-------------------------- services/brig/src/Brig/API/Public.hs | 29 +---------------- 4 files changed, 2 insertions(+), 88 deletions(-) diff --git a/libs/wire-api/src/Wire/API/Swagger.hs b/libs/wire-api/src/Wire/API/Swagger.hs index 4fbc4ed77c..89cfe1f3f4 100644 --- a/libs/wire-api/src/Wire/API/Swagger.hs +++ b/libs/wire-api/src/Wire/API/Swagger.hs @@ -113,7 +113,6 @@ models = Push.Token.modelPushTokenList, Team.modelTeam, Team.modelTeamList, - Team.modelNewBindingTeam, Team.modelNewNonBindingTeam, Team.modelUpdateData, Team.modelTeamDelete, @@ -141,7 +140,6 @@ models = Team.SearchVisibility.modelTeamSearchVisibility, User.modelUserIdList, User.modelUser, - User.modelNewUser, User.modelEmailUpdate, User.modelDelete, User.modelVerifyDelete, diff --git a/libs/wire-api/src/Wire/API/Team.hs b/libs/wire-api/src/Wire/API/Team.hs index ed773095b0..8fb331559c 100644 --- a/libs/wire-api/src/Wire/API/Team.hs +++ b/libs/wire-api/src/Wire/API/Team.hs @@ -63,7 +63,6 @@ module Wire.API.Team -- * Swagger modelTeam, modelTeamList, - modelNewBindingTeam, modelNewNonBindingTeam, modelUpdateData, modelTeamDelete, @@ -182,17 +181,6 @@ newtype BindingNewTeam = BindingNewTeam (NewTeam ()) deriving stock (Eq, Show, Generic) deriving (ToJSON, FromJSON, S.ToSchema) via (Schema BindingNewTeam) -modelNewBindingTeam :: Doc.Model -modelNewBindingTeam = Doc.defineModel "NewBindingTeam" $ do - Doc.description "Required data when creating new teams" - Doc.property "name" Doc.string' $ - Doc.description "team name" - Doc.property "icon" Doc.string' $ - Doc.description "team icon (asset ID)" - Doc.property "icon_key" Doc.string' $ do - Doc.description "team icon asset key" - Doc.optional - instance ToSchema BindingNewTeam where schema = object "BindingNewTeam" bindingNewTeamObjectSchema diff --git a/libs/wire-api/src/Wire/API/User.hs b/libs/wire-api/src/Wire/API/User.hs index 0d47f497b3..c9f33c3ab8 100644 --- a/libs/wire-api/src/Wire/API/User.hs +++ b/libs/wire-api/src/Wire/API/User.hs @@ -94,7 +94,6 @@ module Wire.API.User -- * Swagger modelDelete, modelEmailUpdate, - modelNewUser, modelUser, modelUserIdList, modelVerifyDelete, @@ -144,7 +143,7 @@ import Wire.API.Arbitrary (Arbitrary (arbitrary), GenericUniform (..)) import Wire.API.ErrorDescription import Wire.API.Provider.Service (ServiceRef, modelServiceRef) import Wire.API.Routes.MultiVerb -import Wire.API.Team (BindingNewTeam, bindingNewTeamObjectSchema, modelNewBindingTeam) +import Wire.API.Team (BindingNewTeam, bindingNewTeamObjectSchema) import Wire.API.User.Activation (ActivationCode) import Wire.API.User.Auth (CookieLabel) import Wire.API.User.Identity @@ -457,50 +456,6 @@ newtype NewUserPublic = NewUserPublic NewUser deriving stock (Eq, Show, Generic) deriving (ToJSON, FromJSON, S.ToSchema) via (Schema NewUserPublic) -modelNewUser :: Doc.Model -modelNewUser = Doc.defineModel "NewUser" $ do - Doc.description "New User Data" - Doc.property "name" Doc.string' $ - Doc.description "Name (1 - 128 characters)" - Doc.property "email" Doc.string' $ do - Doc.description "Email address" - Doc.optional - Doc.property "password" Doc.string' $ do - Doc.description "Password (6 - 1024 characters)" - Doc.optional - Doc.property "assets" (Doc.array (Doc.ref modelAsset)) $ do - Doc.description "Profile assets" - Doc.optional - Doc.property "phone" Doc.string' $ do - Doc.description "E.164 phone number" - Doc.optional - Doc.property "accent_id" Doc.int32' $ do - Doc.description "Accent colour ID" - Doc.optional - Doc.property "email_code" Doc.bytes' $ do - Doc.description "Email activation code" - Doc.optional - Doc.property "phone_code" Doc.bytes' $ do - Doc.description "Phone activation code" - Doc.optional - Doc.property "invitation_code" Doc.bytes' $ do - Doc.description "Invitation code. Mutually exclusive with team|team_code" - Doc.optional - Doc.property "locale" Doc.string' $ do - Doc.description "Locale in format." - Doc.optional - Doc.property "label" Doc.string' $ do - Doc.description - "An optional label to associate with the access cookie, \ - \if one is granted during account creation." - Doc.optional - Doc.property "team_code" Doc.string' $ do - Doc.description "Team invitation code. Mutually exclusive with team|invitation_code" - Doc.optional - Doc.property "team" (Doc.ref modelNewBindingTeam) $ do - Doc.description "New team information. Mutually exclusive with team_code|invitation_code" - Doc.optional - instance ToSchema NewUserPublic where schema = unwrap .= withParser schema (eitherToParser . validateNewUserPublic) diff --git a/services/brig/src/Brig/API/Public.hs b/services/brig/src/Brig/API/Public.hs index 56ce7428c6..4e5bf511f3 100644 --- a/services/brig/src/Brig/API/Public.hs +++ b/services/brig/src/Brig/API/Public.hs @@ -369,34 +369,7 @@ sitemap = do Doc.response 200 "Object with properties as attributes." Doc.end -- TODO: put delete here, too? - -- /register, /activate, /password-reset ---------------------------------- - - -- docs/reference/user/registration.md {#RefRegistration} - -- - -- This endpoint can lead to the following events being sent: - -- - UserActivated event to created user, if it is a team invitation or user has an SSO ID - -- - UserIdentityUpdated event to created user, if email code or phone code is provided - -- post "/register" (continue createUserH) $ - -- accept "application" "json" - -- .&. jsonRequest @Public.NewUserPublic - -- document "POST" "register" $ do - -- Doc.summary "Register a new user." - -- Doc.notes - -- "If the environment where the registration takes \ - -- \place is private and a registered email address or phone \ - -- \number is not whitelisted, a 403 error is returned." - -- Doc.body (Doc.ref Public.modelNewUser) $ - -- Doc.description "JSON body" - -- -- FUTUREWORK: I think this should be 'Doc.self' instead of 'user' - -- Doc.returns (Doc.ref Public.modelUser) - -- Doc.response 201 "User created and pending activation." Doc.end - -- Doc.errorResponse whitelistError - -- Doc.errorResponse invalidInvitationCode - -- Doc.errorResponse missingIdentity - -- Doc.errorResponse (errorDescriptionTypeToWai @UserKeyExists) - -- Doc.errorResponse activationCodeNotFound - -- Doc.errorResponse blacklistedEmail - -- Doc.errorResponse (errorDescriptionTypeToWai @BlacklistedPhone) + -- /activate, /password-reset ---------------------------------- -- This endpoint can lead to the following events being sent: -- - UserActivated event to the user, if account gets activated From c3b2ed3ab6fbb3ad2e74c62a11ccc79bc48a1fda Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Wed, 16 Feb 2022 21:24:39 +0100 Subject: [PATCH 14/18] make add-license --- .../Test/Wire/API/Golden/Generated/AccessRoleLegacy_user.hs | 1 + libs/wire-api/test/unit/Test/Wire/API/Conversation.hs | 2 +- services/galley/schema/src/V58_ConversationAccessRoleV2.hs | 2 +- services/galley/schema/src/V59_FileSharingLockStatus.hs | 2 +- 4 files changed, 4 insertions(+), 3 deletions(-) diff --git a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/AccessRoleLegacy_user.hs b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/AccessRoleLegacy_user.hs index ad1587d065..8331b06be8 100644 --- a/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/AccessRoleLegacy_user.hs +++ b/libs/wire-api/test/golden/Test/Wire/API/Golden/Generated/AccessRoleLegacy_user.hs @@ -14,6 +14,7 @@ -- -- You should have received a copy of the GNU Affero General Public License along -- with this program. If not, see . + module Test.Wire.API.Golden.Generated.AccessRoleLegacy_user where import Wire.API.Conversation (AccessRoleLegacy (..)) diff --git a/libs/wire-api/test/unit/Test/Wire/API/Conversation.hs b/libs/wire-api/test/unit/Test/Wire/API/Conversation.hs index 27d198a22f..f9df9a9af2 100644 --- a/libs/wire-api/test/unit/Test/Wire/API/Conversation.hs +++ b/libs/wire-api/test/unit/Test/Wire/API/Conversation.hs @@ -3,7 +3,7 @@ -- This file is part of the Wire Server implementation. -- --- Copyright (C) 2020 Wire Swiss GmbH +-- 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 diff --git a/services/galley/schema/src/V58_ConversationAccessRoleV2.hs b/services/galley/schema/src/V58_ConversationAccessRoleV2.hs index 0d1248f070..a477e9b152 100644 --- a/services/galley/schema/src/V58_ConversationAccessRoleV2.hs +++ b/services/galley/schema/src/V58_ConversationAccessRoleV2.hs @@ -1,6 +1,6 @@ -- This file is part of the Wire Server implementation. -- --- Copyright (C) 2020 Wire Swiss GmbH +-- 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 diff --git a/services/galley/schema/src/V59_FileSharingLockStatus.hs b/services/galley/schema/src/V59_FileSharingLockStatus.hs index 8195f186b3..d1b8392482 100644 --- a/services/galley/schema/src/V59_FileSharingLockStatus.hs +++ b/services/galley/schema/src/V59_FileSharingLockStatus.hs @@ -1,6 +1,6 @@ -- This file is part of the Wire Server implementation. -- --- Copyright (C) 2020 Wire Swiss GmbH +-- 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 From 76e2fb4ca4069a9c827f3bb5315fc193bf8ecf7f Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Thu, 24 Feb 2022 15:38:02 +0100 Subject: [PATCH 15/18] Remove redundant import --- libs/wire-api/src/Wire/API/User.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/libs/wire-api/src/Wire/API/User.hs b/libs/wire-api/src/Wire/API/User.hs index c9f33c3ab8..e5974fb554 100644 --- a/libs/wire-api/src/Wire/API/User.hs +++ b/libs/wire-api/src/Wire/API/User.hs @@ -109,7 +109,6 @@ import Control.Applicative import Control.Error.Safe (rightMay) import Control.Lens (over, (.~), (?~)) import Data.Aeson (FromJSON (..), ToJSON (..)) -import qualified Data.Aeson.KeyMap as KeyMap import qualified Data.Aeson.Types as A import Data.ByteString.Conversion import qualified Data.CaseInsensitive as CI From 7e7cf0664d29bfd6c9c043b348fdd1de6717706b Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Thu, 24 Feb 2022 16:42:25 +0100 Subject: [PATCH 16/18] Fix wrong merge --- services/brig/src/Brig/API/Public.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/services/brig/src/Brig/API/Public.hs b/services/brig/src/Brig/API/Public.hs index 4e5bf511f3..453adbb751 100644 --- a/services/brig/src/Brig/API/Public.hs +++ b/services/brig/src/Brig/API/Public.hs @@ -192,7 +192,6 @@ servantSitemap = userAPI :<|> selfAPI :<|> accountAPI :<|> clientAPI :<|> prekey accountAPI = Named @"register" createUser clientAPI :: ServerT ClientAPI (Handler r) - clientAPI :: ServerT ClientAPI Handler clientAPI = Named @"get-user-clients-unqualified" getUserClientsUnqualified :<|> Named @"get-user-clients-qualified" getUserClientsQualified From 17ff7866ca7d80113f1504b4ccd35ff15a93b05b Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Mon, 28 Feb 2022 09:29:02 +0100 Subject: [PATCH 17/18] Handler -> Handler r --- services/brig/src/Brig/API/Internal.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/services/brig/src/Brig/API/Internal.hs b/services/brig/src/Brig/API/Internal.hs index 62d3ba2df1..a2fc26916f 100644 --- a/services/brig/src/Brig/API/Internal.hs +++ b/services/brig/src/Brig/API/Internal.hs @@ -95,7 +95,7 @@ ejpdAPI = :<|> getConnectionsStatusUnqualified :<|> getConnectionsStatus -accountAPI :: ServerT BrigIRoutes.AccountAPI Handler +accountAPI :: ServerT BrigIRoutes.AccountAPI (Handler r) accountAPI = Named @"createUserNoVerify" createUserNoVerify -- | Responds with 'Nothing' if field is NULL in existing user or user does not exist. From cac1e96a9d13684ee3fa7995f6d57d1a1536fbe2 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Tue, 1 Mar 2022 12:01:37 +0100 Subject: [PATCH 18/18] Remove unhelpful helper eitherToParser --- libs/wire-api/src/Wire/API/User.hs | 5 ++--- libs/wire-api/src/Wire/API/Util/Aeson.hs | 6 ------ 2 files changed, 2 insertions(+), 9 deletions(-) diff --git a/libs/wire-api/src/Wire/API/User.hs b/libs/wire-api/src/Wire/API/User.hs index e5974fb554..148fd4a702 100644 --- a/libs/wire-api/src/Wire/API/User.hs +++ b/libs/wire-api/src/Wire/API/User.hs @@ -147,7 +147,6 @@ import Wire.API.User.Activation (ActivationCode) import Wire.API.User.Auth (CookieLabel) import Wire.API.User.Identity import Wire.API.User.Profile -import Wire.API.Util.Aeson (eitherToParser) -------------------------------------------------------------------------------- -- UserIdList @@ -457,7 +456,7 @@ newtype NewUserPublic = NewUserPublic NewUser instance ToSchema NewUserPublic where schema = - unwrap .= withParser schema (eitherToParser . validateNewUserPublic) + unwrap .= withParser schema (either fail pure . validateNewUserPublic) where unwrap (NewUserPublic nu) = nu @@ -685,7 +684,7 @@ newUserToRaw NewUser {..} = newUserFromRaw :: NewUserRaw -> A.Parser NewUser newUserFromRaw NewUserRaw {..} = do origin <- - eitherToParser $ + either fail pure $ maybeNewUserOriginFromComponents (isJust newUserRawPassword) (isJust newUserRawSSOId) diff --git a/libs/wire-api/src/Wire/API/Util/Aeson.hs b/libs/wire-api/src/Wire/API/Util/Aeson.hs index 6ea1515069..4b0f3ad2d7 100644 --- a/libs/wire-api/src/Wire/API/Util/Aeson.hs +++ b/libs/wire-api/src/Wire/API/Util/Aeson.hs @@ -18,12 +18,10 @@ module Wire.API.Util.Aeson ( customEncodingOptions, CustomEncoded (..), - eitherToParser, ) where import Data.Aeson -import Data.Aeson.Types (Parser) import qualified Data.Char as Char import GHC.Generics (Rep) import Imports hiding (All) @@ -45,7 +43,3 @@ instance (Generic a, GToJSON Zero (Rep a)) => ToJSON (CustomEncoded a) where instance (Generic a, GFromJSON Zero (Rep a)) => FromJSON (CustomEncoded a) where parseJSON = fmap CustomEncoded . genericParseJSON @a customEncodingOptions - -eitherToParser :: Either String a -> Parser a -eitherToParser (Left e) = fail e -eitherToParser (Right a) = pure a