chore(avs): synch problems to avs implemented

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

@@ -17,6 +17,7 @@ AvsTitleLicenceSynch: Abgleich Fahrberechtigungen zwischen AVS und FRADrive
 BtnRevokeAvsLicences: Fahrberechtigungen im AVS sofort entziehen
 BtnImportUnknownAvsIds: Daten unbekannter Personen importieren
 AvsImportIDs n@Int m@Int: AVS Persondendaten importiert: #{show n}/#{show m}
+AvsSetLicences alic@AvsLicence n@Int m@Int: _{alic} im AVS gesetzt: #{show n}/#{show m}
 RevokeUnknownLicencesOk: AVS Fahrberechtigungen unbekannter Fahrer wurden gesperrt
 RevokeUnknownLicencesFail: Nicht alle AVS Fahrberechtigungen unbekannter Fahrer konnten entzogen werden, siehe Log für Details
 AvsCommunicationError: AVS Schnittstelle lieferte einen unerwarteten Fehler.

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

@@ -16,7 +16,8 @@ AvsPersonNoNotId: AVS person number is used in human communication only and must
 AvsTitleLicenceSynch: Synchronisation driving licences between AVS and FRADrive
 BtnRevokeAvsLicences: Revoke AVS driving licences immediately
 BtnImportUnknownAvsIds: Import unknown person data
-AvsImportIDs n m: AVS person daten importet: #{show n}/#{show m}
+AvsImportIDs n m: AVS person data imported: #{show n}/#{show m}
+AvsSetLicences alic n m: _{alic} set in AVS: #{show n}/#{show m}
 RevokeUnknownLicencesOk: AVS driving licences of unknown drivers revoked
 RevokeUnknownLicencesFail: Not all AVS driving licences of unknown drivers could be revoked, see log for details
 AvsCommunicationError: AVS interface returned an unexpected error.

messages/uniworx/misc/de-de-formal.msg

@@ -16,3 +16,7 @@ Months num@Int64: #{num} #{pluralDE num "Monat" "Monate"}
 Days num@Int64: #{num} #{pluralDE num "Tag" "Tage"}
 
 ClusterVolatileQuickActionsEnabled: Schnellzugriffsmenü aktiv
+
+AvsNoLicence: Keine Fahrberechtigung
+AvsLicenceVorfeld: Vorfeld Fahrberechtigung
+AvsLicenceRollfeld: Rollfeld Fahrberechtigung

messages/uniworx/misc/en-eu.msg

@@ -16,3 +16,7 @@ Months num: #{num} #{pluralEN num "Month" "Months"}
 Days num: #{num} #{pluralEN num "Day" "Days"}
 
 ClusterVolatileQuickActionsEnabled: Quick actions enabled
+
+AvsNoLicence: No driving licence
+AvsLicenceVorfeld: Apron driving licence
+AvsLicenceRollfeld: Maneuvering area driving licence

src/Foundation/I18n.hs

@@ -182,6 +182,7 @@ newtype ShortTermIdentifier = ShortTermIdentifier TermIdentifier
   deriving stock (Eq, Ord, Read, Show)
 
 
+
 -- Messages creates type UniWorXMessage and RenderMessage UniWorX instance
 mkMessage ''UniWorX "messages/uniworx/misc" "de-de-formal"
 mkMessageAddition ''UniWorX "Test" "messages/uniworx/test" "de-de-formal"
@@ -212,8 +213,6 @@ mkMessageAddition ''UniWorX "Send" "messages/uniworx/categories/send" "de-de-for
 mkMessageAddition ''UniWorX "YesodMiddleware" "messages/uniworx/categories/yesod_middleware" "de-de-formal"
 mkMessageAddition ''UniWorX "User" "messages/uniworx/categories/user" "de-de-formal"
 mkMessageAddition ''UniWorX "Print" "messages/uniworx/categories/print" "de-de-formal"
-mkMessageAddition ''UniWorX "Qualification" "messages/uniworx/categories/qualification" "de-de-formal"
-mkMessageAddition ''UniWorX "Avs" "messages/uniworx/categories/avs" "de-de-formal"
 mkMessageAddition ''UniWorX "Button" "messages/uniworx/utils/buttons" "de-de-formal"
 mkMessageAddition ''UniWorX "Form" "messages/uniworx/utils/handler_form" "de-de-formal"
 mkMessageAddition ''UniWorX "TableColumn" "messages/uniworx/utils/table_column" "de-de-formal"
@@ -228,6 +227,10 @@ mkMessageVariant ''UniWorX ''PWHashMessage "messages/auth/pw-hash" "de"
 mkMessageVariant ''UniWorX ''ButtonMessage "messages/button" "de"
 mkMessageVariant ''UniWorX ''FrontendMessage "messages/frontend" "de-de-formal"
 
+embedRenderMessage ''UniWorX ''AvsLicence id -- required by UniWorXAvsMessages
+mkMessageAddition ''UniWorX "Qualification" "messages/uniworx/categories/qualification" "de-de-formal"
+mkMessageAddition ''UniWorX "Avs" "messages/uniworx/categories/avs" "de-de-formal"
+
 instance RenderMessage UniWorX TermIdentifier where
   renderMessage _foundation _ls = termToText -- TODO: respect user selected Datetime Format
 

src/Handler/Admin/Avs.hs

@@ -194,9 +194,7 @@ postAdminAvsR = do
         flip (renderAForm FormStandard) html $ (,) <$> areq intField (fslI MsgAvsPersonId) Nothing
                                                    <*> areq (selectField $ return avsLicenceOptions) (fslI MsgAvsLicence) (Just AvsLicenceVorfeld)
       let procFormSetLic (aid, lic) = do            
-            let req = Set.singleton $ AvsPersonLicence { avsLicenceRampLicence = lic, avsLicencePersonID = AvsPersonId aid }
+            res <- try $ setLicenceAvs (AvsPersonId aid) lic
-            addMessage Info $ text2Html $ "See log for detailed errors. Query: " <> tshow (toJSON $ AvsQuerySetLicences req)
-            res <- try $ setLicencesAvs req
             case res of
               (Right True) ->
                 return $ Just [whamlet|<h2>Success:</h2> Licence #{tshow (licence2char lic)} set for #{tshow aid}.|]
@@ -304,12 +302,14 @@ data LicenceTableActionData =  LicenceTableChangeAvsData
 postProblemAvsSynchR,  getProblemAvsSynchR :: Handler Html
 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, AvsPersonId 12345678]
   --     setTo1 = Set.fromList [AvsPersonId minutes]
   --     setTo2 = Set.fromList [AvsPersonId hours, AvsPersonId 12345678]
+  -- addMessageI Success $ MsgAvsSetLicences AvsLicenceVorfeld 99 1000 
 
   (setTo0, setTo1, setTo2) <- try retrieveDifferingLicences >>= \case
     Right res -> return res
@@ -337,11 +337,12 @@ getProblemAvsSynchR = do
           addMessageI ms $ MsgAvsImportIDs oks numUnknownLicenceOwners
           redirect ProblemAvsSynchR
         Left err -> addMessageModal Error (i18n MsgAvsCommunicationError) (Right (text2widget $ tshow (err :: SomeException)))
-    (Just BtnRevokeAvsLicences) ->
+    (Just BtnRevokeAvsLicences) -> do
-      try (setLicencesAvs $ Set.map (AvsPersonLicence AvsNoLicence) $ Set.fromList unknownLicenceOwners)
+      let revokes = Set.map (AvsPersonLicence AvsNoLicence) $ Set.fromList unknownLicenceOwners
-      >>= \case
+          no_revokes = Set.size revokes
-        Right True  -> addMessageI Info  MsgRevokeUnknownLicencesOk
+      try (setLicencesAvs revokes) >>= \case
-        Right False -> addMessageI Error MsgRevokeUnknownLicencesFail
+        Right no_ok | no_ok < no_revokes -> addMessageI Error MsgRevokeUnknownLicencesFail
+                    | otherwise          -> addMessageI Info  MsgRevokeUnknownLicencesOk        
         Left  err   -> addMessageModal Error (i18n MsgAvsCommunicationError) (Right (text2widget $ tshow (err :: SomeException)))
       >> redirect ProblemAvsSynchR
     
@@ -350,7 +351,13 @@ getProblemAvsSynchR = do
           <*> mkLicenceTable "driveSynchVorfeld"    AvsLicenceVorfeld  setTo1 (Just LicenceTableChangeAvs)
           <*> mkLicenceTable "driveSynchRollfeld"   AvsLicenceRollfeld setTo2 (Just LicenceTableChangeAvs)
   let procRes :: AvsLicence -> (LicenceTableActionData, Set AvsPersonId) -> Handler ()
-      procRes _alic r@(LicenceTableChangeAvsData       , _apids) = addMessage Info $ toHtml $ tshow r
+      procRes aLic (LicenceTableChangeAvsData       , apids) = do 
+        try (setLicencesAvs $ Set.map (AvsPersonLicence aLic) apids) >>= \case 
+          (Right no_ok) -> let no_req = Set.size apids
+                               mkind = if no_ok < no_req then Warning else Success
+                           in addMessageI mkind $ MsgAvsSetLicences aLic no_ok no_req          
+          (Left err)    -> addMessageModal Error (i18n MsgAvsCommunicationError) (Right (text2widget $ tshow (err :: SomeException)))        
+        redirect ProblemAvsSynchR -- reload to update all tables 
       procRes _alic r@(_, _apids) = addMessage Info $ toHtml $ tshow r
   formResult tres2 $ procRes AvsLicenceRollfeld
   formResult tres1 $ procRes AvsLicenceVorfeld

src/Handler/Utils/Avs.hs

@@ -39,6 +39,9 @@ import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications
 import qualified Database.Esqueleto.Utils        as E
 
 
+
+
+
 --------------------
 -- AVS Exceptions --
 --------------------
@@ -129,15 +132,15 @@ setLicenceAvs :: (MonadHandler m, MonadThrow m, HandlerSite m ~ UniWorX) =>
                   AvsPersonId -> AvsLicence -> m Bool
 setLicenceAvs apid lic = do
   let req = Set.singleton $ AvsPersonLicence { avsLicenceRampLicence = lic, avsLicencePersonID = apid }
-  setLicencesAvs req
+  (1 ==) <$> setLicencesAvs req
 
 
 --setLicencesAvs :: Set AvsPersonLicence -> Handler Bool
 setLicencesAvs :: (MonadHandler m, MonadThrow m, HandlerSite m ~ UniWorX) =>
-                  Set AvsPersonLicence -> m Bool
+                  Set AvsPersonLicence -> m Int
 setLicencesAvs persLics = do
     AvsQuery{avsQuerySetLicences=aqsl} <- maybeThrowM AvsInterfaceUnavailable $ getsYesod $ view _appAvsQuery
-    aux aqsl True persLics
+    aux aqsl 0 persLics
   where
     aux aqsl batch0_ok pls
       | Set.null pls = return batch0_ok
@@ -154,11 +157,11 @@ setLicencesAvs persLics = do
             let (ok,bad') = Set.partition (sloppyBool . avsResponseSuccess) msgs
                 ok_ids = Set.map avsResponsePersonID ok
                 bad = Map.withoutKeys (setToMap avsResponsePersonID bad') ok_ids -- it is possible to receive an id multiple times, with only one success, but this is sufficient
-                batch1_ok = length ok == length batch1
+                batch1_ok = Set.size ok
             forM_ bad $ \AvsLicenceResponse { avsResponsePersonID=api, avsResponseMessage=msg} ->
               $logErrorS "AVS" $ "Set AVS Licence failed for " <> tshow api <> " due to " <> cropText msg
               -- TODO: Admin Error page
-            aux aqsl (batch0_ok && batch1_ok) batch2 -- yay for tail recursion (TODO: maybe refactor?)
+            aux aqsl (batch0_ok + batch1_ok) batch2 -- yay for tail recursion (TODO: maybe refactor?)
 
 
 -- | Retrieve all currently valid driving licences and check against our database
@@ -170,10 +173,11 @@ synchAvsLicences = do
   allLicences   <- throwLeftM avsQueryGetAllLicences
   deltaLicences <- computeDifferingLicences allLicences
   setResponse   <- setLicencesAvs deltaLicences
-  if setResponse
+  let setOk = setResponse == Set.size deltaLicences
+  if setOk
     then $logInfoS "AVS" "FRADrive Licences written to AVS successfully."
     else $logWarnS "AVS" "Writing FRADrive Licences to AVS incomplete."
-  return setResponse
+  return setOk
 
 computeDifferingLicences :: AvsResponseGetLicences -> Handler (Set AvsPersonLicence)
 computeDifferingLicences argl = do

src/Model/Types/Avs.hs

@@ -243,6 +243,7 @@ instance FromJSON AvsLicence where
   parseJSON _ = pure AvsNoLicence     -- we simply ignore all other values
 #endif
 
+
 -- we assume that the Ord-Instance is respected by the SQL Backend!
 instance PersistField AvsLicence where
   toPersistValue = PersistInt64 . fromIntegral . fromEnum

src/Utils/Lens.hs

@@ -151,6 +151,12 @@ instance HasStudyDegree a => HasStudyDegree (Entity a) where
 instance HasQualification a => HasQualification (Entity a) where
   hasQualification = _entityVal . hasQualification
 
+instance HasQualificationUser a => HasQualificationUser (Entity a) where
+  hasQualificationUser = _entityVal . hasQualificationUser
+
+instance HasLmsUser a => HasLmsUser (Entity a) where
+  hasLmsUser = _entityVal . hasLmsUser
+
 instance HasUserAvs a => HasUserAvs (Entity a)   where
   hasUserAvs = _entityVal . hasUserAvs