chore(avs): WIP fixing avs synch problems
This commit is contained in:
Steffen Jost
parent
df1a816d83
commit
37b46a3abb
@ -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
|
||||
|
||||
@ -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{..}
|
||||
@ -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))
|
||||
|
||||
@ -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}
|
||||
|
||||
Loading…
Reference in New Issue
Block a user