diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index 128307869..041af20f7 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/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 - = let sortUni = zip [1..] vals -- 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) +orderByList valus + = 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 valus) orderByOrd :: (Ord a, Finite a, PersistField a) => E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value Int) orderByOrd = orderByList $ List.sort universeF diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs index 6e6c51985..53982ca99 100644 --- a/src/Handler/Admin/Avs.hs +++ b/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{..} \ No newline at end of file diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index b03e7f8ef..54af00732 100644 --- a/src/Handler/LMS.hs +++ b/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 ("blocked-due" , SortColumn $ queryQualUser >>> (E.^. QualificationUserBlockedDue)) + , single $ sortUserEmail 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)) , single ("lms-ident" , SortColumn $ queryLmsUser >>> (E.?. LmsUserIdent)) , single ("lms-status" , SortColumn $ views (to queryLmsUser) (E.?. LmsUserStatus)) , single ("lms-started" , SortColumn $ queryLmsUser >>> (E.?. LmsUserStarted)) diff --git a/templates/i18n/avs-synchronisation/de-de-formal.hamlet b/templates/i18n/avs-synchronisation/de-de-formal.hamlet index 7e8ead8be..707595162 100644 --- a/templates/i18n/avs-synchronisation/de-de-formal.hamlet +++ b/templates/i18n/avs-synchronisation/de-de-formal.hamlet @@ -35,5 +35,16 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later

Abweichende Fahrberechtigungen auflösen +

+ Fahrberechtigung Rollfeld im AVS erteilen

- Hier folgt eine dbTable mit Actions \ No newline at end of file + ^{tb2} +

+ Fahrberechtigung Vorfeld im AVS erteilen +

+ ^{tb1} +

+ Jegliche Fahrberechtigung im AVS entziehen +

+ ^{tb0} + \ No newline at end of file