From 136fc6a514d6171b991970644a5a0bec9443355c Mon Sep 17 00:00:00 2001 From: Matthias Fischmann Date: Fri, 22 Nov 2024 10:29:28 +0100 Subject: [PATCH] [WPB-14436] helpful dynamic mapping errors (#29) * rm outdated or cryptic TODOs; cleanup. * Test case reproducing the issue. * ldapToScim: optionally enforce existence of `userName` field. * Eliminate -Wno-... Hack around orphan instance; don't turn warning on and off again. * Haddocks. * Mention offending scim field name in error messages. * Haddocks. * Update src/LdapScimBridge.hs Co-authored-by: Sven Tennie --------- Co-authored-by: Sven Tennie --- ldap-scim-bridge.cabal | 2 +- src/LdapScimBridge.hs | 105 ++++++++++++++++++++++++----------------- test/Spec.hs | 29 ++++++++---- 3 files changed, 85 insertions(+), 51 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 36031fe..0bdda52 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 @@ -84,7 +83,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 @@ -151,23 +150,30 @@ 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 +-- | 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) + +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 data MappingError = MissingAttr Text + | MissingMandatoryValue Text | WrongNumberOfAttrValues Text String Int | CouldNotParseEmail Text String deriving stock (Eq, Show) @@ -223,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) - -- Really, not username, but handle. - mapUserName :: Text -> FieldMapping - mapUserName ldapFieldName = FieldMapping "userName" $ + -- Wire user handle (the one with the '@'). + 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 @@ -264,23 +270,23 @@ 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) -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] @@ -297,23 +303,38 @@ 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. See 'RequireUserName', 'ldapToScim' if you wonder whether this is a +-- good idea. 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)] => + (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 +387,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 +403,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) @@ -506,7 +527,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 diff --git a/test/Spec.hs b/test/Spec.hs index cf0941a..2ff752a 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,10 +29,10 @@ 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 + let Right (actualSearchEntry, actualScimUser) = ldapToScim Lenient conf searchEntry actualSearchEntry `shouldBe` searchEntry actualScimUser `shouldBe` expectedScimUser @@ -49,21 +49,34 @@ 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 + let Right (actualSearchEntry, actualScimUser) = ldapToScim Lenient conf searchEntry 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 Strict conf searchEntry `shouldBe` Left [(searchEntry, MissingMandatoryValue "userName")] + searchEntryEmpty :: SearchEntry 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,