Merge branch 'fradrive/company' into test
This commit is contained in:
commit
45048ce62d
7
messages/uniworx/categories/firm/de-de-formal.msg
Normal file
7
messages/uniworx/categories/firm/de-de-formal.msg
Normal 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
6
messages/uniworx/categories/firm/en-eu.msg
Normal 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
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
2
routes
@ -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
|
||||
|
||||
@ -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"
|
||||
|
||||
|
||||
@ -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"
|
||||
|
||||
@ -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,8 +35,8 @@ 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
|
||||
@ -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
|
||||
@ -180,7 +188,7 @@ firmCountActiveReroutes' cmpy = E.subSelectCount $ do
|
||||
E.&&. usrSuper E.^. UserSupervisorRerouteNotifications
|
||||
|
||||
|
||||
mkFirmAllTable :: Bool -> UserId -> DB (Any, Widget)
|
||||
mkFirmAllTable :: Bool -> UserId -> DB (FormResult (FirmAllActionData, Set CompanyId), Widget)
|
||||
mkFirmAllTable isAdmin uid = do
|
||||
-- now <- liftIO getCurrentTime
|
||||
let
|
||||
@ -190,7 +198,7 @@ mkFirmAllTable isAdmin uid = 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,17 +209,19 @@ 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) ->
|
||||
, 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
|
||||
@ -229,28 +239,78 @@ 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"
|
||||
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
|
||||
@ -260,6 +320,10 @@ postFirmUsersR fsh = do
|
||||
setTitle $ citext2Html fsh
|
||||
[whamlet|!!!STUB!!!TO DO!!!|]
|
||||
|
||||
|
||||
-----------------------------
|
||||
-- Firm Supervisors Table
|
||||
|
||||
getFirmSupersR, postFirmSupersR :: CompanyShorthand -> Handler Html
|
||||
getFirmSupersR = postFirmSupersR
|
||||
postFirmSupersR fsh = do
|
||||
|
||||
@ -359,9 +359,8 @@ data LmsTableAction = LmsActNotify
|
||||
| LmsActReset
|
||||
| LmsActRestart
|
||||
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
|
||||
deriving anyclass (Universe, Finite)
|
||||
|
||||
instance Universe LmsTableAction
|
||||
instance Finite LmsTableAction
|
||||
nullaryPathPiece ''LmsTableAction $ camelToPathPiece' 2
|
||||
embedRenderMessage ''UniWorX ''LmsTableAction id
|
||||
|
||||
|
||||
@ -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))
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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.
|
||||
|
||||
@ -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 --
|
||||
|
||||
@ -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
|
||||
|
||||
Reference in New Issue
Block a user