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

chore(avs): minor improve avs debugging printout

Browse Source
This commit is contained in:
Steffen Jost 2022-12-14 16:05:03 +01:00
parent 2163ed96d0
commit df1a816d83
2 changed files with 49 additions and 42 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -6,7 +6,7 @@
module Handler.Admin.Avs module Handler.Admin.Avs
( getAdminAvsR, postAdminAvsR ( getAdminAvsR, postAdminAvsR
, getProblemAvsSynchR, postProblemAvsSynchR , getProblemAvsSynchR, postProblemAvsSynchR
) where ) where
import Import import Import
@ -23,7 +23,7 @@ import Utils.Avs
import Database.Esqueleto.Experimental ((:&)(..)) import Database.Esqueleto.Experimental ((:&)(..))
import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Legacy as E
import qualified Database.Esqueleto.Experimental as E hiding (from, on) import qualified Database.Esqueleto.Experimental as E hiding (from, on)
import qualified Database.Esqueleto.Experimental as X (from, on) -- needs TypeApplications Lang-Pragma import qualified Database.Esqueleto.Experimental as X (from, on) -- needs TypeApplications Lang-Pragma
import qualified Database.Esqueleto.Utils as E import qualified Database.Esqueleto.Utils as E
@ -39,7 +39,7 @@ nullaryPathPiece ''ButtonAvsTest camelToPathPiece
instance Button UniWorX ButtonAvsTest where instance Button UniWorX ButtonAvsTest where
btnLabel BtnCheckLicences = "Check all licences" -- could be msg btnLabel BtnCheckLicences = "Check all licences" -- could be msg
btnLabel BtnSynchLicences = "Synchronize all licences" -- could be msg btnLabel BtnSynchLicences = "Synchronize all licences" -- could be msg
btnClasses BtnCheckLicences = [BCIsButton, BCPrimary] btnClasses BtnCheckLicences = [BCIsButton, BCPrimary]
btnClasses BtnSynchLicences = [BCIsButton, BCDanger] btnClasses BtnSynchLicences = [BCIsButton, BCDanger]
-- END Button -- END Button
@ -57,9 +57,9 @@ makeAvsPersonForm tmpl = identifyForm FIDAvsQueryPerson . validateForm validateA
<*> aopt textField (fslI MsgAvsVersionNo) (avsPersonQueryVersionNo <$> tmpl) <*> aopt textField (fslI MsgAvsVersionNo) (avsPersonQueryVersionNo <$> tmpl)
<*> aopt textField (fslI MsgAvsFirstName) (avsPersonQueryFirstName <$> tmpl) <*> aopt textField (fslI MsgAvsFirstName) (avsPersonQueryFirstName <$> tmpl)
<*> aopt textField (fslI MsgAvsLastName) (avsPersonQueryLastName <$> tmpl) <*> aopt textField (fslI MsgAvsLastName) (avsPersonQueryLastName <$> tmpl)
<*> aopt avsInternalPersonalNoField <*> aopt avsInternalPersonalNoField
(fslI MsgAvsInternalPersonalNo) (avsPersonQueryInternalPersonalNo <$> tmpl) (fslI MsgAvsInternalPersonalNo) (avsPersonQueryInternalPersonalNo <$> tmpl)
validateAvsQueryPerson :: FormValidator AvsQueryPerson Handler () validateAvsQueryPerson :: FormValidator AvsQueryPerson Handler ()
validateAvsQueryPerson = do validateAvsQueryPerson = do
@ -113,8 +113,12 @@ postAdminAvsR = do
addMessage Info $ text2Html $ "Query: " <> tshow (toJSON fr) addMessage Info $ text2Html $ "Query: " <> tshow (toJSON fr)
res <- avsQueryPerson fr res <- avsQueryPerson fr
case res of case res of
Left err -> return . Just $ tshow err Left err -> let msg = tshow err in return $ Just [whamlet|<h2>Error:</h2> #{msg}|]
Right jsn -> return . Just $ Text.replace "},Avs" "},\n Avs" $ tshow jsn Right (AvsResponsePerson pns) -> return $ Just [whamlet|
<ul>
$forall p <- pns
<li>#{tshow p}
|]
mbPerson <- formResultMaybe presult procFormPerson mbPerson <- formResultMaybe presult procFormPerson
((sresult, swidget), senctype) <- runFormPost $ makeAvsStatusForm Nothing ((sresult, swidget), senctype) <- runFormPost $ makeAvsStatusForm Nothing
@ -122,8 +126,12 @@ postAdminAvsR = do
addMessage Info $ text2Html $ "Query: " <> tshow (toJSON fr) addMessage Info $ text2Html $ "Query: " <> tshow (toJSON fr)
res <- avsQueryStatus fr res <- avsQueryStatus fr
case res of case res of
Left err -> return . Just $ tshow err Left err -> let msg = tshow err in return $ Just [whamlet|<h2>Error:</h2> #{msg}|]
Right jsn -> return . Just $ Text.replace "},Avs" "},\n Avs" $ tshow jsn Right (AvsResponseStatus pns) -> return $ Just [whamlet|
<ul>
$forall p <- pns
<li>#{tshow p}
|]
mbStatus <- formResultMaybe sresult procFormStatus mbStatus <- formResultMaybe sresult procFormStatus
((crUsrRes, crUsrWgt), crUsrEnctype) <- runFormPost $ identifyForm FIDAvsCreateUser $ \html -> ((crUsrRes, crUsrWgt), crUsrEnctype) <- runFormPost $ identifyForm FIDAvsCreateUser $ \html ->
@ -144,17 +152,17 @@ postAdminAvsR = do
((getLicRes, getLicWgt), getLicEnctype) <- runFormPost $ identifyForm FIDAvsQueryLicence $ \html -> ((getLicRes, getLicWgt), getLicEnctype) <- runFormPost $ identifyForm FIDAvsQueryLicence $ \html ->
flip (renderAForm FormStandard) html $ (,,) <$> aopt intField (fslI $ text2message "Min AvsPersonId") Nothing flip (renderAForm FormStandard) html $ (,,) <$> aopt intField (fslI $ text2message "Min AvsPersonId") Nothing
<*> aopt intField (fslI $ text2message "Max AvsPersonId") Nothing <*> aopt intField (fslI $ text2message "Max AvsPersonId") Nothing
<*> aopt (selectField $ return avsLicenceOptions) (fslI MsgAvsLicence) Nothing <*> aopt (selectField $ return avsLicenceOptions) (fslI MsgAvsLicence) Nothing
let procFormGetLic fr = do let procFormGetLic fr = do
res <- avsQueryGetAllLicences res <- avsQueryGetAllLicences
case res of case res of
(Right (AvsResponseGetLicences lics)) -> do (Right (AvsResponseGetLicences lics)) -> do
let flics = Set.toList $ Set.filter lfltr lics let flics = Set.toList $ Set.filter lfltr lics
lfltr = case fr of -- not pretty, but it'll do 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, Just idmax, Just lic) -> \AvsPersonLicence{..} -> (avsLicenceRampLicence == lic) && (avsLicencePersonID `inBetween` (AvsPersonId idmin, AvsPersonId idmax))
(Just idmin, Nothing, Just lic) -> \AvsPersonLicence{..} -> (avsLicenceRampLicence == lic) && (avsLicencePersonID == AvsPersonId idmin) (Just idmin, Nothing, Just lic) -> \AvsPersonLicence{..} -> (avsLicenceRampLicence == lic) && (avsLicencePersonID == AvsPersonId idmin)
(Nothing , Just idmax, Just lic) -> \AvsPersonLicence{..} -> (avsLicenceRampLicence == lic) && (avsLicencePersonID == AvsPersonId idmax) (Nothing , Just idmax, Just lic) -> \AvsPersonLicence{..} -> (avsLicenceRampLicence == lic) && (avsLicencePersonID == AvsPersonId idmax)
(Nothing , Nothing, Just lic) -> \AvsPersonLicence{..} -> avsLicenceRampLicence == lic (Nothing , Nothing, Just lic) -> \AvsPersonLicence{..} -> avsLicenceRampLicence == lic
(Just idmin, Just idmax, Nothing ) -> (`inBetween` (AvsPersonId idmin, AvsPersonId idmax)) . avsLicencePersonID (Just idmin, Just idmax, Nothing ) -> (`inBetween` (AvsPersonId idmin, AvsPersonId idmax)) . avsLicencePersonID
(Just idmin, Nothing, Nothing ) -> (== AvsPersonId idmin) . avsLicencePersonID (Just idmin, Nothing, Nothing ) -> (== AvsPersonId idmin) . avsLicencePersonID
@ -162,12 +170,12 @@ postAdminAvsR = do
(Nothing , Nothing, Nothing ) -> const True (Nothing , Nothing, Nothing ) -> const True
addMessage Info $ text2Html $ "Query returned " <> tshow (length flics) <> " licences." addMessage Info $ text2Html $ "Query returned " <> tshow (length flics) <> " licences."
return $ Just [whamlet| return $ Just [whamlet|
<h2>Success:</h2> <h2>Success:</h2>
<ul> <ul>
$forall AvsPersonLicence{..} <- flics $forall AvsPersonLicence{..} <- flics
<li> #{tshow avsLicencePersonID}: #{licence2char avsLicenceRampLicence} <li> #{tshow avsLicencePersonID}: #{licence2char avsLicenceRampLicence}
|] |]
(Left err) -> do (Left err) -> do
let msg = tshow err let msg = tshow err
return $ Just [whamlet|<h2>Error:</h2> #{msg}|] return $ Just [whamlet|<h2>Error:</h2> #{msg}|]
@ -192,14 +200,14 @@ postAdminAvsR = do
(qryLicForm, qryLicRes) <- runButtonForm FIDAvsQueryLicenceDiffs (qryLicForm, qryLicRes) <- runButtonForm FIDAvsQueryLicenceDiffs
mbQryLic <- case qryLicRes of mbQryLic <- case qryLicRes of
Nothing -> return Nothing Nothing -> return Nothing
(Just BtnCheckLicences) -> do (Just BtnCheckLicences) -> do
res <- try $ do res <- try $ do
allLicences <- throwLeftM avsQueryGetAllLicences allLicences <- throwLeftM avsQueryGetAllLicences
computeDifferingLicences allLicences computeDifferingLicences allLicences
case res of case res of
(Right diffs) -> do (Right diffs) -> do
let showLics l = Text.intercalate ", " $ fmap (tshow . avsLicencePersonID) $ Set.toList $ Set.filter ((l ==) . avsLicenceRampLicence) diffs let showLics l = Text.intercalate ", " $ fmap (tshow . avsLicencePersonID) $ Set.toList $ Set.filter ((l ==) . avsLicenceRampLicence) diffs
r_grant = showLics AvsLicenceRollfeld r_grant = showLics AvsLicenceRollfeld
f_set = showLics AvsLicenceVorfeld f_set = showLics AvsLicenceVorfeld
@ -212,7 +220,7 @@ postAdminAvsR = do
<h3>Set to F: <h3>Set to F:
<p> <p>
#{f_set} #{f_set}
<h3>Revoke licence: <h3>Revoke licence:
<p> <p>
#{revoke} #{revoke}
|] |]
@ -228,7 +236,7 @@ postAdminAvsR = do
return $ Just [whamlet|<h2>Error:</h2> Licences could not be synchronized, see error log.|] return $ Just [whamlet|<h2>Error:</h2> Licences could not be synchronized, see error log.|]
(Left e) -> do (Left e) -> do
let msg = tshow (e :: SomeException) let msg = tshow (e :: SomeException)
return $ Just [whamlet|<h2>Licence synchronisation error:</h2> #{msg}|] return $ Just [whamlet|<h2>Licence synchronisation error:</h2> #{msg}|]
actionUrl <- fromMaybe AdminAvsR <$> getCurrentRoute actionUrl <- fromMaybe AdminAvsR <$> getCurrentRoute
siteLayoutMsg MsgMenuAvs $ do siteLayoutMsg MsgMenuAvs $ do
@ -238,7 +246,7 @@ postAdminAvsR = do
statusForm = wrapFormHere swidget senctype statusForm = wrapFormHere swidget senctype
crUsrForm = wrapFormHere crUsrWgt crUsrEnctype crUsrForm = wrapFormHere crUsrWgt crUsrEnctype
getLicForm = wrapFormHere getLicWgt getLicEnctype getLicForm = wrapFormHere getLicWgt getLicEnctype
setLicForm = wrapFormHere setLicWgt setLicEnctype setLicForm = wrapFormHere setLicWgt setLicEnctype
-- TODO: use i18nWidgetFile instead if this is to become permanent -- TODO: use i18nWidgetFile instead if this is to become permanent
$(widgetFile "avs") $(widgetFile "avs")
@ -255,7 +263,7 @@ type SynchDBRow = (E.Value AvsPersonId, E.Value AvsLicence, Entity Qualification
-} -}
data ButtonAvsSynch = BtnImportUnknownAvsIds | BtnRevokeAvsLicences data ButtonAvsSynch = BtnImportUnknownAvsIds | BtnRevokeAvsLicences
deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable) deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
instance Universe ButtonAvsSynch instance Universe ButtonAvsSynch
instance Finite ButtonAvsSynch instance Finite ButtonAvsSynch
@ -263,27 +271,27 @@ instance Finite ButtonAvsSynch
nullaryPathPiece ''ButtonAvsSynch camelToPathPiece nullaryPathPiece ''ButtonAvsSynch camelToPathPiece
embedRenderMessage ''UniWorX ''ButtonAvsSynch id embedRenderMessage ''UniWorX ''ButtonAvsSynch id
instance Button UniWorX ButtonAvsSynch where instance Button UniWorX ButtonAvsSynch where
btnClasses BtnImportUnknownAvsIds = [BCIsButton, BCPrimary] btnClasses BtnImportUnknownAvsIds = [BCIsButton, BCPrimary]
btnClasses BtnRevokeAvsLicences = [BCIsButton, BCDanger] btnClasses BtnRevokeAvsLicences = [BCIsButton, BCDanger]
postProblemAvsSynchR, getProblemAvsSynchR :: Handler Html postProblemAvsSynchR, getProblemAvsSynchR :: Handler Html
postProblemAvsSynchR = getProblemAvsSynchR postProblemAvsSynchR = getProblemAvsSynchR
getProblemAvsSynchR = do getProblemAvsSynchR = do
-- TODO: just for Testing -- TODO: just for Testing
-- now <- liftIO getCurrentTime -- now <- liftIO getCurrentTime
-- let TimeOfDay hours minutes _seconds = timeToTimeOfDay (utctDayTime now) -- let TimeOfDay hours minutes _seconds = timeToTimeOfDay (utctDayTime now)
-- setTo0 = Set.fromList [AvsPersonId hours, AvsPersonId minutes] -- setTo0 = Set.fromList [AvsPersonId hours, AvsPersonId minutes]
(setTo0, _setTo1, _setTo2) <- try retrieveDifferingLicences >>= \case (setTo0, _setTo1, _setTo2) <- try retrieveDifferingLicences >>= \case
Right res -> return res Right res -> return res
Left err -> do addMessageModal Error (i18n MsgAvsCommunicationError) (Right (text2widget $ tshow (err :: SomeException))) Left err -> do addMessageModal Error (i18n MsgAvsCommunicationError) (Right (text2widget $ tshow (err :: SomeException)))
redirect AdminR redirect AdminR
unknownLicenceOwners' <- whenNonEmpty setTo0 $ \neZeros -> unknownLicenceOwners' <- whenNonEmpty setTo0 $ \neZeros ->
runDB $ E.select $ do runDB $ E.select $ do
(toZero :& usrAvs) <- X.from $ (toZero :& usrAvs) <- X.from $
E.toValues neZeros `E.leftJoin` E.table @UserAvs E.toValues neZeros `E.leftJoin` E.table @UserAvs
`X.on` (\(toZero :& usrAvs) -> usrAvs E.?. UserAvsPersonId E.==. E.just toZero) `X.on` (\(toZero :& usrAvs) -> usrAvs E.?. UserAvsPersonId E.==. E.just toZero)
E.where_ $ E.isNothing (usrAvs E.?. UserAvsPersonId) E.where_ $ E.isNothing (usrAvs E.?. UserAvsPersonId)
@ -291,19 +299,19 @@ getProblemAvsSynchR = do
let unknownLicenceOwners = E.unValue <$> unknownLicenceOwners' let unknownLicenceOwners = E.unValue <$> unknownLicenceOwners'
numUnknownLicenceOwners = length unknownLicenceOwners numUnknownLicenceOwners = length unknownLicenceOwners
(btnUnknownWgt, btnUnknownRes) <- runButtonFormHash unknownLicenceOwners FIDAbsUnknownLicences (btnUnknownWgt, btnUnknownRes) <- runButtonFormHash unknownLicenceOwners FIDAbsUnknownLicences
case btnUnknownRes of case btnUnknownRes of
Nothing -> return () Nothing -> return ()
(Just BtnImportUnknownAvsIds) -> do (Just BtnImportUnknownAvsIds) -> do
let procAid = fmap (Sum . maybe 0 (const 1)) <$> upsertAvsUserById let procAid = fmap (Sum . maybe 0 (const 1)) <$> upsertAvsUserById
res <- try (getSum <$> foldMapM procAid unknownLicenceOwners) res <- try (getSum <$> foldMapM procAid unknownLicenceOwners)
case res of case res of
Right oks -> do Right oks -> do
let ms = if oks == numUnknownLicenceOwners then Info else Warning let ms = if oks == numUnknownLicenceOwners then Info else Warning
addMessageI ms $ MsgAvsImportIDs oks numUnknownLicenceOwners addMessageI ms $ MsgAvsImportIDs oks numUnknownLicenceOwners
redirect ProblemAvsSynchR redirect ProblemAvsSynchR
Left err -> addMessageModal Error (i18n MsgAvsCommunicationError) (Right (text2widget $ tshow (err :: SomeException))) Left err -> addMessageModal Error (i18n MsgAvsCommunicationError) (Right (text2widget $ tshow (err :: SomeException)))
(Just BtnRevokeAvsLicences) -> (Just BtnRevokeAvsLicences) ->
try (setLicencesAvs $ Set.map (AvsPersonLicence AvsNoLicence) $ Set.fromList unknownLicenceOwners) try (setLicencesAvs $ Set.map (AvsPersonLicence AvsNoLicence) $ Set.fromList unknownLicenceOwners)
>>= \case >>= \case
Right True -> addMessageI Info MsgRevokeUnknownLicencesOk Right True -> addMessageI Info MsgRevokeUnknownLicencesOk
Right False -> addMessageI Error MsgRevokeUnknownLicencesFail Right False -> addMessageI Error MsgRevokeUnknownLicencesFail
@ -316,11 +324,10 @@ getProblemAvsSynchR = do
{- dbtSQLQuery = \(usrAvs `E.LeftOuterJoin` (qaul `E.InnerJoin` qualUser `E.InnerJoin` user)) -> do {- dbtSQLQuery = \(usrAvs `E.LeftOuterJoin` (qaul `E.InnerJoin` qualUser `E.InnerJoin` user)) -> do
E.on $ user E.^. UserId E.==. qualUser E.^. QualificationUserUser E.on $ user E.^. UserId E.==. qualUser E.^. QualificationUserUser
E.on $ qual E.^. QualificationId E.==. qualUser E.^. QualificationUserQualification E.on $ qual E.^. QualificationId E.==. qualUser E.^. QualificationUserQualification
E.on $ user E.^. UserId E.==. usrAvs E.^ UserAvsUser E.on $ user E.^. UserId E.==. usrAvs E.^ UserAvsUser
E.where_ $ E.isJust (qual E.^. QualificationAvsLicence) E.where_ $ E.isJust (qual E.^. QualificationAvsLicence)
-} -}
siteLayoutMsg MsgAvsTitleLicenceSynch $ do siteLayoutMsg MsgAvsTitleLicenceSynch $ do
setTitleI MsgAvsTitleLicenceSynch setTitleI MsgAvsTitleLicenceSynch
$(i18nWidgetFile "avs-synchronisation") $(i18nWidgetFile "avs-synchronisation")

4
templates/avs.hamlet
View File

@ -43,7 +43,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
$maybe answer <- mbPerson $maybe answer <- mbPerson
<p> <p>
Unverarbeitete Antwort: # Unverarbeitete Antwort: #
#{answer} ^{answer}
<section> <section>
<p> <p>
@ -52,4 +52,4 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
$maybe answer <- mbStatus $maybe answer <- mbStatus
<p> <p>
Unverarbeitete Antwort: # Unverarbeitete Antwort: #
#{answer} ^{answer}