refactor(ldap): completed refactoring, userDisplayName no longer contains a comma

src/Foundation/Yesod/Auth.hs

@@ -157,30 +157,35 @@ upsertCampusUser upsertMode ldapData = do
   UserDefaultConf{..} <- getsYesod $ view _appUserDefaults
 
   let
-    ldapMap :: Map.Map Ldap.Attr [Ldap.AttrValue]
+    ldapMap :: Map.Map Ldap.Attr [Ldap.AttrValue] -- Recall: Ldap.AttrValue == ByteString
     ldapMap = Map.fromListWith (++) $ ldapData <&> second (filter (not . ByteString.null))
-    userEmail' :: [Ldap.AttrValue]
-    userEmail' = lookupSome ldapMap $ toList ldapUserEmail    
-    userLdapPrimaryKey' :: [Ldap.AttrValue]  -- ~ [ByteString]
-    userLdapPrimaryKey'        = ldapMap !!! ldapPrimaryKey
-    userIdent''                = ldapMap !!! ldapUserPrincipalName
-    userDisplayName''          = ldapMap !!! ldapUserDisplayName
-    -- userFirstName'             = ldapMap !!! ldapUserFirstName
-    userSurname'               = ldapMap !!! ldapUserSurname
-    userTitle'                 = ldapMap !!! ldapUserTitle
-    userTelephone'             = ldapMap !!! ldapUserTelephone
-    userMobile'                = ldapMap !!! ldapUserMobile
-    userFraportPersonalnummer' = ldapMap !!! ldapUserFraportPersonalnummer
-    userFraportAbteilung'      = ldapMap !!! ldapUserFraportAbteilung
 
-    -- TODO: continue here     
+    -- only accept a single result, throw error otherwise
-    -- decodeLdap1 :: (Exception e) => Ldap.Attr -> e -> m Text
+    -- 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 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
+
+    userTelephone             = decodeLdap ldapUserTelephone
+    userMobile                = decodeLdap ldapUserMobile
+    userCompanyPersonalNumber = decodeLdap ldapUserFraportPersonalnummer
+    userCompanyDepartment     = decodeLdap ldapUserFraportAbteilung
+
     userAuthentication
       | is _UpsertCampusUserLoginOther upsertMode
       = error "Non-LDAP logins should only work for users that are already known"
@@ -189,7 +194,7 @@ upsertCampusUser upsertMode ldapData = do
     isLogin = has (_UpsertCampusUserLoginLdap <> _UpsertCampusUserLoginOther . united) upsertMode
 
   userIdent <- if
-    | [bs] <- userIdent''
+    | [bs] <- ldapMap !!! ldapUserPrincipalName
     , Right userIdent' <- CI.mk <$> Text.decodeUtf8' bs
     , hasn't _upsertCampusUserIdent upsertMode || has (_upsertCampusUserIdent . only userIdent') upsertMode
       -> return userIdent'
@@ -197,66 +202,21 @@ upsertCampusUser upsertMode ldapData = do
       -> return userIdent'
     | otherwise
       -> throwM CampusUserInvalidIdent
+
   userEmail <- if
-    | userEmail : _ <- mapMaybe (assertM (elem '@') . either (const Nothing) Just . Text.decodeUtf8') userEmail'
+    | userEmail : _ <- mapMaybe (assertM (elem '@') . either (const Nothing) Just . Text.decodeUtf8') (lookupSome ldapMap $ toList ldapUserEmail)
       -> return $ CI.mk userEmail
     | otherwise
       -> throwM CampusUserInvalidEmail
   userFirstName <- decodeLdap1 ldapUserFirstName CampusUserInvalidGivenName
-  --userFirstName <- if
+  userSurname   <- decodeLdap1 ldapUserSurname   CampusUserInvalidSurname
-  --  | [bs] <- userFirstName'
+  userTitle     <- decodeLdap' ldapUserTitle     CampusUserInvalidTitle
-  --  , Right userFirstName <- Text.decodeUtf8' bs
+
-  --    -> return userFirstName
+  userDisplayName' <- decodeLdap1 ldapUserDisplayName CampusUserInvalidDisplayName >>= 
-  --  | otherwise
+    (maybeThrow CampusUserInvalidDisplayName . checkDisplayName userTitle userFirstName userSurname)
-  --    -> throwM CampusUserInvalidGivenName
-  userSurname <- if
-    | [bs] <- userSurname'
-    , Right userSurname <- Text.decodeUtf8' bs
-      -> return userSurname
-    | otherwise
-      -> throwM CampusUserInvalidSurname
-  userTitle <- if
-    | [] <- userTitle'
-      -> return Nothing
-    | [bs] <- userTitle'
-    , Right userTitle <- Text.decodeUtf8' bs
-      -> return $ Just userTitle
-    | otherwise
-      -> throwM CampusUserInvalidTitle
-  userDisplayName' <- if
-    | [bs] <- userDisplayName''
-    , Right userDisplayName1 <- Text.decodeUtf8' bs
-    , Just userDisplayName2 <- checkDisplayName userTitle userFirstName userSurname userDisplayName1
-      -> return userDisplayName2
-    | otherwise
-      -> throwM CampusUserInvalidDisplayName
-  userTelephone <- if
-    | [bs] <- userTelephone'
-    , Right userTelephone <- Text.decodeUtf8' bs
-      -> return $ Just userTelephone
-    | otherwise
-      -> return Nothing
-  userMobile <- if
-    | [bs] <- userMobile'
-    , Right userMobile <- Text.decodeUtf8' bs
-      -> return $ Just userMobile
-    | otherwise
-      -> return Nothing
-  userCompanyPersonalNumber  <- if
-    | [bs] <- userFraportPersonalnummer'
-    , Right dt <- Text.decodeUtf8' bs
-      -> return $ Just dt
-    | otherwise
-      -> return Nothing
-  userCompanyDepartment <- if
-    | [bs] <- userFraportAbteilung'
-    , Right dt <- Text.decodeUtf8' bs
-      -> return $ Just dt
-    | otherwise
-      -> return Nothing
 
   userLdapPrimaryKey <- if
-    | [bs] <- userLdapPrimaryKey'
+    | [bs] <- ldapMap !!! ldapPrimaryKey
     , Right userLdapPrimaryKey'' <- Text.decodeUtf8' bs
     , Just userLdapPrimaryKey''' <- assertM' (not . Text.null) $ Text.strip userLdapPrimaryKey''
       -> return $ Just userLdapPrimaryKey'''
@@ -265,33 +225,33 @@ upsertCampusUser upsertMode ldapData = do
 
   let
     newUser = User
-      { userMaxFavourites        = userDefaultMaxFavourites
+      { userMaxFavourites           = userDefaultMaxFavourites
-      , userMaxFavouriteTerms    = userDefaultMaxFavouriteTerms
+      , userMaxFavouriteTerms       = userDefaultMaxFavouriteTerms
-      , userTheme                = userDefaultTheme
+      , userTheme                   = userDefaultTheme
-      , userDateTimeFormat       = userDefaultDateTimeFormat
+      , userDateTimeFormat          = userDefaultDateTimeFormat
-      , userDateFormat           = userDefaultDateFormat
+      , userDateFormat              = userDefaultDateFormat
-      , userTimeFormat           = userDefaultTimeFormat
+      , userTimeFormat              = userDefaultTimeFormat
-      , userDownloadFiles        = userDefaultDownloadFiles
+      , userDownloadFiles           = userDefaultDownloadFiles
-      , userWarningDays          = userDefaultWarningDays
+      , userWarningDays             = userDefaultWarningDays
-      , userShowSex              = userDefaultShowSex
+      , userShowSex                 = userDefaultShowSex
-      , userSex                  = Nothing
+      , userSex                     = Nothing
-      , userExamOfficeGetSynced  = userDefaultExamOfficeGetSynced
+      , userExamOfficeGetSynced     = userDefaultExamOfficeGetSynced
-      , userExamOfficeGetLabels  = userDefaultExamOfficeGetLabels
+      , userExamOfficeGetLabels     = userDefaultExamOfficeGetLabels
-      , userNotificationSettings = def
+      , userNotificationSettings    = def
-      , userLanguages            = Nothing
+      , userLanguages               = Nothing
-      , userCsvOptions           = def
+      , userCsvOptions              = def
-      , userTokensIssuedAfter    = Nothing
+      , userTokensIssuedAfter       = Nothing
-      , userCreated              = now
+      , userCreated                 = now
       , userLastLdapSynchronisation = Just now      
-      , userDisplayName          = userDisplayName'
+      , userDisplayName             = userDisplayName'
-      , userDisplayEmail         = userEmail
+      , userDisplayEmail            = userEmail
-      , userMatrikelnummer       = Nothing -- not known from LDAP, must be derived from REST interface to AVS TODO      
+      , 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
+      , userPostAddress             = Nothing -- not known from LDAP, must be derived from REST interface to AVS TODO
-      , userPrefersPostal        = False
+      , userPrefersPostal           = False
       , ..
       }
     userUpdate =  [
-                  -- UserDisplayName             =. userDisplayName -- never updated, since users are allowed to change their DisplayName
+                  -- UserDisplayName             =. userDisplayName -- not updated here, since users are allowed to change their DisplayName; see line 272
                     UserFirstName               =. userFirstName
                   , UserSurname                 =. userSurname
                   , UserEmail                   =. userEmail
@@ -309,7 +269,7 @@ upsertCampusUser upsertMode ldapData = do
   user@(Entity userId userRec) <- case oldUsers of
     Just [oldUserId] -> updateGetEntity oldUserId userUpdate
     _other           -> upsertBy (UniqueAuthentication userIdent) newUser userUpdate
-  unless (validDisplayName Nothing userFirstName userSurname $ userDisplayName userRec) $
+  unless (validDisplayName userTitle userFirstName userSurname $ userDisplayName userRec) $
     update userId [ UserDisplayName =. userDisplayName' ]
 
   let