From e9a4c838a88a7f352a9909852879b0149ab751a3 Mon Sep 17 00:00:00 2001 From: Steffen Date: Wed, 11 Sep 2024 17:43:56 +0200 Subject: [PATCH] refactor(map): clarify some unnecessarily obfuscated code also, using Map.fromList is more efficient if the list happens to be ordered --- src/Handler/Admin.hs | 40 +++++------ src/Handler/Admin/Avs.hs | 52 +++++++------- src/Handler/CommCenter.hs | 17 ++--- src/Handler/Firm.hs | 111 +++++++++++++++-------------- src/Handler/LMS.hs | 68 +++++++++--------- src/Handler/LMS/Learners.hs | 20 +++--- src/Handler/LMS/Report.hs | 13 ++-- src/Handler/LMS/Users.hs | 26 +++---- src/Handler/MailCenter.hs | 22 +++--- src/Handler/PrintCenter.hs | 55 +++++++------- src/Handler/Qualification.hs | 50 ++++++------- src/Handler/Utils/Table/Columns.hs | 6 +- 12 files changed, 220 insertions(+), 260 deletions(-) diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index 1567da027..d19b90320 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -39,10 +39,6 @@ import Handler.Admin.Crontab as Handler.Admin import Handler.Admin.Avs 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 data ProblemTableAction = ProblemTableMarkSolved @@ -368,22 +364,22 @@ mkProblemLogTable = do , 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 ] - dbtSorting = mconcat - [ single ("time" , SortColumn $ queryProblem >>> (E.^. ProblemLogTime)) - , single ("info" , SortColumn $ queryProblem >>> (E.^. ProblemLogInfo)) - -- , single ("firm" , SortColumn ((E.->>. "company" ).(queryProblem >>> (E.^. ProblemLogInfo)))) - , single ("firm" , SortColumn $ \r -> queryProblem r E.^. ProblemLogInfo E.->>. "company") - , single ("user" , sortUserNameBareM queryUser) - , single ("solved", SortColumn $ queryProblem >>> (E.^. ProblemLogSolved)) - , single ("solver", sortUserNameBareM querySolver) + dbtSorting = Map.fromList + [ ("time" , SortColumn $ queryProblem >>> (E.^. ProblemLogTime)) + , ("info" , SortColumn $ queryProblem >>> (E.^. ProblemLogInfo)) + -- , ("firm" , SortColumn ((E.->>. "company" ).(queryProblem >>> (E.^. ProblemLogInfo)))) + , ("firm" , SortColumn $ \r -> queryProblem r E.^. ProblemLogInfo E.->>. "company") + , ("user" , sortUserNameBareM queryUser) + , ("solved", SortColumn $ queryProblem >>> (E.^. ProblemLogSolved)) + , ("solver", sortUserNameBareM querySolver) ] - dbtFilter = mconcat - [ single ("user" , FilterColumn . E.mkContainsFilterWithCommaPlus Just $ views (to queryUser) (E.?. UserDisplayName)) - , single ("solver" , FilterColumn . E.mkContainsFilterWithCommaPlus Just $ views (to querySolver) (E.?. UserDisplayName)) - , single ("company" , FilterColumn . E.mkContainsFilter $ views (to queryProblem) ((E.->>. "company").(E.^. ProblemLogInfo))) - , single ("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! - , single ("problem" , mkFilterProjectedPost $ \(getLast -> criterion) dbr -> -- falls es nicht schnell genug ist: in dbtProj den Anzeigetext nur einmal berechnen + dbtFilter = Map.fromList + [ ("user" , FilterColumn . E.mkContainsFilterWithCommaPlus Just $ views (to queryUser) (E.?. UserDisplayName)) + , ("solver" , FilterColumn . E.mkContainsFilterWithCommaPlus Just $ views (to querySolver) (E.?. UserDisplayName)) + , ("company" , FilterColumn . E.mkContainsFilter $ views (to queryProblem) ((E.->>. "company").(E.^. ProblemLogInfo))) + , ("solved" , FilterColumn . E.mkExactFilterLast $ views (to queryProblem) (E.isJust . (E.^. ProblemLogSolved))) + -- , ("problem" , FilterColumn . E.mkContainsFilter $ views (to queryProblem) ((E.->>. "problem").(E.^. ProblemLogInfo))) -- not stored in plaintext! + , ("problem" , mkFilterProjectedPost $ \(getLast -> criterion) dbr -> -- falls es nicht schnell genug ist: in dbtProj den Anzeigetext nur einmal berechnen ifNothingM criterion True $ \(crit::Text) -> do let problem = dbr ^. resultProblem . _entityVal . _problemLogAdminProblem protxt <- adminProblem2Text problem @@ -398,9 +394,9 @@ mkProblemLogTable = do , prismAForm (singletonFilter "solved" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgAdminProblemSolved) ] acts :: Map ProblemTableAction (AForm Handler ProblemTableActionData) - acts = mconcat - [ singletonMap ProblemTableMarkSolved $ pure ProblemTableMarkSolvedData - , singletonMap ProblemTableMarkUnsolved $ pure ProblemTableMarkUnsolvedData + acts = Map.fromList + [ (ProblemTableMarkSolved , pure ProblemTableMarkSolvedData) + , (ProblemTableMarkUnsolved , pure ProblemTableMarkUnsolvedData) ] dbtParams = DBParamsForm { dbParamsFormMethod = POST diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs index 038538e2a..2da4b2e76 100644 --- a/src/Handler/Admin/Avs.hs +++ b/src/Handler/Admin/Avs.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Sarah Vaupel ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-24 Sarah Vaupel ,Steffen Jost ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -38,10 +38,6 @@ import qualified Database.Esqueleto.Utils as E -- 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 e) = [whamlet|

Error:

#{tshow e}|] @@ -692,23 +688,23 @@ mkLicenceTable apidStatus rsChanged dbtIdent aLic apids = do ) $ \(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 ] - dbtSorting = mconcat - [ single $ sortUserNameLink queryUser - , single ("avspersonno" , SortColumn $ queryUserAvs >>> (E.^. UserAvsNoPerson)) - , single ("qualification" , SortColumn $ queryQualification >>> (E.?. QualificationShorthand)) - , single $ sortUserCompany queryUser - , single ("valid-until" , SortColumn $ queryQualUser >>> (E.?. QualificationUserValidUntil)) - , single ("last-refresh" , SortColumn $ queryQualUser >>> (E.?. QualificationUserLastRefresh)) - , single ("first-held" , SortColumn $ queryQualUser >>> (E.?. QualificationUserFirstHeld)) - , single ("blocked" , SortColumnNeverNull $ queryQualBlock >>> (E.?. QualificationUserBlockFrom)) - , single ("schedule-renew", SortColumnNullsInv $ queryQualUser >>> (E.?. QualificationUserScheduleRenewal)) - -- , single ("validity" , SortColumn $ queryQualUser >>> (E.?. QualificationUserValidUntil)) + dbtSorting = Map.fromList + [ sortUserNameLink queryUser + , ("avspersonno" , SortColumn $ queryUserAvs >>> (E.^. UserAvsNoPerson)) + , ("qualification" , SortColumn $ queryQualification >>> (E.?. QualificationShorthand)) + , sortUserCompany queryUser + , ("valid-until" , SortColumn $ queryQualUser >>> (E.?. QualificationUserValidUntil)) + , ("last-refresh" , SortColumn $ queryQualUser >>> (E.?. QualificationUserLastRefresh)) + , ("first-held" , SortColumn $ queryQualUser >>> (E.?. QualificationUserFirstHeld)) + , ("blocked" , SortColumnNeverNull $ queryQualBlock >>> (E.?. QualificationUserBlockFrom)) + , ("schedule-renew", SortColumnNullsInv $ queryQualUser >>> (E.?. QualificationUserScheduleRenewal)) + -- , ("validity" , SortColumn $ queryQualUser >>> (E.?. QualificationUserValidUntil)) ] - dbtFilter = mconcat - [ single $ fltrUserNameEmail queryUser - , single ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) (validQualification' now)) - , single ( "user-company", FilterColumn . E.mkExistsFilter $ \row criterion -> + dbtFilter = Map.fromList + [ fltrUserNameEmail queryUser + , ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) (validQualification' now)) + , ( "user-company", FilterColumn . E.mkExistsFilter $ \row criterion -> E.from $ \(usrComp `E.InnerJoin` comp) -> do 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))) @@ -1025,15 +1021,15 @@ getProblemAvsErrorR = do , sortable (Just "avs-last-error") (i18nCell MsgLastAvsSynchError) $ cellMaybe textCell . view (reserrUsrAvs . _entityVal . _userAvsLastSynchError) ] - dbtSorting = mconcat - [ single (sortUserNameLink qerryUser) - , single ("avs-nr" , SortColumn $ qerryUsrAvs >>> (E.^. UserAvsNoPerson)) - , single ("avs-last-synch", SortColumnNullsInv $ qerryUsrAvs >>> (E.^. UserAvsLastSynch)) - , single ("avs-last-error", SortColumn $ qerryUsrAvs >>> (E.^. UserAvsLastSynchError)) + dbtSorting = Map.fromList + [ (sortUserNameLink qerryUser) + , ("avs-nr" , SortColumn $ qerryUsrAvs >>> (E.^. UserAvsNoPerson)) + , ("avs-last-synch", SortColumnNullsInv $ qerryUsrAvs >>> (E.^. UserAvsLastSynch)) + , ("avs-last-error", SortColumn $ qerryUsrAvs >>> (E.^. UserAvsLastSynchError)) ] - dbtFilter = mconcat - [ single $ fltrUserNameEmail qerryUser - , single ("avs-last-error", FilterColumn $ E.mkContainsFilterWithCommaPlus Just $ views (to qerryUsrAvs) (E.^. UserAvsLastSynchError)) + dbtFilter = Map.fromList + [ fltrUserNameEmail qerryUser + , ("avs-last-error", FilterColumn $ E.mkContainsFilterWithCommaPlus Just $ views (to qerryUsrAvs) (E.^. UserAvsLastSynchError)) ] dbtFilterUI mPrev = mconcat [ fltrUserNameEmailHdrUI MsgLmsUser mPrev diff --git a/src/Handler/CommCenter.hs b/src/Handler/CommCenter.hs index 00c688647..3d9e560e8 100644 --- a/src/Handler/CommCenter.hs +++ b/src/Handler/CommCenter.hs @@ -25,11 +25,6 @@ import qualified Database.Esqueleto.PostgreSQL as E 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 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] ] ] - dbtFilter = mconcat - [ single ("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 - , single ("recipient" , FilterColumn . E.mkContainsFilterWithCommaPlus Just - $ \row -> E.coalesce [queryRecipientPrint row E.?. UserDisplayName, queryRecipientMail row E.?. UserDisplayName]) - , single ("subject" , FilterColumn . E.mkContainsFilterWithCommaPlus Just + dbtFilter = Map.fromList + [ ("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 + , ("recipient" , FilterColumn . E.mkContainsFilterWithCommaPlus Just + $ \row -> E.coalesce [queryRecipientPrint row E.?. UserDisplayName, queryRecipientMail row E.?. UserDisplayName]) + , ("subject" , FilterColumn . E.mkContainsFilterWithCommaPlus Just $ \row -> E.coalesce [E.str2text' $ queryPrint row E.?. PrintJobFilename ,E.str2text' $ queryMail row E.?. SentMailHeaders ]) ] diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index e059888e9..4acf5139e 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -39,10 +39,6 @@ import qualified Database.Esqueleto.Utils as E 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 = decrypt @@ -482,10 +478,10 @@ mkFirmAllTable isAdmin uid = do -- , singletonMap "reroute-act" $ SortColumn firmCountActiveReroutes -- , singletonMap "reroute-all" $ SortColumn firmCountActiveReroutes' ] - dbtFilter = mconcat - [ single $ fltrCompanyNameNr queryAllCompany - , single ("company-number", FilterColumn $ E.mkExactFilterWithComma readMay (queryAllCompany >>> (E.^. CompanyAvsId))) - , single ("is-associate" , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do + dbtFilter = Map.fromList + [ fltrCompanyNameNr queryAllCompany + , ("company-number", FilterColumn $ E.mkExactFilterWithComma readMay (queryAllCompany >>> (E.^. CompanyAvsId))) + , ("is-associate" , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do (usr :& usrCmp) <- E.from $ E.table @User `E.innerJoin` E.table @UserCompany `E.on` (\(usr :& usrCmp) -> usr E.^. UserId E.==. usrCmp E.^. UserCompanyUser) @@ -496,7 +492,7 @@ mkFirmAllTable isAdmin uid = do ) ) -- 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 -- `E.leftJoin` E.table @UserCompany -- `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 -- E.where_ $ ((usr E.^. UserDisplayName `E.hasInfix` E.val 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 -- E.where_ $ ((usr E.^. UserDisplayName `E.hasInfix` E.val 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 -- Nothing -> E.true -- (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 Nothing -> return True :: DB Bool (Just (crit::Text)) -> do @@ -601,7 +597,7 @@ mkFirmAllTable isAdmin uid = do let cid = dbr ^. resultAllCompanyEntity . _entityKey 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 -- `E.leftJoin` E.table @UserCompany -- `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 `E.innerJoin` E.table @UserCompany `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.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId ) - , single ("foreign-supervisor", FilterColumn $ \row (getLast -> criterion) -> + , ("foreign-supervisor", FilterColumn $ \row (getLast -> criterion) -> -- let checkSuper = do -- expensive -- usrSpr <- E.from $ E.table @UserSupervisor -- E.where_ $ E.notExists (do @@ -655,8 +651,8 @@ mkFirmAllTable isAdmin uid = do Just True -> E.exists checkSuper Just False -> E.notExists checkSuper ) - , single ("company-postal", FilterColumn $ E.mkExactFilterLast $ views (to queryAllCompany) (E.isJust . (E.^. CompanyPostAddress))) - , single ("qualification" , FilterColumn . E.mkExistsFilter $ \row (CI.mk -> criterion :: CI Text) -> do + , ("company-postal", FilterColumn $ E.mkExactFilterLast $ views (to queryAllCompany) (E.isJust . (E.^. CompanyPostAddress))) + , ("qualification" , FilterColumn . E.mkExistsFilter $ \row (CI.mk -> criterion :: CI Text) -> do (usrCmp :& usrQual :& qual) <- E.from $ E.table @UserCompany `E.innerJoin` E.table @QualificationUser `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.&&. 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 [ fltrCompanyNameUI mPrev @@ -863,20 +858,20 @@ mkFirmUserTable isAdmin cid = do in numCell prio <> spacerCell <> ifIconCell isPrime IconTop , sortable Nothing (i18nCell MsgTableUserEdit) $ \(view resultUserUser -> entUsr) -> cellEditUserModal entUsr ] - dbtSorting = mconcat - [ single $ sortUserNameLink queryUserUser - , single $ sortUserEmail queryUserUser - , singletonMap "postal-pref" $ SortColumn $ queryUserUser >>> (E.^. UserPrefersPostal) - , singletonMap "matriculation" $ SortColumn $ queryUserUser >>> (E.^. UserMatrikelnummer) - , singletonMap "personal-number" $ SortColumn $ queryUserUser >>> (E.^. UserCompanyPersonalNumber) - , singletonMap "supervisors" $ SortColumn $ queryUserUserCompany >>> firmCountUserSupervisors - , singletonMap "reroutes" $ SortColumn $ queryUserUserCompany >>> firmCountUserSupervisorsReroute - , singletonMap "usr-reason" $ SortColumn $ queryUserUserCompany >>> (E.^. UserCompanyReason) - , singletonMap "priority" $ SortColumn $ queryUserUserCompany >>> (E.^. UserCompanyPriority) + dbtSorting = Map.fromList + [ sortUserNameLink queryUserUser + , sortUserEmail queryUserUser + , ("postal-pref" , SortColumn $ queryUserUser >>> (E.^. UserPrefersPostal) ) + , ("matriculation" , SortColumn $ queryUserUser >>> (E.^. UserMatrikelnummer) ) + , ("personal-number" , SortColumn $ queryUserUser >>> (E.^. UserCompanyPersonalNumber)) + , ("supervisors" , SortColumn $ queryUserUserCompany >>> firmCountUserSupervisors ) + , ("reroutes" , SortColumn $ queryUserUserCompany >>> firmCountUserSupervisorsReroute ) + , ("usr-reason" , SortColumn $ queryUserUserCompany >>> (E.^. UserCompanyReason) ) + , ("priority" , SortColumn $ queryUserUserCompany >>> (E.^. UserCompanyPriority) ) ] - dbtFilter = mconcat - [ single $ fltrUserNameEmail queryUserUser - , singletonMap "has-supervisor" $ FilterColumn $ \row (getLast -> criterion) -> + dbtFilter = Map.fromList + [ fltrUserNameEmail queryUserUser + , ("has-supervisor", FilterColumn $ \row (getLast -> criterion) -> let checkSuper = do usrSpr <- E.from $ E.table @UserSupervisor E.where_ $ usrSpr E.^. UserSupervisorUser E.==. queryUserUser row E.^. UserId @@ -884,7 +879,8 @@ mkFirmUserTable isAdmin cid = do Nothing -> E.true Just True -> E.exists checkSuper Just False -> E.notExists checkSuper - , singletonMap "has-company-supervisor" $ FilterColumn $ \row (getLast -> criterion) -> + ) + , ("has-company-supervisor", FilterColumn $ \row (getLast -> criterion) -> let checkSuper = do usrSpr <- E.from $ E.table @UserSupervisor E.where_ $ usrSpr E.^. UserSupervisorUser E.==. queryUserUser row E.^. UserId @@ -897,7 +893,8 @@ mkFirmUserTable isAdmin cid = do Nothing -> E.true Just True -> E.exists checkSuper Just False -> E.notExists checkSuper - , singletonMap "has-foreign-supervisor" $ FilterColumn $ \row (getLast -> criterion) -> + ) + , ("has-foreign-supervisor", FilterColumn $ \row (getLast -> criterion) -> let checkSuper = do usrSpr <- E.from $ E.table @UserSupervisor E.where_ $ usrSpr E.^. UserSupervisorUser E.==. queryUserUser row E.^. UserId @@ -910,7 +907,8 @@ mkFirmUserTable isAdmin cid = do Nothing -> E.true Just True -> E.exists checkSuper Just False -> E.notExists checkSuper - , singletonMap "supervisor-is" $ FilterColumn $ \row (getLast -> criterion) -> + ) + , ("supervisor-is", FilterColumn $ \row (getLast -> criterion) -> case criterion of Just uid -> do -- uid <- decryptUser uuid @@ -919,7 +917,8 @@ mkFirmUserTable isAdmin cid = do E.where_ $ usrSpr E.^. UserSupervisorUser E.==. queryUserUser row E.^. UserId E.&&. usrSpr E.^. UserSupervisorSupervisor E.==. E.val uid _otherwise -> E.true - , singletonMap "supervisors-are" $ FilterColumn $ \row criteria -> + ) + , ("supervisors-are", FilterColumn $ \row criteria -> case criteria of _ | Set.null criteria -> E.true | otherwise -> do @@ -928,7 +927,8 @@ mkFirmUserTable isAdmin cid = do usrSpr <- E.from $ E.table @UserSupervisor E.where_ $ usrSpr E.^. UserSupervisorUser E.==. queryUserUser row E.^. UserId 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 other <- E.from $ E.table @UserCompany E.where_ $ other E.^. UserCompanyUser E.==. queryUserUserCompany row E.^. UserCompanyUser @@ -937,6 +937,7 @@ mkFirmUserTable isAdmin cid = do Nothing -> E.true Just False -> E.exists checkPrimary Just True -> E.notExists checkPrimary + ) ] -- superField = selectField $ ???? 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 Nothing (i18nCell MsgTableUserEdit) $ \(view resultSuperUser -> entUsr) -> cellEditUserModal entUsr ] - dbtSorting = mconcat - [ single $ sortUserNameLink querySuperUser - , single $ sortUserEmail querySuperUser - , singletonMap "matriculation" $ SortColumn $ querySuperUser >>> (E.^. UserMatrikelnummer) - , singletonMap "personal-number" $ SortColumn $ querySuperUser >>> (E.^. UserCompanyPersonalNumber) - , singletonMap "postal-pref" $ SortColumn $ querySuperUser >>> (E.^. UserPrefersPostal) - , singletonMap "supervised" $ SortColumn $ querySuperUser >>> firmCountForSupervisor cid Nothing - , singletonMap "rerouted" $ SortColumn $ querySuperUser >>> firmCountForSupervisor cid (Just (E.^. UserSupervisorRerouteNotifications)) - , singletonMap "user-company" $ SortColumn (\row -> E.subSelect $ do + dbtSorting = Map.fromList + [ sortUserNameLink querySuperUser + , sortUserEmail querySuperUser + , ("matriculation" , SortColumn $ querySuperUser >>> (E.^. UserMatrikelnummer)) + , ("personal-number" , SortColumn $ querySuperUser >>> (E.^. UserCompanyPersonalNumber)) + , ("postal-pref" , SortColumn $ querySuperUser >>> (E.^. UserPrefersPostal)) + , ("supervised" , SortColumn $ querySuperUser >>> firmCountForSupervisor cid Nothing) + , ("rerouted" , SortColumn $ querySuperUser >>> firmCountForSupervisor cid (Just (E.^. UserSupervisorRerouteNotifications))) + , ("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) E.where_ $ usrCmp E.^. UserCompanyUser E.==. querySuperUser row E.^. UserId E.orderBy [E.asc $ cmp E.^. CompanyName] return (cmp E.^. CompanyName) - ) - , singletonMap "def-super" $ SortColumn $ querySuperUserCompany >>> (E.?. UserCompanySupervisor) - , singletonMap "def-reroute" $ SortColumn $ querySuperUserCompany >>> (E.?. UserCompanySupervisorReroute) + )) + , ("def-super" , SortColumn $ querySuperUserCompany >>> (E.?. UserCompanySupervisor)) + , ("def-reroute" , SortColumn $ querySuperUserCompany >>> (E.?. UserCompanySupervisorReroute)) ] - dbtFilter = mconcat - [ single $ fltrUserNameEmail querySuperUser - , singletonMap "is-foreign-supervisor" $ FilterColumn $ \(querySuperUserCompany -> suc) (getLast -> criterion) -> + dbtFilter = Map.fromList + [ fltrUserNameEmail querySuperUser + , ("is-foreign-supervisor", FilterColumn $ \(querySuperUserCompany -> suc) (getLast -> criterion) -> case criterion of Nothing -> E.true Just True -> E.isNothing $ 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 usrSpr <- E.from $ E.table @UserSupervisor E.where_ $ usrSpr E.^. UserSupervisorSupervisor E.==. querySuperUser row E.^. UserId @@ -1288,6 +1290,7 @@ mkFirmSuperTable isAdmin cid = do Nothing -> E.true Just True -> E.exists checkSuper Just False -> E.notExists checkSuper + ) ] dbtFilterUI mPrev = mconcat [ fltrUserNameEmailHdrUI MsgTableSupervisor mPrev diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index ab0fa1964..13f782661 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -50,10 +50,6 @@ import Handler.LMS.Report as Handler.LMS 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 data ButtonManualLms = BtnLmsEnqueue | BtnLmsDequeue 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) dbtProj = dbtProjId dbtColonnade = cols getCompanyName - dbtSorting = mconcat - [ single $ sortUserNameLink queryUser - , single $ sortUserEmail queryUser - , single $ sortUserMatriclenr queryUser - , single ("valid-until" , SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserValidUntil)) - -- , single ("validity" , SortColumn $ queryQualUser >>> validQualification nowaday) - , single ("last-refresh" , SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserLastRefresh)) - , single ("first-held" , SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserFirstHeld)) - , single ("blocked" , SortColumnNeverNull$ queryQualBlock >>> (E.?. QualificationUserBlockFrom)) - , single ("schedule-renew", SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserScheduleRenewal)) - , single ("ident" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserIdent)) - , single ("pin" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserPin)) - -- , single ("status" , SortColumnNullsInv $ views (to queryLmsUser) (E.^. LmsUserStatusDay)) - , single ("status" , SortColumnNeverNull $ \row -> E.coalesceDefault [ queryLmsUser row E.^. LmsUserStatusDay + dbtSorting = Map.fromList + [ sortUserNameLink queryUser + , sortUserEmail queryUser + , sortUserMatriclenr queryUser + , ("valid-until" , SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserValidUntil)) + -- , ("validity" , SortColumn $ queryQualUser >>> validQualification nowaday) + , ("last-refresh" , SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserLastRefresh)) + , ("first-held" , SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserFirstHeld)) + , ("blocked" , SortColumnNeverNull$ queryQualBlock >>> (E.?. QualificationUserBlockFrom)) + , ("schedule-renew", SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserScheduleRenewal)) + , ("ident" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserIdent)) + , ("pin" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserPin)) + -- , ("status" , SortColumnNullsInv $ views (to queryLmsUser) (E.^. LmsUserStatusDay)) + , ("status" , SortColumnNeverNull $ \row -> E.coalesceDefault [ queryLmsUser row E.^. LmsUserStatusDay , queryLmsUser row E.^. LmsUserNotified ](queryLmsUser row E.^. LmsUserStarted)) - , single ("started" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserStarted)) - , single ("datepin" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserDatePin)) - , single ("received" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserReceived)) - , single ("notified" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserNotified)) -- cannot include printJob acknowledge date - , single ("ended" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserEnded)) - , single ("user-company", SortColumn $ \row -> E.subSelect $ E.from $ \(usrComp `E.InnerJoin` comp) -> do + , ("started" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserStarted)) + , ("datepin" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserDatePin)) + , ("received" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserReceived)) + , ("notified" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserNotified)) -- cannot include printJob acknowledge date + , ("ended" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserEnded)) + , ("user-company", SortColumn $ \row -> E.subSelect $ E.from $ \(usrComp `E.InnerJoin` comp) -> do E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId E.where_ $ usrComp E.^. UserCompanyUser E.==. queryUser row E.^. UserId E.orderBy [E.asc (comp E.^. CompanyName)] return (comp E.^. CompanyName) - ) + ) ] - dbtFilter = mconcat - [ single $ fltrUserNameEmail queryUser - , single ("ident" , FilterColumn . E.mkContainsFilterWithCommaPlus LmsIdent $ views (to queryLmsUser) (E.^. LmsUserIdent)) - , single ("status" , FilterColumn . E.mkExactFilterMaybeLast $ views (to queryLmsUser) (E.^. LmsUserStatus)) - -- , single ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) ((E.>=. E.val nowaday) . (E.^. QualificationUserValidUntil))) - , single ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) (validQualification now)) - -- , single ("renewal-due" , FilterColumn $ \(queryQualUser -> quser) criterion -> + dbtFilter = Map.fromList + [ fltrUserNameEmail queryUser + , ("ident" , FilterColumn . E.mkContainsFilterWithCommaPlus LmsIdent $ views (to queryLmsUser) (E.^. LmsUserIdent)) + , ("status" , FilterColumn . E.mkExactFilterMaybeLast $ views (to queryLmsUser) (E.^. LmsUserStatus)) + -- , ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) ((E.>=. E.val nowaday) . (E.^. QualificationUserValidUntil))) + , ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) (validQualification now)) + -- , ("renewal-due" , FilterColumn $ \(queryQualUser -> quser) criterion -> -- if | Just renewal <- mbRenewal -- , Just True <- getLast criterion -> quser E.^. QualificationUserValidUntil E.<=. E.val renewal -- E.&&. quser E.^. QualificationUserValidUntil E.>=. E.val nowaday -- | otherwise -> E.true -- ) - , single ("notified", FilterColumn . E.mkExactFilterLast $ views (to queryLmsUser) (E.isJust . (E.^. LmsUserNotified))) - , single ("avs-number" , FilterColumn . E.mkExistsFilter $ \row criterion -> + , ("notified", FilterColumn . E.mkExactFilterLast $ views (to queryLmsUser) (E.isJust . (E.^. LmsUserNotified))) + , ("avs-number" , FilterColumn . E.mkExistsFilter $ \row criterion -> E.from $ \usrAvs -> -- do E.where_ $ usrAvs E.^. UserAvsUser E.==. queryUser row E.^. UserId E.&&. ((E.val criterion :: E.SqlExpr (E.Value (CI Text))) E.==. (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 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))) @@ -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 ) , 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 | otherwise -> E.any (\c -> user E.^. UserCompanyPersonalNumber `E.hasInfix` E.val c) criteria ) diff --git a/src/Handler/LMS/Learners.hs b/src/Handler/LMS/Learners.hs index 144d8f9bb..239b5d061 100644 --- a/src/Handler/LMS/Learners.hs +++ b/src/Handler/LMS/Learners.hs @@ -76,19 +76,15 @@ instance FromNamedRecord LmsUserTableCsv where <*> csv Csv..: csvLmsLock instance CsvColumnsExplained LmsUserTableCsv where - csvColumnsExplanations _ = mconcat - [ single csvLmsIdent MsgCsvColumnLmsIdent - , single csvLmsPin MsgCsvColumnLmsPin - , single csvLmsResetPin MsgCsvColumnLmsResetPin - , single csvLmsDelete MsgCsvColumnLmsDelete - , single csvLmsStaff MsgCsvColumnLmsStaff - , single csvLmsResetTries MsgCsvColumnLmsResetTries - , single csvLmsLock MsgCsvColumnLmsLock + csvColumnsExplanations _ = Map.fromList + [ (csvLmsIdent , msg2widget MsgCsvColumnLmsIdent) + , (csvLmsPin , msg2widget MsgCsvColumnLmsPin) + , (csvLmsResetPin , msg2widget MsgCsvColumnLmsResetPin) + , (csvLmsDelete , msg2widget MsgCsvColumnLmsDelete) + , (csvLmsStaff , msg2widget MsgCsvColumnLmsStaff) + , (csvLmsResetTries , msg2widget MsgCsvColumnLmsResetTries) + , (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) diff --git a/src/Handler/LMS/Report.hs b/src/Handler/LMS/Report.hs index c360c3eb9..66d846232 100644 --- a/src/Handler/LMS/Report.hs +++ b/src/Handler/LMS/Report.hs @@ -64,15 +64,12 @@ instance FromNamedRecord LmsReportTableCsv where <*> csv Csv..: csvLmsLock instance CsvColumnsExplained LmsReportTableCsv where - csvColumnsExplanations _ = mconcat - [ single csvLmsIdent MsgCsvColumnLmsIdent - , single csvLmsDate MsgCsvColumnLmsDate - , single csvLmsResult MsgCsvColumnLmsResult - , single csvLmsLock MsgCsvColumnLmsLock + csvColumnsExplanations _ = Map.fromList + [ (csvLmsIdent , msg2widget MsgCsvColumnLmsIdent) + , (csvLmsDate , msg2widget MsgCsvColumnLmsDate) + , (csvLmsResult , msg2widget MsgCsvColumnLmsResult) + , (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 deriving (Eq, Ord, Read, Show, Generic, Enum, Bounded) diff --git a/src/Handler/LMS/Users.hs b/src/Handler/LMS/Users.hs index b5f534b5a..e4b2eb990 100644 --- a/src/Handler/LMS/Users.hs +++ b/src/Handler/LMS/Users.hs @@ -68,23 +68,19 @@ instance FromNamedRecord LmsUserTableCsv where <*> csv Csv..: csvLmsStaff instance CsvColumnsExplained LmsUserTableCsv where - csvColumnsExplanations _ = mconcat - [ single csvLmsIdent MsgCsvColumnLmsIdent - , single csvLmsPin MsgCsvColumnLmsPin - , single csvLmsResetPin MsgCsvColumnLmsResetPin - , single csvLmsDelete MsgCsvColumnLmsDelete - , single csvLmsStaff MsgCsvColumnLmsStaff + csvColumnsExplanations _ = Map.fromList + [ (csvLmsIdent , msg2widget MsgCsvColumnLmsIdent) + , (csvLmsPin , msg2widget MsgCsvColumnLmsPin) + , (csvLmsResetPin , msg2widget MsgCsvColumnLmsResetPin) + , (csvLmsDelete , msg2widget MsgCsvColumnLmsDelete) + , (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 _sid qsh qid = do cutoff <- liftHandler $ lmsDeletionDate Nothing - dbtCsvName <- csvFilenameLmsUser qsh + dbtCsvName <- csvFilenameLmsUser qsh let dbtCsvSheetName = dbtCsvName let userDBTable = DBTable{..} @@ -160,7 +156,7 @@ getLmsUsersDirectR sid qsh = do selectList [ LmsUserQualification ==. qid , LmsUserEnded ==. Nothing -- , 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 Ex.select $ do @@ -175,7 +171,7 @@ getLmsUsersDirectR sid qsh = do , csvLUTstaff = LmsBool False } -} - LmsConf{..} <- getsYesod $ view _appLmsConf + LmsConf{..} <- getsYesod $ view _appLmsConf let --csvRenderedData = toNamedRecord . lmsUser2csv . entityVal <$> lms_users --csvRenderedHeader = lmsUserTableCsvHeader --cvsRendered = CsvRendered {..} @@ -188,10 +184,10 @@ getLmsUsersDirectR sid qsh = do csvOpts = def { csvFormat = fmtOpts } csvSheetName <- csvFilenameLmsUser qsh 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 addHeader "Content-Disposition" $ "attachment; filename=\"" <> csvSheetName <> "\"" - csvRenderedToTypedContentWith csvOpts csvSheetName csvRendered + csvRenderedToTypedContentWith csvOpts csvSheetName csvRendered -- direct Download see: -- https://ersocon.net/blog/2017/2/22/creating-csv-files-in-yesod \ No newline at end of file diff --git a/src/Handler/MailCenter.hs b/src/Handler/MailCenter.hs index f84cf4ec7..26ad06075 100644 --- a/src/Handler/MailCenter.hs +++ b/src/Handler/MailCenter.hs @@ -41,12 +41,6 @@ import qualified Data.ByteString.Lazy as LB 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 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 MsgCommSubject) $ \(preview $ resultMail . _entityVal . _sentMailHeaders . _mailHeaders' . _mailHeader' "Subject" -> h) -> cellMaybe textCell h ] - dbtSorting = mconcat - [ single ("sent" , SortColumn $ queryMail >>> (E.^. SentMailSentAt)) - , single ("recipient" , sortUserNameBareM queryRecipient) + dbtSorting = Map.fromList + [ ("sent" , SortColumn $ queryMail >>> (E.^. SentMailSentAt)) + , ("recipient" , sortUserNameBareM queryRecipient) ] - dbtFilter = mconcat - [ single ("sent" , FilterColumn . E.mkDayFilterTo $ views (to queryMail) (E.^. SentMailSentAt)) - , single ("recipient" , FilterColumn . E.mkContainsFilterWithCommaPlus Just $ views (to queryRecipient) (E.?. UserDisplayName)) - , single ("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))) + dbtFilter = Map.fromList + [ ("sent" , FilterColumn . E.mkDayFilterTo $ views (to queryMail) (E.^. SentMailSentAt)) + , ("recipient" , FilterColumn . E.mkContainsFilterWithCommaPlus Just $ views (to queryRecipient) (E.?. UserDisplayName)) + , ("subject" , FilterColumn . E.mkContainsFilterWithCommaPlus id $ views (to queryMail) (E.str2text . (E.^. SentMailHeaders))) + -- , ("regex" , FilterColumn . E.mkRegExFilterWith id $ views (to queryMail) (E.str2text . (E.^. SentMailHeaders))) ] dbtFilterUI mPrev = mconcat [ prismAForm (singletonFilter "sent" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift dayField) (fslI MsgPrintJobCreated) diff --git a/src/Handler/PrintCenter.hs b/src/Handler/PrintCenter.hs index 43af0bff9..1bacb9a47 100644 --- a/src/Handler/PrintCenter.hs +++ b/src/Handler/PrintCenter.hs @@ -39,11 +39,6 @@ import qualified Data.CaseInsensitive as CI import Jobs.Queue --- avoids repetition of local definitions -single :: (k,a) -> Map k a -single = uncurry Map.singleton - - data LRQF = LRQF { lrqfLetter :: Text , lrqfUser :: Either UserEmail UserId @@ -224,33 +219,33 @@ mkPJTable = do , 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 ] - dbtSorting = mconcat - [ single ("name" , SortColumn $ queryPrintJob >>> (E.^. PrintJobName)) - , single ("filename" , SortColumn $ queryPrintJob >>> (E.^. PrintJobFilename)) - , single ("created" , SortColumn $ queryPrintJob >>> (E.^. PrintJobCreated)) - , single ("acknowledged" , SortColumn $ queryPrintJob >>> (E.^. PrintJobAcknowledged)) - , single ("apcid" , SortColumn $ queryPrintJob >>> (E.^. PrintJobApcIdent)) - , single ("recipient" , sortUserNameBareM queryRecipient) - , single ("affected" , sortUserNameBareM queryAffected) - , single ("sender" , sortUserNameBareM querySender ) - , single ("course" , SortColumn $ queryCourse >>> (E.?. CourseName)) - , single ("qualification", SortColumn $ queryQualification >>> (E.?. QualificationName)) - , single ("lmsid" , SortColumn $ queryPrintJob >>> (E.^. PrintJobLmsUser)) + dbtSorting = Map.fromList + [ ("name" , SortColumn $ queryPrintJob >>> (E.^. PrintJobName)) + , ("filename" , SortColumn $ queryPrintJob >>> (E.^. PrintJobFilename)) + , ("created" , SortColumn $ queryPrintJob >>> (E.^. PrintJobCreated)) + , ("acknowledged" , SortColumn $ queryPrintJob >>> (E.^. PrintJobAcknowledged)) + , ("apcid" , SortColumn $ queryPrintJob >>> (E.^. PrintJobApcIdent)) + , ("recipient" , sortUserNameBareM queryRecipient) + , ("affected" , sortUserNameBareM queryAffected ) + , ("sender" , sortUserNameBareM querySender ) + , ("course" , SortColumn $ queryCourse >>> (E.?. CourseName)) + , ("qualification", SortColumn $ queryQualification >>> (E.?. QualificationName)) + , ("lmsid" , SortColumn $ queryPrintJob >>> (E.^. PrintJobLmsUser)) ] - dbtFilter = mconcat - [ single ("name" , FilterColumn . E.mkContainsFilterWithCommaPlus id $ views (to queryPrintJob) (E.^. PrintJobName)) - , single ("apcid" , FilterColumn . E.mkContainsFilterWithComma id $ views (to queryPrintJob) (E.^. PrintJobApcIdent)) - , single ("filename" , FilterColumn . E.mkContainsFilter $ views (to queryPrintJob) (E.^. PrintJobFilename)) - , single ("created" , FilterColumn . E.mkDayFilter $ views (to queryPrintJob) (E.^. PrintJobCreated)) - --, single ("created" , FilterColumn . E.mkDayBetweenFilter $ views (to queryPrintJob) (E.^. PrintJobCreated)) - , single ("recipient" , FilterColumn . E.mkContainsFilterWithCommaPlus Just $ views (to queryRecipient) (E.?. UserDisplayName)) - , single ("affected" , FilterColumn . E.mkContainsFilterWithCommaPlus Just $ views (to queryAffected) (E.?. UserDisplayName)) - , single ("sender" , FilterColumn . E.mkContainsFilterWithCommaPlus Just $ views (to querySender) (E.?. UserDisplayName)) - , single ("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)) - , single ("lmsid" , FilterColumn . E.mkContainsFilterWithCommaPlus (Just . LmsIdent) $ views (to queryPrintJob) (E.^. PrintJobLmsUser)) + dbtFilter = Map.fromList + [ ("name" , FilterColumn . E.mkContainsFilterWithCommaPlus id $ views (to queryPrintJob) (E.^. PrintJobName)) + , ("apcid" , FilterColumn . E.mkContainsFilterWithComma id $ views (to queryPrintJob) (E.^. PrintJobApcIdent)) + , ("filename" , FilterColumn . E.mkContainsFilter $ views (to queryPrintJob) (E.^. PrintJobFilename)) + , ("created" , FilterColumn . E.mkDayFilter $ views (to queryPrintJob) (E.^. PrintJobCreated)) + --, ("created" , FilterColumn . E.mkDayBetweenFilter $ views (to queryPrintJob) (E.^. PrintJobCreated)) + , ("recipient" , FilterColumn . E.mkContainsFilterWithCommaPlus Just $ views (to queryRecipient) (E.?. UserDisplayName)) + , ("affected" , FilterColumn . E.mkContainsFilterWithCommaPlus Just $ views (to queryAffected) (E.?. UserDisplayName)) + , ("sender" , FilterColumn . E.mkContainsFilterWithCommaPlus Just $ views (to querySender) (E.?. UserDisplayName)) + , ("course" , FilterColumn . E.mkContainsFilterWith (Just . CI.mk) $ views (to queryCourse) (E.?. CourseName)) + , ("qualification", FilterColumn . E.mkContainsFilterWith (Just . CI.mk) $ views (to queryQualification) (E.?. QualificationName)) + , ("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 [ prismAForm (singletonFilter "name" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintJobName & setTooltip MsgTableFilterCommaPlus) diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs index e2934401d..6eee590d3 100644 --- a/src/Handler/Qualification.hs +++ b/src/Handler/Qualification.hs @@ -36,10 +36,6 @@ import Database.Esqueleto.Utils.TH -- 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 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) dbtProj = dbtProjId dbtColonnade = cols getCompanyName - dbtSorting = mconcat - [ single $ sortUserNameLink queryUser - , single $ sortUserEmail queryUser - , single $ sortUserMatriclenr queryUser - , single ("first-held" , SortColumn $ queryQualUser >>> (E.^. QualificationUserFirstHeld)) - , single ("last-refresh" , SortColumn $ queryQualUser >>> (E.^. QualificationUserLastRefresh)) - , single ("last-notified" , SortColumn $ queryQualUser >>> (E.^. QualificationUserLastNotified)) - , single ("valid-until" , SortColumn $ queryQualUser >>> (E.^. QualificationUserValidUntil)) - , single ("blocked" , SortColumnNeverNull $ queryQualBlock >>> (E.?. QualificationUserBlockFrom)) - , single ("lms-status-plus",SortColumnNullsInv $ \row -> E.coalesce [ E.joinV (queryLmsUser row E.?. LmsUserStatusDay) + dbtSorting = Map.fromList + [ sortUserNameLink queryUser + , sortUserEmail queryUser + , sortUserMatriclenr queryUser + , ("first-held" , SortColumn $ queryQualUser >>> (E.^. QualificationUserFirstHeld)) + , ("last-refresh" , SortColumn $ queryQualUser >>> (E.^. QualificationUserLastRefresh)) + , ("last-notified" , SortColumn $ queryQualUser >>> (E.^. QualificationUserLastNotified)) + , ("valid-until" , SortColumn $ queryQualUser >>> (E.^. QualificationUserValidUntil)) + , ("blocked" , SortColumnNeverNull $ queryQualBlock >>> (E.?. QualificationUserBlockFrom)) + , ("lms-status-plus",SortColumnNullsInv $ \row -> E.coalesce [ E.joinV (queryLmsUser row E.?. LmsUserStatusDay) , E.joinV (queryLmsUser row E.?. LmsUserNotified) , queryLmsUser row E.?. LmsUserStarted]) - , single ("schedule-renew", SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserScheduleRenewal)) - , single ("user-company" , SortColumn $ \row -> E.subSelect $ E.from $ \(usrComp `E.InnerJoin` comp) -> do + , ("schedule-renew", SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserScheduleRenewal)) + , ("user-company" , SortColumn $ \row -> E.subSelect $ E.from $ \(usrComp `E.InnerJoin` comp) -> do E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId E.where_ $ usrComp E.^. UserCompanyUser E.==. queryUser row E.^. UserId E.orderBy [E.asc (comp E.^. CompanyName)] return (comp E.^. CompanyName) - ) - -- , single ("validity", SortColumn $ queryQualUser >>> validQualification now) + ) + -- , ("validity", SortColumn $ queryQualUser >>> validQualification now) ] - dbtFilter = mconcat - [ single $ fltrUserNameEmail queryUser - , single ("avs-number" , FilterColumn . E.mkExistsFilter $ \row criterion -> + dbtFilter = Map.fromList + [ fltrUserNameEmail queryUser + , ("avs-number" , FilterColumn . E.mkExistsFilter $ \row criterion -> E.from $ \usrAvs -> -- do E.where_ $ usrAvs E.^. UserAvsUser E.==. queryUser row E.^. UserId E.&&. ((E.val criterion :: E.SqlExpr (E.Value (CI Text))) E.==. (E.explicitUnsafeCoerceSqlExprValue "citext" (usrAvs E.^. UserAvsNoPerson) :: E.SqlExpr (E.Value (CI Text))) )) , 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 | 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 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))) @@ -428,18 +424,18 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId E.where_ $ usrComp E.^. UserCompanyUser E.==. queryUser row E.^. UserId E.&&. testcrit ) - , single ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) (validQualification now)) - , single ("renewal-due" , FilterColumn $ \(queryQualUser -> quser) criterion -> + , ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) (validQualification now)) + , ("renewal-due" , FilterColumn $ \(queryQualUser -> quser) criterion -> if | Just renewal <- mbRenewal , Just True <- getLast criterion -> quser E.^. QualificationUserValidUntil E.<=. E.val renewal E.&&. quser E.^. QualificationUserValidUntil E.>=. E.val nowaday | 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) | 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 [ fltrUserNameEmailHdrUI MsgLmsUser mPrev diff --git a/src/Handler/Utils/Table/Columns.hs b/src/Handler/Utils/Table/Columns.hs index a2feb123e..a8c342a1c 100644 --- a/src/Handler/Utils/Table/Columns.hs +++ b/src/Handler/Utils/Table/Columns.hs @@ -8,7 +8,7 @@ module Handler.Utils.Table.Columns where 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.Utils as E hiding ((->.)) @@ -830,8 +830,8 @@ fltrCompanyNameNrHdrUI msg mPrev = fltrAVSCardNos :: (IsFilterColumnHandler t ([Text] -> Handler (a -> E.SqlExpr (E.Value Bool))), IsString k) - => (a -> E.SqlExpr (Entity User)) -> Map k (FilterColumn t fs) -fltrAVSCardNos queryUser = Map.singleton "avs-card" fch + => (a -> E.SqlExpr (Entity User)) -> (k, FilterColumn t fs) +fltrAVSCardNos queryUser = ("avs-card", fch) where fch = FilterColumnHandler $ \case [] -> return (const E.true)