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

fix(cvs): export company in e-learning view

Browse Source
This commit is contained in:
Steffen Jost 2023-04-28 15:56:12 +00:00
parent 4df024374d
commit 2093cf5018
2 changed files with 124 additions and 104 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

220
src/Handler/LMS.hs
View File

@ -195,38 +195,42 @@ postLmsEditR = error "TODO: STUB"
data LmsTableCsv = LmsTableCsv -- L..T..C.. -> ltc.. data LmsTableCsv = LmsTableCsv -- L..T..C.. -> ltc..
{ ltcDisplayName :: UserDisplayName { ltcDisplayName :: UserDisplayName
, ltcEmail :: UserEmail , ltcEmail :: UserEmail
, ltcValidUntil :: Day , ltcCompany :: Maybe Text
, ltcLastRefresh :: Day , ltcCompanyNumbers :: CsvSemicolonList Int
, ltcFirstHeld :: Day , ltcValidUntil :: Day
, ltcBlockedDue :: Maybe QualificationBlocked , ltcLastRefresh :: Day
, ltcLmsIdent :: Maybe LmsIdent , ltcFirstHeld :: Day
, ltcLmsStatus :: Maybe LmsStatus , ltcBlockedDue :: Maybe QualificationBlocked
, ltcLmsStarted :: Maybe UTCTime , ltcLmsIdent :: Maybe LmsIdent
, ltcLmsDatePin :: Maybe UTCTime , ltcLmsStatus :: Maybe LmsStatus
, ltcLmsReceived :: Maybe UTCTime , ltcLmsStarted :: Maybe UTCTime
, ltcLmsNotified :: Maybe UTCTime , ltcLmsDatePin :: Maybe UTCTime
, ltcLmsEnded :: Maybe UTCTime , ltcLmsReceived :: Maybe UTCTime
, ltcLmsNotified :: Maybe UTCTime
, ltcLmsEnded :: Maybe UTCTime
} }
deriving Generic deriving Generic
makeLenses_ ''LmsTableCsv makeLenses_ ''LmsTableCsv
ltcExample :: LmsTableCsv ltcExample :: LmsTableCsv
ltcExample = LmsTableCsv ltcExample = LmsTableCsv
{ ltcDisplayName = "Max Mustermann" { ltcDisplayName = "Max Mustermann"
, ltcEmail = "m.mustermann@example.com" , ltcEmail = "m.mustermann@example.com"
, ltcValidUntil = compDay , ltcCompany = Just "Example Brothers LLC, SecondaryJobs Inc"
, ltcLastRefresh = compDay , ltcCompanyNumbers = CsvSemicolonList [27,69]
, ltcFirstHeld = compDay , ltcValidUntil = compDay
, ltcBlockedDue = Nothing , ltcLastRefresh = compDay
, ltcLmsIdent = Nothing , ltcFirstHeld = compDay
, ltcLmsStatus = Nothing , ltcBlockedDue = Nothing
, ltcLmsStarted = Just compTime , ltcLmsIdent = Nothing
, ltcLmsDatePin = Nothing , ltcLmsStatus = Nothing
, ltcLmsReceived = Nothing , ltcLmsStarted = Just compTime
, ltcLmsNotified = Nothing , ltcLmsDatePin = Nothing
, ltcLmsEnded = Nothing , ltcLmsReceived = Nothing
, ltcLmsNotified = Nothing
, ltcLmsEnded = Nothing
} }
where where
compTime :: UTCTime compTime :: UTCTime
@ -253,35 +257,37 @@ instance Csv.DefaultOrdered LmsTableCsv where
instance CsvColumnsExplained LmsTableCsv where instance CsvColumnsExplained LmsTableCsv where
csvColumnsExplanations = genericCsvColumnsExplanations ltcOptions $ Map.fromList csvColumnsExplanations = genericCsvColumnsExplanations ltcOptions $ Map.fromList
[ ('ltcDisplayName, MsgLmsUser) [ ('ltcDisplayName , SomeMessage MsgLmsUser)
, ('ltcEmail , MsgTableLmsEmail) , ('ltcEmail , SomeMessage MsgTableLmsEmail)
, ('ltcValidUntil , MsgLmsQualificationValidUntil) , ('ltcCompany , SomeMessage MsgTableCompanies)
, ('ltcLastRefresh, MsgTableQualificationLastRefresh) , ('ltcCompanyNumbers , SomeMessage MsgTableCompanyNos)
, ('ltcFirstHeld , MsgTableQualificationFirstHeld) , ('ltcValidUntil , SomeMessage MsgLmsQualificationValidUntil)
, ('ltcLmsIdent , MsgTableLmsIdent) , ('ltcLastRefresh , SomeMessage MsgTableQualificationLastRefresh)
, ('ltcLmsStatus , MsgTableLmsStatus) , ('ltcFirstHeld , SomeMessage MsgTableQualificationFirstHeld)
, ('ltcLmsStarted , MsgTableLmsStarted) , ('ltcLmsIdent , SomeMessage MsgTableLmsIdent)
, ('ltcLmsDatePin , MsgTableLmsDatePin) , ('ltcLmsStatus , SomeMessage MsgTableLmsStatus)
, ('ltcLmsReceived, MsgTableLmsReceived) , ('ltcLmsStarted , SomeMessage MsgTableLmsStarted)
, ('ltcLmsEnded , MsgTableLmsEnded) , ('ltcLmsDatePin , SomeMessage MsgTableLmsDatePin)
, ('ltcLmsReceived , SomeMessage MsgTableLmsReceived)
, ('ltcLmsEnded , SomeMessage MsgTableLmsEnded)
] ]
type LmsTableExpr = ( E.SqlExpr (Entity QualificationUser) type LmsTableExpr = E.SqlExpr (Entity QualificationUser)
`E.InnerJoin` E.SqlExpr (Entity User) `E.InnerJoin` E.SqlExpr (Entity User)
) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity LmsUser)) `E.InnerJoin` E.SqlExpr (Entity LmsUser)
queryQualUser :: LmsTableExpr -> E.SqlExpr (Entity QualificationUser) queryQualUser :: LmsTableExpr -> E.SqlExpr (Entity QualificationUser)
queryQualUser = $(sqlIJproj 2 1) . $(sqlLOJproj 2 1) queryQualUser = $(sqlIJproj 3 1)
queryUser :: LmsTableExpr -> E.SqlExpr (Entity User) 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 :: LmsTableExpr -> E.SqlExpr (Entity LmsUser)
queryLmsUser = $(sqlLOJproj 2 2) 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 :: Lens' LmsTableData (Entity QualificationUser)
resultQualUser = _dbrOutput . _1 resultQualUser = _dbrOutput . _1
@ -289,12 +295,15 @@ resultQualUser = _dbrOutput . _1
resultUser :: Lens' LmsTableData (Entity User) resultUser :: Lens' LmsTableData (Entity User)
resultUser = _dbrOutput . _2 resultUser = _dbrOutput . _2
resultLmsUser :: Traversal' LmsTableData (Entity LmsUser) resultLmsUser :: Lens' LmsTableData (Entity LmsUser)
resultLmsUser = _dbrOutput . _3 . _Just resultLmsUser = _dbrOutput . _3
resultPrintAck :: Traversal' LmsTableData [Maybe UTCTime] resultPrintAck :: Traversal' LmsTableData [Maybe UTCTime]
resultPrintAck = _dbrOutput . _4 . _unValue . _Just resultPrintAck = _dbrOutput . _4 . _unValue . _Just
resultCompanyUser :: Lens' LmsTableData [Entity UserCompany]
resultCompanyUser = _dbrOutput . _5
instance HasEntity LmsTableData User where instance HasEntity LmsTableData User where
hasEntity = resultUser hasEntity = resultUser
@ -330,53 +339,58 @@ isRenewPinAct LmsActRenewPinData = True
lmsTableQuery :: QualificationId -> LmsTableExpr lmsTableQuery :: QualificationId -> LmsTableExpr
-> E.SqlQuery ( E.SqlExpr (Entity QualificationUser) -> E.SqlQuery ( E.SqlExpr (Entity QualificationUser)
, E.SqlExpr (Entity User) , 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 , 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 -- 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; -- - 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; -- - 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 -- 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.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.&&. 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.on $ user E.^. UserId E.==. qualUser E.^. QualificationUserUser
E.where_ $ E.val qid E.==. qualUser E.^. QualificationUserQualification E.where_ $ E.val qid E.==. qualUser E.^. QualificationUserQualification
-- TODO: decide whether to use subSelect or LeftOuterJoin and delete the other! -- TODO: decide whether to use subSelect or LeftOuterJoin and delete the other!
-- Letztes Datum anzeigen, wenn mehrere, dann diese in klickbaren Tooltip verstecken! -- Letztes Datum anzeigen, wenn mehrere, dann diese in klickbaren Tooltip verstecken!
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))
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! 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! 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 E.arrayAggWith E.AggModeAll (pj E.^. PrintJobAcknowledged) pjOrder
return (qualUser, user, lmsUser, printAcknowledged) return (qualUser, user, lmsUser, printAcknowledged)
mkLmsTable :: forall h p cols act act'. mkLmsTable :: ( Functor h, ToSortable h
( Functor h, ToSortable h , AsCornice h p LmsTableData (DBCell (MForm Handler) (FormResult (First LmsTableActionData, DBFormResult UserId Bool LmsTableData))) cols
, Ord act, PathPiece act, RenderMessage UniWorX act
, AsCornice h p LmsTableData (DBCell (MForm Handler) (FormResult (First act', DBFormResult UserId Bool LmsTableData))) cols
) )
=> Bool => Bool
-> Entity Qualification -> Entity Qualification
-> Map act (AForm Handler act') -> Map LmsTableAction (AForm Handler LmsTableActionData)
-> cols -> (Map CompanyId (Entity Company) -> cols)
-> PSValidator (MForm Handler) (FormResult (First act', DBFormResult UserId Bool LmsTableData)) -> PSValidator (MForm Handler) (FormResult (First LmsTableActionData, DBFormResult UserId Bool LmsTableData))
-> DB (FormResult (act', Set UserId), Widget) -> DB (FormResult (LmsTableActionData, Set UserId), Widget)
mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
let let
nowaday = utctDay now 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 mbRenewal = addGregorianDurationClip <$> qualificationRefreshWithin quali <*> Just nowaday
csvName = T.replace " " "-" $ CI.original (quali ^. _qualificationName) csvName = T.replace " " "-" $ CI.original (quali ^. _qualificationName)
dbtIdent :: Text dbtIdent :: Text
dbtIdent = "qualification" dbtIdent = "qualification"
dbtSQLQuery = lmsTableQuery qid dbtSQLQuery = lmsTableQuery qid
dbtRowKey = queryUser >>> (E.^. UserId) dbtRowKey = queryUser >>> (E.^. UserId)
dbtProj = dbtProjId dbtProj = dbtProjSimple $ \(qualUsr, usr, lmsUsr, printAcks) -> do
cmpUsr <- selectList [UserCompanyUser ==. entityKey usr] [Asc UserCompanyCompany]
dbtColonnade = cols return (qualUsr, usr, lmsUsr, printAcks, cmpUsr)
dbtColonnade = cols cmpMap
dbtSorting = mconcat dbtSorting = mconcat
[ single $ sortUserNameLink queryUser [ single $ sortUserNameLink queryUser
, single $ sortUserEmail 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 ("first-held" , SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserFirstHeld))
, single ("blocked-due" , SortColumnNeverNull$ queryQualUser >>> (E.^. QualificationUserBlockedDue)) , single ("blocked-due" , SortColumnNeverNull$ queryQualUser >>> (E.^. QualificationUserBlockedDue))
, single ("schedule-renew", SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserScheduleRenewal)) , single ("schedule-renew", SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserScheduleRenewal))
, single ("lms-ident" , SortColumnNullsInv $ queryLmsUser >>> (E.?. LmsUserIdent)) , single ("lms-ident" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserIdent))
, single ("lms-pin" , SortColumnNullsInv $ queryLmsUser >>> (E.?. LmsUserPin)) , single ("lms-pin" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserPin))
, single ("lms-status" , SortColumnNullsInv $ views (to queryLmsUser) (E.?. LmsUserStatus)) , single ("lms-status" , SortColumnNullsInv $ views (to queryLmsUser) (E.^. LmsUserStatus))
, single ("lms-started" , SortColumnNullsInv $ queryLmsUser >>> (E.?. LmsUserStarted)) , single ("lms-started" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserStarted))
, single ("lms-datepin" , SortColumnNullsInv $ queryLmsUser >>> (E.?. LmsUserDatePin)) , single ("lms-datepin" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserDatePin))
, single ("lms-received" , SortColumnNullsInv $ queryLmsUser >>> (E.?. LmsUserReceived)) , single ("lms-received" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserReceived))
, single ("lms-notified" , SortColumnNullsInv $ queryLmsUser >>> (E.?. LmsUserNotified)) -- cannot include printJob acknowledge date , single ("lms-notified" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserNotified)) -- cannot include printJob acknowledge date
, single ("lms-ended" , SortColumnNullsInv $ queryLmsUser >>> (E.?. LmsUserEnded)) , single ("lms-ended" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserEnded))
, single ( "user-company" , SortColumn $ \row -> E.subSelect $ E.from $ \(usrComp `E.InnerJoin` comp) -> do , single ( "user-company" , SortColumn $ \row -> E.subSelect $ E.from $ \(usrComp `E.InnerJoin` comp) -> do
E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
E.where_ $ usrComp E.^. UserCompanyUser E.==. queryUser row E.^. UserId 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 dbtFilter = mconcat
[ single $ fltrUserNameEmail queryUser [ 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 ("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) ((E.>=. E.val nowaday) . (E.^. QualificationUserValidUntil)))
, single ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) (validQualification nowaday)) , 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 E.&&. quser E.^. QualificationUserValidUntil E.>=. E.val nowaday
| otherwise -> E.true | 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 -> , single ("avs-number" , FilterColumn . E.mkExistsFilter $ \row criterion ->
E.from $ \usrAvs -> -- do E.from $ \usrAvs -> -- do
E.where_ $ usrAvs E.^. UserAvsUser E.==. queryUser row E.^. UserId 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 doEncode' = LmsTableCsv
<$> view (resultUser . _entityVal . _userDisplayName) <$> view (resultUser . _entityVal . _userDisplayName)
<*> view (resultUser . _entityVal . _userDisplayEmail) <*> view (resultUser . _entityVal . _userDisplayEmail)
<*> (view resultCompanyUser >>= getCompanies)
<*> (view resultCompanyUser >>= getCompanyNos)
<*> view (resultQualUser . _entityVal . _qualificationUserValidUntil) <*> view (resultQualUser . _entityVal . _qualificationUserValidUntil)
<*> view (resultQualUser . _entityVal . _qualificationUserLastRefresh) <*> view (resultQualUser . _entityVal . _qualificationUserLastRefresh)
<*> view (resultQualUser . _entityVal . _qualificationUserFirstHeld) <*> 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 . _lmsUserReceived))
<*> (join . preview (resultLmsUser . _entityVal . _lmsUserNotified)) -- TODO: only exports last email date / print job sending date, not print acknowledge <*> (join . preview (resultLmsUser . _entityVal . _lmsUserNotified)) -- TODO: only exports last email date / print job sending date, not print acknowledge
<*> (join . preview (resultLmsUser . _entityVal . _lmsUserEnded)) <*> (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 dbtCsvDecode = Nothing
dbtExtraReps = [] dbtExtraReps = []
dbtParams = if not isAdmin then def {dbParamsFormAction = Nothing, dbParamsFormSubmit = FormNoSubmit} else dbtParams = if not isAdmin then def {dbParamsFormAction = Nothing, dbParamsFormSubmit = FormNoSubmit} else
@ -513,20 +534,20 @@ postLmsR sid qsh = do
-- , singletonMap LmsActRenewPin $ pure LmsActRenewPinData -- , singletonMap LmsActRenewPin $ pure LmsActRenewPinData
] ]
-- lmsStatusLink = toMaybe isAdmin LmsUserR -- 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" [ 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 , colUserNameModalHdr MsgLmsUser AdminUserR
, colUserEmail , 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" , sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \( view resultCompanyUser -> cmps) ->
companies' <- liftHandler . runDB . E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do let icnSuper = text2markup " " <> icon IconSupervisor
E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId cs = [ (cmpName, cmpSpr)
E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid | Entity _ UserCompany{userCompanyCompany=cmpId, userCompanySupervisor=cmpSpr} <- cmps
E.orderBy [E.asc (comp E.^. CompanyName)] , let cmpEnt = Map.lookup cmpId cmpMap
return (comp E.^. CompanyName, usrComp E.^. UserCompanySupervisor) , Just (Entity _ Company{companyName = cmpName}) <- [cmpEnt]
let companies = intersperse (text2markup ", ") $ ]
(\(E.Value cmpName, E.Value cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> companies' companies = intercalate (text2markup ", ") $
icnSuper = text2markup " " <> icon IconSupervisor (\(cmpName, cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> cs
pure $ toWgt $ mconcat companies in wgtCell companies
, colUserMatriclenr , colUserMatriclenr
, sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) $ \( view $ resultQualUser . _entityVal . _qualificationUserValidUntil -> d) -> dayCell d , 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 "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 ) $ \( view $ resultQualUser . _entityVal . _qualificationUserBlockedDue -> b) -> qualificationBlockedCell b
, sortable (Just "schedule-renew")(i18nCell MsgTableQualificationNoRenewal & cellTooltip MsgTableQualificationNoRenewalTooltip , sortable (Just "schedule-renew")(i18nCell MsgTableQualificationNoRenewal & cellTooltip MsgTableQualificationNoRenewalTooltip
) $ \( view $ resultQualUser . _entityVal . _qualificationUserScheduleRenewal -> b) -> ifIconCell (not b) IconNoNotification ) $ \( 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)] , sortable (Just "lms-pin") (i18nCell MsgTableLmsPin & cellAttrs <>~ [("uw-hide-column-default-hidden",mempty)]
) $ \(preview $ resultLmsUser . _entityVal . _lmsUserPin -> pin) -> foldMap textCell pin ) $ \(view $ resultLmsUser . _entityVal . _lmsUserPin -> pin) -> textCell pin
, sortable (Just "lms-status") (i18nCell MsgTableLmsStatus) $ \(preview $ resultLmsUser . _entityVal . _lmsUserStatus -> status) -> foldMap lmsStatusCell $ join status , sortable (Just "lms-status") (i18nCell MsgTableLmsStatus) $ \(view $ resultLmsUser . _entityVal . _lmsUserStatus -> status) -> foldMap lmsStatusCell status
, sortable (Just "lms-started") (i18nLms MsgTableLmsStarted) $ \(preview $ resultLmsUser . _entityVal . _lmsUserStarted -> d) -> foldMap dateTimeCell d , sortable (Just "lms-started") (i18nLms MsgTableLmsStarted) $ \(view $ resultLmsUser . _entityVal . _lmsUserStarted -> d) -> dateTimeCell d
, sortable (Just "lms-datepin") (i18nLms MsgTableLmsDatePin) $ \(preview $ resultLmsUser . _entityVal . _lmsUserDatePin -> d) -> foldMap dateTimeCell d , sortable (Just "lms-datepin") (i18nLms MsgTableLmsDatePin) $ \(view $ resultLmsUser . _entityVal . _lmsUserDatePin -> d) -> dateTimeCell d
, sortable (Just "lms-received") (i18nLms MsgTableLmsReceived) $ \(preview $ resultLmsUser . _entityVal . _lmsUserReceived -> d) -> foldMap dateTimeCell $ join d , sortable (Just "lms-received") (i18nLms MsgTableLmsReceived) $ \(view $ resultLmsUser . _entityVal . _lmsUserReceived -> d) -> foldMap dateTimeCell d
--, sortable (Just "lms-notified") (i18nLms MsgTableLmsNotified) $ \(preview $ resultLmsUser . _entityVal . _lmsUserNotified -> d) -> foldMap dateTimeCell $ join 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 -> , sortable (Just "lms-notified") (i18nLms MsgTableLmsNotified & cellTooltip MsgTableLmsNotifiedTooltip) $ \row ->
-- 4 Cases: -- 4 Cases:
-- - No notification: LmsUserNotified == Nothing -- - No notification: LmsUserNotified == Nothing
-- - Email sent : LmsUserNotified == Just _ && PrintJobId == Nothing -- - Email sent : LmsUserNotified == Just _ && PrintJobId == Nothing
-- - Letter printed : LmsUserNotified == Just _ && PrintJobId == Just _ -- - Letter printed : LmsUserNotified == Just _ && PrintJobId == Just _
-- - Letter sent : LmsUserNotified == Just _ && PrintJobId == Just _ && PrintJobAcknowledged == Just _ -- - Letter sent : LmsUserNotified == Just _ && PrintJobId == Just _ && PrintJobAcknowledged == Just _
let notifyDate = join $ row ^? resultLmsUser . _entityVal . _lmsUserNotified let notifyDate = row ^. resultLmsUser . _entityVal . _lmsUserNotified
lmsident = row ^? resultLmsUser . _entityVal . _lmsUserIdent lmsident = row ^. resultLmsUser . _entityVal . _lmsUserIdent
recipient = row ^. hasUser recipient = row ^. hasUser
letterDates = row ^? resultPrintAck letterDates = row ^? resultPrintAck
lastLetterDate = headDef Nothing =<< letterDates lastLetterDate = headDef Nothing =<< letterDates
@ -560,7 +581,7 @@ postLmsR sid qsh = do
cDate = if | not letterSent -> foldMap dateTimeCell notifyDate cDate = if | not letterSent -> foldMap dateTimeCell notifyDate
| Just d <- lastLetterDate -> dateTimeCell d | Just d <- lastLetterDate -> dateTimeCell d
| otherwise -> i18nCell MsgPrintJobUnacknowledged | 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 cAckDates = case letterDates of
Just ackDates@(_:_:_) -> spacerCell <> modalCell [whamlet| Just ackDates@(_:_:_) -> spacerCell <> modalCell [whamlet|
<h1> <h1>
@ -573,10 +594,9 @@ postLmsR sid qsh = do
^{formatTimeW SelFormatDateTime ackdate} ^{formatTimeW SelFormatDateTime ackdate}
$nothing $nothing
_{MsgPrintJobUnacknowledged} _{MsgPrintJobUnacknowledged}
$maybe lu <- lprLink <p>
<p> <a href=@{lprLink}>
<a href=@{lu}> _{MsgPrintJobs}
_{MsgPrintJobs}
|] |]
-- (PrintCenterR, [("pj-lmsid", toPathPiece lu)]) -- (PrintCenterR, [("pj-lmsid", toPathPiece lu)])
_ -> mempty _ -> mempty
@ -585,7 +605,7 @@ postLmsR sid qsh = do
then mempty then mempty
else cIcon <> spacerCell <> cDate <> cAckDates else cIcon <> spacerCell <> cDate <> cAckDates
-- , sortable (Just "lms-notified-alternative") (i18nLms MsgTableLmsNotified) $ \(preview resultPrintAck -> d) -> textCell (show 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) $ \(view $ resultLmsUser . _entityVal . _lmsUserEnded -> d) -> foldMap dateTimeCell d
] ]
where where
-- i18nLms :: (RenderMessage UniWorX msg, IsDBTable m a) => msg -> DBCell m a -- i18nLms :: (RenderMessage UniWorX msg, IsDBTable m a) => msg -> DBCell m a

2
src/Handler/Qualification.hs
View File

@ -304,7 +304,7 @@ qualificationTableQuery qid fltr (qualUser `E.InnerJoin` user `E.LeftOuterJoin`
mkQualificationTable :: mkQualificationTable ::
( Functor h, ToSortable h ( 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 => Bool
-> Entity Qualification -> Entity Qualification