diff --git a/models/users.model b/models/users.model index 080004af1..8d3fc92ef 100644 --- a/models/users.model +++ b/models/users.model @@ -84,10 +84,10 @@ UserGroupMember UniqueUserGroupMember group user deriving Generic UserCompany - company CompanyId user UserId - supervisor Bool -- is this user a company supervisor? - UniqueCompanyUser company user + company CompanyId + supervisor Bool -- is this user a company supervisor? + UniqueUserCompany user -- only one company per user is currently allowed deriving Generic UserSupervisor supervisor UserId -- multiple supervisor per trainee possible diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index c68a07d07..7c8660ee2 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -1023,7 +1023,7 @@ mkQualificationsTable = , dbtProj = dbtProjId , dbtColonnade = mconcat [ colSchool (_dbrOutput . _1 . _entityVal . _qualificationSchool) - , sortable (Just "quali") (i18nCell MsgQualificationName) $ qualificationCell <$> view (_dbrOutput . _1 . _entityVal) + , sortable (Just "quali") (i18nCell MsgQualificationName) $ qualificationDescrCell <$> view (_dbrOutput . _1 . _entityVal) , sortable (Just "blocked-due") (i18nCell MsgTableQualificationBlockedDue & cellTooltip MsgTableQualificationBlockedTooltip ) $ qualificationBlockedCell <$> view (_dbrOutput . _2 . _entityVal . _qualificationUserBlockedDue ) , sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) $ dayCell <$> view (_dbrOutput . _2 . _entityVal . _qualificationUserValidUntil ) diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index dbbd5bbaf..b28adcacb 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -117,12 +117,8 @@ checkLicences = do upsertAvsUser :: Text -> Handler (Maybe UserId) --- upsertAvsUser (readAvsFullCardNo -> Just afcn) = upsertAvsUserByCard afcn --- upsertAvsUser someid --- | Just avsid <- discernAvsIds someid --- = upsertAvsUserByCard $ over _Right (const someid) avsid -- Note: Right case is a number, it could be AvsPersonId or AvsInternalPersonalNumber; we cannot discern, but the latter is much more likely and useful! -upsertAvsUser (discernAvsCardPersonalNo -> Just someid) = upsertAvsUserByCard someid -upsertAvsUser _other = return Nothing -- TODO: attempt LDAP lookup to find by eMail; merely for convenience, not necessary now +upsertAvsUser (discernAvsCardPersonalNo -> Just someid) = upsertAvsUserByCard someid -- Note: Right case is a number, it could be AvsPersonId or AvsInternalPersonalNumber; we cannot know, but the latter is much more likely and useful to users! +upsertAvsUser _other = return Nothing -- TODO: attempt LDAP lookup to find by eMail; merely for convenience, not necessary right now {- maybe this code helps? upsRes :: Either CampusUserConversionException (Entity User) <- try $ upsertCampusUserByOther persNo @@ -132,7 +128,27 @@ upsertAvsUser _other = return Nothing -- TODO: attempt LDAP lookup to find by eM -} --- | Retrieve and _always_ update user by AvsPersonId. Non-existing users are created. +-- | Given CardNo or internal Number, retrieve UserId. Create non-existing users, if possible. +-- Throws errors if the avsInterface in unavailable or the user is non-unique within external AVS DB. +upsertAvsUserByCard :: Either AvsFullCardNo AvsInternalPersonalNo -> Handler (Maybe UserId) -- Idee: Eingabe ohne Punkt is AvsInternalPersonalNo mit Punkt is Ausweisnummer?! +upsertAvsUserByCard persNo = do + let qry = case persNo of + Left AvsFullCardNo{..} -> def{ avsPersonQueryCardNo = Just avsFullCardNo, avsPersonQueryVersionNo = Just avsFullCardVersion } + Right fpn -> def{ avsPersonQueryInternalPersonalNo = Just fpn } + AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery + AvsResponsePerson adps <- throwLeftM $ avsQueryPerson qry + case Set.elems adps of + [] -> throwM AvsPersonSearchEmpty + (_:_:_) -> throwM AvsPersonSearchAmbiguous + [AvsDataPerson{avsPersonPersonID=appi}] -> do + mbuid <- runDB $ getBy $ UniqueUserAvsId appi + case mbuid of + (Just (Entity _ UserAvs{userAvsUser=uau})) -> return $ Just uau + Nothing -> upsertAvsUserById appi + + + +-- | Retrieve and _always_ update user by AvsPersonId. Non-existing users are created. Ignore AVS Licence status! Updates Company, Address, PinPassword -- Throws errors if the avsInterface in unavailable or the user is non-unique within external AVS DB (should never happen). upsertAvsUserById :: AvsPersonId -> Handler (Maybe UserId) upsertAvsUserById api = do @@ -150,16 +166,19 @@ upsertAvsUserById api = do upsRes :: Either CampusUserConversionException (Entity User) <- try $ upsertCampusUserByCn persNo case upsRes of - Right Entity{entityKey=uid} -> insertUniqueEntity $ UserAvs api uid + Right Entity{entityKey=uid} -> insertUniqueEntity $ UserAvs api uid -- pin/addr are updated in next step anyway _other -> return mbuid -- ==Nothing -- user could not be created somehow _other -> return mbuid case (mbuid, mbapd) of ( _ , 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 + (Nothing, Just AvsDataPerson{..}) -> do -- No LDAP User, but found in AVS; create new user let firmAddress = guessLicenceAddress avsPersonPersonCards mbCompany = firmAddress ^? _Just . _1 . _Just - bestCard = Set.lookupMax avsPersonPersonCards - fakeIdent = CI.mk $ tshow api + userFirmAddr= plaintextToStoredMarkup . mergeCompanyAddress <$> firmAddress + addrCard = firmAddress ^? _Just . _3 + pinCard = Set.lookupMax avsPersonPersonCards + userPin = tshowAvsFullCardNo . getFullCardNo <$> pinCard + fakeIdent = CI.mk $ "AVSID:" <> tshow api newUsr = AdminUserForm { aufTitle = Nothing , aufFirstName = avsPersonFirstName @@ -172,53 +191,60 @@ upsertAvsUserById api = do , aufTelephone = Nothing , aufFPersonalNumber = avsPersonInternalPersonalNo , aufFDepartment = Nothing - , aufPostAddress = plaintextToStoredMarkup . mergeCompanyAddress <$> firmAddress + , aufPostAddress = userFirmAddr , aufPrefersPostal = isJust firmAddress - , aufPinPassword = tshowAvsFullCardNo . getFullCardNo <$> bestCard + , aufPinPassword = userPin , 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 } mbUid <- addNewUser newUsr -- triggers JobSynchroniseLdapUser, JobSendPasswordReset and NotificationUserAutoModeUpdate -- TODO: check if these are failsafe - case mbUid of - Just uid -> runDB $ do - now <- liftIO getCurrentTime - insert_ $ UserAvs avsPersonPersonID uid - -- forM_ avsPersonPersonCards $ -- save all cards for later - forM_ bestCard $ -- only save the card used to the postal address - \avsCard -> insert_ $ UserAvsCard avsPersonPersonID (avsDataCardNo avsCard) avsCard now - case mbCompany of - Just cpy -> do - cid <- upsertCompany cpy - insert_ $ UserCompany cid uid False - _ -> return () - _ -> return () + whenIsJust mbUid $ \uid -> runDB $ do + now <- liftIO getCurrentTime + insert_ $ UserAvs avsPersonPersonID uid + -- forM_ avsPersonPersonCards $ -- save all cards for later + let cs :: Set AvsDataPersonCard = Set.fromList $ catMaybes [pinCard, addrCard] + forM_ cs $ -- only save used cards for the postal address update detection + \avsCard -> insert_ $ UserAvsCard avsPersonPersonID (avsDataCardNo avsCard) avsCard now + upsertUserCompany uid mbCompany return mbUid - - (Just (Entity _ UserAvs{}), Just AvsDataPerson{}) -> -- known user, do some updates - error "TODO" -- CONTINUE HERE + + (Just (Entity _ UserAvs{userAvsUser=uid}), Just AvsDataPerson{avsPersonPersonCards}) -> do -- known user, update address and pinPassword + let firmAddress = guessLicenceAddress avsPersonPersonCards + mbCompany = firmAddress ^? _Just . _1 . _Just + userFirmAddr= plaintextToStoredMarkup . mergeCompanyAddress <$> firmAddress + addrCard = firmAddress ^? _Just . _3 + pinCard = Set.lookupMax avsPersonPersonCards + userPin = tshowAvsFullCardNo . getFullCardNo <$> pinCard + runDB $ do + now <- liftIO getCurrentTime + upsertUserCompany uid mbCompany + whenIsJust addrCard $ \aCard -> + getBy (UniqueAvsCard $ avsDataCardNo aCard) >>= \case + (Just (Entity uac UserAvsCard{..})) | aCard == userAvsCardCard -> -- address seen before, no change + update uac [UserAvsCardLastSynch =. now] + _ -> do -- possibly new address data + void $ upsert UserAvsCard + { userAvsCardPersonId = api + , userAvsCardCardNo = avsDataCardNo aCard + , userAvsCardCard = aCard + , userAvsCardLastSynch= now + } + [ UserAvsCardCard =. aCard + , UserAvsCardLastSynch =. now + ] + when (isJust userFirmAddr) $ updateWhere [UserId ==. uid] [UserPostAddress =. userFirmAddr] + whenIsJust pinCard $ \pCard -> + unlessM (exists [UserAvsCardCardNo ==. avsDataCardNo pCard]) $ do + -- update pin, but only if it was unset or set to the value of an old card + oldCards <- selectList [UserAvsCardPersonId ==. api] [] + let oldPins = Just . tshowAvsFullCardNo . getFullCardNo . userAvsCardCard . entityVal <$> oldCards + updateWhere [UserId ==. uid, UserPinPassword !=. userPin, UserPinPassword <-. Nothing:oldPins] + [UserPinPassword =. userPin] + insert_ $ UserAvsCard api (avsDataCardNo pCard) pCard now + return $ Just uid --- | Given CardNo or internal Number, retrieve UserId. Create non-existing users, if possible. --- Throws errors if the avsInterface in unavailable or the user is non-unique within external AVS DB. ---upsertAvsUserByCard :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX ) => --- upsertAvsUserByCard :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, WithRunDB SqlReadBackend (HandlerFor UniWorX) m ) -upsertAvsUserByCard :: - Either AvsFullCardNo AvsInternalPersonalNo -> Handler (Maybe UserId) -- Idee: Eingabe ohne Punkt is AvsInternalPersonalNo mit Punkt is Ausweisnummer?! -upsertAvsUserByCard persNo = do - let qry = case persNo of - Left AvsFullCardNo{..} -> def{ avsPersonQueryCardNo = Just avsFullCardNo, avsPersonQueryVersionNo = Just avsFullCardVersion } - Right fpn -> def{ avsPersonQueryInternalPersonalNo = Just fpn } - AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery - AvsResponsePerson adps <- throwLeftM $ avsQueryPerson qry - case Set.elems adps of - [] -> throwM AvsPersonSearchEmpty - (_:_:_) -> throwM AvsPersonSearchAmbiguous - [AvsDataPerson{avsPersonPersonID=appi}] -> do - mbuid <- runDB $ getBy $ UniqueUserAvsId appi - case mbuid of - (Just (Entity _ UserAvs{userAvsUser=uau})) -> return $ Just uau - Nothing -> upsertAvsUserById appi diff --git a/src/Handler/Utils/Company.hs b/src/Handler/Utils/Company.hs index 12fc28ec5..9d55090a0 100644 --- a/src/Handler/Utils/Company.hs +++ b/src/Handler/Utils/Company.hs @@ -13,6 +13,15 @@ import qualified Data.Char as Char import qualified Data.Text as Text +-- | Ensure that the given user is linked to the given company +upsertUserCompany :: UserId -> Maybe Text -> DB () +upsertUserCompany uid (Just cName) | notNull cName = do + cid <- upsertCompany cName + void $ upsertBy (UniqueUserCompany uid) + (UserCompany uid cid False) + [UserCompanyCompany =. cid, UserCompanySupervisor =. False] +upsertUserCompany uid _ = deleteBy (UniqueUserCompany uid) + upsertCompany :: Text -> DB CompanyId upsertCompany cName = let cName' = CI.mk cName in diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index 18dc88120..ac31a99cb 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -272,10 +272,14 @@ courseCell Course{..} = anchorCell link name `mappend` desc |] qualificationCell :: IsDBTable m a => Qualification -> DBCell m a -qualificationCell Qualification{..} = anchorCell link name <> desc +qualificationCell Qualification{..} = anchorCell link name where link = QualificationR qualificationSchool qualificationShorthand name = citext2widget qualificationName + +qualificationDescrCell :: IsDBTable m a => Qualification -> DBCell m a +qualificationDescrCell q@Qualification{..} = qualificationCell q <> desc + where desc = case qualificationDescription of Nothing -> mempty (Just descr) -> spacerCell <> markupCellLargeModal descr diff --git a/src/Handler/Utils/Users.hs b/src/Handler/Utils/Users.hs index c94dda85b..07533158f 100644 --- a/src/Handler/Utils/Users.hs +++ b/src/Handler/Utils/Users.hs @@ -910,12 +910,12 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do -- Companies, in conflict, keep the newUser-Company as is E.insertSelectWithConflict - UniqueCompanyUser + UniqueUserCompany (E.from $ \userCompany -> do E.where_ $ userCompany E.^. UserCompanyUser E.==. E.val oldUserId return $ UserCompany - E.<# (userCompany E.^. UserCompanyCompany) - E.<&> E.val newUserId + E.<# E.val newUserId + E.<&> (userCompany E.^. UserCompanyCompany) E.<&> (userCompany E.^. UserCompanySupervisor) ) (\current _excluded -> [ UserCompanySupervisor E.=. (current E.^. UserCompanySupervisor)] ) diff --git a/src/Utils.hs b/src/Utils.hs index 1fc7301fd..f3eb3f693 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -623,7 +623,8 @@ mTuple = liftA2 (,) -- Lists -- ----------- --- notNull = not . null +notNull :: MonoFoldable mono => mono -> Bool +notNull = not . null headDef :: a -> [a] -> a headDef _ (h:_) = h diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index 0ae3e1db5..832176b31 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -113,7 +113,7 @@ fillDb = do , userShowSex = userDefaultShowSex , userTelephone = Nothing , userMobile = Nothing - , userCompanyPersonalNumber = Nothing + , userCompanyPersonalNumber = Just "00000" , userCompanyDepartment = Nothing , userPinPassword = Nothing , userPostAddress = Nothing @@ -271,7 +271,7 @@ fillDb = do , userShowSex = userDefaultShowSex , userTelephone = Nothing , userMobile = Nothing - , userCompanyPersonalNumber = Nothing + , userCompanyPersonalNumber = Just "12345" , userCompanyDepartment = Nothing , userPinPassword = Nothing , userPostAddress = Nothing