chore(avs): upsertAvsUser now has a failsafe alternative

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

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

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|

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            

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.Set             as Set
-import qualified Data.Map           as Map
+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
             }

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)
+  deriving newtype (NFData, PathPiece, Csv.ToField, Csv.FromField) 
-instance E.SqlString AvsCardNo
+-- 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 

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