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

refactor(map): clarify some unnecessarily obfuscated code

Browse Source 
also, using Map.fromList is more efficient if the list happens to be ordered
This commit is contained in:
Steffen Jost 2024-09-11 17:43:56 +02:00 committed by Sarah Vaupel
parent 733324a732
commit e9a4c838a8
12 changed files with 220 additions and 260 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

40
src/Handler/Admin.hs
View File

@ -39,10 +39,6 @@ import Handler.Admin.Crontab as Handler.Admin
import Handler.Admin.Avs as Handler.Admin import Handler.Admin.Avs as Handler.Admin
import Handler.Admin.Ldap as Handler.Admin import Handler.Admin.Ldap as Handler.Admin
-- avoids repetition of local definitions
single :: (k,a) -> Map k a
single = uncurry Map.singleton
-- Types and Template Haskell -- Types and Template Haskell
data ProblemTableAction = ProblemTableMarkSolved data ProblemTableAction = ProblemTableMarkSolved
@ -368,22 +364,22 @@ mkProblemLogTable = do
, sortable (Just "solved") (i18nCell MsgAdminProblemSolved) $ \( view $ resultProblem . _entityVal . _problemLogSolved -> t) -> cellMaybe dateTimeCell t , sortable (Just "solved") (i18nCell MsgAdminProblemSolved) $ \( view $ resultProblem . _entityVal . _problemLogSolved -> t) -> cellMaybe dateTimeCell t
, sortable (Just "solver") (i18nCell MsgAdminProblemSolver) $ \(preview resultSolver -> u) -> maybeCell u $ cellHasUserLink AdminUserR , sortable (Just "solver") (i18nCell MsgAdminProblemSolver) $ \(preview resultSolver -> u) -> maybeCell u $ cellHasUserLink AdminUserR
] ]
dbtSorting = mconcat dbtSorting = Map.fromList
[ single ("time" , SortColumn $ queryProblem >>> (E.^. ProblemLogTime)) [ ("time" , SortColumn $ queryProblem >>> (E.^. ProblemLogTime))
, single ("info" , SortColumn $ queryProblem >>> (E.^. ProblemLogInfo)) , ("info" , SortColumn $ queryProblem >>> (E.^. ProblemLogInfo))
-- , single ("firm" , SortColumn ((E.->>. "company" ).(queryProblem >>> (E.^. ProblemLogInfo)))) -- , ("firm" , SortColumn ((E.->>. "company" ).(queryProblem >>> (E.^. ProblemLogInfo))))
, single ("firm" , SortColumn $ \r -> queryProblem r E.^. ProblemLogInfo E.->>. "company") , ("firm" , SortColumn $ \r -> queryProblem r E.^. ProblemLogInfo E.->>. "company")
, single ("user" , sortUserNameBareM queryUser) , ("user" , sortUserNameBareM queryUser)
, single ("solved", SortColumn $ queryProblem >>> (E.^. ProblemLogSolved)) , ("solved", SortColumn $ queryProblem >>> (E.^. ProblemLogSolved))
, single ("solver", sortUserNameBareM querySolver) , ("solver", sortUserNameBareM querySolver)
] ]
dbtFilter = mconcat dbtFilter = Map.fromList
[ single ("user" , FilterColumn . E.mkContainsFilterWithCommaPlus Just $ views (to queryUser) (E.?. UserDisplayName)) [ ("user" , FilterColumn . E.mkContainsFilterWithCommaPlus Just $ views (to queryUser) (E.?. UserDisplayName))
, single ("solver" , FilterColumn . E.mkContainsFilterWithCommaPlus Just $ views (to querySolver) (E.?. UserDisplayName)) , ("solver" , FilterColumn . E.mkContainsFilterWithCommaPlus Just $ views (to querySolver) (E.?. UserDisplayName))
, single ("company" , FilterColumn . E.mkContainsFilter $ views (to queryProblem) ((E.->>. "company").(E.^. ProblemLogInfo))) , ("company" , FilterColumn . E.mkContainsFilter $ views (to queryProblem) ((E.->>. "company").(E.^. ProblemLogInfo)))
, single ("solved" , FilterColumn . E.mkExactFilterLast $ views (to queryProblem) (E.isJust . (E.^. ProblemLogSolved))) , ("solved" , FilterColumn . E.mkExactFilterLast $ views (to queryProblem) (E.isJust . (E.^. ProblemLogSolved)))
-- , single ("problem" , FilterColumn . E.mkContainsFilter $ views (to queryProblem) ((E.->>. "problem").(E.^. ProblemLogInfo))) -- not stored in plaintext! -- , ("problem" , FilterColumn . E.mkContainsFilter $ views (to queryProblem) ((E.->>. "problem").(E.^. ProblemLogInfo))) -- not stored in plaintext!
, single ("problem" , mkFilterProjectedPost $ \(getLast -> criterion) dbr -> -- falls es nicht schnell genug ist: in dbtProj den Anzeigetext nur einmal berechnen , ("problem" , mkFilterProjectedPost $ \(getLast -> criterion) dbr -> -- falls es nicht schnell genug ist: in dbtProj den Anzeigetext nur einmal berechnen
ifNothingM criterion True $ \(crit::Text) -> do ifNothingM criterion True $ \(crit::Text) -> do
let problem = dbr ^. resultProblem . _entityVal . _problemLogAdminProblem let problem = dbr ^. resultProblem . _entityVal . _problemLogAdminProblem
protxt <- adminProblem2Text problem protxt <- adminProblem2Text problem
@ -398,9 +394,9 @@ mkProblemLogTable = do
, prismAForm (singletonFilter "solved" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgAdminProblemSolved) , prismAForm (singletonFilter "solved" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgAdminProblemSolved)
] ]
acts :: Map ProblemTableAction (AForm Handler ProblemTableActionData) acts :: Map ProblemTableAction (AForm Handler ProblemTableActionData)
acts = mconcat acts = Map.fromList
[ singletonMap ProblemTableMarkSolved $ pure ProblemTableMarkSolvedData [ (ProblemTableMarkSolved , pure ProblemTableMarkSolvedData)
, singletonMap ProblemTableMarkUnsolved $ pure ProblemTableMarkUnsolvedData , (ProblemTableMarkUnsolved , pure ProblemTableMarkUnsolvedData)
] ]
dbtParams = DBParamsForm dbtParams = DBParamsForm
{ dbParamsFormMethod = POST { dbParamsFormMethod = POST

52
src/Handler/Admin/Avs.hs
View File

@ -1,4 +1,4 @@
-- SPDX-FileCopyrightText: 2022 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de> -- SPDX-FileCopyrightText: 2022-24 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
-- --
-- SPDX-License-Identifier: AGPL-3.0-or-later -- SPDX-License-Identifier: AGPL-3.0-or-later
@ -38,10 +38,6 @@ import qualified Database.Esqueleto.Utils as E
-- import Database.Esqueleto.Utils.TH -- import Database.Esqueleto.Utils.TH
-- avoids repetition of local definitions
single :: (k,a) -> Map k a
single = uncurry Map.singleton
exceptionWgt :: SomeException -> Widget exceptionWgt :: SomeException -> Widget
exceptionWgt (SomeException e) = [whamlet|<h2>Error:</h2> #{tshow e}|] exceptionWgt (SomeException e) = [whamlet|<h2>Error:</h2> #{tshow e}|]
@ -692,23 +688,23 @@ mkLicenceTable apidStatus rsChanged dbtIdent aLic apids = do
) $ \(preview $ resultQualUser . _entityVal . _qualificationUserScheduleRenewal -> b) -> cellMaybe (flip ifIconCell IconNoNotification . not) b ) $ \(preview $ resultQualUser . _entityVal . _qualificationUserScheduleRenewal -> b) -> cellMaybe (flip ifIconCell IconNoNotification . not) b
, sortable Nothing (i18nCell MsgTableAvsActiveCards) $ \(view $ resultUserAvs . _userAvsPersonId -> apid) -> foldMap avsPersonCardCell $ Map.lookup apid apidStatus , sortable Nothing (i18nCell MsgTableAvsActiveCards) $ \(view $ resultUserAvs . _userAvsPersonId -> apid) -> foldMap avsPersonCardCell $ Map.lookup apid apidStatus
] ]
dbtSorting = mconcat dbtSorting = Map.fromList
[ single $ sortUserNameLink queryUser [ sortUserNameLink queryUser
, single ("avspersonno" , SortColumn $ queryUserAvs >>> (E.^. UserAvsNoPerson)) , ("avspersonno" , SortColumn $ queryUserAvs >>> (E.^. UserAvsNoPerson))
, single ("qualification" , SortColumn $ queryQualification >>> (E.?. QualificationShorthand)) , ("qualification" , SortColumn $ queryQualification >>> (E.?. QualificationShorthand))
, single $ sortUserCompany queryUser , sortUserCompany queryUser
, single ("valid-until" , SortColumn $ queryQualUser >>> (E.?. QualificationUserValidUntil)) , ("valid-until" , SortColumn $ queryQualUser >>> (E.?. QualificationUserValidUntil))
, single ("last-refresh" , SortColumn $ queryQualUser >>> (E.?. QualificationUserLastRefresh)) , ("last-refresh" , SortColumn $ queryQualUser >>> (E.?. QualificationUserLastRefresh))
, single ("first-held" , SortColumn $ queryQualUser >>> (E.?. QualificationUserFirstHeld)) , ("first-held" , SortColumn $ queryQualUser >>> (E.?. QualificationUserFirstHeld))
, single ("blocked" , SortColumnNeverNull $ queryQualBlock >>> (E.?. QualificationUserBlockFrom)) , ("blocked" , SortColumnNeverNull $ queryQualBlock >>> (E.?. QualificationUserBlockFrom))
, single ("schedule-renew", SortColumnNullsInv $ queryQualUser >>> (E.?. QualificationUserScheduleRenewal)) , ("schedule-renew", SortColumnNullsInv $ queryQualUser >>> (E.?. QualificationUserScheduleRenewal))
-- , single ("validity" , SortColumn $ queryQualUser >>> (E.?. QualificationUserValidUntil)) -- , ("validity" , SortColumn $ queryQualUser >>> (E.?. QualificationUserValidUntil))
] ]
dbtFilter = mconcat dbtFilter = Map.fromList
[ single $ fltrUserNameEmail queryUser [ fltrUserNameEmail queryUser
, single ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) (validQualification' now)) , ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) (validQualification' now))
, single ( "user-company", FilterColumn . E.mkExistsFilter $ \row criterion -> , ( "user-company", FilterColumn . E.mkExistsFilter $ \row criterion ->
E.from $ \(usrComp `E.InnerJoin` comp) -> do E.from $ \(usrComp `E.InnerJoin` comp) -> do
let testname = (E.val criterion :: E.SqlExpr (E.Value (CI Text))) `E.isInfixOf` let testname = (E.val criterion :: E.SqlExpr (E.Value (CI Text))) `E.isInfixOf`
(E.explicitUnsafeCoerceSqlExprValue "citext" (comp E.^. CompanyName) :: E.SqlExpr (E.Value (CI Text))) (E.explicitUnsafeCoerceSqlExprValue "citext" (comp E.^. CompanyName) :: E.SqlExpr (E.Value (CI Text)))
@ -1025,15 +1021,15 @@ getProblemAvsErrorR = do
, sortable (Just "avs-last-error") (i18nCell MsgLastAvsSynchError) , sortable (Just "avs-last-error") (i18nCell MsgLastAvsSynchError)
$ cellMaybe textCell . view (reserrUsrAvs . _entityVal . _userAvsLastSynchError) $ cellMaybe textCell . view (reserrUsrAvs . _entityVal . _userAvsLastSynchError)
] ]
dbtSorting = mconcat dbtSorting = Map.fromList
[ single (sortUserNameLink qerryUser) [ (sortUserNameLink qerryUser)
, single ("avs-nr" , SortColumn $ qerryUsrAvs >>> (E.^. UserAvsNoPerson)) , ("avs-nr" , SortColumn $ qerryUsrAvs >>> (E.^. UserAvsNoPerson))
, single ("avs-last-synch", SortColumnNullsInv $ qerryUsrAvs >>> (E.^. UserAvsLastSynch)) , ("avs-last-synch", SortColumnNullsInv $ qerryUsrAvs >>> (E.^. UserAvsLastSynch))
, single ("avs-last-error", SortColumn $ qerryUsrAvs >>> (E.^. UserAvsLastSynchError)) , ("avs-last-error", SortColumn $ qerryUsrAvs >>> (E.^. UserAvsLastSynchError))
] ]
dbtFilter = mconcat dbtFilter = Map.fromList
[ single $ fltrUserNameEmail qerryUser [ fltrUserNameEmail qerryUser
, single ("avs-last-error", FilterColumn $ E.mkContainsFilterWithCommaPlus Just $ views (to qerryUsrAvs) (E.^. UserAvsLastSynchError)) , ("avs-last-error", FilterColumn $ E.mkContainsFilterWithCommaPlus Just $ views (to qerryUsrAvs) (E.^. UserAvsLastSynchError))
] ]
dbtFilterUI mPrev = mconcat dbtFilterUI mPrev = mconcat
[ fltrUserNameEmailHdrUI MsgLmsUser mPrev [ fltrUserNameEmailHdrUI MsgLmsUser mPrev

17
src/Handler/CommCenter.hs
View File

@ -25,11 +25,6 @@ import qualified Database.Esqueleto.PostgreSQL as E
import Database.Esqueleto.Utils.TH import Database.Esqueleto.Utils.TH
-- avoids repetition of local definitions
single :: (k,a) -> Map k a
single = uncurry Map.singleton
data CCTableAction = CCActDummy -- just a dummy, since we don't now yet which actions we will be needing data CCTableAction = CCActDummy -- just a dummy, since we don't now yet which actions we will be needing
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
@ -119,12 +114,12 @@ mkCCTable = do
, SomeExprValue $ E.coalesce [queryRecipientPrint row E.?. UserDisplayName, queryRecipientMail row E.?. UserDisplayName] , SomeExprValue $ E.coalesce [queryRecipientPrint row E.?. UserDisplayName, queryRecipientMail row E.?. UserDisplayName]
] ]
] ]
dbtFilter = mconcat dbtFilter = Map.fromList
[ single ("sent" , FilterColumn . E.mkDayFilterTo [ ("sent" , FilterColumn . E.mkDayFilterTo
$ \row -> E.coalesceDefault [queryPrint row E.?. PrintJobCreated, queryMail row E.?. SentMailSentAt] E.now_) -- either one is guaranteed to be non-null, default never used $ \row -> E.coalesceDefault [queryPrint row E.?. PrintJobCreated, queryMail row E.?. SentMailSentAt] E.now_) -- either one is guaranteed to be non-null, default never used
, single ("recipient" , FilterColumn . E.mkContainsFilterWithCommaPlus Just , ("recipient" , FilterColumn . E.mkContainsFilterWithCommaPlus Just
$ \row -> E.coalesce [queryRecipientPrint row E.?. UserDisplayName, queryRecipientMail row E.?. UserDisplayName]) $ \row -> E.coalesce [queryRecipientPrint row E.?. UserDisplayName, queryRecipientMail row E.?. UserDisplayName])
, single ("subject" , FilterColumn . E.mkContainsFilterWithCommaPlus Just , ("subject" , FilterColumn . E.mkContainsFilterWithCommaPlus Just
$ \row -> E.coalesce [E.str2text' $ queryPrint row E.?. PrintJobFilename $ \row -> E.coalesce [E.str2text' $ queryPrint row E.?. PrintJobFilename
,E.str2text' $ queryMail row E.?. SentMailHeaders ]) ,E.str2text' $ queryMail row E.?. SentMailHeaders ])
] ]

111
src/Handler/Firm.hs
View File

@ -39,10 +39,6 @@ import qualified Database.Esqueleto.Utils as E
import Database.Esqueleto.Utils.TH import Database.Esqueleto.Utils.TH
-- avoids repetition of local definitions
single :: (k,a) -> Map k a
single = uncurry Map.singleton
-- decryptUser :: (MonadHandler m, HandlerSite m ~ UniWorX) => CryptoUUIDUser -> m UserId -- decryptUser :: (MonadHandler m, HandlerSite m ~ UniWorX) => CryptoUUIDUser -> m UserId
-- decryptUser = decrypt -- decryptUser = decrypt
@ -482,10 +478,10 @@ mkFirmAllTable isAdmin uid = do
-- , singletonMap "reroute-act" $ SortColumn firmCountActiveReroutes -- , singletonMap "reroute-act" $ SortColumn firmCountActiveReroutes
-- , singletonMap "reroute-all" $ SortColumn firmCountActiveReroutes' -- , singletonMap "reroute-all" $ SortColumn firmCountActiveReroutes'
] ]
dbtFilter = mconcat dbtFilter = Map.fromList
[ single $ fltrCompanyNameNr queryAllCompany [ fltrCompanyNameNr queryAllCompany
, single ("company-number", FilterColumn $ E.mkExactFilterWithComma readMay (queryAllCompany >>> (E.^. CompanyAvsId))) , ("company-number", FilterColumn $ E.mkExactFilterWithComma readMay (queryAllCompany >>> (E.^. CompanyAvsId)))
, single ("is-associate" , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do , ("is-associate" , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do
(usr :& usrCmp) <- E.from $ E.table @User (usr :& usrCmp) <- E.from $ E.table @User
`E.innerJoin` E.table @UserCompany `E.innerJoin` E.table @UserCompany
`E.on` (\(usr :& usrCmp) -> usr E.^. UserId E.==. usrCmp E.^. UserCompanyUser) `E.on` (\(usr :& usrCmp) -> usr E.^. UserId E.==. usrCmp E.^. UserCompanyUser)
@ -496,7 +492,7 @@ mkFirmAllTable isAdmin uid = do
) )
) )
-- THIS WAS WAY TOO SLOW: -- THIS WAS WAY TOO SLOW:
-- , single ("is-supervisor" , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do -- too slow -- , ("is-supervisor" , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do -- too slow
-- (usr :& usrCmp) <- E.from $ E.table @User -- (usr :& usrCmp) <- E.from $ E.table @User
-- `E.leftJoin` E.table @UserCompany -- `E.leftJoin` E.table @UserCompany
-- `E.on` (\(usr :& usrCmp) -> usr E.^. UserId E.=?. usrCmp E.?. UserCompanyUser) -- `E.on` (\(usr :& usrCmp) -> usr E.^. UserId E.=?. usrCmp E.?. UserCompanyUser)
@ -515,7 +511,7 @@ mkFirmAllTable isAdmin uid = do
-- ) -- )
-- ) -- )
-- ) -- )
-- , single ("is-supervisor" , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do -- too slow -- , ("is-supervisor" , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do -- too slow
-- usr <- E.from $ E.table @User -- usr <- E.from $ E.table @User
-- E.where_ $ ((usr E.^. UserDisplayName `E.hasInfix` E.val criterion) -- E.where_ $ ((usr E.^. UserDisplayName `E.hasInfix` E.val criterion)
-- E.||. (usr E.^. UserDisplayEmail `E.hasInfix` E.val (CI.mk criterion)) -- E.||. (usr E.^. UserDisplayEmail `E.hasInfix` E.val (CI.mk criterion))
@ -536,7 +532,7 @@ mkFirmAllTable isAdmin uid = do
-- ) -- )
-- ) -- )
-- ) -- )
-- , single ("is-supervisor" , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do -- too slow -- , ("is-supervisor" , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do -- too slow
-- usr <- E.from $ E.table @User -- usr <- E.from $ E.table @User
-- E.where_ $ ((usr E.^. UserDisplayName `E.hasInfix` E.val criterion) -- E.where_ $ ((usr E.^. UserDisplayName `E.hasInfix` E.val criterion)
-- E.||. (usr E.^. UserDisplayEmail `E.hasInfix` E.val (CI.mk criterion)) -- E.||. (usr E.^. UserDisplayEmail `E.hasInfix` E.val (CI.mk criterion))
@ -553,7 +549,7 @@ mkFirmAllTable isAdmin uid = do
-- )) -- ))
-- ) -- )
-- ) -- )
-- , single ("is-supervisor", FilterColumn $ \row (getLast -> criterion) -> -- , ("is-supervisor", FilterColumn $ \row (getLast -> criterion) ->
-- case criterion of -- case criterion of
-- Nothing -> E.true -- Nothing -> E.true
-- (Just (crit::Text)) -> E.exists $ do -- (Just (crit::Text)) -> E.exists $ do
@ -573,7 +569,7 @@ mkFirmAllTable isAdmin uid = do
-- )) -- ))
-- ) -- )
-- ) -- )
, single ("is-supervisor", mkFilterProjectedPost $ \(getLast -> criterion) dbr -> , ("is-supervisor", mkFilterProjectedPost $ \(getLast -> criterion) dbr ->
case criterion of case criterion of
Nothing -> return True :: DB Bool Nothing -> return True :: DB Bool
(Just (crit::Text)) -> do (Just (crit::Text)) -> do
@ -601,7 +597,7 @@ mkFirmAllTable isAdmin uid = do
let cid = dbr ^. resultAllCompanyEntity . _entityKey let cid = dbr ^. resultAllCompanyEntity . _entityKey
return $ Set.member cid critFirms return $ Set.member cid critFirms
) )
-- , single ("is-supervisor" , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do -- too slow -- , ("is-supervisor" , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do -- too slow
-- (usr :& usrCmp) <- E.from $ E.table @User -- (usr :& usrCmp) <- E.from $ E.table @User
-- `E.leftJoin` E.table @UserCompany -- `E.leftJoin` E.table @UserCompany
-- `E.on` (\(usr :& usrCmp) -> usr E.^. UserId E.=?. usrCmp E.?. UserCompanyUser) -- `E.on` (\(usr :& usrCmp) -> usr E.^. UserId E.=?. usrCmp E.?. UserCompanyUser)
@ -616,7 +612,7 @@ mkFirmAllTable isAdmin uid = do
-- ) -- )
-- ) -- )
-- ) -- )
, single ("is-default-supervisor" , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do , ("is-default-supervisor" , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do
(usr :& usrCmp) <- E.from $ E.table @User (usr :& usrCmp) <- E.from $ E.table @User
`E.innerJoin` E.table @UserCompany `E.innerJoin` E.table @UserCompany
`E.on` (\(usr :& usrCmp) -> usr E.^. UserId E.==. usrCmp E.^. UserCompanyUser) `E.on` (\(usr :& usrCmp) -> usr E.^. UserId E.==. usrCmp E.^. UserCompanyUser)
@ -626,7 +622,7 @@ mkFirmAllTable isAdmin uid = do
) E.&&. usrCmp E.^. UserCompanySupervisor ) E.&&. usrCmp E.^. UserCompanySupervisor
E.&&. usrCmp E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId E.&&. usrCmp E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId
) )
, single ("foreign-supervisor", FilterColumn $ \row (getLast -> criterion) -> , ("foreign-supervisor", FilterColumn $ \row (getLast -> criterion) ->
-- let checkSuper = do -- expensive -- let checkSuper = do -- expensive
-- usrSpr <- E.from $ E.table @UserSupervisor -- usrSpr <- E.from $ E.table @UserSupervisor
-- E.where_ $ E.notExists (do -- E.where_ $ E.notExists (do
@ -655,8 +651,8 @@ mkFirmAllTable isAdmin uid = do
Just True -> E.exists checkSuper Just True -> E.exists checkSuper
Just False -> E.notExists checkSuper Just False -> E.notExists checkSuper
) )
, single ("company-postal", FilterColumn $ E.mkExactFilterLast $ views (to queryAllCompany) (E.isJust . (E.^. CompanyPostAddress))) , ("company-postal", FilterColumn $ E.mkExactFilterLast $ views (to queryAllCompany) (E.isJust . (E.^. CompanyPostAddress)))
, single ("qualification" , FilterColumn . E.mkExistsFilter $ \row (CI.mk -> criterion :: CI Text) -> do , ("qualification" , FilterColumn . E.mkExistsFilter $ \row (CI.mk -> criterion :: CI Text) -> do
(usrCmp :& usrQual :& qual) <- E.from $ E.table @UserCompany (usrCmp :& usrQual :& qual) <- E.from $ E.table @UserCompany
`E.innerJoin` E.table @QualificationUser `E.innerJoin` E.table @QualificationUser
`E.on` (\(usrCmp :& usrQual) -> usrCmp E.^. UserCompanyUser E.==. usrQual E.^. QualificationUserUser) `E.on` (\(usrCmp :& usrQual) -> usrCmp E.^. UserCompanyUser E.==. usrQual E.^. QualificationUserUser)
@ -666,8 +662,7 @@ mkFirmAllTable isAdmin uid = do
E.&&. qual E.^. QualificationShorthand E.==. E.val criterion E.&&. qual E.^. QualificationShorthand E.==. E.val criterion
E.&&. validQualification now usrQual E.&&. validQualification now usrQual
) )
, single ("company-address", FilterColumn $ E.mkContainsFilterWithCommaPlus id $ views (to queryAllCompany) ((E.->>. "markup-input").(E.^. CompanyPostAddress)) , ("company-address", FilterColumn $ E.mkContainsFilterWithCommaPlus id $ views (to queryAllCompany) ((E.->>. "markup-input").(E.^. CompanyPostAddress)))
)
] ]
dbtFilterUI mPrev = mconcat dbtFilterUI mPrev = mconcat
[ fltrCompanyNameUI mPrev [ fltrCompanyNameUI mPrev
@ -863,20 +858,20 @@ mkFirmUserTable isAdmin cid = do
in numCell prio <> spacerCell <> ifIconCell isPrime IconTop in numCell prio <> spacerCell <> ifIconCell isPrime IconTop
, sortable Nothing (i18nCell MsgTableUserEdit) $ \(view resultUserUser -> entUsr) -> cellEditUserModal entUsr , sortable Nothing (i18nCell MsgTableUserEdit) $ \(view resultUserUser -> entUsr) -> cellEditUserModal entUsr
] ]
dbtSorting = mconcat dbtSorting = Map.fromList
[ single $ sortUserNameLink queryUserUser [ sortUserNameLink queryUserUser
, single $ sortUserEmail queryUserUser , sortUserEmail queryUserUser
, singletonMap "postal-pref" $ SortColumn $ queryUserUser >>> (E.^. UserPrefersPostal) , ("postal-pref" , SortColumn $ queryUserUser >>> (E.^. UserPrefersPostal) )
, singletonMap "matriculation" $ SortColumn $ queryUserUser >>> (E.^. UserMatrikelnummer) , ("matriculation" , SortColumn $ queryUserUser >>> (E.^. UserMatrikelnummer) )
, singletonMap "personal-number" $ SortColumn $ queryUserUser >>> (E.^. UserCompanyPersonalNumber) , ("personal-number" , SortColumn $ queryUserUser >>> (E.^. UserCompanyPersonalNumber))
, singletonMap "supervisors" $ SortColumn $ queryUserUserCompany >>> firmCountUserSupervisors , ("supervisors" , SortColumn $ queryUserUserCompany >>> firmCountUserSupervisors )
, singletonMap "reroutes" $ SortColumn $ queryUserUserCompany >>> firmCountUserSupervisorsReroute , ("reroutes" , SortColumn $ queryUserUserCompany >>> firmCountUserSupervisorsReroute )
, singletonMap "usr-reason" $ SortColumn $ queryUserUserCompany >>> (E.^. UserCompanyReason) , ("usr-reason" , SortColumn $ queryUserUserCompany >>> (E.^. UserCompanyReason) )
, singletonMap "priority" $ SortColumn $ queryUserUserCompany >>> (E.^. UserCompanyPriority) , ("priority" , SortColumn $ queryUserUserCompany >>> (E.^. UserCompanyPriority) )
] ]
dbtFilter = mconcat dbtFilter = Map.fromList
[ single $ fltrUserNameEmail queryUserUser [ fltrUserNameEmail queryUserUser
, singletonMap "has-supervisor" $ FilterColumn $ \row (getLast -> criterion) -> , ("has-supervisor", FilterColumn $ \row (getLast -> criterion) ->
let checkSuper = do let checkSuper = do
usrSpr <- E.from $ E.table @UserSupervisor usrSpr <- E.from $ E.table @UserSupervisor
E.where_ $ usrSpr E.^. UserSupervisorUser E.==. queryUserUser row E.^. UserId E.where_ $ usrSpr E.^. UserSupervisorUser E.==. queryUserUser row E.^. UserId
@ -884,7 +879,8 @@ mkFirmUserTable isAdmin cid = do
Nothing -> E.true Nothing -> E.true
Just True -> E.exists checkSuper Just True -> E.exists checkSuper
Just False -> E.notExists checkSuper Just False -> E.notExists checkSuper
, singletonMap "has-company-supervisor" $ FilterColumn $ \row (getLast -> criterion) -> )
, ("has-company-supervisor", FilterColumn $ \row (getLast -> criterion) ->
let checkSuper = do let checkSuper = do
usrSpr <- E.from $ E.table @UserSupervisor usrSpr <- E.from $ E.table @UserSupervisor
E.where_ $ usrSpr E.^. UserSupervisorUser E.==. queryUserUser row E.^. UserId E.where_ $ usrSpr E.^. UserSupervisorUser E.==. queryUserUser row E.^. UserId
@ -897,7 +893,8 @@ mkFirmUserTable isAdmin cid = do
Nothing -> E.true Nothing -> E.true
Just True -> E.exists checkSuper Just True -> E.exists checkSuper
Just False -> E.notExists checkSuper Just False -> E.notExists checkSuper
, singletonMap "has-foreign-supervisor" $ FilterColumn $ \row (getLast -> criterion) -> )
, ("has-foreign-supervisor", FilterColumn $ \row (getLast -> criterion) ->
let checkSuper = do let checkSuper = do
usrSpr <- E.from $ E.table @UserSupervisor usrSpr <- E.from $ E.table @UserSupervisor
E.where_ $ usrSpr E.^. UserSupervisorUser E.==. queryUserUser row E.^. UserId E.where_ $ usrSpr E.^. UserSupervisorUser E.==. queryUserUser row E.^. UserId
@ -910,7 +907,8 @@ mkFirmUserTable isAdmin cid = do
Nothing -> E.true Nothing -> E.true
Just True -> E.exists checkSuper Just True -> E.exists checkSuper
Just False -> E.notExists checkSuper Just False -> E.notExists checkSuper
, singletonMap "supervisor-is" $ FilterColumn $ \row (getLast -> criterion) -> )
, ("supervisor-is", FilterColumn $ \row (getLast -> criterion) ->
case criterion of case criterion of
Just uid -> do Just uid -> do
-- uid <- decryptUser uuid -- uid <- decryptUser uuid
@ -919,7 +917,8 @@ mkFirmUserTable isAdmin cid = do
E.where_ $ usrSpr E.^. UserSupervisorUser E.==. queryUserUser row E.^. UserId E.where_ $ usrSpr E.^. UserSupervisorUser E.==. queryUserUser row E.^. UserId
E.&&. usrSpr E.^. UserSupervisorSupervisor E.==. E.val uid E.&&. usrSpr E.^. UserSupervisorSupervisor E.==. E.val uid
_otherwise -> E.true _otherwise -> E.true
, singletonMap "supervisors-are" $ FilterColumn $ \row criteria -> )
, ("supervisors-are", FilterColumn $ \row criteria ->
case criteria of case criteria of
_ | Set.null criteria -> E.true _ | Set.null criteria -> E.true
| otherwise -> do | otherwise -> do
@ -928,7 +927,8 @@ mkFirmUserTable isAdmin cid = do
usrSpr <- E.from $ E.table @UserSupervisor usrSpr <- E.from $ E.table @UserSupervisor
E.where_ $ usrSpr E.^. UserSupervisorUser E.==. queryUserUser row E.^. UserId E.where_ $ usrSpr E.^. UserSupervisorUser E.==. queryUserUser row E.^. UserId
E.&&. usrSpr E.^. UserSupervisorSupervisor `E.in_` E.vals criteria E.&&. usrSpr E.^. UserSupervisorSupervisor `E.in_` E.vals criteria
, singletonMap "is-primary-company" $ FilterColumn $ \row (getLast -> criterion) -> )
, ("is-primary-company", FilterColumn $ \row (getLast -> criterion) ->
let checkPrimary = do let checkPrimary = do
other <- E.from $ E.table @UserCompany other <- E.from $ E.table @UserCompany
E.where_ $ other E.^. UserCompanyUser E.==. queryUserUserCompany row E.^. UserCompanyUser E.where_ $ other E.^. UserCompanyUser E.==. queryUserUserCompany row E.^. UserCompanyUser
@ -937,6 +937,7 @@ mkFirmUserTable isAdmin cid = do
Nothing -> E.true Nothing -> E.true
Just False -> E.exists checkPrimary Just False -> E.exists checkPrimary
Just True -> E.notExists checkPrimary Just True -> E.notExists checkPrimary
)
] ]
-- superField = selectField $ ???? -- superField = selectField $ ????
dbtFilterUI mPrev = mconcat dbtFilterUI mPrev = mconcat
@ -1251,31 +1252,32 @@ mkFirmSuperTable isAdmin cid = do
, sortable (Just "def-reroute") (i18nCell MsgTableIsDefaultReroute) $ \(view resultSuperCompanyDefaultReroute -> mb) -> tickmarkCell (mb == Just True) , sortable (Just "def-reroute") (i18nCell MsgTableIsDefaultReroute) $ \(view resultSuperCompanyDefaultReroute -> mb) -> tickmarkCell (mb == Just True)
, sortable Nothing (i18nCell MsgTableUserEdit) $ \(view resultSuperUser -> entUsr) -> cellEditUserModal entUsr , sortable Nothing (i18nCell MsgTableUserEdit) $ \(view resultSuperUser -> entUsr) -> cellEditUserModal entUsr
] ]
dbtSorting = mconcat dbtSorting = Map.fromList
[ single $ sortUserNameLink querySuperUser [ sortUserNameLink querySuperUser
, single $ sortUserEmail querySuperUser , sortUserEmail querySuperUser
, singletonMap "matriculation" $ SortColumn $ querySuperUser >>> (E.^. UserMatrikelnummer) , ("matriculation" , SortColumn $ querySuperUser >>> (E.^. UserMatrikelnummer))
, singletonMap "personal-number" $ SortColumn $ querySuperUser >>> (E.^. UserCompanyPersonalNumber) , ("personal-number" , SortColumn $ querySuperUser >>> (E.^. UserCompanyPersonalNumber))
, singletonMap "postal-pref" $ SortColumn $ querySuperUser >>> (E.^. UserPrefersPostal) , ("postal-pref" , SortColumn $ querySuperUser >>> (E.^. UserPrefersPostal))
, singletonMap "supervised" $ SortColumn $ querySuperUser >>> firmCountForSupervisor cid Nothing , ("supervised" , SortColumn $ querySuperUser >>> firmCountForSupervisor cid Nothing)
, singletonMap "rerouted" $ SortColumn $ querySuperUser >>> firmCountForSupervisor cid (Just (E.^. UserSupervisorRerouteNotifications)) , ("rerouted" , SortColumn $ querySuperUser >>> firmCountForSupervisor cid (Just (E.^. UserSupervisorRerouteNotifications)))
, singletonMap "user-company" $ SortColumn (\row -> E.subSelect $ do , ("user-company" , SortColumn (\row -> E.subSelect $ do
(cmp :& usrCmp) <- E.from $ E.table @Company `E.innerJoin` E.table @UserCompany `E.on` (\(cmp :& usrCmp) -> cmp E.^. CompanyId E.==. usrCmp E.^. UserCompanyCompany) (cmp :& usrCmp) <- E.from $ E.table @Company `E.innerJoin` E.table @UserCompany `E.on` (\(cmp :& usrCmp) -> cmp E.^. CompanyId E.==. usrCmp E.^. UserCompanyCompany)
E.where_ $ usrCmp E.^. UserCompanyUser E.==. querySuperUser row E.^. UserId E.where_ $ usrCmp E.^. UserCompanyUser E.==. querySuperUser row E.^. UserId
E.orderBy [E.asc $ cmp E.^. CompanyName] E.orderBy [E.asc $ cmp E.^. CompanyName]
return (cmp E.^. CompanyName) return (cmp E.^. CompanyName)
) ))
, singletonMap "def-super" $ SortColumn $ querySuperUserCompany >>> (E.?. UserCompanySupervisor) , ("def-super" , SortColumn $ querySuperUserCompany >>> (E.?. UserCompanySupervisor))
, singletonMap "def-reroute" $ SortColumn $ querySuperUserCompany >>> (E.?. UserCompanySupervisorReroute) , ("def-reroute" , SortColumn $ querySuperUserCompany >>> (E.?. UserCompanySupervisorReroute))
] ]
dbtFilter = mconcat dbtFilter = Map.fromList
[ single $ fltrUserNameEmail querySuperUser [ fltrUserNameEmail querySuperUser
, singletonMap "is-foreign-supervisor" $ FilterColumn $ \(querySuperUserCompany -> suc) (getLast -> criterion) -> , ("is-foreign-supervisor", FilterColumn $ \(querySuperUserCompany -> suc) (getLast -> criterion) ->
case criterion of case criterion of
Nothing -> E.true Nothing -> E.true
Just True -> E.isNothing $ suc E.?. UserCompanyUser Just True -> E.isNothing $ suc E.?. UserCompanyUser
Just False -> E.isJust $ suc E.?. UserCompanyUser Just False -> E.isJust $ suc E.?. UserCompanyUser
, singletonMap "super-relation-foreign" $ FilterColumn $ \row (getLast -> criterion) -> )
, ("super-relation-foreign", FilterColumn $ \row (getLast -> criterion) ->
let checkSuper = do let checkSuper = do
usrSpr <- E.from $ E.table @UserSupervisor usrSpr <- E.from $ E.table @UserSupervisor
E.where_ $ usrSpr E.^. UserSupervisorSupervisor E.==. querySuperUser row E.^. UserId E.where_ $ usrSpr E.^. UserSupervisorSupervisor E.==. querySuperUser row E.^. UserId
@ -1288,6 +1290,7 @@ mkFirmSuperTable isAdmin cid = do
Nothing -> E.true Nothing -> E.true
Just True -> E.exists checkSuper Just True -> E.exists checkSuper
Just False -> E.notExists checkSuper Just False -> E.notExists checkSuper
)
] ]
dbtFilterUI mPrev = mconcat dbtFilterUI mPrev = mconcat
[ fltrUserNameEmailHdrUI MsgTableSupervisor mPrev [ fltrUserNameEmailHdrUI MsgTableSupervisor mPrev

68
src/Handler/LMS.hs
View File

@ -50,10 +50,6 @@ import Handler.LMS.Report as Handler.LMS
import Handler.LMS.Fake as Handler.LMS -- TODO: remove in production! import Handler.LMS.Fake as Handler.LMS -- TODO: remove in production!
-- avoids repetition of local definitions
single :: (k,a) -> Map k a
single = uncurry Map.singleton
-- Button only needed here -- Button only needed here
data ButtonManualLms = BtnLmsEnqueue | BtnLmsDequeue data ButtonManualLms = BtnLmsEnqueue | BtnLmsDequeue
deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic) deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic)
@ -457,54 +453,54 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do
dbtRowKey = queryUser >>> (E.^. UserId) dbtRowKey = queryUser >>> (E.^. UserId)
dbtProj = dbtProjId dbtProj = dbtProjId
dbtColonnade = cols getCompanyName dbtColonnade = cols getCompanyName
dbtSorting = mconcat dbtSorting = Map.fromList
[ single $ sortUserNameLink queryUser [ sortUserNameLink queryUser
, single $ sortUserEmail queryUser , sortUserEmail queryUser
, single $ sortUserMatriclenr queryUser , sortUserMatriclenr queryUser
, single ("valid-until" , SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserValidUntil)) , ("valid-until" , SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserValidUntil))
-- , single ("validity" , SortColumn $ queryQualUser >>> validQualification nowaday) -- , ("validity" , SortColumn $ queryQualUser >>> validQualification nowaday)
, single ("last-refresh" , SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserLastRefresh)) , ("last-refresh" , SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserLastRefresh))
, single ("first-held" , SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserFirstHeld)) , ("first-held" , SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserFirstHeld))
, single ("blocked" , SortColumnNeverNull$ queryQualBlock >>> (E.?. QualificationUserBlockFrom)) , ("blocked" , SortColumnNeverNull$ queryQualBlock >>> (E.?. QualificationUserBlockFrom))
, single ("schedule-renew", SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserScheduleRenewal)) , ("schedule-renew", SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserScheduleRenewal))
, single ("ident" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserIdent)) , ("ident" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserIdent))
, single ("pin" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserPin)) , ("pin" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserPin))
-- , single ("status" , SortColumnNullsInv $ views (to queryLmsUser) (E.^. LmsUserStatusDay)) -- , ("status" , SortColumnNullsInv $ views (to queryLmsUser) (E.^. LmsUserStatusDay))
, single ("status" , SortColumnNeverNull $ \row -> E.coalesceDefault [ queryLmsUser row E.^. LmsUserStatusDay , ("status" , SortColumnNeverNull $ \row -> E.coalesceDefault [ queryLmsUser row E.^. LmsUserStatusDay
, queryLmsUser row E.^. LmsUserNotified , queryLmsUser row E.^. LmsUserNotified
](queryLmsUser row E.^. LmsUserStarted)) ](queryLmsUser row E.^. LmsUserStarted))
, single ("started" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserStarted)) , ("started" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserStarted))
, single ("datepin" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserDatePin)) , ("datepin" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserDatePin))
, single ("received" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserReceived)) , ("received" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserReceived))
, single ("notified" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserNotified)) -- cannot include printJob acknowledge date , ("notified" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserNotified)) -- cannot include printJob acknowledge date
, single ("ended" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserEnded)) , ("ended" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserEnded))
, single ("user-company", SortColumn $ \row -> E.subSelect $ E.from $ \(usrComp `E.InnerJoin` comp) -> do , ("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
E.orderBy [E.asc (comp E.^. CompanyName)] E.orderBy [E.asc (comp E.^. CompanyName)]
return (comp E.^. CompanyName) return (comp E.^. CompanyName)
) )
] ]
dbtFilter = mconcat dbtFilter = Map.fromList
[ single $ fltrUserNameEmail queryUser [ fltrUserNameEmail queryUser
, single ("ident" , FilterColumn . E.mkContainsFilterWithCommaPlus LmsIdent $ views (to queryLmsUser) (E.^. LmsUserIdent)) , ("ident" , FilterColumn . E.mkContainsFilterWithCommaPlus LmsIdent $ views (to queryLmsUser) (E.^. LmsUserIdent))
, single ("status" , FilterColumn . E.mkExactFilterMaybeLast $ views (to queryLmsUser) (E.^. LmsUserStatus)) , ("status" , FilterColumn . E.mkExactFilterMaybeLast $ views (to queryLmsUser) (E.^. LmsUserStatus))
-- , single ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) ((E.>=. E.val nowaday) . (E.^. QualificationUserValidUntil))) -- , ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) ((E.>=. E.val nowaday) . (E.^. QualificationUserValidUntil)))
, single ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) (validQualification now)) , ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) (validQualification now))
-- , single ("renewal-due" , FilterColumn $ \(queryQualUser -> quser) criterion -> -- , ("renewal-due" , FilterColumn $ \(queryQualUser -> quser) criterion ->
-- if | Just renewal <- mbRenewal -- if | Just renewal <- mbRenewal
-- , Just True <- getLast criterion -> quser E.^. QualificationUserValidUntil E.<=. E.val renewal -- , Just True <- getLast criterion -> quser E.^. QualificationUserValidUntil E.<=. E.val renewal
-- E.&&. quser E.^. QualificationUserValidUntil E.>=. E.val nowaday -- E.&&. quser E.^. QualificationUserValidUntil E.>=. E.val nowaday
-- | otherwise -> E.true -- | otherwise -> E.true
-- ) -- )
, single ("notified", FilterColumn . E.mkExactFilterLast $ views (to queryLmsUser) (E.isJust . (E.^. LmsUserNotified))) , ("notified", FilterColumn . E.mkExactFilterLast $ views (to queryLmsUser) (E.isJust . (E.^. LmsUserNotified)))
, single ("avs-number" , FilterColumn . E.mkExistsFilter $ \row criterion -> , ("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
E.&&. ((E.val criterion :: E.SqlExpr (E.Value (CI Text))) E.==. E.&&. ((E.val criterion :: E.SqlExpr (E.Value (CI Text))) E.==.
(E.explicitUnsafeCoerceSqlExprValue "citext" (usrAvs E.^. UserAvsNoPerson) :: E.SqlExpr (E.Value (CI Text))) )) (E.explicitUnsafeCoerceSqlExprValue "citext" (usrAvs E.^. UserAvsNoPerson) :: E.SqlExpr (E.Value (CI Text))) ))
, single ("user-company", FilterColumn . E.mkExistsFilter $ \row criterion -> , ("user-company", FilterColumn . E.mkExistsFilter $ \row criterion ->
E.from $ \(usrComp `E.InnerJoin` comp) -> do E.from $ \(usrComp `E.InnerJoin` comp) -> do
let testname = (E.val criterion :: E.SqlExpr (E.Value (CI Text))) `E.isInfixOf` let testname = (E.val criterion :: E.SqlExpr (E.Value (CI Text))) `E.isInfixOf`
(E.explicitUnsafeCoerceSqlExprValue "citext" (comp E.^. CompanyName) :: E.SqlExpr (E.Value (CI Text))) (E.explicitUnsafeCoerceSqlExprValue "citext" (comp E.^. CompanyName) :: E.SqlExpr (E.Value (CI Text)))
@ -514,7 +510,7 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do
E.where_ $ usrComp E.^. UserCompanyUser E.==. queryUser row E.^. UserId E.&&. testcrit E.where_ $ usrComp E.^. UserCompanyUser E.==. queryUser row E.^. UserId E.&&. testcrit
) )
, fltrAVSCardNos queryUser , fltrAVSCardNos queryUser
, single ("personal-number", FilterColumn $ \(queryUser -> user) (criteria :: Set.Set Text) -> if , ("personal-number", FilterColumn $ \(queryUser -> user) (criteria :: Set.Set Text) -> if
| Set.null criteria -> E.true | Set.null criteria -> E.true
| otherwise -> E.any (\c -> user E.^. UserCompanyPersonalNumber `E.hasInfix` E.val c) criteria | otherwise -> E.any (\c -> user E.^. UserCompanyPersonalNumber `E.hasInfix` E.val c) criteria
) )

20
src/Handler/LMS/Learners.hs
View File

@ -76,19 +76,15 @@ instance FromNamedRecord LmsUserTableCsv where
<*> csv Csv..: csvLmsLock <*> csv Csv..: csvLmsLock
instance CsvColumnsExplained LmsUserTableCsv where instance CsvColumnsExplained LmsUserTableCsv where
csvColumnsExplanations _ = mconcat csvColumnsExplanations _ = Map.fromList
[ single csvLmsIdent MsgCsvColumnLmsIdent [ (csvLmsIdent , msg2widget MsgCsvColumnLmsIdent)
, single csvLmsPin MsgCsvColumnLmsPin , (csvLmsPin , msg2widget MsgCsvColumnLmsPin)
, single csvLmsResetPin MsgCsvColumnLmsResetPin , (csvLmsResetPin , msg2widget MsgCsvColumnLmsResetPin)
, single csvLmsDelete MsgCsvColumnLmsDelete , (csvLmsDelete , msg2widget MsgCsvColumnLmsDelete)
, single csvLmsStaff MsgCsvColumnLmsStaff , (csvLmsStaff , msg2widget MsgCsvColumnLmsStaff)
, single csvLmsResetTries MsgCsvColumnLmsResetTries , (csvLmsResetTries , msg2widget MsgCsvColumnLmsResetTries)
, single csvLmsLock MsgCsvColumnLmsLock , (csvLmsLock , msg2widget MsgCsvColumnLmsLock)
] ]
where
single :: RenderMessage UniWorX msg => Csv.Name -> msg -> Map Csv.Name Widget
single k v = singletonMap k [whamlet|_{v}|]
mkUserTable :: SchoolId -> QualificationShorthand -> QualificationId -> UTCTime -> DB (Any, Widget) mkUserTable :: SchoolId -> QualificationShorthand -> QualificationId -> UTCTime -> DB (Any, Widget)

13
src/Handler/LMS/Report.hs
View File

@ -64,15 +64,12 @@ instance FromNamedRecord LmsReportTableCsv where
<*> csv Csv..: csvLmsLock <*> csv Csv..: csvLmsLock
instance CsvColumnsExplained LmsReportTableCsv where instance CsvColumnsExplained LmsReportTableCsv where
csvColumnsExplanations _ = mconcat csvColumnsExplanations _ = Map.fromList
[ single csvLmsIdent MsgCsvColumnLmsIdent [ (csvLmsIdent , msg2widget MsgCsvColumnLmsIdent)
, single csvLmsDate MsgCsvColumnLmsDate , (csvLmsDate , msg2widget MsgCsvColumnLmsDate)
, single csvLmsResult MsgCsvColumnLmsResult , (csvLmsResult , msg2widget MsgCsvColumnLmsResult)
, single csvLmsLock MsgCsvColumnLmsLock , (csvLmsLock , msg2widget MsgCsvColumnLmsLock)
] ]
where
single :: RenderMessage UniWorX msg => Csv.Name -> msg -> Map Csv.Name Widget
single k v = singletonMap k [whamlet|_{v}|]
data LmsReportCsvActionClass = LmsReportInsert | LmsReportUpdate data LmsReportCsvActionClass = LmsReportInsert | LmsReportUpdate
deriving (Eq, Ord, Read, Show, Generic, Enum, Bounded) deriving (Eq, Ord, Read, Show, Generic, Enum, Bounded)

26
src/Handler/LMS/Users.hs
View File

@ -68,23 +68,19 @@ instance FromNamedRecord LmsUserTableCsv where
<*> csv Csv..: csvLmsStaff <*> csv Csv..: csvLmsStaff
instance CsvColumnsExplained LmsUserTableCsv where instance CsvColumnsExplained LmsUserTableCsv where
csvColumnsExplanations _ = mconcat csvColumnsExplanations _ = Map.fromList
[ single csvLmsIdent MsgCsvColumnLmsIdent [ (csvLmsIdent , msg2widget MsgCsvColumnLmsIdent)
, single csvLmsPin MsgCsvColumnLmsPin , (csvLmsPin , msg2widget MsgCsvColumnLmsPin)
, single csvLmsResetPin MsgCsvColumnLmsResetPin , (csvLmsResetPin , msg2widget MsgCsvColumnLmsResetPin)
, single csvLmsDelete MsgCsvColumnLmsDelete , (csvLmsDelete , msg2widget MsgCsvColumnLmsDelete)
, single csvLmsStaff MsgCsvColumnLmsStaff , (csvLmsStaff , msg2widget MsgCsvColumnLmsStaff)
] ]
where
single :: RenderMessage UniWorX msg => Csv.Name -> msg -> Map Csv.Name Widget
single k v = singletonMap k [whamlet|_{v}|]
mkUserTable :: SchoolId -> QualificationShorthand -> QualificationId -> DB (Any, Widget) mkUserTable :: SchoolId -> QualificationShorthand -> QualificationId -> DB (Any, Widget)
mkUserTable _sid qsh qid = do mkUserTable _sid qsh qid = do
cutoff <- liftHandler $ lmsDeletionDate Nothing cutoff <- liftHandler $ lmsDeletionDate Nothing
dbtCsvName <- csvFilenameLmsUser qsh dbtCsvName <- csvFilenameLmsUser qsh
let dbtCsvSheetName = dbtCsvName let dbtCsvSheetName = dbtCsvName
let let
userDBTable = DBTable{..} userDBTable = DBTable{..}
@ -160,7 +156,7 @@ getLmsUsersDirectR sid qsh = do
selectList [ LmsUserQualification ==. qid selectList [ LmsUserQualification ==. qid
, LmsUserEnded ==. Nothing , LmsUserEnded ==. Nothing
-- , LmsUserReceived ==. Nothing ||. LmsUserResetPin ==. True ||. LmsUserStatus !=. Nothing -- send delta only NOTE: know-how no longer expects delta -- , LmsUserReceived ==. Nothing ||. LmsUserResetPin ==. True ||. LmsUserStatus !=. Nothing -- send delta only NOTE: know-how no longer expects delta
] [Asc LmsUserStarted, Asc LmsUserIdent] ] [Asc LmsUserStarted, Asc LmsUserIdent]
{- To avoid exporting unneeded columns, we would need an SqlSelect instance for LmsUserTableCsv; probably not worth it {- To avoid exporting unneeded columns, we would need an SqlSelect instance for LmsUserTableCsv; probably not worth it
Ex.select $ do Ex.select $ do
@ -175,7 +171,7 @@ getLmsUsersDirectR sid qsh = do
, csvLUTstaff = LmsBool False , csvLUTstaff = LmsBool False
} }
-} -}
LmsConf{..} <- getsYesod $ view _appLmsConf LmsConf{..} <- getsYesod $ view _appLmsConf
let --csvRenderedData = toNamedRecord . lmsUser2csv . entityVal <$> lms_users let --csvRenderedData = toNamedRecord . lmsUser2csv . entityVal <$> lms_users
--csvRenderedHeader = lmsUserTableCsvHeader --csvRenderedHeader = lmsUserTableCsvHeader
--cvsRendered = CsvRendered {..} --cvsRendered = CsvRendered {..}
@ -188,10 +184,10 @@ getLmsUsersDirectR sid qsh = do
csvOpts = def { csvFormat = fmtOpts } csvOpts = def { csvFormat = fmtOpts }
csvSheetName <- csvFilenameLmsUser qsh csvSheetName <- csvFilenameLmsUser qsh
let nr = length lms_users let nr = length lms_users
msg = "Success. LMS Users download file " <> csvSheetName <> " containing " <> tshow nr <> " rows" msg = "Success. LMS Users download file " <> csvSheetName <> " containing " <> tshow nr <> " rows"
$logInfoS "LMS" msg $logInfoS "LMS" msg
addHeader "Content-Disposition" $ "attachment; filename=\"" <> csvSheetName <> "\"" addHeader "Content-Disposition" $ "attachment; filename=\"" <> csvSheetName <> "\""
csvRenderedToTypedContentWith csvOpts csvSheetName csvRendered csvRenderedToTypedContentWith csvOpts csvSheetName csvRendered
-- direct Download see: -- direct Download see:
-- https://ersocon.net/blog/2017/2/22/creating-csv-files-in-yesod -- https://ersocon.net/blog/2017/2/22/creating-csv-files-in-yesod

22
src/Handler/MailCenter.hs
View File

@ -41,12 +41,6 @@ import qualified Data.ByteString.Lazy as LB
import Handler.Utils import Handler.Utils
-- avoids repetition of local definitions
single :: (k,a) -> Map k a
single = uncurry Map.singleton
data MCTableAction = MCActDummy -- just a dummy, since we don't now yet which actions we will be needing data MCTableAction = MCActDummy -- just a dummy, since we don't now yet which actions we will be needing
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
@ -101,15 +95,15 @@ mkMCTable = do
-- , sortable Nothing (i18nCell MsgCommContent) $ \(view $ resultMail . _entityKey -> k) -> anchorCellM (MailHtmlR <$> encrypt k) (text2widget "html") -- , sortable Nothing (i18nCell MsgCommContent) $ \(view $ resultMail . _entityKey -> k) -> anchorCellM (MailHtmlR <$> encrypt k) (text2widget "html")
-- , sortable Nothing (i18nCell MsgCommSubject) $ \(preview $ resultMail . _entityVal . _sentMailHeaders . _mailHeaders' . _mailHeader' "Subject" -> h) -> cellMaybe textCell h -- , sortable Nothing (i18nCell MsgCommSubject) $ \(preview $ resultMail . _entityVal . _sentMailHeaders . _mailHeaders' . _mailHeader' "Subject" -> h) -> cellMaybe textCell h
] ]
dbtSorting = mconcat dbtSorting = Map.fromList
[ single ("sent" , SortColumn $ queryMail >>> (E.^. SentMailSentAt)) [ ("sent" , SortColumn $ queryMail >>> (E.^. SentMailSentAt))
, single ("recipient" , sortUserNameBareM queryRecipient) , ("recipient" , sortUserNameBareM queryRecipient)
] ]
dbtFilter = mconcat dbtFilter = Map.fromList
[ single ("sent" , FilterColumn . E.mkDayFilterTo $ views (to queryMail) (E.^. SentMailSentAt)) [ ("sent" , FilterColumn . E.mkDayFilterTo $ views (to queryMail) (E.^. SentMailSentAt))
, single ("recipient" , FilterColumn . E.mkContainsFilterWithCommaPlus Just $ views (to queryRecipient) (E.?. UserDisplayName)) , ("recipient" , FilterColumn . E.mkContainsFilterWithCommaPlus Just $ views (to queryRecipient) (E.?. UserDisplayName))
, single ("subject" , FilterColumn . E.mkContainsFilterWithCommaPlus id $ views (to queryMail) (E.str2text . (E.^. SentMailHeaders))) , ("subject" , FilterColumn . E.mkContainsFilterWithCommaPlus id $ views (to queryMail) (E.str2text . (E.^. SentMailHeaders)))
-- , single ("regex" , FilterColumn . E.mkRegExFilterWith id $ views (to queryMail) (E.str2text . (E.^. SentMailHeaders))) -- , ("regex" , FilterColumn . E.mkRegExFilterWith id $ views (to queryMail) (E.str2text . (E.^. SentMailHeaders)))
] ]
dbtFilterUI mPrev = mconcat dbtFilterUI mPrev = mconcat
[ prismAForm (singletonFilter "sent" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift dayField) (fslI MsgPrintJobCreated) [ prismAForm (singletonFilter "sent" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift dayField) (fslI MsgPrintJobCreated)

55
src/Handler/PrintCenter.hs
View File

@ -39,11 +39,6 @@ import qualified Data.CaseInsensitive as CI
import Jobs.Queue import Jobs.Queue
-- avoids repetition of local definitions
single :: (k,a) -> Map k a
single = uncurry Map.singleton
data LRQF = LRQF data LRQF = LRQF
{ lrqfLetter :: Text { lrqfLetter :: Text
, lrqfUser :: Either UserEmail UserId , lrqfUser :: Either UserEmail UserId
@ -224,33 +219,33 @@ mkPJTable = do
, sortable (Just "qualification")(i18nCell MsgPrintQualification) $ \(preview $ resultQualification . _entityVal -> q) -> maybeCell q qualificationCell , sortable (Just "qualification")(i18nCell MsgPrintQualification) $ \(preview $ resultQualification . _entityVal -> q) -> maybeCell q qualificationCell
, sortable (Just "lmsid") (i18nCell MsgPrintLmsUser) $ \( view $ resultPrintJob . _entityVal . _printJobLmsUser -> l) -> foldMap (textCell . getLmsIdent) l , sortable (Just "lmsid") (i18nCell MsgPrintLmsUser) $ \( view $ resultPrintJob . _entityVal . _printJobLmsUser -> l) -> foldMap (textCell . getLmsIdent) l
] ]
dbtSorting = mconcat dbtSorting = Map.fromList
[ single ("name" , SortColumn $ queryPrintJob >>> (E.^. PrintJobName)) [ ("name" , SortColumn $ queryPrintJob >>> (E.^. PrintJobName))
, single ("filename" , SortColumn $ queryPrintJob >>> (E.^. PrintJobFilename)) , ("filename" , SortColumn $ queryPrintJob >>> (E.^. PrintJobFilename))
, single ("created" , SortColumn $ queryPrintJob >>> (E.^. PrintJobCreated)) , ("created" , SortColumn $ queryPrintJob >>> (E.^. PrintJobCreated))
, single ("acknowledged" , SortColumn $ queryPrintJob >>> (E.^. PrintJobAcknowledged)) , ("acknowledged" , SortColumn $ queryPrintJob >>> (E.^. PrintJobAcknowledged))
, single ("apcid" , SortColumn $ queryPrintJob >>> (E.^. PrintJobApcIdent)) , ("apcid" , SortColumn $ queryPrintJob >>> (E.^. PrintJobApcIdent))
, single ("recipient" , sortUserNameBareM queryRecipient) , ("recipient" , sortUserNameBareM queryRecipient)
, single ("affected" , sortUserNameBareM queryAffected) , ("affected" , sortUserNameBareM queryAffected )
, single ("sender" , sortUserNameBareM querySender ) , ("sender" , sortUserNameBareM querySender )
, single ("course" , SortColumn $ queryCourse >>> (E.?. CourseName)) , ("course" , SortColumn $ queryCourse >>> (E.?. CourseName))
, single ("qualification", SortColumn $ queryQualification >>> (E.?. QualificationName)) , ("qualification", SortColumn $ queryQualification >>> (E.?. QualificationName))
, single ("lmsid" , SortColumn $ queryPrintJob >>> (E.^. PrintJobLmsUser)) , ("lmsid" , SortColumn $ queryPrintJob >>> (E.^. PrintJobLmsUser))
] ]
dbtFilter = mconcat dbtFilter = Map.fromList
[ single ("name" , FilterColumn . E.mkContainsFilterWithCommaPlus id $ views (to queryPrintJob) (E.^. PrintJobName)) [ ("name" , FilterColumn . E.mkContainsFilterWithCommaPlus id $ views (to queryPrintJob) (E.^. PrintJobName))
, single ("apcid" , FilterColumn . E.mkContainsFilterWithComma id $ views (to queryPrintJob) (E.^. PrintJobApcIdent)) , ("apcid" , FilterColumn . E.mkContainsFilterWithComma id $ views (to queryPrintJob) (E.^. PrintJobApcIdent))
, single ("filename" , FilterColumn . E.mkContainsFilter $ views (to queryPrintJob) (E.^. PrintJobFilename)) , ("filename" , FilterColumn . E.mkContainsFilter $ views (to queryPrintJob) (E.^. PrintJobFilename))
, single ("created" , FilterColumn . E.mkDayFilter $ views (to queryPrintJob) (E.^. PrintJobCreated)) , ("created" , FilterColumn . E.mkDayFilter $ views (to queryPrintJob) (E.^. PrintJobCreated))
--, single ("created" , FilterColumn . E.mkDayBetweenFilter $ views (to queryPrintJob) (E.^. PrintJobCreated)) --, ("created" , FilterColumn . E.mkDayBetweenFilter $ views (to queryPrintJob) (E.^. PrintJobCreated))
, single ("recipient" , FilterColumn . E.mkContainsFilterWithCommaPlus Just $ views (to queryRecipient) (E.?. UserDisplayName)) , ("recipient" , FilterColumn . E.mkContainsFilterWithCommaPlus Just $ views (to queryRecipient) (E.?. UserDisplayName))
, single ("affected" , FilterColumn . E.mkContainsFilterWithCommaPlus Just $ views (to queryAffected) (E.?. UserDisplayName)) , ("affected" , FilterColumn . E.mkContainsFilterWithCommaPlus Just $ views (to queryAffected) (E.?. UserDisplayName))
, single ("sender" , FilterColumn . E.mkContainsFilterWithCommaPlus Just $ views (to querySender) (E.?. UserDisplayName)) , ("sender" , FilterColumn . E.mkContainsFilterWithCommaPlus Just $ views (to querySender) (E.?. UserDisplayName))
, single ("course" , FilterColumn . E.mkContainsFilterWith (Just . CI.mk) $ views (to queryCourse) (E.?. CourseName)) , ("course" , FilterColumn . E.mkContainsFilterWith (Just . CI.mk) $ views (to queryCourse) (E.?. CourseName))
, single ("qualification", FilterColumn . E.mkContainsFilterWith (Just . CI.mk) $ views (to queryQualification) (E.?. QualificationName)) , ("qualification", FilterColumn . E.mkContainsFilterWith (Just . CI.mk) $ views (to queryQualification) (E.?. QualificationName))
, single ("lmsid" , FilterColumn . E.mkContainsFilterWithCommaPlus (Just . LmsIdent) $ views (to queryPrintJob) (E.^. PrintJobLmsUser)) , ("lmsid" , FilterColumn . E.mkContainsFilterWithCommaPlus (Just . LmsIdent) $ views (to queryPrintJob) (E.^. PrintJobLmsUser))
, single ("acknowledged" , FilterColumn . E.mkExactFilterLast $ views (to queryPrintJob) (E.isJust . (E.^. PrintJobAcknowledged))) , ("acknowledged" , FilterColumn . E.mkExactFilterLast $ views (to queryPrintJob) (E.isJust . (E.^. PrintJobAcknowledged)))
] ]
dbtFilterUI mPrev = mconcat dbtFilterUI mPrev = mconcat
[ prismAForm (singletonFilter "name" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintJobName & setTooltip MsgTableFilterCommaPlus) [ prismAForm (singletonFilter "name" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintJobName & setTooltip MsgTableFilterCommaPlus)

50
src/Handler/Qualification.hs
View File

@ -36,10 +36,6 @@ import Database.Esqueleto.Utils.TH
-- import Handler.Utils.Qualification (validQualification) -- import Handler.Utils.Qualification (validQualification)
-- avoids repetition of local definitions
single :: (k,a) -> Map k a
single = uncurry Map.singleton
getQualificationSchoolR :: SchoolId -> Handler Html getQualificationSchoolR :: SchoolId -> Handler Html
getQualificationSchoolR ssh = redirect (QualificationAllR, [("qualification-overview-school", toPathPiece ssh)]) getQualificationSchoolR ssh = redirect (QualificationAllR, [("qualification-overview-school", toPathPiece ssh)])
@ -386,40 +382,40 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do
dbtRowKey = queryUser >>> (E.^. UserId) dbtRowKey = queryUser >>> (E.^. UserId)
dbtProj = dbtProjId dbtProj = dbtProjId
dbtColonnade = cols getCompanyName dbtColonnade = cols getCompanyName
dbtSorting = mconcat dbtSorting = Map.fromList
[ single $ sortUserNameLink queryUser [ sortUserNameLink queryUser
, single $ sortUserEmail queryUser , sortUserEmail queryUser
, single $ sortUserMatriclenr queryUser , sortUserMatriclenr queryUser
, single ("first-held" , SortColumn $ queryQualUser >>> (E.^. QualificationUserFirstHeld)) , ("first-held" , SortColumn $ queryQualUser >>> (E.^. QualificationUserFirstHeld))
, single ("last-refresh" , SortColumn $ queryQualUser >>> (E.^. QualificationUserLastRefresh)) , ("last-refresh" , SortColumn $ queryQualUser >>> (E.^. QualificationUserLastRefresh))
, single ("last-notified" , SortColumn $ queryQualUser >>> (E.^. QualificationUserLastNotified)) , ("last-notified" , SortColumn $ queryQualUser >>> (E.^. QualificationUserLastNotified))
, single ("valid-until" , SortColumn $ queryQualUser >>> (E.^. QualificationUserValidUntil)) , ("valid-until" , SortColumn $ queryQualUser >>> (E.^. QualificationUserValidUntil))
, single ("blocked" , SortColumnNeverNull $ queryQualBlock >>> (E.?. QualificationUserBlockFrom)) , ("blocked" , SortColumnNeverNull $ queryQualBlock >>> (E.?. QualificationUserBlockFrom))
, single ("lms-status-plus",SortColumnNullsInv $ \row -> E.coalesce [ E.joinV (queryLmsUser row E.?. LmsUserStatusDay) , ("lms-status-plus",SortColumnNullsInv $ \row -> E.coalesce [ E.joinV (queryLmsUser row E.?. LmsUserStatusDay)
, E.joinV (queryLmsUser row E.?. LmsUserNotified) , E.joinV (queryLmsUser row E.?. LmsUserNotified)
, queryLmsUser row E.?. LmsUserStarted]) , queryLmsUser row E.?. LmsUserStarted])
, single ("schedule-renew", SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserScheduleRenewal)) , ("schedule-renew", SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserScheduleRenewal))
, single ("user-company" , SortColumn $ \row -> E.subSelect $ E.from $ \(usrComp `E.InnerJoin` comp) -> do , ("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
E.orderBy [E.asc (comp E.^. CompanyName)] E.orderBy [E.asc (comp E.^. CompanyName)]
return (comp E.^. CompanyName) return (comp E.^. CompanyName)
) )
-- , single ("validity", SortColumn $ queryQualUser >>> validQualification now) -- , ("validity", SortColumn $ queryQualUser >>> validQualification now)
] ]
dbtFilter = mconcat dbtFilter = Map.fromList
[ single $ fltrUserNameEmail queryUser [ fltrUserNameEmail queryUser
, single ("avs-number" , FilterColumn . E.mkExistsFilter $ \row criterion -> , ("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
E.&&. ((E.val criterion :: E.SqlExpr (E.Value (CI Text))) E.==. E.&&. ((E.val criterion :: E.SqlExpr (E.Value (CI Text))) E.==.
(E.explicitUnsafeCoerceSqlExprValue "citext" (usrAvs E.^. UserAvsNoPerson) :: E.SqlExpr (E.Value (CI Text))) )) (E.explicitUnsafeCoerceSqlExprValue "citext" (usrAvs E.^. UserAvsNoPerson) :: E.SqlExpr (E.Value (CI Text))) ))
, fltrAVSCardNos queryUser , fltrAVSCardNos queryUser
, single ("personal-number", FilterColumn $ \(queryUser -> user) (criteria :: Set.Set Text) -> if , ("personal-number", FilterColumn $ \(queryUser -> user) (criteria :: Set.Set Text) -> if
| Set.null criteria -> E.true | Set.null criteria -> E.true
| otherwise -> E.any (\c -> user E.^. UserCompanyPersonalNumber `E.hasInfix` E.val c) criteria | otherwise -> E.any (\c -> user E.^. UserCompanyPersonalNumber `E.hasInfix` E.val c) criteria
) )
, single ("user-company", FilterColumn . E.mkExistsFilter $ \row criterion -> , ("user-company", FilterColumn . E.mkExistsFilter $ \row criterion ->
E.from $ \(usrComp `E.InnerJoin` comp) -> do E.from $ \(usrComp `E.InnerJoin` comp) -> do
let testname = (E.val criterion :: E.SqlExpr (E.Value (CI Text))) `E.isInfixOf` let testname = (E.val criterion :: E.SqlExpr (E.Value (CI Text))) `E.isInfixOf`
(E.explicitUnsafeCoerceSqlExprValue "citext" (comp E.^. CompanyName) :: E.SqlExpr (E.Value (CI Text))) (E.explicitUnsafeCoerceSqlExprValue "citext" (comp E.^. CompanyName) :: E.SqlExpr (E.Value (CI Text)))
@ -428,18 +424,18 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = 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.&&. testcrit E.where_ $ usrComp E.^. UserCompanyUser E.==. queryUser row E.^. UserId E.&&. testcrit
) )
, single ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) (validQualification now)) , ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) (validQualification now))
, single ("renewal-due" , FilterColumn $ \(queryQualUser -> quser) criterion -> , ("renewal-due" , FilterColumn $ \(queryQualUser -> quser) criterion ->
if | Just renewal <- mbRenewal if | Just renewal <- mbRenewal
, Just True <- getLast criterion -> quser E.^. QualificationUserValidUntil E.<=. E.val renewal , Just True <- getLast criterion -> quser E.^. QualificationUserValidUntil E.<=. E.val renewal
E.&&. quser E.^. QualificationUserValidUntil E.>=. E.val nowaday E.&&. quser E.^. QualificationUserValidUntil E.>=. E.val nowaday
| otherwise -> E.true | otherwise -> E.true
) )
, single ("tobe-notified", FilterColumn $ \row criterion -> , ("tobe-notified", FilterColumn $ \row criterion ->
if | Just True <- getLast criterion -> quserToNotify now (queryQualUser row) (queryQualBlock row) if | Just True <- getLast criterion -> quserToNotify now (queryQualUser row) (queryQualBlock row)
| otherwise -> E.true | otherwise -> E.true
) )
, single ("status" , FilterColumn . E.mkExactFilterMaybeLast' (views (to queryLmsUser) (E.?. LmsUserId)) $ views (to queryLmsUser) (E.?. LmsUserStatus)) , ("status" , FilterColumn . E.mkExactFilterMaybeLast' (views (to queryLmsUser) (E.?. LmsUserId)) $ views (to queryLmsUser) (E.?. LmsUserStatus))
] ]
dbtFilterUI mPrev = mconcat dbtFilterUI mPrev = mconcat
[ fltrUserNameEmailHdrUI MsgLmsUser mPrev [ fltrUserNameEmailHdrUI MsgLmsUser mPrev

6
src/Handler/Utils/Table/Columns.hs
View File

@ -8,7 +8,7 @@ module Handler.Utils.Table.Columns where
import Import hiding (link) import Import hiding (link)
import qualified Data.Map as Map -- import qualified Data.Map as Map
import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Legacy as E
import qualified Database.Esqueleto.Utils as E hiding ((->.)) import qualified Database.Esqueleto.Utils as E hiding ((->.))
@ -830,8 +830,8 @@ fltrCompanyNameNrHdrUI msg mPrev =
fltrAVSCardNos :: (IsFilterColumnHandler t ([Text] -> Handler (a -> E.SqlExpr (E.Value Bool))), IsString k) fltrAVSCardNos :: (IsFilterColumnHandler t ([Text] -> Handler (a -> E.SqlExpr (E.Value Bool))), IsString k)
=> (a -> E.SqlExpr (Entity User)) -> Map k (FilterColumn t fs) => (a -> E.SqlExpr (Entity User)) -> (k, FilterColumn t fs)
fltrAVSCardNos queryUser = Map.singleton "avs-card" fch fltrAVSCardNos queryUser = ("avs-card", fch)
where where
fch = FilterColumnHandler $ \case fch = FilterColumnHandler $ \case
[] -> return (const E.true) [] -> return (const E.true)