fraport/fradrive-old
Archived
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

chore(lms): use array_agg for print job acknowledgements

Browse Source
This commit is contained in:
Steffen Jost 2022-10-28 12:48:11 +02:00
parent 0054544d1d
commit fb82dcbb33
2 changed files with 20 additions and 19 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
src/Database/Esqueleto/Utils.hs
View File

@ -104,7 +104,7 @@ justValList = E.valList . map Just
infixl 4 =?. infixl 4 =?.
(=?.) :: PersistField typ => E.SqlExpr (E.Value typ) -> E.SqlExpr (E.Value (Maybe typ)) -> E.SqlExpr (E.Value Bool) (=?.) :: PersistField typ => E.SqlExpr (E.Value typ) -> E.SqlExpr (E.Value (Maybe typ)) -> E.SqlExpr (E.Value Bool)
(=?.) a b = E.just a E.==. b (=?.) = (E.==.) . E.just
infixl 4 ?=. infixl 4 ?=.
(?=.) :: PersistField typ => E.SqlExpr (E.Value (Maybe typ)) -> E.SqlExpr (E.Value typ) -> E.SqlExpr (E.Value Bool) (?=.) :: PersistField typ => E.SqlExpr (E.Value (Maybe typ)) -> E.SqlExpr (E.Value typ) -> E.SqlExpr (E.Value Bool)

11
src/Handler/LMS.hs
View File

@ -36,6 +36,7 @@ import qualified Data.CaseInsensitive as CI
import qualified Data.Conduit.List as C import qualified Data.Conduit.List as C
import qualified Database.Esqueleto.Experimental as Ex -- needs TypeApplications Lang-Pragma import qualified Database.Esqueleto.Experimental as Ex -- needs TypeApplications Lang-Pragma
import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Legacy as E
import qualified Database.Esqueleto.PostgreSQL as E
import qualified Database.Esqueleto.Utils as E import qualified Database.Esqueleto.Utils as E
import Database.Esqueleto.Utils.TH import Database.Esqueleto.Utils.TH
@ -267,7 +268,7 @@ queryLmsUser = $(sqlLOJproj 3 2)
queryPrintJob :: LmsTableExpr -> E.SqlExpr (Maybe (Entity PrintJob)) queryPrintJob :: LmsTableExpr -> E.SqlExpr (Maybe (Entity PrintJob))
queryPrintJob = $(sqlLOJproj 3 3) queryPrintJob = $(sqlLOJproj 3 3)
type LmsTableData = DBRow (Entity QualificationUser, Entity User, Maybe (Entity LmsUser), Maybe (Entity PrintJob), E.Value (Maybe UTCTime)) type LmsTableData = DBRow (Entity QualificationUser, Entity User, Maybe (Entity LmsUser), Maybe (Entity PrintJob), E.Value (Maybe [Maybe UTCTime]))
resultQualUser :: Lens' LmsTableData (Entity QualificationUser) resultQualUser :: Lens' LmsTableData (Entity QualificationUser)
resultQualUser = _dbrOutput . _1 resultQualUser = _dbrOutput . _1
@ -281,7 +282,7 @@ resultLmsUser = _dbrOutput . _3 . _Just
resultPrintJob :: Traversal' LmsTableData (Entity PrintJob) resultPrintJob :: Traversal' LmsTableData (Entity PrintJob)
resultPrintJob = _dbrOutput . _4 . _Just resultPrintJob = _dbrOutput . _4 . _Just
resultPrintAck :: Traversal' LmsTableData UTCTime resultPrintAck :: Traversal' LmsTableData [Maybe UTCTime]
resultPrintAck = _dbrOutput . _5 . _unValue . _Just resultPrintAck = _dbrOutput . _5 . _unValue . _Just
instance HasEntity LmsTableData User where instance HasEntity LmsTableData User where
@ -320,7 +321,7 @@ lmsTableQuery :: QualificationId -> LmsTableExpr -> E.SqlQuery ( E.SqlExpr (Enti
, E.SqlExpr (Entity User) , E.SqlExpr (Entity User)
, E.SqlExpr (Maybe (Entity LmsUser)) , E.SqlExpr (Maybe (Entity LmsUser))
, E.SqlExpr (Maybe (Entity PrintJob)) , E.SqlExpr (Maybe (Entity PrintJob))
, E.SqlExpr (E.Value (Maybe UTCTime)) , E.SqlExpr (E.Value (Maybe [Maybe UTCTime]))
) )
lmsTableQuery qid (qualUser `E.InnerJoin` user `E.LeftOuterJoin` lmsUser `E.LeftOuterJoin` printJob) = do lmsTableQuery qid (qualUser `E.InnerJoin` user `E.LeftOuterJoin` lmsUser `E.LeftOuterJoin` printJob) = do
-- E.distinctOn [E.don $ printJob E.?. PrintJobLmsUser] $ do -- types, but destroys the ability to sort interactively, since distinctOn requires sorting; -- E.distinctOn [E.don $ printJob E.?. PrintJobLmsUser] $ do -- types, but destroys the ability to sort interactively, since distinctOn requires sorting;
@ -339,7 +340,7 @@ lmsTableQuery qid (qualUser `E.InnerJoin` user `E.LeftOuterJoin` lmsUser `E.Left
let printAcknowledged = E.subSelectMaybe . E.from $ \pj -> do let printAcknowledged = E.subSelectMaybe . E.from $ \pj -> do
E.where_ $ E.isJust (pj E.^. PrintJobLmsUser) E.where_ $ E.isJust (pj E.^. PrintJobLmsUser)
E.&&. ((lmsUser E.?. LmsUserIdent) E.==. (pj E.^. PrintJobLmsUser)) E.&&. ((lmsUser E.?. LmsUserIdent) E.==. (pj E.^. PrintJobLmsUser))
pure $ E.joinV $ E.max_ $ pj E.^. PrintJobAcknowledged pure $ E.arrayAggWith E.AggModeAll (pj E.^. PrintJobAcknowledged) [E.asc $ pj E.^. PrintJobCreated]
return (qualUser, user, lmsUser, printJob, printAcknowledged) return (qualUser, user, lmsUser, printJob, printAcknowledged)
@ -522,7 +523,7 @@ postLmsR sid qsh = do
in if notNotified in if notNotified
then mempty then mempty
else cIcon <> spacerCell <> cDate else cIcon <> spacerCell <> cDate
, sortable (Just "lms-notified-alternative") (i18nLms MsgTableLmsNotified) $ \(preview resultPrintAck -> d) -> foldMap dateTimeCell d , sortable (Just "lms-notified-alternative") (i18nLms MsgTableLmsNotified) $ \(preview resultPrintAck -> d) -> textCell (show d)
, sortable (Just "lms-ended") (i18nLms MsgTableLmsEnded) $ \(preview $ resultLmsUser . _entityVal . _lmsUserEnded -> d) -> foldMap dateTimeCell $ join d , sortable (Just "lms-ended") (i18nLms MsgTableLmsEnded) $ \(preview $ resultLmsUser . _entityVal . _lmsUserEnded -> d) -> foldMap dateTimeCell $ join d
] ]
where where