chore(avs): prepare proper avs interface for admin

messages/button/de.msg

@@ -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

messages/button/en.msg

@@ -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

messages/uniworx/categories/avs/de-de-formal.msg

@@ -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

messages/uniworx/categories/avs/en-eu.msg

@@ -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

src/Handler/Admin.hs

@@ -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})

src/Handler/Admin/Avs.hs

@@ -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)
+      (qryLicForm, qryLicRes) <- runButtonForm FIDAvsQueryLicenceDiffs
-      let procFormQryLic btn = case btn of 
+      mbQryLic <- case qryLicRes of 
-            BtnCheckLicences -> do 
+        Nothing -> return Nothing
-              res <- try $ do                 
+        (Just BtnCheckLicences) -> do 
-                allLicences <- throwLeftM avsQueryGetAllLicences
+          res <- try $ do                 
-                computeDifferingLicences allLicences
+            allLicences <- throwLeftM avsQueryGetAllLicences
-              case res of 
+            computeDifferingLicences allLicences
-                (Right diffs) -> do 
+          case res of 
-                  let showLics l = Text.intercalate ", " $ fmap (tshow . avsLicencePersonID) $ Set.toList $ Set.filter ((l ==) . avsLicenceRampLicence) diffs
+            (Right diffs) -> do 
-                      r_grant = showLics AvsLicenceRollfeld
+              let showLics l = Text.intercalate ", " $ fmap (tshow . avsLicencePersonID) $ Set.toList $ Set.filter ((l ==) . avsLicenceRampLicence) diffs
-                      f_set   = showLics AvsLicenceVorfeld
+                  r_grant = showLics AvsLicenceRollfeld
-                      revoke  = showLics AvsNoLicence
+                  f_set   = showLics AvsLicenceVorfeld
-                  return $ Just [whamlet|
+                  revoke  = showLics AvsNoLicence
-                      <h2>Licence check differences:
+              return $ Just [whamlet|
-                      <h3>Grant R:
+                  <h2>Licence check differences:
-                      <p>
+                  <h3>Grant R:
-                        #{r_grant}
+                  <p>
-                      <h3>Set to F:
+                    #{r_grant}
-                      <p>
+                  <h3>Set to F:
-                        #{f_set}
+                  <p>
-                      <h3>Revoke licence:                      
+                    #{f_set}
-                      <p>
+                  <h3>Revoke licence:                      
-                        #{revoke}
+                  <p>
-                    |]
+                    #{revoke}
-                (Left e) -> do
+                |]
-                  let msg = tshow (e :: SomeException)
+            (Left e) -> do
-                  return $ Just [whamlet|<h2>Licence check error:</h2> #{msg}|]
+              let msg = tshow (e :: SomeException)
-            BtnSynchLicences -> do
+              return $ Just [whamlet|<h2>Licence check error:</h2> #{msg}|]
-              res <- try synchAvsLicences
+        (Just BtnSynchLicences) -> do
-              case res of
+          res <- try synchAvsLicences
-                (Right True) ->
+          case res of
-                  return $ Just [whamlet|<h2>Success:</h2> Licences sychronized.|]
+            (Right True) ->
-                (Right False) ->
+              return $ Just [whamlet|<h2>Success:</h2> Licences sychronized.|]
-                  return $ Just [whamlet|<h2>Error:</h2> Licences could not be synchronized, see error log.|]
+            (Right False) ->
-                (Left e) -> do
+              return $ Just [whamlet|<h2>Error:</h2> Licences could not be synchronized, see error log.|]
-                  let msg = tshow (e :: SomeException)
+            (Left e) -> do
-                  return $ Just [whamlet|<h2>Licence synchronisation error:</h2> #{msg}|]
+              let msg = tshow (e :: SomeException)
-      mbQryLic <- formResultMaybe qryLicRes procFormQryLic
+              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
+            setLicForm = wrapFormHere setLicWgt setLicEnctype            
-            qryLicForm = wrapForm     qryLicWgt def { formAction = Just $ SomeRoute actionUrl, formEncoding = qryLicEnctype, formSubmit = FormNoSubmit }
         -- 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")
+
+  

src/Handler/Utils/Avs.hs

@@ -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
+  let nowaday = utctDay now      
-      noOne   = AvsPersonId 0
       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)

src/Model/Types/Avs.hs

@@ -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

src/Utils.hs

@@ -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 --
 ----------

src/Utils/Avs.hs

@@ -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

src/Utils/Form.hs

@@ -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 --
 -------------------

templates/i18n/avs-synchronisation/de-de-formal.hamlet

@@ -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

templates/i18n/avs-synchronisation/en-eu.hamlet

@@ -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