refactor(ldap): make ldap response parsing way more lenient

src/Foundation/Yesod/Auth.hs

@@ -206,6 +206,14 @@ decodeUser now UserDefaultConf{..} upsertMode ldapData = do
       userLastAuthentication = guardOn isLogin now
       isLogin = has (_UpsertCampusUserLoginLdap <> _UpsertCampusUserLoginOther . united) upsertMode
 
+      userTitle       = decodeLdap  ldapUserTitle     -- CampusUserInvalidTitle
+      userFirstName   = decodeLdap' ldapUserFirstName -- CampusUserInvalidGivenName
+      userSurname     = decodeLdap' ldapUserSurname   -- CampusUserInvalidSurname
+    userDisplayName <- decodeLdap1  ldapUserDisplayName  CampusUserInvalidDisplayName  <&> fixDisplayName -- do not check LDAP-given userDisplayName
+
+    --userDisplayName <- decodeLdap1 ldapUserDisplayName CampusUserInvalidDisplayName >>=
+    -- (maybeThrow CampusUserInvalidDisplayName . checkDisplayName userTitle userFirstName userSurname)
+
     userIdent <- if
       | [bs] <- ldapMap !!! ldapUserPrincipalName
       , Right userIdent' <- CI.mk <$> Text.decodeUtf8' bs
@@ -221,12 +229,6 @@ decodeUser now UserDefaultConf{..} upsertMode ldapData = do
         -> return $ CI.mk userEmail
       | otherwise
         -> throwM CampusUserInvalidEmail
-    userFirstName <- decodeLdapN ldapUserFirstName CampusUserInvalidGivenName
-    userSurname   <- decodeLdap1 ldapUserSurname   CampusUserInvalidSurname
-    userTitle     <- decodeLdap' ldapUserTitle     CampusUserInvalidTitle
-
-    userDisplayName' <- decodeLdap1 ldapUserDisplayName CampusUserInvalidDisplayName >>=
-      (maybeThrow CampusUserInvalidDisplayName . checkDisplayName userTitle userFirstName userSurname)
         
     userLdapPrimaryKey <- if
       | [bs] <- ldapMap !!! ldapPrimaryKey
@@ -256,7 +258,7 @@ decodeUser now UserDefaultConf{..} upsertMode ldapData = do
         , userTokensIssuedAfter       = Nothing
         , userCreated                 = now
         , userLastLdapSynchronisation = Just now
-        , userDisplayName             = userDisplayName'
+        , userDisplayName             = userDisplayName
         , userDisplayEmail            = userEmail
         , userMatrikelnummer          = Nothing -- not known from LDAP, must be derived from REST interface to AVS TODO
         , userPostAddress             = Nothing -- not known from LDAP, must be derived from REST interface to AVS TODO
@@ -283,35 +285,38 @@ decodeUser now UserDefaultConf{..} upsertMode ldapData = do
     ldapMap :: Map.Map Ldap.Attr [Ldap.AttrValue] -- Recall: Ldap.AttrValue == ByteString
     ldapMap = Map.fromListWith (++) $ ldapData <&> second (filter (not . ByteString.null))
 
-    -- only accept a single result, throw error otherwise
-    -- decodeLdap1 :: (MonadThrow m, Exception e) => Ldap.Attr -> e -> m Text
-    decodeLdap1 attr err
-      | [bs] <- ldapMap !!! attr
-      , Right t <- Text.decodeUtf8' bs
-        = return t
-      | otherwise = throwM err
-
-    -- accept multiple successful decodings, ignoring all others
-    decodeLdapN attr err
-        | t@(_:_) <- rights vs
-          = return $ Text.unwords t
-        | otherwise = throwM err
-      where
-        vs = Text.decodeUtf8' <$> (ldapMap !!! attr)
-
-    -- accept any successful decoding or empty; only throw an error if all decodings fail
-    -- decodeLdap' :: (Exception e) => Ldap.Attr -> e -> m Text
-    decodeLdap' attr err
-        | []    <-        vs = return   Nothing
-        | (h:_) <- rights vs = return $ Just h
-        | otherwise          = throwM err
-      where
-        vs = Text.decodeUtf8' <$> (ldapMap !!! attr)
-
     -- just returns Nothing on error, pure
     decodeLdap :: Ldap.Attr -> Maybe Text
     decodeLdap attr = listToMaybe . rights $ Text.decodeUtf8' <$> ldapMap !!! attr
 
+    decodeLdap' :: Ldap.Attr -> Text
+    decodeLdap' = fromMaybe "" . decodeLdap
+    -- accept the first successful decoding or empty; only throw an error if all decodings fail
+    -- decodeLdap' :: (Exception e) => Ldap.Attr -> e -> m (Maybe Text)
+    -- decodeLdap' attr err
+    --     | []    <-        vs = return   Nothing
+    --     | (h:_) <- rights vs = return $ Just h
+    --     | otherwise          = throwM err
+    --   where
+    --     vs = Text.decodeUtf8' <$> (ldapMap !!! attr)
+
+    -- only accepts the first successful decoding, ignoring all others, but failing if there is none
+    -- decodeLdap1 :: (MonadThrow m, Exception e) => Ldap.Attr -> e -> m Text
+    decodeLdap1 attr err
+        | (h:_) <- rights vs  = return h
+        | otherwise           = throwM err
+      where
+        vs = Text.decodeUtf8' <$> (ldapMap !!! attr)
+
+    -- accept and merge one or more successful decodings, ignoring all others
+    -- decodeLdapN attr err
+    --     | t@(_:_) <- rights vs
+    --       = return $ Text.unwords t
+    --     | otherwise = throwM err
+    --   where
+    --     vs = Text.decodeUtf8' <$> (ldapMap !!! attr)
+
+
 associateUserSchoolsByTerms :: MonadIO m => UserId -> SqlPersistT m ()
 associateUserSchoolsByTerms uid = do
   sfs <- selectList [StudyFeaturesUser ==. uid] []

src/Handler/Admin/Ldap.hs

@@ -9,7 +9,7 @@ import Import
 -- import qualified Control.Monad.State.Class as State
 -- import Data.Aeson (encode)
 import qualified Data.CaseInsensitive as CI
--- import qualified Data.Text as Text
+import qualified Data.Text as Text
 import qualified Data.Text.Encoding as Text
 -- import qualified Data.Set  as Set
 import Foundation.Yesod.Auth (decodeUserTest)
@@ -57,8 +57,8 @@ postAdminLdapR = do
           else addMessage Info    $ text2Html "Input for LDAP test received."
         fmap join . for ldapPool' $ \ldapPool -> do 
           ldapData <- campusUser'' ldapPool FailoverUnlimited ldapQueryIdent
-          eitherErr <- decodeUserTest (Just $ CI.mk ldapQueryIdent) $ concat ldapData
+          decodedErr <- decodeUserTest (Just $ CI.mk ldapQueryIdent) $ concat ldapData
-          whenIsLeft eitherErr $ addMessageI Error 
+          whenIsLeft decodedErr $ addMessageI Error 
           return ldapData
 
           
@@ -72,6 +72,10 @@ postAdminLdapR = do
                       { formAction = Just $ SomeRoute actionUrl
                       , formEncoding = penctype
                       }
+
+        presentUtf8   lv = Text.intercalate ", " (either tshow id . Text.decodeUtf8' <$> lv)      
+        presentLatin1 lv = Text.intercalate ", " (                 Text.decodeLatin1 <$> lv)
+
     -- TODO: use i18nWidgetFile instead if this is to become permanent
     $(widgetFile "ldap")
 

src/Handler/Profile.hs

@@ -439,8 +439,10 @@ validateSettings :: User -> FormValidator SettingsForm Handler ()
 validateSettings User{..} = do
   userDisplayName' <- use _stgDisplayName
   guardValidation MsgUserDisplayNameInvalid $
+    userDisplayName == userDisplayName' ||  -- unchanged or valid (invalid displayNames delivered by LDAP are preserved)
     validDisplayName userTitle userFirstName userSurname userDisplayName'
     
+
   userPinPassword'  <- use _stgPinPassword
   guardValidation MsgPDFPasswordInvalid $
     validCmdArgument userPinPassword' -- used as CMD argument for pdftk

src/Handler/Utils/Profile.hs

@@ -14,12 +14,16 @@ import qualified Data.Text.Lazy as LT
 import qualified Data.MultiSet as MultiSet
 import qualified Data.Set as Set
 
+-- | Instead of CI.mk, this still allows use of Text.isInfixOf, etc.
+stripFold :: Text -> Text 
+stripFold = Text.toCaseFold . Text.strip
+
 -- | remove last comma and swap order of the two parts, ie. transforming "surname, givennames" into "givennames surname".
 --   Input "givennames surname" is left unchanged, except for removing excess whitespace
 fixDisplayName :: UserDisplayName -> UserDisplayName 
 fixDisplayName udn = 
   let (Text.strip . Text.dropEnd 1 -> surname, Text.strip -> firstnames) = Text.breakOnEnd "," udn 
-  in Text.strip $ firstnames <> Text.cons ' ' surname
+  in Text.toTitle $ Text.strip $ firstnames <> Text.cons ' ' surname
 
 -- | Like `validDisplayName` but may return an automatically corrected name
 checkDisplayName :: Maybe UserTitle -> UserFirstName -> UserSurname -> UserDisplayName -> Maybe UserDisplayName
@@ -32,7 +36,7 @@ validDisplayName :: Maybe UserTitle
                  -> UserSurname
                  -> UserDisplayName
                  -> Bool
-validDisplayName (fmap Text.strip -> mTitle) (Text.strip -> fName) (Text.strip -> sName) (Text.strip -> dName)
+validDisplayName (fmap stripFold -> mTitle) (stripFold -> fName) (stripFold -> sName) (stripFold -> dName)
   = and [ dNameFrags `MultiSet.isSubsetOf` MultiSet.unions [titleFrags, fNameFrags, sNameFrags]
         , sName `Text.isInfixOf` dName
         , all ((<= 1) . Text.length) . filter (Text.any isAdd) $ Text.group dName
@@ -54,6 +58,7 @@ validDisplayName (fmap Text.strip -> mTitle) (Text.strip -> fName) (Text.strip -
     splitAdd = Text.split isAdd
     makeMultiSet = MultiSet.fromList . filter (not . Text.null) . splitAdd
     
+
 -- | Primitive postal address requires at least one alphabetic character, one digit and a line break
 validPostAddress :: Maybe StoredMarkup -> Bool
 validPostAddress (Just StoredMarkup {markupInput = addr})

src/Utils.hs

@@ -275,6 +275,11 @@ addAttrsClass cl attrs = ("class", cl') : noClAttrs
 stripAll :: Text -> Text
 stripAll = Text.filter (not . isSpace)
 
+-- | strip leading and trailing whitespace and make case insensitive
+-- also helps to avoid the need to import just for CI.mk
+stripCI :: Text -> CI Text 
+stripCI = CI.mk . Text.strip
+
 citext2lower :: CI Text -> Text 
 citext2lower = Text.toLower . CI.original
 

templates/ldap.hamlet

@@ -3,9 +3,13 @@
     LDAP Person Search:
     ^{personForm}
   $maybe answers <- mbLdapData
-    <dl>
+    <h1>
       Antwort: #
-      <dl>
+    <dl .deflist>
-        $forall (lk, lv) <- answers
+      $forall (lk, lv) <- answers
-          <dt>#{show lk}
+        <dt>
-          <dd>#{show (fmap Text.decodeUtf8' lv)}
+          #{show lk}
+        <dd>
+          UTF8:  #{presentUtf8 lv}
+          &#8212;
+          Latin: #{presentLatin1 lv}