From aec65e3b66b11bd6ae8cd04272c94c1bd1c9ecbd Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Thu, 21 Nov 2024 08:46:10 +0100 Subject: [PATCH 1/8] rm outdated or cryptic TODOs; cleanup. --- src/LdapScimBridge.hs | 10 +++++----- test/Spec.hs | 12 ++++++------ 2 files changed, 11 insertions(+), 11 deletions(-) diff --git a/src/LdapScimBridge.hs b/src/LdapScimBridge.hs index 36031fe..3e43035 100644 --- a/src/LdapScimBridge.hs +++ b/src/LdapScimBridge.hs @@ -84,7 +84,7 @@ instance Aeson.FromJSON LdapConf where fpassword :: String <- obj Aeson..: "password" fsearch :: LdapSearch <- obj Aeson..: "search" fcodec :: Text <- obj Aeson..: "codec" - fdeleteOnAttribute :: Maybe LdapFilterAttr <- obj Aeson..:? "deleteOnAttribute" -- TODO: this can go into 'fdeleteFromDirectory'. + fdeleteOnAttribute :: Maybe LdapFilterAttr <- obj Aeson..:? "deleteOnAttribute" fdeleteFromDirectory :: Maybe LdapSearch <- obj Aeson..:? "deleteFromDirectory" let vhost :: Host @@ -237,7 +237,7 @@ instance Aeson.FromJSON Mapping where [val] -> Right $ \usr -> usr {Scim.displayName = Just val} bad -> Left $ WrongNumberOfAttrValues ldapFieldName "1" (Prelude.length bad) - -- Really, not username, but handle. + -- Wire user handle (the one with the '@'). mapUserName :: Text -> FieldMapping mapUserName ldapFieldName = FieldMapping "userName" $ \case @@ -277,10 +277,10 @@ instance Aeson.FromJSON Mapping where type LdapResult a = IO (Either LdapError a) -ldapObjectClassFilter :: Text -> Filter -- TODO: inline? +ldapObjectClassFilter :: Text -> Filter ldapObjectClassFilter = (Attr "objectClass" :=) . cs -ldapFilterAttrToFilter :: LdapFilterAttr -> Filter -- TODO: inline? replace LdapFilterAttr with `Attr` and `:=`? +ldapFilterAttrToFilter :: LdapFilterAttr -> Filter ldapFilterAttrToFilter (LdapFilterAttr key val) = Attr key := cs val listLdapUsers :: LdapConf -> LdapSearch -> LdapResult [SearchEntry] @@ -308,7 +308,7 @@ scimSchemas = [Scim.User20] ldapToScim :: forall m. - m ~ Either [(SearchEntry, MappingError)] => + (m ~ Either [(SearchEntry, MappingError)]) => BridgeConf -> SearchEntry -> m (SearchEntry, User) diff --git a/test/Spec.hs b/test/Spec.hs index cf0941a..57e069f 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,6 +1,8 @@ {-# LANGUAGE OverloadedStrings #-} import Data.ByteString (ByteString) +import Data.Function ((&)) +import Data.Maybe (maybeToList) import Data.String.Conversions (cs) import Data.Text import qualified Data.Yaml as Yaml @@ -12,8 +14,6 @@ import Web.Scim.Schema.Meta as Scim import Web.Scim.Schema.Schema as Scim import Web.Scim.Schema.User as Scim import Web.Scim.Schema.User.Email as Scim -import Data.Function ((&)) -import Data.Maybe (maybeToList) main :: IO () main = hspec $ do @@ -29,7 +29,7 @@ main = hspec $ do & addAttr "uidNumber" userName & addAttr "email" email - let expectedScimUser = mkScimUser displayName userName externalId email Nothing + let expectedScimUser = mkExpectedScimUser displayName userName externalId email Nothing conf <- Yaml.decodeThrow confYaml let Right (actualSearchEntry, actualScimUser) = ldapToScim conf searchEntry @@ -49,7 +49,7 @@ main = hspec $ do & addAttr "email" email & addAttr "employeeType" role - let expectedScimUser = mkScimUser displayName userName externalId email (Just role) + let expectedScimUser = mkExpectedScimUser displayName userName externalId email (Just role) conf <- Yaml.decodeThrow confYaml let Right (actualSearchEntry, actualScimUser) = ldapToScim conf searchEntry @@ -62,8 +62,8 @@ searchEntryEmpty = SearchEntry (Dn "") [] addAttr :: Text -> Text -> SearchEntry -> SearchEntry addAttr key value (SearchEntry dn attrs) = SearchEntry dn ((Attr key, [cs value]) : attrs) -mkScimUser :: Text -> Text -> Text -> Text -> Maybe Text -> Scim.User ScimTag -mkScimUser displayName userName externalId email mRole = +mkExpectedScimUser :: Text -> Text -> Text -> Text -> Maybe Text -> Scim.User ScimTag +mkExpectedScimUser displayName userName externalId email mRole = Scim.User { schemas = [User20], userName = userName, From a7923f87c4ad3ab1f619c1b26c7af29d08c63b62 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Thu, 21 Nov 2024 08:56:24 +0100 Subject: [PATCH 2/8] Test case reproducing the issue. --- test/Spec.hs | 13 +++++++++++++ 1 file changed, 13 insertions(+) diff --git a/test/Spec.hs b/test/Spec.hs index 57e069f..3cb7bd2 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -56,6 +56,19 @@ main = hspec $ do actualSearchEntry `shouldBe` searchEntry actualScimUser `shouldBe` expectedScimUser + it "helpful error message if scim userName (wire handle) field is missing" $ do + let displayName = "John Doe" + let userName = "jdoe" + let externalId = "jdoe@nodomain" + let email = "jdoe@nodomain" + let searchEntry = + searchEntryEmpty + & addAttr "displayName" displayName + & addAttr "email" email + + conf <- Yaml.decodeThrow confYaml + ldapToScim conf searchEntry `shouldBe` Left [] + searchEntryEmpty :: SearchEntry searchEntryEmpty = SearchEntry (Dn "") [] From df249673077d1a2a206d96ec7d8ef54db9189722 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Thu, 21 Nov 2024 16:29:36 +0100 Subject: [PATCH 3/8] ldapToScim: optionally enforce existence of `userName` field. --- src/LdapScimBridge.hs | 27 +++++++++++++++++++++------ test/Spec.hs | 6 +++--- 2 files changed, 24 insertions(+), 9 deletions(-) diff --git a/src/LdapScimBridge.hs b/src/LdapScimBridge.hs index 3e43035..953ffb1 100644 --- a/src/LdapScimBridge.hs +++ b/src/LdapScimBridge.hs @@ -168,6 +168,7 @@ instance Aeson.FromJSON BridgeConf data MappingError = MissingAttr Text + | MissingMandatoryValue Text | WrongNumberOfAttrValues Text String Int | CouldNotParseEmail Text String deriving stock (Eq, Show) @@ -297,23 +298,37 @@ type User = Scim.User ScimTag type StoredUser = ScimClass.StoredUser ScimTag --- | the 'undefined' is ok, the mapping is guaranteed to contain a filler for this, or the --- mapping parser would have failed. +-- | Note that the `userName` field is mandatory in SCIM, but we gloss over this by setting it +-- to an empty Text here. emptyScimUser :: User emptyScimUser = - Scim.empty scimSchemas (error "undefined") Scim.NoUserExtra + Scim.empty scimSchemas "" Scim.NoUserExtra scimSchemas :: [Scim.Schema] scimSchemas = [Scim.User20] +data RequireUserName = Lenient | Strict + deriving stock (Eq, Show) + +-- | Translate an ldap record into a scim record. If username is not provided in the ldap +-- record, behavior is defined by the first argument: if `Lenient`, just fill in an empty +-- Text; if `Strict`, throw an error. ldapToScim :: forall m. (m ~ Either [(SearchEntry, MappingError)]) => + RequireUserName -> BridgeConf -> SearchEntry -> m (SearchEntry, User) -ldapToScim conf entry@(SearchEntry _ attrs) = (entry,) <$> Foldable.foldl' go (Right emptyScimUser) attrs +ldapToScim reqUserName conf entry@(SearchEntry _ attrs) = do + guardUserName + (entry,) <$> Foldable.foldl' go (Right emptyScimUser) attrs where + guardUserName = + if reqUserName == Strict && Attr "userName" `notElem` (fst <$> toList attrs) + then Left [(entry, MissingMandatoryValue "userName")] + else Right () + codec = case ldapCodec (ldapSource conf) of Utf8 -> Text.decodeUtf8 Latin1 -> Text.decodeLatin1 @@ -366,7 +381,7 @@ updateScimPeer lgr conf = do lgr Info "[post/put: started]" let ldapKeepees = filter (not . isDeletee (ldapSource conf)) ldaps scims :: [(SearchEntry, User)] <- - mapM (either (throwIO . ErrorCall . show) pure) (ldapToScim conf <$> ldapKeepees) + mapM (either (throwIO . ErrorCall . show) pure) (ldapToScim Strict conf <$> ldapKeepees) lgr Debug $ "Pulled the following ldap users for post/put:\n" <> show (fst <$> scims) lgr Debug . cs $ "Translated to scim:\n" <> Aeson.encodePretty (snd <$> scims) updateScimPeerPostPut lgr clientEnv tok (snd <$> scims) @@ -382,7 +397,7 @@ updateScimPeer lgr conf = do pure mempty scims :: [(SearchEntry, User)] <- - mapM (either (throwIO . ErrorCall . show) pure) (ldapToScim conf <$> (ldapDeleteesAttr <> ldapDeleteesDirectory)) + mapM (either (throwIO . ErrorCall . show) pure) (ldapToScim Lenient conf <$> (ldapDeleteesAttr <> ldapDeleteesDirectory)) lgr Debug $ "Pulled the following ldap users for delete:\n" <> show (fst <$> scims) lgr Debug . cs $ "Translated to scim:\n" <> Aeson.encodePretty (snd <$> scims) updateScimPeerDelete lgr clientEnv tok (snd <$> scims) diff --git a/test/Spec.hs b/test/Spec.hs index 3cb7bd2..2ff752a 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -32,7 +32,7 @@ main = hspec $ do let expectedScimUser = mkExpectedScimUser displayName userName externalId email Nothing conf <- Yaml.decodeThrow confYaml - let Right (actualSearchEntry, actualScimUser) = ldapToScim conf searchEntry + let Right (actualSearchEntry, actualScimUser) = ldapToScim Lenient conf searchEntry actualSearchEntry `shouldBe` searchEntry actualScimUser `shouldBe` expectedScimUser @@ -52,7 +52,7 @@ main = hspec $ do let expectedScimUser = mkExpectedScimUser displayName userName externalId email (Just role) conf <- Yaml.decodeThrow confYaml - let Right (actualSearchEntry, actualScimUser) = ldapToScim conf searchEntry + let Right (actualSearchEntry, actualScimUser) = ldapToScim Lenient conf searchEntry actualSearchEntry `shouldBe` searchEntry actualScimUser `shouldBe` expectedScimUser @@ -67,7 +67,7 @@ main = hspec $ do & addAttr "email" email conf <- Yaml.decodeThrow confYaml - ldapToScim conf searchEntry `shouldBe` Left [] + ldapToScim Strict conf searchEntry `shouldBe` Left [(searchEntry, MissingMandatoryValue "userName")] searchEntryEmpty :: SearchEntry searchEntryEmpty = SearchEntry (Dn "") [] From 34e56463d8fe73005127b201be849619b766fae1 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Thu, 21 Nov 2024 21:49:44 +0100 Subject: [PATCH 4/8] Eliminate -Wno-... Hack around orphan instance; don't turn warning on and off again. --- ldap-scim-bridge.cabal | 2 +- src/LdapScimBridge.hs | 26 +++++++++++++++----------- 2 files changed, 16 insertions(+), 12 deletions(-) diff --git a/ldap-scim-bridge.cabal b/ldap-scim-bridge.cabal index 0be0a9b..ffa9528 100644 --- a/ldap-scim-bridge.cabal +++ b/ldap-scim-bridge.cabal @@ -60,7 +60,7 @@ common common-options -O2 -Wall -Wcompat -Widentities -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path -Wredundant-constraints - -fhide-source-paths -Wmissing-export-lists -Wpartial-fields + -fhide-source-paths -Wpartial-fields -Wmissing-deriving-strategies default-language: Haskell2010 diff --git a/src/LdapScimBridge.hs b/src/LdapScimBridge.hs index 953ffb1..62c6ac4 100644 --- a/src/LdapScimBridge.hs +++ b/src/LdapScimBridge.hs @@ -1,5 +1,4 @@ {-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -Wno-orphans -Wno-missing-export-lists #-} module LdapScimBridge where @@ -151,18 +150,23 @@ data BridgeConf = BridgeConf { ldapSource :: LdapConf, scimTarget :: ScimConf, mapping :: Mapping, - logLevel :: Level + logLevel :: PhantomParent Level } deriving stock (Show, Generic) -instance Aeson.FromJSON Level where - parseJSON "Trace" = pure Trace - parseJSON "Debug" = pure Debug - parseJSON "Info" = pure Info - parseJSON "Warn" = pure Warn - parseJSON "Error" = pure Error - parseJSON "Fatal" = pure Fatal - parseJSON bad = fail $ "unknown Level: " <> show bad +newtype PhantomParent a = PhantomParent {unPhantomParent :: a} + deriving stock (Eq, Ord, Bounded, Show, Generic) + +instance Aeson.FromJSON (PhantomParent Level) where + parseJSON = + fmap PhantomParent . \case + "Trace" -> pure Trace + "Debug" -> pure Debug + "Info" -> pure Info + "Warn" -> pure Warn + "Error" -> pure Error + "Fatal" -> pure Fatal + bad -> fail $ "unknown Level: " <> show bad instance Aeson.FromJSON BridgeConf @@ -521,7 +525,7 @@ mkLogger lvl = do main :: IO () main = do myconf :: BridgeConf <- parseCli - lgr :: Logger <- mkLogger (logLevel myconf) + lgr :: Logger <- mkLogger (unPhantomParent $ logLevel myconf) lgr Debug $ show (mapping myconf) updateScimPeer lgr myconf `catch` logErrors lgr where From 85958434ed7e1b1531e9c712677632796ab6e9d4 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Fri, 22 Nov 2024 09:52:24 +0100 Subject: [PATCH 5/8] Haddocks. --- src/LdapScimBridge.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/LdapScimBridge.hs b/src/LdapScimBridge.hs index 62c6ac4..c0c22d6 100644 --- a/src/LdapScimBridge.hs +++ b/src/LdapScimBridge.hs @@ -154,6 +154,7 @@ data BridgeConf = BridgeConf } deriving stock (Show, Generic) +-- | Work around orphan instances. Might not be a phantom, but I like the name. :) newtype PhantomParent a = PhantomParent {unPhantomParent :: a} deriving stock (Eq, Ord, Bounded, Show, Generic) From 57c199aaba96d51427bbc07dea539a53e6b908b3 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Fri, 22 Nov 2024 09:59:43 +0100 Subject: [PATCH 6/8] Mention offending scim field name in error messages. --- src/LdapScimBridge.hs | 40 ++++++++++++++++++++-------------------- 1 file changed, 20 insertions(+), 20 deletions(-) diff --git a/src/LdapScimBridge.hs b/src/LdapScimBridge.hs index c0c22d6..31698e1 100644 --- a/src/LdapScimBridge.hs +++ b/src/LdapScimBridge.hs @@ -229,35 +229,35 @@ instance Aeson.FromJSON Mapping where go mp (k, b) = Map.alter (Just . maybe [b] (b :)) k mp pure . Mapping . listToMap . catMaybes $ - [ (\fdisplayName -> (fdisplayName, mapDisplayName fdisplayName)) <$> mfdisplayName, - Just (fuserName, mapUserName fuserName), - Just (fexternalId, mapExternalId fexternalId), - (\femail -> (femail, mapEmail femail)) <$> mfemail, - (\frole -> (frole, mapRole frole)) <$> mfrole + [ (\fdisplayName -> (fdisplayName, mapDisplayName fdisplayName "displayName")) <$> mfdisplayName, + Just (fuserName, mapUserName fuserName "userName"), + Just (fexternalId, mapExternalId fexternalId "externalId"), + (\femail -> (femail, mapEmail femail "email")) <$> mfemail, + (\frole -> (frole, mapRole frole "roles")) <$> mfrole ] where -- The name that shows for this user in wire. - mapDisplayName :: Text -> FieldMapping - mapDisplayName ldapFieldName = FieldMapping "displayName" $ + mapDisplayName :: Text -> Text -> FieldMapping + mapDisplayName ldapFieldName scimFieldName = FieldMapping scimFieldName $ \case [val] -> Right $ \usr -> usr {Scim.displayName = Just val} - bad -> Left $ WrongNumberOfAttrValues ldapFieldName "1" (Prelude.length bad) + bad -> Left $ WrongNumberOfAttrValues (ldapFieldName <> " -> " <> scimFieldName) "1" (Prelude.length bad) -- Wire user handle (the one with the '@'). - mapUserName :: Text -> FieldMapping - mapUserName ldapFieldName = FieldMapping "userName" $ + mapUserName :: Text -> Text -> FieldMapping + mapUserName ldapFieldName scimFieldName = FieldMapping scimFieldName $ \case [val] -> Right $ \usr -> usr {Scim.userName = val} - bad -> Left $ WrongNumberOfAttrValues ldapFieldName "1" (Prelude.length bad) + bad -> Left $ WrongNumberOfAttrValues (ldapFieldName <> " -> " <> scimFieldName) "1" (Prelude.length bad) - mapExternalId :: Text -> FieldMapping - mapExternalId ldapFieldName = FieldMapping "externalId" $ + mapExternalId :: Text -> Text -> FieldMapping + mapExternalId ldapFieldName scimFieldName = FieldMapping scimFieldName $ \case [val] -> Right $ \usr -> usr {Scim.externalId = Just val} - bad -> Left $ WrongNumberOfAttrValues ldapFieldName "1" (Prelude.length bad) + bad -> Left $ WrongNumberOfAttrValues (ldapFieldName <> " -> " <> scimFieldName) "1" (Prelude.length bad) - mapEmail :: Text -> FieldMapping - mapEmail ldapFieldName = FieldMapping "emails" $ + mapEmail :: Text -> Text -> FieldMapping + mapEmail ldapFieldName scimFieldName = FieldMapping scimFieldName $ \case [] -> Right id [val] -> case Text.Email.Validate.validate (SC.cs val) of @@ -270,16 +270,16 @@ instance Aeson.FromJSON Mapping where bad -> Left $ WrongNumberOfAttrValues - ldapFieldName + (ldapFieldName <> " -> " <> scimFieldName) "<=1 (with more than one email, which one should be primary?)" (Prelude.length bad) - mapRole :: Text -> FieldMapping - mapRole ldapFieldName = FieldMapping "roles" $ + mapRole :: Text -> Text -> FieldMapping + mapRole ldapFieldName scimFieldName = FieldMapping scimFieldName $ \case [] -> Right id [val] -> Right $ \usr -> usr {Scim.roles = [val]} - bad -> Left $ WrongNumberOfAttrValues ldapFieldName "1" (Prelude.length bad) + bad -> Left $ WrongNumberOfAttrValues (ldapFieldName <> " -> " <> scimFieldName) "1" (Prelude.length bad) type LdapResult a = IO (Either LdapError a) From df20b203feb32b9a9111bf4301ffa930db566dee Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Fri, 22 Nov 2024 10:01:40 +0100 Subject: [PATCH 7/8] Haddocks. --- src/LdapScimBridge.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/LdapScimBridge.hs b/src/LdapScimBridge.hs index 31698e1..054108b 100644 --- a/src/LdapScimBridge.hs +++ b/src/LdapScimBridge.hs @@ -304,7 +304,8 @@ type User = Scim.User ScimTag type StoredUser = ScimClass.StoredUser ScimTag -- | Note that the `userName` field is mandatory in SCIM, but we gloss over this by setting it --- to an empty Text here. +-- to an empty Text here. See 'RequireUserName', 'ldapToScim' if you wonder whether this is a +-- good idea. emptyScimUser :: User emptyScimUser = Scim.empty scimSchemas "" Scim.NoUserExtra From 4d121c57e70ba8813f36b8f9002b18e3af2edab0 Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Fri, 22 Nov 2024 10:05:04 +0100 Subject: [PATCH 8/8] Update src/LdapScimBridge.hs Co-authored-by: Sven Tennie --- src/LdapScimBridge.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/LdapScimBridge.hs b/src/LdapScimBridge.hs index 62c6ac4..ce66bc5 100644 --- a/src/LdapScimBridge.hs +++ b/src/LdapScimBridge.hs @@ -314,7 +314,7 @@ scimSchemas = [Scim.User20] data RequireUserName = Lenient | Strict deriving stock (Eq, Show) --- | Translate an ldap record into a scim record. If username is not provided in the ldap +-- | Translate an LDAP record into a SCIM record. If username is not provided in the LDAP -- record, behavior is defined by the first argument: if `Lenient`, just fill in an empty -- Text; if `Strict`, throw an error. ldapToScim ::