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

Merge branch 'fradrive/company' into test

Browse Source
This commit is contained in:
Steffen Jost 2023-10-24 16:15:32 +00:00
commit 45048ce62d
18 changed files with 316 additions and 173 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
messages/uniworx/categories/firm/de-de-formal.msg Normal file
View File

@ -0,0 +1,7 @@
# SPDX-FileCopyrightText: 2023 Steffen Jost <s.jost@fraport.de>
#
# SPDX-License-Identifier: AGPL-3.0-or-later
FirmAllActNotify: Mitteilung versenden
FirmAllActResetSupervision: Ansprechpartner für alle Firmenangehörigen zurücksetzen

6
messages/uniworx/categories/firm/en-eu.msg Normal file
View File

@ -0,0 +1,6 @@
# SPDX-FileCopyrightText: 2023 Steffen Jost <s.jost@fraport.de>
#
# SPDX-License-Identifier: AGPL-3.0-or-later
FirmAllActNotify: Send message
FirmAllActResetSupervision: Reset supervisors for all company associates

1
messages/uniworx/categories/user/de-de-formal.msg
View File

@ -94,6 +94,7 @@ UserHijack: Sitzung übernehmen
UserAddSupervisor: Ansprechpartner hinzufügen
UserSetSupervisor: Ansprechpartner ersetzen
UserRemoveSupervisor: Alle Ansprechpartner entfernen
UserIsSupervisor: Ist Ansprechpartner
AuthKindLDAP: Fraport AG Kennung
AuthKindPWHash: FRADrive Kennung
AuthKindNoLogin: Kein Login möglich

1
messages/uniworx/categories/user/en-eu.msg
View File

@ -94,6 +94,7 @@ UserHijack: Hijack session
UserAddSupervisor: Add supervisor
UserSetSupervisor: Replace supervisors
UserRemoveSupervisor: Set to unsupervised
UserIsSupervisor: Is supervisor
AuthKindLDAP: Fraport AG account
AuthKindPWHash: FRADrive account
AuthKindNoLogin: No login

5
messages/uniworx/utils/table_column/de-de-formal.msg
View File

@ -16,7 +16,7 @@ TableTerm !ident-ok: Jahr
TableCourseSchool: Bereich
TableSubmissionGroup: Feste Abgabegruppe
TableNoSubmissionGroup: Keine feste Abgabegruppe
TableMatrikelNr: AVS Nr
TableMatrikelNr: AVS Personennummer
TableSex: Geschlecht
TableBirthday: Geburtsdatum
TableSchool: Bereich
@ -75,12 +75,15 @@ TableExamOfficeLabelStatus: Label-Farbe
TableExamOfficeLabelPriority: Label-Priorität
TableQualifications: Qualifikationen
TableCompany: Firma
TableCompanyFilter: Firma oder Nummer
TableCompanyShort: Firmenkürzel
TableCompanies: Firmen
TableCompanyNo: Firmennummer
TableCompanyNos: Firmennummern
TableCompanyNrUsers: Firmenangehörige
TableCompanyNrSupers: Ansprechpartner
TableCompanyNrSupersActive: Mitarbeiter mit Ansprechpartner
TableCompanyNrSupersDefault: Standard Ansprechpartner
TableCompanyNrForeignSupers: Firmenfremde Ansprechpartner
TableCompanyNrRerouteDefault: Standard Umleitungen
TableCompanyNrRerouteActive: Aktive Umleitungen

5
messages/uniworx/utils/table_column/en-eu.msg
View File

@ -16,7 +16,7 @@ TableTerm: Year
TableCourseSchool: Department
TableSubmissionGroup: Registered submission group
TableNoSubmissionGroup: No registered submission group
TableMatrikelNr: AVS No
TableMatrikelNr: AVS person no
TableSex: Sex
TableBirthday: Birthday
TableSchool: Department
@ -75,12 +75,15 @@ TableExamOfficeLabelStatus: Label colour
TableExamOfficeLabelPriority: Label priority
TableQualifications: Qualifications
TableCompany: Company
TableCompanyFilter: Company/Nr
TableCompanyShort: Company shorthand
TableCompanies: Companies
TableCompanyNo: Company number
TableCompanyNos: Company numbers
TableCompanyNrUsers: Associates
TableCompanyNrSupers: Supervisors
TableCompanyNrSupersActive: Associates having supervisors
TableCompanyNrSupersDefault: Default supervisors
TableCompanyNrForeignSupers: External Supervisors
TableCompanyNrRerouteDefault: Default reroutes
TableCompanyNrRerouteActive: Active reroutes

2
routes
View File

@ -113,7 +113,7 @@
/for/#CryptoUUIDUser/user ForProfileR GET POST !supervisor !self
/for/#CryptoUUIDUser/user/profile ForProfileDataR GET !supervisor !self
/firm FirmAllR GET
/firm FirmAllR GET POST
/firm/#CompanyShorthand FirmR GET POST
/firm/#CompanyShorthand/users FirmUsersR GET POST
/firm/#CompanyShorthand/supers FirmSupersR GET POST

18
src/Database/Esqueleto/Utils.hs
View File

@ -24,7 +24,7 @@ module Database.Esqueleto.Utils
, mkContainsFilter, mkContainsFilterWith
, mkContainsFilterWithSet, mkContainsFilterWithComma, mkContainsFilterWithCommaPlus
, mkDayFilter, mkDayFilterFrom, mkDayFilterTo
, mkExistsFilter
, mkExistsFilter, mkExistsFilterWithComma
, anyFilter, allFilter
, ascNullsFirst, descNullsLast
, orderByList
@ -46,6 +46,7 @@ module Database.Esqueleto.Utils
, subSelectCountDistinct
, selectCountRows, selectCountDistinct
, selectMaybe
, num2text
, day, day', dayMaybe, interval, diffDays, diffTimes
, exprLift
, explicitUnsafeCoerceSqlExprValue
@ -422,6 +423,17 @@ mkExistsFilter query row criterias
| Set.null criterias = true
| otherwise = any (E.exists . query row) $ Set.toList criterias
mkExistsFilterWithComma :: PathPiece a
=> (Text -> a)
-> (t -> a -> E.SqlQuery ())
-> t
-> Set.Set Text
-> E.SqlExpr (E.Value Bool)
mkExistsFilterWithComma cast query row (foldMap commaSeparatedText -> criterias)
| Set.null criterias = true
| otherwise = any (E.exists . query row) (cast <$> Set.toList criterias)
-- | Combine several filters, using logical or
anyFilter :: Foldable f
=> f (t -> cs -> E.SqlExpr (E.Value Bool))
@ -656,10 +668,14 @@ selectCountDistinct q = do
selectMaybe :: (E.SqlSelect a r, MonadIO m) => E.SqlQuery a -> E.SqlReadT m (Maybe r)
selectMaybe = fmap listToMaybe . E.select . (<* E.limit 1)
-- | cast numeric type to text, which is safe and allows for an inefficient but safe comparison of numbers stored as text and numbers
num2text :: Num n => E.SqlExpr (E.Value n) -> E.SqlExpr (E.Value Text)
num2text = E.unsafeSqlCastAs "text"
day :: E.SqlExpr (E.Value UTCTime) -> E.SqlExpr (E.Value Day)
day = E.unsafeSqlCastAs "date"
-- | cast text to day, truly unsafe
day' :: E.SqlExpr (E.Value Text) -> E.SqlExpr (E.Value Day)
day' = E.unsafeSqlCastAs "date"

9
src/Foundation/I18n.hs
View File

@ -1,7 +1,12 @@
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@cip.ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
-- SPDX-FileCopyrightText: 2022-23 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <s.jost@fraport.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later
-- To add new language files:
-- 1. include new statement, e.g. mkMessageAddition ''UniWorX "Print" "messages/uniworx/categories/print" "de-de-formal"
-- 2. create appropriate translation files in the specified folder
-- 3. add constructor to list of module exports
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
@ -20,6 +25,7 @@ module Foundation.I18n
, UniWorXI18nMessage(..),UniWorXJobsHandlerMessage(..), UniWorXModelTypesMessage(..), UniWorXYesodMiddlewareMessage(..)
, UniWorXQualificationMessage(..)
, UniWorXPrintMessage(..)
, UniWorXFirmMessage(..)
, UniWorXAvsMessage(..)
, UniWorXAuthorshipStatementMessage(..)
, ShortTermIdentifier(..)
@ -233,6 +239,7 @@ mkMessageAddition ''UniWorX "Send" "messages/uniworx/categories/send" "de-de-for
mkMessageAddition ''UniWorX "YesodMiddleware" "messages/uniworx/categories/yesod_middleware" "de-de-formal"
mkMessageAddition ''UniWorX "User" "messages/uniworx/categories/user" "de-de-formal"
mkMessageAddition ''UniWorX "Print" "messages/uniworx/categories/print" "de-de-formal"
mkMessageAddition ''UniWorX "Firm" "messages/uniworx/categories/firm" "de-de-formal"
mkMessageAddition ''UniWorX "Button" "messages/uniworx/utils/buttons" "de-de-formal"
mkMessageAddition ''UniWorX "Form" "messages/uniworx/utils/handler_form" "de-de-formal"
mkMessageAddition ''UniWorX "TableColumn" "messages/uniworx/utils/table_column" "de-de-formal"

316
src/Handler/Firm.hs
View File

@ -7,7 +7,7 @@
{-# LANGUAGE TypeApplications #-}
module Handler.Firm
( getFirmAllR , postFirmAllR
( getFirmAllR , postFirmAllR
, getFirmR , postFirmR
, getFirmUsersR , postFirmUsersR
, getFirmSupersR, postFirmSupersR
@ -19,11 +19,11 @@ import Import
-- import Jobs
import Handler.Utils
-- import qualified Data.Set as Set
-- import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.Map as Map
-- import qualified Data.Csv as Csv
-- import qualified Data.Text as T
-- import qualified Data.CaseInsensitive as CI
import qualified Data.CaseInsensitive as CI
-- import qualified Data.Conduit.List as C
-- import Database.Persist.Sql (updateWhereCount)
import Database.Esqueleto.Experimental ((:&)(..))
@ -35,22 +35,22 @@ import Database.Esqueleto.Utils.TH
-- avoids repetition of local definitions
-- single :: (k,a) -> Map k a
-- single = uncurry Map.singleton
single :: (k,a) -> Map k a
single = uncurry Map.singleton
getFirmR, postFirmR :: CompanyShorthand -> Handler Html
getFirmR = postFirmR
postFirmR fsh = do
let fshId = CompanyKey fsh
cusers <- runDB $ do
cusers <- runDB $ do
cusers <- selectList [UserCompanyCompany ==. fshId] []
selectList [UserId <-. fmap (userCompanyUser . entityVal) cusers] [Asc UserDisplayName]
csuper <- runDB $ do
csuper <- runDB $ do
csuper <- selectList [UserCompanyCompany ==. fshId, UserCompanySupervisor ==. True] []
selectList [UserId <-. fmap (userCompanyUser . entityVal) csuper] [Asc UserDisplayName]
cactSuper <- runDB $ E.select $ do
(usr :& spr :& scmpy) <- E.from $
cactSuper <- runDB $ E.select $ do
(usr :& spr :& scmpy) <- E.from $
E.table @User
`E.innerJoin` E.table @UserSupervisor
`E.on` (\(usr :& spr ) -> spr E.^. UserSupervisorSupervisor E.==. usr E.^. UserId)
@ -61,28 +61,28 @@ postFirmR fsh = do
E.orderBy [E.asc $ usr E.^. UserId, E.asc $ usr E.^. UserDisplayName, E.asc $ usr E.^. UserSurname, E.asc $ scmpy E.?. UserCompanyCompany]
let countRows' :: E.SqlExpr (E.Value Int64) = E.countRows
return (usr E.^. UserId, usr E.^. UserDisplayName, usr E.^. UserSurname, scmpy E.?. UserCompanyCompany, countRows')
siteLayoutMsg (SomeMessage fsh) $ do
siteLayoutMsg (SomeMessage fsh) $ do
setTitle $ citext2Html fsh
[whamlet|
[whamlet|
<h3>#{length csuper} Company Default Supervisors (non-foreign only)
<ul>
<ul>
$forall u <- csuper
<li>^{linkUserWidget ForProfileDataR u}
<h3>#{length cactSuper} Active Supervisors for Employees
<ul>
<ul>
$forall (E.Value _, E.Value dn, E.Value sn, E.Value mbCsh, E.Value nr) <- cactSuper
<li>#{nr} Employees supervised by ^{nameWidget dn sn}
<li>#{nr} Employees supervised by ^{nameWidget dn sn}
$maybe csh <- mbCsh
$if csh /= fshId
from foreign company #{unCompanyKey csh}
$else
from this company
$else
from this company
$nothing
having no associated company
<h3>#{length cusers} Employees
<h3>#{length cusers} Employees
<ul>
$forall u <- cusers
<li>^{linkUserWidget ForProfileDataR u}
@ -91,24 +91,32 @@ postFirmR fsh = do
|]
getFirmAllR, postFirmAllR :: Handler Html
getFirmAllR = postFirmAllR
postFirmAllR = do
uid <- requireAuthId
isAdmin <- hasReadAccessTo AdminR
firmTable <- runDB $ do
view _2 <$> mkFirmAllTable isAdmin uid -- filter to associated companies for non-admins
siteLayoutMsg MsgMenuFirms $ do
setTitleI MsgMenuFirms
-- $(widgetFile "firm-all")
[whamlet|!!!STUB!!!TO DO!!!
^{firmTable}
|]
-----------------------
-- All Firms Table
data FirmAllAction = FirmAllActNotify
| FirmAllActResetSupervision
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
deriving anyclass (Universe, Finite)
nullaryPathPiece ''FirmAllAction $ camelToPathPiece' 3
embedRenderMessage ''UniWorX ''FirmAllAction id
data FirmAllActionData = FirmAllActNotifyData
| FirmAllActResetSupervisionData
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
-- just in case for future extensions
type AllCompanyTableExpr = E.SqlExpr (Entity Company)
queryCompany :: AllCompanyTableExpr -> E.SqlExpr (Entity Company)
queryCompany = id
type AllCompanyTableData = DBRow (Entity Company, E.Value Word64, E.Value Word64, E.Value Word64, E.Value Word64, E.Value Word64, E.Value Word64)
resultAllCompanyEntity :: Lens' AllCompanyTableData (Entity Company)
resultAllCompanyEntity = _dbrOutput . _1
resultAllCompany :: Lens' AllCompanyTableData Company
resultAllCompany = _dbrOutput . _1 . _entityVal
resultAllCompany = resultAllCompanyEntity . _entityVal
resultAllCompanyUsers :: Lens' AllCompanyTableData Word64
resultAllCompanyUsers = _dbrOutput . _2 . _unValue
@ -129,7 +137,7 @@ resultAllCompanyActiveReroutes' :: Lens' AllCompanyTableData Word64
resultAllCompanyActiveReroutes' = _dbrOutput . _7 . _unValue
fromUserCompany :: Maybe (E.SqlExpr (Entity UserCompany) -> E.SqlExpr (E.Value Bool)) -> E.SqlExpr (Entity Company) -> E.SqlQuery ()
fromUserCompany mbFltr cmpy = do
fromUserCompany mbFltr cmpy = do
usrCmpy <- E.from $ E.table @UserCompany
let basecond = usrCmpy E.^. UserCompanyCompany E.==. cmpy E.^. CompanyId
E.where_ $ maybe basecond ((basecond E.&&.).($ usrCmpy)) mbFltr
@ -138,9 +146,9 @@ firmCountUsers :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64
firmCountUsers = E.subSelectCount . fromUserCompany Nothing
firmCountSupervisors :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
firmCountSupervisors = E.subSelectCount . fromUserCompany (Just (E.^. UserCompanySupervisor))
firmCountSupervisors = E.subSelectCount . fromUserCompany (Just (E.^. UserCompanySupervisor))
-- firmCountSupervisors :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
-- firmCountSupervisors cmpy = E.subSelectCount $ E.distinct $ do
-- firmCountSupervisors cmpy = E.subSelectCount $ E.distinct $ do
-- usrCmpy <- E.from $ E.table @UserCompany
-- E.where_ $ (usrCmpy E.^. UserCompanyCompany E.==. cmpy E.^. CompanyId)
-- E.&&. (usrCmpy E.^. UserCompanySupervisor E.==. E.true)
@ -152,45 +160,45 @@ firmCountDefaultReroutes = E.subSelectCount . fromUserCompany (Just (\uc -> uc E
-- firmCountForeignSupervisors :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
-- firmCountForeignSupervisors cmpy = E.coalesceDefault
-- [E.subSelect $ do
-- usrSuper <- E.from $ E.table @UserSupervisor
-- usrSuper <- E.from $ E.table @UserSupervisor
-- E.groupBy (usrSuper E.^. UserSupervisorSupervisor)
-- E.where_ $ E.exists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorUser) cmpy)
-- E.&&. E.notExists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorSupervisor) cmpy)
-- E.&&. E.notExists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorSupervisor) cmpy)
-- return E.countRows
-- ] (E.val 0)
firmCountForeignSupervisors :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
firmCountForeignSupervisors cmpy = E.subSelectCountDistinct $ do
usrSuper <- E.from $ E.table @UserSupervisor
firmCountForeignSupervisors cmpy = E.subSelectCountDistinct $ do
usrSuper <- E.from $ E.table @UserSupervisor
E.where_ $ E.exists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorUser) cmpy)
E.&&. E.notExists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorSupervisor) cmpy)
pure $ usrSuper E.^. UserSupervisorSupervisor
firmCountActiveReroutes :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
firmCountActiveReroutes cmpy = E.subSelectCountDistinct $ do
usrSuper <- E.from $ E.table @UserSupervisor
usrSuper <- E.from $ E.table @UserSupervisor
E.where_ $ E.exists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorUser) cmpy)
E.&&. usrSuper E.^. UserSupervisorRerouteNotifications
pure $ usrSuper E.^. UserSupervisorSupervisor
firmCountActiveReroutes' :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
firmCountActiveReroutes' cmpy = E.subSelectCount $ do
usrSuper <- E.from $ E.table @UserSupervisor
usrSuper <- E.from $ E.table @UserSupervisor
E.where_ $ E.exists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorUser) cmpy)
E.&&. usrSuper E.^. UserSupervisorRerouteNotifications
mkFirmAllTable :: Bool -> UserId -> DB (Any, Widget)
mkFirmAllTable isAdmin uid = do
mkFirmAllTable :: Bool -> UserId -> DB (FormResult (FirmAllActionData, Set CompanyId), Widget)
mkFirmAllTable isAdmin uid = do
-- now <- liftIO getCurrentTime
let
let
resultDBTable = DBTable{..}
where
dbtSQLQuery cmpy = do
dbtSQLQuery cmpy = do
unless isAdmin $ E.where_ $ E.exists $ do -- only show associated companies
usrCmpy <- E.from $ E.table @UserCompany
E.where_ $ usrCmpy E.^. UserCompanyCompany E.==. cmpy E.^. CompanyId
E.&&. usrCmpy E.^. UserCompanyUser E.==. E.val uid
E.&&. usrCmpy E.^. UserCompanyUser E.==. E.val uid
return ( cmpy
, cmpy & firmCountUsers
, cmpy & firmCountSupervisors
@ -201,22 +209,24 @@ mkFirmAllTable isAdmin uid = do
)
dbtRowKey = (E.^. CompanyId)
dbtProj = dbtProjId
dbtColonnade = dbColonnade $ mconcat
[ -- if not isAdmin then mempty else dbSelect (applying _2) id (return . view (resultAllCompany . _companyShorthand))
sortable (Just "name") (i18nCell MsgTableCompany) $ \(view resultAllCompany -> firm) ->
dbtColonnade = formColonnade $
mconcat
[ if not isAdmin then mempty else -- guardOnM idAdmin $
dbSelect (applying _2) id (return . view (resultAllCompanyEntity . _entityKey))
, sortable (Just "name") (i18nCell MsgTableCompany) $ \(view resultAllCompany -> firm) ->
anchorCell (FirmR $ companyShorthand firm) . toWgt $ companyName firm
, sortable (Just "short") (i18nCell MsgTableCompanyShort) $ \(view resultAllCompany -> firm) ->
let fsh = companyShorthand firm
, sortable (Just "short") (i18nCell MsgTableCompanyShort) $ \(view resultAllCompany -> firm) ->
let fsh = companyShorthand firm
in anchorCell (FirmR fsh) $ toWgt fsh
, sortable (Just "avsnr") (i18nCell MsgTableCompanyNo) $ \(view resultAllCompany -> firm) ->
, sortable (Just "avsnr") (i18nCell MsgTableCompanyNo) $ \(view resultAllCompany -> firm) ->
anchorCell (FirmR $ companyShorthand firm) $ toWgt $ companyAvsId firm
, sortable (Just "users") (i18nCell MsgTableCompanyNrUsers) $ \(view resultAllCompanyUsers -> nr) -> wgtCell $ word2widget nr
, sortable (Just "supervisors") (i18nCell MsgTableCompanyNrSupers) $ \(view resultAllCompanySupervisors -> nr) -> wgtCell $ word2widget nr
, sortable (Just "supervisors") (i18nCell MsgTableCompanyNrSupersDefault) $ \(view resultAllCompanySupervisors -> nr) -> wgtCell $ word2widget nr
, sortable (Just "reroute-def") (i18nCell MsgTableCompanyNrRerouteDefault) $ \(view resultAllCompanyDefaultReroutes -> nr) -> wgtCell $ word2widget nr
, sortable (Just "foreigners") (i18nCell MsgTableCompanyNrForeignSupers) $ \(view resultAllCompanyForeignSupers -> nr) -> wgtCell $ word2widget nr
, sortable (Just "reroute-act") (i18nCell MsgTableCompanyNrRerouteActive) $ \(view resultAllCompanyActiveReroutes -> nr) -> wgtCell $ word2widget nr
, sortable (Just "reroute-all") (i18nCell MsgTableCompanyNrRerouteActive) $ \(view resultAllCompanyActiveReroutes' -> nr) -> wgtCell $ word2widget nr
]
]
dbtSorting = mconcat
[ singletonMap "name" $ SortColumn (E.^. CompanyName)
, singletonMap "short" $ SortColumn (E.^. CompanyShorthand)
@ -229,42 +239,96 @@ mkFirmAllTable isAdmin uid = do
, singletonMap "reroute-all" $ SortColumn firmCountActiveReroutes'
]
dbtFilter = mconcat
[
[ single $ fltrCompanyNameNr queryCompany
, single ("is-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)
E.where_ $ usrCmp E.^. UserCompanyCompany E.==. queryCompany row E.^. CompanyId
E.&&. ( (usr E.^. UserDisplayName `E.hasInfix` E.val criterion)
E.||. (usr E.^. UserDisplayEmail `E.hasInfix` E.val (CI.mk criterion))
E.||. (usr E.^. UserSurname `E.hasInfix` E.val criterion)
)
)
]
dbtFilterUI = mconcat
[
dbtFilterUI mPrev = mconcat
[ fltrCompanyNameNrUI mPrev
, prismAForm (singletonFilter "is-supervisor") mPrev $ aopt textField (fslI MsgTableSupervisor)
]
dbtStyle = def -- { dbsFilterLayout = defaultDBSFilterLayout }
dbtParams = def
acts :: Map FirmAllAction (AForm Handler FirmAllActionData)
acts = mconcat
[ singletonMap FirmAllActNotify $ pure FirmAllActNotifyData
, singletonMap FirmAllActResetSupervision $ pure FirmAllActResetSupervisionData
]
dbtParams = DBParamsForm
{ dbParamsFormMethod = POST
, dbParamsFormAction = Nothing
, dbParamsFormAttrs = []
, dbParamsFormSubmit = FormSubmit
, dbParamsFormAdditional
= renderAForm FormStandard $ (, mempty) . First . Just
<$> multiActionA acts (fslI MsgTableAction) Nothing
, dbParamsFormEvaluate = liftHandler . runFormPost
, dbParamsFormResult = id
, dbParamsFormIdent = def
}
dbtIdent :: Text
dbtIdent = "firm"
dbtIdent = "firm"
dbtCsvEncode = noCsvEncode
dbtCsvDecode = Nothing
dbtExtraReps = []
postprocess :: FormResult (First FirmAllActionData, DBFormResult CompanyId Bool AllCompanyTableData)
-> FormResult ( FirmAllActionData, Set CompanyId)
postprocess inp = do
(First (Just act), cmpMap) <- inp
let cmpSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) cmpMap
return (act, cmpSet)
-- resultDBTableValidator :: PSValidator (MForm Handler) (FormResult (First FirmAllActionData, DBFormResult CompanyId Bool FirmAllActionData))
resultDBTableValidator = def
-- & defaultSorting [SortAscBy "school", SortAscBy "qshort"]
dbTable resultDBTableValidator resultDBTable
& defaultSorting [SortAscBy "short"]
over _1 postprocess <$> dbTable resultDBTableValidator resultDBTable
getFirmAllR, postFirmAllR :: Handler Html
getFirmAllR = postFirmAllR
postFirmAllR = do
uid <- requireAuthId
isAdmin <- hasReadAccessTo AdminR
(firmRes, firmTable) <- runDB $ mkFirmAllTable isAdmin uid -- filters to associated companies for non-admins
formResult firmRes $ \case
(FirmAllActNotifyData , fids) -> addMessage Info $ text2Html $ "Notify " <> tshow (length fids) <> " companies. TODO"
(FirmAllActResetSupervisionData, fids) -> addMessage Info $ text2Html $ "Reset " <> tshow (length fids) <> " companies. TODO"
siteLayoutMsg MsgMenuFirms $ do
setTitleI MsgMenuFirms
-- $(widgetFile "firm-all")
[whamlet|!!!STUB!!!TO DO!!!
^{firmTable}
|]
-- -- getQualificationEditR, postQualificationEditR :: SchoolId -> QualificationShorthand -> Handler Html
-- -- getQualificationEditR = postQualificationEditR
-- -- postQualificationEditR = error "TODO"
-----------------------
-- Firm Users Table
getFirmUsersR, postFirmUsersR :: CompanyShorthand -> Handler Html
getFirmUsersR = postFirmUsersR
postFirmUsersR fsh = do
postFirmUsersR fsh = do
let _fshId = CompanyKey fsh
siteLayout (citext2widget fsh) $ do
siteLayout (citext2widget fsh) $ do
setTitle $ citext2Html fsh
[whamlet|!!!STUB!!!TO DO!!!|]
-----------------------------
-- Firm Supervisors Table
getFirmSupersR, postFirmSupersR :: CompanyShorthand -> Handler Html
getFirmSupersR = postFirmSupersR
postFirmSupersR fsh = do
postFirmSupersR fsh = do
let _fshId = CompanyKey fsh
siteLayout (citext2widget fsh) $ do
siteLayout (citext2widget fsh) $ do
setTitle $ citext2Html fsh
[whamlet|!!!STUB!!!TO DO!!!|]
@ -277,7 +341,7 @@ postFirmSupersR fsh = do
-- , qtcValidUntil :: Day
-- , qtcLastRefresh :: Day
-- , qtcBlockStatus :: Maybe Bool
-- , qtcBlockFrom :: Maybe UTCTime
-- , qtcBlockFrom :: Maybe UTCTime
-- , qtcScheduleRenewal:: Bool
-- , qtcLmsStatusTxt :: Maybe Text
-- , qtcLmsStatusDay :: Maybe UTCTime
@ -294,7 +358,7 @@ postFirmSupersR fsh = do
-- , qtcValidUntil = compDay
-- , qtcLastRefresh = compDay
-- , qtcBlockStatus = Nothing
-- , qtcBlockFrom = Nothing
-- , qtcBlockFrom = Nothing
-- , qtcScheduleRenewal= True
-- , qtcLmsStatusTxt = Just "Success"
-- , qtcLmsStatusDay = Just compTime
@ -332,7 +396,7 @@ postFirmSupersR fsh = do
-- , ('qtcBlockFrom , SomeMessage MsgInfoQualificationBlockFrom)
-- , ('qtcScheduleRenewal, SomeMessage MsgQualificationScheduleRenewalTooltip)
-- , ('qtcLmsStatusTxt , SomeMessage MsgTableLmsStatus)
-- , ('qtcLmsStatusDay , SomeMessage MsgTableLmsStatusDay)
-- , ('qtcLmsStatusDay , SomeMessage MsgTableLmsStatusDay)
-- ]
@ -387,15 +451,15 @@ postFirmSupersR fsh = do
-- -- hasQualificationUserBlock = resultQualBlock
-- data QualificationTableAction
-- = QualificationActExpire
-- data QualificationTableAction
-- = QualificationActExpire
-- | QualificationActUnexpire
-- | QualificationActBlockSupervisor
-- | QualificationActBlock
-- | QualificationActUnblock
-- | QualificationActRenew
-- | QualificationActGrant
-- deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
-- deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
-- instance Universe QualificationTableAction
-- instance Finite QualificationTableAction
@ -410,15 +474,15 @@ postFirmSupersR fsh = do
-- isAdminAct _ = True
-- -}
-- data QualificationTableActionData
-- = QualificationActExpireData
-- | QualificationActUnexpireData
-- data QualificationTableActionData
-- = QualificationActExpireData
-- | QualificationActUnexpireData
-- | QualificationActBlockSupervisorData
-- | QualificationActBlockData { qualTableActBlockReason :: Text, qualTableActNotify :: Bool, qualTableActRemoveSupervisors :: Bool }
-- | QualificationActUnblockData { qualTableActBlockReason :: Text, qualTableActNotify :: Bool}
-- | QualificationActRenewData
-- | QualificationActGrantData { qualTableActGrantUntil :: Day }
-- deriving (Eq, Ord, Show, Generic)
-- | QualificationActGrantData { qualTableActGrantUntil :: Day }
-- deriving (Eq, Ord, Show, Generic)
-- isExpiryAct :: QualificationTableActionData -> Bool
-- isExpiryAct QualificationActExpireData = True
@ -456,14 +520,14 @@ postFirmSupersR fsh = do
-- )
-- qualificationTableQuery now qid fltr (qualUser `E.InnerJoin` user `E.LeftOuterJoin` lmsUser `E.LeftOuterJoin` qualBlock) = do
-- -- E.distinctOnOrderBy will not work: sorting with dbTable should work, except that columns contained in distinctOnOrderBy cannot be sorted inversely by user; but PostgreSQL leftJoin with distinct filters too many results, see SQL Example lead/lag under jost/misc DevOps
-- --
-- --
-- E.on $ qualBlock E.?. QualificationUserBlockQualificationUser E.?=. qualUser E.^. QualificationUserId
-- E.&&. qualBlock `isLatestBlockBefore` E.val now
-- E.on $ user E.^. UserId E.=?. lmsUser E.?. LmsUserUser
-- E.&&. E.val qid E.=?. lmsUser E.?. LmsUserQualification -- NOTE: condition was once erroneously placed in where-clause, which does not work
-- E.on $ user E.^. UserId E.==. qualUser E.^. QualificationUserUser
-- E.where_ $ fltr qualUser
-- E.&&. (E.val qid E.==. qualUser E.^. QualificationUserQualification)
-- E.where_ $ fltr qualUser
-- E.&&. (E.val qid E.==. qualUser E.^. QualificationUserQualification)
-- return (qualUser, user, lmsUser, qualBlock)
@ -473,15 +537,15 @@ postFirmSupersR fsh = do
-- )
-- => Bool
-- -> Entity Qualification
-- -> Map QualificationTableAction (AForm Handler QualificationTableActionData)
-- -> Map QualificationTableAction (AForm Handler QualificationTableActionData)
-- -> (Map CompanyId Company -> cols)
-- -> PSValidator (MForm Handler) (FormResult (First QualificationTableActionData, DBFormResult UserId Bool QualificationTableData))
-- -> DB (FormResult (QualificationTableActionData, Set UserId), Widget)
-- mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do
-- svs <- getSupervisees
-- now <- liftIO getCurrentTime
-- -- lookup all companies
-- cmpMap <- memcachedBy (Just . Right $ 5 * diffMinute) ("CompanyDictionary"::Text) $ do
-- now <- liftIO getCurrentTime
-- -- lookup all companies
-- cmpMap <- memcachedBy (Just . Right $ 5 * diffMinute) ("CompanyDictionary"::Text) $ do
-- cmps <- selectList [] [] -- [Asc CompanyShorthand]
-- return $ Map.fromList $ fmap (\Entity{..} -> (entityKey, entityVal)) cmps
-- let
@ -526,14 +590,14 @@ postFirmSupersR fsh = do
-- dbtFilter = mconcat
-- [ single $ fltrUserNameEmail queryUser
-- , single ("avs-number" , FilterColumn . E.mkExistsFilter $ \row criterion ->
-- E.from $ \usrAvs -> -- do
-- E.from $ \usrAvs -> -- do
-- E.where_ $ usrAvs E.^. UserAvsUser E.==. queryUser row E.^. UserId
-- E.&&. ((E.val criterion :: E.SqlExpr (E.Value (CI Text))) E.==.
-- (E.explicitUnsafeCoerceSqlExprValue "citext" (usrAvs E.^. UserAvsNoPerson) :: E.SqlExpr (E.Value (CI Text))) ))
-- , single ("avs-card" , FilterColumn $ \(queryUser -> user) (criterion :: Set.Set Text) -> case readAvsFullCardNo =<< Set.lookupMin criterion of
-- Nothing -> E.false
-- Just cardNo -> E.exists $ E.from $ \(avsCard `E.InnerJoin` usrAvs) -> do
-- E.on $ usrAvs E.^. UserAvsPersonId E.==. avsCard E.^. UserAvsCardPersonId
-- E.on $ usrAvs E.^. UserAvsPersonId E.==. avsCard E.^. UserAvsCardPersonId
-- E.where_ $ usrAvs E.^. UserAvsUser E.==. user E.^. UserId
-- E.&&. (avsCard E.^. UserAvsCardCardNo E.==. E.val cardNo)
-- )
@ -542,14 +606,14 @@ postFirmSupersR fsh = do
-- | otherwise -> E.any (\c -> user E.^. UserCompanyPersonalNumber `E.hasInfix` E.val c) criteria
-- )
-- , single ("user-company", FilterColumn . E.mkExistsFilter $ \row criterion ->
-- E.from $ \(usrComp `E.InnerJoin` comp) -> do
-- E.from $ \(usrComp `E.InnerJoin` comp) -> do
-- let testname = (E.val criterion :: E.SqlExpr (E.Value (CI Text))) `E.isInfixOf`
-- (E.explicitUnsafeCoerceSqlExprValue "citext" (comp E.^. CompanyName) :: E.SqlExpr (E.Value (CI Text)))
-- testnumber nr = E.val nr E.==. comp E.^. CompanyAvsId
-- testcrit = maybe testname testnumber $ readMay $ CI.original criterion
-- 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 ->
-- if | Just renewal <- mbRenewal
@ -568,7 +632,7 @@ postFirmSupersR fsh = do
-- , prismAForm (singletonFilter "user-company") mPrev $ aopt textField (fslI MsgTableCompany)
-- , prismAForm (singletonFilter "personal-number" ) mPrev $ aopt textField (fslI MsgCompanyPersonalNumber)
-- , prismAForm (singletonFilter "avs-card" ) mPrev $ aopt textField (fslI MsgAvsCardNo)
-- , prismAForm (singletonFilter "avs-number" ) mPrev $ aopt textField (fslI MsgAvsPersonNo)
-- , prismAForm (singletonFilter "avs-number" ) mPrev $ aopt textField (fslI MsgAvsPersonNo)
-- , prismAForm (singletonFilter "validity" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsValid)
-- , if isNothing mbRenewal then mempty
-- else prismAForm (singletonFilter "renewal-due" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsRenewal)
@ -593,31 +657,31 @@ postFirmSupersR fsh = do
-- <*> (view resultCompanyUser >>= getCompanies)
-- <*> (view resultCompanyUser >>= getCompanyNos)
-- <*> view (resultQualUser . _entityVal . _qualificationUserValidUntil)
-- <*> view (resultQualUser . _entityVal . _qualificationUserLastRefresh)
-- <*> view (resultQualUser . _entityVal . _qualificationUserLastRefresh)
-- <*> preview (resultQualBlock. _entityVal . _qualificationUserBlockUnblock . _not)
-- <*> preview (resultQualBlock. _entityVal . _qualificationUserBlockFrom)
-- <*> preview (resultQualBlock. _entityVal . _qualificationUserBlockFrom)
-- <*> view (resultQualUser . _entityVal . _qualificationUserScheduleRenewal)
-- <*> getStatusPlusTxt
-- <*> getStatusPlusDay
-- getCompanies cmps = case mapMaybe (flip Map.lookup cmpMap . view (_entityVal . _userCompanyCompany)) cmps of
-- getCompanies cmps = case mapMaybe (flip Map.lookup cmpMap . view (_entityVal . _userCompanyCompany)) cmps of
-- [] -> pure Nothing
-- somecmps -> pure $ Just $ intercalate ", " $ fmap (view (_companyName . _CI)) somecmps
-- getCompanyNos = pure . CsvSemicolonList . mapMaybe (preview (_Just . _companyAvsId) . flip Map.lookup cmpMap . view (_entityVal . _userCompanyCompany))
-- getStatusPlusTxt =
-- (join . preview (resultLmsUser . _entityVal . _lmsUserStatus)) >>= \case
-- getStatusPlusTxt =
-- (join . preview (resultLmsUser . _entityVal . _lmsUserStatus)) >>= \case
-- Just LmsBlocked{} -> return $ Just "Failed"
-- Just LmsExpired{} -> return $ Just "Expired"
-- Just LmsSuccess{} -> return $ Just "Success"
-- Nothing -> maybeM (return Nothing) (const $ return $ Just "Open") $
-- preview (resultLmsUser . _entityVal . _lmsUserStarted)
-- getStatusPlusDay =
-- (join . preview (resultLmsUser . _entityVal . _lmsUserStatusDay)) >>= \case
-- getStatusPlusDay =
-- (join . preview (resultLmsUser . _entityVal . _lmsUserStatusDay)) >>= \case
-- lsd@(Just _) -> return lsd
-- Nothing -> preview (resultLmsUser . _entityVal . _lmsUserStarted)
-- dbtCsvDecode = Nothing
-- dbtExtraReps = []
-- dbtExtraReps = []
-- dbtParams = DBParamsForm
-- { dbParamsFormMethod = POST
-- , dbParamsFormAction = Nothing
@ -646,7 +710,7 @@ postFirmSupersR fsh = do
-- getQualificationR, postQualificationR :: SchoolId -> QualificationShorthand -> Handler Html
-- getQualificationR = postQualificationR
-- postQualificationR sid qsh = do
-- postQualificationR sid qsh = do
-- isAdmin <- hasReadAccessTo AdminR
-- msgGrantWarning <- messageIconI Warning IconWarning MsgQualificationActGrantWarning
-- msgUnexpire <- messageIconI Info IconWarning MsgQualificationActUnexpireWarning
@ -661,13 +725,13 @@ postFirmSupersR fsh = do
-- }} <- getBy404 $ SchoolQualificationShort sid qsh
-- -- Block copied to Handler/Qualifications TODO: refactor
-- let getBlockReasons unblk = E.select $ do
-- (quser :& qblock) <- E.from $ E.table @QualificationUser
-- let getBlockReasons unblk = E.select $ do
-- (quser :& qblock) <- E.from $ E.table @QualificationUser
-- `E.innerJoin` E.table @QualificationUserBlock
-- `E.on` (\(quser :& qblock) -> quser E.^. QualificationUserId E.==. qblock E.^. QualificationUserBlockQualificationUser)
-- E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid
-- E.&&. unblk (qblock E.^. QualificationUserBlockUnblock)
-- E.groupBy (qblock E.^. QualificationUserBlockReason)
-- E.groupBy (qblock E.^. QualificationUserBlockReason)
-- let countRows' :: E.SqlExpr (E.Value Int64) = E.countRows
-- E.orderBy [E.desc countRows']
-- E.limit 7
@ -681,34 +745,34 @@ postFirmSupersR fsh = do
-- acts :: Map QualificationTableAction (AForm Handler QualificationTableActionData)
-- acts = mconcat $
-- [ singletonMap QualificationActExpire $ pure QualificationActExpireData
-- , singletonMap QualificationActUnexpire $ QualificationActUnexpireData
-- <$ aformMessage msgUnexpire
-- ] ++ bool
-- , singletonMap QualificationActUnexpire $ QualificationActUnexpireData
-- <$ aformMessage msgUnexpire
-- ] ++ bool
-- -- nonAdmin actions, ie. Supervisor
-- [ singletonMap QualificationActBlockSupervisor $ pure QualificationActBlockSupervisorData ]
-- [ singletonMap QualificationActBlockSupervisor $ pure QualificationActBlockSupervisorData ]
-- -- Admin-only actions
-- [ singletonMap QualificationActUnblock $ QualificationActUnblockData
-- <$> apreq (textField & cfStrip & addDatalist suggestionsUnblock) (fslI MsgQualificationGrantReason) Nothing
-- <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgQualificationBlockNotify) (Just False)
-- , singletonMap QualificationActBlock $ QualificationActBlockData
-- , singletonMap QualificationActBlock $ QualificationActBlockData
-- <$> apreq (textField & cfStrip & addDatalist suggestionsBlock) (fslI MsgQualificationBlockReason) Nothing
-- <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgQualificationBlockNotify) (Just False)
-- <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgQualificationBlockRemoveSupervisor) (Just False)
-- , singletonMap QualificationActRenew $ pure QualificationActRenewData
-- , singletonMap QualificationActGrant $ QualificationActGrantData
-- , singletonMap QualificationActGrant $ QualificationActGrantData
-- <$> apopt dayField (fslI MsgLmsQualificationValidUntil) dayExpiry
-- <* aformMessage msgGrantWarning
-- ] isAdmin
-- linkLmsUser = toMaybe isAdmin (LmsUserR sid qsh)
-- linkUserName = bool ForProfileR ForProfileDataR isAdmin
-- linkUserName = bool ForProfileR ForProfileDataR isAdmin
-- colChoices cmpMap = mconcat
-- [ dbSelect (applying _2) id (return . view (hasEntity . _entityKey))
-- , colUserNameModalHdr MsgLmsUser linkUserName
-- , colUserEmail
-- , colUserEmail
-- , sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \( view resultCompanyUser -> cmps) ->
-- let icnSuper = text2markup " " <> icon IconSupervisor
-- cs = [ (cmpName, cmpSpr)
-- | Entity _ UserCompany{userCompanyCompany=cmpId, userCompanySupervisor=cmpSpr} <- cmps
-- cs = [ (cmpName, cmpSpr)
-- | Entity _ UserCompany{userCompanyCompany=cmpId, userCompanySupervisor=cmpSpr} <- cmps
-- , let cmpName = maybe (unCompanyKey cmpId) companyName $ Map.lookup cmpId cmpMap
-- ]
-- companies = intercalate (text2markup ", ") $
@ -717,9 +781,9 @@ postFirmSupersR fsh = do
-- , guardMonoid isAdmin colUserMatriclenr
-- -- , sortable (Just "validity") (i18nCell MsgQualificationValidIndicator) (qualificationValidIconCell nowaday . view resultQualUser)
-- , sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ \( view $ resultQualUser . _entityVal . _qualificationUserFirstHeld -> d) -> dayCell d
-- , sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \( view $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> dayCell d
-- , sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \( view $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> dayCell d
-- , sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) (dayCell . view ( resultQualUser . _entityVal . _qualificationUserValidUntil))
-- , sortable (Just "blocked") (i18nCell MsgQualificationValidIndicator & cellTooltip MsgTableQualificationBlockedTooltipSimple) $ \row ->
-- , sortable (Just "blocked") (i18nCell MsgQualificationValidIndicator & cellTooltip MsgTableQualificationBlockedTooltipSimple) $ \row ->
-- qualificationValidReasonCell' (Just $ LmsUserR sid qsh) isAdmin nowaday (row ^? resultQualBlock) row
-- , sortable (Just "schedule-renew")(i18nCell MsgTableQualificationNoRenewal & cellTooltip MsgTableQualificationNoRenewalTooltip
-- ) $ \( view $ resultQualUser . _entityVal . _qualificationUserScheduleRenewal -> b) -> ifIconCell (not b) IconNoNotification
@ -730,13 +794,13 @@ postFirmSupersR fsh = do
-- psValidator = def & defaultSorting [SortDescBy "last-refresh"]
-- tbl <- mkQualificationTable isAdmin qent acts colChoices psValidator
-- return (tbl, qent)
-- formResult lmsRes $ \case
-- (QualificationActRenewData, selectedUsers) | isAdmin -> do
-- noks <- runDB $ renewValidQualificationUsers qid Nothing $ Set.toList selectedUsers
-- noks <- runDB $ renewValidQualificationUsers qid Nothing $ Set.toList selectedUsers
-- addMessageI (if noks > 0 && noks == Set.size selectedUsers then Success else Warning) $ MsgTutorialUserRenewedQualification noks
-- reloadKeepGetParams $ QualificationR sid qsh
-- (QualificationActGrantData grantValidday, selectedUsers) | isAdmin -> do
-- (QualificationActGrantData grantValidday, selectedUsers) | isAdmin -> do
-- runDB . forM_ selectedUsers $ upsertQualificationUser qid nowaday grantValidday Nothing
-- addMessageI (if 0 < Set.size selectedUsers then Success else Warning) . MsgTutorialUserGrantedQualification $ Set.size selectedUsers
-- reloadKeepGetParams $ QualificationR sid qsh
@ -749,18 +813,18 @@ postFirmSupersR fsh = do
-- msgVal = upd & if isUnexpire then MsgQualificationSetUnexpire else MsgQualificationSetExpire
-- addMessageI msgKind msgVal
-- reloadKeepGetParams $ QualificationR sid qsh
-- (action, selectedUsers) | isBlockAct action && (isAdmin || action == QualificationActBlockSupervisorData) -> do
-- (action, selectedUsers) | isBlockAct action && (isAdmin || action == QualificationActBlockSupervisorData) -> do
-- let selUserIds = Set.toList selectedUsers
-- (unblock, reason) = case action of
-- QualificationActBlockSupervisorData -> (False, Right QualificationBlockReturnedByCompany)
-- (unblock, reason) = case action of
-- QualificationActBlockSupervisorData -> (False, Right QualificationBlockReturnedByCompany)
-- QualificationActBlockData{..} -> (False, Left qualTableActBlockReason)
-- QualificationActUnblockData{..} -> (True , Left qualTableActBlockReason)
-- _ -> error "Handle.Qualification.isBlockAct returned non-block action" -- cannot occur due to earlier checks
-- notify = case action of
-- notify = case action of
-- QualificationActBlockData{qualTableActNotify} -> qualTableActNotify
-- _ -> False
-- oks <- runDB $ do
-- oks <- runDB $ do
-- when (blockActRemoveSupervisors action) $ deleteWhere [UserSupervisorUser <-. selUserIds]
-- qualificationUserBlocking qid selUserIds unblock Nothing reason notify
-- let nrq = length selectedUsers

5
src/Handler/LMS.hs
View File

@ -359,9 +359,8 @@ data LmsTableAction = LmsActNotify
| LmsActReset
| LmsActRestart
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
instance Universe LmsTableAction
instance Finite LmsTableAction
deriving anyclass (Universe, Finite)
nullaryPathPiece ''LmsTableAction $ camelToPathPiece' 2
embedRenderMessage ''UniWorX ''LmsTableAction id

6
src/Handler/PrintCenter.hs
View File

@ -225,9 +225,9 @@ mkPJTable = do
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 ("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 ("sender" , FilterColumn . E.mkContainsFilterWithCommaPlus Just $ views (to querySender) (E.?. UserDisplayName))
, single ("course" , FilterColumn . E.mkContainsFilterWith (Just . CI.mk) $ views (to queryCourse) (E.?. CourseName))

14
src/Handler/Profile.hs
View File

@ -102,7 +102,6 @@ instance RenderMessage UniWorX NotificationTriggerKind where
where
mr = renderMessage f ls
makeSettingForm :: Maybe SettingsForm -> Form SettingsForm
makeSettingForm template html = do
MsgRenderer mr <- getMsgRenderer
@ -169,7 +168,7 @@ schoolsForm template = formToAForm $ schoolsFormView =<< renderWForm FormStandar
notificationForm :: Maybe NotificationSettings -> AForm Handler NotificationSettings
notificationForm template = wFormToAForm $ do
mbUid <- liftHandler maybeAuthId
isAdmin <- lift . lift $ hasReadAccessTo AdminR
isAdmin <- checkAdmin
let
sectionIsHidden :: NotificationTriggerKind -> DB Bool
@ -370,13 +369,13 @@ validateSettings User{..} = do
userPrefersPostal' <- use _stgPrefersPostal
guardValidation MsgUserPrefersPostalInvalid $
not $ userPrefersPostal' && postalNotSet
not $ userPrefersPostal' && (postalNotSet || isJust userCompanyDepartment)
userPinPassword' <- use _stgPinPassword
let pinBad = validCmdArgument =<< userPinPassword'
pinMinChar = 5
pinLength = maybe 0 length userPinPassword'
pinOk <- if userPrefersPostal' || pinMinChar <= pinLength then pure True else liftHandler $ hasReadAccessTo AdminR -- admins are allowed to ignore pin requirements
pinOk <- if userPrefersPostal' || pinMinChar <= pinLength then pure True else checkAdmin -- admins are allowed to ignore pin requirements
whenIsJust pinBad (tellValidationError . MsgPDFPasswordInvalid) -- used as CMD argument for pdftk
guardValidation (MsgPDFPasswordTooShort pinMinChar) pinOk
@ -450,9 +449,12 @@ serveProfileR (uid, user@User{..}) = do
formResult res $ \SettingsForm{..} -> do
now <- liftIO getCurrentTime
isAdmin <- checkAdmin
thisUser <- fromMaybe uid <$> maybeAuthId
let changeEmailByUser = userDisplayEmail /= stgDisplayEmail && (not isAdmin || thisUser == uid)
runDBJobs $ do
update uid $
[ UserDisplayEmail =. stgDisplayEmail | userDisplayEmail == stgDisplayEmail ] ++ -- Note that DisplayEmail changes must be confirmed, see 472
[ UserDisplayEmail =. stgDisplayEmail | not changeEmailByUser ] ++ -- DisplayEmail changes by Users must be confirmed, see 480 below
[ UserPostLastUpdate =. Just now | userPostAddress /= stgPostAddress ] ++
[ UserDisplayName =. stgDisplayName
, UserMaxFavourites =. stgMaxFavourites
@ -472,7 +474,7 @@ serveProfileR (uid, user@User{..}) = do
, UserExamOfficeGetLabels =. (stgExamOfficeSettings & eosettingsGetLabels)
]
updateFavourites Nothing
when (stgDisplayEmail /= userDisplayEmail) $ do
when changeEmailByUser $ do
queueDBJob $ JobChangeUserDisplayEmail uid stgDisplayEmail
addMessageI Info $ MsgUserDisplayEmailChangeSent stgDisplayEmail
let

3
src/Handler/Qualification.hs
View File

@ -504,8 +504,7 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do
, dbParamsFormAttrs = []
, dbParamsFormSubmit = FormSubmit
, dbParamsFormAdditional
= renderAForm FormStandard
$ (, mempty) . First . Just
= renderAForm FormStandard $ (, mempty) . First . Just
<$> multiActionA acts (fslI MsgTableAction) Nothing
, dbParamsFormEvaluate = liftHandler . runFormPost
, dbParamsFormResult = id

54
src/Handler/Users.hs
View File

@ -101,7 +101,7 @@ postUsersR = do
(AdminUserR <$> encrypt uid)
(nameWidget userDisplayName userSurname)
, sortable (Just "matriculation") (i18nCell MsgTableMatrikelNr) $ \DBRow{ dbrOutput = entUsr } -> cellHasMatrikelnummerLinked entUsr
, sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \DBRow{ dbrOutput = Entity uid _ } -> flip (set' cellContents) mempty $ do -- why does sqlCell not work here? Mismatch "YesodDB UniWorX" and "RWST (Maybe (Env,FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX"
, sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \DBRow{ dbrOutput = Entity uid _ } -> flip (set' cellContents) mempty $ do -- why does sqlCell not work here? Mismatch "YesodDB UniWorX" and "RWST (Maybe (Env,FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX"
companies' <- liftHandler . runDB . E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do
E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid
@ -265,15 +265,9 @@ postUsersR = do
Just needle -> (E.castString (user E.^. UserEmail) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%))
E.||. (E.castString (user E.^. UserDisplayEmail) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%))
)
, ( "matriculation", FilterColumn $ \user (criteria :: Set.Set Text) -> if
| Set.null criteria -> E.true
| otherwise -> E.any (\c -> user E.^. UserMatrikelnummer `E.hasInfix` E.val c) criteria
)
, ( "personal-number", FilterColumn $ \user (criteria :: Set.Set Text) -> if
| Set.null criteria -> E.true -- TODO: why can this be eFalse and work still?
| otherwise -> E.any (\c -> user E.^. UserCompanyPersonalNumber `E.hasInfix` E.val c) criteria
)
, ( "company-department", FilterColumn $ \user (criteria :: Set.Set Text) -> if
, ( "personal-number" , FilterColumn . E.mkContainsFilterWithComma Just $ (E.^. UserCompanyPersonalNumber))
, ( "matriculation" , FilterColumn . E.mkContainsFilterWithComma Just $ (E.^. UserMatrikelnummer)) -- allows partial matches
, ( "company-department", FilterColumn $ \user (criteria :: Set.Set Text) -> if -- exact filter on table UserAvs
| Set.null criteria -> E.true -- TODO: why can this be eFalse and work still?
| otherwise -> E.any (\c -> user E.^. UserCompanyDepartment `E.hasInfix` E.val c) criteria
)
@ -312,26 +306,32 @@ postUsersR = do
E.where_ $ (spvr E.^. UserSupervisorUser E.==. user E.^.UserId)
E.&&. E.any (E.hasInfix (usrSpvr E.^. UserDisplayName)) (E.val <$> Set.toList criteria)
)
, ( "avs-number", FilterColumn $ E.mkExistsFilter $ \user criterion ->
E.from $ \usrAvs -> -- do
E.where_ $ usrAvs E.^. UserAvsUser E.==. user 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))) )
-- , ( "avs-number", FilterColumn $ E.mkExistsFilterWithComma CI.mk $ \user criterion -> -- note that this is an exact filter
-- E.from $ \usrAvs -> -- do
-- E.where_ $ user E.^. UserId E.==. usrAvs E.^. UserAvsUser
-- E.&&. ((E.val criterion :: E.SqlExpr (E.Value (CI Text))) E.==.
-- (E.explicitUnsafeCoerceSqlExprValue "citext" (usrAvs E.^. UserAvsNoPerson) :: E.SqlExpr (E.Value (CI Text))) )
-- )
, ( "is-supervisor", FilterColumn $ \user criterion -> case criterion of
Last (Just True) -> E.exists . E.from $ \usrSpr -> E.where_ $ user E.^. UserId E.==. usrSpr E.^. UserSupervisorSupervisor
Last (Just False) -> E.notExists . E.from $ \usrSpr -> E.where_ $ user E.^. UserId E.==. usrSpr E.^. UserSupervisorSupervisor
_ -> E.val True :: E.SqlExpr (E.Value Bool)
)
]
, dbtFilterUI = \mPrev -> mconcat
[ prismAForm (singletonFilter "user-search") mPrev $ aopt textField (fslI MsgName)
, prismAForm (singletonFilter "user-ident") mPrev $ aopt textField (fslI MsgAdminUserIdent)
, prismAForm (singletonFilter "user-email") mPrev $ aopt textField (fslI MsgAdminUserEmail)
-- , prismAForm (singletonFilter "matriculation") mPrev $ aopt matriculationField (fslI MsgTableMatrikelNr)
, prismAForm (singletonFilter "personal-number" ) mPrev $ aopt textField (fslI MsgCompanyPersonalNumber)
, prismAForm (singletonFilter "avs-number" ) mPrev $ aopt textField (fslI MsgAvsPersonNo)
, prismAForm (singletonFilter "company-department" ) mPrev $ aopt textField (fslI MsgCompanyDepartment)
, prismAForm (singletonFilter "user-company") mPrev $ aopt textField (fslI MsgTableCompany)
, prismAForm (singletonFilter "user-supervisor") mPrev $ aopt textField (fslI MsgTableSupervisor)
, prismAForm (singletonFilter "auth-ldap" . maybePrism _PathPiece) mPrev $ aopt (lift `hoistField` selectFieldList [(MsgAuthPWHash "", False), (MsgAuthLDAP, True)]) (fslI MsgAuthMode)
, prismAForm (singletonFilter "school") mPrev $ aopt (lift `hoistField` selectFieldList schoolOptions) (fslI MsgCourseSchool)
, prismAForm (singletonFilter "ldap-sync" . maybePrism _PathPiece) mPrev $ aopt utcTimeField (fslI MsgLdapSyncedBefore)
[ prismAForm (singletonFilter "user-search") mPrev $ aopt textField (fslI MsgName)
, prismAForm (singletonFilter "user-ident") mPrev $ aopt textField (fslI MsgAdminUserIdent)
, prismAForm (singletonFilter "user-email") mPrev $ aopt textField (fslI MsgAdminUserEmail)
, prismAForm (singletonFilter "personal-number" ) mPrev $ aopt textField (fslI MsgCompanyPersonalNumber & setTooltip MsgTableFilterCommaPlus)
, prismAForm (singletonFilter "matriculation") mPrev $ aopt matriculationField (fslI MsgTableMatrikelNr & setTooltip MsgTableFilterCommaPlus) -- contains filter on UserMatrikelnummer
-- , prismAForm (singletonFilter "avs-number" ) mPrev $ aopt textField (fslI MsgAvsPersonNo & setTooltip MsgTableFilterCommaPlus) -- exact filter on table UserAvs
, prismAForm (singletonFilter "company-department") mPrev $ aopt textField (fslI MsgCompanyDepartment)
, prismAForm (singletonFilter "user-company") mPrev $ aopt textField (fslI MsgTableCompany)
, prismAForm (singletonFilter "user-supervisor") mPrev $ aopt textField (fslI MsgTableSupervisor)
, prismAForm (singletonFilter "school") mPrev $ aopt (lift `hoistField` selectFieldList schoolOptions) (fslI MsgCourseSchool)
, prismAForm (singletonFilter "is-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgUserIsSupervisor)
, prismAForm (singletonFilter "auth-ldap" . maybePrism _PathPiece) mPrev $ aopt (lift `hoistField` selectFieldList [(MsgAuthPWHash "", False), (MsgAuthLDAP, True)]) (fslI MsgAuthMode)
, prismAForm (singletonFilter "ldap-sync" . maybePrism _PathPiece) mPrev $ aopt utcTimeField (fslI MsgLdapSyncedBefore)
]
, dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
, dbtParams = DBParamsForm

4
src/Handler/Utils.hs
View File

@ -38,6 +38,10 @@ import Handler.Utils.Term as Handler.Utils
import Control.Monad.Logger
-- | default check if the user an active admin
checkAdmin :: (MonadHandler m, MonadAP (HandlerFor (HandlerSite m) )) => m Bool
checkAdmin = liftHandler $ hasReadAccessTo AdminR
-- | Prefix a message with a short course id,
-- eg. for window title bars, etc.

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

@ -753,6 +753,25 @@ sortUserCompany queryUser = ( "user-company"
return (comp E.^. CompanyName)
))
-- | Search companies by name, shorthand oder AVS nr
fltrCompanyNameNr :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)), IsString d)
=> (a -> E.SqlExpr (Entity Company))
-> (d, FilterColumn t fs)
fltrCompanyNameNr query = ( "company-name-number", FilterColumn $ anyFilter
[ mkContainsFilterWithCommaPlus CI.mk $ query >>> (E.^. CompanyName)
, mkContainsFilterWithCommaPlus CI.mk $ query >>> (E.^. CompanyShorthand)
, mkContainsFilterWithCommaPlus id $ query >>> (E.num2text . (E.^. CompanyAvsId))
]
)
fltrCompanyNameNrUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text])
fltrCompanyNameNrUI = fltrCompanyNameNrHdrUI MsgTableCompanyFilter
fltrCompanyNameNrHdrUI :: (RenderMessage UniWorX msg) => msg -> Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text])
fltrCompanyNameNrHdrUI msg mPrev =
prismAForm (singletonFilter "company-name-number") mPrev $ aopt textField (fslI msg & setTooltip MsgTableFilterCommaPlus)
----------------------------
-- Colonnade manipulation --

14
src/Handler/Utils/Table/Pagination.hs
View File

@ -1,10 +1,20 @@
-- SPDX-FileCopyrightText: 2022 Felix Hamann <felix.hamann@campus.lmu.de>,Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@cip.ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
-- SPDX-FileCopyrightText: 2022-23 Felix Hamann <felix.hamann@campus.lmu.de>,Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@cip.ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>,Steffen Jost <s.jost@fraport.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
{- FOP - Frequently occurring problems using dbTable:
- When changing a dbTable to a form, eg. using `dbSelect` then change the colonnade defnition from `dbColonnade` to `formColonnade`!
Both functions are equal to id, but the types are quite different.
- Don't mix up the row type alias traditionally ending with ...Data and the Action-Result-Type also ending with ...Data
-}
module Handler.Utils.Table.Pagination
( module Handler.Utils.Table.Pagination.Types
, dbFilterKey
@ -1654,10 +1664,12 @@ widgetColonnade :: Colonnade h r (DBCell (HandlerFor UniWorX) x)
-> Colonnade h r (DBCell (HandlerFor UniWorX) x)
widgetColonnade = id
-- | force the column list type for tables that cotain forms, especially those constructed with dbSelect, avoids explicit type signatures
formColonnade :: Colonnade h r (DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX)) (FormResult a))
-> Colonnade h r (DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX)) (FormResult a))
formColonnade = id
-- | force the column list type for simple tables that do not contain forms, and especially no dbSelect, avoids explicit type signatures
dbColonnade :: Colonnade h r (DBCell DB x)
-> Colonnade h r (DBCell DB x)
dbColonnade = id