wireapp · fisx · Sep 10, 2021 · Sep 9, 2021 · Sep 9, 2021 · Sep 3, 2021
@@ -0,0 +1,3 @@
+Various improvements and fixes around SAML/SCIM
+* the error message when attempting to saml-authenticate with a user that should have been provisioned by scim, but wasn't, was confusing.  we have a better one now, and the function has a clearer structure.
+* is bumping saml2-web-sso to the latest master, and *shouldn't* change any behavior: saml2-web-sso is providing `CI.CI`-wrapped values in a few places (mostly email and NameID), and we just unpack it using `CI.original`, which recovers all casing information.  in the future, we'll have the option to treat emails case-insensitively as we're supposed to.  (there is currently another, more hacky way in which we do this, see [here](https://github.com/wireapp/wire-server/blob/de673a6fbb2e1a9dc9cdb928cd9b7c4a291470dd/services/spar/src/Spar/Data.hs#L281-L296) and [the internal issue](https://wearezeta.atlassian.net/browse/SQSERVICES-776).)
@@ -25,3 +25,4 @@ cabal.project.local~
 *~
 *.el
 \#*
+.ghci
@@ -101,6 +101,7 @@ shouldEventuallyRespondWith action matcher =
 
 data AcceptanceConfig tag = AcceptanceConfig
   { scimAppAndConfig :: IO (Application, AcceptanceQueryConfig tag),
+    -- TODO: add a destructor, something like: @destroy :: CustomEnv tag -> IO ()@,
     genUserName :: IO Text,
     -- | some acceptance tests match against a fully rendered
     -- response body, which will not work when running the test

@@ -41,6 +41,7 @@ instance FromByteString (List a) => FromHttpApiData (CommaSeparatedList a) where
 instance ToParamSchema (CommaSeparatedList a) where
   toParamSchema _ = mempty & type_ ?~ SwaggerString
 
+-- | TODO: is this obsoleted by the instances in "Data.Range"?
 instance (ToParamSchema a, ToParamSchema (Range n m [a])) => ToParamSchema (Range n m (CommaSeparatedList a)) where
   toParamSchema _ =
     toParamSchema (Proxy @(Range n m [a]))

@@ -101,6 +101,7 @@ import Control.Lens (over, view, (.~), (?~))
 import Data.Aeson (FromJSON (..), ToJSON (..))
 import qualified Data.Aeson.Types as A
 import Data.ByteString.Conversion
+import qualified Data.CaseInsensitive as CI
 import qualified Data.Code as Code
 import qualified Data.Currency as Currency
 import Data.Domain (Domain (Domain))
@@ -413,7 +414,10 @@ userSCIMExternalId usr = userSSOId >=> ssoIdExtId $ usr
     ssoIdExtId :: UserSSOId -> Maybe Text
     ssoIdExtId (UserSSOId _ nameIdXML) = case userManagedBy usr of
       ManagedByWire -> Nothing
-      ManagedByScim -> SAML.unsafeShowNameID <$> either (const Nothing) pure (SAML.decodeElem (TL.fromStrict nameIdXML))
+      ManagedByScim ->
+        -- FUTUREWORK: keep the CI value, store the original in the database, but always use
+        -- the CI value for processing.
+        CI.original . SAML.unsafeShowNameID <$> either (const Nothing) pure (SAML.decodeElem (TL.fromStrict nameIdXML))
     ssoIdExtId (UserScimExternalId extId) = pure extId
 
 connectedProfile :: User -> UserLegalHoldStatus -> UserProfile

@@ -54,6 +54,7 @@ import qualified Data.HashMap.Strict as HashMap
 import Data.Hashable (Hashable)
 import Data.List.Extra (nubOrdOn)
 import qualified Data.Map as Map
+import Data.String.Conversions (cs)
 import qualified Data.Swagger.Build.Api as Doc
 import qualified Data.Text as Text
 import Imports
@@ -278,8 +279,8 @@ instance FromJSON RichField where
 instance Arbitrary RichField where
   arbitrary =
     RichField
-      <$> arbitrary
-      <*> (arbitrary `QC.suchThat` (/= "")) -- This is required because FromJSON calls @normalizeRichInfo@ and roundtrip tests fail
+      <$> (CI.mk . cs . QC.getPrintableString <$> arbitrary)
+      <*> (cs . QC.getPrintableString <$> arbitrary `QC.suchThat` (/= QC.PrintableString "")) -- This is required because FromJSON calls @normalizeRichInfo*@ and roundtrip tests fail
 
 --------------------------------------------------------------------------------
 -- convenience functions

@@ -4,7 +4,7 @@ cabal-version: 1.12
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: 8728b07d9aff8cd747ea5ca33259f9168c966ae28ca76825e0a073e166d43213
+-- hash: 0acb724202f4ba39242c1ebbe5f5db555404624b7a6be922d5a4148d38c5786d
 
 name:           galley
 version:        0.83.0
@@ -89,6 +89,7 @@ library
     , brig-types >=0.73.1
     , bytestring >=0.9
     , bytestring-conversion >=0.2
+    , case-insensitive
     , cassandra-util >=0.16.2
     , cassava >=0.5.2
     , cereal >=0.4
@@ -167,6 +168,7 @@ executable galley
   build-depends:
       HsOpenSSL
     , base
+    , case-insensitive
     , extended
     , galley
     , galley-types
@@ -299,6 +301,7 @@ executable galley-migrate-data
   ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path
   build-depends:
       base
+    , case-insensitive
     , cassandra-util
     , conduit
     , containers
@@ -365,6 +368,7 @@ executable galley-schema
   ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path
   build-depends:
       base
+    , case-insensitive
     , cassandra-util
     , extended
     , imports
@@ -397,6 +401,7 @@ test-suite galley-types-tests
   build-depends:
       QuickCheck
     , base
+    , case-insensitive
     , containers
     , extended
     , galley

@@ -11,6 +11,7 @@ license: AGPL-3
 
 dependencies:
 - imports
+- case-insensitive
 - extended
 - safe >=0.3
 - ssl-util

@@ -63,6 +63,7 @@ import Control.Lens
 import Control.Monad.Catch
 import Data.ByteString.Conversion hiding (fromList)
 import Data.ByteString.Lazy.Builder (lazyByteString)
+import qualified Data.CaseInsensitive as CI
 import Data.Csv (EncodeOptions (..), Quoting (QuoteAll), encodeDefaultOrderedByNameWith)
 import qualified Data.Handle as Handle
 import Data.Id
@@ -488,7 +489,7 @@ getTeamMembersCSVH (zusr ::: tid ::: _) = do
     samlNamedId :: User -> Maybe Text
     samlNamedId =
       userSSOId >=> \case
-        (UserSSOId _idp nameId) -> SAML.unsafeShowNameID <$> either (const Nothing) pure (SAML.decodeElem (cs nameId))
+        (UserSSOId _idp nameId) -> CI.original . SAML.unsafeShowNameID <$> either (const Nothing) pure (SAML.decodeElem (cs nameId))
         (UserScimExternalId _) -> Nothing
 
 bulkGetTeamMembersH :: UserId ::: TeamId ::: Range 1 Public.HardTruncationLimit Int32 ::: JsonRequest Public.UserIdList ::: JSON -> Galley Response

@@ -173,10 +173,12 @@ authresp ckyraw arbody = logErrors $ SAML.authresp sparSPIssuer sparResponseURI
   where
     cky :: Maybe BindCookie
     cky = ckyraw >>= bindCookieFromHeader
+
     go :: SAML.AuthnResponse -> SAML.AccessVerdict -> Spar Void
     go resp verdict = do
       result :: SAML.ResponseVerdict <- verdictHandler cky resp verdict
       throwError $ SAML.CustomServant result
+
     logErrors :: Spar Void -> Spar Void
     logErrors = flip catchError $ \case
       e@(SAML.CustomServant _) -> throwError e

@@ -29,8 +29,6 @@ module Spar.App
     getUserByUref,
     getUserByScimExternalId,
     insertUser,
-    autoprovisionSamlUser,
-    autoprovisionSamlUserWithId,
     validateEmailIfExists,
     errorPage,
   )
@@ -48,6 +46,7 @@ import Control.Monad.Except
 import Data.Aeson as Aeson (encode, object, (.=))
 import Data.Aeson.Text as Aeson (encodeToLazyText)
 import qualified Data.ByteString.Builder as Builder
+import qualified Data.CaseInsensitive as CI
 import Data.Id
 import Data.String.Conversions
 import Data.Text.Ascii (encodeBase64, toText)
@@ -77,6 +76,7 @@ import SAML2.WebSSO
     uidTenant,
   )
 import qualified SAML2.WebSSO as SAML
+import qualified SAML2.WebSSO.Types.Email as SAMLEmail
 import Servant
 import qualified Servant.Multipart as Multipart
 import qualified Spar.Data as Data
@@ -229,47 +229,53 @@ getUserByScimExternalId tid email = do
 -- FUTUREWORK: once we support <https://github.com/wireapp/hscim scim>, brig will refuse to delete
 -- users that have an sso id, unless the request comes from spar.  then we can make users
 -- undeletable in the team admin page, and ask admins to go talk to their IdP system.
-createSamlUserWithId :: UserId -> SAML.UserRef -> ManagedBy -> Spar ()
-createSamlUserWithId buid suid managedBy = do
+createSamlUserWithId :: UserId -> SAML.UserRef -> Spar ()
+createSamlUserWithId buid suid = do
   teamid <- (^. idpExtraInfo . wiTeam) <$> getIdPConfigByIssuer (suid ^. uidTenant)
   uname <- either (throwSpar . SparBadUserName . cs) pure $ Intra.mkUserName Nothing (UrefOnly suid)
-  buid' <- Intra.createBrigUserSAML suid buid teamid uname managedBy
+  buid' <- Intra.createBrigUserSAML suid buid teamid uname ManagedByWire
   assert (buid == buid') $ pure ()
   insertUser suid buid
 
 -- | If the team has no scim token, call 'createSamlUser'.  Otherwise, raise "invalid
 -- credentials".
-autoprovisionSamlUser :: SAML.UserRef -> ManagedBy -> Spar UserId
-autoprovisionSamlUser suid managedBy = do
+autoprovisionSamlUser :: SAML.UserRef -> Spar UserId
+autoprovisionSamlUser suid = do
   buid <- Id <$> liftIO UUID.nextRandom
-  autoprovisionSamlUserWithId buid suid managedBy
+  autoprovisionSamlUserWithId buid suid
   pure buid
 
 -- | Like 'autoprovisionSamlUser', but for an already existing 'UserId'.
-autoprovisionSamlUserWithId :: UserId -> SAML.UserRef -> ManagedBy -> Spar ()
-autoprovisionSamlUserWithId buid suid managedBy = do
+autoprovisionSamlUserWithId :: UserId -> SAML.UserRef -> Spar ()
+autoprovisionSamlUserWithId buid suid = do
   idp <- getIdPConfigByIssuer (suid ^. uidTenant)
-  unless (isNothing $ idp ^. idpExtraInfo . wiReplacedBy) $ do
-    throwSpar $ SparCannotCreateUsersOnReplacedIdP (cs . SAML.idPIdToST $ idp ^. idpId)
-  let teamid = idp ^. idpExtraInfo . wiTeam
-  scimtoks <- wrapMonadClient $ Data.getScimTokens teamid
-  if null scimtoks
-    then do
-      createSamlUserWithId buid suid managedBy
-      validateEmailIfExists buid suid
-    else
-      throwError . SAML.Forbidden $
-        "bad credentials (note that your team uses SCIM, "
-          <> "which disables saml auto-provisioning)"
+  guardReplacedIdP idp
+  guardScimTokens idp
+  createSamlUserWithId buid suid
+  validateEmailIfExists buid suid
+  where
+    -- Replaced IdPs are not allowed to create new wire accounts.
+    guardReplacedIdP :: IdP -> Spar ()
+    guardReplacedIdP idp = do
+      unless (isNothing $ idp ^. idpExtraInfo . wiReplacedBy) $ do
+        throwSpar $ SparCannotCreateUsersOnReplacedIdP (cs . SAML.idPIdToST $ idp ^. idpId)
+
+    -- IdPs in teams with scim tokens are not allowed to auto-provision.
+    guardScimTokens :: IdP -> Spar ()
+    guardScimTokens idp = do
+      let teamid = idp ^. idpExtraInfo . wiTeam
+      scimtoks <- wrapMonadClient $ Data.getScimTokens teamid
+      unless (null scimtoks) $ do
+        throwSpar SparSamlCredentialsNotFound
 
 -- | If user's 'NameID' is an email address and the team has email validation for SSO enabled,
 -- make brig initiate the email validate procedure.
 validateEmailIfExists :: UserId -> SAML.UserRef -> Spar ()
 validateEmailIfExists uid = \case
-  (SAML.UserRef _ (view SAML.nameID -> UNameIDEmail email)) -> doValidate email
+  (SAML.UserRef _ (view SAML.nameID -> UNameIDEmail email)) -> doValidate (CI.original email)
   _ -> pure ()
   where
-    doValidate :: SAML.Email -> Spar ()
+    doValidate :: SAMLEmail.Email -> Spar ()
     doValidate email = do
       enabled <- do
         tid <- Intra.getBrigUserTeam Intra.NoPendingInvitations uid
@@ -421,7 +427,7 @@ verdictHandlerResultCore bindCky = \case
         -- This is the first SSO authentication, so we auto-create a user. We know the user
         -- has not been created via SCIM because then we would've ended up in the
         -- "reauthentication" branch, so we pass 'ManagedByWire'.
-        (Nothing, Nothing, Nothing) -> autoprovisionSamlUser userref ManagedByWire
+        (Nothing, Nothing, Nothing) -> autoprovisionSamlUser userref
         -- If the user is only found under an old (previous) issuer, move it here.
         (Nothing, Nothing, Just (oldUserRef, uid)) -> moveUserToNewIssuer oldUserRef userref uid >> pure uid
         -- SSO re-authentication (the most common case).

@@ -94,6 +94,7 @@ import Control.Arrow (Arrow ((&&&)))
 import Control.Lens
 import Control.Monad.Except
 import Data.CaseInsensitive (foldCase)
+import qualified Data.CaseInsensitive as CI
 import Data.Id
 import Data.Json.Util (UTCTimeMillis, toUTCTimeMillis)
 import qualified Data.List.NonEmpty as NL
@@ -104,8 +105,8 @@ import GHC.TypeLits (KnownSymbol)
 import Imports
 import SAML2.Util (renderURI)
 import qualified SAML2.WebSSO as SAML
+import qualified SAML2.WebSSO.Types.Email as SAMLEmail
 import Spar.Data.Instances (VerdictFormatCon, VerdictFormatRow, fromVerdictFormat, toVerdictFormat)
-import qualified Text.Email.Parser as Email
 import Text.RawString.QQ
 import URI.ByteString
 import qualified Web.Cookie as Cky
@@ -283,7 +284,7 @@ normalizeUnqualifiedNameId = NormalizedUNameID . foldCase . nameIdTxt
   where
     nameIdTxt :: SAML.UnqualifiedNameID -> ST
     nameIdTxt (SAML.UNameIDUnspecified txt) = SAML.unsafeFromXmlText txt
-    nameIdTxt (SAML.UNameIDEmail (SAML.Email txt)) = cs $ Email.toByteString txt
+    nameIdTxt (SAML.UNameIDEmail email) = SAMLEmail.render $ CI.original email
     nameIdTxt (SAML.UNameIDX509 txt) = SAML.unsafeFromXmlText txt
     nameIdTxt (SAML.UNameIDWindows txt) = SAML.unsafeFromXmlText txt
     nameIdTxt (SAML.UNameIDKerberos txt) = SAML.unsafeFromXmlText txt

@@ -69,6 +69,7 @@ throwSpar = throwError . SAML.CustomError
 
 data SparCustomError
   = SparIdPNotFound
+  | SparSamlCredentialsNotFound
   | SparMissingZUsr
   | SparNotInTeam
   | SparNoPermission LT
@@ -158,6 +159,7 @@ renderSparError SAML.BadSamlResponseNoAssertions = Right $ Wai.mkError status400
 renderSparError SAML.BadSamlResponseAssertionWithoutID = Right $ Wai.mkError status400 "bad-response-saml" ("Bad response: assertion without ID")
 renderSparError (SAML.BadSamlResponseInvalidSignature msg) = Right $ Wai.mkError status400 "bad-response-signature" (cs msg)
 renderSparError (SAML.CustomError SparIdPNotFound) = Right $ Wai.mkError status404 "not-found" "Could not find IdP."
+renderSparError (SAML.CustomError SparSamlCredentialsNotFound) = Right $ Wai.mkError status404 "not-found" "Could not find SAML credentials, and auto-provisioning is disabled."
 renderSparError (SAML.CustomError SparMissingZUsr) = Right $ Wai.mkError status400 "client-error" "[header] 'Z-User' required"
 renderSparError (SAML.CustomError SparNotInTeam) = Right $ Wai.mkError status403 "no-team-member" "Requesting user is not a team member or not a member of this team."
 renderSparError (SAML.CustomError (SparNoPermission perm)) = Right $ Wai.mkError status403 "insufficient-permissions" ("You need permission " <> cs perm <> ".")

@@ -67,6 +67,7 @@ import Brig.Types.User.Auth (SsoLogin (..))
 import Control.Lens
 import Control.Monad.Except
 import Data.ByteString.Conversion
+import qualified Data.CaseInsensitive as CI
 import Data.Handle (Handle (Handle, fromHandle))
 import Data.Id (Id (Id), TeamId, UserId)
 import Data.Misc (PlainTextPassword)
@@ -76,10 +77,10 @@ import Imports
 import Network.HTTP.Types.Method
 import qualified Network.Wai.Utilities.Error as Wai
 import qualified SAML2.WebSSO as SAML
+import qualified SAML2.WebSSO.Types.Email as SAMLEmail
 import Spar.Error
 import Spar.Intra.Galley as Galley (MonadSparToGalley, assertHasPermission)
 import qualified System.Logger.Class as Log
-import qualified Text.Email.Parser
 import Web.Cookie
 import Wire.API.User
 import Wire.API.User.RichInfo as RichInfo
@@ -111,11 +112,11 @@ veidFromUserSSOId = \case
       (parseEmail email)
 
 urefToExternalId :: SAML.UserRef -> Maybe Text
-urefToExternalId = SAML.shortShowNameID . view SAML.uidSubject
+urefToExternalId = fmap CI.original . SAML.shortShowNameID . view SAML.uidSubject
 
 urefToEmail :: SAML.UserRef -> Maybe Email
 urefToEmail uref = case uref ^. SAML.uidSubject . SAML.nameID of
-  SAML.UNameIDEmail email -> Just $ emailFromSAML email
+  SAML.UNameIDEmail email -> Just . emailFromSAML . CI.original $ email
   _ -> Nothing
 
 -- | If the brig user has a 'UserSSOId', transform that into a 'ValidExternalId' (this is a
@@ -140,7 +141,7 @@ mkUserName :: Maybe Text -> ValidExternalId -> Either String Name
 mkUserName (Just n) = const $ mkName n
 mkUserName Nothing =
   runValidExternalId
-    (\uref -> mkName (SAML.unsafeShowNameID $ uref ^. SAML.uidSubject))
+    (\uref -> mkName (CI.original . SAML.unsafeShowNameID $ uref ^. SAML.uidSubject))
     (\email -> mkName (fromEmail email))
 
 renderValidExternalId :: ValidExternalId -> Maybe Text
@@ -157,18 +158,11 @@ respToCookie resp = do
   unless (statusCode resp == 200) crash
   maybe crash (pure . parseSetCookie) $ getHeader "Set-Cookie" resp
 
-emailFromSAML :: HasCallStack => SAML.Email -> Email
-emailFromSAML =
-  fromJust . parseEmail . cs
-    . Text.Email.Parser.toByteString
-    . SAML.fromEmail
+emailFromSAML :: HasCallStack => SAMLEmail.Email -> Email
+emailFromSAML = fromJust . parseEmail . SAMLEmail.render
 
-emailToSAML :: HasCallStack => Email -> SAML.Email
-emailToSAML brigEmail =
-  SAML.Email $
-    Text.Email.Parser.unsafeEmailAddress
-      (cs $ emailLocal brigEmail)
-      (cs $ emailDomain brigEmail)
+emailToSAML :: HasCallStack => Email -> SAMLEmail.Email
+emailToSAML = CI.original . fromRight (error "emailToSAML") . SAMLEmail.validate . toByteString
 
 -- | FUTUREWORK(fisx): if saml2-web-sso exported the 'NameID' constructor, we could make this
 -- function total without all that praying and hoping.
@@ -177,7 +171,7 @@ emailToSAMLNameID = fromRight (error "impossible") . SAML.emailNameID . fromEmai
 
 emailFromSAMLNameID :: HasCallStack => SAML.NameID -> Maybe Email
 emailFromSAMLNameID nid = case nid ^. SAML.nameID of
-  SAML.UNameIDEmail email -> Just $ emailFromSAML email
+  SAML.UNameIDEmail email -> Just . emailFromSAML . CI.original $ email
   _ -> Nothing
 
 ----------------------------------------------------------------------
-Original file line number
+Diff line change
@@ Expand Up / @@ -25,3 +25,4 @@ cabal.project.local~ @@
     *~
     *.el
     \#*
+    .ghci