refactor(ldap): git merge problem

src/Auth/LDAP.hs

@@ -1,3 +1,5 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
 module Auth.LDAP
   ( apLdap
   , ADError(..), ADInvalidCredentials(..)
@@ -13,6 +15,7 @@ module Auth.LDAP
   , ldapAffiliation
   , ldapUserMobile, ldapUserTelephone
   , ldapUserFraportPersonalnummer, ldapUserFraportAbteilung
+  , ldapUserTitle
   ) where
 
 import Import.NoFoundation
@@ -30,6 +33,9 @@ import qualified Yesod.Auth.Message as Msg
 
 import Auth.LDAP.AD
 
+-- allow Ldap.Attr usage as key for Data.Map
+deriving newtype instance Ord Ldap.Attr
+
 
 data CampusLogin = CampusLogin
   { campusIdent :: CI Text
@@ -72,29 +78,20 @@ userSearchSettings LdapConf{..} = mconcat
   , Ldap.derefAliases Ldap.DerefAlways
   ]
 
-ldapPrimaryKey, ldapUserPrincipalName, ldapUserDisplayName, ldapUserFirstName, ldapUserSurname, ldapAffiliation, ldapUserMobile, ldapUserTelephone, ldapUserFraportPersonalnummer, ldapUserFraportAbteilung  :: Ldap.Attr
+ldapPrimaryKey, ldapUserPrincipalName, ldapUserDisplayName, ldapUserFirstName, ldapUserSurname, ldapAffiliation, ldapUserTitle, ldapUserTelephone,  ldapUserMobile, ldapUserFraportPersonalnummer, ldapUserFraportAbteilung  :: Ldap.Attr
 ldapPrimaryKey            = Ldap.Attr "cn" -- should always be identical to "sAMAccountName"
 ldapUserPrincipalName     = Ldap.Attr "userPrincipalName"
 ldapUserDisplayName       = Ldap.Attr "displayName"
 ldapUserFirstName         = Ldap.Attr "givenName"
 ldapUserSurname           = Ldap.Attr "sn"
 ldapAffiliation           = Ldap.Attr "memberOf"   -- group determine user functions, see Handler.Utils.LdapSystemFunctions.determineSystemFunctions
+ldapUserTitle             = Ldap.Attr "title"      -- not used at Fraport
 -- new 
 ldapUserTelephone             = Ldap.Attr "telephoneNumber"
 ldapUserMobile                = Ldap.Attr "mobile"
 ldapUserFraportPersonalnummer = Ldap.Attr "sAMAccountName"
 ldapUserFraportAbteilung      = Ldap.Attr "department"
 
-{- --outdated to be removed 
-ldapUserMatriculation     = Ldap.Attr "LMU-Stud-Matrikelnummer"
-ldapUserTitle             = Ldap.Attr "title"
-ldapUserStudyFeatures     = Ldap.Attr "dfnEduPersonFeaturesOfStudy"
-ldapUserFieldName         = Ldap.Attr "LMU-Stg-Fach"
-ldapUserSchoolAssociation = Ldap.Attr "LMU-IFI-eduPersonOrgUnitDNString"
-ldapSex                   = Ldap.Attr "schacGender"
-ldapUserSubTermsSemester  = Ldap.Attr "LMU-Stg-FachundFS"
--}
-
 ldapUserEmail :: NonEmpty Ldap.Attr
 ldapUserEmail = Ldap.Attr "mail" :|
   [ Ldap.Attr "userPrincipalName"

src/Foundation/Yesod/Auth.hs

@@ -26,12 +26,13 @@ import qualified Control.Monad.Catch as C (Handler(..))
 import qualified Ldap.Client as Ldap
 import qualified Data.Text as Text
 import qualified Data.Text.Encoding as Text
--- import qualified Data.ByteString as ByteString
+import qualified Data.ByteString as ByteString
 import qualified Data.Set as Set
+import qualified Data.Map as Map
 -- import qualified Data.Conduit.Combinators as C
 
 -- import qualified Data.List as List ((\\))
-  
+
 -- import qualified Data.UUID as UUID
 -- import Data.ByteArray (convert)
 -- import Crypto.Hash (SHAKE128)
@@ -112,7 +113,7 @@ authenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend
     _other
       -> acceptExisting
 
-  
+
 data CampusUserConversionException
   = CampusUserInvalidIdent
   | CampusUserInvalidEmail
@@ -120,7 +121,7 @@ data CampusUserConversionException
   | CampusUserInvalidGivenName
   | CampusUserInvalidSurname
   | CampusUserInvalidTitle
-  | CampusUserInvalidMatriculation  
+  | CampusUserInvalidMatriculation
   | CampusUserInvalidFeaturesOfStudy Text
   | CampusUserInvalidAssociatedSchools Text
   deriving (Eq, Ord, Read, Show, Generic, Typeable)
@@ -155,22 +156,30 @@ upsertCampusUser upsertMode ldapData = do
   now <- liftIO getCurrentTime
   UserDefaultConf{..} <- getsYesod $ view _appUserDefaults
 
-  let    
+  let
-    userEmail'          = fold $ do
+    ldapMap :: Map.Map Ldap.Attr [Ldap.AttrValue]
-      k' <- toList ldapUserEmail
+    ldapMap = Map.fromListWith (++) $ ldapData <&> second (filter (not . ByteString.null))
-      (k, v) <- ldapData
+    userEmail' :: [Ldap.AttrValue]
-      guard $ k' == k
+    userEmail' = lookupSome ldapMap $ toList ldapUserEmail    
-      return v
+    userLdapPrimaryKey' :: [Ldap.AttrValue]  -- ~ [ByteString]
-    -- SJ says: this highly repetitive code needs fefactoring; why not turn ldapData into a Data.Map right away instead of repetitive list iteration?
+    userLdapPrimaryKey'        = ldapMap !!! ldapPrimaryKey
-    userLdapPrimaryKey' = fold [ v | (k, v) <- ldapData, k == ldapPrimaryKey        ]    
+    userIdent''                = ldapMap !!! ldapUserPrincipalName
-    userIdent''         = fold [ v | (k, v) <- ldapData, k == ldapUserPrincipalName ]    
+    userDisplayName''          = ldapMap !!! ldapUserDisplayName
-    userDisplayName''   = fold [ v | (k, v) <- ldapData, k == ldapUserDisplayName   ]
+    -- userFirstName'             = ldapMap !!! ldapUserFirstName
-    userFirstName'      = fold [ v | (k, v) <- ldapData, k == ldapUserFirstName     ]
+    userSurname'               = ldapMap !!! ldapUserSurname
-    userSurname'        = fold [ v | (k, v) <- ldapData, k == ldapUserSurname       ]
+    userTitle'                 = ldapMap !!! ldapUserTitle
-    userTelephone'      = fold [ v | (k, v) <- ldapData, k == ldapUserTelephone     ]
+    userTelephone'             = ldapMap !!! ldapUserTelephone
-    userMobile'         = fold [ v | (k, v) <- ldapData, k == ldapUserMobile        ]
+    userMobile'                = ldapMap !!! ldapUserMobile
-    userFraportPersonalnummer' = fold [ v | (k, v) <- ldapData, k == ldapUserFraportPersonalnummer ]
+    userFraportPersonalnummer' = ldapMap !!! ldapUserFraportPersonalnummer
-    userFraportAbteilung'      = fold [ v | (k, v) <- ldapData, k == ldapUserFraportAbteilung      ]
+    userFraportAbteilung'      = ldapMap !!! ldapUserFraportAbteilung
+
+    -- TODO: continue here 
+    decodeLdap1 :: _hole -- (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 
 
     userAuthentication
       | is _UpsertCampusUserLoginOther upsertMode
@@ -193,45 +202,55 @@ upsertCampusUser upsertMode ldapData = do
       -> return $ CI.mk userEmail
     | otherwise
       -> throwM CampusUserInvalidEmail
-  userDisplayName' <- if
+  userFirstName <- decodeLdap1 ldapUserFirstName CampusUserInvalidGivenName
-    | [bs] <- userDisplayName''
+  --userFirstName <- if
-    , Right userDisplayName' <- Text.decodeUtf8' bs
+  --  | [bs] <- userFirstName'
-      -> return userDisplayName'
+  --  , Right userFirstName <- Text.decodeUtf8' bs
-    | otherwise
+  --    -> return userFirstName
-      -> throwM CampusUserInvalidDisplayName
+  --  | otherwise
-  userFirstName <- if
+  --    -> throwM CampusUserInvalidGivenName
-    | [bs] <- userFirstName'
-    , Right userFirstName <- Text.decodeUtf8' bs
-      -> return userFirstName
-    | otherwise
-      -> throwM CampusUserInvalidGivenName
   userSurname <- if
     | [bs] <- userSurname'
     , Right userSurname <- Text.decodeUtf8' bs
       -> return userSurname
     | otherwise
       -> throwM CampusUserInvalidSurname
-  userTelephone <- if 
+  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 
+    , Right userTelephone <- Text.decodeUtf8' bs
       -> return $ Just userTelephone
     | otherwise
       -> return Nothing
-  userMobile <- if 
+  userMobile <- if
     | [bs] <- userMobile'
-    , Right userMobile <- Text.decodeUtf8' bs 
+    , Right userMobile <- Text.decodeUtf8' bs
       -> return $ Just userMobile
     | otherwise
       -> return Nothing
-  userCompanyPersonalNumber  <- if 
+  userCompanyPersonalNumber  <- if
     | [bs] <- userFraportPersonalnummer'
-    , Right dt <- Text.decodeUtf8' bs 
+    , Right dt <- Text.decodeUtf8' bs
       -> return $ Just dt
     | otherwise
       -> return Nothing
-  userCompanyDepartment <- if 
+  userCompanyDepartment <- if
     | [bs] <- userFraportAbteilung'
-    , Right dt <- Text.decodeUtf8' bs 
+    , Right dt <- Text.decodeUtf8' bs
       -> return $ Just dt
     | otherwise
       -> return Nothing
@@ -266,17 +285,16 @@ upsertCampusUser upsertMode ldapData = do
       , userLastLdapSynchronisation = Just now
       , userDisplayName          = userDisplayName'
       , 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      
-      , userTitle                = Nothing
       , userPostAddress          = Nothing -- not known from LDAP, must be derived from REST interface to AVS TODO
       , userPrefersPostal        = False
       , ..
       }
-    userUpdate =  [ 
+    userUpdate =  [
                   -- UserDisplayName             =. userDisplayName -- never updated, since users are allowed to change their DisplayName
                     UserFirstName               =. userFirstName
-                  , UserSurname                 =. userSurname                  
+                  , UserSurname                 =. userSurname
-                  , UserEmail                   =. userEmail                  
+                  , UserEmail                   =. userEmail
                   , UserLastLdapSynchronisation =. Just now
                   , UserLdapPrimaryKey          =. userLdapPrimaryKey
                   , UserMobile                  =. userMobile
@@ -308,7 +326,7 @@ upsertCampusUser upsertMode ldapData = do
     if | preset -> void $ upsert (UserSystemFunction userId func False False) []
        | otherwise -> deleteWhere [UserSystemFunctionUser ==. userId, UserSystemFunctionFunction ==. func, UserSystemFunctionIsOptOut ==. False, UserSystemFunctionManual ==. False]
 
-  return user  
+  return user
 
 associateUserSchoolsByTerms :: MonadIO m => UserId -> SqlPersistT m ()
 associateUserSchoolsByTerms uid = do
@@ -322,7 +340,7 @@ associateUserSchoolsByTerms uid = do
         , userSchoolSchool   = schoolTermsSchool
         , userSchoolIsOptOut = False
         }
-  
+
 updateUserLanguage :: ( MonadHandler m, HandlerSite m ~ UniWorX
                       , YesodAuth UniWorX
                       , UserId ~ AuthId UniWorX

src/Handler/Utils/Profile.hs

@@ -1,5 +1,7 @@
 module Handler.Utils.Profile
-  ( validDisplayName
+  ( checkDisplayName
+  , validDisplayName
+  , fixDisplayName  
   ) where
 
 import Import.NoFoundation
@@ -8,7 +10,18 @@ import qualified Data.Text as Text
 import qualified Data.MultiSet as MultiSet
 import qualified Data.Set as Set
 
+-- | 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
 
+-- | Like `validDisplayName` but may return an automatically corrected name
+checkDisplayName :: Maybe UserTitle -> UserFirstName -> UserSurname -> UserDisplayName -> Maybe UserDisplayName
+checkDisplayName mTitle fName sName (fixDisplayName -> dName)
+  | validDisplayName mTitle fName sName dName = Just dName
+  | otherwise = Nothing
 
 validDisplayName :: Maybe UserTitle
                  -> UserFirstName
@@ -31,7 +44,7 @@ validDisplayName (fmap Text.strip -> mTitle) (Text.strip -> fName) (Text.strip -
     fNameLetters =          Set.fromList $ unpack  fName
     sNameLetters =          Set.fromList $ unpack  sName
     dNameLetters =          Set.fromList $ unpack  dName
-    addLetters   =          Set.fromList [' ', ',', '.', '-']
+    addLetters   =          Set.fromList [' ', '.', '-']
 
     isAdd = (`Set.member` addLetters)
     splitAdd = Text.split isAdd

src/Jobs/Handler/SendNotification/Qualification.hs

@@ -58,7 +58,7 @@ dispatchNotificationQualificationRenewal nQualification jRecipient = do
   let prepAddress upa = userDisplayName : (upa & html2textlines) -- TODO: use supervisor's address    
       pdfMeta = mkMeta
                   [ toMeta "date"      letterDate
-                  , toMeta "lang"    $ selectDeEn userLanguages -- select German or English, see Utils.Lang
+                  , toMeta "lang"     (selectDeEn userLanguages)    -- select either German or English only, see Utils.Lang
                   , toMeta "login"    (lmsUserIdent & getLmsIdent)
                   , toMeta "pin"       lmsUserPin
                   , toMeta "recipient" userDisplayName

src/Utils.hs

@@ -654,6 +654,11 @@ infixl 5 !!!
 (!!!) :: (Ord k, Monoid v) => Map k v -> k -> v
 (!!!) m k = fromMaybe mempty $ Map.lookup k m
 
+lookupSome :: (Monad m, Ord k, Monoid (m v)) => Map k (m v) -> m k -> m v
+-- lookupSome :: Ord k => Map k [v] -> [k] -> [v] 
+-- lookupSome m ks = ks >>= (m !!!)
+lookupSome = (=<<) . (!!!)
+
 groupMap :: (Ord k, Ord v) => [(k,v)] -> Map k (Set v)
 groupMap l = Map.fromListWith mappend [(k, Set.singleton v) | (k,v) <- l]
 
@@ -888,7 +893,7 @@ actLeft (Left  x) f = f x
 actLeft (Right y) _ = pure $ Right y
 
 -- | like monadic bind for 'Either', but wrapped in another monad
---   ok to use once, otherweise better to use 'Control.Monad.Trans.Except' instead
+--   ok to use once, otherwise better to use 'Control.Monad.Trans.Except' instead
 actRight :: Applicative f => Either a b -> (b -> f (Either a c)) -> f (Either a c)
 actRight (Left  x) _ = pure $ Left x
 actRight (Right y) f = f y