refactor(map): clarify some unnecessarily obfuscated code
also, using Map.fromList is more efficient if the list happens to be ordered
This commit is contained in:
parent
733324a732
commit
e9a4c838a8
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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|<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
|
||||
, 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
|
||||
|
||||
@ -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 ])
|
||||
]
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
)
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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
|
||||
@ -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)
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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)
|
||||
|
||||
Loading…
Reference in New Issue
Block a user