Merge branch 'fradrive/company' into test

messages/uniworx/categories/firm/de-de-formal.msg

@@ -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
+

messages/uniworx/categories/firm/en-eu.msg

@@ -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

messages/uniworx/categories/user/de-de-formal.msg

@@ -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

messages/uniworx/categories/user/en-eu.msg

@@ -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

messages/uniworx/utils/table_column/de-de-formal.msg

@@ -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

messages/uniworx/utils/table_column/en-eu.msg

@@ -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

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

src/Database/Esqueleto/Utils.hs

@@ -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"
 

src/Foundation/I18n.hs

@@ -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"

src/Handler/Firm.hs

@@ -19,11 +19,11 @@ import Import
 -- import Jobs
 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.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 :: (k,a) -> Map k a
--- single = uncurry Map.singleton
+single = uncurry Map.singleton
 
 
 getFirmR,  postFirmR :: CompanyShorthand -> Handler Html
@@ -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)
+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
+        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
-          , 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"]
+      & 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
@@ -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

src/Handler/LMS.hs

@@ -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
 

src/Handler/PrintCenter.hs

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

src/Handler/Profile.hs

@@ -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

src/Handler/Qualification.hs

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

src/Handler/Users.hs

@@ -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
+          , ( "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?
                  | 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 ->
+          -- , ( "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
-          [ 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 }
       , dbtParams    = DBParamsForm

src/Handler/Utils.hs

@@ -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.

src/Handler/Utils/Table/Columns.hs

@@ -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 --

src/Handler/Utils/Table/Pagination.hs

@@ -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