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

chore(avs): prepare proper avs interface for admin

Browse Source
This commit is contained in:
Steffen Jost 2022-12-13 18:04:43 +01:00
parent f352eca7e7
commit a890179d81
13 changed files with 245 additions and 49 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
messages/button/de.msg
View File

@ -4,4 +4,5 @@
AmbiguousButtons: Mehrere Submit-Buttons aktiv
WrongButtonValue: Submit-Button hat falschen Wert
MultipleButtonValues: Submit-Button hat mehrere Werte
MultipleButtonValues: Submit-Button hat mehrere Werte
BtnFormOutdated: Knopfdruck verworfen wegen zwischenzeitlicher Datenänderungen

1
messages/button/en.msg
View File

@ -5,3 +5,4 @@
AmbiguousButtons: Multiple active submit buttons
WrongButtonValue: Submit button has wrong value
MultipleButtonValues: Submit button has multiple values
BtnFormOutdated: Button ignored due to interim data changes

5
messages/uniworx/categories/avs/de-de-formal.msg
View File

@ -12,4 +12,7 @@ AvsVersionNo: Versionsnummer
AvsQueryEmpty: Bitte mindestens ein Anfragefeld ausfüllen!
AvsQueryStatusInvalid t@Text: Nur numerische IDs eingeben, durch Komma getrennt! Erhalten: #{show t}
AvsLicence: Fahrberechtigung
AvsPersonNoNotId: AVS Personennummer dient zur menschlichen Kommunikation mit der Ausweisstelle und darf nicht verwechselt werden mit der maschinell verwendeten AVS Personen Id
AvsPersonNoNotId: AVS Personennummer dient zur menschlichen Kommunikation mit der Ausweisstelle und darf nicht verwechselt werden mit der maschinell verwendeten AVS Personen Id
AvsTitleLicenceSynch: Abgleich Fahrberechtigungen zwischen AVS und FRADrive
BtnRevokeAvsLicences: Fahrberechtigungen im AVS sofort entziehen
BtnImportUnknownAvsIds: Daten unbekannter Personen importieren

5
messages/uniworx/categories/avs/en-eu.msg
View File

@ -12,4 +12,7 @@ AvsVersionNo: Version number
AvsQueryEmpty: At least one query field must be filled!
AvsQueryStatusInvalid t: Numeric IDs only, comma seperated! #{show t}
AvsLicence: Driving Licence
AvsPersonNoNotId: AVS person number is used in human communication only and must not be mistaken for the AVS personen id used in machine communications
AvsPersonNoNotId: AVS person number is used in human communication only and must not be mistaken for the AVS personen id used in machine communications
AvsTitleLicenceSynch: Synchronisation driving licences between AVS and FRADrive
BtnRevokeAvsLicences: Revoke AVS driving licences immediately
BtnImportUnknownAvsIds: Import unknown person data

1
src/Handler/Admin.hs
View File

@ -47,6 +47,7 @@ getAdminR = do
-- (Left (UnsupportedContentType "text/html" resp)) -> Left $ text2widget "Html received"
(Left e) -> Left $ text2widget $ tshow (e :: SomeException)
(Right (to0, to1, to2)) -> Right (Set.size to0, Set.size to1, Set.size to2)
-- Attempt to format results in a nicer way failed, since rendering Html within a modal destroyed the page layout itself
-- let procDiffLics (to0, to1, to2) = Right (Set.size to0, Set.size to1, Set.size to2)
-- diffLics <- (procDiffLics <$> retrieveDifferingLicences) `catches`
-- [ Catch.Handler (\case (UnsupportedContentType "text/html;charset=utf-8" Response{responseBody})

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

@ -2,9 +2,12 @@
--
-- SPDX-License-Identifier: AGPL-3.0-or-later
{-# LANGUAGE TypeApplications #-}
module Handler.Admin.Avs
( getAdminAvsR
, postAdminAvsR
, getQualificationSynchR, postQualificationSynchR
) where
import Import
@ -18,6 +21,14 @@ import Handler.Utils.Avs
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 X (from, on) -- needs TypeApplications Lang-Pragma
import qualified Database.Esqueleto.Utils as E
-- Button needed only here
data ButtonAvsTest = BtnCheckLicences | BtnSynchLicences
deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
@ -181,44 +192,44 @@ postAdminAvsR = do
mbSetLic <- formResultMaybe setLicRes procFormSetLic
((qryLicRes, qryLicWgt), qryLicEnctype) <- runFormPost $ identifyForm FIDAvsQueryLicenceDiffs (buttonForm :: Form ButtonAvsTest)
let procFormQryLic btn = case btn of
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}|]
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}|]
mbQryLic <- formResultMaybe qryLicRes procFormQryLic
(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}|]
actionUrl <- fromMaybe AdminAvsR <$> getCurrentRoute
siteLayoutMsg MsgMenuAvs $ do
@ -228,7 +239,77 @@ postAdminAvsR = do
statusForm = wrapFormHere swidget senctype
crUsrForm = wrapFormHere crUsrWgt crUsrEnctype
getLicForm = wrapFormHere getLicWgt getLicEnctype
setLicForm = wrapFormHere setLicWgt setLicEnctype
qryLicForm = wrapForm qryLicWgt def { formAction = Just $ SomeRoute actionUrl, formEncoding = qryLicEnctype, formSubmit = FormNoSubmit }
setLicForm = wrapFormHere setLicWgt setLicEnctype
-- TODO: use i18nWidgetFile instead if this is to become permanent
$(widgetFile "avs")
{-
type SynchTableExpr = ( E.SqlExpr (E.Value AvsPersonId)
`E.LeftOuterJoin` E.SqlExpr (Entity UserAvs)
`E.LeftOuterJoin` ( E.SqlExpr (Entity Qualification)
`E.InnerJoin` E.SqlExpr (Entity QualificationUser)
`E.InnerJoin` E.SqlExpr (Entity User)
))
type SynchDBRow = (E.Value AvsPersonId, E.Value AvsLicence, Entity Qualification, Entity QualificationUser, Entity User)
-}
data ButtonAvsSynch = BtnRevokeAvsLicences | BtnImportUnknownAvsIds
deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
instance Universe ButtonAvsSynch
instance Finite ButtonAvsSynch
nullaryPathPiece ''ButtonAvsSynch camelToPathPiece
embedRenderMessage ''UniWorX ''ButtonAvsSynch id
instance Button UniWorX ButtonAvsSynch where
btnClasses BtnImportUnknownAvsIds = [BCIsButton, BCPrimary]
btnClasses BtnRevokeAvsLicences = [BCIsButton, BCDanger]
postQualificationSynchR, getQualificationSynchR :: Handler Html
postQualificationSynchR = getQualificationSynchR
getQualificationSynchR = 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) <- retrieveDifferingLicences
unknownLicenceOwners' <- whenNonEmpty setTo0 $ \neZeros ->
runDB $ E.select $ do
(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)
pure toZero
let unknownLicenceOwners = E.unValue <$> unknownLicenceOwners'
numUnknownLicenceOwners = length unknownLicenceOwners
(btnUnknownWgt, btnUnknownRes) <- runButtonFormHash (hash unknownLicenceOwners) FIDAbsUnknownLicences
case btnUnknownRes of
(Just BtnImportUnknownAvsIds) -> addMessage Info "UnknownAvsIds pressed."
-- do
-- let procAid = (Sum . (maybe 0 (const 1))) <$> upsertAvsUserById
-- oks <- getSum <$> foldMapM procAid unknownLicenceOwners
-- let ms = if oks == numUnkownLicenceOwners then Info else Warning
-- addMessageI ms $ MsgAvsImportIDs oks
(Just BtnRevokeAvsLicences) -> addMessage Info "Revoke Avs Licences pressed."
Nothing -> return ()
-- move elsewhere?
-- let dbtIdent = "drivingLicenceSynch" :: Text
-- dbtStyle = def
{- 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.where_ $ E.isJust (qual E.^. QualificationAvsLicence)
-}
siteLayoutMsg MsgAvsTitleLicenceSynch $ do
setTitleI MsgAvsTitleLicenceSynch
$(i18nWidgetFile "avs-synchronisation")

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

@ -177,8 +177,7 @@ getDifferingLicences (AvsResponseGetLicences licences) = do
--let (vorfeld, nonvorfeld) = Set.partition (`avsPersonLicenceIs` AvsLicenceVorfeld) licences
-- rollfeld = Set.filter (`avsPersonLicenceIs` AvsLicenceRollfeld) nonvorfeld
-- Note: FRADrive users with 'R' also own 'F' qualification, but AvsGetResponseGetLicences yields only either
let nowaday = utctDay now
noOne = AvsPersonId 0
let nowaday = utctDay now
vorORrollfeld' = Set.dropWhileAntitone (`avsPersonLicenceIsLEQ` AvsNoLicence) licences
rollfeld' = Set.dropWhileAntitone (`avsPersonLicenceIsLEQ` AvsLicenceVorfeld) vorORrollfeld'
vorORrollfeld = Set.map avsLicencePersonID vorORrollfeld'
@ -200,13 +199,13 @@ getDifferingLicences (AvsResponseGetLicences licences) = do
)
`E.innerJoin` E.table @UserAvs
`E.on` (\(_ :& qualUser :& usrAvs) -> qualUser E.^. QualificationUserUser E.==. usrAvs E.^. UserAvsUser)
) `E.fullOuterJoin` E.toValues (set2NonEmpty noOne avsLics) -- left-hand side produces all currently valid matching qualifications
) `E.fullOuterJoin` E.toValues (set2NonEmpty avsPersonIdZero avsLics) -- left-hand side produces all currently valid matching qualifications
`E.on` (\((_ :& _ :& usrAvs) :& excl) -> usrAvs E.?. UserAvsPersonId E.==. excl)
E.where_ $ E.isNothing excl E.||. E.isNothing (usrAvs E.?. UserAvsPersonId) -- anti join
return (usrAvs E.?. UserAvsPersonId, excl)
unwrapIds :: [(E.Value (Maybe AvsPersonId), E.Value (Maybe AvsPersonId))] -> (Set AvsPersonId, Set AvsPersonId)
unwrapIds = mapBoth (Set.delete noOne) . foldr aux mempty
unwrapIds = mapBoth (Set.delete avsPersonIdZero) . foldr aux mempty
where
aux (_, E.Value(Just api)) (l,r) = (l, Set.insert api r) -- we may assume here that each pair contains precisely one Just constructor
aux (E.Value(Just api), _) (l,r) = (Set.insert api l, r)

5
src/Model/Types/Avs.hs
View File

@ -183,7 +183,7 @@ discernAvsCardPersonalNo _ = Nothing
-- The AVS API requires PersonIds sometimes as as mere numbers `AvsPersonId` and sometimes as tagged objects `AvsObjPersonId`
newtype AvsPersonId = AvsPersonId { avsPersonId :: Int } -- untagged Int
deriving (Eq, Ord, Generic, Typeable)
deriving newtype (NFData, PathPiece, PersistField, PersistFieldSql, Csv.ToField, Csv.FromField)
deriving newtype (NFData, PathPiece, PersistField, PersistFieldSql, Csv.ToField, Csv.FromField, Hashable)
instance E.SqlString AvsPersonId
-- As opposed to AvsObjPersonId, AvsPersonId is an untagged Int with respect to FromJSON/ToJSON, as needed by AVS API;
instance FromJSON AvsPersonId where
@ -196,6 +196,9 @@ instance Show AvsPersonId where
instance Read AvsPersonId where
readPrec = fmap AvsPersonId readPrec
-- | Non-existing default, also needed for query all ramp driving licences
avsPersonIdZero :: AvsPersonId
avsPersonIdZero = AvsPersonId 0 -- this mus be zero acording to VSM specification
newtype AvsObjPersonId = AvsObjPersonId -- tagged object
{ avsObjPersonID :: AvsPersonId

5
src/Utils.hs
View File

@ -708,6 +708,10 @@ partitionWith f (x:xs) = case f x of
nonEmpty' :: Alternative f => [a] -> f (NonEmpty a)
nonEmpty' = maybe empty pure . nonEmpty
whenNonEmpty :: (Applicative f, Monoid a, MonoFoldable mono) => mono -> (NonEmpty (Element mono) -> f a) -> f a
whenNonEmpty (toList -> h:t) = ($ (h :| t))
whenNonEmpty _ = const $ pure mempty
dropWhileM :: (IsSequence seq, Monad m) => (Element seq -> m Bool) -> seq -> m seq
dropWhileM p xs'
| Just (x, xs) <- uncons xs'
@ -734,6 +738,7 @@ pattern NonEmpty :: forall a. a -> [a] -> NonEmpty a
pattern NonEmpty x xs = x :| xs
{-# COMPLETE NonEmpty #-}
----------
-- Sets --
----------

2
src/Utils/Avs.hs
View File

@ -55,7 +55,7 @@ makeLenses_ ''AvsQuery
-- | To query all active licences, a special constant argument must be prepared
avsQueryAllLicences :: AvsQueryGetLicences
avsQueryAllLicences = AvsQueryGetLicences $ AvsObjPersonId $ AvsPersonId 0
avsQueryAllLicences = AvsQueryGetLicences $ AvsObjPersonId avsPersonIdZero
mkAvsQuery :: BaseUrl -> BasicAuthData -> ClientEnv -> AvsQuery

26
src/Utils/Form.hs
View File

@ -308,6 +308,7 @@ data FormIdentifier
| FIDAvsQueryLicence
| FIDAvsSetLicence
| FIDLmsLetter
| FIDAbsUnknownLicences
deriving (Eq, Ord, Read, Show)
instance PathPiece FormIdentifier where
@ -373,6 +374,7 @@ class (PathPiece a, PathPiece (ButtonClass site), RenderMessage site ButtonMessa
data ButtonMessage = MsgAmbiguousButtons
| MsgWrongButtonValue
| MsgMultipleButtonValues
| MsgBtnFormOutdated
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
-- | Default button for submitting. Required in Foundation for Login, other Buttons defined in Handler.Utils.Form
@ -561,6 +563,30 @@ runButtonForm' btns fid = do
return (btnForm, res)
-- | like runButtonForm, but may include a hash value enclosed in a hidden field to ensure
-- that the button press still applies to the correct situation
runButtonFormHash ::(PathPiece ident, Eq ident, RenderAFormSite site
, RenderMessage site (ValueRequired site)
, Button site ButtonSubmit, Button site a, Finite a)
=> Int -> ident -> HandlerT site IO (WidgetT site IO (), Maybe a)
runButtonFormHash hVal fid = do
currentRoute <- getCurrentRoute
let bForm = disambiguateButtons $ combinedButtonFieldF ""
hForm = areq hiddenField "" $ Just hVal
((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm fid $ \html ->
flip (renderAForm FormStandard) html $ (,) <$> bForm <*> hForm
let btnForm = wrapForm btnWdgt def { formAction = SomeRoute <$> currentRoute
, formEncoding = btnEnctype
, formSubmit = FormNoSubmit
}
res <- formResultMaybe btnResult $ \case
(_, rVal) | rVal /= hVal -> addMessageI Error MsgBtnFormOutdated
>> return Nothing
(btn, _ ) -> return $ Just btn
return (btnForm, res)
-------------------
-- Custom Fields --
-------------------

33
templates/i18n/avs-synchronisation/de-de-formal.hamlet Normal file
View File

@ -0,0 +1,33 @@
$newline never
$# SPDX-FileCopyrightText: 2022 Steffen Jost <jost@tcs.ifi.lmu.de>
$#
$# SPDX-License-Identifier: AGPL-3.0-or-later
<section>
<h2>
AVS Fahrberechtigte, welche FRADrive unbekannt sind
$if numUnknownLicenceOwners > 0
<p>
Es wurden #{length unknownLicenceOwners}
Personen mit einer Fahrberechtigung im AVS gefunden,
welche FRADrive unbekannt sind.
Option 1:
Personendaten aus dem AVS importeren, Fahrberechtigungen in AVS und FRADrive bleiben dabei erst einmal unverändert,
d.h. der Konflikt muss danach noch im nächsten Abschnitt aufgelöst werden.
Option 2:
Fahrberechtigungen all dieser Personen im AVS entziehen.
$else
<p>
Die Personendaten aller Fahrberechtigten im AVS sind FRADrive derzeit bekannt.
<section>
<h2>
Abweichende Fahrberechtigungen auflösen
<p>
Hier folgt eine dbTable mit Actions

40
templates/i18n/avs-synchronisation/en-eu.hamlet Normal file
View File

@ -0,0 +1,40 @@
$newline never
$# SPDX-FileCopyrightText: 2022 Steffen Jost <jost@tcs.ifi.lmu.de>
$#
$# SPDX-License-Identifier: AGPL-3.0-or-later
$# SPDX-FileCopyrightText: 2022 Steffen Jost <jost@tcs.ifi.lmu.de>
$#
$# SPDX-License-Identifier: AGPL-3.0-or-later
<section>
<h2>
AVS Fahrberechtigte, welche FRADrive unbekannt sind
$if numUnknownLicenceOwners > 0
<p>
Es wurden #{length unknownLicenceOwners}
Personen mit einer Fahrberechtigung im AVS gefunden,
welche FRADrive unbekannt sind.
^{btnUnknownWgt}
Option 1:
Personendaten aus dem AVS importeren, Fahrberechtigungen in AVS und FRADrive bleiben dabei erst einmal unverändert,
d.h. der Konflikt muss danach noch im nächsten Abschnitt aufgelöst werden.
Option 2:
Fahrberechtigungen all dieser Personen im AVS entziehen.
$else
<p>
Die Personendaten aller Fahrberechtigten im AVS sind FRADrive derzeit bekannt.
<section>
<h2>
Abweichende Fahrberechtigungen auflösen
<p>
Hier folgt eine dbTable mit Actions