From 2093cf501827ab2305f26ab5cf742f2b0be4a7de Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 28 Apr 2023 15:56:12 +0000 Subject: [PATCH] fix(cvs): export company in e-learning view --- src/Handler/LMS.hs | 226 +++++++++++++++++++---------------- src/Handler/Qualification.hs | 2 +- 2 files changed, 124 insertions(+), 104 deletions(-) diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index ef8f77347..d902aed38 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -195,38 +195,42 @@ postLmsEditR = error "TODO: STUB" data LmsTableCsv = LmsTableCsv -- L..T..C.. -> ltc.. - { ltcDisplayName :: UserDisplayName - , ltcEmail :: UserEmail - , ltcValidUntil :: Day - , ltcLastRefresh :: Day - , ltcFirstHeld :: Day - , ltcBlockedDue :: Maybe QualificationBlocked - , ltcLmsIdent :: Maybe LmsIdent - , ltcLmsStatus :: Maybe LmsStatus - , ltcLmsStarted :: Maybe UTCTime - , ltcLmsDatePin :: Maybe UTCTime - , ltcLmsReceived :: Maybe UTCTime - , ltcLmsNotified :: Maybe UTCTime - , ltcLmsEnded :: Maybe UTCTime + { ltcDisplayName :: UserDisplayName + , ltcEmail :: UserEmail + , ltcCompany :: Maybe Text + , ltcCompanyNumbers :: CsvSemicolonList Int + , ltcValidUntil :: Day + , ltcLastRefresh :: Day + , ltcFirstHeld :: Day + , ltcBlockedDue :: Maybe QualificationBlocked + , ltcLmsIdent :: Maybe LmsIdent + , ltcLmsStatus :: Maybe LmsStatus + , ltcLmsStarted :: Maybe UTCTime + , ltcLmsDatePin :: Maybe UTCTime + , ltcLmsReceived :: Maybe UTCTime + , ltcLmsNotified :: Maybe UTCTime + , ltcLmsEnded :: Maybe UTCTime } deriving Generic makeLenses_ ''LmsTableCsv ltcExample :: LmsTableCsv ltcExample = LmsTableCsv - { ltcDisplayName = "Max Mustermann" - , ltcEmail = "m.mustermann@example.com" - , ltcValidUntil = compDay - , ltcLastRefresh = compDay - , ltcFirstHeld = compDay - , ltcBlockedDue = Nothing - , ltcLmsIdent = Nothing - , ltcLmsStatus = Nothing - , ltcLmsStarted = Just compTime - , ltcLmsDatePin = Nothing - , ltcLmsReceived = Nothing - , ltcLmsNotified = Nothing - , ltcLmsEnded = Nothing + { ltcDisplayName = "Max Mustermann" + , ltcEmail = "m.mustermann@example.com" + , ltcCompany = Just "Example Brothers LLC, SecondaryJobs Inc" + , ltcCompanyNumbers = CsvSemicolonList [27,69] + , ltcValidUntil = compDay + , ltcLastRefresh = compDay + , ltcFirstHeld = compDay + , ltcBlockedDue = Nothing + , ltcLmsIdent = Nothing + , ltcLmsStatus = Nothing + , ltcLmsStarted = Just compTime + , ltcLmsDatePin = Nothing + , ltcLmsReceived = Nothing + , ltcLmsNotified = Nothing + , ltcLmsEnded = Nothing } where compTime :: UTCTime @@ -253,35 +257,37 @@ instance Csv.DefaultOrdered LmsTableCsv where instance CsvColumnsExplained LmsTableCsv where csvColumnsExplanations = genericCsvColumnsExplanations ltcOptions $ Map.fromList - [ ('ltcDisplayName, MsgLmsUser) - , ('ltcEmail , MsgTableLmsEmail) - , ('ltcValidUntil , MsgLmsQualificationValidUntil) - , ('ltcLastRefresh, MsgTableQualificationLastRefresh) - , ('ltcFirstHeld , MsgTableQualificationFirstHeld) - , ('ltcLmsIdent , MsgTableLmsIdent) - , ('ltcLmsStatus , MsgTableLmsStatus) - , ('ltcLmsStarted , MsgTableLmsStarted) - , ('ltcLmsDatePin , MsgTableLmsDatePin) - , ('ltcLmsReceived, MsgTableLmsReceived) - , ('ltcLmsEnded , MsgTableLmsEnded) + [ ('ltcDisplayName , SomeMessage MsgLmsUser) + , ('ltcEmail , SomeMessage MsgTableLmsEmail) + , ('ltcCompany , SomeMessage MsgTableCompanies) + , ('ltcCompanyNumbers , SomeMessage MsgTableCompanyNos) + , ('ltcValidUntil , SomeMessage MsgLmsQualificationValidUntil) + , ('ltcLastRefresh , SomeMessage MsgTableQualificationLastRefresh) + , ('ltcFirstHeld , SomeMessage MsgTableQualificationFirstHeld) + , ('ltcLmsIdent , SomeMessage MsgTableLmsIdent) + , ('ltcLmsStatus , SomeMessage MsgTableLmsStatus) + , ('ltcLmsStarted , SomeMessage MsgTableLmsStarted) + , ('ltcLmsDatePin , SomeMessage MsgTableLmsDatePin) + , ('ltcLmsReceived , SomeMessage MsgTableLmsReceived) + , ('ltcLmsEnded , SomeMessage MsgTableLmsEnded) ] -type LmsTableExpr = ( E.SqlExpr (Entity QualificationUser) - `E.InnerJoin` E.SqlExpr (Entity User) - ) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity LmsUser)) +type LmsTableExpr = E.SqlExpr (Entity QualificationUser) + `E.InnerJoin` E.SqlExpr (Entity User) + `E.InnerJoin` E.SqlExpr (Entity LmsUser) queryQualUser :: LmsTableExpr -> E.SqlExpr (Entity QualificationUser) -queryQualUser = $(sqlIJproj 2 1) . $(sqlLOJproj 2 1) +queryQualUser = $(sqlIJproj 3 1) queryUser :: LmsTableExpr -> E.SqlExpr (Entity User) -queryUser = $(sqlIJproj 2 2) . $(sqlLOJproj 2 1) +queryUser = $(sqlIJproj 3 2) -queryLmsUser :: LmsTableExpr -> E.SqlExpr (Maybe (Entity LmsUser)) -queryLmsUser = $(sqlLOJproj 2 2) +queryLmsUser :: LmsTableExpr -> E.SqlExpr (Entity LmsUser) +queryLmsUser = $(sqlIJproj 3 3) -type LmsTableData = DBRow (Entity QualificationUser, Entity User, Maybe (Entity LmsUser), E.Value (Maybe [Maybe UTCTime])) +type LmsTableData = DBRow (Entity QualificationUser, Entity User, Entity LmsUser, E.Value (Maybe [Maybe UTCTime]), [Entity UserCompany]) resultQualUser :: Lens' LmsTableData (Entity QualificationUser) resultQualUser = _dbrOutput . _1 @@ -289,12 +295,15 @@ resultQualUser = _dbrOutput . _1 resultUser :: Lens' LmsTableData (Entity User) resultUser = _dbrOutput . _2 -resultLmsUser :: Traversal' LmsTableData (Entity LmsUser) -resultLmsUser = _dbrOutput . _3 . _Just +resultLmsUser :: Lens' LmsTableData (Entity LmsUser) +resultLmsUser = _dbrOutput . _3 resultPrintAck :: Traversal' LmsTableData [Maybe UTCTime] resultPrintAck = _dbrOutput . _4 . _unValue . _Just +resultCompanyUser :: Lens' LmsTableData [Entity UserCompany] +resultCompanyUser = _dbrOutput . _5 + instance HasEntity LmsTableData User where hasEntity = resultUser @@ -330,53 +339,58 @@ isRenewPinAct LmsActRenewPinData = True lmsTableQuery :: QualificationId -> LmsTableExpr -> E.SqlQuery ( E.SqlExpr (Entity QualificationUser) , E.SqlExpr (Entity User) - , E.SqlExpr (Maybe (Entity LmsUser)) + , E.SqlExpr (Entity LmsUser) , E.SqlExpr (E.Value (Maybe [Maybe UTCTime])) -- outer maybe indicates, whether a printJob exists, inner maybe indicates all acknowledged printJobs ) -lmsTableQuery qid (qualUser `E.InnerJoin` user `E.LeftOuterJoin` lmsUser) = do +lmsTableQuery qid (qualUser `E.InnerJoin` user `E.InnerJoin` lmsUser) = do -- RECALL: another outer join on PrintJob did not work out well, since -- - E.distinctOn [E.don $ printJob E.?. PrintJobLmsUser] $ do -- types, but destroys the ability to sort interactively, since distinctOn requires sorting; -- - using noExsists on printJob join condition works, but only deliver single value; -- experiments with separate sub-query showed that we would need two subsqueries to learn whether the request was indeed the latest - E.on $ user E.^. UserId E.=?. lmsUser E.?. LmsUserUser - E.&&. E.val qid E.=?. lmsUser E.?. LmsUserQualification -- NOTE: condition was once erroneously placed in where-clause, which does not work + E.on $ user E.^. UserId E.==. lmsUser E.^. LmsUserUser + E.&&. E.val qid E.==. lmsUser E.^. LmsUserQualification -- NOTE: condition was once erroneously placed in where-clause, which does not work E.on $ user E.^. UserId E.==. qualUser E.^. QualificationUserUser E.where_ $ E.val qid E.==. qualUser E.^. QualificationUserQualification -- TODO: decide whether to use subSelect or LeftOuterJoin and delete the other! -- Letztes Datum anzeigen, wenn mehrere, dann diese in klickbaren Tooltip verstecken! let printAcknowledged = E.subSelectMaybe . E.from $ \pj -> do E.where_ $ E.isJust (pj E.^. PrintJobLmsUser) - E.&&. ((lmsUser E.?. LmsUserIdent) E.==. (pj E.^. PrintJobLmsUser)) + E.&&. ((lmsUser E.^. LmsUserIdent) E.=?. (pj E.^. PrintJobLmsUser)) let pjOrder = [E.desc $ pj E.^. PrintJobCreated, E.desc $ pj E.^. PrintJobAcknowledged] -- latest created comes first! This is assumed to be the case later on! pure $ --(E.arrayAggWith E.AggModeAll (pj E.^. PrintJobCreated ) pjOrder, -- return two aggregates only works with select, the restricted typr of subSelect does not seem to support this! E.arrayAggWith E.AggModeAll (pj E.^. PrintJobAcknowledged) pjOrder return (qualUser, user, lmsUser, printAcknowledged) -mkLmsTable :: forall h p cols act act'. - ( Functor h, ToSortable h - , Ord act, PathPiece act, RenderMessage UniWorX act - , AsCornice h p LmsTableData (DBCell (MForm Handler) (FormResult (First act', DBFormResult UserId Bool LmsTableData))) cols +mkLmsTable :: ( Functor h, ToSortable h + , AsCornice h p LmsTableData (DBCell (MForm Handler) (FormResult (First LmsTableActionData, DBFormResult UserId Bool LmsTableData))) cols ) => Bool -> Entity Qualification - -> Map act (AForm Handler act') - -> cols - -> PSValidator (MForm Handler) (FormResult (First act', DBFormResult UserId Bool LmsTableData)) - -> DB (FormResult (act', Set UserId), Widget) + -> Map LmsTableAction (AForm Handler LmsTableActionData) + -> (Map CompanyId (Entity Company) -> cols) + -> PSValidator (MForm Handler) (FormResult (First LmsTableActionData, DBFormResult UserId Bool LmsTableData)) + -> DB (FormResult (LmsTableActionData, Set UserId), Widget) mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do - now <- liftIO getCurrentTime - let + now <- liftIO getCurrentTime + let nowaday = utctDay now + companyStamp = "CompanyMap" <> tshow (roundDownToMinutes 5 now) + -- lookup all companies + cmpMap <- $cachedHereBinary companyStamp $ do + cmps <- selectList [] [Asc CompanyId] + return $ Map.fromAscList $ fmap (\c -> (entityKey c, c)) cmps + let mbRenewal = addGregorianDurationClip <$> qualificationRefreshWithin quali <*> Just nowaday csvName = T.replace " " "-" $ CI.original (quali ^. _qualificationName) dbtIdent :: Text dbtIdent = "qualification" dbtSQLQuery = lmsTableQuery qid dbtRowKey = queryUser >>> (E.^. UserId) - dbtProj = dbtProjId - - dbtColonnade = cols + dbtProj = dbtProjSimple $ \(qualUsr, usr, lmsUsr, printAcks) -> do + cmpUsr <- selectList [UserCompanyUser ==. entityKey usr] [Asc UserCompanyCompany] + return (qualUsr, usr, lmsUsr, printAcks, cmpUsr) + dbtColonnade = cols cmpMap dbtSorting = mconcat [ single $ sortUserNameLink queryUser , single $ sortUserEmail queryUser @@ -386,14 +400,14 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do , single ("first-held" , SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserFirstHeld)) , single ("blocked-due" , SortColumnNeverNull$ queryQualUser >>> (E.^. QualificationUserBlockedDue)) , single ("schedule-renew", SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserScheduleRenewal)) - , single ("lms-ident" , SortColumnNullsInv $ queryLmsUser >>> (E.?. LmsUserIdent)) - , single ("lms-pin" , SortColumnNullsInv $ queryLmsUser >>> (E.?. LmsUserPin)) - , single ("lms-status" , SortColumnNullsInv $ views (to queryLmsUser) (E.?. LmsUserStatus)) - , single ("lms-started" , SortColumnNullsInv $ queryLmsUser >>> (E.?. LmsUserStarted)) - , single ("lms-datepin" , SortColumnNullsInv $ queryLmsUser >>> (E.?. LmsUserDatePin)) - , single ("lms-received" , SortColumnNullsInv $ queryLmsUser >>> (E.?. LmsUserReceived)) - , single ("lms-notified" , SortColumnNullsInv $ queryLmsUser >>> (E.?. LmsUserNotified)) -- cannot include printJob acknowledge date - , single ("lms-ended" , SortColumnNullsInv $ queryLmsUser >>> (E.?. LmsUserEnded)) + , single ("lms-ident" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserIdent)) + , single ("lms-pin" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserPin)) + , single ("lms-status" , SortColumnNullsInv $ views (to queryLmsUser) (E.^. LmsUserStatus)) + , single ("lms-started" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserStarted)) + , single ("lms-datepin" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserDatePin)) + , single ("lms-received" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserReceived)) + , single ("lms-notified" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserNotified)) -- cannot include printJob acknowledge date + , single ("lms-ended" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserEnded)) , single ( "user-company" , SortColumn $ \row -> E.subSelect $ E.from $ \(usrComp `E.InnerJoin` comp) -> do E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId E.where_ $ usrComp E.^. UserCompanyUser E.==. queryUser row E.^. UserId @@ -403,7 +417,7 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do ] dbtFilter = mconcat [ single $ fltrUserNameEmail queryUser - , single ("lms-ident" , FilterColumn . E.mkContainsFilterWith (Just . LmsIdent) $ views (to queryLmsUser) (E.?. LmsUserIdent)) + , single ("lms-ident" , FilterColumn . E.mkContainsFilterWith 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) (validQualification nowaday)) @@ -413,7 +427,7 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do E.&&. quser E.^. QualificationUserValidUntil E.>=. E.val nowaday | otherwise -> E.true ) - , single ("lms-notified", FilterColumn . E.mkExactFilterLast $ views (to queryLmsUser) (E.isJust . (E.?. LmsUserNotified))) + , single ("lms-notified", FilterColumn . E.mkExactFilterLast $ views (to queryLmsUser) (E.isJust . (E.^. LmsUserNotified))) , single ("avs-number" , FilterColumn . E.mkExistsFilter $ \row criterion -> E.from $ \usrAvs -> -- do E.where_ $ usrAvs E.^. UserAvsUser E.==. queryUser row E.^. UserId @@ -455,6 +469,8 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do doEncode' = LmsTableCsv <$> view (resultUser . _entityVal . _userDisplayName) <*> view (resultUser . _entityVal . _userDisplayEmail) + <*> (view resultCompanyUser >>= getCompanies) + <*> (view resultCompanyUser >>= getCompanyNos) <*> view (resultQualUser . _entityVal . _qualificationUserValidUntil) <*> view (resultQualUser . _entityVal . _qualificationUserLastRefresh) <*> view (resultQualUser . _entityVal . _qualificationUserFirstHeld) @@ -466,6 +482,11 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do <*> (join . preview (resultLmsUser . _entityVal . _lmsUserReceived)) <*> (join . preview (resultLmsUser . _entityVal . _lmsUserNotified)) -- TODO: only exports last email date / print job sending date, not print acknowledge <*> (join . preview (resultLmsUser . _entityVal . _lmsUserEnded)) + getCompanies cmps = case mapMaybe (flip Map.lookup cmpMap . view (_entityVal . _userCompanyCompany)) cmps of + [] -> pure Nothing + somecmps -> pure $ Just $ intercalate ", " $ fmap (view (_entityVal . _companyName . _CI)) somecmps + getCompanyNos = pure . CsvSemicolonList . mapMaybe (preview (_Just . _entityVal . _companyAvsId) . flip Map.lookup cmpMap . view (_entityVal . _userCompanyCompany)) + dbtCsvDecode = Nothing dbtExtraReps = [] dbtParams = if not isAdmin then def {dbParamsFormAction = Nothing, dbParamsFormSubmit = FormNoSubmit} else @@ -513,20 +534,20 @@ postLmsR sid qsh = do -- , singletonMap LmsActRenewPin $ pure LmsActRenewPinData ] -- lmsStatusLink = toMaybe isAdmin LmsUserR - colChoices = mconcat + colChoices cmpMap = mconcat [ if not isAdmin then mempty else dbSelectIf (applying _2) id (return . view (resultUser . _entityKey)) (\r -> isJust $ r ^? resultLmsUser) -- TODO: refactor using function "is" , colUserNameModalHdr MsgLmsUser AdminUserR , colUserEmail - , sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \( view $ resultUser . _entityKey -> uid) -> flip (set' cellContents) mempty $ do -- why does sqlCell not work here? Mismatch "YesodDB UniWorX" and "RWST (Maybe (Env,FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX" - companies' <- liftHandler . runDB . E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do - E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId - E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid - E.orderBy [E.asc (comp E.^. CompanyName)] - return (comp E.^. CompanyName, usrComp E.^. UserCompanySupervisor) - let companies = intersperse (text2markup ", ") $ - (\(E.Value cmpName, E.Value cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> companies' - icnSuper = text2markup " " <> icon IconSupervisor - pure $ toWgt $ mconcat companies + , sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \( view resultCompanyUser -> cmps) -> + let icnSuper = text2markup " " <> icon IconSupervisor + cs = [ (cmpName, cmpSpr) + | Entity _ UserCompany{userCompanyCompany=cmpId, userCompanySupervisor=cmpSpr} <- cmps + , let cmpEnt = Map.lookup cmpId cmpMap + , Just (Entity _ Company{companyName = cmpName}) <- [cmpEnt] + ] + companies = intercalate (text2markup ", ") $ + (\(cmpName, cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> cs + in wgtCell companies , colUserMatriclenr , 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 @@ -535,22 +556,22 @@ postLmsR sid qsh = do ) $ \( view $ resultQualUser . _entityVal . _qualificationUserBlockedDue -> b) -> qualificationBlockedCell b , sortable (Just "schedule-renew")(i18nCell MsgTableQualificationNoRenewal & cellTooltip MsgTableQualificationNoRenewalTooltip ) $ \( view $ resultQualUser . _entityVal . _qualificationUserScheduleRenewal -> b) -> ifIconCell (not b) IconNoNotification - , sortable (Just "lms-ident") (i18nCell MsgTableLmsIdent) $ \(preview $ resultLmsUser . _entityVal . _lmsUserIdent . _getLmsIdent -> lid) -> foldMap textCell lid + , sortable (Just "lms-ident") (i18nCell MsgTableLmsIdent) $ \(view $ resultLmsUser . _entityVal . _lmsUserIdent . _getLmsIdent -> lid) -> textCell lid , sortable (Just "lms-pin") (i18nCell MsgTableLmsPin & cellAttrs <>~ [("uw-hide-column-default-hidden",mempty)] - ) $ \(preview $ resultLmsUser . _entityVal . _lmsUserPin -> pin) -> foldMap textCell pin - , sortable (Just "lms-status") (i18nCell MsgTableLmsStatus) $ \(preview $ resultLmsUser . _entityVal . _lmsUserStatus -> status) -> foldMap lmsStatusCell $ join status - , sortable (Just "lms-started") (i18nLms MsgTableLmsStarted) $ \(preview $ resultLmsUser . _entityVal . _lmsUserStarted -> d) -> foldMap dateTimeCell d - , sortable (Just "lms-datepin") (i18nLms MsgTableLmsDatePin) $ \(preview $ resultLmsUser . _entityVal . _lmsUserDatePin -> d) -> foldMap dateTimeCell d - , sortable (Just "lms-received") (i18nLms MsgTableLmsReceived) $ \(preview $ resultLmsUser . _entityVal . _lmsUserReceived -> d) -> foldMap dateTimeCell $ join d - --, sortable (Just "lms-notified") (i18nLms MsgTableLmsNotified) $ \(preview $ resultLmsUser . _entityVal . _lmsUserNotified -> d) -> foldMap dateTimeCell $ join d - , sortable (Just "lms-notified") (i18nLms MsgTableLmsNotified & cellTooltip MsgTableLmsNotifiedTooltip) $ \row -> + ) $ \(view $ resultLmsUser . _entityVal . _lmsUserPin -> pin) -> textCell pin + , sortable (Just "lms-status") (i18nCell MsgTableLmsStatus) $ \(view $ resultLmsUser . _entityVal . _lmsUserStatus -> status) -> foldMap lmsStatusCell status + , sortable (Just "lms-started") (i18nLms MsgTableLmsStarted) $ \(view $ resultLmsUser . _entityVal . _lmsUserStarted -> d) -> dateTimeCell d + , sortable (Just "lms-datepin") (i18nLms MsgTableLmsDatePin) $ \(view $ resultLmsUser . _entityVal . _lmsUserDatePin -> d) -> dateTimeCell d + , sortable (Just "lms-received") (i18nLms MsgTableLmsReceived) $ \(view $ resultLmsUser . _entityVal . _lmsUserReceived -> d) -> foldMap dateTimeCell d + --, sortable (Just "lms-notified") (i18nLms MsgTableLmsNotified) $ \(view $ resultLmsUser . _entityVal . _lmsUserNotified -> d) -> foldMap dateTimeCell $ join d + , sortable (Just "lms-notified") (i18nLms MsgTableLmsNotified & cellTooltip MsgTableLmsNotifiedTooltip) $ \row -> -- 4 Cases: -- - No notification: LmsUserNotified == Nothing -- - Email sent : LmsUserNotified == Just _ && PrintJobId == Nothing -- - Letter printed : LmsUserNotified == Just _ && PrintJobId == Just _ -- - Letter sent : LmsUserNotified == Just _ && PrintJobId == Just _ && PrintJobAcknowledged == Just _ - let notifyDate = join $ row ^? resultLmsUser . _entityVal . _lmsUserNotified - lmsident = row ^? resultLmsUser . _entityVal . _lmsUserIdent + let notifyDate = row ^. resultLmsUser . _entityVal . _lmsUserNotified + lmsident = row ^. resultLmsUser . _entityVal . _lmsUserIdent recipient = row ^. hasUser letterDates = row ^? resultPrintAck lastLetterDate = headDef Nothing =<< letterDates @@ -560,7 +581,7 @@ postLmsR sid qsh = do cDate = if | not letterSent -> foldMap dateTimeCell notifyDate | Just d <- lastLetterDate -> dateTimeCell d | otherwise -> i18nCell MsgPrintJobUnacknowledged - lprLink :: Maybe (Route UniWorX) = lmsident <&> (\lid -> urlRoute (PrintCenterR, [("print-job-lmsid", toPathPiece lid)])) + lprLink :: Route UniWorX = lmsident & (\lid -> urlRoute (PrintCenterR, [("print-job-lmsid", toPathPiece lid)])) cAckDates = case letterDates of Just ackDates@(_:_:_) -> spacerCell <> modalCell [whamlet|

@@ -572,11 +593,10 @@ postLmsR sid qsh = do $maybe ackdate <- mbackdate ^{formatTimeW SelFormatDateTime ackdate} $nothing - _{MsgPrintJobUnacknowledged} - $maybe lu <- lprLink -

- - _{MsgPrintJobs} + _{MsgPrintJobUnacknowledged} +

+ + _{MsgPrintJobs} |] -- (PrintCenterR, [("pj-lmsid", toPathPiece lu)]) _ -> mempty @@ -585,7 +605,7 @@ postLmsR sid qsh = do then mempty else cIcon <> spacerCell <> cDate <> cAckDates -- , 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) $ \(view $ resultLmsUser . _entityVal . _lmsUserEnded -> d) -> foldMap dateTimeCell d ] where -- i18nLms :: (RenderMessage UniWorX msg, IsDBTable m a) => msg -> DBCell m a diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs index 8d693c17f..fc0a0c46e 100644 --- a/src/Handler/Qualification.hs +++ b/src/Handler/Qualification.hs @@ -304,7 +304,7 @@ qualificationTableQuery qid fltr (qualUser `E.InnerJoin` user `E.LeftOuterJoin` mkQualificationTable :: ( Functor h, ToSortable h - , AsCornice h p QualificationTableData (DBCell (MForm Handler) (FormResult (First QualificationTableActionData, DBFormResult UserId Bool QualificationTableData))) cols + , AsCornice h p QualificationTableData (DBCell (MForm Handler) (FormResult (First QualificationTableActionData, DBFormResult UserId Bool QualificationTableData))) cols ) => Bool -> Entity Qualification