chore(avs): WIP fixing avs synch problems

src/Database/Esqueleto/Utils.hs

@@ -7,7 +7,7 @@
 
 module Database.Esqueleto.Utils
   ( true, false
-  , justVal, justValList, toValues
+  , vals, justVal, justValList, toValues
   , isJust, alt
   , isInfixOf, hasInfix
   , strConcat, substring
@@ -98,6 +98,9 @@ false = E.val False
 -- infinity :: E.SqlExpr (E.Value UTCTime)
 -- infinity = unsafeSqlValue "'infinity'"
 
+vals :: (MonoFoldable mono, PersistField (Element mono)) => mono -> E.SqlExpr (E.ValueList (Element mono))
+vals = E.valList . toList
+
 justVal :: PersistField typ => typ -> E.SqlExpr (E.Value (Maybe typ))
 -- justVal = E.val . Just
 justVal = E.just . E.val
@@ -327,9 +330,9 @@ allFilter fltrs needle criterias = F.foldr aux true fltrs
 
 
 orderByList :: PersistField a => [a] -> E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value Int)
-orderByList vals
+orderByList valus
-  = let sortUni = zip [1..] vals -- memoize this, might not work due to polymorphism
+  = let sortUni = zip [1..] valus -- memoize this, might not work due to polymorphism
-     in \x -> E.case_ [ (x E.==. E.val u, E.val i) | (i,u) <- sortUni ] (E.val . succ $ List.length vals)
+     in \x -> E.case_ [ (x E.==. E.val u, E.val i) | (i,u) <- sortUni ] (E.val . succ $ List.length valus)
 
 orderByOrd :: (Ord a, Finite a, PersistField a) => E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value Int)
 orderByOrd = orderByList $ List.sort universeF

src/Handler/Admin/Avs.hs

@@ -2,6 +2,9 @@
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
+
+{-# OPTIONS_GHC -fno-warn-orphans #-}      -- needed for HasEntity instances
+{-# OPTIONS -Wno-unused-top-binds #-}      -- TODO: remove me, for debugging only
 {-# LANGUAGE TypeApplications #-}
 
 module Handler.Admin.Avs
@@ -14,6 +17,7 @@ import qualified Control.Monad.State.Class as State
 -- import Data.Aeson (encode)
 import qualified Data.Text as Text
 import qualified Data.Set  as Set
+import qualified Data.Map as Map
 
 import Handler.Utils
 import Handler.Utils.Avs
@@ -27,6 +31,10 @@ 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
 
+-- avoids repetition of local definitions
+single :: (k,a) -> Map k a
+single = uncurry Map.singleton
+
 
 -- Button needed only here
 data ButtonAvsTest = BtnCheckLicences | BtnSynchLicences
@@ -284,7 +292,7 @@ getProblemAvsSynchR = do
   -- let TimeOfDay hours minutes _seconds = timeToTimeOfDay (utctDayTime now)
   --     setTo0 = Set.fromList [AvsPersonId hours, AvsPersonId minutes]
 
-  (setTo0, _setTo1, _setTo2) <- try retrieveDifferingLicences >>= \case
+  (setTo0, setTo1, setTo2) <- try retrieveDifferingLicences >>= \case
     Right res -> return res
     Left  err -> do addMessageModal Error (i18n MsgAvsCommunicationError) (Right (text2widget $ tshow (err :: SomeException)))
                     redirect AdminR
@@ -317,17 +325,93 @@ getProblemAvsSynchR = do
         Right False -> addMessageI Error MsgRevokeUnknownLicencesFail
         Left  err   -> addMessageModal Error (i18n MsgAvsCommunicationError) (Right (text2widget $ tshow (err :: SomeException)))
       >> redirect ProblemAvsSynchR
+    
+  ((_,tb0),(_,tb1),(_,tb2)) <- runDB $ (,,) 
+          <$> mkLicenceTable AvsNoLicence       setTo0
+          <*> mkLicenceTable AvsLicenceVorfeld  setTo1
+          <*> mkLicenceTable AvsLicenceRollfeld setTo2
 
-  -- 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")
 
+
+type LicenceTableExpr = (                 E.SqlExpr (Entity UserAvs)        
+                          `E.InnerJoin`   E.SqlExpr (Entity User)  
+                        ) `E.LeftOuterJoin` (
+                                          E.SqlExpr (Maybe (Entity QualificationUser))
+                          `E.InnerJoin`   E.SqlExpr (Maybe (Entity Qualification))
+                        )                        
+
+queryUser :: LicenceTableExpr -> E.SqlExpr (Entity User)
+queryUser = $(E.sqlIJproj 2 2) . $(E.sqlLOJproj 2 1)
+
+queryQualUser :: LicenceTableExpr -> E.SqlExpr (Maybe (Entity QualificationUser))
+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), E.Value AvsPersonId)
+
+resultUser :: Lens' LicenceTableData (Entity User) 
+resultUser = _dbrOutput . _1
+
+resultQualUser :: Traversal' LicenceTableData (Entity QualificationUser) 
+resultQualUser = _dbrOutput . _2 . _Just
+
+resultAvsPID :: Traversal' LicenceTableData (Entity QualificationUser) 
+resultAvsPID = _dbrOutput . _3 . _unValue
+
+instance HasEntity LicenceTableData User where 
+  hasEntity = resultUser
+
+instance HasUser LicenceTableData where 
+  hasUser   = resultUser . _entityVal
+
+mkLicenceTable :: AvsLicence -> Set AvsPersonId -> DB (DBResult Handler ())
+mkLicenceTable aLic apids = do 
+  now <- liftIO getCurrentTime
+  let nowaday = utctDay now
+      dbtIdent = "drivingLicenceSynch" :: Text
+      dbtStyle = def
+      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.&&. (usrAvs E.^. UserAvsPersonId `E.in_` E.vals apids)
+        return (user, qualUser, usrAvs E.^. UserAvsPersonId)
+      dbtRowKey ((usrAvs `E.InnerJoin` _) `E.LeftOuterJoin` _) = usrAvs E.^. UserAvsPersonId
+      dbtProj = dbtProjFilteredPostId -- TODO: or dbtProjSimple what is the difference?
+      dbtColonnade = mconcat
+        [ dbSelect (applying _1) id (return . view resultAvsPID)
+        , colUserNameLink AdminUserR
+        , sortable (Just "valid-until")   (i18nCell MsgLmsQualificationValidUntil)   $ \(   view $ resultQualUser . _entityVal . _qualificationUserValidUntil  -> d)  -> dayCell d
+        , sortable (Just "last-refresh")  (i18nCell MsgTableQualificationLastRefresh)$ \(   view $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d)  -> dayCell d
+        , sortable (Just "first-held")    (i18nCell MsgTableQualificationFirstHeld)  $ \(   view $ resultQualUser . _entityVal . _qualificationUserFirstHeld   -> d)  -> dayCell d
+        , sortable (Just "blocked-due")   (i18nCell MsgTableQualificationBlockedDue & cellTooltip MsgTableQualificationBlockedTooltip
+                                                                                   ) $ \(   view $ resultQualUser . _entityVal . _qualificationUserBlockedDue  -> b)  -> qualificationBlockedCell b
+        ]
+      dbtSorting = mconcat
+        [ single $ sortUserNameLink queryUser                
+        , single ("valid-until" , SortColumn $ queryQualUser >>> (E.?. QualificationUserValidUntil))
+        , 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)))
+        ]
+      dbtFilterUI mPrev = mconcat
+        [ fltrUserNameEmailHdrUI MsgLmsUser mPrev
+        , prismAForm (singletonFilter "validity"     . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsValid)
+        ]
+      dbtParams = def
+      dbtCsvEncode = noCsvEncode
+      dbtCsvDecode = Nothing
+      dbtExtraReps = []
+      validator = def -- & defaultSorting [SortDescBy "column-label"]
+  dbTable validator DBTable{..}

src/Handler/LMS.hs

@@ -393,11 +393,11 @@ mkLmsTable (Entity qid quali) acts restrict cols psValidator = do
     dbtColonnade = cols
     dbtSorting = mconcat
       [ single $ sortUserNameLink queryUser
-      , single $ sortUserEmail    queryUser
+      , single $ sortUserEmail    queryUser      
-      , single ("blocked-due" , SortColumn $ queryQualUser >>> (E.^. QualificationUserBlockedDue))
       , single ("valid-until" , SortColumn $ queryQualUser >>> (E.^. QualificationUserValidUntil))
       , single ("last-refresh", SortColumn $ queryQualUser >>> (E.^. QualificationUserLastRefresh))
       , single ("first-held"  , SortColumn $ queryQualUser >>> (E.^. QualificationUserFirstHeld))
+      , single ("blocked-due" , SortColumn $ queryQualUser >>> (E.^. QualificationUserBlockedDue))
       , single ("lms-ident"   , SortColumn $ queryLmsUser  >>> (E.?. LmsUserIdent))
       , single ("lms-status"  , SortColumn $ views (to queryLmsUser) (E.?. LmsUserStatus))
       , single ("lms-started" , SortColumn $ queryLmsUser  >>> (E.?. LmsUserStarted))

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

@@ -35,5 +35,16 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
 <section>
   <h2>
     Abweichende Fahrberechtigungen auflösen
+  <h3>
+    Fahrberechtigung Rollfeld im AVS erteilen
   <p>
-    Hier folgt eine dbTable mit Actions
+    ^{tb2}
+  <h3>
+    Fahrberechtigung Vorfeld im AVS erteilen
+  <p>
+    ^{tb1}
+  <h3>
+    Jegliche Fahrberechtigung im AVS entziehen
+  <p>
+    ^{tb0}
+