[WPB-14436] Bump hscim to 0.4.0.6; fix guardUserName (#30)

* Fix guardUserName: look for *ldap* key in ldap, not for *scim* key. * More readable rendering of error messages. * cabal gen-bounds * drop support for ghc9.4. * Bump dockerfile base image. * add script for publishing on hackage und quay.io * Developers section for README.md --------- Co-authored-by: Sven Tennie <[email protected]>
wireapp · Nov 28, 2024 · fde64a9 · fde64a9
1 parent 136fc6a
commit fde64a9
Show file tree

Hide file tree

Showing 11 changed files with 140 additions and 62 deletions.
diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml
@@ -24,8 +24,8 @@ jobs:
       fail-fast: false
       matrix:
         os: [ubuntu-latest]
-        ghc-version: ['9.4']
-        cabal: ['3.10.2.1']
+        ghc-version: ['9.6.6']
+        cabal: ['3.10.3.0']
 
     steps:
     - uses: actions/checkout@v4

diff --git a/.gitignore b/.gitignore
@@ -1,3 +1,4 @@
+/.ghci
 ### Haskell
 dist
 dist-*

diff --git a/CHANGELOG.md b/CHANGELOG.md
@@ -3,6 +3,10 @@
 `ldap-scim-bridge` uses [PVP][1]-compatible versioning.
 The changelog is available [on GitHub][2].
 
+## 0.10
+
+- More helpful error messages on bad LDAP input records.
+
 ## 0.9
 
 - Map ldap attribute to SCIM roles (#26)

diff --git a/Dockerfile b/Dockerfile
@@ -1,4 +1,4 @@
-FROM haskell:9.4.8-buster
+FROM haskell:9.6.6-slim-bullseye
 
 WORKDIR /opt/ldap-scim-bridge
 

diff --git a/README.md b/README.md
@@ -73,6 +73,13 @@ docker run -it --network=host \
   ldap-scim-bridge /mnt/config.yaml
 ```
 
+## developers
+
+For running unit tests, try `cabal test`.
+
+Integration tests is a bit more involved, since we need ldap and
+wire-server running.  See `./examples/wire-server/run.sh`.
+
 ## future work
 
 See https://github.com/wireapp/ldap-scim-bridge/issues

diff --git a/admin/publish.sh b/admin/publish.sh
@@ -0,0 +1,19 @@
+#!/bin/bash
+
+echo "WARNING!! this script has never run!!  test carefully!!"
+exit 1
+
+# hackage
+# from https://hackage.haskell.org/upload
+dir=$(mktemp -d dist-docs.XXXXXX)
+trap 'rm -r "$dir"' EXIT
+cabal v2-haddock --builddir="$dir" --haddock-for-hackage --enable-doc
+cabal upload -d --publish $dir/*-docs.tar.gz
+
+# docker
+export VERSION=0.10
+docker build -t ldap-scim-bridge:${VERSION} .
+docker tag ldap-scim-bridge:${VERSION} quay.io/wire/ldap-scim-bridge:${VERSION}
+docker login quay.io
+docker push quay.io/wire/ldap-scim-bridge:${VERSION}
+
diff --git a/examples/wire-server/run.sh b/examples/wire-server/run.sh
@@ -29,7 +29,7 @@ export SCIM_TOKEN
 export SCIM_TOKEN_ID
 export SCIM_TOKEN_FULL
 export WIRE_SAMLIDP
-export WIRE_SERVER_PATH="${WIRE_SERVER_PATH:=~/src/wire-server}"
+export WIRE_SERVER_PATH="${WIRE_SERVER_PATH:=${HOME}/src/wire-server}"
 export SPAR_URL=http://localhost:8088
 export BRIG_URL=http://localhost:8082
 export GALLEY_URL=http://localhost:8085
@@ -69,7 +69,7 @@ function scaffolding_spar() {
     WIRE_PASSWD=$(echo "$WIRE_USER" | sed 's/^\([^,]\+\),\([^,]\+\),\([^,]\+\)$/\3/')
     WIRE_TEAMID=$(curl -s -H'content-type: application/json' -H'Z-User: '"${WIRE_USERID}" "$BRIG_URL/self" | jq .team | xargs echo)
 
-    # create a saml idp (if we don't, users will not be created, but invitated, which would make the following more awkward to write down).
+    # create a saml idp (if we don't, users will not be created, but invited, which would make the following more awkward to write down).
     curl -s -X PUT \
       --header "Z-User: $WIRE_USERID" \
       --header 'Content-Type: application/json;charset=utf-8' \
@@ -78,7 +78,7 @@ function scaffolding_spar() {
     WIRE_SAMLIDP=$(curl -X POST \
       --header "Z-User: $WIRE_USERID" \
       --header 'Content-Type: application/xml;charset=utf-8' \
-      -d "<EntityDescriptor xmlns:samlp=\"urn:oasis:names:tc:SAML:2.0:protocol\" xmlns:samla=\"urn:oasis:names:tc:SAML:2.0:assertion\" xmlns:samlm=\"urn:oasis:names:tc:SAML:2.0:metadata\" xmlns:ds=\"http://www.w3.org/2000/09/xmldsig#\" ID=\"_0c29ba62-a541-11e8-8042-873ef87bdcba\" entityID=\"https://issuer.net/_$(uuidgen)\" xmlns=\"urn:oasis:names:tc:SAML:2.0:metadata\"><IDPSSODescriptor protocolSupportEnumeration=\"urn:oasis:names:tc:SAML:2.0:protocol\"><KeyDescriptor use=\"signing\"><ds:KeyInfo><ds:X509Data><ds:X509Certificate>MIIBOTCBxKADAgECAg4TIFmNatMeqaAE8BWQBTANBgkqhkiG9w0BAQsFADAAMB4XDTIxMDkwMzEzMjUyMVoXDTQxMDgyOTEzMjUyMVowADB6MA0GCSqGSIb3DQEBAQUAA2kAMGYCYQDPAqTk/nq2B/J0WH2FtiRh6nB8BvOc6M7d4K2KV0kXrePjeRPh+cDDf9mYrpntnjBa2LGAc0S4gjUXdvnt1Fxg2YYXYJ+N7+jxV36jUng7cGz1tEOB5RIj28Mv8/eXnjUCAREwDQYJKoZIhvcNAQELBQADYQBaIWDz832gg5jZPIy5z0CV1rWbUQALy6SUodWMezbzVF86hycUvZqAzd5Pir8084Mk/6FQK2Hbbml2LaHS8JnZpYxlgNIRNNonzScAUFclDi4NNmcxPuB6ycu9kK/0l+A=</ds:X509Certificate></ds:X509Data></ds:KeyInfo></KeyDescriptor><SingleSignOnService Binding=\"urn:oasis:names:tc:SAML:2.0:bindings:HTTP-POST\" Location=\"https://requri.net/fb9e3c14-25eb-482a-8df3-c71e3e83110b\"/></IDPSSODescriptor></EntityDescriptor>" \
+      -d "<EntityDescriptor xmlns:samlp=\"urn:oasis:names:tc:SAML:2.0:protocol\" xmlns:samla=\"urn:oasis:names:tc:SAML:2.0:assertion\" xmlns:samlm=\"urn:oasis:names:tc:SAML:2.0:metadata\" xmlns:ds=\"http://www.w3.org/2000/09/xmldsig#\" ID=\"_0c29ba62-a541-11e8-8042-873ef87bdcba\" entityID=\"https://issuer.net/_$(uuid)\" xmlns=\"urn:oasis:names:tc:SAML:2.0:metadata\"><IDPSSODescriptor protocolSupportEnumeration=\"urn:oasis:names:tc:SAML:2.0:protocol\"><KeyDescriptor use=\"signing\"><ds:KeyInfo><ds:X509Data><ds:X509Certificate>MIIBOTCBxKADAgECAg4TIFmNatMeqaAE8BWQBTANBgkqhkiG9w0BAQsFADAAMB4XDTIxMDkwMzEzMjUyMVoXDTQxMDgyOTEzMjUyMVowADB6MA0GCSqGSIb3DQEBAQUAA2kAMGYCYQDPAqTk/nq2B/J0WH2FtiRh6nB8BvOc6M7d4K2KV0kXrePjeRPh+cDDf9mYrpntnjBa2LGAc0S4gjUXdvnt1Fxg2YYXYJ+N7+jxV36jUng7cGz1tEOB5RIj28Mv8/eXnjUCAREwDQYJKoZIhvcNAQELBQADYQBaIWDz832gg5jZPIy5z0CV1rWbUQALy6SUodWMezbzVF86hycUvZqAzd5Pir8084Mk/6FQK2Hbbml2LaHS8JnZpYxlgNIRNNonzScAUFclDi4NNmcxPuB6ycu9kK/0l+A=</ds:X509Certificate></ds:X509Data></ds:KeyInfo></KeyDescriptor><SingleSignOnService Binding=\"urn:oasis:names:tc:SAML:2.0:bindings:HTTP-POST\" Location=\"https://requri.net/fb9e3c14-25eb-482a-8df3-c71e3e83110b\"/></IDPSSODescriptor></EntityDescriptor>" \
       ${SPAR_URL}/identity-providers | jq .)
     if [ "$(echo "$WIRE_SAMLIDP" | jq .id)" == "null" ]; then
         echo "could not create idp: $WIRE_SAMLIDP"

diff --git a/ldap-scim-bridge.cabal b/ldap-scim-bridge.cabal
@@ -1,15 +1,15 @@
 cabal-version:      2.4
 name:               ldap-scim-bridge
-version:            0.9
+version:            0.10
 synopsis:           See README for synopsis
 description:        See README for description
 homepage:           https://github.com/wireapp/ldap-scim-bridge
 bug-reports:        https://github.com/wireapp/ldap-scim-bridge/issues
 license:            AGPL-3.0-or-later
 license-file:       LICENSE
-author:             Matthias Fischmann
-maintainer:         Matthias Fischmann <[email protected]>
-copyright:          (c) 2021 wire.com
+author:             wire.com
+maintainer:         [email protected]
+copyright:          (c) 2021 - 2024 wire.com
 category:           System
 build-type:         Simple
 extra-doc-files:
@@ -22,35 +22,35 @@ extra-source-files:
   examples/wire-server/run.sh
   examples/wire-server/runlog
 
-tested-with:        GHC ==8.8.3
+tested-with:        GHC ==9.6.6
 
 source-repository head
   type:     git
   location: https://github.com/wireapp/ldap-scim-bridge.git
 
 common common-options
   build-depends:
-    , aeson                 >=2.1.2   && <2.2
-    , aeson-pretty          >=0.8.10  && <0.9
-    , base                  >=4.17.2  && <4.18
-    , bytestring            >=0.11.5  && <0.12
-    , containers            >=0.6.7   && <0.7
-    , email-validate        >=2.3.2   && <2.4
-    , hscim                 >=0.4.0.2 && <0.5
-    , http-client           >=0.7.16  && <0.8
-    , http-client-tls       >=0.3.6   && <0.4
-    , http-types            >=0.12.4  && <0.13
-    , ldap-client           >=0.4.2   && <0.5
-    , network               >=3.1.4   && <3.2
-    , relude                >=1.2.1   && <1.3
-    , servant               >=0.19.1  && <0.20
-    , servant-client        >=0.19    && <0.20
-    , servant-client-core   >=0.19    && <0.20
-    , string-conversions    >=0.4.0   && <0.5
-    , text                  >=2.0.2   && <2.1
-    , tinylog               >=0.15.0  && <0.16
-    , unordered-containers  >=0.2.20  && <0.3
-    , yaml                  >=0.11.11 && <0.12
+    , aeson >= 2.1.2 && < 2.2
+    , aeson-pretty >= 0.8.10 && < 0.9
+    , base >= 4.17 && < 4.21
+    , bytestring >= 0.11.5 && < 0.12
+    , containers >= 0.6.7 && < 0.7
+    , email-validate >= 2.3.2 && < 2.4
+    , hscim >= 0.4.0.6 && < 0.5
+    , http-client >= 0.7.16 && < 0.8
+    , http-client-tls >= 0.3.6 && < 0.4
+    , http-types >= 0.12.4 && < 0.13
+    , ldap-client >= 0.4.2 && < 0.5
+    , network >= 3.2.6 && < 3.3
+    , relude >= 1.2.1 && < 1.3
+    , servant >= 0.19 && < 0.21
+    , servant-client >= 0.19 && < 0.21
+    , servant-client-core >= 0.19 && < 0.21
+    , string-conversions >= 0.4.0 && < 0.5
+    , text >= 2.0.2 && < 2.1
+    , tinylog >= 0.15.0 && < 0.16
+    , unordered-containers >= 0.2.20 && < 0.3
+    , yaml >= 0.11.11 && < 0.12
 
   mixins:
     base hiding (Prelude),
@@ -123,16 +123,16 @@ test-suite ldap-scim-bridge-test
   type:             exitcode-stdio-1.0
   build-depends:
     , base
-    , bytestring          >=0.11.5  && <0.12
-    , email-validate      >=2.3.2   && <2.4
-    , hscim               >=0.4.0.2 && <0.5
+    , bytestring
+    , email-validate
+    , hscim
     , hspec
-    , ldap-client         >=0.4.2   && <0.5
+    , ldap-client
     , ldap-scim-bridge
     , QuickCheck
     , string-conversions
-    , text                >=2.0.2   && <2.1
-    , yaml                >=0.11.11 && <0.12
+    , text
+    , yaml
 
   hs-source-dirs:   test
   default-language: Haskell2010
diff --git a/shell.nix b/shell.nix
@@ -1,7 +1,7 @@
 let
   nixpkgs = fetchTarball {
-    url = "https://github.com/NixOS/nixpkgs/archive/7eeacecff44e05a9fd61b9e03836b66ecde8a525.tar.gz";
-    sha256 = "sha256:0f6nv0pgk58d1962r8vswi7ks59fryh0yrdk99d30b3qj11a2045";
+    url = "https://github.com/NixOS/nixpkgs/archive/4f31540079322e6013930b5b2563fd10f96917f0.tar.gz";
+    sha256 = "sha256:12748r3h44hy3a41slm5hcihn1nhrxjlgp75qz6iwzazkxnclx00";
   };
   pkgs = import nixpkgs { config = { }; overlays = [ ]; };
 in
@@ -13,7 +13,7 @@ pkgs.mkShellNoCC rec {
     ghcid
     ghc
     zlib
-    (haskell.lib.justStaticExecutables pkgs.haskell.packages.ghc94.ormolu_0_5_2_0)
+    (haskell.lib.justStaticExecutables haskellPackages.ormolu)
     (haskell.lib.justStaticExecutables haskellPackages.cabal-fmt)
     nixpkgs-fmt
     treefmt

diff --git a/src/LdapScimBridge.hs b/src/LdapScimBridge.hs
@@ -13,6 +13,7 @@ import qualified Data.List
 import qualified Data.Map as Map
 import Data.String.Conversions (cs)
 import qualified Data.String.Conversions as SC
+import qualified Data.Text as Text
 import qualified Data.Text.Encoding as Text
 import qualified Data.Yaml as Yaml
 import qualified GHC.Show
@@ -172,14 +173,27 @@ instance Aeson.FromJSON (PhantomParent Level) where
 instance Aeson.FromJSON BridgeConf
 
 data MappingError
-  = MissingAttr Text
-  | MissingMandatoryValue Text
-  | WrongNumberOfAttrValues Text String Int
-  | CouldNotParseEmail Text String
-  deriving stock (Eq, Show)
+  = MissingMandatoryValue Text Text
+  | WrongNumberOfAttrValues Text Text String Int
+  | CouldNotParseEmail Text Text Text String
+  deriving stock (Eq)
+
+renderMappingError :: MappingError -> String
+renderMappingError (MissingMandatoryValue ldapAttr scimAttr) =
+  "MissingMandatoryValue: " <> Text.unpack ldapAttr <> " -> " <> Text.unpack scimAttr
+renderMappingError (WrongNumberOfAttrValues ldapAttr scimAttr expected actual) =
+  ("Wrong number of attribute values: " <> Text.unpack ldapAttr <> " -> " <> Text.unpack scimAttr)
+    <> (" (got <> " <> show actual <> "; expected " <> expected <> ")")
+renderMappingError (CouldNotParseEmail ldapAttr scimAttr bad err) =
+  ("Could not parse email: " <> Text.unpack ldapAttr <> " -> " <> Text.unpack scimAttr)
+    <> (" (input: " <> show bad <> "; error: " <> err <> ")")
+
+renderSearchError :: [(SearchEntry, MappingError)] -> String
+renderSearchError = show . fmap (\(s, m) -> (s, renderMappingError m))
 
 data FieldMapping = FieldMapping
-  { fieldMappingLabel :: Text,
+  { -- | This is the SCIM label (the LDAP label is in the key of the `Mapping`)
+    fieldMappingLabel :: Text,
     fieldMappingFun ::
       [Text] ->
       Either
@@ -241,20 +255,20 @@ instance Aeson.FromJSON Mapping where
       mapDisplayName ldapFieldName scimFieldName = FieldMapping scimFieldName $
         \case
           [val] -> Right $ \usr -> usr {Scim.displayName = Just val}
-          bad -> Left $ WrongNumberOfAttrValues (ldapFieldName <> " -> " <> scimFieldName) "1" (Prelude.length bad)
+          bad -> Left $ WrongNumberOfAttrValues ldapFieldName scimFieldName "1" (Prelude.length bad)
 
       -- 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 <> " -> " <> scimFieldName) "1" (Prelude.length bad)
+          bad -> Left $ WrongNumberOfAttrValues ldapFieldName scimFieldName "1" (Prelude.length bad)
 
       mapExternalId :: Text -> Text -> FieldMapping
       mapExternalId ldapFieldName scimFieldName = FieldMapping scimFieldName $
         \case
           [val] -> Right $ \usr -> usr {Scim.externalId = Just val}
-          bad -> Left $ WrongNumberOfAttrValues (ldapFieldName <> " -> " <> scimFieldName) "1" (Prelude.length bad)
+          bad -> Left $ WrongNumberOfAttrValues ldapFieldName scimFieldName "1" (Prelude.length bad)
 
       mapEmail :: Text -> Text -> FieldMapping
       mapEmail ldapFieldName scimFieldName = FieldMapping scimFieldName $
@@ -264,13 +278,14 @@ instance Aeson.FromJSON Mapping where
             Right email -> Right $ \usr ->
               usr
                 { Scim.emails =
-                    [Scim.Email Nothing (Scim.EmailAddress2 email) Nothing]
+                    [Scim.Email Nothing (Scim.EmailAddress email) Nothing]
                 }
-            Left err -> Left $ CouldNotParseEmail val err
+            Left err -> Left $ CouldNotParseEmail ldapFieldName scimFieldName val err
           bad ->
             Left $
               WrongNumberOfAttrValues
-                (ldapFieldName <> " -> " <> scimFieldName)
+                ldapFieldName
+                scimFieldName
                 "<=1 (with more than one email, which one should be primary?)"
                 (Prelude.length bad)
 
@@ -279,7 +294,7 @@ instance Aeson.FromJSON Mapping where
         \case
           [] -> Right id
           [val] -> Right $ \usr -> usr {Scim.roles = [val]}
-          bad -> Left $ WrongNumberOfAttrValues (ldapFieldName <> " -> " <> scimFieldName) "1" (Prelude.length bad)
+          bad -> Left $ WrongNumberOfAttrValues ldapFieldName scimFieldName "1" (Prelude.length bad)
 
 type LdapResult a = IO (Either LdapError a)
 
@@ -330,9 +345,21 @@ 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")]
+    guardUserName = do
+      let raw :: [(Text, [FieldMapping])]
+          raw = Map.assocs . fromMapping . mapping $ conf
+
+          fltr :: [(Text, [FieldMapping])] -> [(Text, [FieldMapping])]
+          fltr = filter (\(_, fm) -> (fieldMappingLabel <$> fm) == ["userName"])
+
+          userNameInLdap = case fltr raw of
+            [(ldapName, _)] -> ldapName
+            bad ->
+              -- `userName` is a mandatory field, the `Mapping` parser guarantees that it's always present.
+              error $ "impossible: " <> show bad
+
+      if reqUserName == Strict && Attr userNameInLdap `notElem` (fst <$> toList attrs)
+        then Left [(entry, MissingMandatoryValue userNameInLdap "userName")]
         else Right ()
 
     codec = case ldapCodec (ldapSource conf) of
@@ -387,7 +414,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 Strict conf <$> ldapKeepees)
+      mapM (either (throwIO . ErrorCall . renderSearchError) 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)
@@ -403,7 +430,7 @@ updateScimPeer lgr conf = do
         pure mempty
 
     scims :: [(SearchEntry, User)] <-
-      mapM (either (throwIO . ErrorCall . show) pure) (ldapToScim Lenient conf <$> (ldapDeleteesAttr <> ldapDeleteesDirectory))
+      mapM (either (throwIO . ErrorCall . renderSearchError) 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)
-Original file line number
+Diff line change
@@ -1,3 +1,4 @@
+    /.ghci
     ### Haskell
     dist
     dist-*
@@ Expand Down @@