fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

refactor(avs): rework guessAvsUser

Browse Source
This commit is contained in:
Steffen Jost 2024-04-11 17:39:19 +02:00
parent 4c29150371
commit 1f7c175a58
7 changed files with 263 additions and 223 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
src/Application.hs
View File

@ -124,7 +124,7 @@ import Handler.Utils.Memcached (manageMemcachedLocalInvalidations)
import qualified System.Clock as Clock
import Utils.Avs
import Utils.Avs (mkAvsQuery)
-- Import all relevant handler modules here.
-- (HPack takes care to add new modules to our cabal file nowadays.)

2
src/Foundation/Type.hs
View File

@ -43,7 +43,7 @@ import Data.Time.Clock.POSIX (POSIXTime)
import GHC.Fingerprint (Fingerprint)
import Handler.Sheet.PersonalisedFiles.Types (PersonalisedSheetFilesSeedKey)
import Utils.Avs (AvsQuery)
import Utils.Avs (AvsQuery())
type SMTPPool = Pool SMTPConnection

380
src/Handler/Admin/Avs.hs
View File

@ -28,8 +28,6 @@ import Handler.Utils
import Handler.Utils.Avs
-- import Handler.Utils.Qualification
import Utils.Avs
import Database.Esqueleto.Experimental ((:&)(..))
import qualified Database.Esqueleto.Legacy as E
@ -43,6 +41,13 @@ import qualified Database.Esqueleto.Utils as E
single :: (k,a) -> Map k a
single = uncurry Map.singleton
exceptionWgt :: SomeException -> Widget
exceptionWgt (SomeException e) = [whamlet|<h2>Error:</h2> #{tshow e}|]
tryShow :: MonadCatch m => m Widget -> m Widget
tryShow act = try act >>= \case
Left err -> return $ exceptionWgt err
Right res -> return res
-- Button only needed in AVS TEST; further buttons see below
data ButtonAvsTest = BtnCheckLicences -- | BtnSynchLicences
@ -152,169 +157,155 @@ postAdminAvsR = do
$nothing
AVS nicht konfiguriert!
|]
mAvsQuery <- getsYesod $ view _appAvsQuery
case mAvsQuery of
Nothing -> siteLayoutMsg MsgMenuAvs [whamlet|Error: AVS interface configuration is incomplete.|] -- should never occur after initilisation
Just AvsQuery{..} -> do
((presult, pwidget), penctype) <- runFormPost $ makeAvsPersonForm Nothing
((presult, pwidget), penctype) <- runFormPost $ makeAvsPersonForm Nothing
let procFormPerson fr = do
addMessage Info $ text2Html $ "Query: " <> tshow (toJSON fr)
res <- avsQueryPerson fr
case res of
Left err -> let msg = tshow err in return $ Just [whamlet|<h2>Error:</h2> #{msg}|]
Right (AvsResponsePerson pns) -> return $ Just [whamlet|
<ul>
$forall p <- pns
<li>#{decodeUtf8 (Pretty.encodePretty (toJSON p))}
|]
mbPerson <- formResultMaybe presult procFormPerson
let procFormPerson fr = do
addMessage Info $ text2Html $ "Query: " <> tshow (toJSON fr)
tryShow $ do
AvsResponsePerson pns <- avsQuery fr
return [whamlet|
<ul>
$forall p <- pns
<li>#{decodeUtf8 (Pretty.encodePretty (toJSON p))}
|]
mbPerson <- formResultMaybe presult (Just <<$>> procFormPerson)
((sresult, swidget), senctype) <- runFormPost $ makeAvsStatusForm Nothing
let procFormStatus fr = do
addMessage Info $ text2Html $ "Status Query: " <> tshow (toJSON fr)
res <- avsQueryStatus fr
case res of
Left err -> let msg = tshow err in return $ Just [whamlet|<h2>Error:</h2> #{msg}|]
Right (AvsResponseStatus pns) -> return $ Just [whamlet|
<ul>
$forall p <- pns
<li>#{decodeUtf8 (Pretty.encodePretty (toJSON p))}
|]
mbStatus <- formResultMaybe sresult procFormStatus
((sresult, swidget), senctype) <- runFormPost $ makeAvsStatusForm Nothing
let procFormStatus fr = do
addMessage Info $ text2Html $ "Status Query: " <> tshow (toJSON fr)
tryShow $ do
AvsResponseStatus pns <- avsQuery fr
return [whamlet|
<ul>
$forall p <- pns
<li>#{decodeUtf8 (Pretty.encodePretty (toJSON p))}
|]
mbStatus <- formResultMaybe sresult (Just <<$>> procFormStatus)
((cresult, cwidget), cenctype) <- runFormPost $ makeAvsContactForm Nothing
let procFormContact fr = do
addMessage Info $ text2Html $ "Contact Query: " <> tshow (toJSON fr)
res <- avsQueryContact fr
case res of
Left err -> let msg = tshow err in return $ Just [whamlet|<h2>Error:</h2> #{msg}|]
Right (AvsResponseContact pns) -> return $ Just [whamlet|
<ul>
$forall AvsDataContact{..} <- pns
<li>
<ul>
<li>AvsId: #{tshow avsContactPersonID}
<li>#{decodeUtf8 (Pretty.encodePretty (toJSON avsContactPersonInfo))}
<li>#{decodeUtf8 (Pretty.encodePretty (toJSON avsContactFirmInfo))}
|]
mbContact <- formResultMaybe cresult procFormContact
((crUsrRes, crUsrWgt), crUsrEnctype) <- runFormPost $ identifyForm FIDAvsCreateUser $ \html ->
flip (renderAForm FormStandard) html $ areq textField (fslI MsgAvsCardNo) Nothing
let procFormCrUsr fr = do
-- addMessage Info $ text2Html $ "Query: " <> tshow (toJSON fr)
res <- try $ guessAvsUser fr
case res of
(Right (Just uid)) -> do
uuid :: CryptoUUIDUser <- encrypt uid
return $ Just [whamlet|<h2>Success:</h2> <a href=@{ForProfileR uuid}>User created or updated.|]
(Right Nothing) ->
return $ Just [whamlet|<h2>Warning:</h2> No user found.|]
(Left e) -> do
let msg = tshow (e :: SomeException)
return $ Just [whamlet|<h2>Error:</h2> #{msg}|]
mbCrUser <- formResultMaybe crUsrRes procFormCrUsr
((getLicRes, getLicWgt), getLicEnctype) <- runFormPost $ identifyForm FIDAvsQueryLicence $ \html ->
flip (renderAForm FormStandard) html $ (,,) <$> aopt intField (fslI $ text2message "Min AvsPersonId") Nothing
<*> aopt intField (fslI $ text2message "Max AvsPersonId") Nothing
<*> aopt (selectField $ return avsLicenceOptions) (fslI MsgAvsLicence) Nothing
let procFormGetLic fr = do
res <- avsQueryGetAllLicences
case res of
(Right (AvsResponseGetLicences lics)) -> do
let flics = Set.toList $ Set.filter lfltr lics
lfltr = case fr of -- not pretty, but it'll do
(Just idmin, Just idmax, Just lic) -> \AvsPersonLicence{..} -> (avsLicenceRampLicence == lic) && (avsLicencePersonID `inBetween` (AvsPersonId idmin, AvsPersonId idmax))
(Just idmin, Nothing, Just lic) -> \AvsPersonLicence{..} -> (avsLicenceRampLicence == lic) && (avsLicencePersonID == AvsPersonId idmin)
(Nothing , Just idmax, Just lic) -> \AvsPersonLicence{..} -> (avsLicenceRampLicence == lic) && (avsLicencePersonID == AvsPersonId idmax)
(Nothing , Nothing, Just lic) -> \AvsPersonLicence{..} -> avsLicenceRampLicence == lic
(Just idmin, Just idmax, Nothing ) -> (`inBetween` (AvsPersonId idmin, AvsPersonId idmax)) . avsLicencePersonID
(Just idmin, Nothing, Nothing ) -> (== AvsPersonId idmin) . avsLicencePersonID
(Nothing , Just idmax, Nothing ) -> (== AvsPersonId idmax) . avsLicencePersonID
(Nothing , Nothing, Nothing ) -> const True
addMessage Info $ text2Html $ "Query returned " <> tshow (length flics) <> " licences."
return $ Just [whamlet|
<h2>Success:</h2>
((cresult, cwidget), cenctype) <- runFormPost $ makeAvsContactForm Nothing
let procFormContact fr = do
addMessage Info $ text2Html $ "Contact Query: " <> tshow (toJSON fr)
tryShow $ do
AvsResponseContact pns <- avsQuery fr
return [whamlet|
<ul>
$forall AvsDataContact{..} <- pns
<li>
<ul>
$forall AvsPersonLicence{..} <- flics
<li> #{tshow avsLicencePersonID}: #{licence2char avsLicenceRampLicence}
|]
(Left err) -> do
let msg = tshow err
return $ Just [whamlet|<h2>Error:</h2> #{msg}|]
mbGetLic <- formResultMaybe getLicRes procFormGetLic
((setLicRes, setLicWgt), setLicEnctype) <- runFormPost $ identifyForm FIDAvsSetLicence $ \html ->
flip (renderAForm FormStandard) html $ (,) <$> areq intField (fslI MsgAvsPersonId) Nothing
<*> areq (selectField $ return avsLicenceOptions) (fslI MsgAvsLicence) (Just AvsLicenceVorfeld)
let procFormSetLic (aid, lic) = do
res <- try $ setLicenceAvs (AvsPersonId aid) lic
case res of
(Right True) ->
return $ Just [whamlet|<h2>Success:</h2> Licence #{tshow (licence2char lic)} set for #{tshow aid}.|]
(Right False) ->
return $ Just [whamlet|<h2>Error:</h2> Licence could not be set for #{tshow aid}.|]
(Left e) -> do
let msg = tshow (e :: SomeException)
return $ Just [whamlet|<h2>Error:</h2> #{msg}|]
mbSetLic <- formResultMaybe setLicRes procFormSetLic
<li>AvsId: #{tshow avsContactPersonID}
<li>#{decodeUtf8 (Pretty.encodePretty (toJSON avsContactPersonInfo))}
<li>#{decodeUtf8 (Pretty.encodePretty (toJSON avsContactFirmInfo))}
|]
mbContact <- formResultMaybe cresult (Just <<$>> procFormContact)
(qryLicForm, qryLicRes) <- runButtonForm FIDAvsQueryLicenceDiffs
mbQryLic <- case qryLicRes of
Nothing -> return Nothing
(Just BtnCheckLicences) -> do
res <- try $ do
allLicences <- throwLeftM avsQueryGetAllLicences
computeDifferingLicences allLicences
case res of
(Right diffs) -> do
let showLics l = Text.intercalate ", " $ fmap (tshow . avsLicencePersonID) $ Set.toList $ Set.filter ((l ==) . avsLicenceRampLicence) diffs
r_grant = showLics AvsLicenceRollfeld
f_set = showLics AvsLicenceVorfeld
revoke = showLics AvsNoLicence
return $ Just [whamlet|
<h2>Licence check differences:
<h3>Grant R:
<p>
#{r_grant}
<h3>Set to F:
<p>
#{f_set}
<h3>Revoke licence:
<p>
#{revoke}
|]
(Left e) -> do
let msg = tshow (e :: SomeException)
return $ Just [whamlet|<h2>Licence check error:</h2> #{msg}|]
-- (Just BtnSynchLicences) -> do
-- res <- try synchAvsLicences
-- case res of
-- (Right True) ->
-- return $ Just [whamlet|<h2>Success:</h2> Licences sychronized.|]
-- (Right False) ->
-- return $ Just [whamlet|<h2>Error:</h2> Licences could not be synchronized, see error log.|]
-- (Left e) -> do
-- let msg = tshow (e :: SomeException)
-- return $ Just [whamlet|<h2>Licence synchronisation error:</h2> #{msg}|]
((crUsrRes, crUsrWgt), crUsrEnctype) <- runFormPost $ identifyForm FIDAvsCreateUser $ \html ->
flip (renderAForm FormStandard) html $ areq textField (fslI MsgAvsCardNo) Nothing
let procFormCrUsr fr = do
-- addMessage Info $ text2Html $ "Query: " <> tshow (toJSON fr)
res <- try $ guessAvsUser fr
case res of
(Right (Just uid)) -> do
uuid :: CryptoUUIDUser <- encrypt uid
return $ Just [whamlet|<h2>Success:</h2> <a href=@{ForProfileR uuid}>User created or updated.|]
(Right Nothing) ->
return $ Just [whamlet|<h2>Warning:</h2> No user found.|]
(Left e) -> return $ Just $ exceptionWgt e
mbCrUser <- formResultMaybe crUsrRes procFormCrUsr
actionUrl <- fromMaybe AdminAvsR <$> getCurrentRoute
siteLayoutMsg MsgMenuAvs $ do
setTitleI MsgMenuAvs
let wrapFormHere fw fe = wrapForm fw def { formAction = Just $ SomeRoute actionUrl, formEncoding = fe }
personForm = wrapFormHere pwidget penctype
statusForm = wrapFormHere swidget senctype
contactForm = wrapFormHere cwidget cenctype
crUsrForm = wrapFormHere crUsrWgt crUsrEnctype
getLicForm = wrapFormHere getLicWgt getLicEnctype
setLicForm = wrapFormHere setLicWgt setLicEnctype
-- TODO: use i18nWidgetFile instead if this is to become permanent
$(widgetFile "avs")
((getLicRes, getLicWgt), getLicEnctype) <- runFormPost $ identifyForm FIDAvsQueryLicence $ \html ->
flip (renderAForm FormStandard) html $ (,,) <$> aopt intField (fslI $ text2message "Min AvsPersonId") Nothing
<*> aopt intField (fslI $ text2message "Max AvsPersonId") Nothing
<*> aopt (selectField $ return avsLicenceOptions) (fslI MsgAvsLicence) Nothing
let procFormGetLic fr = tryShow $ do
AvsResponseGetLicences lics <- avsQuery AvsQueryGetAllLicences
let flics = Set.toList $ Set.filter lfltr lics
lfltr = case fr of -- not pretty, but it'll do
(Just idmin, Just idmax, Just lic) -> \AvsPersonLicence{..} -> (avsLicenceRampLicence == lic) && (avsLicencePersonID `inBetween` (AvsPersonId idmin, AvsPersonId idmax))
(Just idmin, Nothing, Just lic) -> \AvsPersonLicence{..} -> (avsLicenceRampLicence == lic) && (avsLicencePersonID == AvsPersonId idmin)
(Nothing , Just idmax, Just lic) -> \AvsPersonLicence{..} -> (avsLicenceRampLicence == lic) && (avsLicencePersonID == AvsPersonId idmax)
(Nothing , Nothing, Just lic) -> \AvsPersonLicence{..} -> avsLicenceRampLicence == lic
(Just idmin, Just idmax, Nothing ) -> (`inBetween` (AvsPersonId idmin, AvsPersonId idmax)) . avsLicencePersonID
(Just idmin, Nothing, Nothing ) -> (== AvsPersonId idmin) . avsLicencePersonID
(Nothing , Just idmax, Nothing ) -> (== AvsPersonId idmax) . avsLicencePersonID
(Nothing , Nothing, Nothing ) -> const True
addMessage Info $ text2Html $ "Query returned " <> tshow (length flics) <> " licences."
return [whamlet|
<h2>Success:</h2>
<ul>
$forall AvsPersonLicence{..} <- flics
<li> #{tshow avsLicencePersonID}: #{licence2char avsLicenceRampLicence}
|]
mbGetLic <- formResultMaybe getLicRes (Just <<$>> procFormGetLic)
((setLicRes, setLicWgt), setLicEnctype) <- runFormPost $ identifyForm FIDAvsSetLicence $ \html ->
flip (renderAForm FormStandard) html $ (,) <$> areq intField (fslI MsgAvsPersonId) Nothing
<*> areq (selectField $ return avsLicenceOptions) (fslI MsgAvsLicence) (Just AvsLicenceVorfeld)
let procFormSetLic (aid, lic) = do
res <- try $ setLicenceAvs (AvsPersonId aid) lic
case res of
(Right True) ->
return $ Just [whamlet|<h2>Success:</h2> Licence #{tshow (licence2char lic)} set for #{tshow aid}.|]
(Right False) ->
return $ Just [whamlet|<h2>Error:</h2> Licence could not be set for #{tshow aid}.|]
(Left e) -> do
let msg = tshow (e :: SomeException)
return $ Just [whamlet|<h2>Error:</h2> #{msg}|]
mbSetLic <- formResultMaybe setLicRes procFormSetLic
(qryLicForm, qryLicRes) <- runButtonForm FIDAvsQueryLicenceDiffs
mbQryLic <- case qryLicRes of
Nothing -> return Nothing
(Just BtnCheckLicences) -> do
res <- try $ do
allLicences <- avsQuery AvsQueryGetAllLicences
computeDifferingLicences allLicences
case res of
(Right diffs) -> do
let showLics l = Text.intercalate ", " $ fmap (tshow . avsLicencePersonID) $ Set.toList $ Set.filter ((l ==) . avsLicenceRampLicence) diffs
r_grant = showLics AvsLicenceRollfeld
f_set = showLics AvsLicenceVorfeld
revoke = showLics AvsNoLicence
return $ Just [whamlet|
<h2>Licence check differences:
<h3>Grant R:
<p>
#{r_grant}
<h3>Set to F:
<p>
#{f_set}
<h3>Revoke licence:
<p>
#{revoke}
|]
(Left e) -> do
let msg = tshow (e :: SomeException)
return $ Just [whamlet|<h2>Licence check error:</h2> #{msg}|]
-- (Just BtnSynchLicences) -> do
-- res <- try synchAvsLicences
-- case res of
-- (Right True) ->
-- return $ Just [whamlet|<h2>Success:</h2> Licences sychronized.|]
-- (Right False) ->
-- return $ Just [whamlet|<h2>Error:</h2> Licences could not be synchronized, see error log.|]
-- (Left e) -> do
-- let msg = tshow (e :: SomeException)
-- return $ Just [whamlet|<h2>Licence synchronisation error:</h2> #{msg}|]
actionUrl <- fromMaybe AdminAvsR <$> getCurrentRoute
siteLayoutMsg MsgMenuAvs $ do
setTitleI MsgMenuAvs
let wrapFormHere fw fe = wrapForm fw def { formAction = Just $ SomeRoute actionUrl, formEncoding = fe }
personForm = wrapFormHere pwidget penctype
statusForm = wrapFormHere swidget senctype
contactForm = wrapFormHere cwidget cenctype
crUsrForm = wrapFormHere crUsrWgt crUsrEnctype
getLicForm = wrapFormHere getLicWgt getLicEnctype
setLicForm = wrapFormHere setLicWgt setLicEnctype
-- TODO: use i18nWidgetFile instead if this is to become permanent
$(widgetFile "avs")
{-
@ -689,48 +680,43 @@ getAdminAvsUserR :: CryptoUUIDUser -> Handler Html
getAdminAvsUserR uuid = do
uid <- decrypt uuid
Entity{entityVal=UserAvs{..}} <- runDB $ getBy404 $ UniqueUserAvsUser uid
mAvsQuery <- getsYesod $ view _appAvsQuery
resWgt <- case mAvsQuery of
Nothing -> return [whamlet|Error: AVS interface configuration is incomplete.|] -- should never occur after initilisation
Just AvsQuery{..} -> do
mbContact <- avsQueryContact $ AvsQueryContact $ Set.singleton $ AvsObjPersonId userAvsPersonId
mbDataPerson <- lookupAvsUser userAvsPersonId
return [whamlet|
<p>
Vorläufige Admin Ansicht AVS Daten.
Ansicht zeigt aktuelle Daten.
Es erfolgte damit aber noch kein Update der FRADrive Daten.
<p>
<dl .deflist>
<dt .deflist__dt>InfoPersonContact <br>
<i>(bevorzugt)
<dd .deflist__dd>
$case mbContact
$of Left err
Fehler: #{tshow err}
$of Right contactInfo
#{decodeUtf8 (Pretty.encodePretty (toJSON contactInfo))}
<dt .deflist__dt>PersonStatus und mehrere PersonSearch <br>
<i>(benötigt mehrere AVS Abfragen)
<dd .deflist__dd>
$maybe dataPerson <- mbDataPerson
#{decodeUtf8 (Pretty.encodePretty (toJSON dataPerson))}
$nothing
Keine Daten erhalten.
<h3>
Provisorische formatierte Ansicht
<p>
Generisch formatierte Ansicht, die zeigt, in welche Richtung die Endansicht gehen könnte.
In der Endansicht wären nur ausgewählte Felder mit besserer Bennenung in einer manuell gewählten Reihenfolge sichtbar.
<p>
^{foldMap jsonWidget mbContact}
<p>
^{foldMap jsonWidget mbDataPerson}
|]
mbContact <- try $ avsQuery $ AvsQueryContact $ Set.singleton $ AvsObjPersonId userAvsPersonId
mbDataPerson <- lookupAvsUser userAvsPersonId
let heading = [whamlet|_{MsgAvsPersonNo} #{userAvsNoPerson}|]
siteLayout heading $ do
setTitle $ toHtml $ show userAvsNoPerson
resWgt
[whamlet|
<p>
Vorläufige Admin Ansicht AVS Daten.
Ansicht zeigt aktuelle Daten.
Es erfolgte damit aber noch kein Update der FRADrive Daten.
<p>
<dl .deflist>
<dt .deflist__dt>InfoPersonContact <br>
<i>(bevorzugt)
<dd .deflist__dd>
$case mbContact
$of Left err
^{exceptionWgt err}
$of Right contactInfo
#{decodeUtf8 (Pretty.encodePretty (toJSON contactInfo))}
<dt .deflist__dt>PersonStatus und mehrere PersonSearch <br>
<i>(benötigt mehrere AVS Abfragen)
<dd .deflist__dd>
$maybe dataPerson <- mbDataPerson
#{decodeUtf8 (Pretty.encodePretty (toJSON dataPerson))}
$nothing
Keine Daten erhalten.
<h3>
Provisorische formatierte Ansicht
<p>
Generisch formatierte Ansicht, die zeigt, in welche Richtung die Endansicht gehen könnte.
In der Endansicht wären nur ausgewählte Felder mit besserer Bennenung in einer manuell gewählten Reihenfolge sichtbar.
<p>
^{foldMap jsonWidget mbContact}
<p>
^{foldMap jsonWidget mbDataPerson}
|]
instance HasEntity (DBRow (Entity UserAvs, Entity User)) User where
hasEntity = _dbrOutput . _2

83
src/Handler/Utils/Avs.hs
View File

@ -12,7 +12,7 @@
module Handler.Utils.Avs
( guessAvsUser
, upsertAvsUser, upsertAvsUserById, upsertAvsUserByCard
, upsertAvsUserById, upsertAvsUserByCard
-- , getLicence, getLicenceDB, getLicenceByAvsId -- not supported by interface
, AvsLicenceDifferences(..)
, setLicence, setLicenceAvs, setLicencesAvs
@ -24,6 +24,7 @@ module Handler.Utils.Avs
, updateReceivers
, AvsPersonIdMapPersonCard
-- CR3
, SomeAvsQuery(..)
, queryAvsCardNo, queryAvsCardNos
) where
@ -76,15 +77,22 @@ instance Exception AvsException
{-
Error Handling: in Addition to AvsException, Servant.ClientError must be expected. Maybe we should wrap it within an AvsException?
-}
handleAvsExceptions = (`catches` handlers)
where
handlers =
[ Handler (\(e::AvsException -> handleAvsException e))
, Handler (\(e::ClientError -> handleClientError e))
]
-}
------------------
-- AVS Handlers --
------------------
{-
-- | 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
-- If an existing User with internal number is found, an AVS update query is executed
guessAvsUser :: Text -> Handler (Maybe UserId)
guessAvsUser (Text.splitAt 6 -> ("AVSID:", avsidTxt)) = ifMaybeM (readMay avsidTxt) Nothing $ \avsidNr ->
let avsid = AvsPersonId avsidNr
@ -108,7 +116,7 @@ guessAvsUser someid = do
-- [justOneCard] -> maybeM (return Nothing) extractUidCard (return $ Just justOneCard)
-- _ -> return Nothing
Just cid@(Left _wholeNumber) ->
maybeUpsertAvsUserByCard cid >>= \case
maybeUpsertAvsUserByCard cid >>= \case
Nothing ->
runDB (selectList [UserCompanyPersonalNumber ==. Just someid] []) >>= \case
[Entity uid _] -> return $ Just uid
@ -124,7 +132,8 @@ guessAvsUser someid = do
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-Address
upsertAvsUser :: Text -> Handler (Maybe UserId) -- TODO: change to Entity
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!
@ -139,7 +148,7 @@ upsertAvsUser otherId = -- attempt LDAP lookup to find by eMail
<|> MaybeT (getKeyBy $ UniqueAuthentication someIdent)
MaybeT $ view (_entityVal . _userAvsPersonId) <<$>> getBy (UniqueUserAvsUser uid)
ifMaybeM apid Nothing upsertAvsUserById
-}
-- | Given CardNo or internal Number, retrieve UserId. Create non-existing users, if possible. Always update.
-- Throws errors if the avsInterface in unavailable or the user is non-unique within external AVS DB.
@ -329,6 +338,14 @@ updateReceivers uid = do
------------------
-- CR3 Functions
--
-- DONE Update UserCompany too
-- DONE #124 Add an old default supervisor to an Admin TODO-List
-- TODO #76 "sekundäre Firma wählen" -- aktuelle Firmen löschen
-- TODO #36 "company postal preference", but for updates only yet
--
-- TODO Adjust dispatchJobSYnchroniseAvsQueue to use updateAvsUserByIds directly, dealing with batches do
-- | `SomeAvsQuery` is an umbrella to unify usage of all AVS queries, since Servant required separate types to fit the existing AVS-VSM API
class SomeAvsQuery q where
@ -463,16 +480,16 @@ updateRecord dbv inp (CheckAvsUpdate up l) =
in dbv & lensRec .~ newval
-- | Update given AvsPersonId by querying AVS for each; update only, no insertion!
-- | Update given AvsPersonId by querying AVS for each; update only, no insertion! Uses batch mechanism
updateAvsUserByIds :: Set AvsPersonId -> DB (Set (AvsPersonId, UserId))
updateAvsUserByIds apids = do
AvsResponseContact adcs <- avsQuery $ AvsQueryContact $ Set.mapMonotonic AvsObjPersonId apids
AvsResponseContact adcs <- avsQuery $ AvsQueryContact $ Set.mapMonotonic AvsObjPersonId apids -- automatically batched!
let requestedAnswers = Set.filter (view (_avsContactPersonID . to (`Set.member` apids))) adcs -- should not occur, neither should one apid occur multiple times within the response (if so, all responses processed here in random order)
res <- foldMapM procResp requestedAnswers
let missing = Set.toList $ Set.difference apids $ Set.map fst res
unless (null missing) $ do
now <- liftIO getCurrentTime
updateWhere [UserAvsPersonId <-. missing] [UserAvsLastSynch =. now, UserAvsLastSynchError =. Just "Contact unknown for AvsPersonId"] -- TODO: last successfull synch
updateWhere [UserAvsPersonId <-. missing] [UserAvsLastSynch =. now, UserAvsLastSynchError =. Just "Contact unknown for AvsPersonId"] -- all others were already marked as updated
return res
where
procResp (AvsDataContact apid newAvsPersonInfo newAvsFirmInfo) = fmap maybeMonoid . runMaybeT $ do
@ -505,12 +522,6 @@ updateAvsUserByIds apids = do
, UserAvsLastPersonInfo =. Just newAvsPersonInfo
, UserAvsLastFirmInfo =. Just newAvsFirmInfo
]
--
-- TODO: Update UserCompany too
-- DONE #124 Add an old default supervisor to an Admin TODO-List
-- TODO #76 "sekundäre Firma wählen" -- aktuelle Firmen löschen
-- TODO #36 "company postal preference"
--
lift $ do -- maybeT no longer needed from here onwards
-- update company association & supervision
Entity{entityKey=newCompanyId, entityVal=newCompany} <- upsertAvsCompany newAvsFirmInfo oldAvsFirmInfo
@ -519,10 +530,10 @@ updateAvsUserByIds apids = do
let oldCompanyId = entityKey <$> oldCompanyEnt
oldCompanyMb = entityVal <$> oldCompanyEnt
pst_up = if
| isJust oldCompanyId && (oldCompanyId == primaryCompanyId)
-> mkUpdate usr newCompany oldCompanyMb $ CheckAvsUpdate UserPrefersPostal _companyPrefersPostal -- possibly change postal preference
| isNothing oldCompanyMb
-> mkUpdateDirect usr newCompany $ CheckAvsUpdate UserPrefersPostal _companyPrefersPostal -- always update if company association is fresh (case should not occur in practice though)
| oldCompanyId == primaryCompanyId -- && isJust oldCompanyId -- is ensured by previous line
-> mkUpdate usr newCompany oldCompanyMb $ CheckAvsUpdate UserPrefersPostal _companyPrefersPostal -- possibly change postal preference
| otherwise
-> Nothing
superReasonComDef = tshow SupervisorReasonCompanyDefault
@ -645,6 +656,44 @@ upsertAvsCompany newAvsFirmInfo mbOldAvsFirmInfo = do
]
-- | 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 update query is executed
guessAvsUser :: Text -> Handler (Maybe UserId)
guessAvsUser (Text.splitAt 6 -> (Text.toUpper -> prefix, readMay -> Just nr))
| prefix=="AVSID:" =
let avsid = AvsPersonId nr in
runDB (getBy $ UniqueUserAvsId avsid) >>= \case
(Just Entity{entityVal=UserAvs{userAvsUser=uid}}) -> return $ Just uid
Nothing -> maybeCatchAll $ upsertAvsUserById avsid
| prefix=="AVSNO:" =
runDB (selectList [UserAvsNoPerson ==. nr] []) <&> \case
[ Entity{entityVal=UserAvs{userAvsUser=uid}}] -> Just uid
_ -> Nothing -- not existing or not unique
guessAvsUser someid@(discernAvsCardPersonalNo -> Just someavsid) =
maybeCatchAll $ upsertAvsUserByCard someavsid >>= \case
Nothing | Left{} <- someavsid -> -- attempt to find PersonalNumber in DB
runDB (selectList [UserCompanyPersonalNumber ==. Just someid] []) <&> \case
[Entity{entityKey=uid}] -> Just uid
_ -> Nothing -- not existing or not unique
other -> return other
guessAvsUser someid = do
try (runDB $ ldapLookupAndUpsert someid) >>= \case
Right Entity{entityKey=uid, entityVal=User{userCompanyPersonalNumber=Just persNo}} -> -- ensure internal user is linked to avs, if possible
maybeCatchAll (upsertAvsUserByCard $ Left $ mkAvsInternalPersonalNo persNo) <&> \case
Nothing -> Just uid
other -> other
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)
-- <|> MaybeT (getKeyBy $ UniqueLdapPrimaryKey someIdent)
-- Licences
setLicence :: (PersistUniqueRead backend, MonadThrow m,
MonadHandler m, HandlerSite m ~ UniWorX,

10
src/Handler/Utils/Table/Columns.hs
View File

@ -819,15 +819,19 @@ fltrAVSCardNos queryUser = Map.singleton "avs-card" fch
cs -> do
let crds = mapMaybe parseAvsCardNo $ foldMap anySeparatedText cs
toutsecs <- getsYesod $ preview $ _appAvsConf . _Just . _avsTimeout
maybeTimeoutHandler toutsecs (queryAvsCardNos crds) >>= \case
maybeTimeoutHandler toutsecs (try $ queryAvsCardNos crds) >>= \case
Nothing -> addMessageI Error MsgAvsCommunicationTimeout
>> return (const E.false)
(Just (null -> True)) -> return (const E.false)
(Just apids) -> return $
(Just (Left err)) -> addMessage Error (someExc2Html err)
>> return (const E.false)
(Just (Right (null -> True))) -> return (const E.false)
(Just (Right apids)) -> return $
\(queryUser -> user) ->
E.exists $ E.from $ \usrAvs ->
E.where_ $ usrAvs E.^. UserAvsUser E.==. user E.^. UserId
E.&&. usrAvs E.^. UserAvsPersonId `E.in_` E.vals apids
someExc2Html :: SomeException -> Html
someExc2Html (SomeException e) = text2Html $ tshow e
fltrAVSCardNosUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text])
fltrAVSCardNosUI mPrev =

7
src/Jobs/Handler/SynchroniseAvs.hs
View File

@ -85,8 +85,9 @@ dispatchJobSynchroniseAvsQueue = JobHandlerException $ do
Just Entity{entityKey=asid, entityVal=AvsSync{..}} -> do
delete asid
getBy (UniqueUserAvsUser avsSyncUser) >>= \case
Just uae@Entity{entityVal=UserAvs{userAvsLastSynch} }
| maybe True (utctDay userAvsLastSynch <) avsSyncPause -> return $ Just uae
Just uae@Entity{entityVal=UserAvs{userAvsLastSynch=_} }
-- | maybe True (utctDay userAvsLastSynch <) avsSyncPause -- TODO: we ignore pauses for now
-> return $ Just uae
_other -> return Nothing -- we just updated this one within the given limit or the entity does not exist
ifMaybeM syncJob () $ \Entity{entityKey=avsKey, entityVal=UserAvs{userAvsPersonId=apid}} -> do
@ -96,7 +97,7 @@ dispatchJobSynchroniseAvsQueue = JobHandlerException $ do
now <- liftIO getCurrentTime
runDB (update avsKey [UserAvsLastSynchError =. Just (tshow exc), UserAvsLastSynch =. now])
case exc of
AvsInterfaceUnavailable -> return () -- ignore and retry later
AvsInterfaceUnavailable -> return () -- ignore and retry later -- TODO won't be retried, since individual job had been deleted
AvsUserUnknownByAvs _ -> return () -- ignore for users no longer listed in AVS
otherExc -> throwM otherExc
)

2
src/Utils/Avs.hs
View File

@ -37,7 +37,7 @@ avsMaxSetLicenceAtOnce :: Int
avsMaxSetLicenceAtOnce = 80 -- maximum input set size for avsQuerySetLicences as enforced by AVS
avsMaxQueryAtOnce :: Int
avsMaxQueryAtOnce = 500 -- maximum input set size for avsQueryStatus as enforced by AVS
avsMaxQueryAtOnce = 500 -- maximum input set size for avsQueryStatus and avsQueryContact as enforced by AVS
avsMaxQueryDelay :: Int
avsMaxQueryDelay = 300000 -- microsecond to wait before sending another AVS query