chore(avs): fix qualification validity filtering

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

@@ -21,4 +21,5 @@ RevokeUnknownLicencesOk: AVS Fahrberechtigungen unbekannter Fahrer wurden gesper
 RevokeUnknownLicencesFail: Nicht alle AVS Fahrberechtigungen unbekannter Fahrer konnten entzogen werden, siehe Log für Details
 AvsCommunicationError: AVS Schnittstelle lieferte einen unerwarteten Fehler.
 LicenceTableChangeAvs: Im AVS ändern
-LicenceTableChangeFDrive: In FRADrive ändern
+LicenceTableGrantFDrive: In FRADrive erteilen
+LicenceTableRevokeFDrive: In FRADrive entziehen

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

@@ -21,4 +21,5 @@ 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.
 LicenceTableChangeAvs: Change in AVS
-LicenceTableChangeFDrive: Change within FRADrive
+LicenceTableGrantFDrive: Grant in FRADrive
+LicenceTableRevokeFDrive: Revoke in FRADrive

src/Handler/Admin/Avs.hs

@@ -286,7 +286,8 @@ instance Button UniWorX ButtonAvsSynch where
 
 
 data LicenceTableAction =  LicenceTableChangeAvs
-                        |  LicenceTableChangeFDrive
+                        |  LicenceTableRevokeFDrive
+                        |  LicenceTableGrantFDrive
   deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
 
 instance Universe LicenceTableAction
@@ -295,7 +296,8 @@ nullaryPathPiece ''LicenceTableAction $ camelToPathPiece' 2
 embedRenderMessage ''UniWorX ''LicenceTableAction id
 
 data LicenceTableActionData =  LicenceTableChangeAvsData
-                            |  LicenceTableChangeFDriveData { licenceTableChangeFDriveEnd :: Day }
+                            |  LicenceTableRevokeFDriveData
+                            |  LicenceTableGrantFDriveData { licenceTableChangeFDriveEnd :: Day }
   deriving (Eq, Ord, Read, Show, Generic, Typeable)
 
 
@@ -303,16 +305,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,20 +345,17 @@ getProblemAvsSynchR = do
         Left  err   -> addMessageModal Error (i18n MsgAvsCommunicationError) (Right (text2widget $ tshow (err :: SomeException)))
       >> redirect ProblemAvsSynchR
     
-  ((r0,tb0),(r1,tb1),(r2,tb2)) <- runDB $ (,,) 
+  ((tres0,tb0),(tres1,tb1),(tres2,tb2)) <- runDB $ (,,) 
           <$> mkLicenceTable "driveSynchNoLicence"  AvsNoLicence       setTo0 (Just LicenceTableChangeAvs)
           <*> mkLicenceTable "driveSynchVorfeld"    AvsLicenceVorfeld  setTo1 (Just LicenceTableChangeAvs)
           <*> mkLicenceTable "driveSynchRollfeld"   AvsLicenceRollfeld setTo2 (Just LicenceTableChangeAvs)
-
+  let procRes :: AvsLicence -> (LicenceTableActionData, Set AvsPersonId) -> Handler ()
-  -- for debugging
+      procRes _alic r@(LicenceTableChangeAvsData       , _apids) = addMessage Info $ toHtml $ tshow r
-  let sres x = case x of 
+      procRes _alic r@(_, _apids) = addMessage Info $ toHtml $ tshow r
-                FormSuccess (tda, ids) -> addMessage Info $ toHtml $ "Received " <> tshow (Set.size ids) <> " ids for " <> tshow tda
+  formResult tres2 $ procRes AvsLicenceRollfeld
-                _ -> pure ()
+  formResult tres1 $ procRes AvsLicenceVorfeld
-  sres r0
+  formResult tres0 $ procRes AvsNoLicence
-  sres r1
+  
-  sres r2
-  -- end debugging
-
   siteLayoutMsg MsgAvsTitleLicenceSynch $ do
     setTitleI   MsgAvsTitleLicenceSynch
     $(i18nWidgetFile "avs-synchronisation")
@@ -406,10 +405,8 @@ mkLicenceTable :: Text -> AvsLicence -> Set AvsPersonId -> Maybe LicenceTableAct
 mkLicenceTable dbtIdent aLic apids defAct = do 
   currentRoute <- fromMaybe (error "mkLicenceTable called from 404-handler") <$> liftHandler getCurrentRoute
   now <- liftIO getCurrentTime
-  let nowaday = utctDay now      
+  let nowaday = utctDay now            
-      dbtStyle = def
+      fltrLic qual = if 
-      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:       
@@ -422,7 +419,7 @@ mkLicenceTable dbtIdent aLic apids defAct = do
       dbtRowKey = (queryUserAvs       >>> (E.^. UserAvsPersonId)) 
               &&& (queryQualification >>> (E.?. QualificationId)) 
       --dbtProj = dbtProjSimple $ \(user, qualUsr, E.Value api, quali) -> return (user, qualUsr, api, quali)
-      dbtProj = dbtProjSimple $ pure . over _3 E.unValue 
+      dbtProj = dbtProjSimple $ pure . over _3 E.unValue -- just remove Value wrapper in 3rd element
       dbtColonnade = mconcat
         [ dbSelect (applying _2) id $ \DBRow{dbrOutput=(_,_,apid,_)} -> return apid -- return . view resultAvsPID -- does not type due to traversal
         , colUserNameLink AdminUserR
@@ -440,10 +437,11 @@ mkLicenceTable dbtIdent aLic apids defAct = do
         , single ("last-refresh"  , SortColumn $ queryQualUser      >>> (E.?. QualificationUserLastRefresh))
         , single ("first-held"    , SortColumn $ queryQualUser      >>> (E.?. QualificationUserFirstHeld))
         , single ("blocked-due"   , SortColumn $ queryQualUser      >>> (E.?. QualificationUserBlockedDue))
-        ]
+        ]      
+
       dbtFilter = mconcat
         [ single $ fltrUserNameEmail   queryUser
-        , single ("validity"    , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) ((E.>=. E.justVal nowaday) . (E.?. QualificationUserValidUntil)))
+        , single ("validity"     , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) (validQualification' nowaday)) -- why does this not work?        
         ]
       dbtFilterUI mPrev = mconcat
         [ fltrUserNameEmailHdrUI MsgLmsUser mPrev
@@ -452,9 +450,10 @@ mkLicenceTable dbtIdent aLic apids defAct = do
       acts :: Map LicenceTableAction (AForm Handler LicenceTableActionData)
       acts = mconcat
           [ singletonMap LicenceTableChangeAvs    $ pure LicenceTableChangeAvsData
-          , singletonMap LicenceTableChangeFDrive (LicenceTableChangeFDriveData <$> apopt dayField (fslI MsgLmsQualificationValidUntil) Nothing)
+          , if aLic == AvsNoLicence
-          ]
+              then singletonMap LicenceTableGrantFDrive  $ LicenceTableGrantFDriveData <$> apopt dayField (fslI MsgLmsQualificationValidUntil) Nothing
-          
+              else singletonMap LicenceTableRevokeFDrive $ pure LicenceTableRevokeFDriveData
+          ]      
       dbtParams = DBParamsForm
           { dbParamsFormMethod = POST
           , dbParamsFormAction = Just $ SomeRoute currentRoute
@@ -471,6 +470,7 @@ mkLicenceTable dbtIdent aLic apids defAct = do
       dbtCsvEncode = noCsvEncode
       dbtCsvDecode = Nothing
       dbtExtraReps = []
+      dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }          
       validator = def -- & defaultSorting [SortDescBy "column-label"]
       postprocess :: FormResult (First LicenceTableActionData, DBFormResult AvsPersonId Bool LicenceTableData) -- == DBFormResult (Map AvsPersonId (LicenceTableData, Bool -> Bool))
                   -> FormResult (      LicenceTableActionData, Set AvsPersonId)

src/Handler/LMS.hs

@@ -45,6 +45,8 @@ import Handler.LMS.Userlist as Handler.LMS
 import Handler.LMS.Result   as Handler.LMS
 import Handler.LMS.Fake     as Handler.LMS -- TODO: remove in production!
 
+import Handler.Utils.Avs (validQualification) -- TODO: why cant we use validQualification below?
+
 -- avoids repetition of local definitions
 single :: (k,a) -> Map k a
 single = uncurry Map.singleton
@@ -116,7 +118,7 @@ mkLmsAllTable isAdmin = do
               cactive = Ex.subSelectCount $ do
                 quser <- Ex.from $ Ex.table @QualificationUser
                 Ex.where_ $ quser Ex.^. QualificationUserQualification Ex.==. quali Ex.^. QualificationId
-                      E.&&. quser Ex.^. QualificationUserValidUntil    Ex.>=. E.val (utctDay now)
+                      E.&&. validQualification (utctDay now) quser
           -- Failed attempt using Join/GroupBy instead of subselect: see branch csv-osis-demo-groupby-problem
           return (quali, cactive, cusers)
         dbtRowKey = (E.^. QualificationId)
@@ -411,7 +413,8 @@ mkLmsTable (Entity qid quali) acts restrict cols psValidator = do
       , single $ fltrUserNameEmail   queryUser
       , single ("lms-ident"   , FilterColumn . E.mkContainsFilterWith (Just . LmsIdent) $ views (to queryLmsUser) (E.?. LmsUserIdent))
       -- , single ("lms-status"  , FilterColumn . E.mkExactFilterLast $ views (to queryLmsUser) ((E.>=. E.val nowaday) . (E.^. LmsUserStatus))) -- LmsStatus cannot be filtered easily within the DB
-      , single ("validity"    , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) ((E.>=. E.val nowaday) . (E.^. QualificationUserValidUntil)))
+      -- , single ("validity"    , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) ((E.>=. E.val nowaday) . (E.^. QualificationUserValidUntil)))
+      , single ("validity"    , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) (validQualification nowaday))
       , single ("renewal-due" , FilterColumn $ \(queryQualUser -> quser) criterion ->
           if | Just renewal <- mbRenewal
              , Just True <- getLast criterion -> quser E.^. QualificationUserValidUntil E.<=. E.val renewal

src/Handler/Utils/Avs.hs

@@ -6,7 +6,8 @@
 
 
 module Handler.Utils.Avs
-  ( upsertAvsUser, upsertAvsUserById, upsertAvsUserByCard
+  ( validQualification, validQualification'
+  , upsertAvsUser, upsertAvsUserById, upsertAvsUserByCard
   -- , getLicence, getLicenceDB, getLicenceByAvsId -- not supported by interface
   , setLicence, setLicenceAvs, setLicencesAvs
   , retrieveDifferingLicences, computeDifferingLicences
@@ -57,6 +58,22 @@ instance Exception AvsException
   Error Handling: in Addition to AvsException, Servant.ClientError must be expected. Maybe we should wrap it within an AvsException?
 -}
 
+------------------
+-- SQL Snippets --
+------------------
+
+validQualification :: Day -> E.SqlExpr (Entity QualificationUser) -> E.SqlExpr (E.Value Bool)
+validQualification nowaday = \qualUser ->
+  (E.val nowaday `E.between` (qualUser E.^. QualificationUserFirstHeld
+                             ,qualUser E.^. QualificationUserValidUntil))   -- currently valid
+           E.&&. E.isNothing (qualUser E.^. QualificationUserBlockedDue)    -- not blocked            
+
+validQualification' :: Day -> E.SqlExpr (Maybe (Entity QualificationUser)) -> E.SqlExpr (E.Value Bool)
+validQualification' nowaday qualUser =
+  (E.justVal nowaday `E.between` (qualUser E.?. QualificationUserFirstHeld
+                                 ,qualUser E.?. QualificationUserValidUntil))   -- currently valid
+     E.&&. E.isNothing (E.joinV $ qualUser E.?. QualificationUserBlockedDue)    -- not blocked            
+
 
 ------------------
 -- AVS Handlers --
@@ -193,9 +210,7 @@ getDifferingLicences (AvsResponseGetLicences licences) = do
                     (quali E.^. QualificationId         E.==. qualUser E.^. QualificationUserQualification)
                 -- NOTE: filters on the innerJoin must be part of ON-condition in order for anti-join to work!
               E.&&. (quali E.^. QualificationAvsLicence E.==. E.justVal lic)                  -- correct type of licence
-              E.&&. (E.val nowaday `E.between` (qualUser E.^. QualificationUserFirstHeld
+              E.&&. (nowaday `validQualification` qualUser)                                   -- currently valid and not blocked              
-                                               ,qualUser E.^. QualificationUserValidUntil))   -- currently valid
-              E.&&. E.isNothing (qualUser E.^. QualificationUserBlockedDue)                   -- not blocked
               )
             `E.innerJoin` E.table @UserAvs
             `E.on` (\(_ :& qualUser :& usrAvs) -> qualUser E.^. QualificationUserUser E.==. usrAvs E.^. UserAvsUser)