diff --git a/models/avs.model b/models/avs.model index 138ec250e..371a3dae0 100644 --- a/models/avs.model +++ b/models/avs.model @@ -25,7 +25,7 @@ UserAvs -- Purpose of saving cards is to detect external changes in qualifications and postal addresses UserAvsCard personId AvsPersonId - cardNo AvsCardNo + cardNo AvsFullCardNo card AvsDataPersonCard lastSynch UTCTime UniqueAvsCard cardNo diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs index 32baec476..dda27d0aa 100644 --- a/src/Handler/Admin/Avs.hs +++ b/src/Handler/Admin/Avs.hs @@ -155,7 +155,7 @@ postAdminAvsR = do flip (renderAForm FormStandard) html $ areq textField (fslI MsgAvsCardNo) Nothing let procFormCrUsr fr = do -- addMessage Info $ text2Html $ "Query: " <> tshow (toJSON fr) - res <- try $ upsertAvsUser fr + res <- try $ guessAvsUser fr case res of (Right (Just uid)) -> do uuid :: CryptoUUIDUser <- encrypt uid diff --git a/src/Handler/Course/ParticipantInvite.hs b/src/Handler/Course/ParticipantInvite.hs index 9425ecea1..0e079ec23 100644 --- a/src/Handler/Course/ParticipantInvite.hs +++ b/src/Handler/Course/ParticipantInvite.hs @@ -151,7 +151,7 @@ postCAddUserR tid ssh csh = do return $ AddUserRequest <$> auReqUsers <*> auReqTutorial formResult usersToAdd $ \AddUserRequest{..} -> do - avsUsers :: Map UserSearchKey (Maybe UserId) <- sequenceA $ Map.fromSet upsertAvsUser auReqUsers + avsUsers :: Map UserSearchKey (Maybe UserId) <- sequenceA $ Map.fromSet guessAvsUser auReqUsers let (usersFound, usersNotFound) = partition (is _Just . view _2) $ Map.toList avsUsers unless (null usersNotFound) $ let msgContent = [whamlet| diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index b2cfbd16c..fa83c8ce6 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -344,9 +344,10 @@ postUsersR = do (UserRemoveSupervisorData, userSet) -> do runDB $ deleteWhere [UserSupervisorUser <-. Set.toList userSet] addMessageI Success $ MsgUsersRemoveSupervisors $ Set.size userSet + redirect UsersR (act, usersSet) | isActionSupervisor act -> do - avsUsers :: Map Text (Maybe UserId) <- sequenceA $ Map.fromSet upsertAvsUser $ getActionSupervisors act + avsUsers :: Map Text (Maybe UserId) <- sequenceA $ Map.fromSet guessAvsUser $ getActionSupervisors act let (supersFound, supersNotFound) = partition (is _Just . view _2) $ Map.toList avsUsers users = Set.toList usersSet nrSuperNotFound = length supersNotFound diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index 583981100..4f71f84bd 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -7,6 +7,7 @@ module Handler.Utils.Avs ( validQualification, validQualification' + , guessAvsUser , upsertAvsUser, upsertAvsUserById, upsertAvsUserByCard -- , getLicence, getLicenceDB, getLicenceByAvsId -- not supported by interface , AvsLicenceDifferences(..) @@ -24,15 +25,15 @@ import Import -- import qualified Database.Esqueleto.Legacy as E import Utils.Avs +import Utils.Users -import qualified Data.Set as Set -import qualified Data.Map as Map - +import qualified Data.Set as Set +import qualified Data.Map as Map +import qualified Data.Text as Text import qualified Data.CaseInsensitive as CI -- import Auth.LDAP (ldapUserPrincipalName) import Foundation.Yesod.Auth (ldapLookupAndUpsert) -- , CampusUserConversionException()) -import Utils.Users import Handler.Utils.Company import Database.Esqueleto.Experimental ((:&)(..)) @@ -288,13 +289,50 @@ getDifferingLicences (AvsResponseGetLicences licences) = do set to 2: rollfeld-set && nicht in vorfeld-unset && (in vorfeld-set || AVS_Licence>0 == vorORrollfeld) -} +-- | Find or upsert User by AvsCardId (with dot), Fraport PersonalNumber, Fraport Email-Address or by prefixed AvsId or prefixed AvsNo; fail-safe, may or may not update existing users, may insert new users +-- If an existing User with internal number is found, an AVS query is executed +guessAvsUser :: Text -> Handler (Maybe UserId) +guessAvsUser (Text.splitAt 6 -> ("AVSID:", avsidTxt)) = ifMaybeM (readMay avsidTxt) Nothing $ \avsidNr -> + let avsid = AvsPersonId avsidNr + maybeAvsUpsert = maybeCatchAll $ upsertAvsUserById avsid + extractUid (Entity _ UserAvs{userAvsUser=uid}) = return $ Just uid + in maybeM maybeAvsUpsert extractUid $ runDB $ getBy $ UniqueUserAvsId avsid +guessAvsUser (Text.splitAt 6 -> ("AVSNO:", avsnoTxt)) = ifMaybeM (readMay avsnoTxt) Nothing $ \avsno -> + runDB (selectList [UserAvsNoPerson ==. avsno] []) >>= \case + [Entity _ UserAvs{userAvsUser=uid}] -> return $ Just uid + _ -> return Nothing +guessAvsUser someid = do + let maybeUpsertAvsUserByCard = maybeCatchAll . upsertAvsUserByCard + extractUid (Entity _ UserAvs{userAvsUser=uid}) = return $ Just uid + extractUidCard (Entity _ UserAvsCard{userAvsCardPersonId=avid}) = getBy $ UniqueUserAvsId avid + case discernAvsCardPersonalNo someid of + Just cid@(Left cardNo) -> + maybeM (maybeUpsertAvsUserByCard cid) extractUid $ runDB $ + maybeM (return Nothing) extractUidCard $ getBy $ UniqueAvsCard cardNo + Just cid@(Right _wholeNumber) -> + maybeUpsertAvsUserByCard cid >>= \case + Nothing -> + runDB (selectList [UserCompanyPersonalNumber ==. Just someid] []) >>= \case + [Entity uid _] -> return $ Just uid + _ -> return Nothing + uid -> return uid + Nothing -> try (runDB $ ldapLookupAndUpsert someid) >>= \case + Right Entity{entityKey=uid, entityVal=User{userCompanyPersonalNumber=Just persNo}} -> + maybeM (return $ Just uid) (return . Just) (maybeUpsertAvsUserByCard (Right $ mkAvsInternalPersonalNo persNo)) + Right Entity{entityKey=uid} -> return $ Just uid + other -> do -- attempt to recover by trying other ids + whenIsLeft other (\(err::SomeException) -> $logInfoS "AVS" $ "upsertAvsUser LDAP error " <> tshow err) -- this line primarily forces exception type to catch-all + runDB . runMaybeT $ + let someIdent = stripCI someid + in MaybeT (getKeyBy $ UniqueEmail someIdent) + <|> MaybeT (getKeyBy $ UniqueAuthentication someIdent) --- | Always update AVS Data, accepts AvsCardId (with dot), Fraport PersonalNumber or Fraport Email-Adress +-- | Always update AVS Data, accepts AvsCardId (with dot), Fraport PersonalNumber or Fraport Email-Address upsertAvsUser :: Text -> Handler (Maybe UserId) -- TODO: change to Entity -upsertAvsUser (discernAvsCardPersonalNo -> Just someid) = upsertAvsUserByCard someid -- Note: Right case is any number; it could be AvsCardNumber or AvsInternalPersonalNumber; we cannot know, but the latter is much more likely and useful to users! +upsertAvsUser (discernAvsCardPersonalNo -> Just someid) = maybeCatchAll $ upsertAvsUserByCard someid -- Note: Right case is any number; it could be AvsCardNumber or AvsInternalPersonalNumber; we cannot know, but the latter is much more likely and useful to users! upsertAvsUser otherId = -- attempt LDAP lookup to find by eMail try (runDB $ ldapLookupAndUpsert otherId) >>= \case - Right Entity{entityVal=User{userCompanyPersonalNumber=Just persNo}} -> upsertAvsUserByCard (Right $ mkAvsInternalPersonalNo persNo) + Right Entity{entityVal=User{userCompanyPersonalNumber=Just persNo}} -> maybeCatchAll $ upsertAvsUserByCard (Right $ mkAvsInternalPersonalNo persNo) other -> do -- attempt to recover by trying other ids whenIsLeft other (\(err::SomeException) -> $logInfoS "AVS" $ "upsertAvsUser LDAP error " <> tshow err) -- this line primarily forces exception type to catch-all apid <- runDB . runMaybeT $ do @@ -389,7 +427,7 @@ upsertAvsUserById api = do 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 + \avsCard -> insert_ $ UserAvsCard avsPersonPersonID (getFullCardNo avsCard) avsCard now upsertUserCompany uid mbCompany return mbUid @@ -407,15 +445,15 @@ upsertAvsUserById api = do unless (maybe True (`Set.member` oldAddrs) mbCoFirmAddr) $ do -- update postal address, unless the exact address had been seen before updateWhere [UserId ==. uid] [UserPostAddress =. userFirmAddr] whenIsJust pinCard $ \pCard -> -- update pin, but only if it was unset or set to the value of an old card - unlessM (exists [UserAvsCardCardNo ==. avsDataCardNo pCard]) $ do + unlessM (exists [UserAvsCardCardNo ==. getFullCardNo pCard]) $ do let oldPins = Just . personCard2pin . userAvsCardCard . entityVal <$> oldCards updateWhere [UserId ==. uid, UserPinPassword !=. userPin, UserPinPassword <-. Nothing:oldPins] [UserPinPassword =. userPin] - insert_ $ UserAvsCard api (avsDataCardNo pCard) pCard now + insert_ $ UserAvsCard api (getFullCardNo pCard) pCard now upsertUserCompany uid mbCompany forM_ avsPersonPersonCards $ \aCard -> void $ upsert UserAvsCard { userAvsCardPersonId = api - , userAvsCardCardNo = avsDataCardNo aCard + , userAvsCardCardNo = getFullCardNo aCard , userAvsCardCard = aCard , userAvsCardLastSynch = now } diff --git a/src/Model/Types/Avs.hs b/src/Model/Types/Avs.hs index a836630f1..7e70ccb9c 100644 --- a/src/Model/Types/Avs.hs +++ b/src/Model/Types/Avs.hs @@ -140,8 +140,11 @@ instance {-# OVERLAPS #-} Canonical (Maybe AvsInternalPersonalNo) where type AvsVersionNo = Text -- always 1 digit newtype AvsCardNo = AvsCardNo { avsCardNo :: Text } -- always 8 digits deriving (Eq, Ord, Show, Generic) - deriving newtype (NFData, PathPiece, PersistField, PersistFieldSql, Csv.ToField, Csv.FromField) -instance E.SqlString AvsCardNo + deriving newtype (NFData, PathPiece, Csv.ToField, Csv.FromField) +-- No longer needed: +-- deriving newtype (PersistField, PersistFieldSql) +-- instance E.SqlString AvsCardNo + -- AvsCardNo is an untagged Text with respect to FromJSON/ToJSON, as needed by AVS API instance FromJSON AvsCardNo where parseJSON x = AvsCardNo . normalizeAvsCardNo <$> parseJSON x @@ -156,7 +159,7 @@ instance Canonical AvsCardNo where data AvsFullCardNo = AvsFullCardNo { avsFullCardNo :: AvsCardNo, avsFullCardVersion :: AvsVersionNo } - deriving (Eq, Ord, Generic) + deriving (Eq, Ord, Generic, NFData) tshowAvsFullCardNo :: AvsFullCardNo -> Text tshowAvsFullCardNo AvsFullCardNo{..} = avsCardNo avsFullCardNo <> Text.cons '.' avsFullCardVersion @@ -170,6 +173,16 @@ readAvsFullCardNo (Text.span Char.isDigit -> (c, Text.uncons -> Just ('.',v))) = Just $ AvsFullCardNo (AvsCardNo c) v readAvsFullCardNo _ = Nothing +instance PersistField AvsFullCardNo where + toPersistValue = PersistText . tshowAvsFullCardNo + fromPersistValue (PersistText t) + | Just afc <- readAvsFullCardNo t = Right afc + | otherwise = Left $ "Encoding of AvsFullCardNo is invalid: " <> t + fromPersistValue other = Left $ "Encoding of AvsFullCardNo with invalid type: " <> tshow other + +instance PersistFieldSql AvsFullCardNo where + sqlType _ = SqlString + discernAvsCardPersonalNo :: Text -> Maybe (Either AvsFullCardNo AvsInternalPersonalNo) -- Just implies it is a whole number or decimal with one digit after the point discernAvsCardPersonalNo (Text.span Char.isDigit -> (c, pv)) | Text.null pv diff --git a/src/Utils.hs b/src/Utils.hs index 48a067438..a1108dce7 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -1022,6 +1022,19 @@ actRight (Right y) f = f y -- Exception -- --------------- +-- maybeCatchAll :: MonadCatch m => m a -> m (Maybe a) +-- maybeCatchAll act = catch (Just <$> act) ignore +-- where +-- ignore :: Monad m => SomeException -> m (Maybe a) +-- ignore _ = return Nothing + +-- | Ignore all errors by returning Nothing. (Not sure if this function is a good idea) +maybeCatchAll :: MonadCatch m => m (Maybe a) -> m (Maybe a) +maybeCatchAll act = catch act ignore + where + ignore :: Monad m => SomeException -> m (Maybe a) + ignore _ = return Nothing + maybeExceptT :: Monad m => e -> m (Maybe b) -> ExceptT e m b maybeExceptT err act = lift act >>= maybe (throwE err) return