fraport/fradrive-old
Archived
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 UserAddSupervisor: Ansprechpartner hinzufügen
UserSetSupervisor: Ansprechpartner ersetzen UserSetSupervisor: Ansprechpartner ersetzen
UserRemoveSupervisor: Alle Ansprechpartner entfernen UserRemoveSupervisor: Alle Ansprechpartner entfernen
UserIsSupervisor: Ist Ansprechpartner
AuthKindLDAP: Fraport AG Kennung AuthKindLDAP: Fraport AG Kennung
AuthKindPWHash: FRADrive Kennung AuthKindPWHash: FRADrive Kennung
AuthKindNoLogin: Kein Login möglich 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 UserAddSupervisor: Add supervisor
UserSetSupervisor: Replace supervisors UserSetSupervisor: Replace supervisors
UserRemoveSupervisor: Set to unsupervised UserRemoveSupervisor: Set to unsupervised
UserIsSupervisor: Is supervisor
AuthKindLDAP: Fraport AG account AuthKindLDAP: Fraport AG account
AuthKindPWHash: FRADrive account AuthKindPWHash: FRADrive account
AuthKindNoLogin: No login 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 TableCourseSchool: Bereich
TableSubmissionGroup: Feste Abgabegruppe TableSubmissionGroup: Feste Abgabegruppe
TableNoSubmissionGroup: Keine feste Abgabegruppe TableNoSubmissionGroup: Keine feste Abgabegruppe
TableMatrikelNr: AVS Nr TableMatrikelNr: AVS Personennummer
TableSex: Geschlecht TableSex: Geschlecht
TableBirthday: Geburtsdatum TableBirthday: Geburtsdatum
TableSchool: Bereich TableSchool: Bereich
@ -75,12 +75,15 @@ TableExamOfficeLabelStatus: Label-Farbe
TableExamOfficeLabelPriority: Label-Priorität TableExamOfficeLabelPriority: Label-Priorität
TableQualifications: Qualifikationen TableQualifications: Qualifikationen
TableCompany: Firma TableCompany: Firma
TableCompanyFilter: Firma oder Nummer
TableCompanyShort: Firmenkürzel TableCompanyShort: Firmenkürzel
TableCompanies: Firmen TableCompanies: Firmen
TableCompanyNo: Firmennummer TableCompanyNo: Firmennummer
TableCompanyNos: Firmennummern TableCompanyNos: Firmennummern
TableCompanyNrUsers: Firmenangehörige TableCompanyNrUsers: Firmenangehörige
TableCompanyNrSupers: Ansprechpartner TableCompanyNrSupers: Ansprechpartner
TableCompanyNrSupersActive: Mitarbeiter mit Ansprechpartner
TableCompanyNrSupersDefault: Standard Ansprechpartner
TableCompanyNrForeignSupers: Firmenfremde Ansprechpartner TableCompanyNrForeignSupers: Firmenfremde Ansprechpartner
TableCompanyNrRerouteDefault: Standard Umleitungen TableCompanyNrRerouteDefault: Standard Umleitungen
TableCompanyNrRerouteActive: Aktive Umleitungen TableCompanyNrRerouteActive: Aktive Umleitungen

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

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

2
routes
View File

@ -113,7 +113,7 @@
/for/#CryptoUUIDUser/user ForProfileR GET POST !supervisor !self /for/#CryptoUUIDUser/user ForProfileR GET POST !supervisor !self
/for/#CryptoUUIDUser/user/profile ForProfileDataR GET !supervisor !self /for/#CryptoUUIDUser/user/profile ForProfileDataR GET !supervisor !self
/firm FirmAllR GET /firm FirmAllR GET POST
/firm/#CompanyShorthand FirmR GET POST /firm/#CompanyShorthand FirmR GET POST
/firm/#CompanyShorthand/users FirmUsersR GET POST /firm/#CompanyShorthand/users FirmUsersR GET POST
/firm/#CompanyShorthand/supers FirmSupersR 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 , mkContainsFilter, mkContainsFilterWith
, mkContainsFilterWithSet, mkContainsFilterWithComma, mkContainsFilterWithCommaPlus , mkContainsFilterWithSet, mkContainsFilterWithComma, mkContainsFilterWithCommaPlus
, mkDayFilter, mkDayFilterFrom, mkDayFilterTo , mkDayFilter, mkDayFilterFrom, mkDayFilterTo
, mkExistsFilter , mkExistsFilter, mkExistsFilterWithComma
, anyFilter, allFilter , anyFilter, allFilter
, ascNullsFirst, descNullsLast , ascNullsFirst, descNullsLast
, orderByList , orderByList
@ -46,6 +46,7 @@ module Database.Esqueleto.Utils
, subSelectCountDistinct , subSelectCountDistinct
, selectCountRows, selectCountDistinct , selectCountRows, selectCountDistinct
, selectMaybe , selectMaybe
, num2text
, day, day', dayMaybe, interval, diffDays, diffTimes , day, day', dayMaybe, interval, diffDays, diffTimes
, exprLift , exprLift
, explicitUnsafeCoerceSqlExprValue , explicitUnsafeCoerceSqlExprValue
@ -422,6 +423,17 @@ mkExistsFilter query row criterias
| Set.null criterias = true | Set.null criterias = true
| otherwise = any (E.exists . query row) $ Set.toList criterias | 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 -- | Combine several filters, using logical or
anyFilter :: Foldable f anyFilter :: Foldable f
=> f (t -> cs -> E.SqlExpr (E.Value Bool)) => 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 :: (E.SqlSelect a r, MonadIO m) => E.SqlQuery a -> E.SqlReadT m (Maybe r)
selectMaybe = fmap listToMaybe . E.select . (<* E.limit 1) 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.SqlExpr (E.Value UTCTime) -> E.SqlExpr (E.Value Day)
day = E.unsafeSqlCastAs "date" day = E.unsafeSqlCastAs "date"
-- | cast text to day, truly unsafe
day' :: E.SqlExpr (E.Value Text) -> E.SqlExpr (E.Value Day) day' :: E.SqlExpr (E.Value Text) -> E.SqlExpr (E.Value Day)
day' = E.unsafeSqlCastAs "date" 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 -- 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 #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-orphans #-}
@ -20,6 +25,7 @@ module Foundation.I18n
, UniWorXI18nMessage(..),UniWorXJobsHandlerMessage(..), UniWorXModelTypesMessage(..), UniWorXYesodMiddlewareMessage(..) , UniWorXI18nMessage(..),UniWorXJobsHandlerMessage(..), UniWorXModelTypesMessage(..), UniWorXYesodMiddlewareMessage(..)
, UniWorXQualificationMessage(..) , UniWorXQualificationMessage(..)
, UniWorXPrintMessage(..) , UniWorXPrintMessage(..)
, UniWorXFirmMessage(..)
, UniWorXAvsMessage(..) , UniWorXAvsMessage(..)
, UniWorXAuthorshipStatementMessage(..) , UniWorXAuthorshipStatementMessage(..)
, ShortTermIdentifier(..) , 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 "YesodMiddleware" "messages/uniworx/categories/yesod_middleware" "de-de-formal"
mkMessageAddition ''UniWorX "User" "messages/uniworx/categories/user" "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 "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 "Button" "messages/uniworx/utils/buttons" "de-de-formal"
mkMessageAddition ''UniWorX "Form" "messages/uniworx/utils/handler_form" "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" mkMessageAddition ''UniWorX "TableColumn" "messages/uniworx/utils/table_column" "de-de-formal"

316
src/Handler/Firm.hs
View File

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

5
src/Handler/LMS.hs
View File

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

6
src/Handler/PrintCenter.hs
View File

@ -225,9 +225,9 @@ mkPJTable = do
dbtFilter = mconcat dbtFilter = mconcat
[ single ("name" , FilterColumn . E.mkContainsFilterWithCommaPlus id $ views (to queryPrintJob) (E.^. PrintJobName)) [ single ("name" , FilterColumn . E.mkContainsFilterWithCommaPlus id $ views (to queryPrintJob) (E.^. PrintJobName))
, single ("apcid" , FilterColumn . E.mkContainsFilterWithComma id $ views (to queryPrintJob) (E.^. PrintJobApcIdent)) , single ("apcid" , FilterColumn . E.mkContainsFilterWithComma id $ views (to queryPrintJob) (E.^. PrintJobApcIdent))
, single ("filename" , FilterColumn . E.mkContainsFilter $ views (to queryPrintJob) (E.^. PrintJobFilename)) , single ("filename" , FilterColumn . E.mkContainsFilter $ views (to queryPrintJob) (E.^. PrintJobFilename))
, single ("created" , FilterColumn . E.mkDayFilter $ views (to queryPrintJob) (E.^. PrintJobCreated)) , single ("created" , FilterColumn . E.mkDayFilter $ views (to queryPrintJob) (E.^. PrintJobCreated))
--, single ("created" , FilterColumn . E.mkDayBetweenFilter $ 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 ("recipient" , FilterColumn . E.mkContainsFilterWithCommaPlus Just $ views (to queryRecipient) (E.?. UserDisplayName))
, single ("sender" , FilterColumn . E.mkContainsFilterWithCommaPlus Just $ views (to querySender) (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 ("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 where
mr = renderMessage f ls mr = renderMessage f ls
makeSettingForm :: Maybe SettingsForm -> Form SettingsForm makeSettingForm :: Maybe SettingsForm -> Form SettingsForm
makeSettingForm template html = do makeSettingForm template html = do
MsgRenderer mr <- getMsgRenderer MsgRenderer mr <- getMsgRenderer
@ -169,7 +168,7 @@ schoolsForm template = formToAForm $ schoolsFormView =<< renderWForm FormStandar
notificationForm :: Maybe NotificationSettings -> AForm Handler NotificationSettings notificationForm :: Maybe NotificationSettings -> AForm Handler NotificationSettings
notificationForm template = wFormToAForm $ do notificationForm template = wFormToAForm $ do
mbUid <- liftHandler maybeAuthId mbUid <- liftHandler maybeAuthId
isAdmin <- lift . lift $ hasReadAccessTo AdminR isAdmin <- checkAdmin
let let
sectionIsHidden :: NotificationTriggerKind -> DB Bool sectionIsHidden :: NotificationTriggerKind -> DB Bool
@ -370,13 +369,13 @@ validateSettings User{..} = do
userPrefersPostal' <- use _stgPrefersPostal userPrefersPostal' <- use _stgPrefersPostal
guardValidation MsgUserPrefersPostalInvalid $ guardValidation MsgUserPrefersPostalInvalid $
not $ userPrefersPostal' && postalNotSet not $ userPrefersPostal' && (postalNotSet || isJust userCompanyDepartment)
userPinPassword' <- use _stgPinPassword userPinPassword' <- use _stgPinPassword
let pinBad = validCmdArgument =<< userPinPassword' let pinBad = validCmdArgument =<< userPinPassword'
pinMinChar = 5 pinMinChar = 5
pinLength = maybe 0 length userPinPassword' 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 whenIsJust pinBad (tellValidationError . MsgPDFPasswordInvalid) -- used as CMD argument for pdftk
guardValidation (MsgPDFPasswordTooShort pinMinChar) pinOk guardValidation (MsgPDFPasswordTooShort pinMinChar) pinOk
@ -450,9 +449,12 @@ serveProfileR (uid, user@User{..}) = do
formResult res $ \SettingsForm{..} -> do formResult res $ \SettingsForm{..} -> do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
isAdmin <- checkAdmin
thisUser <- fromMaybe uid <$> maybeAuthId
let changeEmailByUser = userDisplayEmail /= stgDisplayEmail && (not isAdmin || thisUser == uid)
runDBJobs $ do runDBJobs $ do
update uid $ 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 ] ++ [ UserPostLastUpdate =. Just now | userPostAddress /= stgPostAddress ] ++
[ UserDisplayName =. stgDisplayName [ UserDisplayName =. stgDisplayName
, UserMaxFavourites =. stgMaxFavourites , UserMaxFavourites =. stgMaxFavourites
@ -472,7 +474,7 @@ serveProfileR (uid, user@User{..}) = do
, UserExamOfficeGetLabels =. (stgExamOfficeSettings & eosettingsGetLabels) , UserExamOfficeGetLabels =. (stgExamOfficeSettings & eosettingsGetLabels)
] ]
updateFavourites Nothing updateFavourites Nothing
when (stgDisplayEmail /= userDisplayEmail) $ do when changeEmailByUser $ do
queueDBJob $ JobChangeUserDisplayEmail uid stgDisplayEmail queueDBJob $ JobChangeUserDisplayEmail uid stgDisplayEmail
addMessageI Info $ MsgUserDisplayEmailChangeSent stgDisplayEmail addMessageI Info $ MsgUserDisplayEmailChangeSent stgDisplayEmail
let let

3
src/Handler/Qualification.hs
View File

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

54
src/Handler/Users.hs
View File

@ -101,7 +101,7 @@ postUsersR = do
(AdminUserR <$> encrypt uid) (AdminUserR <$> encrypt uid)
(nameWidget userDisplayName userSurname) (nameWidget userDisplayName userSurname)
, sortable (Just "matriculation") (i18nCell MsgTableMatrikelNr) $ \DBRow{ dbrOutput = entUsr } -> cellHasMatrikelnummerLinked entUsr , 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 companies' <- liftHandler . runDB . E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do
E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid 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.%)) 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.%)) E.||. (E.castString (user E.^. UserDisplayEmail) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%))
) )
, ( "matriculation", FilterColumn $ \user (criteria :: Set.Set Text) -> if , ( "personal-number" , FilterColumn . E.mkContainsFilterWithComma Just $ (E.^. UserCompanyPersonalNumber))
| Set.null criteria -> E.true , ( "matriculation" , FilterColumn . E.mkContainsFilterWithComma Just $ (E.^. UserMatrikelnummer)) -- allows partial matches
| otherwise -> E.any (\c -> user E.^. UserMatrikelnummer `E.hasInfix` E.val c) criteria , ( "company-department", FilterColumn $ \user (criteria :: Set.Set Text) -> if -- exact filter on table UserAvs
)
, ( "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
| Set.null criteria -> E.true -- TODO: why can this be eFalse and work still? | 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 | 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.where_ $ (spvr E.^. UserSupervisorUser E.==. user E.^.UserId)
E.&&. E.any (E.hasInfix (usrSpvr E.^. UserDisplayName)) (E.val <$> Set.toList criteria) E.&&. E.any (E.hasInfix (usrSpvr E.^. UserDisplayName)) (E.val <$> Set.toList criteria)
) )
, ( "avs-number", FilterColumn $ E.mkExistsFilter $ \user criterion -> -- , ( "avs-number", FilterColumn $ E.mkExistsFilterWithComma CI.mk $ \user criterion -> -- note that this is an exact filter
E.from $ \usrAvs -> -- do -- E.from $ \usrAvs -> -- do
E.where_ $ usrAvs E.^. UserAvsUser E.==. user E.^.UserId -- E.where_ $ user E.^. UserId E.==. usrAvs E.^. UserAvsUser
E.&&. ((E.val criterion :: E.SqlExpr (E.Value (CI Text))) E.==. -- E.&&. ((E.val criterion :: E.SqlExpr (E.Value (CI Text))) E.==.
(E.explicitUnsafeCoerceSqlExprValue "citext" (usrAvs E.^. UserAvsNoPerson) :: E.SqlExpr (E.Value (CI Text))) ) -- (E.explicitUnsafeCoerceSqlExprValue "citext" (usrAvs E.^. UserAvsNoPerson) :: E.SqlExpr (E.Value (CI Text))) )
-- )
, ( "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 , dbtFilterUI = \mPrev -> mconcat
[ prismAForm (singletonFilter "user-search") mPrev $ aopt textField (fslI MsgName) [ prismAForm (singletonFilter "user-search") mPrev $ aopt textField (fslI MsgName)
, prismAForm (singletonFilter "user-ident") mPrev $ aopt textField (fslI MsgAdminUserIdent) , prismAForm (singletonFilter "user-ident") mPrev $ aopt textField (fslI MsgAdminUserIdent)
, prismAForm (singletonFilter "user-email") mPrev $ aopt textField (fslI MsgAdminUserEmail) , 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 & setTooltip MsgTableFilterCommaPlus)
, prismAForm (singletonFilter "personal-number" ) mPrev $ aopt textField (fslI MsgCompanyPersonalNumber) , prismAForm (singletonFilter "matriculation") mPrev $ aopt matriculationField (fslI MsgTableMatrikelNr & setTooltip MsgTableFilterCommaPlus) -- contains filter on UserMatrikelnummer
, prismAForm (singletonFilter "avs-number" ) mPrev $ aopt textField (fslI MsgAvsPersonNo) -- , 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 "company-department") mPrev $ aopt textField (fslI MsgCompanyDepartment)
, prismAForm (singletonFilter "user-company") mPrev $ aopt textField (fslI MsgTableCompany) , prismAForm (singletonFilter "user-company") mPrev $ aopt textField (fslI MsgTableCompany)
, prismAForm (singletonFilter "user-supervisor") mPrev $ aopt textField (fslI MsgTableSupervisor) , 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 "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 "ldap-sync" . maybePrism _PathPiece) mPrev $ aopt utcTimeField (fslI MsgLdapSyncedBefore) , 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 } , dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
, dbtParams = DBParamsForm , dbtParams = DBParamsForm

4
src/Handler/Utils.hs
View File

@ -38,6 +38,10 @@ import Handler.Utils.Term as Handler.Utils
import Control.Monad.Logger 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, -- | Prefix a message with a short course id,
-- eg. for window title bars, etc. -- 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) 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 -- -- 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 -- SPDX-License-Identifier: AGPL-3.0-or-later
{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} {-# 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
( module Handler.Utils.Table.Pagination.Types ( module Handler.Utils.Table.Pagination.Types
, dbFilterKey , dbFilterKey
@ -1654,10 +1664,12 @@ widgetColonnade :: Colonnade h r (DBCell (HandlerFor UniWorX) x)
-> Colonnade h r (DBCell (HandlerFor UniWorX) x) -> Colonnade h r (DBCell (HandlerFor UniWorX) x)
widgetColonnade = id 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)) 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)) -> Colonnade h r (DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX)) (FormResult a))
formColonnade = id 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) dbColonnade :: Colonnade h r (DBCell DB x)
-> Colonnade h r (DBCell DB x) -> Colonnade h r (DBCell DB x)
dbColonnade = id dbColonnade = id