chore(avs): fix problem listing no fd licence but in avs

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

@@ -24,7 +24,7 @@ TableQualificationBlockedDue: Suspendiert
 TableQualificationBlockedTooltip: Wann wurde die Qualifikation vorübergehend außer Kraft gesetzt und wer hat das veranlasst?
 LmsUser: Inhaber
 TableLmsEmail: E-Mail
-TableLmsIdent: Identifikation
+TableLmsIdent: LMS Identifikation
 TableLmsElearning: E-Learning
 TableLmsPin: E-Learning Pin
 TableLmsResetPin: Pin zurücksetzen?

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

@@ -24,7 +24,7 @@ TableQualificationBlockedDue: Suspended
 TableQualificationBlockedTooltip: When was the qualification temporarily suspended and who requested this?
 LmsUser: Licensee
 TableLmsEmail: Email
-TableLmsIdent: Identifier
+TableLmsIdent: LMS Identifier
 TableLmsPin: E-learning pin
 TableLmsElearning: E-learning
 TableLmsResetPin: Reset pin?

src/Handler/Admin/Avs.hs

@@ -303,16 +303,16 @@ postProblemAvsSynchR,  getProblemAvsSynchR :: Handler Html
 postProblemAvsSynchR = getProblemAvsSynchR
 getProblemAvsSynchR = do
   -- 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, AvsPersonId 12345678]
+      setTo0 = Set.fromList [AvsPersonId hours, AvsPersonId minutes, AvsPersonId 12345678]
-  --     setTo1 = Set.fromList [AvsPersonId minutes]
+      setTo1 = Set.fromList [AvsPersonId minutes]
-  --     setTo2 = Set.fromList [AvsPersonId hours, AvsPersonId 12345678]
+      setTo2 = Set.fromList [AvsPersonId hours, AvsPersonId 12345678]
 
-  (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 ->
     runDB $ E.select $ do
@@ -343,11 +343,20 @@ getProblemAvsSynchR = do
         Left  err   -> addMessageModal Error (i18n MsgAvsCommunicationError) (Right (text2widget $ tshow (err :: SomeException)))
       >> redirect ProblemAvsSynchR
     
-  ((_,tb0),(_,tb1),(_,tb2)) <- runDB $ (,,) 
+  ((r0,tb0),(r1,tb1),(r2,tb2)) <- runDB $ (,,) 
-          <$> mkLicenceTable AvsLicenceVorfeld  setTo0 (Just LicenceTableChangeAvs)
+          <$> mkLicenceTable AvsNoLicence       setTo0 (Just LicenceTableChangeAvs)
           <*> mkLicenceTable AvsLicenceVorfeld  setTo1 (Just LicenceTableChangeAvs)
           <*> mkLicenceTable AvsLicenceRollfeld setTo2 (Just LicenceTableChangeAvs)
 
+  -- for debugging
+  let sres x = case x of 
+                FormSuccess (tda, ids) -> addMessage Info $ toHtml $ "Received " <> tshow (Set.size ids) <> " ids for " <> tshow tda
+                _ -> pure ()
+  sres r0
+  sres r1
+  sres r2
+  -- end debugging
+
   siteLayoutMsg MsgAvsTitleLicenceSynch $ do
     setTitleI   MsgAvsTitleLicenceSynch
     $(i18nWidgetFile "avs-synchronisation")
@@ -360,6 +369,9 @@ type LicenceTableExpr = (                 E.SqlExpr (Entity UserAvs)
                           `E.InnerJoin`   E.SqlExpr (Maybe (Entity Qualification))
                         )                        
 
+queryUserAvs :: LicenceTableExpr -> E.SqlExpr (Entity UserAvs)
+queryUserAvs = $(E.sqlIJproj 2 1) . $(E.sqlLOJproj 2 1)
+
 queryUser :: LicenceTableExpr -> E.SqlExpr (Entity User)
 queryUser = $(E.sqlIJproj 2 2) . $(E.sqlLOJproj 2 1)
 
@@ -369,7 +381,7 @@ queryQualUser = $(E.sqlIJproj 2 1) . $(E.sqlLOJproj 2 2)
 queryQualification :: LicenceTableExpr -> E.SqlExpr (Maybe (Entity Qualification))
 queryQualification = $(E.sqlIJproj 2 2) . $(E.sqlLOJproj 2 2)
 
-type LicenceTableData = DBRow (Entity User, Maybe (Entity QualificationUser), AvsPersonId)
+type LicenceTableData = DBRow (Entity User, Maybe (Entity QualificationUser), AvsPersonId, Maybe (Entity Qualification))
 
 resultUser :: Lens' LicenceTableData (Entity User) 
 resultUser = _dbrOutput . _1
@@ -380,6 +392,9 @@ resultQualUser = _dbrOutput . _2 . _Just
 resultAvsPID :: Traversal' LicenceTableData AvsPersonId 
 resultAvsPID = _dbrOutput . _3
 
+resultQualification :: Traversal' LicenceTableData (Entity Qualification)
+resultQualification = _dbrOutput . _4 . _Just
+
 instance HasEntity LicenceTableData User where 
   hasEntity = resultUser
 
@@ -387,25 +402,31 @@ instance HasUser LicenceTableData where
   hasUser   = resultUser . _entityVal
 
 
-mkLicenceTable :: AvsLicence -> Set AvsPersonId -> Maybe LicenceTableAction -> DB (FormResult (LicenceTableActionData, Set UserId), Widget)
+mkLicenceTable :: AvsLicence -> Set AvsPersonId -> Maybe LicenceTableAction -> DB (FormResult (LicenceTableActionData, Set AvsPersonId), Widget)
 mkLicenceTable aLic apids defAct = do 
   currentRoute <- fromMaybe (error "mkLicenceTable called from 404-handler") <$> liftHandler getCurrentRoute
   now <- liftIO getCurrentTime
   let nowaday = utctDay now
       dbtIdent = "drivingLicenceSynch" :: Text
       dbtStyle = def
+      fltrLic qual = if
+        -- | aLic == AvsNoLicence -> E.true -- could be R, F, both or none at all, but has licence in AVS
+        | aLic == AvsNoLicence -> E.isNothing (qual E.?. QualificationId) E.||. E.isJust (E.joinV $ qual E.?. QualificationAvsLicence)  -- could be R, F, both or none at all, but has licence in AVS
+        | otherwise            -> E.val aLic E.=?. E.joinV (qual E.?. QualificationAvsLicence) -- if we suggest granting that licence, this join should deliver a value too
+      -- TODO: user holding multiple qualifications may appear multiple times in to-delete-in-avs table, which is kinda ugly. Solution:       
       dbtSQLQuery = \((usrAvs `E.InnerJoin` user) `E.LeftOuterJoin` (qualUser `E.InnerJoin` qual)) -> do
         E.on $ qual E.?. QualificationId  E.==. qualUser E.?. QualificationUserQualification
         E.on $ user E.^. UserId           E.=?. qualUser E.?. QualificationUserUser
         E.on $ user E.^. UserId           E.==. usrAvs   E.^. UserAvsUser
-        E.where_ $ E.val aLic E.=?. E.joinV (qual E.?. QualificationAvsLicence)
+        E.where_ $ fltrLic qual E.&&. (usrAvs E.^. UserAvsPersonId `E.in_` E.vals apids)
-            E.&&. (usrAvs E.^. UserAvsPersonId `E.in_` E.vals apids)
+        return (user, qualUser, usrAvs E.^. UserAvsPersonId, qual)
-        return (user, qualUser, usrAvs E.^. UserAvsPersonId)
+      dbtRowKey = queryUserAvs >>> (E.^. UserAvsPersonId)
-      dbtRowKey = queryUser >>> (E.^. UserId) -- ((_usrAvs `E.InnerJoin` usr) `E.LeftOuterJoin` _) = usr E.^. UserId
+      --dbtProj = dbtProjSimple $ \(user, qualUsr, E.Value api, quali) -> return (user, qualUsr, api, quali)
-      dbtProj = dbtProjSimple $ \(user, qualUsr, E.Value api) -> return (user, qualUsr, api)
+      dbtProj = dbtProjSimple $ pure . over _3 E.unValue 
       dbtColonnade = mconcat
-        [ dbSelect (applying _2) id (return . view (resultUser . _entityKey))
+        [ dbSelect (applying _2) id $ \DBRow{dbrOutput=(_,_,apid,_)} -> return apid -- return . view resultAvsPID -- does not type due to traversal
         , colUserNameLink AdminUserR
+        , sortable (Just "qualification") (i18nCell MsgTableQualifications)          $ \(preview $ resultQualification . _entityVal -> q)                             -> cellMaybe qualificationShortCell q
         , sortable (Just "valid-until")   (i18nCell MsgLmsQualificationValidUntil)   $ \(preview $ resultQualUser . _entityVal . _qualificationUserValidUntil  -> d)  -> cellMaybe dayCell d
         , sortable (Just "last-refresh")  (i18nCell MsgTableQualificationLastRefresh)$ \(preview $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d)  -> cellMaybe dayCell d
         , sortable (Just "first-held")    (i18nCell MsgTableQualificationFirstHeld)  $ \(preview $ resultQualUser . _entityVal . _qualificationUserFirstHeld   -> d)  -> cellMaybe dayCell d
@@ -414,10 +435,11 @@ mkLicenceTable aLic apids defAct = do
         ]
       dbtSorting = mconcat
         [ single $ sortUserNameLink queryUser                
-        , single ("valid-until" , SortColumn $ queryQualUser >>> (E.?. QualificationUserValidUntil))
+        , single ("qualification" , SortColumn $ queryQualification >>> (E.?. QualificationShorthand))
-        , single ("last-refresh", SortColumn $ queryQualUser >>> (E.?. QualificationUserLastRefresh))
+        , single ("valid-until"   , SortColumn $ queryQualUser      >>> (E.?. QualificationUserValidUntil))
-        , single ("first-held"  , SortColumn $ queryQualUser >>> (E.?. QualificationUserFirstHeld))
+        , single ("last-refresh"  , SortColumn $ queryQualUser      >>> (E.?. QualificationUserLastRefresh))
-        , single ("blocked-due" , SortColumn $ queryQualUser >>> (E.?. QualificationUserBlockedDue))
+        , single ("first-held"    , SortColumn $ queryQualUser      >>> (E.?. QualificationUserFirstHeld))
+        , single ("blocked-due"   , SortColumn $ queryQualUser      >>> (E.?. QualificationUserBlockedDue))
         ]
       dbtFilter = mconcat
         [ single $ fltrUserNameEmail   queryUser
@@ -425,7 +447,7 @@ mkLicenceTable aLic apids defAct = do
         ]
       dbtFilterUI mPrev = mconcat
         [ fltrUserNameEmailHdrUI MsgLmsUser mPrev
-        , prismAForm (singletonFilter "validity"     . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsValid)
+        , prismAForm (singletonFilter "validity" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsValid)
         ]
       acts :: Map LicenceTableAction (AForm Handler LicenceTableActionData)
       acts = mconcat
@@ -450,8 +472,8 @@ mkLicenceTable aLic apids defAct = do
       dbtCsvDecode = Nothing
       dbtExtraReps = []
       validator = def -- & defaultSorting [SortDescBy "column-label"]
-      postprocess :: FormResult (First LicenceTableActionData, DBFormResult UserId Bool LicenceTableData)
+      postprocess :: FormResult (First LicenceTableActionData, DBFormResult AvsPersonId Bool LicenceTableData) -- == DBFormResult (Map AvsPersonId (LicenceTableData, Bool -> Bool))
-                  -> FormResult (      LicenceTableActionData, Set UserId)
+                  -> FormResult (      LicenceTableActionData, Set AvsPersonId)
       postprocess inp = do 
         (First (Just act), usrMap) <- inp
         let usrSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) usrMap

src/Handler/Utils/Table/Cells.hs

@@ -277,6 +277,13 @@ qualificationCell Qualification{..} = anchorCell link name
     link = QualificationR qualificationSchool qualificationShorthand
     name = citext2widget qualificationName
 
+qualificationShortCell :: IsDBTable m a => Qualification -> DBCell m a
+qualificationShortCell Qualification{..} = anchorCell link name
+  where
+    link = QualificationR qualificationSchool qualificationShorthand
+    name = citext2widget qualificationShorthand
+
+
 qualificationDescrCell :: IsDBTable m a => Qualification -> DBCell m a
 qualificationDescrCell q@Qualification{..} = qualificationCell q <> desc
   where

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, Hashable)
+  deriving newtype (NFData, PathPiece, PersistField, PersistFieldSql, Csv.ToField, Csv.FromField, Hashable, Binary)
 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

src/Model/Types/Lms.hs

@@ -1,4 +1,3 @@
--- SPDX-FileCopyrightText: 2022 Steffen Jost <jost@tcs.ifi.lmu.de>
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later