chore(avs): upsert avs user continued (WIP)
This commit is contained in:
Steffen Jost
parent
6f7282b512
commit
453bbd6ce4
@ -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)
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user