From 453bbd6ce4f9e89d8aa3e20a548ac37290add1db Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 15 Nov 2022 13:12:57 +0100 Subject: [PATCH] chore(avs): upsert avs user continued (WIP) --- src/Foundation/Types.hs | 2 +- src/Handler/Users/Add.hs | 113 +++++++++++++++++++-------------------- src/Handler/Utils/Avs.hs | 53 ++++++++++++------ src/Model/Types/Avs.hs | 4 +- src/Utils/Avs.hs | 11 ++-- 5 files changed, 106 insertions(+), 77 deletions(-) diff --git a/src/Foundation/Types.hs b/src/Foundation/Types.hs index aaa45b153..7e8d9ae6a 100644 --- a/src/Foundation/Types.hs +++ b/src/Foundation/Types.hs @@ -14,7 +14,7 @@ import Import.NoFoundation data UpsertCampusUserMode = UpsertCampusUserLoginLdap | UpsertCampusUserLoginDummy { upsertCampusUserIdent :: UserIdent } - | UpsertCampusUserLoginOther { upsertCampusUserIdent :: UserIdent } + | UpsertCampusUserLoginOther { upsertCampusUserIdent :: UserIdent } -- erlaubt keinen späteren Login | UpsertCampusUserLdapSync { upsertCampusUserIdent :: UserIdent } | UpsertCampusUserGuessUser deriving (Eq, Ord, Read, Show, Generic, Typeable) diff --git a/src/Handler/Users/Add.hs b/src/Handler/Users/Add.hs index df15fb815..d267bd85d 100644 --- a/src/Handler/Users/Add.hs +++ b/src/Handler/Users/Add.hs @@ -4,8 +4,9 @@ module Handler.Users.Add ( getAdminUserAddR, postAdminUserAddR - , AdminUserForm(..), adminUserForm -- no longer needed elsewhere - -- , AuthenticationKind(..), classifyAuth, mkAuthMode -- no longer needed elsewhere + , AdminUserForm(..), AuthenticationKind(..) + , addNewUser + --, adminUserForm , classifyAuth, mkAuthMode -- no longer needed elsewhere ) where @@ -74,66 +75,64 @@ adminUserForm template = renderAForm FormStandard <*> areq (textField & cfStrip & cfCI) (fslI MsgAdminUserIdent) (aufIdent <$> template) <*> areq (selectField optionsFinite) (fslI MsgAdminUserAuth) (aufAuth <$> template <|> Just AuthKindLDAP) +addNewUser :: AdminUserForm -> Handler (Maybe UserId) +addNewUser AdminUserForm{..} = do + now <- liftIO getCurrentTime + UserDefaultConf{..} <- getsYesod $ view _appUserDefaults + let + newUser = User + { userIdent = aufIdent + , userMaxFavourites = userDefaultMaxFavourites + , userMaxFavouriteTerms = userDefaultMaxFavouriteTerms + , userTheme = userDefaultTheme + , userDateTimeFormat = userDefaultDateTimeFormat + , userDateFormat = userDefaultDateFormat + , userTimeFormat = userDefaultTimeFormat + , userDownloadFiles = userDefaultDownloadFiles + , userWarningDays = userDefaultWarningDays + , userShowSex = userDefaultShowSex + , userExamOfficeGetSynced = userDefaultExamOfficeGetSynced + , userExamOfficeGetLabels = userDefaultExamOfficeGetLabels + , userNotificationSettings = def + , userLanguages = Nothing + , userCsvOptions = def + , userTokensIssuedAfter = Nothing + , userCreated = now + , userLastLdapSynchronisation = Nothing + , userLdapPrimaryKey = aufFPersonalNumber + , userLastAuthentication = Nothing + , userEmail = aufEmail + , userDisplayName = aufDisplayName + , userDisplayEmail = aufDisplayEmail + , userFirstName = aufFirstName + , userSurname = aufSurname + , userTitle = aufTitle + , userSex = aufSex + , userMobile = aufMobile + , userTelephone = aufTelephone + , userCompanyPersonalNumber = aufFPersonalNumber + , userCompanyDepartment = aufFDepartment + , userPostAddress = aufPostAddress + , userPrefersPostal = aufPrefersPostal + , userPinPassword = aufPinPassword + , userMatrikelnummer = aufMatriculation + , userAuthentication = mkAuthMode aufAuth + } + runDBJobs . runMaybeT $ do + uid <- MaybeT $ insertUnique newUser + lift . queueDBJob $ JobSynchroniseLdapUser uid + lift . queueDBJob . JobQueueNotification $ NotificationUserAuthModeUpdate uid (newUser ^. _userAuthentication) + when (aufAuth == AuthKindPWHash) $ + lift . queueDBJob $ JobSendPasswordReset uid + return uid + getAdminUserAddR, postAdminUserAddR :: Handler Html getAdminUserAddR = postAdminUserAddR postAdminUserAddR = do ((userRes, userView), userEnctype) <- runFormPost $ adminUserForm Nothing - - formResult userRes $ \AdminUserForm{..} -> do - now <- liftIO getCurrentTime - UserDefaultConf{..} <- getsYesod $ view _appUserDefaults - - let - newUser@User{..} = User - { userIdent = aufIdent - , userMaxFavourites = userDefaultMaxFavourites - , userMaxFavouriteTerms = userDefaultMaxFavouriteTerms - , userTheme = userDefaultTheme - , userDateTimeFormat = userDefaultDateTimeFormat - , userDateFormat = userDefaultDateFormat - , userTimeFormat = userDefaultTimeFormat - , userDownloadFiles = userDefaultDownloadFiles - , userWarningDays = userDefaultWarningDays - , userShowSex = userDefaultShowSex - , userExamOfficeGetSynced = userDefaultExamOfficeGetSynced - , userExamOfficeGetLabels = userDefaultExamOfficeGetLabels - , userNotificationSettings = def - , userLanguages = Nothing - , userCsvOptions = def - , userTokensIssuedAfter = Nothing - , userCreated = now - , userLastLdapSynchronisation = Nothing - , userLdapPrimaryKey = Nothing - , userLastAuthentication = Nothing - , userEmail = aufEmail - , userDisplayName = aufDisplayName - , userDisplayEmail = aufDisplayEmail - , userFirstName = aufFirstName - , userSurname = aufSurname - , userTitle = aufTitle - , userSex = aufSex - , userMobile = aufMobile - , userTelephone = aufTelephone - , userCompanyPersonalNumber = aufFPersonalNumber - , userCompanyDepartment = aufFDepartment - , userPostAddress = aufPostAddress - , userPrefersPostal = aufPrefersPostal - , userPinPassword = aufPinPassword - , userMatrikelnummer = aufMatriculation - , userAuthentication = mkAuthMode aufAuth - } - - didInsert <- runDBJobs . runMaybeT $ do - uid <- MaybeT $ insertUnique newUser - lift . queueDBJob $ JobSynchroniseLdapUser uid - lift . queueDBJob . JobQueueNotification $ NotificationUserAuthModeUpdate uid userAuthentication - when (aufAuth == AuthKindPWHash) $ - lift . queueDBJob $ JobSendPasswordReset uid - return uid - - case didInsert of - Just uid -> do + formResult userRes $ addNewUser >=> \case + (Just uid) -> do addMessageI Success MsgUserAdded cID <- encrypt uid redirect $ AdminUserR cID diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index 7963e8697..0a371b7e7 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -21,7 +21,11 @@ import Utils.Avs import qualified Data.Set as Set import qualified Data.Map as Map --- import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text + +import qualified Data.CaseInsensitive as CI +import Auth.LDAP (ldapUserPrincipalName) +import Foundation.Yesod.Auth (upsertCampusUser,CampusUserConversionException()) import Handler.Users.Add @@ -34,8 +38,10 @@ data AvsException = AvsInterfaceUnavailable -- Interface to AVS was not configured at startup or does not respond | AvsUserUnassociated UserId -- Manipulating AVS Data for a user that is not linked to AVS yet | AvsUserUnknownByAvs AvsPersonId -- AvsPersionId not (or no longer) found in AVS DB + | AvsUserAmbiguous -- Multiple matching existing users found in our DB | AvsPersonSearchEmpty -- AvsPersonSearch returned empty result | AvsPersonSearchAmbiguous -- AvsPersonSearch returned more than one result + deriving (Show, Generic, Typeable) instance Exception AvsException @@ -118,14 +124,30 @@ or -- | Retrieve and _always_ update user by AvsPersonId. Non-existing users are created. -- Throws errors if the avsInterface in unavailable or the user is non-unique within external AVS DB (should never happen). upsertAvsUser :: AvsPersonId -> Handler (Maybe UserId) -upsertAvsUser api = do - mbuid <- runDB $ getBy $ UniqueUserAvsId api +upsertAvsUser api = do mbapd <- lookupAvsUser api + mbuid <- runDB $ do + mbuid <- getBy (UniqueUserAvsId api) + case (mbuid, mbapd) of + (Nothing, Just AvsDataPerson{..}) -- FRADriver User does not exist yet, but found in AVS and has Internal Personal Number + | Just persNo <- avsPersonInternalPersonalNo -> do + candidates <- selectKeysList [UserCompanyPersonalNumber ==. avsPersonInternalPersonalNo] [] + case candidates of + [uid] -> insertUniqueEntity $ UserAvs api uid + (_:_) -> throwM AvsUserAmbiguous + [] -> do + upsRes :: Either CampusUserConversionException (Entity User) <- try $ upsertCampusUser UpsertCampusUserGuessUser [(ldapUserPrincipalName,[Text.encodeUtf8 persNo])] + case upsRes of + Right Entity{entityKey=uid} -> insertUniqueEntity $ UserAvs api uid + _other -> return mbuid -- ==Nothing -- user could not be created somehow + _other -> return mbuid case (mbuid, mbapd) of - ( _ , Nothing) -> throwM $ AvsUserUnknownByAvs api -- this should never happen - (Nothing, Just AvsDataPerson{..}) -> do -- unknown user, must be created - -- if | Just ipn <- avsPersonInternalPersonalNo -> TODO? - let _newUsr = AdminUserForm + ( _ , Nothing ) -> throwM $ AvsUserUnknownByAvs api -- User not found in AVS at all, i.e. no valid card exists yet + (Nothing, Just AvsDataPerson{..}) -> do -- No LDAP User, but found in AVS; create user + let firmAddress = mergeFirmAddress <$> guessLicenceAddress avsPersonPersonCards + bestCard = Set.lookupMax avsPersonPersonCards + fakeIdent = CI.mk $ tshow api + newUsr = AdminUserForm { aufTitle = Nothing , aufFirstName = avsPersonFirstName , aufSurname = avsPersonLastName @@ -137,17 +159,18 @@ upsertAvsUser api = do , aufTelephone = Nothing , aufFPersonalNumber = avsPersonInternalPersonalNo , aufFDepartment = Nothing - , aufPostAddress = error "TODO" -- CONTINUE HERE - , aufPrefersPostal = error "TODO" -- CONTINUE HERE - , aufPinPassword = error "TODO" -- CONTINUE HERE - , aufEmail = "" - , aufIdent = error "TODO" -- CONTINUE HERE - , aufAuth = error "TODO" -- CONTINUE HERE AuthKindNoLogin or AuthKindLDAP if ldap search worked + , aufPostAddress = plaintextToStoredMarkup <$> firmAddress + , aufPrefersPostal = isJust firmAddress + , aufPinPassword = getFullCardNo <$> bestCard + , aufEmail = fakeIdent -- Email is unknown in this version of the avs query, to be updated later (FUTURE TODO) + , aufIdent = fakeIdent -- use AvsPersonId instead + , aufAuth = maybe AuthKindNoLogin (const AuthKindLDAP) avsPersonInternalPersonalNo -- FUTURE TODO: if email is known, use AuthKinfPWHash for email invite, if no internal personal number is known } + _ <- addNewUser newUsr -- _newAvs = UserAvs avsPersonPersonID uid -- _newAvsCards = UserAvsCard - error "TODO" -- CONTINUE HERE - (Just _uid, Just _apd) -> do -- known user + error "TODO" -- CONTINUE HERE + (Just (Entity _ UserAvs{}), Just AvsDataPerson{}) -> -- known user, do some updates error "TODO" -- CONTINUE HERE diff --git a/src/Model/Types/Avs.hs b/src/Model/Types/Avs.hs index 8daaef962..29c2956b1 100644 --- a/src/Model/Types/Avs.hs +++ b/src/Model/Types/Avs.hs @@ -80,7 +80,7 @@ instance FromJSON SloppyBool where -- AVS Datatypes -- ------------------- -type AvsInternalPersonalNo = Text -- type synonym for claritty/documentation within types +type AvsInternalPersonalNo = Text -- type synonym for clarity/documentation within types -- CompleteCardNo = xxxxxxxx.y -- where x is an 8 digit AvsCardNo prefixed by zeros @@ -246,6 +246,8 @@ instance ToJSON AvsDataPersonCard where ] derivePersistFieldJSON ''AvsDataPersonCard +getFullCardNo :: AvsDataPersonCard -> Text +getFullCardNo AvsDataPersonCard{avsDataCardNo, avsDataVersionNo} = avsCardNo avsDataCardNo <> Text.cons '.' avsDataVersionNo data AvsStatusPerson = AvsStatusPerson { avsStatusPersonID :: AvsPersonId diff --git a/src/Utils/Avs.hs b/src/Utils/Avs.hs index 2a4cf06f6..00251aa95 100644 --- a/src/Utils/Avs.hs +++ b/src/Utils/Avs.hs @@ -87,16 +87,21 @@ getValidLicence cutoff licence' cards = Set.lookupMax validLicenceCards cardMatch AvsDataPersonCard{..} = avsDataValid && (avsDataValidTo >= cutoff) && (licence `Set.member` avsDataCardAreas) -guessLicenceAddress :: Set AvsDataPersonCard -> Maybe (Maybe Text, Text) +guessLicenceAddress :: Set AvsDataPersonCard -> Maybe (Maybe Text, Text, AvsDataPersonCard) guessLicenceAddress cards | Just c <- Set.lookupMax cards - , AvsDataPersonCard{..} <- Set.foldr pickLicenceAddress c cards + , card@AvsDataPersonCard{..} <- Set.foldr pickLicenceAddress c cards , Just street <- avsDataStreet , Just pcode <- avsDataPostalCode , Just city <- avsDataCity - = Just (avsDataFirm, Text.unlines [street, Text.unwords [pcode, city]]) + = Just (avsDataFirm, Text.unlines [street, Text.unwords [pcode, city]], card) | otherwise = Nothing +-- | Helper for guessLicenceAddress +mergeFirmAddress :: (Maybe Text, Text, a) -> Text +mergeFirmAddress (Nothing , addr, _) = addr +mergeFirmAddress (Just firm, addr, _) = firm <> Text.cons '\n' addr + hasAddress :: AvsDataPersonCard -> Bool hasAddress AvsDataPersonCard{..} = isJust avsDataStreet && isJust avsDataCity && isJust avsDataPostalCode