chore(avs): minor improve avs debugging printout
This commit is contained in:
Steffen Jost
parent
2163ed96d0
commit
df1a816d83
@ -6,7 +6,7 @@
|
||||
|
||||
module Handler.Admin.Avs
|
||||
( getAdminAvsR, postAdminAvsR
|
||||
, getProblemAvsSynchR, postProblemAvsSynchR
|
||||
, getProblemAvsSynchR, postProblemAvsSynchR
|
||||
) where
|
||||
|
||||
import Import
|
||||
@ -23,7 +23,7 @@ import Utils.Avs
|
||||
|
||||
import Database.Esqueleto.Experimental ((:&)(..))
|
||||
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.Utils as E
|
||||
|
||||
@ -39,7 +39,7 @@ nullaryPathPiece ''ButtonAvsTest camelToPathPiece
|
||||
instance Button UniWorX ButtonAvsTest where
|
||||
btnLabel BtnCheckLicences = "Check 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]
|
||||
-- END Button
|
||||
|
||||
@ -57,9 +57,9 @@ makeAvsPersonForm tmpl = identifyForm FIDAvsQueryPerson . validateForm validateA
|
||||
<*> aopt textField (fslI MsgAvsVersionNo) (avsPersonQueryVersionNo <$> tmpl)
|
||||
<*> aopt textField (fslI MsgAvsFirstName) (avsPersonQueryFirstName <$> tmpl)
|
||||
<*> aopt textField (fslI MsgAvsLastName) (avsPersonQueryLastName <$> tmpl)
|
||||
<*> aopt avsInternalPersonalNoField
|
||||
<*> aopt avsInternalPersonalNoField
|
||||
(fslI MsgAvsInternalPersonalNo) (avsPersonQueryInternalPersonalNo <$> tmpl)
|
||||
|
||||
|
||||
|
||||
validateAvsQueryPerson :: FormValidator AvsQueryPerson Handler ()
|
||||
validateAvsQueryPerson = do
|
||||
@ -113,8 +113,12 @@ postAdminAvsR = do
|
||||
addMessage Info $ text2Html $ "Query: " <> tshow (toJSON fr)
|
||||
res <- avsQueryPerson fr
|
||||
case res of
|
||||
Left err -> return . Just $ tshow err
|
||||
Right jsn -> return . Just $ Text.replace "},Avs" "},\n Avs" $ tshow jsn
|
||||
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>#{tshow p}
|
||||
|]
|
||||
mbPerson <- formResultMaybe presult procFormPerson
|
||||
|
||||
((sresult, swidget), senctype) <- runFormPost $ makeAvsStatusForm Nothing
|
||||
@ -122,8 +126,12 @@ postAdminAvsR = do
|
||||
addMessage Info $ text2Html $ "Query: " <> tshow (toJSON fr)
|
||||
res <- avsQueryStatus fr
|
||||
case res of
|
||||
Left err -> return . Just $ tshow err
|
||||
Right jsn -> return . Just $ Text.replace "},Avs" "},\n Avs" $ tshow jsn
|
||||
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>#{tshow p}
|
||||
|]
|
||||
mbStatus <- formResultMaybe sresult procFormStatus
|
||||
|
||||
((crUsrRes, crUsrWgt), crUsrEnctype) <- runFormPost $ identifyForm FIDAvsCreateUser $ \html ->
|
||||
@ -144,17 +152,17 @@ postAdminAvsR = do
|
||||
|
||||
((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 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
|
||||
(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)
|
||||
(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
|
||||
@ -162,12 +170,12 @@ postAdminAvsR = do
|
||||
(Nothing , Nothing, Nothing ) -> const True
|
||||
addMessage Info $ text2Html $ "Query returned " <> tshow (length flics) <> " licences."
|
||||
return $ Just [whamlet|
|
||||
<h2>Success:</h2>
|
||||
<h2>Success:</h2>
|
||||
<ul>
|
||||
$forall AvsPersonLicence{..} <- flics
|
||||
<li> #{tshow avsLicencePersonID}: #{licence2char avsLicenceRampLicence}
|
||||
|]
|
||||
|
||||
|
||||
(Left err) -> do
|
||||
let msg = tshow err
|
||||
return $ Just [whamlet|<h2>Error:</h2> #{msg}|]
|
||||
@ -192,14 +200,14 @@ postAdminAvsR = do
|
||||
|
||||
|
||||
(qryLicForm, qryLicRes) <- runButtonForm FIDAvsQueryLicenceDiffs
|
||||
mbQryLic <- case qryLicRes of
|
||||
mbQryLic <- case qryLicRes of
|
||||
Nothing -> return Nothing
|
||||
(Just BtnCheckLicences) -> do
|
||||
res <- try $ do
|
||||
(Just BtnCheckLicences) -> do
|
||||
res <- try $ do
|
||||
allLicences <- throwLeftM avsQueryGetAllLicences
|
||||
computeDifferingLicences allLicences
|
||||
case res of
|
||||
(Right diffs) -> do
|
||||
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
|
||||
@ -212,7 +220,7 @@ postAdminAvsR = do
|
||||
<h3>Set to F:
|
||||
<p>
|
||||
#{f_set}
|
||||
<h3>Revoke licence:
|
||||
<h3>Revoke licence:
|
||||
<p>
|
||||
#{revoke}
|
||||
|]
|
||||
@ -228,7 +236,7 @@ postAdminAvsR = do
|
||||
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}|]
|
||||
return $ Just [whamlet|<h2>Licence synchronisation error:</h2> #{msg}|]
|
||||
|
||||
actionUrl <- fromMaybe AdminAvsR <$> getCurrentRoute
|
||||
siteLayoutMsg MsgMenuAvs $ do
|
||||
@ -238,7 +246,7 @@ postAdminAvsR = do
|
||||
statusForm = wrapFormHere swidget senctype
|
||||
crUsrForm = wrapFormHere crUsrWgt crUsrEnctype
|
||||
getLicForm = wrapFormHere getLicWgt getLicEnctype
|
||||
setLicForm = wrapFormHere setLicWgt setLicEnctype
|
||||
setLicForm = wrapFormHere setLicWgt setLicEnctype
|
||||
-- TODO: use i18nWidgetFile instead if this is to become permanent
|
||||
$(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)
|
||||
instance Universe ButtonAvsSynch
|
||||
instance Finite ButtonAvsSynch
|
||||
@ -263,27 +271,27 @@ instance Finite ButtonAvsSynch
|
||||
nullaryPathPiece ''ButtonAvsSynch camelToPathPiece
|
||||
embedRenderMessage ''UniWorX ''ButtonAvsSynch id
|
||||
|
||||
instance Button UniWorX ButtonAvsSynch where
|
||||
btnClasses BtnImportUnknownAvsIds = [BCIsButton, BCPrimary]
|
||||
instance Button UniWorX ButtonAvsSynch where
|
||||
btnClasses BtnImportUnknownAvsIds = [BCIsButton, BCPrimary]
|
||||
btnClasses BtnRevokeAvsLicences = [BCIsButton, BCDanger]
|
||||
|
||||
|
||||
postProblemAvsSynchR, getProblemAvsSynchR :: Handler Html
|
||||
postProblemAvsSynchR = getProblemAvsSynchR
|
||||
getProblemAvsSynchR = do
|
||||
postProblemAvsSynchR = getProblemAvsSynchR
|
||||
getProblemAvsSynchR = do
|
||||
-- TODO: just for Testing
|
||||
-- now <- liftIO getCurrentTime
|
||||
-- let TimeOfDay hours minutes _seconds = timeToTimeOfDay (utctDayTime now)
|
||||
-- setTo0 = Set.fromList [AvsPersonId hours, AvsPersonId minutes]
|
||||
|
||||
(setTo0, _setTo1, _setTo2) <- try retrieveDifferingLicences >>= \case
|
||||
|
||||
(setTo0, _setTo1, _setTo2) <- try retrieveDifferingLicences >>= \case
|
||||
Right res -> return res
|
||||
Left err -> do addMessageModal Error (i18n MsgAvsCommunicationError) (Right (text2widget $ tshow (err :: SomeException)))
|
||||
redirect AdminR
|
||||
|
||||
unknownLicenceOwners' <- whenNonEmpty setTo0 $ \neZeros ->
|
||||
runDB $ E.select $ do
|
||||
(toZero :& usrAvs) <- X.from $
|
||||
(toZero :& usrAvs) <- X.from $
|
||||
E.toValues neZeros `E.leftJoin` E.table @UserAvs
|
||||
`X.on` (\(toZero :& usrAvs) -> usrAvs E.?. UserAvsPersonId E.==. E.just toZero)
|
||||
E.where_ $ E.isNothing (usrAvs E.?. UserAvsPersonId)
|
||||
@ -291,19 +299,19 @@ getProblemAvsSynchR = do
|
||||
let unknownLicenceOwners = E.unValue <$> unknownLicenceOwners'
|
||||
numUnknownLicenceOwners = length unknownLicenceOwners
|
||||
(btnUnknownWgt, btnUnknownRes) <- runButtonFormHash unknownLicenceOwners FIDAbsUnknownLicences
|
||||
case btnUnknownRes of
|
||||
case btnUnknownRes of
|
||||
Nothing -> return ()
|
||||
(Just BtnImportUnknownAvsIds) -> do
|
||||
let procAid = fmap (Sum . maybe 0 (const 1)) <$> upsertAvsUserById
|
||||
(Just BtnImportUnknownAvsIds) -> do
|
||||
let procAid = fmap (Sum . maybe 0 (const 1)) <$> upsertAvsUserById
|
||||
res <- try (getSum <$> foldMapM procAid unknownLicenceOwners)
|
||||
case res of
|
||||
case res of
|
||||
Right oks -> do
|
||||
let ms = if oks == numUnknownLicenceOwners then Info else Warning
|
||||
addMessageI ms $ MsgAvsImportIDs oks numUnknownLicenceOwners
|
||||
redirect ProblemAvsSynchR
|
||||
Left err -> addMessageModal Error (i18n MsgAvsCommunicationError) (Right (text2widget $ tshow (err :: SomeException)))
|
||||
(Just BtnRevokeAvsLicences) ->
|
||||
try (setLicencesAvs $ Set.map (AvsPersonLicence AvsNoLicence) $ Set.fromList unknownLicenceOwners)
|
||||
(Just BtnRevokeAvsLicences) ->
|
||||
try (setLicencesAvs $ Set.map (AvsPersonLicence AvsNoLicence) $ Set.fromList unknownLicenceOwners)
|
||||
>>= \case
|
||||
Right True -> addMessageI Info MsgRevokeUnknownLicencesOk
|
||||
Right False -> addMessageI Error MsgRevokeUnknownLicencesFail
|
||||
@ -316,11 +324,10 @@ getProblemAvsSynchR = do
|
||||
{- dbtSQLQuery = \(usrAvs `E.LeftOuterJoin` (qaul `E.InnerJoin` qualUser `E.InnerJoin` user)) -> do
|
||||
E.on $ user E.^. UserId E.==. qualUser E.^. QualificationUserUser
|
||||
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)
|
||||
-}
|
||||
siteLayoutMsg MsgAvsTitleLicenceSynch $ do
|
||||
setTitleI MsgAvsTitleLicenceSynch
|
||||
setTitleI MsgAvsTitleLicenceSynch
|
||||
$(i18nWidgetFile "avs-synchronisation")
|
||||
|
||||
|
||||
@ -43,7 +43,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
$maybe answer <- mbPerson
|
||||
<p>
|
||||
Unverarbeitete Antwort: #
|
||||
#{answer}
|
||||
^{answer}
|
||||
|
||||
<section>
|
||||
<p>
|
||||
@ -52,4 +52,4 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
$maybe answer <- mbStatus
|
||||
<p>
|
||||
Unverarbeitete Antwort: #
|
||||
#{answer}
|
||||
^{answer}
|
||||
Loading…
Reference in New Issue
Block a user