updateAvsUser (partial) requires migration

config/settings.yml

@@ -91,8 +91,8 @@ study-features-recache-relevance-within: 172800
 study-features-recache-relevance-interval: 293
 
 # Enqueue at specified hour, a few minutes later
-# job-lms-qualifications-enqueue-hour: 15
+job-lms-qualifications-enqueue-hour: 16
-# job-lms-qualifications-dequeue-hour: 3
+job-lms-qualifications-dequeue-hour: 4
 
 log-settings:
   detailed:      "_env:DETAILED_LOGGING:false"

models/avs.model

@@ -16,9 +16,11 @@
 UserAvs
   personId        AvsPersonId -- unique identifier for user throughout avs; newtype for Int  
   user            UserId
-  noPerson        Int         default=0 -- only needed for manual communication with personnel from Ausweisverwaltungsstelle
+  noPerson        Int         default=0 -- only needed for manual communication with personnel from Ausweisverwaltungsstelle, redundant since needed for filtering
   lastSynch       UTCTime     default=now()
   lastSynchError  Text Maybe
+  lastPersonInfo  AvsPersonInfo Maybe -- just to discern field changes
+  lastFirmInfo    AvsFirmInfo   Maybe -- just to discern field changes
   UniqueUserAvsUser user
   UniqueUserAvsId   personId
   deriving Generic Show

src/Handler/Admin/Avs.hs

@@ -740,7 +740,7 @@ getProblemAvsErrorR = do
         dbtSQLQuery (usravs `E.InnerJoin` user) = do
           E.on $ usravs E.^. UserAvsUser E.==. user E.^. UserId
           E.where_ $ E.isJust $ usravs E.^. UserAvsLastSynchError
-          return (usravs, user)
+          return (usravs, user) -- , E.substring (usravs E.^. UserAvsLastSynchError) (E.val ("'#\"%#\" %'") (E.val "#")) -- needs a different type on substring
         qerryUsrAvs :: (E.SqlExpr (Entity UserAvs) `E.InnerJoin` E.SqlExpr (Entity User)) -> E.SqlExpr (Entity UserAvs)
         qerryUsrAvs   = $(E.sqlIJproj 2 1) 
         qerryUser   :: (E.SqlExpr (Entity UserAvs) `E.InnerJoin` E.SqlExpr (Entity User)) -> E.SqlExpr (Entity User)
@@ -748,7 +748,7 @@ getProblemAvsErrorR = do
         reserrUsrAvs :: Lens' (DBRow (Entity UserAvs, Entity User)) (Entity UserAvs)
         reserrUsrAvs  = _dbrOutput . _1
         -- reserrUser   :: Lens' (DBRow (Entity UserAvs, Entity User)) (Entity User)
-        -- reserrUser    = _dbrOutput . _2
+        -- reserrUser    = _dbrOutput . _2        
         dbtRowKey = qerryUsrAvs >>> (E.^. UserAvsId)
         dbtProj = dbtProjId
         dbtColonnade = dbColonnade $ mconcat

src/Handler/Utils/Avs.hs

@@ -4,6 +4,7 @@
 
 {-# LANGUAGE TypeApplications #-}
 
+{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
 
 -- Module for functions directly related to the AVS interface,
 -- for utilities dealing with FraDrive Qualification types see Handler.Utils.Qualification
@@ -417,14 +418,14 @@ upsertAvsUserById api = do
             $logInfoS "AVS" $ "Creating new user with avsInternalPersonalNo " <> tshow persNo
             candidates <- selectKeysList [UserCompanyPersonalNumber ==. Just persNo] []
             case candidates of
-              [uid] -> $logInfoS "AVS" "Matching user found, linking." >> insertUniqueEntity (UserAvs api uid avsPersonPersonNo now Nothing)
+              [uid] -> $logInfoS "AVS" "Matching user found, linking." >> insertUniqueEntity (UserAvs api uid avsPersonPersonNo now Nothing Nothing Nothing) -- TODO info
               (_:_) -> throwM $ AvsUserAmbiguous api
               [] -> do
                 upsRes :: Either SomeException (Entity User)
                   <- try $ ldapLookupAndUpsert persNo
                 $logInfoS "AVS" $ "No matching existing user found. Attempted LDAP upsert returned: " <> tshow upsRes
                 case upsRes of
-                  Right Entity{entityKey=uid} -> insertUniqueEntity $ UserAvs api uid avsPersonPersonNo now Nothing -- pin/addr are updated in next step anyway
+                  Right Entity{entityKey=uid} -> insertUniqueEntity $ UserAvs api uid avsPersonPersonNo now Nothing Nothing Nothing -- pin/addr are updated in next step anyway -- TODO info
                   Left err -> do 
                     $logWarnS "AVS" $ "AVS user with avsInternalPersonalNo " <> tshow persNo <> " not found in LDAP: " <> tshow err
                     return mbuid -- == Nothing -- user could not be created somehow
@@ -464,7 +465,7 @@ upsertAvsUserById api = do
             }
       mbUid <- addNewUser newUsr -- triggers JobSynchroniseLdapUser, JobSendPasswordReset and NotificationUserAutoModeUpdate -- TODO: check if these are failsafe
       whenIsJust mbUid $ \uid -> runDB $ do        
-        insert_ $ UserAvs avsPersonPersonID uid avsPersonPersonNo now Nothing
+        insert_ $ UserAvs avsPersonPersonID uid avsPersonPersonNo now Nothing Nothing Nothing -- TODO info
         forM_ avsPersonPersonCards $ -- save all cards for later comparisons whether an update occurred
         -- let cs :: Set AvsDataPersonCard = Set.fromList $ catMaybes [pinCard, addrCard]
         -- forM_ cs $  -- only save used cards for the postal address update detection
@@ -486,7 +487,7 @@ upsertAvsUserById api = do
                     , UserCompanyPersonalNumber =. avsInternalPersonalNo <$> canonical avsPersonInternalPersonalNo
                     ]     
         oldCards <- selectList [UserAvsCardPersonId ==. api] []
-        let oldAddrs = Set.fromList $ mapMaybe (snd3 . getCompanyAddress . userAvsCardCard . entityVal) oldCards
+        let oldAddrs = Set.fromList $ mapMaybe (snd3 . getCompanyAddress . userAvsCardCard . entityVal) oldCards -- TODO: get rid of getCompanyAddress
         unless (maybe True (`Set.member` oldAddrs) mbCoFirmAddr) $ do  -- update postal address, unless the exact address had been seen before
           encRecipient :: CryptoUUIDUser <- encrypt uid
           $logInfoS "AVS" $ "Postal address updated for" <> tshow encRecipient
@@ -565,3 +566,48 @@ updateReceivers uid = do
       if null receivers
         then directResult
         else return (underling, receivers, uid `elem` (entityKey <$> receivers))
+
+
+------------------
+-- CR3 Functions
+
+updateAvsUserById :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX ) 
+                  => AvsPersonId -> m (Maybe UserId)
+updateAvsUserById apid = do
+  AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery
+  AvsResponseContact adcs <- throwLeftM . avsQueryContact $ AvsQueryContact $ Set.singleton $ AvsObjPersonId apid
+  case Set.elems $ Set.filter ((== apid) . avsContactPersonID) adcs of
+    []      -> throwM AvsPersonSearchEmpty
+    (_:_:_) -> throwM AvsPersonSearchAmbiguous
+    [AvsDataContact _apid _avsPersonInfo _avsFirmInfo] -> do
+      return Nothing -- TODO
+
+updateAvsUserByIds :: Set AvsPersonId -> Handler (Set UserId)
+updateAvsUserByIds apids = do
+    AvsQuery{..} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery
+    AvsResponseContact adcs <- throwLeftM . avsQueryContact $ AvsQueryContact $ Set.mapMonotonic AvsObjPersonId apids
+    foldMapM procResp adcs
+  where 
+    procResp (AvsDataContact apid avsPersonInfo _avsFirmInfo)
+      | apid `Set.notMember` apids = return mempty -- should not occur, neither should one apid occur multiple times withtin the response (if so, all responses processed here in random order)
+      | otherwise = runDB $ 
+          getBy (UniqueUserAvsId apid) >>= continueJust ( \(Entity _ usravs) -> 
+            let usrId = userAvsUser usravs in
+            get usrId >>= continueJust ( \usr -> do
+              let ups = mapMaybe (mkUpdate usr avsPersonInfo $ userAvsLastPersonInfo usravs)
+                          [ (_avsInfoFirstName  , UserFirstName  )
+                          , (_avsInfoLastName   , UserSurname    )
+                          , (_avsInfoDisplayName, UserDisplayName)
+                          -- , (_avsInfoDateOfBirth, UserBirthday   ) -- not polymorphic enough, needs type annotation
+                          ]              
+              update usrId ups
+              return $ Set.singleton usrId
+            ))
+    mkUpdate usr npi (Just opi) (la, up)
+      | let newval = npi ^. la
+      , let oldval = opi ^. la
+      , let usrval = getField up usr
+      , oldval /= newval
+      , oldval == usrval
+      = Just (up =. newval)
+    mkUpdate _ _ _ _ = Nothing

src/Jobs/Handler/LMS.hs

@@ -60,7 +60,7 @@ dispatchJobLmsEnqueue qid = JobHandlerAtomic act
     act = do
       quali <- getJust qid -- may throw an error, aborting the job
       let qshort = CI.original $ qualificationShorthand quali
-      $logInfoS "LMS" $ "Notifying about exipiring qualification " <> qshort
+      $logInfoS "LMS" $ "Notifying about expiring qualification " <> qshort
       now <- liftIO getCurrentTime
       case qualificationRefreshWithin quali of
         Nothing -> return () -- TODO: no renewal period, no reminders currently
@@ -129,7 +129,6 @@ dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act
           qprefix = fst <$> Text.uncons (Text.toLower qshort)
       identsInUseVs <- E.select $ do
         lui <- E.from $
-
           ( (E.^. LmsUserIdent)     <$> E.from (E.table @LmsUser    ) ) -- no filter by Qid, since LmsIdents must be unique across all
           `E.union_`
           ( (E.^. LmsReportIdent)   <$> E.from (E.table @LmsReport  ) ) -- V2

src/Model/Types/Avs.hs

@@ -485,15 +485,24 @@ data AvsPersonInfo = AvsPersonInfo
   { avsInfoPersonNo             :: Text -- Int                  -- AVS Personennummer, zum Gebrauch in menschlicher Kommunikation
   , avsInfoFirstName            :: Text                         -- WARNING: name stored as is, but AVS does contain weird whitespaces
   , avsInfoLastName             :: Text                         -- WARNING: name stored as is, but AVS does contain weird whitespaces
-  , avsInfoRampLicence          :: Int  -- AvsLicence           -- unlike other queries, may return -1 for guest unable to hold a licence; currently not distinquished from no licence
+  , avsInfoRampLicence          :: Int  -- AvsLicence           -- unlike other queries, may return -1 for a guest unable to hold a licence; currently not distinquished from no licence
   , avsInfoDateOfBirth          :: Maybe Day
   , avsInfoPersonEMail          :: Maybe Text
   , avsInfoPersonMobilePhoneNo  :: Maybe Text
   , avsInfoInternalPersonalNo   :: Maybe AvsInternalPersonalNo  -- Fraport Personalnummer
-  } deriving (Eq, Ord, Show, Generic)
+  } deriving (Eq, Ord, Show, Generic, NFData)
 
 makeLenses_ ''AvsPersonInfo
 
+-- | Lens for a virtual DisplayName field. WARNING when used as Setter: Ambiguously the split into First- and LastName will always on the last word given.
+_avsInfoDisplayName :: Lens' AvsPersonInfo Text
+_avsInfoDisplayName = lens g s
+  where
+    g AvsPersonInfo{avsInfoFirstName, avsInfoLastName} = Text.append avsInfoFirstName $ Text.cons ' ' avsInfoLastName
+    s api dn = let (Text.strip -> fn, Text.strip -> ln) = Text.breakOnEnd " " dn 
+               in api{avsInfoFirstName = fn, avsInfoLastName = ln}
+
+
 instance FromJSON AvsPersonInfo where
   parseJSON = withObject "AvsPersonInfo" $ \o -> AvsPersonInfo
     <$> o .:   "PersonsNo"                                      -- NOTE: PersonsNo, not PersonNo as elsewhere
@@ -518,7 +527,7 @@ instance ToJSON AvsPersonInfo where
     , "LastName"    .= avsInfoLastName
     , "RampLicence" .= avsInfoRampLicence
     ]
--- derivePersistFieldJSON ''AvsPersonInfo
+derivePersistFieldJSON ''AvsPersonInfo
 
 
 data AvsFirmCommunication = AvsFirmCommunication
@@ -527,7 +536,7 @@ data AvsFirmCommunication = AvsFirmCommunication
   , avsCommunicationCountry          :: Maybe Text
   , avsCommunicationStreetANDHouseNo :: Maybe Text
   , avsCommunicationEMail            :: Maybe Text
-  } deriving (Eq, Ord, Show, Generic)
+  } deriving (Eq, Ord, Show, Generic, NFData)
 
 instance {-# OVERLAPS #-} Canonical (Maybe AvsFirmCommunication) where
   canonical (Just AvsFirmCommunication{..})
@@ -557,6 +566,7 @@ instance ToJSON AvsFirmCommunication where
     , ("StreetANDHouseNo" .=) <$> avsCommunicationStreetANDHouseNo & canonical
     , ("EMail"            .=) <$> avsCommunicationEMail            & canonical
     ]
+derivePersistFieldJSON ''AvsFirmCommunication
 
 data AvsFirmInfo = AvsFirmInfo
   { avsFirmFirm             :: Text
@@ -569,7 +579,7 @@ data AvsFirmInfo = AvsFirmInfo
   , avsFirmEMail            :: Maybe Text
   , avsFirmEMailSuperior    :: Maybe Text
   , avsFirmCommunication    :: Maybe AvsFirmCommunication
-  } deriving (Eq, Ord, Show, Generic)
+  } deriving (Eq, Ord, Show, Generic, NFData)
 
 makeLenses_ ''AvsFirmInfo
 
@@ -600,7 +610,7 @@ instance ToJSON AvsFirmInfo where
     , "FirmNo"        .= avsFirmFirmNo
     , "Abbreviation"  .= avsFirmAbbreviation
     ]
--- derivePersistFieldJSON ''AvsFirmInfo
+derivePersistFieldJSON ''AvsFirmInfo
 
 
 data AvsDataContact = AvsDataContact

src/Utils.hs

@@ -904,6 +904,11 @@ whenIsJust :: Monad m => Maybe a -> (a -> m ()) -> m ()
 whenIsJust (Just x) f = f x
 whenIsJust Nothing  _ = return ()
 
+-- | synonym for `flip foldMapM`
+continueJust :: (Monoid m, Applicative f) => (a -> f m) -> Maybe a  -> f m
+continueJust f (Just x) = f x
+continueJust _ Nothing  = pure mempty
+
 ifMaybeM :: Monad m => Maybe a -> b -> (a -> m b) -> m b -- more convenient argument order as compared to maybeM
 ifMaybeM Nothing dft _  = return dft
 ifMaybeM (Just x) _ act = act x

src/Utils/Avs.hs

@@ -114,18 +114,18 @@ splitQuery rawQuery q
 -- Utility Functions --
 -----------------------
 
--- | retrieve AvsDataPersonCard with longest validity for a given licence,
+--   retrieve AvsDataPersonCard with longest validity for a given licence,
 --   first argument is a lower bound for avsDataValidTo, usually current day
 --   Note that avsDataValidTo is Nothing if retrieved via AvsResponseStatus (simply use isJust on result in this case)
-getValidLicence :: Maybe Day -> AvsLicence -> Set AvsDataPersonCard -> Maybe AvsDataPersonCard
+-- getValidLicence :: Maybe Day -> AvsLicence -> Set AvsDataPersonCard -> Maybe AvsDataPersonCard
-getValidLicence cutoff licence' cards = Set.lookupMax validLicenceCards
+-- getValidLicence cutoff licence' cards = Set.lookupMax validLicenceCards
-  where
+--   where
-    licence = licence2char licence'
+--     licence = licence2char licence'
-    validLicenceCards = Set.filter cardMatch cards
+--     validLicenceCards = Set.filter cardMatch cards
-    cardMatch AvsDataPersonCard{..} =
+--     cardMatch AvsDataPersonCard{..} =
-      avsDataValid && (avsDataValidTo >= cutoff) && (licence `Set.member` avsDataCardAreas)
+--       avsDataValid && (avsDataValidTo >= cutoff) && (licence `Set.member` avsDataCardAreas)
-
 
+-- | DEPRECTATED
 getCompanyAddress :: AvsDataPersonCard -> (Maybe Text, Maybe Text, Maybe AvsDataPersonCard)
 getCompanyAddress card@AvsDataPersonCard{..} 
   | Just street <- avsDataStreet

src/Utils/DB.hs

@@ -29,6 +29,13 @@ import GHC.Stack (HasCallStack, CallStack, callStack)
 
 -- import Control.Monad.Trans.Reader (withReaderT)
 
+-- | Obtain the record projection from the EntityField value
+getFieldEnt :: PersistEntity record => EntityField record typ -> Entity record -> typ
+getFieldEnt = view . fieldLens
+
+getField :: PersistEntity record => EntityField record typ -> record -> typ
+getField = (. Entity (error "getField required key")) . getFieldEnt
+
 
 emptyOrIn :: PersistField typ
           => E.SqlExpr (E.Value typ) -> Set typ -> E.SqlExpr (E.Value Bool)