From be527ada321b6f3c4fe08e44a4ca11a1bb39eea3 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 6 Oct 2023 15:07:34 +0000 Subject: [PATCH 01/50] refactor: minor code cleaning --- src/Jobs/Handler/LMS.hs | 9 ++++----- src/Jobs/Handler/SendNotification/Qualification.hs | 10 +++++----- 2 files changed, 9 insertions(+), 10 deletions(-) diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index 1b6cf4359..827f44496 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -197,14 +197,13 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act luser E.?. LmsUserUser E.?=. quser E.^. QualificationUserUser E.&&. luser E.?. LmsUserQualification E.?=. quser E.^. QualificationUserQualification) E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid - -- E.&&. luser E.?. LmsUserQualification E.?=. E.val qid + -- E.&&. luser E.?. LmsUserQualification E.?=. E.val qid -- E.&&. E.isNothing (luser E.^. LmsUserStatus) -- E.&&. E.isNothing (luser E.^. LmsUserEnded) E.&&. E.not_ (validQualification now quser) - pure (luser E.?. LmsUserId, quser E.^. QualificationUserUser) - nrBlocked <- qualificationUserBlocking qid (E.unValue . snd <$> expiredUsers) False (Just now) (Right QualificationBlockExpired) True -- essential that blocks occur only once - let expiredLearners = [ luid | (E.Value (Just luid), _) <- expiredUsers ] - -- let expiredLearners = catMaybes (E.unValue . fst <$> expiredUsers) + pure (quser E.^. QualificationUserUser, luser E.?. LmsUserId) + nrBlocked <- qualificationUserBlocking qid (E.unValue . fst <$> expiredUsers) False (Just now) (Right QualificationBlockExpired) True -- essential that blocks occur only once + let expiredLearners = [luid | (_, E.Value (Just luid)) <- expiredUsers] nrExpired <- E.updateCount $ \luser -> do E.set luser [LmsUserStatus E.=. E.justVal LmsExpired, LmsUserStatusDay E.=. E.justVal now] E.where_ $ E.isNothing (luser E.^. LmsUserStatus) diff --git a/src/Jobs/Handler/SendNotification/Qualification.hs b/src/Jobs/Handler/SendNotification/Qualification.hs index d5338acf6..d5d8d595e 100644 --- a/src/Jobs/Handler/SendNotification/Qualification.hs +++ b/src/Jobs/Handler/SendNotification/Qualification.hs @@ -60,7 +60,7 @@ dispatchNotificationQualificationExpired nQualification jRecipient = do let expDay = maybe qualificationUserValidUntil (min qualificationUserValidUntil . utctDay . qualificationUserBlockFrom) block qname = CI.original qualificationName qshort = CI.original qualificationShorthand - letter = LetterExpireQualification + letter = LetterExpireQualification { leqHolderCFN = encRecShort , leqHolderID = jRecipient , leqHolderDN = userDisplayName @@ -72,14 +72,14 @@ dispatchNotificationQualificationExpired nQualification jRecipient = do , leqSchool = qualificationSchool , leqUrl = pure . urender $ ForProfileDataR encRecipient } - if expDay > utctDay qualificationUserLastNotified + if expDay > utctDay qualificationUserLastNotified then do notifyOk <- sendEmailOrLetter jRecipient letter if notifyOk - then do + then do runDB $ update quId [QualificationUserLastNotified =. now] $logInfoS "LMS" $ "Notified " <> tshow encRecipient <> " about expired qualification " <> qname - else + else $logErrorS "LMS" $ "Failed to notify " <> tshow encRecipient <> " about expired qualification " <> qname else $logErrorS "LMS" $ "Suppressed repeated notification " <> tshow encRecipient <> " about expired qualification " <> qname _ -> $logErrorS "LMS" $ "Failed to notify " <> tshow encRecipient <> " about expired qualification " <> tshow nQualification @@ -89,7 +89,7 @@ dispatchNotificationQualificationExpired nQualification jRecipient = do dispatchNotificationQualificationRenewal :: QualificationId -> Bool -> UserId -> Handler () dispatchNotificationQualificationRenewal nQualification nReminder jRecipient = do encRecipient :: CryptoUUIDUser <- encrypt jRecipient - query <- runDB $ (,,,) + query <- runDB $ (,,,) <$> get jRecipient <*> get nQualification <*> getBy (UniqueQualificationUser nQualification jRecipient) From 9caf2af540c9c18e38bbbeb5c0b397e8b0a04f48 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 9 Oct 2023 07:24:01 +0000 Subject: [PATCH 02/50] chore(firm): initial stub --- .../utils/navigation/menu/de-de-formal.msg | 2 + .../uniworx/utils/navigation/menu/en-eu.msg | 2 + routes | 2 + src/Application.hs | 1 + src/Foundation/Navigation.hs | 3 + src/Handler/Firm.hs | 663 ++++++++++++++++++ 6 files changed, 673 insertions(+) create mode 100644 src/Handler/Firm.hs diff --git a/messages/uniworx/utils/navigation/menu/de-de-formal.msg b/messages/uniworx/utils/navigation/menu/de-de-formal.msg index 5ea9b7e59..9e1c55f5a 100644 --- a/messages/uniworx/utils/navigation/menu/de-de-formal.msg +++ b/messages/uniworx/utils/navigation/menu/de-de-formal.msg @@ -133,6 +133,8 @@ MenuLmsFake: Testnutzer generieren MenuLmsLearners: Export Benutzer E‑Learning MenuLmsReport: Ergebnisse E‑Learning +MenuFirms: Firmen + MenuSap: SAP Schnittstelle MenuAvs: AVS Schnittstelle diff --git a/messages/uniworx/utils/navigation/menu/en-eu.msg b/messages/uniworx/utils/navigation/menu/en-eu.msg index b4a66104d..6145f0d81 100644 --- a/messages/uniworx/utils/navigation/menu/en-eu.msg +++ b/messages/uniworx/utils/navigation/menu/en-eu.msg @@ -134,6 +134,8 @@ MenuLmsFake: Generate Test Users MenuLmsLearners: E‑learning Users MenuLmsReport: E‑learning Results +MenuFirms: Companies + MenuSap: SAP Interface MenuAvs: AVS Interface diff --git a/routes b/routes index 7a68b54e3..e7f9fc7b9 100644 --- a/routes +++ b/routes @@ -113,6 +113,8 @@ /for/#CryptoUUIDUser/user ForProfileR GET POST !supervisor !self /for/#CryptoUUIDUser/user/profile ForProfileDataR GET !supervisor !self +/firm FirmAllR GET +/firm/#CompanyShorthand FirmR GET POST /exam-office ExamOfficeR !exam-office: / EOExamsR GET POST !system-exam-office diff --git a/src/Application.hs b/src/Application.hs index 90d344bfd..45f24768e 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -159,6 +159,7 @@ import Handler.SAP import Handler.PrintCenter import Handler.ApiDocs import Handler.Swagger +import Handler.Firm import ServantApi () -- YesodSubDispatch instances import Servant.API diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index 1dbc9384a..9fce295f5 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -123,6 +123,9 @@ breadcrumb ProblemFbutNoR = i18nCrumb MsgProblemsRWithoutFHeading $ Just breadcrumb ProblemAvsSynchR = i18nCrumb MsgProblemsAvsSynchHeading $ Just AdminProblemsR breadcrumb ProblemAvsErrorR = i18nCrumb MsgProblemsAvsErrorHeading $ Just ProblemAvsSynchR +breadcrumb FirmAllR = i18nCrumb MsgMenuFirms Nothing +breadcrumb FirmR = i18nCrumb MsgMenuFirms $ Just FirmAllR + breadcrumb PrintCenterR = i18nCrumb MsgMenuApc Nothing breadcrumb PrintSendR = i18nCrumb MsgMenuPrintSend $ Just PrintCenterR breadcrumb PrintDownloadR{} = i18nCrumb MsgMenuPrintDownload $ Just PrintCenterR diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs new file mode 100644 index 000000000..5d640d603 --- /dev/null +++ b/src/Handler/Firm.hs @@ -0,0 +1,663 @@ +-- SPDX-FileCopyrightText: 2023 Steffen Jost +-- +-- SPDX-License-Identifier: AGPL-3.0-or-later + +{-# OPTIONS_GHC -fno-warn-orphans #-} -- needed for HasEntity instances +{-# LANGUAGE TypeApplications #-} + +module Handler.Firm + ( getFirmAllR + , getFirmR, postFirmR + ) + where + +import Import + +-- import Jobs +import Handler.Utils + +-- import qualified Data.Set as Set +-- import qualified Data.Map as Map +-- import qualified Data.Csv as Csv +-- import qualified Data.Text as T +-- import qualified Data.CaseInsensitive as CI +-- import qualified Data.Conduit.List as C +-- import Database.Persist.Sql (updateWhereCount) +-- import Database.Esqueleto.Experimental ((:&)(..)) +-- import qualified Database.Esqueleto.Experimental as Ex -- needs TypeApplications Lang-Pragma +-- import qualified Database.Esqueleto.Legacy as E +-- import qualified Database.Esqueleto.PostgreSQL as E +-- import qualified Database.Esqueleto.Utils as E +-- import Database.Esqueleto.Utils.TH + + +-- avoids repetition of local definitions +single :: (k,a) -> Map k a +single = uncurry Map.singleton + + +getFirmAllR :: Handler Html +getFirmAllR = do + siteLayoutMsg MsgMenuFirms $ do + setTitleI MsgMenuFirms + [whamlet|STUB TO DO|] + + +getFirmR, postFirmR :: CompanyShorthand -> Handler Html +getFirmR = postFirmR +postFirmR _ = do + siteLayoutMsg MsgMenuFirms $ do + setTitleI MsgMenuFirms + [whamlet|STUB TO DO|] + + +-- isAdmin <- hasReadAccessTo AdminR +-- firmTable <- runDB $ do +-- view _2 <$> mkFirmAllTable isAdmin +-- siteLayoutMsg MsgMenuFirms $ do +-- setTitleI MsgMenuFirms +-- $(widgetFile "firm-all") + +-- type AllQualificationTableData = DBRow (Entity Qualification, Ex.Value Word64, Ex.Value Word64) +-- resultAllQualification :: Lens' AllQualificationTableData Qualification +-- resultAllQualification = _dbrOutput . _1 . _entityVal + +-- resultAllQualificationActive :: Lens' AllQualificationTableData Word64 +-- resultAllQualificationActive = _dbrOutput . _2 . _unValue + +-- resultAllQualificationTotal :: Lens' AllQualificationTableData Word64 +-- resultAllQualificationTotal = _dbrOutput . _3 . _unValue + + +-- mkQualificationAllTable :: Bool -> DB (Any, Widget) +-- mkQualificationAllTable isAdmin = do +-- svs <- getSupervisees +-- now <- liftIO getCurrentTime +-- let +-- resultDBTable = DBTable{..} +-- where +-- dbtSQLQuery quali = do +-- let filterSvs quser = quser Ex.^. QualificationUserQualification Ex.==. quali Ex.^. QualificationId +-- Ex.&&. (E.val isAdmin E.||. quser Ex.^. QualificationUserUser `Ex.in_` E.vals svs) +-- cusers = Ex.subSelectCount $ do +-- quser <- Ex.from $ Ex.table @QualificationUser +-- Ex.where_ $ filterSvs quser +-- cactive = Ex.subSelectCount $ do +-- quser <- Ex.from $ Ex.table @QualificationUser +-- Ex.where_ $ filterSvs quser Ex.&&. validQualification now quser +-- return (quali, cactive, cusers) +-- dbtRowKey = (Ex.^. QualificationId) +-- dbtProj = dbtProjId +-- dbtColonnade = dbColonnade $ mconcat +-- [ colSchool $ resultAllQualification . _qualificationSchool +-- , sortable (Just "qshort") (i18nCell MsgQualificationShort) $ \(view resultAllQualification -> quali) -> +-- let qsh = qualificationShorthand quali in +-- anchorCell (QualificationR (qualificationSchool quali) qsh) $ toWgt qsh +-- , sortable (Just "qname") (i18nCell MsgQualificationName) $ \(view resultAllQualification -> quali) -> +-- let qsh = qualificationShorthand quali +-- qnm = qualificationName quali +-- in anchorCell (QualificationR (qualificationSchool quali) qsh) $ toWgt qnm +-- , sortable Nothing (i18nCell MsgQualificationDescription) $ \(view resultAllQualification -> quali) -> +-- maybeCell (qualificationDescription quali) markupCellLargeModal +-- , sortable Nothing (i18nCell MsgQualificationValidDuration & cellTooltip MsgTableDiffDaysTooltip) $ +-- foldMap (textCell . formatCalendarDiffDays . fromMonths) . view (resultAllQualification . _qualificationValidDuration) +-- , sortable Nothing (i18nCell MsgQualificationRefreshWithin & cellTooltips [SomeMessage MsgQualificationRefreshWithinTooltip , SomeMessage MsgTableDiffDaysTooltip]) $ +-- foldMap (textCell . formatCalendarDiffDays ) . view (resultAllQualification . _qualificationRefreshWithin) +-- , sortable Nothing (i18nCell MsgQualificationRefreshReminder & cellTooltips [SomeMessage MsgQualificationRefreshReminderTooltip, SomeMessage MsgTableDiffDaysTooltip]) $ +-- foldMap (textCell . formatCalendarDiffDays ) . view (resultAllQualification . _qualificationRefreshReminder) +-- , sortable (Just "qelearning") (i18nCell MsgTableLmsElearning & cellTooltip MsgQualificationElearningStart) +-- $ tickmarkCell . view (resultAllQualification . _qualificationElearningStart) +-- , sortable (Just "noteexpiry") (i18nCell MsgQualificationExpiryNotification & cellTooltip MsgQualificationExpiryNotificationTooltip) +-- $ tickmarkCell . view (resultAllQualification . _qualificationExpiryNotification) +-- , sortable Nothing (i18nCell MsgTableQualificationIsAvsLicence & cellTooltip MsgTableQualificationIsAvsLicenceTooltip) +-- $ \(view (resultAllQualification . _qualificationAvsLicence) -> licence) -> maybeCell licence $ textCell . T.singleton . licence2char +-- , sortable Nothing (i18nCell MsgTableQualificationSapExport & cellTooltip MsgTableQualificationSapExportTooltip) +-- $ \(view (resultAllQualification . _qualificationSapId) -> mbSapId) -> tickmarkCell $ isJust mbSapId +-- , sortable Nothing (i18nCell MsgTableQualificationCountActive & cellTooltip MsgTableQualificationCountActiveTooltip) +-- $ \(view resultAllQualificationActive -> n) -> wgtCell $ word2widget n +-- , sortable Nothing (i18nCell MsgTableQualificationCountTotal) $ wgtCell . word2widget . view resultAllQualificationTotal +-- ] +-- dbtSorting = mconcat +-- [ +-- sortSchool $ to (E.^. QualificationSchool) +-- , singletonMap "qshort" $ SortColumn (E.^. QualificationShorthand) +-- , singletonMap "qname" $ SortColumn (E.^. QualificationName) +-- , singletonMap "qelearning" $ SortColumn (E.^. QualificationElearningStart) +-- , singletonMap "noteexpiry" $ SortColumn (E.^. QualificationExpiryNotification) +-- ] +-- dbtFilter = mconcat +-- [ +-- fltrSchool $ to (E.^. QualificationSchool) +-- , singletonMap "qelearning" . FilterColumn $ E.mkExactFilterLast (E.^. QualificationElearningStart) +-- ] +-- dbtFilterUI = mconcat +-- [ +-- fltrSchoolUI +-- , \mPrev -> prismAForm (singletonFilter "qelearning" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgTableLmsElearning) +-- ] +-- dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } +-- dbtParams = def +-- dbtIdent :: Text +-- dbtIdent = "qualification-overview" +-- dbtCsvEncode = noCsvEncode +-- dbtCsvDecode = Nothing +-- dbtExtraReps = [] + +-- resultDBTableValidator = def +-- & defaultSorting [SortAscBy "school", SortAscBy "qshort"] +-- dbTable resultDBTableValidator resultDBTable + + + +-- -- getQualificationEditR, postQualificationEditR :: SchoolId -> QualificationShorthand -> Handler Html +-- -- getQualificationEditR = postQualificationEditR +-- -- postQualificationEditR = error "TODO" + +-- data QualificationTableCsv = QualificationTableCsv -- Q..T..C.. -> qtc.. +-- { qtcDisplayName :: UserDisplayName +-- , qtcEmail :: UserEmail +-- , qtcCompany :: Maybe Text +-- , qtcCompanyNumbers :: CsvSemicolonList Int +-- , qtcValidUntil :: Day +-- , qtcLastRefresh :: Day +-- , qtcBlockStatus :: Maybe Bool +-- , qtcBlockFrom :: Maybe UTCTime +-- , qtcScheduleRenewal:: Bool +-- , qtcLmsStatusTxt :: Maybe Text +-- , qtcLmsStatusDay :: Maybe UTCTime +-- } +-- deriving Generic +-- makeLenses_ ''QualificationTableCsv + +-- qtcExample :: QualificationTableCsv +-- qtcExample = QualificationTableCsv +-- { qtcDisplayName = "Max Mustermann" +-- , qtcEmail = "m.mustermann@example.com" +-- , qtcCompany = Just "Example Brothers LLC, SecondaryJobs Inc" +-- , qtcCompanyNumbers = CsvSemicolonList [27,69] +-- , qtcValidUntil = compDay +-- , qtcLastRefresh = compDay +-- , qtcBlockStatus = Nothing +-- , qtcBlockFrom = Nothing +-- , qtcScheduleRenewal= True +-- , qtcLmsStatusTxt = Just "Success" +-- , qtcLmsStatusDay = Just compTime +-- } +-- where +-- compTime :: UTCTime +-- compTime = $compileTime +-- compDay :: Day +-- compDay = utctDay compTime + +-- qtcOptions :: Csv.Options +-- qtcOptions = Csv.defaultOptions { Csv.fieldLabelModifier = renameLtc } +-- where +-- renameLtc "qtcDisplayName" = "licensee" +-- renameLtc other = replaceLtc $ camelToPathPiece' 1 other +-- replaceLtc ('l':'m':'s':'-':t) = prefixLms t +-- replaceLtc other = other +-- prefixLms = ("elearn-" <>) + +-- instance Csv.ToNamedRecord QualificationTableCsv where +-- toNamedRecord = Csv.genericToNamedRecord qtcOptions + +-- instance Csv.DefaultOrdered QualificationTableCsv where +-- headerOrder = Csv.genericHeaderOrder qtcOptions + +-- instance CsvColumnsExplained QualificationTableCsv where +-- csvColumnsExplanations = genericCsvColumnsExplanations qtcOptions $ Map.fromList +-- [ ('qtcDisplayName , SomeMessage MsgLmsUser) +-- , ('qtcEmail , SomeMessage MsgTableLmsEmail) +-- , ('qtcCompany , SomeMessage MsgTableCompanies) +-- , ('qtcCompanyNumbers , SomeMessage MsgTableCompanyNos) +-- , ('qtcValidUntil , SomeMessage MsgLmsQualificationValidUntil) +-- , ('qtcLastRefresh , SomeMessage MsgTableQualificationLastRefresh) +-- , ('qtcBlockStatus , SomeMessage MsgInfoQualificationBlockStatus) +-- , ('qtcBlockFrom , SomeMessage MsgInfoQualificationBlockFrom) +-- , ('qtcScheduleRenewal, SomeMessage MsgQualificationScheduleRenewalTooltip) +-- , ('qtcLmsStatusTxt , SomeMessage MsgTableLmsStatus) +-- , ('qtcLmsStatusDay , SomeMessage MsgTableLmsStatusDay) +-- ] + + +-- type QualificationTableExpr = ( E.SqlExpr (Entity QualificationUser) +-- `E.InnerJoin` E.SqlExpr (Entity User) +-- ) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity LmsUser)) +-- `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity QualificationUserBlock)) + +-- queryQualUser :: QualificationTableExpr -> E.SqlExpr (Entity QualificationUser) +-- queryQualUser = $(sqlIJproj 2 1) . $(sqlLOJproj 3 1) + +-- queryUser :: QualificationTableExpr -> E.SqlExpr (Entity User) +-- queryUser = $(sqlIJproj 2 2) . $(sqlLOJproj 3 1) + +-- queryLmsUser :: QualificationTableExpr -> E.SqlExpr (Maybe (Entity LmsUser)) +-- queryLmsUser = $(sqlLOJproj 3 2) + +-- queryQualBlock :: QualificationTableExpr -> E.SqlExpr (Maybe (Entity QualificationUserBlock)) +-- queryQualBlock = $(sqlLOJproj 3 3) + +-- type QualificationTableData = DBRow (Entity QualificationUser, Entity User, Maybe (Entity LmsUser), Maybe (Entity QualificationUserBlock), [Entity UserCompany]) + +-- resultQualUser :: Lens' QualificationTableData (Entity QualificationUser) +-- resultQualUser = _dbrOutput . _1 + +-- resultUser :: Lens' QualificationTableData (Entity User) +-- resultUser = _dbrOutput . _2 + +-- resultLmsUser :: Traversal' QualificationTableData (Entity LmsUser) +-- resultLmsUser = _dbrOutput . _3 . _Just + +-- resultQualBlock :: Traversal' QualificationTableData (Entity QualificationUserBlock) +-- resultQualBlock = _dbrOutput . _4 . _Just + +-- resultCompanyUser :: Lens' QualificationTableData [Entity UserCompany] +-- resultCompanyUser = _dbrOutput . _5 + + +-- instance HasEntity QualificationTableData User where +-- hasEntity = resultUser + +-- instance HasUser QualificationTableData where +-- hasUser = resultUser . _entityVal + +-- instance HasEntity QualificationTableData QualificationUser where +-- hasEntity = resultQualUser + +-- instance HasQualificationUser QualificationTableData where +-- hasQualificationUser = resultQualUser . _entityVal + +-- -- instance HasEntity QualificationUserBlock where +-- -- hasQualificationUserBlock = resultQualBlock + + +-- data QualificationTableAction +-- = QualificationActExpire +-- | QualificationActUnexpire +-- | QualificationActBlockSupervisor +-- | QualificationActBlock +-- | QualificationActUnblock +-- | QualificationActRenew +-- | QualificationActGrant +-- deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) + +-- instance Universe QualificationTableAction +-- instance Finite QualificationTableAction +-- nullaryPathPiece ''QualificationTableAction $ camelToPathPiece' 2 +-- embedRenderMessage ''UniWorX ''QualificationTableAction id + +-- {- +-- isAdminAct :: QualificationTableAction -> Bool +-- isAdminAct QualificationActExpire = False +-- isAdminAct QualificationActUnexpire = False +-- isAdminAct QualificationActBlockSupervisor = False +-- isAdminAct _ = True +-- -} + +-- data QualificationTableActionData +-- = QualificationActExpireData +-- | QualificationActUnexpireData +-- | QualificationActBlockSupervisorData +-- | QualificationActBlockData { qualTableActBlockReason :: Text, qualTableActNotify :: Bool, qualTableActRemoveSupervisors :: Bool } +-- | QualificationActUnblockData { qualTableActBlockReason :: Text, qualTableActNotify :: Bool} +-- | QualificationActRenewData +-- | QualificationActGrantData { qualTableActGrantUntil :: Day } +-- deriving (Eq, Ord, Show, Generic) + +-- isExpiryAct :: QualificationTableActionData -> Bool +-- isExpiryAct QualificationActExpireData = True +-- isExpiryAct QualificationActUnexpireData = True +-- isExpiryAct _ = False + +-- isBlockAct :: QualificationTableActionData -> Bool +-- isBlockAct QualificationActBlockSupervisorData = True +-- isBlockAct QualificationActBlockData{} = True +-- isBlockAct QualificationActUnblockData{} = True +-- isBlockAct _ = False + +-- blockActRemoveSupervisors :: QualificationTableActionData -> Bool +-- blockActRemoveSupervisors QualificationActBlockSupervisorData = True +-- blockActRemoveSupervisors QualificationActBlockData{qualTableActRemoveSupervisors=res} = res +-- blockActRemoveSupervisors _ = False + +-- -- qualificationTableQuery :: QualificationId -> (_ -> E.SqlExpr (E.Value Bool)) -> QualificationTableExpr +-- -- -> E.SqlQuery ( E.SqlExpr (Entity QualificationUser) +-- -- , E.SqlExpr (Entity User) +-- -- , E.SqlExpr (Maybe (Entity LmsUser)) +-- -- ) +-- -- qualificationTableQuery qid fltr (qualUser `E.InnerJoin` user `E.LeftOuterJoin` lmsUse) = do +-- -- E.on $ user E.^. UserId E.=?. lmsUser E.?. LmsUserUser +-- -- E.&&. E.val qid E.=?. lmsUser E.?. LmsUserQualification -- NOTE: condition was once erroneously placed in where-clause, which does not work +-- -- E.on $ user E.^. UserId E.==. qualUser E.^. QualificationUserUser +-- -- E.where_ $ fltr qualUser E.&&. (E.val qid E.==. qualUser E.^. QualificationUserQualification) +-- -- return (qualUser, user, lmsUser) + +-- qualificationTableQuery :: UTCTime -> QualificationId -> (_ -> E.SqlExpr (E.Value Bool)) -> QualificationTableExpr +-- -> E.SqlQuery ( E.SqlExpr (Entity QualificationUser) +-- , E.SqlExpr (Entity User) +-- , E.SqlExpr (Maybe (Entity LmsUser)) +-- , E.SqlExpr (Maybe (Entity QualificationUserBlock)) +-- ) +-- qualificationTableQuery now qid fltr (qualUser `E.InnerJoin` user `E.LeftOuterJoin` lmsUser `E.LeftOuterJoin` qualBlock) = do +-- -- E.distinctOnOrderBy will not work: sorting with dbTable should work, except that columns contained in distinctOnOrderBy cannot be sorted inversely by user; but PostgreSQL leftJoin with distinct filters too many results, see SQL Example lead/lag under jost/misc DevOps +-- -- +-- E.on $ qualBlock E.?. QualificationUserBlockQualificationUser E.?=. qualUser E.^. QualificationUserId +-- E.&&. qualBlock `isLatestBlockBefore` E.val now +-- E.on $ user E.^. UserId E.=?. lmsUser E.?. LmsUserUser +-- E.&&. E.val qid E.=?. lmsUser E.?. LmsUserQualification -- NOTE: condition was once erroneously placed in where-clause, which does not work +-- E.on $ user E.^. UserId E.==. qualUser E.^. QualificationUserUser +-- E.where_ $ fltr qualUser +-- E.&&. (E.val qid E.==. qualUser E.^. QualificationUserQualification) +-- return (qualUser, user, lmsUser, qualBlock) + + +-- mkQualificationTable :: +-- ( Functor h, ToSortable h +-- , AsCornice h p QualificationTableData (DBCell (MForm Handler) (FormResult (First QualificationTableActionData, DBFormResult UserId Bool QualificationTableData))) cols +-- ) +-- => Bool +-- -> Entity Qualification +-- -> Map QualificationTableAction (AForm Handler QualificationTableActionData) +-- -> (Map CompanyId Company -> cols) +-- -> PSValidator (MForm Handler) (FormResult (First QualificationTableActionData, DBFormResult UserId Bool QualificationTableData)) +-- -> DB (FormResult (QualificationTableActionData, Set UserId), Widget) +-- mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do +-- svs <- getSupervisees +-- now <- liftIO getCurrentTime +-- -- lookup all companies +-- cmpMap <- memcachedBy (Just . Right $ 5 * diffMinute) ("CompanyDictionary"::Text) $ do +-- cmps <- selectList [] [] -- [Asc CompanyShorthand] +-- return $ Map.fromList $ fmap (\Entity{..} -> (entityKey, entityVal)) cmps +-- let +-- nowaday = utctDay now +-- mbRenewal = addGregorianDurationClip <$> qualificationRefreshWithin quali <*> Just nowaday +-- csvName = T.replace " " "-" $ CI.original (quali ^. _qualificationName) +-- dbtIdent :: Text +-- dbtIdent = "qualification" +-- fltrSvs = if isAdmin then const E.true else \quser -> quser E.^. QualificationUserUser `Ex.in_` E.vals svs +-- dbtSQLQuery = qualificationTableQuery now qid fltrSvs +-- dbtRowKey = queryUser >>> (E.^. UserId) +-- dbtProj = dbtProjSimple $ \(qualUsr, usr, lmsUsr, qUsrBlock) -> do +-- -- cmps <- 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 (entityKey usr) +-- -- E.orderBy [E.asc (comp E.^. CompanyName)] +-- -- return (comp E.^. CompanyName, comp E.^. CompanyAvsId, usrComp E.^. UserCompanySupervisor) +-- cmpUsr <- selectList [UserCompanyUser ==. entityKey usr] [Asc UserCompanyCompany] +-- return (qualUsr, usr, lmsUsr, qUsrBlock, cmpUsr) +-- dbtColonnade = cols cmpMap +-- dbtSorting = mconcat +-- [ single $ sortUserNameLink queryUser +-- , single $ sortUserEmail queryUser +-- , single $ sortUserMatriclenr queryUser +-- , single ("first-held" , SortColumn $ queryQualUser >>> (E.^. QualificationUserFirstHeld)) +-- , single ("last-refresh" , SortColumn $ queryQualUser >>> (E.^. QualificationUserLastRefresh)) +-- , single ("last-notified" , SortColumn $ queryQualUser >>> (E.^. QualificationUserLastNotified)) +-- , single ("valid-until" , SortColumn $ queryQualUser >>> (E.^. QualificationUserValidUntil)) +-- , single ("blocked" , SortColumnNeverNull $ queryQualBlock >>> (E.?. QualificationUserBlockFrom)) +-- , single ("lms-status-plus",SortColumnNeverNull $ \row -> E.coalesce [ E.joinV (queryLmsUser row E.?. LmsUserStatusDay) +-- , E.joinV (queryLmsUser row E.?. LmsUserNotified) +-- , queryLmsUser row E.?. LmsUserStarted]) +-- , single ("schedule-renew", SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserScheduleRenewal)) +-- , single ("user-company" , SortColumn $ \row -> E.subSelect $ E.from $ \(usrComp `E.InnerJoin` comp) -> do +-- E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId +-- E.where_ $ usrComp E.^. UserCompanyUser E.==. queryUser row E.^. UserId +-- E.orderBy [E.asc (comp E.^. CompanyName)] +-- return (comp E.^. CompanyName) +-- ) +-- -- , single ("validity", SortColumn $ queryQualUser >>> validQualification now) +-- ] +-- dbtFilter = mconcat +-- [ single $ fltrUserNameEmail queryUser +-- , single ("avs-number" , FilterColumn . E.mkExistsFilter $ \row criterion -> +-- E.from $ \usrAvs -> -- do +-- E.where_ $ usrAvs E.^. UserAvsUser E.==. queryUser row E.^. UserId +-- E.&&. ((E.val criterion :: E.SqlExpr (E.Value (CI Text))) E.==. +-- (E.explicitUnsafeCoerceSqlExprValue "citext" (usrAvs E.^. UserAvsNoPerson) :: E.SqlExpr (E.Value (CI Text))) )) +-- , single ("avs-card" , FilterColumn $ \(queryUser -> user) (criterion :: Set.Set Text) -> case readAvsFullCardNo =<< Set.lookupMin criterion of +-- Nothing -> E.false +-- Just cardNo -> E.exists $ E.from $ \(avsCard `E.InnerJoin` usrAvs) -> do +-- E.on $ usrAvs E.^. UserAvsPersonId E.==. avsCard E.^. UserAvsCardPersonId +-- E.where_ $ usrAvs E.^. UserAvsUser E.==. user E.^. UserId +-- E.&&. (avsCard E.^. UserAvsCardCardNo E.==. E.val cardNo) +-- ) +-- , single ("personal-number", FilterColumn $ \(queryUser -> user) (criteria :: Set.Set Text) -> if +-- | Set.null criteria -> E.true +-- | otherwise -> E.any (\c -> user E.^. UserCompanyPersonalNumber `E.hasInfix` E.val c) criteria +-- ) +-- , single ("user-company", FilterColumn . E.mkExistsFilter $ \row criterion -> +-- E.from $ \(usrComp `E.InnerJoin` comp) -> do +-- let testname = (E.val criterion :: E.SqlExpr (E.Value (CI Text))) `E.isInfixOf` +-- (E.explicitUnsafeCoerceSqlExprValue "citext" (comp E.^. CompanyName) :: E.SqlExpr (E.Value (CI Text))) +-- testnumber nr = E.val nr E.==. comp E.^. CompanyAvsId +-- testcrit = maybe testname testnumber $ readMay $ CI.original criterion +-- E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId +-- E.where_ $ usrComp E.^. UserCompanyUser E.==. queryUser row E.^. UserId E.&&. testcrit +-- ) +-- , single ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) (validQualification now)) +-- , single ("renewal-due" , FilterColumn $ \(queryQualUser -> quser) criterion -> +-- if | Just renewal <- mbRenewal +-- , Just True <- getLast criterion -> quser E.^. QualificationUserValidUntil E.<=. E.val renewal +-- E.&&. quser E.^. QualificationUserValidUntil E.>=. E.val nowaday +-- | otherwise -> E.true +-- ) +-- , single ("tobe-notified", FilterColumn $ \row criterion -> +-- if | Just True <- getLast criterion -> quserToNotify now (queryQualUser row) (queryQualBlock row) +-- | otherwise -> E.true +-- ) +-- , single ("status" , FilterColumn . E.mkExactFilterMaybeLast' (views (to queryLmsUser) (E.?. LmsUserId)) $ views (to queryLmsUser) (E.?. LmsUserStatus)) +-- ] +-- dbtFilterUI mPrev = mconcat +-- [ fltrUserNameEmailHdrUI MsgLmsUser mPrev +-- , prismAForm (singletonFilter "user-company") mPrev $ aopt textField (fslI MsgTableCompany) +-- , prismAForm (singletonFilter "personal-number" ) mPrev $ aopt textField (fslI MsgCompanyPersonalNumber) +-- , prismAForm (singletonFilter "avs-card" ) mPrev $ aopt textField (fslI MsgAvsCardNo) +-- , prismAForm (singletonFilter "avs-number" ) mPrev $ aopt textField (fslI MsgAvsPersonNo) +-- , prismAForm (singletonFilter "validity" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsValid) +-- , if isNothing mbRenewal then mempty +-- else prismAForm (singletonFilter "renewal-due" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsRenewal) +-- , prismAForm (singletonFilter "tobe-notified" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsNotificationDue) +-- , prismAForm (singletonFilter "status" . maybePrism _PathPiece) mPrev $ aopt (hoistField liftHandler (selectField optionsFinite) :: (Field _ (Maybe LmsStatus))) (fslI MsgTableLmsStatus) +-- ] +-- dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } +-- dbtCsvEncode = Just DBTCsvEncode +-- { dbtCsvExportForm = pure () +-- , dbtCsvDoEncode = \() -> C.map (doEncode' . view _2) +-- , dbtCsvName = csvName +-- , dbtCsvSheetName = csvName +-- , dbtCsvNoExportData = Just id +-- , dbtCsvHeader = const $ return $ Csv.headerOrder qtcExample +-- , dbtCsvExampleData = Just [qtcExample] +-- } +-- where +-- doEncode' :: QualificationTableData -> QualificationTableCsv +-- doEncode' = QualificationTableCsv +-- <$> view (resultUser . _entityVal . _userDisplayName) +-- <*> view (resultUser . _entityVal . _userDisplayEmail) +-- <*> (view resultCompanyUser >>= getCompanies) +-- <*> (view resultCompanyUser >>= getCompanyNos) +-- <*> view (resultQualUser . _entityVal . _qualificationUserValidUntil) +-- <*> view (resultQualUser . _entityVal . _qualificationUserLastRefresh) +-- <*> preview (resultQualBlock. _entityVal . _qualificationUserBlockUnblock . _not) +-- <*> preview (resultQualBlock. _entityVal . _qualificationUserBlockFrom) +-- <*> view (resultQualUser . _entityVal . _qualificationUserScheduleRenewal) +-- <*> getStatusPlusTxt +-- <*> getStatusPlusDay +-- getCompanies cmps = case mapMaybe (flip Map.lookup cmpMap . view (_entityVal . _userCompanyCompany)) cmps of +-- [] -> pure Nothing +-- somecmps -> pure $ Just $ intercalate ", " $ fmap (view (_companyName . _CI)) somecmps +-- getCompanyNos = pure . CsvSemicolonList . mapMaybe (preview (_Just . _companyAvsId) . flip Map.lookup cmpMap . view (_entityVal . _userCompanyCompany)) + +-- getStatusPlusTxt = +-- (join . preview (resultLmsUser . _entityVal . _lmsUserStatus)) >>= \case +-- Just LmsBlocked{} -> return $ Just "Failed" +-- Just LmsExpired{} -> return $ Just "Expired" +-- Just LmsSuccess{} -> return $ Just "Success" +-- Nothing -> maybeM (return Nothing) (const $ return $ Just "Open") $ +-- preview (resultLmsUser . _entityVal . _lmsUserStarted) +-- getStatusPlusDay = +-- (join . preview (resultLmsUser . _entityVal . _lmsUserStatusDay)) >>= \case +-- lsd@(Just _) -> return lsd +-- Nothing -> preview (resultLmsUser . _entityVal . _lmsUserStarted) + +-- dbtCsvDecode = Nothing +-- dbtExtraReps = [] +-- 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 +-- } + +-- postprocess :: FormResult (First QualificationTableActionData, DBFormResult UserId Bool QualificationTableData) +-- -> FormResult ( QualificationTableActionData, Set UserId) +-- postprocess inp = do +-- (First (Just act), usrMap) <- inp +-- let usrSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) usrMap +-- return (act, usrSet) + +-- -- resultDBTableValidator :: PSValidator (MForm Handler) (FormResult (First QualificationTableActionData, DBFormResult UserId Bool QualificationTableActionData)) +-- -- resultDBTableValidator = def +-- -- & defaultSorting [SortAscBy csvLmsIdent] +-- over _1 postprocess <$> dbTable psValidator DBTable{..} + +-- getQualificationR, postQualificationR :: SchoolId -> QualificationShorthand -> Handler Html +-- getQualificationR = postQualificationR +-- postQualificationR sid qsh = do +-- isAdmin <- hasReadAccessTo AdminR +-- msgGrantWarning <- messageIconI Warning IconWarning MsgQualificationActGrantWarning +-- msgUnexpire <- messageIconI Info IconWarning MsgQualificationActUnexpireWarning +-- now <- liftIO getCurrentTime +-- let nowaday = utctDay now +-- ((lmsRes, qualificationTable), Entity qid quali) <- runDB $ do +-- qent@Entity{ +-- entityKey=qid +-- , entityVal=Qualification{ +-- qualificationAuditDuration=auditMonths +-- , qualificationValidDuration=validMonths +-- }} <- getBy404 $ SchoolQualificationShort sid qsh + +-- -- Block copied to Handler/Qualifications TODO: refactor +-- let getBlockReasons unblk = Ex.select $ do +-- (quser :& qblock) <- Ex.from $ Ex.table @QualificationUser +-- `Ex.innerJoin` Ex.table @QualificationUserBlock +-- `Ex.on` (\(quser :& qblock) -> quser Ex.^. QualificationUserId Ex.==. qblock Ex.^. QualificationUserBlockQualificationUser) +-- Ex.where_ $ quser Ex.^. QualificationUserQualification Ex.==. Ex.val qid +-- Ex.&&. unblk (qblock Ex.^. QualificationUserBlockUnblock) +-- Ex.groupBy (qblock Ex.^. QualificationUserBlockReason) +-- let countRows' :: Ex.SqlExpr (Ex.Value Int64) = Ex.countRows +-- Ex.orderBy [Ex.desc countRows'] +-- Ex.limit 7 +-- pure (qblock Ex.^. QualificationUserBlockReason) +-- mkOption :: Ex.Value Text -> Option Text +-- mkOption (Ex.unValue -> t) = Option{ optionDisplay = t, optionInternalValue = t, optionExternalValue = toPathPiece t } +-- suggestionsBlock :: HandlerFor UniWorX (OptionList Text) +-- suggestionsBlock = mkOptionList . fmap mkOption <$> runDB (getBlockReasons Ex.not_) +-- suggestionsUnblock = mkOptionList . fmap mkOption <$> runDB (getBlockReasons id) +-- dayExpiry = flip addGregorianDurationClip nowaday . fromMonths <$> validMonths +-- acts :: Map QualificationTableAction (AForm Handler QualificationTableActionData) +-- acts = mconcat $ +-- [ singletonMap QualificationActExpire $ pure QualificationActExpireData +-- , singletonMap QualificationActUnexpire $ QualificationActUnexpireData +-- <$ aformMessage msgUnexpire +-- ] ++ bool +-- -- nonAdmin actions, ie. Supervisor +-- [ singletonMap QualificationActBlockSupervisor $ pure QualificationActBlockSupervisorData ] +-- -- Admin-only actions +-- [ singletonMap QualificationActUnblock $ QualificationActUnblockData +-- <$> apreq (textField & cfStrip & addDatalist suggestionsUnblock) (fslI MsgQualificationGrantReason) Nothing +-- <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgQualificationBlockNotify) (Just False) +-- , singletonMap QualificationActBlock $ QualificationActBlockData +-- <$> apreq (textField & cfStrip & addDatalist suggestionsBlock) (fslI MsgQualificationBlockReason) Nothing +-- <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgQualificationBlockNotify) (Just False) +-- <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgQualificationBlockRemoveSupervisor) (Just False) +-- , singletonMap QualificationActRenew $ pure QualificationActRenewData +-- , singletonMap QualificationActGrant $ QualificationActGrantData +-- <$> apopt dayField (fslI MsgLmsQualificationValidUntil) dayExpiry +-- <* aformMessage msgGrantWarning +-- ] isAdmin +-- linkLmsUser = toMaybe isAdmin (LmsUserR sid qsh) +-- linkUserName = bool ForProfileR ForProfileDataR isAdmin +-- colChoices cmpMap = mconcat +-- [ dbSelect (applying _2) id (return . view (hasEntity . _entityKey)) +-- , colUserNameModalHdr MsgLmsUser linkUserName +-- , colUserEmail +-- , sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \( view resultCompanyUser -> cmps) -> +-- let icnSuper = text2markup " " <> icon IconSupervisor +-- cs = [ (cmpName, cmpSpr) +-- | Entity _ UserCompany{userCompanyCompany=cmpId, userCompanySupervisor=cmpSpr} <- cmps +-- , let cmpName = maybe (unCompanyKey cmpId) companyName $ Map.lookup cmpId cmpMap +-- ] +-- companies = intercalate (text2markup ", ") $ +-- (\(cmpName, cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> cs +-- in wgtCell companies +-- , guardMonoid isAdmin colUserMatriclenr +-- -- , sortable (Just "validity") (i18nCell MsgQualificationValidIndicator) (qualificationValidIconCell nowaday . view resultQualUser) +-- , sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ \( view $ resultQualUser . _entityVal . _qualificationUserFirstHeld -> d) -> dayCell d +-- , sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \( view $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> dayCell d +-- , sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) (dayCell . view ( resultQualUser . _entityVal . _qualificationUserValidUntil)) +-- , sortable (Just "blocked") (i18nCell MsgQualificationValidIndicator & cellTooltip MsgTableQualificationBlockedTooltipSimple) $ \row -> +-- qualificationValidReasonCell' (Just $ LmsUserR sid qsh) isAdmin nowaday (row ^? resultQualBlock) row +-- , sortable (Just "schedule-renew")(i18nCell MsgTableQualificationNoRenewal & cellTooltip MsgTableQualificationNoRenewalTooltip +-- ) $ \( view $ resultQualUser . _entityVal . _qualificationUserScheduleRenewal -> b) -> ifIconCell (not b) IconNoNotification +-- , sortable (Just "lms-status-plus")(i18nCell MsgTableLmsStatus & cellTooltipWgt Nothing (lmsStatusInfoCell isAdmin auditMonths)) +-- $ \(preview $ resultLmsUser . _entityVal -> lu) -> foldMap (lmsStatusCell isAdmin linkLmsUser) lu +-- , sortable (Just "last-notified") (i18nCell MsgTableQualificationLastNotified) $ \( view $ resultQualUser . _entityVal . _qualificationUserLastNotified -> d) -> dateTimeCell d +-- ] +-- psValidator = def & defaultSorting [SortDescBy "last-refresh"] +-- tbl <- mkQualificationTable isAdmin qent acts colChoices psValidator +-- return (tbl, qent) + +-- formResult lmsRes $ \case +-- (QualificationActRenewData, selectedUsers) | isAdmin -> do +-- noks <- runDB $ renewValidQualificationUsers qid Nothing $ Set.toList selectedUsers +-- addMessageI (if noks > 0 && noks == Set.size selectedUsers then Success else Warning) $ MsgTutorialUserRenewedQualification noks +-- reloadKeepGetParams $ QualificationR sid qsh +-- (QualificationActGrantData grantValidday, selectedUsers) | isAdmin -> do +-- runDB . forM_ selectedUsers $ upsertQualificationUser qid nowaday grantValidday Nothing +-- addMessageI (if 0 < Set.size selectedUsers then Success else Warning) . MsgTutorialUserGrantedQualification $ Set.size selectedUsers +-- reloadKeepGetParams $ QualificationR sid qsh +-- (action, selectedUsers) | isExpiryAct action -> do +-- let isUnexpire = action == QualificationActUnexpireData +-- upd <- runDB $ updateWhereCount +-- [QualificationUserQualification ==. qid, QualificationUserUser <-. Set.toList selectedUsers] +-- [QualificationUserScheduleRenewal =. isUnexpire] +-- let msgKind = if upd > 0 then Success else Warning +-- msgVal = upd & if isUnexpire then MsgQualificationSetUnexpire else MsgQualificationSetExpire +-- addMessageI msgKind msgVal +-- reloadKeepGetParams $ QualificationR sid qsh +-- (action, selectedUsers) | isBlockAct action && (isAdmin || action == QualificationActBlockSupervisorData) -> do +-- let selUserIds = Set.toList selectedUsers +-- (unblock, reason) = case action of +-- QualificationActBlockSupervisorData -> (False, Right QualificationBlockReturnedByCompany) +-- QualificationActBlockData{..} -> (False, Left qualTableActBlockReason) +-- QualificationActUnblockData{..} -> (True , Left qualTableActBlockReason) +-- _ -> error "Handle.Qualification.isBlockAct returned non-block action" -- cannot occur due to earlier checks +-- notify = case action of +-- QualificationActBlockData{qualTableActNotify} -> qualTableActNotify +-- _ -> False + +-- oks <- runDB $ do +-- when (blockActRemoveSupervisors action) $ deleteWhere [UserSupervisorUser <-. selUserIds] +-- qualificationUserBlocking qid selUserIds unblock Nothing reason notify +-- let nrq = length selectedUsers +-- warnLevel = if +-- | oks < 0 -> Error +-- | oks == nrq -> Success +-- | otherwise -> Warning +-- fbmsg = if unblock then MsgQualificationStatusUnblock else MsgQualificationStatusBlock +-- addMessageI warnLevel $ fbmsg qsh oks nrq +-- reloadKeepGetParams $ QualificationR sid qsh +-- _ -> addMessageI Error MsgInvalidFormAction + +-- let heading = citext2widget $ qualificationName quali +-- siteLayout heading $ do +-- setTitle $ toHtml $ unSchoolKey sid <> "-" <> qsh +-- $(widgetFile "qualification") From bc0b449689458ee4868070f770b80dde518f58cf Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 9 Oct 2023 16:30:07 +0000 Subject: [PATCH 03/50] fix build --- src/Foundation/Navigation.hs | 2 +- src/Handler/Firm.hs | 6 +++--- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index 9fce295f5..a38b62b93 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -124,7 +124,7 @@ breadcrumb ProblemAvsSynchR = i18nCrumb MsgProblemsAvsSynchHeading $ Just breadcrumb ProblemAvsErrorR = i18nCrumb MsgProblemsAvsErrorHeading $ Just ProblemAvsSynchR breadcrumb FirmAllR = i18nCrumb MsgMenuFirms Nothing -breadcrumb FirmR = i18nCrumb MsgMenuFirms $ Just FirmAllR +breadcrumb FirmR{} = i18nCrumb MsgMenuFirms $ Just FirmAllR breadcrumb PrintCenterR = i18nCrumb MsgMenuApc Nothing breadcrumb PrintSendR = i18nCrumb MsgMenuPrintSend $ Just PrintCenterR diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 5d640d603..10dcf320b 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -14,7 +14,7 @@ module Handler.Firm import Import -- import Jobs -import Handler.Utils +-- import Handler.Utils -- import qualified Data.Set as Set -- import qualified Data.Map as Map @@ -32,8 +32,8 @@ import Handler.Utils -- avoids repetition of local definitions -single :: (k,a) -> Map k a -single = uncurry Map.singleton +-- single :: (k,a) -> Map k a +-- single = uncurry Map.singleton getFirmAllR :: Handler Html From 8fcfc9586e3aca5f1eb0b3f1019127c7690328e8 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 10 Oct 2023 15:11:56 +0000 Subject: [PATCH 04/50] chore(firm): wip all firm table query --- routes | 2 +- src/Handler/Firm.hs | 213 ++++++++++++++++++++++++-------------------- 2 files changed, 116 insertions(+), 99 deletions(-) diff --git a/routes b/routes index e7f9fc7b9..031e7b5c2 100644 --- a/routes +++ b/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 !free /firm/#CompanyShorthand FirmR GET POST /exam-office ExamOfficeR !exam-office: diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 10dcf320b..8072ef78b 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -36,13 +36,6 @@ import Import -- single = uncurry Map.singleton -getFirmAllR :: Handler Html -getFirmAllR = do - siteLayoutMsg MsgMenuFirms $ do - setTitleI MsgMenuFirms - [whamlet|STUB TO DO|] - - getFirmR, postFirmR :: CompanyShorthand -> Handler Html getFirmR = postFirmR postFirmR _ = do @@ -51,101 +44,125 @@ postFirmR _ = do [whamlet|STUB TO DO|] --- isAdmin <- hasReadAccessTo AdminR --- firmTable <- runDB $ do --- view _2 <$> mkFirmAllTable isAdmin --- siteLayoutMsg MsgMenuFirms $ do --- setTitleI MsgMenuFirms --- $(widgetFile "firm-all") +getFirmAllR :: Handler Html +getFirmAllR = do + uid <- requireAuthId + isAdmin <- hasReadAccessTo AdminR + firmTable <- runDB $ do + view _2 <$> mkFirmAllTable (toMaybe (not isAdmin) uid) -- filter to associated companies for non-admins + siteLayoutMsg MsgMenuFirms $ do + setTitleI MsgMenuFirms + -- $(widgetFile "firm-all") + [whamlet|!!!STUB!!!TO DO!!! --- type AllQualificationTableData = DBRow (Entity Qualification, Ex.Value Word64, Ex.Value Word64) --- resultAllQualification :: Lens' AllQualificationTableData Qualification --- resultAllQualification = _dbrOutput . _1 . _entityVal - --- resultAllQualificationActive :: Lens' AllQualificationTableData Word64 --- resultAllQualificationActive = _dbrOutput . _2 . _unValue - --- resultAllQualificationTotal :: Lens' AllQualificationTableData Word64 --- resultAllQualificationTotal = _dbrOutput . _3 . _unValue + ^{firmTable} + |] --- mkQualificationAllTable :: Bool -> DB (Any, Widget) --- mkQualificationAllTable isAdmin = do --- svs <- getSupervisees --- now <- liftIO getCurrentTime --- let --- resultDBTable = DBTable{..} --- where --- dbtSQLQuery quali = do --- let filterSvs quser = quser Ex.^. QualificationUserQualification Ex.==. quali Ex.^. QualificationId --- Ex.&&. (E.val isAdmin E.||. quser Ex.^. QualificationUserUser `Ex.in_` E.vals svs) --- cusers = Ex.subSelectCount $ do --- quser <- Ex.from $ Ex.table @QualificationUser --- Ex.where_ $ filterSvs quser --- cactive = Ex.subSelectCount $ do --- quser <- Ex.from $ Ex.table @QualificationUser --- Ex.where_ $ filterSvs quser Ex.&&. validQualification now quser --- return (quali, cactive, cusers) --- dbtRowKey = (Ex.^. QualificationId) --- dbtProj = dbtProjId --- dbtColonnade = dbColonnade $ mconcat --- [ colSchool $ resultAllQualification . _qualificationSchool --- , sortable (Just "qshort") (i18nCell MsgQualificationShort) $ \(view resultAllQualification -> quali) -> --- let qsh = qualificationShorthand quali in --- anchorCell (QualificationR (qualificationSchool quali) qsh) $ toWgt qsh --- , sortable (Just "qname") (i18nCell MsgQualificationName) $ \(view resultAllQualification -> quali) -> --- let qsh = qualificationShorthand quali --- qnm = qualificationName quali --- in anchorCell (QualificationR (qualificationSchool quali) qsh) $ toWgt qnm --- , sortable Nothing (i18nCell MsgQualificationDescription) $ \(view resultAllQualification -> quali) -> --- maybeCell (qualificationDescription quali) markupCellLargeModal --- , sortable Nothing (i18nCell MsgQualificationValidDuration & cellTooltip MsgTableDiffDaysTooltip) $ --- foldMap (textCell . formatCalendarDiffDays . fromMonths) . view (resultAllQualification . _qualificationValidDuration) --- , sortable Nothing (i18nCell MsgQualificationRefreshWithin & cellTooltips [SomeMessage MsgQualificationRefreshWithinTooltip , SomeMessage MsgTableDiffDaysTooltip]) $ --- foldMap (textCell . formatCalendarDiffDays ) . view (resultAllQualification . _qualificationRefreshWithin) --- , sortable Nothing (i18nCell MsgQualificationRefreshReminder & cellTooltips [SomeMessage MsgQualificationRefreshReminderTooltip, SomeMessage MsgTableDiffDaysTooltip]) $ --- foldMap (textCell . formatCalendarDiffDays ) . view (resultAllQualification . _qualificationRefreshReminder) --- , sortable (Just "qelearning") (i18nCell MsgTableLmsElearning & cellTooltip MsgQualificationElearningStart) --- $ tickmarkCell . view (resultAllQualification . _qualificationElearningStart) --- , sortable (Just "noteexpiry") (i18nCell MsgQualificationExpiryNotification & cellTooltip MsgQualificationExpiryNotificationTooltip) --- $ tickmarkCell . view (resultAllQualification . _qualificationExpiryNotification) --- , sortable Nothing (i18nCell MsgTableQualificationIsAvsLicence & cellTooltip MsgTableQualificationIsAvsLicenceTooltip) --- $ \(view (resultAllQualification . _qualificationAvsLicence) -> licence) -> maybeCell licence $ textCell . T.singleton . licence2char --- , sortable Nothing (i18nCell MsgTableQualificationSapExport & cellTooltip MsgTableQualificationSapExportTooltip) --- $ \(view (resultAllQualification . _qualificationSapId) -> mbSapId) -> tickmarkCell $ isJust mbSapId --- , sortable Nothing (i18nCell MsgTableQualificationCountActive & cellTooltip MsgTableQualificationCountActiveTooltip) --- $ \(view resultAllQualificationActive -> n) -> wgtCell $ word2widget n --- , sortable Nothing (i18nCell MsgTableQualificationCountTotal) $ wgtCell . word2widget . view resultAllQualificationTotal --- ] --- dbtSorting = mconcat --- [ --- sortSchool $ to (E.^. QualificationSchool) --- , singletonMap "qshort" $ SortColumn (E.^. QualificationShorthand) --- , singletonMap "qname" $ SortColumn (E.^. QualificationName) --- , singletonMap "qelearning" $ SortColumn (E.^. QualificationElearningStart) --- , singletonMap "noteexpiry" $ SortColumn (E.^. QualificationExpiryNotification) --- ] --- dbtFilter = mconcat --- [ --- fltrSchool $ to (E.^. QualificationSchool) --- , singletonMap "qelearning" . FilterColumn $ E.mkExactFilterLast (E.^. QualificationElearningStart) --- ] --- dbtFilterUI = mconcat --- [ --- fltrSchoolUI --- , \mPrev -> prismAForm (singletonFilter "qelearning" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgTableLmsElearning) --- ] --- dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } --- dbtParams = def --- dbtIdent :: Text --- dbtIdent = "qualification-overview" --- dbtCsvEncode = noCsvEncode --- dbtCsvDecode = Nothing --- dbtExtraReps = [] +type AllCompanyTableData = DBRow (Entity Company, Ex.Value Word64, Ex.Value Word64, Ex.Value Word64) +resultAllCompany :: Lens' AllCompanyTableData Company +resultAllCompany = _dbrOutput . _1 . _entityVal --- resultDBTableValidator = def --- & defaultSorting [SortAscBy "school", SortAscBy "qshort"] --- dbTable resultDBTableValidator resultDBTable +resultAllCompanySupervisors :: Lens' AllCompanyTableData Word64 +resultAllCompanySupervisors = _dbrOutput . _2 . _unValue + +resultAllCompanyUsers :: Lens' AllCompanyTableData Word64 +resultAllCompanyUsers = _dbrOutput . _3 . _unValue + +resultAllCompanyForeignSupers :: Lens' AllCompanyTableData Word64 +resultAllCompanyForeignSupers = _dbrOutput . _4 . _unValue + + +mkQualificationAllTable :: Maybe UserId -> DB (Any, Widget) +mkQualificationAllTable mbUid = do + + now <- liftIO getCurrentTime + let + resultDBTable = DBTable{..} + where + dbtSQLQuery cmpy = do + let filterCmpy usrCmpy = usrCmpy E.^. UserCompanyCompany Ex.==. cmpy E.^. CompanyId + cforeign = Ex.subSelectCount $ Ex.distinct $ do + usrSuper <- Ex.from $ Ex.table @UserSupervisor + Ex.where_ (Ex.exists $ do + usrCmpy <- Ex.from $ Ex.table @UserCompany + Ex.where_ $ filterCmpy usrCmpy E.&&. usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorUser + ) E.&&. Ex.notExists (do + usrCmpy <- Ex.from $ Ex.table @UserCompany + Ex.where_ $ filterCmpy usrCmpy E.&&. usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorSupervisor + ) + return $ usrSuper E.^. UserSupervisorSupervisor + cusers = Ex.subSelectCount $ do + usrCmpy <- Ex.from $ Ex.table @UserCompany + Ex.where_ $ filterCmpy usrCmpy + csupers = Ex.subSelectCount $ do + usrCmpy <- Ex.from $ Ex.table @UserCompany + Ex.where_ $ filterCmpy usrCmpy E.&&. usrCmpy E.^. UserCompanySupervisor + whenIsJust mbUid $ \uid -> + Ex.where_ $ Ex.exists $ do -- only show associated companies + usrCmpy <- Ex.from $ Ex.table @UserCompany + Ex.where_ $ filterCmpy usrCmpy E.&&. usrCmpy E.^. UserCompanyUser Ex.==. E.val uid + return (cmpy, csupers, cusers, cforeign) + dbtRowKey = (Ex.^. CompanyShorthand) + dbtProj = dbtProjId + dbtColonnade = dbColonnade $ mconcat + [ colSchool $ resultAllQualification . _qualificationSchool + , sortable (Just "qshort") (i18nCell MsgQualificationShort) $ \(view resultAllQualification -> quali) -> + let qsh = qualificationShorthand quali in + anchorCell (QualificationR (qualificationSchool quali) qsh) $ toWgt qsh + , sortable (Just "qname") (i18nCell MsgQualificationName) $ \(view resultAllQualification -> quali) -> + let qsh = qualificationShorthand quali + qnm = qualificationName quali + in anchorCell (QualificationR (qualificationSchool quali) qsh) $ toWgt qnm + , sortable Nothing (i18nCell MsgQualificationDescription) $ \(view resultAllQualification -> quali) -> + maybeCell (qualificationDescription quali) markupCellLargeModal + , sortable Nothing (i18nCell MsgQualificationValidDuration & cellTooltip MsgTableDiffDaysTooltip) $ + foldMap (textCell . formatCalendarDiffDays . fromMonths) . view (resultAllQualification . _qualificationValidDuration) + , sortable Nothing (i18nCell MsgQualificationRefreshWithin & cellTooltips [SomeMessage MsgQualificationRefreshWithinTooltip , SomeMessage MsgTableDiffDaysTooltip]) $ + foldMap (textCell . formatCalendarDiffDays ) . view (resultAllQualification . _qualificationRefreshWithin) + , sortable Nothing (i18nCell MsgQualificationRefreshReminder & cellTooltips [SomeMessage MsgQualificationRefreshReminderTooltip, SomeMessage MsgTableDiffDaysTooltip]) $ + foldMap (textCell . formatCalendarDiffDays ) . view (resultAllQualification . _qualificationRefreshReminder) + , sortable (Just "qelearning") (i18nCell MsgTableLmsElearning & cellTooltip MsgQualificationElearningStart) + $ tickmarkCell . view (resultAllQualification . _qualificationElearningStart) + , sortable (Just "noteexpiry") (i18nCell MsgQualificationExpiryNotification & cellTooltip MsgQualificationExpiryNotificationTooltip) + $ tickmarkCell . view (resultAllQualification . _qualificationExpiryNotification) + , sortable Nothing (i18nCell MsgTableQualificationIsAvsLicence & cellTooltip MsgTableQualificationIsAvsLicenceTooltip) + $ \(view (resultAllQualification . _qualificationAvsLicence) -> licence) -> maybeCell licence $ textCell . T.singleton . licence2char + , sortable Nothing (i18nCell MsgTableQualificationSapExport & cellTooltip MsgTableQualificationSapExportTooltip) + $ \(view (resultAllQualification . _qualificationSapId) -> mbSapId) -> tickmarkCell $ isJust mbSapId + , sortable Nothing (i18nCell MsgTableQualificationCountActive & cellTooltip MsgTableQualificationCountActiveTooltip) + $ \(view resultAllQualificationActive -> n) -> wgtCell $ word2widget n + , sortable Nothing (i18nCell MsgTableQualificationCountTotal) $ wgtCell . word2widget . view resultAllQualificationTotal + ] + dbtSorting = mconcat + [ + sortSchool $ to (E.^. QualificationSchool) + , singletonMap "qshort" $ SortColumn (E.^. QualificationShorthand) + , singletonMap "qname" $ SortColumn (E.^. QualificationName) + , singletonMap "qelearning" $ SortColumn (E.^. QualificationElearningStart) + , singletonMap "noteexpiry" $ SortColumn (E.^. QualificationExpiryNotification) + ] + dbtFilter = mconcat + [ + fltrSchool $ to (E.^. QualificationSchool) + , singletonMap "qelearning" . FilterColumn $ E.mkExactFilterLast (E.^. QualificationElearningStart) + ] + dbtFilterUI = mconcat + [ + fltrSchoolUI + , \mPrev -> prismAForm (singletonFilter "qelearning" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgTableLmsElearning) + ] + dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } + dbtParams = def + dbtIdent :: Text + dbtIdent = "qualification-overview" + dbtCsvEncode = noCsvEncode + dbtCsvDecode = Nothing + dbtExtraReps = [] + + resultDBTableValidator = def + & defaultSorting [SortAscBy "school", SortAscBy "qshort"] + dbTable resultDBTableValidator resultDBTable From e831a76c2718d92d2d87642fb53cc49827b840b2 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 12 Oct 2023 14:50:42 +0000 Subject: [PATCH 05/50] chore(firm): fix imports --- src/Handler/Firm.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 8072ef78b..e7fc5fe85 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -14,7 +14,7 @@ module Handler.Firm import Import -- import Jobs --- import Handler.Utils +import Handler.Utils -- import qualified Data.Set as Set -- import qualified Data.Map as Map @@ -24,7 +24,7 @@ import Import -- import qualified Data.Conduit.List as C -- import Database.Persist.Sql (updateWhereCount) -- import Database.Esqueleto.Experimental ((:&)(..)) --- import qualified Database.Esqueleto.Experimental as Ex -- needs TypeApplications Lang-Pragma +import qualified Database.Esqueleto.Experimental as Ex -- needs TypeApplications Lang-Pragma -- import qualified Database.Esqueleto.Legacy as E -- import qualified Database.Esqueleto.PostgreSQL as E -- import qualified Database.Esqueleto.Utils as E From d81e6e15dcfeda1fa75d1c48f3f86e3cd663c2af Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 17 Oct 2023 16:09:48 +0000 Subject: [PATCH 06/50] chore(firm): WIP company overview --- .../utils/table_column/de-de-formal.msg | 5 + messages/uniworx/utils/table_column/en-eu.msg | 5 + routes | 2 +- src/Handler/Firm.hs | 143 ++++++++---------- 4 files changed, 71 insertions(+), 84 deletions(-) diff --git a/messages/uniworx/utils/table_column/de-de-formal.msg b/messages/uniworx/utils/table_column/de-de-formal.msg index fdf42b885..b25230af4 100644 --- a/messages/uniworx/utils/table_column/de-de-formal.msg +++ b/messages/uniworx/utils/table_column/de-de-formal.msg @@ -75,8 +75,13 @@ TableExamOfficeLabelStatus: Label-Farbe TableExamOfficeLabelPriority: Label-Priorität TableQualifications: Qualifikationen TableCompany: Firma +TableCompanyShort: Firmenkürzel TableCompanies: Firmen +TableCompanyNo: Firmennummer TableCompanyNos: Firmennummern +TableCompanyNrUsers: Firmenangehörige +TableCompanyNrSupers: Ansprechpartner +TableCompanyNrForeignSupers: Firmenfremde Ansprechpartner TableSupervisor: Ansprechpartner TableCreationTime: Erstellungszeit TableJob !ident-ok: Job diff --git a/messages/uniworx/utils/table_column/en-eu.msg b/messages/uniworx/utils/table_column/en-eu.msg index b4fe83d34..e3d095d4f 100644 --- a/messages/uniworx/utils/table_column/en-eu.msg +++ b/messages/uniworx/utils/table_column/en-eu.msg @@ -75,8 +75,13 @@ TableExamOfficeLabelStatus: Label colour TableExamOfficeLabelPriority: Label priority TableQualifications: Qualifications TableCompany: Company +TableCompanyShort: Company shorthand TableCompanies: Companies +TableCompanyNo: Company number TableCompanyNos: Company numbers +TableCompanyNrUsers: Associates +TableCompanyNrSupers: Supervisors +TableCompanyNrForeignSupers: External Supervisors TableSupervisor: Supervisor TableCreationTime: Creation TableJob !ident-ok: Job diff --git a/routes b/routes index 031e7b5c2..0af78745f 100644 --- a/routes +++ b/routes @@ -113,7 +113,7 @@ /for/#CryptoUUIDUser/user ForProfileR GET POST !supervisor !self /for/#CryptoUUIDUser/user/profile ForProfileDataR GET !supervisor !self -/firm FirmAllR GET !free +/firm FirmAllR GET /firm/#CompanyShorthand FirmR GET POST /exam-office ExamOfficeR !exam-office: diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index e7fc5fe85..9e7a56a29 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -24,7 +24,7 @@ import Handler.Utils -- import qualified Data.Conduit.List as C -- import Database.Persist.Sql (updateWhereCount) -- import Database.Esqueleto.Experimental ((:&)(..)) -import qualified Database.Esqueleto.Experimental as Ex -- needs TypeApplications Lang-Pragma +import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma -- import qualified Database.Esqueleto.Legacy as E -- import qualified Database.Esqueleto.PostgreSQL as E -- import qualified Database.Esqueleto.Utils as E @@ -49,7 +49,7 @@ getFirmAllR = do uid <- requireAuthId isAdmin <- hasReadAccessTo AdminR firmTable <- runDB $ do - view _2 <$> mkFirmAllTable (toMaybe (not isAdmin) uid) -- filter to associated companies for non-admins + view _2 <$> mkFirmAllTable isAdmin uid -- filter to associated companies for non-admins siteLayoutMsg MsgMenuFirms $ do setTitleI MsgMenuFirms -- $(widgetFile "firm-all") @@ -59,7 +59,7 @@ getFirmAllR = do |] -type AllCompanyTableData = DBRow (Entity Company, Ex.Value Word64, Ex.Value Word64, Ex.Value Word64) +type AllCompanyTableData = DBRow (Entity Company, E.Value Word64, E.Value Word64, E.Value Word64) resultAllCompany :: Lens' AllCompanyTableData Company resultAllCompany = _dbrOutput . _1 . _entityVal @@ -73,95 +73,72 @@ resultAllCompanyForeignSupers :: Lens' AllCompanyTableData Word64 resultAllCompanyForeignSupers = _dbrOutput . _4 . _unValue -mkQualificationAllTable :: Maybe UserId -> DB (Any, Widget) -mkQualificationAllTable mbUid = do - +mkQualificationAllTable :: Bool -> UserId -> DB (Any, Widget) +mkQualificationAllTable isAdmin uid = do now <- liftIO getCurrentTime - let + let resultDBTable = DBTable{..} where dbtSQLQuery cmpy = do - let filterCmpy usrCmpy = usrCmpy E.^. UserCompanyCompany Ex.==. cmpy E.^. CompanyId - cforeign = Ex.subSelectCount $ Ex.distinct $ do - usrSuper <- Ex.from $ Ex.table @UserSupervisor - Ex.where_ (Ex.exists $ do - usrCmpy <- Ex.from $ Ex.table @UserCompany - Ex.where_ $ filterCmpy usrCmpy E.&&. usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorUser - ) E.&&. Ex.notExists (do - usrCmpy <- Ex.from $ Ex.table @UserCompany - Ex.where_ $ filterCmpy usrCmpy E.&&. usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorSupervisor + let filterCmpy usrCmpy = usrCmpy E.^. UserCompanyCompany E.==. cmpy E.^. CompanyId + cforeign = E.subSelectCount $ E.distinct $ do + usrSuper <- E.from $ E.table @UserSupervisor + E.where_ (E.exists $ do + usrCmpy <- E.from $ E.table @UserCompany + E.where_ $ filterCmpy usrCmpy E.&&. usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorUser + ) E.&&. E.notExists (do + usrCmpy <- E.from $ E.table @UserCompany + E.where_ $ filterCmpy usrCmpy E.&&. usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorSupervisor ) return $ usrSuper E.^. UserSupervisorSupervisor - cusers = Ex.subSelectCount $ do - usrCmpy <- Ex.from $ Ex.table @UserCompany - Ex.where_ $ filterCmpy usrCmpy - csupers = Ex.subSelectCount $ do - usrCmpy <- Ex.from $ Ex.table @UserCompany - Ex.where_ $ filterCmpy usrCmpy E.&&. usrCmpy E.^. UserCompanySupervisor + cusers = E.subSelectCount $ do + usrCmpy <- E.from $ E.table @UserCompany + E.where_ $ filterCmpy usrCmpy + csupers = E.subSelectCount $ do + usrCmpy <- E.from $ E.table @UserCompany + E.where_ $ filterCmpy usrCmpy E.&&. usrCmpy E.^. UserCompanySupervisor whenIsJust mbUid $ \uid -> - Ex.where_ $ Ex.exists $ do -- only show associated companies - usrCmpy <- Ex.from $ Ex.table @UserCompany - Ex.where_ $ filterCmpy usrCmpy E.&&. usrCmpy E.^. UserCompanyUser Ex.==. E.val uid + E.where_ $ E.exists $ do -- only show associated companies + usrCmpy <- E.from $ E.table @UserCompany + E.where_ $ filterCmpy usrCmpy E.&&. usrCmpy E.^. UserCompanyUser E.==. E.val uid return (cmpy, csupers, cusers, cforeign) - dbtRowKey = (Ex.^. CompanyShorthand) + dbtRowKey = (E.^. CompanyShorthand) dbtProj = dbtProjId dbtColonnade = dbColonnade $ mconcat - [ colSchool $ resultAllQualification . _qualificationSchool - , sortable (Just "qshort") (i18nCell MsgQualificationShort) $ \(view resultAllQualification -> quali) -> - let qsh = qualificationShorthand quali in - anchorCell (QualificationR (qualificationSchool quali) qsh) $ toWgt qsh - , sortable (Just "qname") (i18nCell MsgQualificationName) $ \(view resultAllQualification -> quali) -> - let qsh = qualificationShorthand quali - qnm = qualificationName quali - in anchorCell (QualificationR (qualificationSchool quali) qsh) $ toWgt qnm - , sortable Nothing (i18nCell MsgQualificationDescription) $ \(view resultAllQualification -> quali) -> - maybeCell (qualificationDescription quali) markupCellLargeModal - , sortable Nothing (i18nCell MsgQualificationValidDuration & cellTooltip MsgTableDiffDaysTooltip) $ - foldMap (textCell . formatCalendarDiffDays . fromMonths) . view (resultAllQualification . _qualificationValidDuration) - , sortable Nothing (i18nCell MsgQualificationRefreshWithin & cellTooltips [SomeMessage MsgQualificationRefreshWithinTooltip , SomeMessage MsgTableDiffDaysTooltip]) $ - foldMap (textCell . formatCalendarDiffDays ) . view (resultAllQualification . _qualificationRefreshWithin) - , sortable Nothing (i18nCell MsgQualificationRefreshReminder & cellTooltips [SomeMessage MsgQualificationRefreshReminderTooltip, SomeMessage MsgTableDiffDaysTooltip]) $ - foldMap (textCell . formatCalendarDiffDays ) . view (resultAllQualification . _qualificationRefreshReminder) - , sortable (Just "qelearning") (i18nCell MsgTableLmsElearning & cellTooltip MsgQualificationElearningStart) - $ tickmarkCell . view (resultAllQualification . _qualificationElearningStart) - , sortable (Just "noteexpiry") (i18nCell MsgQualificationExpiryNotification & cellTooltip MsgQualificationExpiryNotificationTooltip) - $ tickmarkCell . view (resultAllQualification . _qualificationExpiryNotification) - , sortable Nothing (i18nCell MsgTableQualificationIsAvsLicence & cellTooltip MsgTableQualificationIsAvsLicenceTooltip) - $ \(view (resultAllQualification . _qualificationAvsLicence) -> licence) -> maybeCell licence $ textCell . T.singleton . licence2char - , sortable Nothing (i18nCell MsgTableQualificationSapExport & cellTooltip MsgTableQualificationSapExportTooltip) - $ \(view (resultAllQualification . _qualificationSapId) -> mbSapId) -> tickmarkCell $ isJust mbSapId - , sortable Nothing (i18nCell MsgTableQualificationCountActive & cellTooltip MsgTableQualificationCountActiveTooltip) - $ \(view resultAllQualificationActive -> n) -> wgtCell $ word2widget n - , sortable Nothing (i18nCell MsgTableQualificationCountTotal) $ wgtCell . word2widget . view resultAllQualificationTotal + [ if not isAdmin then mempty else dbSelect (applying _2) id (return . view (resultAllCompany . _companyShorthand)) + , sortable (Just "name") (i18nCell MsgTableCompany) $ \(view resultAllCompany -> firm) -> + anchorCell (FirmR $ companyShorthand firm) . toWgt $ companyName firm + , sortable (Just "short") (i18nCell MsgTableCompanyShort) $ \(view resultAllCompany -> firm) -> + let fsh = companyShorthand firm + anchorCell (FirmR fsh) $ toWgt fsh + , sortable (Just "nr") (i18nCell MsgTableCompanyNo) $ \(view resultAllCompany -> firm) -> + let fsh = companyShorthand firm + anchorCell (FirmR fsh) $ toWgt $ companyAvsId firm + , sortable Nothing (i18nCell MsgTableCompanyNrUsers) $ \(view resultAllCompanyUsers -> nr) -> wgtCell $ word2widget nr + , sortable Nothing (i18nCell MsgTableCompanyNrSupers) $ \(view resultAllCompanySupervisors -> nr) -> wgtCell $ word2widget nr + , sortable Nothing (i18nCell MsgTableCompanyNrForeignSupers) $ \(view resultAllCompanyForeignSupers -> nr) -> wgtCell $ word2widget nr ] dbtSorting = mconcat - [ - sortSchool $ to (E.^. QualificationSchool) - , singletonMap "qshort" $ SortColumn (E.^. QualificationShorthand) - , singletonMap "qname" $ SortColumn (E.^. QualificationName) - , singletonMap "qelearning" $ SortColumn (E.^. QualificationElearningStart) - , singletonMap "noteexpiry" $ SortColumn (E.^. QualificationExpiryNotification) + [ singletonMap "name" $ SortColumn (E.^. CompanyName) + , singletonMap "short" $ SortColumn (E.^. CompanyShorthand) + , singletonMap "nr" $ SortColumn (E.^. CompanyAvsId) ] dbtFilter = mconcat - [ - fltrSchool $ to (E.^. QualificationSchool) - , singletonMap "qelearning" . FilterColumn $ E.mkExactFilterLast (E.^. QualificationElearningStart) + [ ] dbtFilterUI = mconcat - [ - fltrSchoolUI - , \mPrev -> prismAForm (singletonFilter "qelearning" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgTableLmsElearning) + [ ] - dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } + dbtStyle = def -- { dbsFilterLayout = defaultDBSFilterLayout } dbtParams = def dbtIdent :: Text - dbtIdent = "qualification-overview" + dbtIdent = "firm" dbtCsvEncode = noCsvEncode dbtCsvDecode = Nothing dbtExtraReps = [] resultDBTableValidator = def - & defaultSorting [SortAscBy "school", SortAscBy "qshort"] + -- & defaultSorting [SortAscBy "school", SortAscBy "qshort"] dbTable resultDBTableValidator resultDBTable @@ -391,7 +368,7 @@ mkQualificationAllTable mbUid = do -- csvName = T.replace " " "-" $ CI.original (quali ^. _qualificationName) -- dbtIdent :: Text -- dbtIdent = "qualification" --- fltrSvs = if isAdmin then const E.true else \quser -> quser E.^. QualificationUserUser `Ex.in_` E.vals svs +-- fltrSvs = if isAdmin then const E.true else \quser -> quser E.^. QualificationUserUser `E.in_` E.vals svs -- dbtSQLQuery = qualificationTableQuery now qid fltrSvs -- dbtRowKey = queryUser >>> (E.^. UserId) -- dbtProj = dbtProjSimple $ \(qualUsr, usr, lmsUsr, qUsrBlock) -> do @@ -562,21 +539,21 @@ mkQualificationAllTable mbUid = do -- }} <- getBy404 $ SchoolQualificationShort sid qsh -- -- Block copied to Handler/Qualifications TODO: refactor --- let getBlockReasons unblk = Ex.select $ do --- (quser :& qblock) <- Ex.from $ Ex.table @QualificationUser --- `Ex.innerJoin` Ex.table @QualificationUserBlock --- `Ex.on` (\(quser :& qblock) -> quser Ex.^. QualificationUserId Ex.==. qblock Ex.^. QualificationUserBlockQualificationUser) --- Ex.where_ $ quser Ex.^. QualificationUserQualification Ex.==. Ex.val qid --- Ex.&&. unblk (qblock Ex.^. QualificationUserBlockUnblock) --- Ex.groupBy (qblock Ex.^. QualificationUserBlockReason) --- let countRows' :: Ex.SqlExpr (Ex.Value Int64) = Ex.countRows --- Ex.orderBy [Ex.desc countRows'] --- Ex.limit 7 --- pure (qblock Ex.^. QualificationUserBlockReason) --- mkOption :: Ex.Value Text -> Option Text --- mkOption (Ex.unValue -> t) = Option{ optionDisplay = t, optionInternalValue = t, optionExternalValue = toPathPiece t } +-- let getBlockReasons unblk = E.select $ do +-- (quser :& qblock) <- E.from $ E.table @QualificationUser +-- `E.innerJoin` E.table @QualificationUserBlock +-- `E.on` (\(quser :& qblock) -> quser E.^. QualificationUserId E.==. qblock E.^. QualificationUserBlockQualificationUser) +-- E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid +-- E.&&. unblk (qblock E.^. QualificationUserBlockUnblock) +-- E.groupBy (qblock E.^. QualificationUserBlockReason) +-- let countRows' :: E.SqlExpr (E.Value Int64) = E.countRows +-- E.orderBy [E.desc countRows'] +-- E.limit 7 +-- pure (qblock E.^. QualificationUserBlockReason) +-- mkOption :: E.Value Text -> Option Text +-- mkOption (E.unValue -> t) = Option{ optionDisplay = t, optionInternalValue = t, optionExternalValue = toPathPiece t } -- suggestionsBlock :: HandlerFor UniWorX (OptionList Text) --- suggestionsBlock = mkOptionList . fmap mkOption <$> runDB (getBlockReasons Ex.not_) +-- suggestionsBlock = mkOptionList . fmap mkOption <$> runDB (getBlockReasons E.not_) -- suggestionsUnblock = mkOptionList . fmap mkOption <$> runDB (getBlockReasons id) -- dayExpiry = flip addGregorianDurationClip nowaday . fromMonths <$> validMonths -- acts :: Map QualificationTableAction (AForm Handler QualificationTableActionData) From 92e83475a94b6b0a1ea0ecd2f03b493422459ba2 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 18 Oct 2023 15:45:59 +0000 Subject: [PATCH 07/50] chore(firm): link firms throughout --- routes | 8 ++++---- src/Handler/Admin/Avs.hs | 11 +++++----- src/Handler/Firm.hs | 35 +++++++++++++++----------------- src/Handler/LMS.hs | 13 +++++------- src/Handler/Qualification.hs | 11 ++++------ src/Handler/Users.hs | 10 ++++----- src/Handler/Utils/Table/Cells.hs | 10 +++++++++ src/Utils.hs | 4 ++++ 8 files changed, 54 insertions(+), 48 deletions(-) diff --git a/routes b/routes index 0af78745f..b4485c890 100644 --- a/routes +++ b/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 /firm/#CompanyShorthand FirmR GET POST /exam-office ExamOfficeR !exam-office: @@ -278,7 +278,7 @@ /lms/#SchoolId/#QualificationShorthand/edit LmsEditR GET POST -- old V1 LMS Interface /lms/#SchoolId/#QualificationShorthand/users LmsUsersR GET -/lms/#SchoolId/#QualificationShorthand/users/direct LmsUsersDirectR GET !token -- LMS +/lms/#SchoolId/#QualificationShorthand/users/direct LmsUsersDirectR GET !token -- LMS /lms/#SchoolId/#QualificationShorthand/userlist LmsUserlistR GET POST /lms/#SchoolId/#QualificationShorthand/userlist/upload LmsUserlistUploadR GET POST !development /lms/#SchoolId/#QualificationShorthand/userlist/direct LmsUserlistDirectR POST !token -- LMS, also remove JobLmsUserlist constructor @@ -287,11 +287,11 @@ /lms/#SchoolId/#QualificationShorthand/result/direct LmsResultDirectR POST !token -- LMS, also remove JobLmsResults constructor -- new V2 LMS Interface /lms/#SchoolId/#QualificationShorthand/learners LmsLearnersR GET -/lms/#SchoolId/#QualificationShorthand/learners/direct LmsLearnersDirectR GET !token -- LMS +/lms/#SchoolId/#QualificationShorthand/learners/direct LmsLearnersDirectR GET !token -- LMS /lms/#SchoolId/#QualificationShorthand/report LmsReportR GET POST /lms/#SchoolId/#QualificationShorthand/report/upload LmsReportUploadR GET POST !development /lms/#SchoolId/#QualificationShorthand/report/direct LmsReportDirectR POST !token -- LMS --- other lms routes +-- other lms routes /lms/#SchoolId/#QualificationShorthand/ident/#LmsIdent LmsIdentR GET -- redirect to LmsR with filter-parameter /lms/#SchoolId/#QualificationShorthand/user/#CryptoUUIDUser LmsUserR GET /lmsuser/#CryptoUUIDUser LmsUserAllR GET diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs index e7b4fda22..365143304 100644 --- a/src/Handler/Admin/Avs.hs +++ b/src/Handler/Admin/Avs.hs @@ -556,11 +556,12 @@ mkLicenceTable apidStatus dbtIdent aLic apids = do E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid E.orderBy [E.asc (comp E.^. CompanyName)] - return (comp E.^. CompanyName, usrComp E.^. UserCompanySupervisor) - let companies = intersperse (text2markup ", ") $ - (\(E.Value cmpName, E.Value cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> companies' - icnSuper = text2markup " " <> icon IconSupervisor - pure $ toWgt $ mconcat companies + return (comp E.^. CompanyShorthand, comp E.^. CompanyName, usrComp E.^. UserCompanySupervisor) + let icnSuper = toWidget $ text2markup " " <> icon IconSupervisor + companies = + (\(E.Value cmpSh, E.Value cmpName, E.Value cmpSpr) -> simpleLink (citext2widget cmpName) (FirmR cmpSh) <> bool mempty icnSuper cmpSpr) <$> companies' + + pure $ intercalate (text2widget "; ") companies , sortable (Just "qualification") (i18nCell MsgTableQualifications) $ \(preview resultQualification -> q) -> cellMaybe lmsShortCell q , sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ \(preview $ resultQualUser . _entityVal . _qualificationUserFirstHeld -> d) -> cellMaybe dayCell d , sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \(preview $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> cellMaybe dayCell d diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 9e7a56a29..fe487f78c 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -28,7 +28,7 @@ import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications -- import qualified Database.Esqueleto.Legacy as E -- import qualified Database.Esqueleto.PostgreSQL as E -- import qualified Database.Esqueleto.Utils as E --- import Database.Esqueleto.Utils.TH +import Database.Esqueleto.Utils.TH -- avoids repetition of local definitions @@ -38,10 +38,10 @@ import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications getFirmR, postFirmR :: CompanyShorthand -> Handler Html getFirmR = postFirmR -postFirmR _ = do +postFirmR fsh = do siteLayoutMsg MsgMenuFirms $ do setTitleI MsgMenuFirms - [whamlet|STUB TO DO|] + [whamlet|STUB FOR #{fsh} TO DO|] getFirmAllR :: Handler Html @@ -53,8 +53,7 @@ getFirmAllR = do siteLayoutMsg MsgMenuFirms $ do setTitleI MsgMenuFirms -- $(widgetFile "firm-all") - [whamlet|!!!STUB!!!TO DO!!! - + [whamlet|!!!STUB!!!TO DO!!! ^{firmTable} |] @@ -73,9 +72,9 @@ resultAllCompanyForeignSupers :: Lens' AllCompanyTableData Word64 resultAllCompanyForeignSupers = _dbrOutput . _4 . _unValue -mkQualificationAllTable :: Bool -> UserId -> DB (Any, Widget) -mkQualificationAllTable isAdmin uid = do - now <- liftIO getCurrentTime +mkFirmAllTable :: Bool -> UserId -> DB (Any, Widget) +mkFirmAllTable isAdmin uid = do + -- now <- liftIO getCurrentTime let resultDBTable = DBTable{..} where @@ -83,7 +82,7 @@ mkQualificationAllTable isAdmin uid = do let filterCmpy usrCmpy = usrCmpy E.^. UserCompanyCompany E.==. cmpy E.^. CompanyId cforeign = E.subSelectCount $ E.distinct $ do usrSuper <- E.from $ E.table @UserSupervisor - E.where_ (E.exists $ do + E.where_ $ E.exists (do usrCmpy <- E.from $ E.table @UserCompany E.where_ $ filterCmpy usrCmpy E.&&. usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorUser ) E.&&. E.notExists (do @@ -97,23 +96,21 @@ mkQualificationAllTable isAdmin uid = do csupers = E.subSelectCount $ do usrCmpy <- E.from $ E.table @UserCompany E.where_ $ filterCmpy usrCmpy E.&&. usrCmpy E.^. UserCompanySupervisor - whenIsJust mbUid $ \uid -> - E.where_ $ E.exists $ do -- only show associated companies - usrCmpy <- E.from $ E.table @UserCompany - E.where_ $ filterCmpy usrCmpy E.&&. usrCmpy E.^. UserCompanyUser E.==. E.val uid + unless isAdmin $ E.where_ $ E.exists $ do -- only show associated companies + usrCmpy <- E.from $ E.table @UserCompany + E.where_ $ filterCmpy usrCmpy E.&&. usrCmpy E.^. UserCompanyUser E.==. E.val uid return (cmpy, csupers, cusers, cforeign) dbtRowKey = (E.^. CompanyShorthand) dbtProj = dbtProjId dbtColonnade = dbColonnade $ mconcat - [ if not isAdmin then mempty else dbSelect (applying _2) id (return . view (resultAllCompany . _companyShorthand)) - , sortable (Just "name") (i18nCell MsgTableCompany) $ \(view resultAllCompany -> firm) -> + [ -- if not isAdmin then mempty else dbSelect (applying _2) id (return . view (resultAllCompany . _companyShorthand)) + sortable (Just "name") (i18nCell MsgTableCompany) $ \(view resultAllCompany -> firm) -> anchorCell (FirmR $ companyShorthand firm) . toWgt $ companyName firm , sortable (Just "short") (i18nCell MsgTableCompanyShort) $ \(view resultAllCompany -> firm) -> - let fsh = companyShorthand firm - anchorCell (FirmR fsh) $ toWgt fsh + let fsh = companyShorthand firm + in anchorCell (FirmR fsh) $ toWgt fsh , sortable (Just "nr") (i18nCell MsgTableCompanyNo) $ \(view resultAllCompany -> firm) -> - let fsh = companyShorthand firm - anchorCell (FirmR fsh) $ toWgt $ companyAvsId firm + anchorCell (FirmR $ companyShorthand firm) $ toWgt $ companyAvsId firm , sortable Nothing (i18nCell MsgTableCompanyNrUsers) $ \(view resultAllCompanyUsers -> nr) -> wgtCell $ word2widget nr , sortable Nothing (i18nCell MsgTableCompanyNrSupers) $ \(view resultAllCompanySupervisors -> nr) -> wgtCell $ word2widget nr , sortable Nothing (i18nCell MsgTableCompanyNrForeignSupers) $ \(view resultAllCompanyForeignSupers -> nr) -> wgtCell $ word2widget nr diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index cdd720509..c927cc8f8 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -42,7 +42,7 @@ import qualified Data.Set as Set import qualified Data.Map as Map import qualified Data.Csv as Csv import qualified Data.Text as T -import qualified Data.CaseInsensitive as CI +-- import qualified Data.CaseInsensitive as CI import qualified Data.Conduit.List as C import Database.Esqueleto.Experimental ((:&)(..)) import qualified Database.Esqueleto.Experimental as Ex -- needs TypeApplications Lang-Pragma @@ -445,7 +445,7 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do cmps <- selectList [] [] -- [Asc CompanyShorthand] return $ Map.fromList $ fmap (\Entity{..} -> (entityKey, entityVal)) cmps let - csvName = T.replace " " "-" $ CI.original (quali ^. _qualificationName) + csvName = T.replace " " "-" $ ciOriginal (quali ^. _qualificationName) dbtIdent :: Text dbtIdent = "lms" dbtSQLQuery = lmsTableQuery now qid @@ -506,7 +506,7 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do let testname = (E.val criterion :: E.SqlExpr (E.Value (CI Text))) `E.isInfixOf` (E.explicitUnsafeCoerceSqlExprValue "citext" (comp E.^. CompanyName) :: E.SqlExpr (E.Value (CI Text))) testnumber nr = E.val nr E.==. comp E.^. CompanyAvsId - testcrit = maybe testname testnumber $ readMay $ CI.original criterion + testcrit = maybe testname testnumber $ readMay $ ciOriginal criterion E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId E.where_ $ usrComp E.^. UserCompanyUser E.==. queryUser row E.^. UserId E.&&. testcrit ) @@ -637,14 +637,11 @@ postLmsR sid qsh = do , colUserNameModalHdr MsgLmsUser AdminUserR , colUserEmail , sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \( view resultCompanyUser -> cmps) -> - let icnSuper = text2markup " " <> icon IconSupervisor - cs = [ (cmpName, cmpSpr) + let cs = [ companyCell (unCompanyKey cmpId) cmpName cmpSpr | Entity _ UserCompany{userCompanyCompany=cmpId, userCompanySupervisor=cmpSpr} <- cmps , let cmpName = maybe (unCompanyKey cmpId) companyName $ Map.lookup cmpId cmpMap ] - companies = intercalate (text2markup ", ") $ - (\(cmpName, cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> cs - in wgtCell companies + in intercalate spacerCell cs , colUserMatriclenr -- , sortable (Just "validity") (i18nCell MsgQualificationValidIndicator) (qualificationValidIconCell nowaday . view resultQualUser) , sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ \( view $ resultQualUser . _entityVal . _qualificationUserFirstHeld -> d) -> dayCell d diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs index 6553bb300..5297c8801 100644 --- a/src/Handler/Qualification.hs +++ b/src/Handler/Qualification.hs @@ -586,14 +586,11 @@ postQualificationR sid qsh = do , colUserNameModalHdr MsgLmsUser linkUserName , colUserEmail , sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \( view resultCompanyUser -> cmps) -> - let icnSuper = text2markup " " <> icon IconSupervisor - cs = [ (cmpName, cmpSpr) - | Entity _ UserCompany{userCompanyCompany=cmpId, userCompanySupervisor=cmpSpr} <- cmps - , let cmpName = maybe (unCompanyKey cmpId) companyName $ Map.lookup cmpId cmpMap + let cs = [ companyCell (unCompanyKey cmpId) cmpName cmpSpr + | Entity _ UserCompany{userCompanyCompany=cmpId, userCompanySupervisor=cmpSpr} <- cmps + , let cmpName = maybe (unCompanyKey cmpId) companyName $ Map.lookup cmpId cmpMap ] - companies = intercalate (text2markup ", ") $ - (\(cmpName, cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> cs - in wgtCell companies + in intercalate spacerCell cs , guardMonoid isAdmin colUserMatriclenr -- , sortable (Just "validity") (i18nCell MsgQualificationValidIndicator) (qualificationValidIconCell nowaday . view resultQualUser) , sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ \( view $ resultQualUser . _entityVal . _qualificationUserFirstHeld -> d) -> dayCell d diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index 23ca1e78d..f5ae958e4 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -106,11 +106,11 @@ postUsersR = do E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid E.orderBy [E.asc (comp E.^. CompanyName)] - return (comp E.^. CompanyName, usrComp E.^. UserCompanySupervisor) - let companies = intersperse (text2markup ", ") $ - (\(E.Value cmpName, E.Value cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> companies' - icnSuper = text2markup " " <> icon IconSupervisor - pure $ toWgt $ mconcat companies + return (comp E.^. CompanyShorthand, comp E.^. CompanyName, usrComp E.^. UserCompanySupervisor) + let icnSuper = toWidget $ text2markup " " <> icon IconSupervisor + companies = + (\(E.Value cmpSh, E.Value cmpName, E.Value cmpSpr) -> simpleLink (citext2widget cmpName) (FirmR cmpSh) <> bool mempty icnSuper cmpSpr) <$> companies' + pure $ intercalate (text2widget "; ") companies , sortable (Just "personal-number") (i18nCell MsgCompanyPersonalNumber) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM (AdminUserR <$> encrypt uid) (toWgt userCompanyPersonalNumber) diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index 42970a046..e19be03aa 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -307,6 +307,16 @@ courseCell Course{..} = anchorCell link name `mappend` desc ^{modal "Beschreibung" (Right $ toWidget descr)} |] +companyCell :: IsDBTable m a => CompanyShorthand -> CompanyName -> Bool -> DBCell m a +companyCell cid cname isSupervisor = anchorCell link name + where + link = FirmR cid + corg = ciOriginal cname + name + | isSupervisor = text2markup (corg <> " ") <> icon IconSupervisor + | otherwise = text2markup corg + + qualificationCell :: (IsDBTable m c, HasQualification a) => a -> DBCell m c qualificationCell (view hasQualification -> Qualification{..}) = anchorCell link name where diff --git a/src/Utils.hs b/src/Utils.hs index 7ff482a96..28b7d88a8 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -305,6 +305,10 @@ tshowCrop = cropText . tshow stripCI :: Text -> CI Text stripCI = CI.mk . Text.strip +-- | just to avoid adding an import for this +ciOriginal :: CI Text -> Text +ciOriginal = CI.original + citext2lower :: CI Text -> Text citext2lower = Text.toLower . CI.original From 4cdf39a1fd34720d00ce7c055baa5c2d6188b5a7 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 19 Oct 2023 16:42:37 +0000 Subject: [PATCH 08/50] chore(firm): sorting by employee and supervisor numbers --- src/Handler/Firm.hs | 83 ++++++++++++++++++++++++++++--------------- src/Handler/LMS.hs | 1 - test/Database/Fill.hs | 1 + 3 files changed, 55 insertions(+), 30 deletions(-) diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index fe487f78c..de717655f 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -2,6 +2,7 @@ -- -- SPDX-License-Identifier: AGPL-3.0-or-later +{-# OPTIONS -Wno-unused-top-binds #-} -- TODO: remove me, for debugging only {-# OPTIONS_GHC -fno-warn-orphans #-} -- needed for HasEntity instances {-# LANGUAGE TypeApplications #-} @@ -39,9 +40,28 @@ import Database.Esqueleto.Utils.TH getFirmR, postFirmR :: CompanyShorthand -> Handler Html getFirmR = postFirmR postFirmR fsh = do + cusers <- runDB $ do + cusers <- selectList [UserCompanyCompany ==. CompanyKey fsh] [] + selectList [UserId <-. fmap (userCompanyUser . entityVal) cusers] [Asc UserDisplayName] + csuper <- runDB $ do + csuper <- selectList [UserCompanyCompany ==. CompanyKey fsh, UserCompanySupervisor ==. True] [] + selectList [UserId <-. fmap (userCompanyUser . entityVal) csuper] [Asc UserDisplayName] siteLayoutMsg MsgMenuFirms $ do setTitleI MsgMenuFirms - [whamlet|STUB FOR #{fsh} TO DO|] + [whamlet|STUB HANDLER FOR #{fsh} TO DO + +

Supervisors (non-foreign only) +
    + $forall u <- csuper +
  • ^{userWidget u} + +

    Employees +
      + $forall u <- cusers +
    • ^{userWidget u} + + In the end, this needs to be a dbTable, of course! + |] getFirmAllR :: Handler Html @@ -71,6 +91,24 @@ resultAllCompanyUsers = _dbrOutput . _3 . _unValue resultAllCompanyForeignSupers :: Lens' AllCompanyTableData Word64 resultAllCompanyForeignSupers = _dbrOutput . _4 . _unValue +fromUserCompany :: Maybe (E.SqlExpr (Entity UserCompany) -> E.SqlExpr (E.Value Bool)) -> E.SqlExpr (Entity Company) -> E.SqlQuery () +fromUserCompany mbFltr cmpy = do + usrCmpy <- E.from $ E.table @UserCompany + let basecond = usrCmpy E.^. UserCompanyCompany E.==. cmpy E.^. CompanyId + E.where_ $ maybe basecond ((basecond E.&&.).($ usrCmpy)) mbFltr + +firmCountUsers :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) +firmCountUsers = E.subSelectCount . fromUserCompany Nothing + +firmCountSupervisors :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) +firmCountSupervisors = E.subSelectCount . fromUserCompany (Just (E.^. UserCompanySupervisor)) + +firmCountForeignSupervisors :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) +firmCountForeignSupervisors cmpy = E.subSelectCount $ E.distinct $ do + usrSuper <- E.from $ E.table @UserSupervisor + E.where_ $ E.exists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorUser) cmpy) + E.&&. E.notExists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorSupervisor) cmpy) + return $ usrSuper E.^. UserSupervisorSupervisor mkFirmAllTable :: Bool -> UserId -> DB (Any, Widget) mkFirmAllTable isAdmin uid = do @@ -79,46 +117,33 @@ mkFirmAllTable isAdmin uid = do resultDBTable = DBTable{..} where dbtSQLQuery cmpy = do - let filterCmpy usrCmpy = usrCmpy E.^. UserCompanyCompany E.==. cmpy E.^. CompanyId - cforeign = E.subSelectCount $ E.distinct $ do - usrSuper <- E.from $ E.table @UserSupervisor - E.where_ $ E.exists (do - usrCmpy <- E.from $ E.table @UserCompany - E.where_ $ filterCmpy usrCmpy E.&&. usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorUser - ) E.&&. E.notExists (do - usrCmpy <- E.from $ E.table @UserCompany - E.where_ $ filterCmpy usrCmpy E.&&. usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorSupervisor - ) - return $ usrSuper E.^. UserSupervisorSupervisor - cusers = E.subSelectCount $ do - usrCmpy <- E.from $ E.table @UserCompany - E.where_ $ filterCmpy usrCmpy - csupers = E.subSelectCount $ do - usrCmpy <- E.from $ E.table @UserCompany - E.where_ $ filterCmpy usrCmpy E.&&. usrCmpy E.^. UserCompanySupervisor unless isAdmin $ E.where_ $ E.exists $ do -- only show associated companies usrCmpy <- E.from $ E.table @UserCompany - E.where_ $ filterCmpy usrCmpy E.&&. usrCmpy E.^. UserCompanyUser E.==. E.val uid - return (cmpy, csupers, cusers, cforeign) + E.where_ $ usrCmpy E.^. UserCompanyCompany E.==. cmpy E.^. CompanyId + E.&&. usrCmpy E.^. UserCompanyUser E.==. E.val uid + return (cmpy, firmCountForeignSupervisors cmpy, firmCountUsers cmpy, firmCountSupervisors cmpy) dbtRowKey = (E.^. CompanyShorthand) dbtProj = dbtProjId dbtColonnade = dbColonnade $ mconcat [ -- if not isAdmin then mempty else dbSelect (applying _2) id (return . view (resultAllCompany . _companyShorthand)) - sortable (Just "name") (i18nCell MsgTableCompany) $ \(view resultAllCompany -> firm) -> + 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 "nr") (i18nCell MsgTableCompanyNo) $ \(view resultAllCompany -> firm) -> + , sortable (Just "avsnr") (i18nCell MsgTableCompanyNo) $ \(view resultAllCompany -> firm) -> anchorCell (FirmR $ companyShorthand firm) $ toWgt $ companyAvsId firm - , sortable Nothing (i18nCell MsgTableCompanyNrUsers) $ \(view resultAllCompanyUsers -> nr) -> wgtCell $ word2widget nr - , sortable Nothing (i18nCell MsgTableCompanyNrSupers) $ \(view resultAllCompanySupervisors -> nr) -> wgtCell $ word2widget nr - , sortable Nothing (i18nCell MsgTableCompanyNrForeignSupers) $ \(view resultAllCompanyForeignSupers -> 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 "foreigners") (i18nCell MsgTableCompanyNrForeignSupers) $ \(view resultAllCompanyForeignSupers -> nr) -> wgtCell $ word2widget nr ] dbtSorting = mconcat - [ singletonMap "name" $ SortColumn (E.^. CompanyName) - , singletonMap "short" $ SortColumn (E.^. CompanyShorthand) - , singletonMap "nr" $ SortColumn (E.^. CompanyAvsId) + [ singletonMap "name" $ SortColumn (E.^. CompanyName) + , singletonMap "short" $ SortColumn (E.^. CompanyShorthand) + , singletonMap "avsnr" $ SortColumn (E.^. CompanyAvsId) + , singletonMap "users" $ SortColumn firmCountUsers + , singletonMap "supervisors" $ SortColumn firmCountSupervisors + , singletonMap "foreigners" $ SortColumn firmCountForeignSupervisors ] dbtFilter = mconcat [ diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index c927cc8f8..84892c760 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -3,7 +3,6 @@ -- SPDX-License-Identifier: AGPL-3.0-or-later {-# OPTIONS_GHC -fno-warn-orphans #-} -- needed for HasEntity instances -{-# OPTIONS -Wno-unused-top-binds #-} -- TODO: remove me, for debugging only {-# LANGUAGE TypeApplications #-} module Handler.LMS diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index a4d2ab2c4..ce98b437f 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -636,6 +636,7 @@ fillDb = do void . insert' $ UserCompany fhamann bpol False False void . insert' $ UserCompany fhamann ffacil True True void . insert' $ UserCompany fhamann nice False False + insertMany_ [UserCompany uid fraGround False False| Entity uid User{userMatrikelnummer = fmap readMay -> Just (Just n)} <- matUsers] -- void . insert' $ UserSupervisor jost gkleen True -- void . insert' $ UserSupervisor jost svaupel False -- void . insert' $ UserSupervisor jost sbarth False From 601ce7abdf2a392d30f1ff799a2338968be795f1 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 20 Oct 2023 15:29:40 +0000 Subject: [PATCH 09/50] fix(firm): foreign supervisor counts correct and sortable --- src/Database/Esqueleto/Utils.hs | 7 ++ src/Handler/Firm.hs | 120 ++++++++++++++++++++++++-------- src/Utils.hs | 3 + test/Database/Fill.hs | 7 +- 4 files changed, 106 insertions(+), 31 deletions(-) diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index 70cdaaecc..af0fd0e76 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -43,6 +43,7 @@ module Database.Esqueleto.Utils , (->.), (->>.), (#>>.) , fromSqlKey , unKey + , subSelectCountDistinct , selectCountRows, selectCountDistinct , selectMaybe , day, day', dayMaybe, interval, diffDays, diffTimes @@ -628,6 +629,12 @@ unKey :: ( Coercible (Key entity) a unKey = E.veryUnsafeCoerceSqlExprValue +subSelectCountDistinct :: (Num a, PersistField a) => Ex.SqlQuery (Ex.SqlExpr (Ex.Value typ)) -> Ex.SqlExpr (Ex.Value a) +subSelectCountDistinct query = Ex.subSelectUnsafe (Ex.countDistinct <$> query) + +-- PersistField a => SqlQuery (SqlExpr (Value a)) -> SqlExpr (Value a) +-- countDistinct :: Num a => SqlExpr (Value typ) -> SqlExpr (Value a) + selectCountRows :: (Num a, PersistField a, MonadIO m) => E.SqlQuery ignored -> E.SqlReadT m a selectCountRows q = do res <- E.select $ E.countRows <$ q diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index de717655f..d711045a7 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -2,13 +2,15 @@ -- -- SPDX-License-Identifier: AGPL-3.0-or-later -{-# OPTIONS -Wno-unused-top-binds #-} -- TODO: remove me, for debugging only +{-# OPTIONS -Wno-unused-top-binds -Wno-unused-imports #-} -- TODO: remove me, for debugging only {-# OPTIONS_GHC -fno-warn-orphans #-} -- needed for HasEntity instances {-# LANGUAGE TypeApplications #-} module Handler.Firm - ( getFirmAllR - , getFirmR, postFirmR + ( getFirmAllR , postFirmAllR + , getFirmR , postFirmR + , getFirmUsersR , postFirmUsersR + , getFirmSupersR, postFirmSupersR ) where @@ -24,11 +26,11 @@ import Handler.Utils -- import qualified Data.CaseInsensitive as CI -- import qualified Data.Conduit.List as C -- import Database.Persist.Sql (updateWhereCount) --- import Database.Esqueleto.Experimental ((:&)(..)) +import Database.Esqueleto.Experimental ((:&)(..)) import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma --- import qualified Database.Esqueleto.Legacy as E +-- import qualified Database.Esqueleto.Legacy as EL -- import qualified Database.Esqueleto.PostgreSQL as E --- import qualified Database.Esqueleto.Utils as E +import qualified Database.Esqueleto.Utils as E import Database.Esqueleto.Utils.TH @@ -40,32 +42,58 @@ import Database.Esqueleto.Utils.TH getFirmR, postFirmR :: CompanyShorthand -> Handler Html getFirmR = postFirmR postFirmR fsh = do + let fshId = CompanyKey fsh cusers <- runDB $ do - cusers <- selectList [UserCompanyCompany ==. CompanyKey fsh] [] + cusers <- selectList [UserCompanyCompany ==. fshId] [] selectList [UserId <-. fmap (userCompanyUser . entityVal) cusers] [Asc UserDisplayName] csuper <- runDB $ do - csuper <- selectList [UserCompanyCompany ==. CompanyKey fsh, UserCompanySupervisor ==. True] [] + csuper <- selectList [UserCompanyCompany ==. fshId, UserCompanySupervisor ==. True] [] selectList [UserId <-. fmap (userCompanyUser . entityVal) csuper] [Asc UserDisplayName] - siteLayoutMsg MsgMenuFirms $ do - setTitleI MsgMenuFirms - [whamlet|STUB HANDLER FOR #{fsh} TO DO - -

      Supervisors (non-foreign only) + cactSuper <- runDB $ E.select $ do + (usr :& spr :& scmpy) <- E.from $ + E.table @User + `E.innerJoin` E.table @UserSupervisor + `E.on` (\(usr :& spr ) -> spr E.^. UserSupervisorSupervisor E.==. usr E.^. UserId) + `E.leftJoin` E.table @UserCompany + `E.on` (\(_ :& spr :& scmpy) -> spr E.^. UserSupervisorSupervisor E.=?. scmpy E.?. UserCompanyUser) + E.where_ $ (spr E.^. UserSupervisorUser) `E.in_` E.valList (entityKey <$> cusers) + E.groupBy (usr E.^. UserId, usr E.^. UserDisplayName, usr E.^. UserSurname, 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 + return (usr E.^. UserId, usr E.^. UserDisplayName, usr E.^. UserSurname, scmpy E.?. UserCompanyCompany, countRows') + + siteLayoutMsg (SomeMessage fsh) $ do + setTitle $ citext2Html fsh + [whamlet| +

      #{length csuper} Company Default Supervisors (non-foreign only)
        $forall u <- csuper -
      • ^{userWidget u} +
      • ^{linkUserWidget ForProfileDataR u} -

        Employees +

        #{length cactSuper} Active Supervisors for Employees +
          + $forall (E.Value _, E.Value dn, E.Value sn, E.Value mbCsh, E.Value nr) <- cactSuper +
        • #{nr} Employees supervised by ^{nameWidget dn sn} + $maybe csh <- mbCsh + $if csh /= fshId + from foreign company #{unCompanyKey csh} + $else + from this company + $nothing + having no associated company + +

          #{length cusers} Employees
            $forall u <- cusers -
          • ^{userWidget u} +
          • ^{linkUserWidget ForProfileDataR u} In the end, this needs to be a dbTable, of course! |] -getFirmAllR :: Handler Html -getFirmAllR = do +getFirmAllR, postFirmAllR :: Handler Html +getFirmAllR = postFirmAllR +postFirmAllR = do uid <- requireAuthId isAdmin <- hasReadAccessTo AdminR firmTable <- runDB $ do @@ -82,11 +110,11 @@ type AllCompanyTableData = DBRow (Entity Company, E.Value Word64, E.Value Word64 resultAllCompany :: Lens' AllCompanyTableData Company resultAllCompany = _dbrOutput . _1 . _entityVal -resultAllCompanySupervisors :: Lens' AllCompanyTableData Word64 -resultAllCompanySupervisors = _dbrOutput . _2 . _unValue - resultAllCompanyUsers :: Lens' AllCompanyTableData Word64 -resultAllCompanyUsers = _dbrOutput . _3 . _unValue +resultAllCompanyUsers = _dbrOutput . _2 . _unValue + +resultAllCompanySupervisors :: Lens' AllCompanyTableData Word64 +resultAllCompanySupervisors = _dbrOutput . _3 . _unValue resultAllCompanyForeignSupers :: Lens' AllCompanyTableData Word64 resultAllCompanyForeignSupers = _dbrOutput . _4 . _unValue @@ -102,13 +130,30 @@ firmCountUsers = E.subSelectCount . fromUserCompany Nothing firmCountSupervisors :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) firmCountSupervisors = E.subSelectCount . fromUserCompany (Just (E.^. UserCompanySupervisor)) +-- firmCountSupervisors :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) +-- firmCountSupervisors cmpy = E.subSelectCount $ E.distinct $ do +-- usrCmpy <- E.from $ E.table @UserCompany +-- E.where_ $ (usrCmpy E.^. UserCompanyCompany E.==. cmpy E.^. CompanyId) +-- E.&&. (usrCmpy E.^. UserCompanySupervisor E.==. E.true) +-- return $ usrCmpy E.^. UserCompanyUser + +-- firmCountForeignSupervisors :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) +-- firmCountForeignSupervisors cmpy = E.coalesceDefault +-- [E.subSelect $ do +-- usrSuper <- E.from $ E.table @UserSupervisor +-- E.groupBy (usrSuper E.^. UserSupervisorSupervisor) +-- E.where_ $ E.exists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorUser) cmpy) +-- E.&&. E.notExists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorSupervisor) cmpy) +-- return E.countRows +-- ] (E.val 0) firmCountForeignSupervisors :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) -firmCountForeignSupervisors cmpy = E.subSelectCount $ E.distinct $ do - usrSuper <- E.from $ E.table @UserSupervisor - E.where_ $ E.exists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorUser) cmpy) - E.&&. E.notExists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorSupervisor) cmpy) - return $ usrSuper E.^. UserSupervisorSupervisor +firmCountForeignSupervisors cmpy = E.subSelectCountDistinct $ do + usrSuper <- E.from $ E.table @UserSupervisor + E.where_ $ E.exists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorUser) cmpy) + E.&&. E.notExists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorSupervisor) cmpy) + pure $ usrSuper E.^. UserSupervisorSupervisor + mkFirmAllTable :: Bool -> UserId -> DB (Any, Widget) mkFirmAllTable isAdmin uid = do @@ -121,8 +166,8 @@ mkFirmAllTable isAdmin uid = do usrCmpy <- E.from $ E.table @UserCompany E.where_ $ usrCmpy E.^. UserCompanyCompany E.==. cmpy E.^. CompanyId E.&&. usrCmpy E.^. UserCompanyUser E.==. E.val uid - return (cmpy, firmCountForeignSupervisors cmpy, firmCountUsers cmpy, firmCountSupervisors cmpy) - dbtRowKey = (E.^. CompanyShorthand) + return (cmpy, firmCountUsers cmpy, firmCountSupervisors cmpy, firmCountForeignSupervisors cmpy) + dbtRowKey = (E.^. CompanyId) dbtProj = dbtProjId dbtColonnade = dbColonnade $ mconcat [ -- if not isAdmin then mempty else dbSelect (applying _2) id (return . view (resultAllCompany . _companyShorthand)) @@ -169,6 +214,23 @@ mkFirmAllTable isAdmin uid = do -- -- getQualificationEditR = postQualificationEditR -- -- postQualificationEditR = error "TODO" +getFirmUsersR, postFirmUsersR :: CompanyShorthand -> Handler Html +getFirmUsersR = postFirmUsersR +postFirmUsersR fsh = do + let _fshId = CompanyKey fsh + siteLayout (citext2widget fsh) $ do + setTitle $ citext2Html fsh + [whamlet|!!!STUB!!!TO DO!!!|] + +getFirmSupersR, postFirmSupersR :: CompanyShorthand -> Handler Html +getFirmSupersR = postFirmSupersR +postFirmSupersR fsh = do + let _fshId = CompanyKey fsh + siteLayout (citext2widget fsh) $ do + setTitle $ citext2Html fsh + [whamlet|!!!STUB!!!TO DO!!!|] + + -- data QualificationTableCsv = QualificationTableCsv -- Q..T..C.. -> qtc.. -- { qtcDisplayName :: UserDisplayName -- , qtcEmail :: UserEmail diff --git a/src/Utils.hs b/src/Utils.hs index 28b7d88a8..e91f92015 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -364,6 +364,9 @@ text2asciiAlphaNum = Text.filter (\c -> Char.isAlphaNum c && Char.isAscii c) text2Html :: Text -> Html text2Html = toHtml +citext2Html :: CI Text -> Html +citext2Html = toHtml . CI.original + char2Text :: Char -> Text char2Text c | isSpace c = "" diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index ce98b437f..8bda1668b 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -569,7 +569,7 @@ fillDb = do userDisplayEmail' = CI.mk $ case userSurname of "Walker" -> "AVSNO:" <> userMatrikelnummer' "Clark" -> "E" <> userMatrikelnummer' <> "@fraport.de" - "Elizabeth" -> "" + "Jackson" -> "" _ -> userIdent matrikel <- toMatrikel <$> getRandomRs (0 :: Int, 9 :: Int) @@ -636,7 +636,10 @@ fillDb = do void . insert' $ UserCompany fhamann bpol False False void . insert' $ UserCompany fhamann ffacil True True void . insert' $ UserCompany fhamann nice False False - insertMany_ [UserCompany uid fraGround False False| Entity uid User{userMatrikelnummer = fmap readMay -> Just (Just n)} <- matUsers] + insertMany_ [UserCompany uid fraGround False False| Entity uid User{userFirstName = "John"} <- matUsers] + insertMany_ [UserCompany uid bpol False False| Entity uid User{userFirstName = "Elizabeth"} <- matUsers] + insertMany_ [UserCompany uid bpol True True| Entity uid User{userFirstName = "Clark", userDisplayName = dn} <- matUsers, dn == "Walker" || dn == "John"] + insertMany_ [UserCompany uid ffacil False False| Entity uid User{userSurname = "Walker"} <- matUsers] -- void . insert' $ UserSupervisor jost gkleen True -- void . insert' $ UserSupervisor jost svaupel False -- void . insert' $ UserSupervisor jost sbarth False From 6d221fa3c2878da69c3eec61a4593152e42482a8 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 20 Oct 2023 16:44:55 +0000 Subject: [PATCH 10/50] chore(firm): add rerouting counts --- .../utils/table_column/de-de-formal.msg | 2 + messages/uniworx/utils/table_column/en-eu.msg | 2 + routes | 6 +- src/Database/Esqueleto/Utils.hs | 2 +- src/Foundation/Navigation.hs | 24 +++++++ src/Handler/Firm.hs | 64 +++++++++++++++---- src/Utils/Icon.hs | 2 + test/Database/Fill.hs | 11 +++- 8 files changed, 94 insertions(+), 19 deletions(-) diff --git a/messages/uniworx/utils/table_column/de-de-formal.msg b/messages/uniworx/utils/table_column/de-de-formal.msg index b25230af4..850cbb651 100644 --- a/messages/uniworx/utils/table_column/de-de-formal.msg +++ b/messages/uniworx/utils/table_column/de-de-formal.msg @@ -82,6 +82,8 @@ TableCompanyNos: Firmennummern TableCompanyNrUsers: Firmenangehörige TableCompanyNrSupers: Ansprechpartner TableCompanyNrForeignSupers: Firmenfremde Ansprechpartner +TableCompanyNrRerouteDefault: Standard Umleitungen +TableCompanyNrRerouteActive: Aktive Umleitungen TableSupervisor: Ansprechpartner TableCreationTime: Erstellungszeit TableJob !ident-ok: Job diff --git a/messages/uniworx/utils/table_column/en-eu.msg b/messages/uniworx/utils/table_column/en-eu.msg index e3d095d4f..5642ba22f 100644 --- a/messages/uniworx/utils/table_column/en-eu.msg +++ b/messages/uniworx/utils/table_column/en-eu.msg @@ -82,6 +82,8 @@ TableCompanyNos: Company numbers TableCompanyNrUsers: Associates TableCompanyNrSupers: Supervisors TableCompanyNrForeignSupers: External Supervisors +TableCompanyNrRerouteDefault: Default reroutes +TableCompanyNrRerouteActive: Active reroutes TableSupervisor: Supervisor TableCreationTime: Creation TableJob !ident-ok: Job diff --git a/routes b/routes index b4485c890..e6e4618b7 100644 --- a/routes +++ b/routes @@ -113,8 +113,10 @@ /for/#CryptoUUIDUser/user ForProfileR GET POST !supervisor !self /for/#CryptoUUIDUser/user/profile ForProfileDataR GET !supervisor !self -/firm FirmAllR GET -/firm/#CompanyShorthand FirmR GET POST +/firm FirmAllR GET +/firm/#CompanyShorthand FirmR GET POST +/firm/#CompanyShorthand/users FirmUsersR GET POST +/firm/#CompanyShorthand/supers FirmSupersR GET POST /exam-office ExamOfficeR !exam-office: / EOExamsR GET POST !system-exam-office diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index af0fd0e76..f9a1dde82 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -628,7 +628,7 @@ unKey :: ( Coercible (Key entity) a => E.SqlExpr (E.Value (Key entity)) -> E.SqlExpr (E.Value a) unKey = E.veryUnsafeCoerceSqlExprValue - +-- | distinct version of `Database.Esqueleto.subSelectCount` subSelectCountDistinct :: (Num a, PersistField a) => Ex.SqlQuery (Ex.SqlExpr (Ex.Value typ)) -> Ex.SqlExpr (Ex.Value a) subSelectCountDistinct query = Ex.subSelectUnsafe (Ex.countDistinct <$> query) diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index a38b62b93..4c405b25f 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -125,6 +125,8 @@ breadcrumb ProblemAvsErrorR = i18nCrumb MsgProblemsAvsErrorHeading $ Just breadcrumb FirmAllR = i18nCrumb MsgMenuFirms Nothing breadcrumb FirmR{} = i18nCrumb MsgMenuFirms $ Just FirmAllR +breadcrumb FirmUsersR{} = i18nCrumb MsgMenuFirms $ Just FirmAllR +breadcrumb FirmSupersR{} = i18nCrumb MsgMenuFirms $ Just FirmAllR breadcrumb PrintCenterR = i18nCrumb MsgMenuApc Nothing breadcrumb PrintSendR = i18nCrumb MsgMenuPrintSend $ Just PrintCenterR @@ -757,6 +759,18 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the , navForceActive = False } } + , return NavHeader + { navHeaderRole = NavHeaderPrimary + , navIcon = IconCompany + , navLink = NavLink + { navLabel = MsgMenuFirms + , navRoute = FirmAllR + , navAccess' = NavAccessTrue + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + } , return NavHeader { navHeaderRole = NavHeaderPrimary , navIcon = IconPrintCenter @@ -2401,6 +2415,16 @@ pageActions ApiDocsR = return , navChildren = [] } ] +pageActions (FirmR fsh) = return + [ NavPageActionPrimary + { navLink = defNavLink MsgTableCompanyNrSupers $ FirmSupersR fsh + , navChildren = [] + } + , NavPageActionPrimary + { navLink = defNavLink MsgTableCompanyNrUsers $ FirmUsersR fsh + , navChildren = [] + } + ] pageActions PrintCenterR = do openDays <- useRunDB $ Ex.select $ do pj <- Ex.from $ Ex.table @PrintJob diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index d711045a7..0af9b186c 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -106,18 +106,27 @@ postFirmAllR = do |] -type AllCompanyTableData = DBRow (Entity Company, E.Value Word64, E.Value Word64, E.Value Word64) -resultAllCompany :: Lens' AllCompanyTableData Company -resultAllCompany = _dbrOutput . _1 . _entityVal +type AllCompanyTableData = DBRow (Entity Company, E.Value Word64, E.Value Word64, E.Value Word64, E.Value Word64, E.Value Word64, E.Value Word64) +resultAllCompany :: Lens' AllCompanyTableData Company +resultAllCompany = _dbrOutput . _1 . _entityVal -resultAllCompanyUsers :: Lens' AllCompanyTableData Word64 -resultAllCompanyUsers = _dbrOutput . _2 . _unValue +resultAllCompanyUsers :: Lens' AllCompanyTableData Word64 +resultAllCompanyUsers = _dbrOutput . _2 . _unValue -resultAllCompanySupervisors :: Lens' AllCompanyTableData Word64 -resultAllCompanySupervisors = _dbrOutput . _3 . _unValue +resultAllCompanySupervisors :: Lens' AllCompanyTableData Word64 +resultAllCompanySupervisors = _dbrOutput . _3 . _unValue -resultAllCompanyForeignSupers :: Lens' AllCompanyTableData Word64 -resultAllCompanyForeignSupers = _dbrOutput . _4 . _unValue +resultAllCompanyForeignSupers :: Lens' AllCompanyTableData Word64 +resultAllCompanyForeignSupers = _dbrOutput . _4 . _unValue + +resultAllCompanyDefaultReroutes :: Lens' AllCompanyTableData Word64 +resultAllCompanyDefaultReroutes = _dbrOutput . _5 . _unValue + +resultAllCompanyActiveReroutes :: Lens' AllCompanyTableData Word64 +resultAllCompanyActiveReroutes = _dbrOutput . _6 . _unValue + +resultAllCompanyActiveReroutes' :: Lens' AllCompanyTableData Word64 +resultAllCompanyActiveReroutes' = _dbrOutput . _7 . _unValue fromUserCompany :: Maybe (E.SqlExpr (Entity UserCompany) -> E.SqlExpr (E.Value Bool)) -> E.SqlExpr (Entity Company) -> E.SqlQuery () fromUserCompany mbFltr cmpy = do @@ -137,6 +146,9 @@ firmCountSupervisors = E.subSelectCount . fromUserCompany (Just (E.^. UserCompa -- E.&&. (usrCmpy E.^. UserCompanySupervisor E.==. E.true) -- return $ usrCmpy E.^. UserCompanyUser +firmCountDefaultReroutes :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) +firmCountDefaultReroutes = E.subSelectCount . fromUserCompany (Just (\uc -> uc E.^. UserCompanySupervisor E.&&. uc E.^. UserCompanySupervisorReroute)) + -- firmCountForeignSupervisors :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) -- firmCountForeignSupervisors cmpy = E.coalesceDefault -- [E.subSelect $ do @@ -154,6 +166,19 @@ firmCountForeignSupervisors cmpy = E.subSelectCountDistinct $ do E.&&. E.notExists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorSupervisor) cmpy) pure $ usrSuper E.^. UserSupervisorSupervisor +firmCountActiveReroutes :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) +firmCountActiveReroutes cmpy = E.subSelectCountDistinct $ do + usrSuper <- E.from $ E.table @UserSupervisor + E.where_ $ E.exists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorUser) cmpy) + E.&&. usrSuper E.^. UserSupervisorRerouteNotifications + pure $ usrSuper E.^. UserSupervisorSupervisor + +firmCountActiveReroutes' :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) +firmCountActiveReroutes' cmpy = E.subSelectCount $ do + usrSuper <- E.from $ E.table @UserSupervisor + E.where_ $ E.exists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorUser) cmpy) + E.&&. usrSuper E.^. UserSupervisorRerouteNotifications + mkFirmAllTable :: Bool -> UserId -> DB (Any, Widget) mkFirmAllTable isAdmin uid = do @@ -166,7 +191,14 @@ mkFirmAllTable isAdmin uid = do usrCmpy <- E.from $ E.table @UserCompany E.where_ $ usrCmpy E.^. UserCompanyCompany E.==. cmpy E.^. CompanyId E.&&. usrCmpy E.^. UserCompanyUser E.==. E.val uid - return (cmpy, firmCountUsers cmpy, firmCountSupervisors cmpy, firmCountForeignSupervisors cmpy) + return ( cmpy + , cmpy & firmCountUsers + , cmpy & firmCountSupervisors + , cmpy & firmCountForeignSupervisors + , cmpy & firmCountDefaultReroutes + , cmpy & firmCountActiveReroutes + , cmpy & firmCountActiveReroutes' + ) dbtRowKey = (E.^. CompanyId) dbtProj = dbtProjId dbtColonnade = dbColonnade $ mconcat @@ -178,9 +210,12 @@ mkFirmAllTable isAdmin uid = do in anchorCell (FirmR fsh) $ toWgt fsh , 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 "foreigners") (i18nCell MsgTableCompanyNrForeignSupers) $ \(view resultAllCompanyForeignSupers -> 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 "reroute-def") (i18nCell MsgTableCompanyNrRerouteDefault) $ \(view resultAllCompanyDefaultReroutes -> nr) -> wgtCell $ word2widget nr + , sortable (Just "foreigners") (i18nCell MsgTableCompanyNrForeignSupers) $ \(view resultAllCompanyForeignSupers -> nr) -> wgtCell $ word2widget nr + , sortable (Just "reroute-act") (i18nCell MsgTableCompanyNrRerouteActive) $ \(view resultAllCompanyActiveReroutes -> nr) -> wgtCell $ word2widget nr + , sortable (Just "reroute-all") (i18nCell MsgTableCompanyNrRerouteActive) $ \(view resultAllCompanyActiveReroutes' -> nr) -> wgtCell $ word2widget nr ] dbtSorting = mconcat [ singletonMap "name" $ SortColumn (E.^. CompanyName) @@ -188,7 +223,10 @@ mkFirmAllTable isAdmin uid = do , singletonMap "avsnr" $ SortColumn (E.^. CompanyAvsId) , singletonMap "users" $ SortColumn firmCountUsers , singletonMap "supervisors" $ SortColumn firmCountSupervisors + , singletonMap "reroute-def" $ SortColumn firmCountDefaultReroutes , singletonMap "foreigners" $ SortColumn firmCountForeignSupervisors + , singletonMap "reroute-act" $ SortColumn firmCountActiveReroutes + , singletonMap "reroute-all" $ SortColumn firmCountActiveReroutes' ] dbtFilter = mconcat [ diff --git a/src/Utils/Icon.hs b/src/Utils/Icon.hs index 2c8d9de6a..a3602faec 100644 --- a/src/Utils/Icon.hs +++ b/src/Utils/Icon.hs @@ -114,6 +114,7 @@ data Icon | IconLocked | IconUnlocked | IconResetTries -- also see IconReset + | IconCompany deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic) deriving anyclass (Universe, Finite, NFData) @@ -205,6 +206,7 @@ iconText = \case IconLocked -> "lock" IconUnlocked -> "lock-open-alt" IconResetTries -> "trash-undo" + IconCompany -> "building" nullaryPathPiece ''Icon $ camelToPathPiece' 1 deriveLift ''Icon diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index 8bda1668b..7161397c7 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -636,9 +636,10 @@ fillDb = do void . insert' $ UserCompany fhamann bpol False False void . insert' $ UserCompany fhamann ffacil True True void . insert' $ UserCompany fhamann nice False False + -- need more tests insertMany_ [UserCompany uid fraGround False False| Entity uid User{userFirstName = "John"} <- matUsers] insertMany_ [UserCompany uid bpol False False| Entity uid User{userFirstName = "Elizabeth"} <- matUsers] - insertMany_ [UserCompany uid bpol True True| Entity uid User{userFirstName = "Clark", userDisplayName = dn} <- matUsers, dn == "Walker" || dn == "John"] + insertMany_ [UserCompany uid bpol True True| Entity uid User{userFirstName = "Clark", userSurname = dn} <- matUsers, dn == "Walker" || dn == "Robinson"] insertMany_ [UserCompany uid ffacil False False| Entity uid User{userSurname = "Walker"} <- matUsers] -- void . insert' $ UserSupervisor jost gkleen True -- void . insert' $ UserSupervisor jost svaupel False @@ -651,13 +652,17 @@ fillDb = do , UserSupervisor jost svaupel False , UserSupervisor jost sbarth False , UserSupervisor jost tinaTester True + , UserSupervisor jost jost True , UserSupervisor svaupel gkleen False , UserSupervisor svaupel fhamann True , UserSupervisor sbarth tinaTester True , UserSupervisor gkleen fhamann False + , UserSupervisor gkleen gkleen True + , UserSupervisor tinaTester tinaTester False ] - ++ take 333 [ UserSupervisor fhamann uid False | Entity uid _ <- matUsers ] - ++ take 111 [ UserSupervisor gkleen uid False | Entity uid _ <- drop 300 matUsers ] + ++ take 333 [ UserSupervisor fhamann uid True | Entity uid _ <- matUsers ] + ++ take 111 [ UserSupervisor gkleen uid True | Entity uid _ <- drop 300 matUsers ] + ++ take 11 [ UserSupervisor jost uid False | Entity uid _ <- drop 401 matUsers ] upsertManyWhere supvs [] [] [] -- upsertManyWhere supvs [] [] [] -- NOTE: multiple calls like this are ok -- insertMany_ supvs -- NOTE: multiple calls like this throw an error! From ebecbf5c7f021a61af01eddb98d4ed6ac9d52e1f Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 23 Oct 2023 13:58:01 +0000 Subject: [PATCH 11/50] chore(firm): add table actions (WIP) --- .../uniworx/categories/firm/de-de-formal.msg | 7 ++ messages/uniworx/categories/firm/en-eu.msg | 6 ++ .../utils/table_column/de-de-formal.msg | 2 + messages/uniworx/utils/table_column/en-eu.msg | 2 + src/Foundation/I18n.hs | 9 ++- src/Handler/Firm.hs | 74 +++++++++++++------ src/Handler/LMS.hs | 5 +- 7 files changed, 78 insertions(+), 27 deletions(-) create mode 100644 messages/uniworx/categories/firm/de-de-formal.msg create mode 100644 messages/uniworx/categories/firm/en-eu.msg diff --git a/messages/uniworx/categories/firm/de-de-formal.msg b/messages/uniworx/categories/firm/de-de-formal.msg new file mode 100644 index 000000000..07bc13737 --- /dev/null +++ b/messages/uniworx/categories/firm/de-de-formal.msg @@ -0,0 +1,7 @@ +# SPDX-FileCopyrightText: 2023 Steffen Jost +# +# SPDX-License-Identifier: AGPL-3.0-or-later + +FirmAllActNotify: Mitteilung versenden +FirmAllActResetSupervision: Ansprechpartner für alle Firmenangehörigen zurücksetzen + diff --git a/messages/uniworx/categories/firm/en-eu.msg b/messages/uniworx/categories/firm/en-eu.msg new file mode 100644 index 000000000..dcfeea99c --- /dev/null +++ b/messages/uniworx/categories/firm/en-eu.msg @@ -0,0 +1,6 @@ +# SPDX-FileCopyrightText: 2023 Steffen Jost +# +# SPDX-License-Identifier: AGPL-3.0-or-later + +FirmAllActNotify: Send message +FirmAllActResetSupervision: Reset supervisors for all company associates diff --git a/messages/uniworx/utils/table_column/de-de-formal.msg b/messages/uniworx/utils/table_column/de-de-formal.msg index 850cbb651..aee81f2bb 100644 --- a/messages/uniworx/utils/table_column/de-de-formal.msg +++ b/messages/uniworx/utils/table_column/de-de-formal.msg @@ -81,6 +81,8 @@ 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 diff --git a/messages/uniworx/utils/table_column/en-eu.msg b/messages/uniworx/utils/table_column/en-eu.msg index 5642ba22f..70583dfc7 100644 --- a/messages/uniworx/utils/table_column/en-eu.msg +++ b/messages/uniworx/utils/table_column/en-eu.msg @@ -81,6 +81,8 @@ 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 diff --git a/src/Foundation/I18n.hs b/src/Foundation/I18n.hs index 1271b4da4..a7fd0ac1d 100644 --- a/src/Foundation/I18n.hs +++ b/src/Foundation/I18n.hs @@ -1,7 +1,12 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost ,Steffen Jost ,Winnie Ros +-- SPDX-FileCopyrightText: 2022-23 Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost ,Steffen Jost ,Winnie Ros -- -- 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" diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 0af9b186c..653561d27 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -20,7 +20,7 @@ import Import import Handler.Utils -- 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 @@ -91,19 +91,20 @@ postFirmR fsh = do |] -getFirmAllR, postFirmAllR :: Handler Html -getFirmAllR = postFirmAllR -postFirmAllR = do - uid <- requireAuthId - isAdmin <- hasReadAccessTo AdminR - firmTable <- runDB $ do - view _2 <$> mkFirmAllTable isAdmin uid -- filter to associated companies for non-admins - siteLayoutMsg MsgMenuFirms $ do - setTitleI MsgMenuFirms - -- $(widgetFile "firm-all") - [whamlet|!!!STUB!!!TO DO!!! - ^{firmTable} - |] +----------------------- +-- All Firms Table + +data FirmAllAction = FirmAllActNotify + | FirmAllActResetSupervision + deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) + deriving anyclass (Universe, Finite) + +nullaryPathPiece ''FirmAllAction $ camelToPathPiece' 3 +embedRenderMessage ''UniWorX ''FirmAllAction id + +data FirmAllActionData = FirmAllActNotifyData { } + | FirmAllActResetSupervisionData + deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) type AllCompanyTableData = DBRow (Entity Company, E.Value Word64, E.Value Word64, E.Value Word64, E.Value Word64, E.Value Word64, E.Value Word64) @@ -180,7 +181,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 +191,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 @@ -202,8 +203,9 @@ mkFirmAllTable isAdmin uid = do dbtRowKey = (E.^. CompanyId) dbtProj = dbtProjId dbtColonnade = dbColonnade $ mconcat - [ -- if not isAdmin then mempty else dbSelect (applying _2) id (return . view (resultAllCompany . _companyShorthand)) - sortable (Just "name") (i18nCell MsgTableCompany) $ \(view resultAllCompany -> firm) -> + [ -- if not isAdmin then mempty else -- guardOnM idAdmin $ + dbSelect (applying _2) id (return . view (_dbrOutput . _1 . _entityKey)) + , sortable (Just "name") (i18nCell MsgTableCompany) $ \(view resultAllCompany -> firm) -> anchorCell (FirmR $ companyShorthand firm) . toWgt $ companyName firm , sortable (Just "short") (i18nCell MsgTableCompanyShort) $ \(view resultAllCompany -> firm) -> let fsh = companyShorthand firm @@ -211,7 +213,7 @@ mkFirmAllTable isAdmin uid = do , 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 @@ -242,15 +244,37 @@ mkFirmAllTable isAdmin uid = do dbtCsvDecode = Nothing dbtExtraReps = [] + postprocess :: FormResult (First act', DBFormResult CompanyId Bool FirmAllActionData) + -> FormResult ( act', 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 = def -- & defaultSorting [SortAscBy "school", SortAscBy "qshort"] - 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) -> addMessageI Info $ SomeMessage $ "Notify " <> length fids <> " companies. TODO" + (FirmAllActResetSupervisionData, fids) -> addMessageI Info $ SomeMessage $ "Reset " <> 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 +284,10 @@ postFirmUsersR fsh = do setTitle $ citext2Html fsh [whamlet|!!!STUB!!!TO DO!!!|] + +----------------------------- +-- Firm Supervisors Table + getFirmSupersR, postFirmSupersR :: CompanyShorthand -> Handler Html getFirmSupersR = postFirmSupersR postFirmSupersR fsh = do diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index 94d2df971..c0e32c3f4 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -359,9 +359,8 @@ data LmsTableAction = LmsActNotify | LmsActReset | LmsActRestart deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) - -instance Universe LmsTableAction -instance Finite LmsTableAction + deriving anyclass (Universe, Finite) + nullaryPathPiece ''LmsTableAction $ camelToPathPiece' 2 embedRenderMessage ''UniWorX ''LmsTableAction id From 19eea7abe8ddd317c8dc14cb1264bd07402414e2 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 24 Oct 2023 09:08:04 +0000 Subject: [PATCH 12/50] chore(firm): change dbTable to form with selection box (WIP) --- src/Handler/Firm.hs | 58 ++++++++++++++++++++++++++++++++++----------- 1 file changed, 44 insertions(+), 14 deletions(-) diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 653561d27..45b47f9da 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -102,14 +102,17 @@ data FirmAllAction = FirmAllActNotify nullaryPathPiece ''FirmAllAction $ camelToPathPiece' 3 embedRenderMessage ''UniWorX ''FirmAllAction id -data FirmAllActionData = FirmAllActNotifyData { } +data FirmAllActionData = FirmAllActNotifyData | FirmAllActResetSupervisionData deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) 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 @@ -181,12 +184,19 @@ firmCountActiveReroutes' cmpy = E.subSelectCount $ do E.&&. usrSuper E.^. UserSupervisorRerouteNotifications -mkFirmAllTable :: Bool -> UserId -> DB (FormResult (FirmAllActionData, Set CompanyId), Widget) +mkFirmAllTable :: + -- ( Functor h, ToSortable h + -- , AsCornice h p FirmAllActionData + -- (DBCell (MForm Handler) + -- (FormResult (First FirmAllActionData, DBFormResult CompanyId Bool FirmAllActionData)) + -- ) cols + -- ) => + Bool -> UserId -> DB (FormResult (FirmAllActionData, Set CompanyId), Widget) mkFirmAllTable isAdmin uid = do -- now <- liftIO getCurrentTime - let + let resultDBTable = DBTable{..} - where + where dbtSQLQuery cmpy = do unless isAdmin $ E.where_ $ E.exists $ do -- only show associated companies usrCmpy <- E.from $ E.table @UserCompany @@ -202,9 +212,11 @@ mkFirmAllTable isAdmin uid = do ) dbtRowKey = (E.^. CompanyId) dbtProj = dbtProjId - dbtColonnade = dbColonnade $ mconcat + dbtColonnade = -- formColonnade $ + mconcat [ -- if not isAdmin then mempty else -- guardOnM idAdmin $ - dbSelect (applying _2) id (return . view (_dbrOutput . _1 . _entityKey)) + -- hole :: (x -> f x) -> r -> f r + 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) -> @@ -237,22 +249,40 @@ mkFirmAllTable isAdmin uid = do [ ] 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 act', DBFormResult CompanyId Bool FirmAllActionData) - -> FormResult ( act', Set CompanyId) + postprocess :: FormResult (First FirmAllActionData, DBFormResult CompanyId Bool FirmAllActionData) + -> 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)) -- This type signature is not optional! resultDBTableValidator = def - -- & defaultSorting [SortAscBy "school", SortAscBy "qshort"] + & defaultSorting [SortAscBy "short"] over _1 postprocess <$> dbTable resultDBTableValidator resultDBTable @@ -263,8 +293,8 @@ postFirmAllR = do isAdmin <- hasReadAccessTo AdminR (firmRes, firmTable) <- runDB $ mkFirmAllTable isAdmin uid -- filters to associated companies for non-admins formResult firmRes $ \case - (FirmAllActNotifyData, fids) -> addMessageI Info $ SomeMessage $ "Notify " <> length fids <> " companies. TODO" - (FirmAllActResetSupervisionData, fids) -> addMessageI Info $ SomeMessage $ "Reset " <> length fids <> " companies. TODO" + (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") From dfa03f8ba80009f01bb80cbc0b57d61e5b212df3 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 24 Oct 2023 10:07:12 +0000 Subject: [PATCH 13/50] refactor(firm): dbTable form for firm all with selection box working now --- src/Handler/Firm.hs | 253 +++++++++++++++----------- src/Handler/Utils/Table/Pagination.hs | 14 +- 2 files changed, 156 insertions(+), 111 deletions(-) diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 45b47f9da..5aafa0ed9 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -7,7 +7,7 @@ {-# LANGUAGE TypeApplications #-} module Handler.Firm - ( getFirmAllR , postFirmAllR + ( getFirmAllR , postFirmAllR , getFirmR , postFirmR , getFirmUsersR , postFirmUsersR , getFirmSupersR, postFirmSupersR @@ -43,14 +43,14 @@ getFirmR, postFirmR :: CompanyShorthand -> Handler Html getFirmR = postFirmR postFirmR fsh = do let fshId = CompanyKey fsh - cusers <- runDB $ do + cusers <- runDB $ do cusers <- selectList [UserCompanyCompany ==. fshId] [] selectList [UserId <-. fmap (userCompanyUser . entityVal) cusers] [Asc UserDisplayName] - csuper <- runDB $ do + csuper <- runDB $ do csuper <- selectList [UserCompanyCompany ==. fshId, UserCompanySupervisor ==. True] [] selectList [UserId <-. fmap (userCompanyUser . entityVal) csuper] [Asc UserDisplayName] - cactSuper <- runDB $ E.select $ do - (usr :& spr :& scmpy) <- E.from $ + cactSuper <- runDB $ E.select $ do + (usr :& spr :& scmpy) <- E.from $ E.table @User `E.innerJoin` E.table @UserSupervisor `E.on` (\(usr :& spr ) -> spr E.^. UserSupervisorSupervisor E.==. usr E.^. UserId) @@ -61,28 +61,28 @@ postFirmR fsh = do E.orderBy [E.asc $ usr E.^. UserId, E.asc $ usr E.^. UserDisplayName, E.asc $ usr E.^. UserSurname, E.asc $ scmpy E.?. UserCompanyCompany] let countRows' :: E.SqlExpr (E.Value Int64) = E.countRows return (usr E.^. UserId, usr E.^. UserDisplayName, usr E.^. UserSurname, scmpy E.?. UserCompanyCompany, countRows') - - siteLayoutMsg (SomeMessage fsh) $ do + + siteLayoutMsg (SomeMessage fsh) $ do setTitle $ citext2Html fsh - [whamlet| + [whamlet|

            #{length csuper} Company Default Supervisors (non-foreign only) -
              +
                $forall u <- csuper
              • ^{linkUserWidget ForProfileDataR u}

                #{length cactSuper} Active Supervisors for Employees -
                  +
                    $forall (E.Value _, E.Value dn, E.Value sn, E.Value mbCsh, E.Value nr) <- cactSuper -
                  • #{nr} Employees supervised by ^{nameWidget dn sn} +
                  • #{nr} Employees supervised by ^{nameWidget dn sn} $maybe csh <- mbCsh $if csh /= fshId from foreign company #{unCompanyKey csh} - $else - from this company + $else + from this company $nothing having no associated company -

                    #{length cusers} Employees +

                    #{length cusers} Employees
                      $forall u <- cusers
                    • ^{linkUserWidget ForProfileDataR u} @@ -102,17 +102,17 @@ data FirmAllAction = FirmAllActNotify nullaryPathPiece ''FirmAllAction $ camelToPathPiece' 3 embedRenderMessage ''UniWorX ''FirmAllAction id -data FirmAllActionData = FirmAllActNotifyData +data FirmAllActionData = FirmAllActNotifyData | FirmAllActResetSupervisionData deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) 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 +resultAllCompanyEntity = _dbrOutput . _1 resultAllCompany :: Lens' AllCompanyTableData Company -resultAllCompany = resultAllCompanyEntity . _entityVal +resultAllCompany = resultAllCompanyEntity . _entityVal resultAllCompanyUsers :: Lens' AllCompanyTableData Word64 resultAllCompanyUsers = _dbrOutput . _2 . _unValue @@ -133,7 +133,7 @@ resultAllCompanyActiveReroutes' :: Lens' AllCompanyTableData Word64 resultAllCompanyActiveReroutes' = _dbrOutput . _7 . _unValue fromUserCompany :: Maybe (E.SqlExpr (Entity UserCompany) -> E.SqlExpr (E.Value Bool)) -> E.SqlExpr (Entity Company) -> E.SqlQuery () -fromUserCompany mbFltr cmpy = do +fromUserCompany mbFltr cmpy = do usrCmpy <- E.from $ E.table @UserCompany let basecond = usrCmpy E.^. UserCompanyCompany E.==. cmpy E.^. CompanyId E.where_ $ maybe basecond ((basecond E.&&.).($ usrCmpy)) mbFltr @@ -142,9 +142,9 @@ firmCountUsers :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64 firmCountUsers = E.subSelectCount . fromUserCompany Nothing firmCountSupervisors :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) -firmCountSupervisors = E.subSelectCount . fromUserCompany (Just (E.^. UserCompanySupervisor)) +firmCountSupervisors = E.subSelectCount . fromUserCompany (Just (E.^. UserCompanySupervisor)) -- firmCountSupervisors :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) --- firmCountSupervisors cmpy = E.subSelectCount $ E.distinct $ do +-- firmCountSupervisors cmpy = E.subSelectCount $ E.distinct $ do -- usrCmpy <- E.from $ E.table @UserCompany -- E.where_ $ (usrCmpy E.^. UserCompanyCompany E.==. cmpy E.^. CompanyId) -- E.&&. (usrCmpy E.^. UserCompanySupervisor E.==. E.true) @@ -156,48 +156,48 @@ firmCountDefaultReroutes = E.subSelectCount . fromUserCompany (Just (\uc -> uc E -- firmCountForeignSupervisors :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) -- firmCountForeignSupervisors cmpy = E.coalesceDefault -- [E.subSelect $ do --- usrSuper <- E.from $ E.table @UserSupervisor +-- usrSuper <- E.from $ E.table @UserSupervisor -- E.groupBy (usrSuper E.^. UserSupervisorSupervisor) -- E.where_ $ E.exists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorUser) cmpy) --- E.&&. E.notExists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorSupervisor) cmpy) +-- E.&&. E.notExists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorSupervisor) cmpy) -- return E.countRows -- ] (E.val 0) firmCountForeignSupervisors :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) -firmCountForeignSupervisors cmpy = E.subSelectCountDistinct $ do - usrSuper <- E.from $ E.table @UserSupervisor +firmCountForeignSupervisors cmpy = E.subSelectCountDistinct $ do + usrSuper <- E.from $ E.table @UserSupervisor E.where_ $ E.exists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorUser) cmpy) E.&&. E.notExists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorSupervisor) cmpy) pure $ usrSuper E.^. UserSupervisorSupervisor firmCountActiveReroutes :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) firmCountActiveReroutes cmpy = E.subSelectCountDistinct $ do - usrSuper <- E.from $ E.table @UserSupervisor + usrSuper <- E.from $ E.table @UserSupervisor E.where_ $ E.exists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorUser) cmpy) E.&&. usrSuper E.^. UserSupervisorRerouteNotifications pure $ usrSuper E.^. UserSupervisorSupervisor firmCountActiveReroutes' :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) firmCountActiveReroutes' cmpy = E.subSelectCount $ do - usrSuper <- E.from $ E.table @UserSupervisor + usrSuper <- E.from $ E.table @UserSupervisor E.where_ $ E.exists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorUser) cmpy) E.&&. usrSuper E.^. UserSupervisorRerouteNotifications -mkFirmAllTable :: +mkFirmAllTable :: -- ( Functor h, ToSortable h - -- , AsCornice h p FirmAllActionData - -- (DBCell (MForm Handler) + -- , AsCornice h p FirmAllActionData + -- (DBCell (MForm Handler) -- (FormResult (First FirmAllActionData, DBFormResult CompanyId Bool FirmAllActionData)) -- ) cols - -- ) => + -- ) => Bool -> UserId -> DB (FormResult (FirmAllActionData, Set CompanyId), Widget) -mkFirmAllTable isAdmin uid = do +mkFirmAllTable isAdmin uid = do -- now <- liftIO getCurrentTime - let + let resultDBTable = DBTable{..} - where - dbtSQLQuery cmpy = do + where + dbtSQLQuery cmpy = do unless isAdmin $ E.where_ $ E.exists $ do -- only show associated companies usrCmpy <- E.from $ E.table @UserCompany E.where_ $ usrCmpy E.^. UserCompanyCompany E.==. cmpy E.^. CompanyId @@ -212,17 +212,50 @@ mkFirmAllTable isAdmin uid = do ) dbtRowKey = (E.^. CompanyId) dbtProj = dbtProjId - dbtColonnade = -- formColonnade $ + dbtColonnade = formColonnade $ mconcat [ -- if not isAdmin then mempty else -- guardOnM idAdmin $ - -- hole :: (x -> f x) -> r -> f r + {- hole :: (x -> f x) -> r -> f r + (FormResult + (DBFormResult (Key Company) Bool (DBRow (Entity Company, E.Value Word64, E.Value Word64, E.Value Word64, E.Value Word64, E.Value Word64, E.Value Word64)) + ) + -> f (FormResult + (DBFormResult + (Key Company) + Bool + (DBRow + (Entity Company, E.Value Word64, E.Value Word64, E.Value Word64, + E.Value Word64, E.Value Word64, E.Value Word64))))) + -> FormResult + (First FirmAllActionData, + DBFormResult CompanyId Bool FirmAllActionData) + -> f (FormResult + (First FirmAllActionData, + DBFormResult CompanyId Bool FirmAllActionData)) + + ------- + + ( (FormResult (DBFormResult (Key Company) Bool AllCompanyTableData)) + -> f (FormResult (DBFormResult (Key Company) Bool AllCompanyTableData)) + ) + -> (FormResult (First FirmAllActionData, DBFormResult CompanyId Bool FirmAllActionData)) + -> f (FormResult (First FirmAllActionData, DBFormResult CompanyId Bool FirmAllActionData)) + + ------ + Lens' (FormResult (DBFormResult (Key Company) Bool AllCompanyTableData)) + (FormResult (First FirmAllActionData, DBFormResult CompanyId Bool FirmAllActionData)) + ------ + Lens' (FormResult (Map (Key Company) (AllCompanyTableData,Bool -> Bool))) + (FormResult (First FirmAllActionData, (Map (CompanyId) (FirmAllActionData ,Bool -> Bool)))) + -- applying bringt uns unter das FormResult + -} dbSelect (applying _2) id (return . view (resultAllCompanyEntity . _entityKey)) - , sortable (Just "name") (i18nCell MsgTableCompany) $ \(view resultAllCompany -> firm) -> + , sortable (Just "name") (i18nCell MsgTableCompany) $ \(view resultAllCompany -> firm) -> anchorCell (FirmR $ companyShorthand firm) . toWgt $ companyName firm - , sortable (Just "short") (i18nCell MsgTableCompanyShort) $ \(view resultAllCompany -> firm) -> - let fsh = companyShorthand firm + , sortable (Just "short") (i18nCell MsgTableCompanyShort) $ \(view resultAllCompany -> firm) -> + let fsh = companyShorthand firm in anchorCell (FirmR fsh) $ toWgt fsh - , sortable (Just "avsnr") (i18nCell MsgTableCompanyNo) $ \(view resultAllCompany -> firm) -> + , sortable (Just "avsnr") (i18nCell MsgTableCompanyNo) $ \(view resultAllCompany -> firm) -> anchorCell (FirmR $ companyShorthand firm) $ toWgt $ companyAvsId firm , sortable (Just "users") (i18nCell MsgTableCompanyNrUsers) $ \(view resultAllCompanyUsers -> nr) -> wgtCell $ word2widget nr , sortable (Just "supervisors") (i18nCell MsgTableCompanyNrSupersDefault) $ \(view resultAllCompanySupervisors -> nr) -> wgtCell $ word2widget nr @@ -230,7 +263,7 @@ mkFirmAllTable isAdmin uid = do , sortable (Just "foreigners") (i18nCell MsgTableCompanyNrForeignSupers) $ \(view resultAllCompanyForeignSupers -> nr) -> wgtCell $ word2widget nr , sortable (Just "reroute-act") (i18nCell MsgTableCompanyNrRerouteActive) $ \(view resultAllCompanyActiveReroutes -> nr) -> wgtCell $ word2widget nr , sortable (Just "reroute-all") (i18nCell MsgTableCompanyNrRerouteActive) $ \(view resultAllCompanyActiveReroutes' -> nr) -> wgtCell $ word2widget nr - ] + ] dbtSorting = mconcat [ singletonMap "name" $ SortColumn (E.^. CompanyName) , singletonMap "short" $ SortColumn (E.^. CompanyShorthand) @@ -243,14 +276,14 @@ mkFirmAllTable isAdmin uid = do , singletonMap "reroute-all" $ SortColumn firmCountActiveReroutes' ] dbtFilter = mconcat - [ + [ ] dbtFilterUI = mconcat - [ + [ ] dbtStyle = def -- { dbsFilterLayout = defaultDBSFilterLayout } acts :: Map FirmAllAction (AForm Handler FirmAllActionData) - acts = mconcat + acts = mconcat [ singletonMap FirmAllActNotify $ pure FirmAllActNotifyData , singletonMap FirmAllActResetSupervision $ pure FirmAllActResetSupervisionData ] @@ -268,18 +301,18 @@ mkFirmAllTable isAdmin uid = do , dbParamsFormIdent = def } dbtIdent :: Text - dbtIdent = "firm" + dbtIdent = "firm" dbtCsvEncode = noCsvEncode dbtCsvDecode = Nothing dbtExtraReps = [] - postprocess :: FormResult (First FirmAllActionData, DBFormResult CompanyId Bool FirmAllActionData) + 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)) -- This type signature is not optional! resultDBTableValidator = def & defaultSorting [SortAscBy "short"] @@ -295,10 +328,10 @@ postFirmAllR = do 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 + siteLayoutMsg MsgMenuFirms $ do setTitleI MsgMenuFirms -- $(widgetFile "firm-all") - [whamlet|!!!STUB!!!TO DO!!! + [whamlet|!!!STUB!!!TO DO!!! ^{firmTable} |] @@ -308,9 +341,9 @@ postFirmAllR = do getFirmUsersR, postFirmUsersR :: CompanyShorthand -> Handler Html getFirmUsersR = postFirmUsersR -postFirmUsersR fsh = do +postFirmUsersR fsh = do let _fshId = CompanyKey fsh - siteLayout (citext2widget fsh) $ do + siteLayout (citext2widget fsh) $ do setTitle $ citext2Html fsh [whamlet|!!!STUB!!!TO DO!!!|] @@ -320,9 +353,9 @@ postFirmUsersR fsh = do getFirmSupersR, postFirmSupersR :: CompanyShorthand -> Handler Html getFirmSupersR = postFirmSupersR -postFirmSupersR fsh = do +postFirmSupersR fsh = do let _fshId = CompanyKey fsh - siteLayout (citext2widget fsh) $ do + siteLayout (citext2widget fsh) $ do setTitle $ citext2Html fsh [whamlet|!!!STUB!!!TO DO!!!|] @@ -335,7 +368,7 @@ postFirmSupersR fsh = do -- , qtcValidUntil :: Day -- , qtcLastRefresh :: Day -- , qtcBlockStatus :: Maybe Bool --- , qtcBlockFrom :: Maybe UTCTime +-- , qtcBlockFrom :: Maybe UTCTime -- , qtcScheduleRenewal:: Bool -- , qtcLmsStatusTxt :: Maybe Text -- , qtcLmsStatusDay :: Maybe UTCTime @@ -352,7 +385,7 @@ postFirmSupersR fsh = do -- , qtcValidUntil = compDay -- , qtcLastRefresh = compDay -- , qtcBlockStatus = Nothing --- , qtcBlockFrom = Nothing +-- , qtcBlockFrom = Nothing -- , qtcScheduleRenewal= True -- , qtcLmsStatusTxt = Just "Success" -- , qtcLmsStatusDay = Just compTime @@ -390,7 +423,7 @@ postFirmSupersR fsh = do -- , ('qtcBlockFrom , SomeMessage MsgInfoQualificationBlockFrom) -- , ('qtcScheduleRenewal, SomeMessage MsgQualificationScheduleRenewalTooltip) -- , ('qtcLmsStatusTxt , SomeMessage MsgTableLmsStatus) --- , ('qtcLmsStatusDay , SomeMessage MsgTableLmsStatusDay) +-- , ('qtcLmsStatusDay , SomeMessage MsgTableLmsStatusDay) -- ] @@ -445,15 +478,15 @@ postFirmSupersR fsh = do -- -- hasQualificationUserBlock = resultQualBlock --- data QualificationTableAction --- = QualificationActExpire +-- data QualificationTableAction +-- = QualificationActExpire -- | QualificationActUnexpire -- | QualificationActBlockSupervisor -- | QualificationActBlock -- | QualificationActUnblock -- | QualificationActRenew -- | QualificationActGrant --- deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) +-- deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) -- instance Universe QualificationTableAction -- instance Finite QualificationTableAction @@ -468,15 +501,15 @@ postFirmSupersR fsh = do -- isAdminAct _ = True -- -} --- data QualificationTableActionData --- = QualificationActExpireData --- | QualificationActUnexpireData +-- data QualificationTableActionData +-- = QualificationActExpireData +-- | QualificationActUnexpireData -- | QualificationActBlockSupervisorData -- | QualificationActBlockData { qualTableActBlockReason :: Text, qualTableActNotify :: Bool, qualTableActRemoveSupervisors :: Bool } -- | QualificationActUnblockData { qualTableActBlockReason :: Text, qualTableActNotify :: Bool} -- | QualificationActRenewData --- | QualificationActGrantData { qualTableActGrantUntil :: Day } --- deriving (Eq, Ord, Show, Generic) +-- | QualificationActGrantData { qualTableActGrantUntil :: Day } +-- deriving (Eq, Ord, Show, Generic) -- isExpiryAct :: QualificationTableActionData -> Bool -- isExpiryAct QualificationActExpireData = True @@ -514,14 +547,14 @@ postFirmSupersR fsh = do -- ) -- qualificationTableQuery now qid fltr (qualUser `E.InnerJoin` user `E.LeftOuterJoin` lmsUser `E.LeftOuterJoin` qualBlock) = do -- -- E.distinctOnOrderBy will not work: sorting with dbTable should work, except that columns contained in distinctOnOrderBy cannot be sorted inversely by user; but PostgreSQL leftJoin with distinct filters too many results, see SQL Example lead/lag under jost/misc DevOps --- -- +-- -- -- E.on $ qualBlock E.?. QualificationUserBlockQualificationUser E.?=. qualUser E.^. QualificationUserId -- E.&&. qualBlock `isLatestBlockBefore` E.val now -- E.on $ user E.^. UserId E.=?. lmsUser E.?. LmsUserUser -- E.&&. E.val qid E.=?. lmsUser E.?. LmsUserQualification -- NOTE: condition was once erroneously placed in where-clause, which does not work -- E.on $ user E.^. UserId E.==. qualUser E.^. QualificationUserUser --- E.where_ $ fltr qualUser --- E.&&. (E.val qid E.==. qualUser E.^. QualificationUserQualification) +-- E.where_ $ fltr qualUser +-- E.&&. (E.val qid E.==. qualUser E.^. QualificationUserQualification) -- return (qualUser, user, lmsUser, qualBlock) @@ -531,15 +564,15 @@ postFirmSupersR fsh = do -- ) -- => Bool -- -> Entity Qualification --- -> Map QualificationTableAction (AForm Handler QualificationTableActionData) +-- -> Map QualificationTableAction (AForm Handler QualificationTableActionData) -- -> (Map CompanyId Company -> cols) -- -> PSValidator (MForm Handler) (FormResult (First QualificationTableActionData, DBFormResult UserId Bool QualificationTableData)) -- -> DB (FormResult (QualificationTableActionData, Set UserId), Widget) -- mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do -- svs <- getSupervisees --- now <- liftIO getCurrentTime --- -- lookup all companies --- cmpMap <- memcachedBy (Just . Right $ 5 * diffMinute) ("CompanyDictionary"::Text) $ do +-- now <- liftIO getCurrentTime +-- -- lookup all companies +-- cmpMap <- memcachedBy (Just . Right $ 5 * diffMinute) ("CompanyDictionary"::Text) $ do -- cmps <- selectList [] [] -- [Asc CompanyShorthand] -- return $ Map.fromList $ fmap (\Entity{..} -> (entityKey, entityVal)) cmps -- let @@ -584,14 +617,14 @@ postFirmSupersR fsh = do -- dbtFilter = mconcat -- [ single $ fltrUserNameEmail queryUser -- , single ("avs-number" , FilterColumn . E.mkExistsFilter $ \row criterion -> --- E.from $ \usrAvs -> -- do +-- E.from $ \usrAvs -> -- do -- E.where_ $ usrAvs E.^. UserAvsUser E.==. queryUser row E.^. UserId -- E.&&. ((E.val criterion :: E.SqlExpr (E.Value (CI Text))) E.==. -- (E.explicitUnsafeCoerceSqlExprValue "citext" (usrAvs E.^. UserAvsNoPerson) :: E.SqlExpr (E.Value (CI Text))) )) -- , single ("avs-card" , FilterColumn $ \(queryUser -> user) (criterion :: Set.Set Text) -> case readAvsFullCardNo =<< Set.lookupMin criterion of -- Nothing -> E.false -- Just cardNo -> E.exists $ E.from $ \(avsCard `E.InnerJoin` usrAvs) -> do --- E.on $ usrAvs E.^. UserAvsPersonId E.==. avsCard E.^. UserAvsCardPersonId +-- E.on $ usrAvs E.^. UserAvsPersonId E.==. avsCard E.^. UserAvsCardPersonId -- E.where_ $ usrAvs E.^. UserAvsUser E.==. user E.^. UserId -- E.&&. (avsCard E.^. UserAvsCardCardNo E.==. E.val cardNo) -- ) @@ -600,14 +633,14 @@ postFirmSupersR fsh = do -- | otherwise -> E.any (\c -> user E.^. UserCompanyPersonalNumber `E.hasInfix` E.val c) criteria -- ) -- , single ("user-company", FilterColumn . E.mkExistsFilter $ \row criterion -> --- E.from $ \(usrComp `E.InnerJoin` comp) -> do +-- E.from $ \(usrComp `E.InnerJoin` comp) -> do -- let testname = (E.val criterion :: E.SqlExpr (E.Value (CI Text))) `E.isInfixOf` -- (E.explicitUnsafeCoerceSqlExprValue "citext" (comp E.^. CompanyName) :: E.SqlExpr (E.Value (CI Text))) -- testnumber nr = E.val nr E.==. comp E.^. CompanyAvsId -- testcrit = maybe testname testnumber $ readMay $ CI.original criterion -- E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId -- E.where_ $ usrComp E.^. UserCompanyUser E.==. queryUser row E.^. UserId E.&&. testcrit --- ) +-- ) -- , single ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) (validQualification now)) -- , single ("renewal-due" , FilterColumn $ \(queryQualUser -> quser) criterion -> -- if | Just renewal <- mbRenewal @@ -626,7 +659,7 @@ postFirmSupersR fsh = do -- , prismAForm (singletonFilter "user-company") mPrev $ aopt textField (fslI MsgTableCompany) -- , prismAForm (singletonFilter "personal-number" ) mPrev $ aopt textField (fslI MsgCompanyPersonalNumber) -- , prismAForm (singletonFilter "avs-card" ) mPrev $ aopt textField (fslI MsgAvsCardNo) --- , prismAForm (singletonFilter "avs-number" ) mPrev $ aopt textField (fslI MsgAvsPersonNo) +-- , prismAForm (singletonFilter "avs-number" ) mPrev $ aopt textField (fslI MsgAvsPersonNo) -- , prismAForm (singletonFilter "validity" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsValid) -- , if isNothing mbRenewal then mempty -- else prismAForm (singletonFilter "renewal-due" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsRenewal) @@ -651,31 +684,31 @@ postFirmSupersR fsh = do -- <*> (view resultCompanyUser >>= getCompanies) -- <*> (view resultCompanyUser >>= getCompanyNos) -- <*> view (resultQualUser . _entityVal . _qualificationUserValidUntil) --- <*> view (resultQualUser . _entityVal . _qualificationUserLastRefresh) +-- <*> view (resultQualUser . _entityVal . _qualificationUserLastRefresh) -- <*> preview (resultQualBlock. _entityVal . _qualificationUserBlockUnblock . _not) --- <*> preview (resultQualBlock. _entityVal . _qualificationUserBlockFrom) +-- <*> preview (resultQualBlock. _entityVal . _qualificationUserBlockFrom) -- <*> view (resultQualUser . _entityVal . _qualificationUserScheduleRenewal) -- <*> getStatusPlusTxt -- <*> getStatusPlusDay --- getCompanies cmps = case mapMaybe (flip Map.lookup cmpMap . view (_entityVal . _userCompanyCompany)) cmps of +-- getCompanies cmps = case mapMaybe (flip Map.lookup cmpMap . view (_entityVal . _userCompanyCompany)) cmps of -- [] -> pure Nothing -- somecmps -> pure $ Just $ intercalate ", " $ fmap (view (_companyName . _CI)) somecmps -- getCompanyNos = pure . CsvSemicolonList . mapMaybe (preview (_Just . _companyAvsId) . flip Map.lookup cmpMap . view (_entityVal . _userCompanyCompany)) --- getStatusPlusTxt = --- (join . preview (resultLmsUser . _entityVal . _lmsUserStatus)) >>= \case +-- getStatusPlusTxt = +-- (join . preview (resultLmsUser . _entityVal . _lmsUserStatus)) >>= \case -- Just LmsBlocked{} -> return $ Just "Failed" -- Just LmsExpired{} -> return $ Just "Expired" -- Just LmsSuccess{} -> return $ Just "Success" -- Nothing -> maybeM (return Nothing) (const $ return $ Just "Open") $ -- preview (resultLmsUser . _entityVal . _lmsUserStarted) --- getStatusPlusDay = --- (join . preview (resultLmsUser . _entityVal . _lmsUserStatusDay)) >>= \case +-- getStatusPlusDay = +-- (join . preview (resultLmsUser . _entityVal . _lmsUserStatusDay)) >>= \case -- lsd@(Just _) -> return lsd -- Nothing -> preview (resultLmsUser . _entityVal . _lmsUserStarted) - + -- dbtCsvDecode = Nothing --- dbtExtraReps = [] +-- dbtExtraReps = [] -- dbtParams = DBParamsForm -- { dbParamsFormMethod = POST -- , dbParamsFormAction = Nothing @@ -704,7 +737,7 @@ postFirmSupersR fsh = do -- getQualificationR, postQualificationR :: SchoolId -> QualificationShorthand -> Handler Html -- getQualificationR = postQualificationR --- postQualificationR sid qsh = do +-- postQualificationR sid qsh = do -- isAdmin <- hasReadAccessTo AdminR -- msgGrantWarning <- messageIconI Warning IconWarning MsgQualificationActGrantWarning -- msgUnexpire <- messageIconI Info IconWarning MsgQualificationActUnexpireWarning @@ -719,13 +752,13 @@ postFirmSupersR fsh = do -- }} <- getBy404 $ SchoolQualificationShort sid qsh -- -- Block copied to Handler/Qualifications TODO: refactor --- let getBlockReasons unblk = E.select $ do --- (quser :& qblock) <- E.from $ E.table @QualificationUser +-- let getBlockReasons unblk = E.select $ do +-- (quser :& qblock) <- E.from $ E.table @QualificationUser -- `E.innerJoin` E.table @QualificationUserBlock -- `E.on` (\(quser :& qblock) -> quser E.^. QualificationUserId E.==. qblock E.^. QualificationUserBlockQualificationUser) -- E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid -- E.&&. unblk (qblock E.^. QualificationUserBlockUnblock) --- E.groupBy (qblock E.^. QualificationUserBlockReason) +-- E.groupBy (qblock E.^. QualificationUserBlockReason) -- let countRows' :: E.SqlExpr (E.Value Int64) = E.countRows -- E.orderBy [E.desc countRows'] -- E.limit 7 @@ -739,34 +772,34 @@ postFirmSupersR fsh = do -- acts :: Map QualificationTableAction (AForm Handler QualificationTableActionData) -- acts = mconcat $ -- [ singletonMap QualificationActExpire $ pure QualificationActExpireData --- , singletonMap QualificationActUnexpire $ QualificationActUnexpireData --- <$ aformMessage msgUnexpire --- ] ++ bool +-- , singletonMap QualificationActUnexpire $ QualificationActUnexpireData +-- <$ aformMessage msgUnexpire +-- ] ++ bool -- -- nonAdmin actions, ie. Supervisor --- [ singletonMap QualificationActBlockSupervisor $ pure QualificationActBlockSupervisorData ] +-- [ singletonMap QualificationActBlockSupervisor $ pure QualificationActBlockSupervisorData ] -- -- Admin-only actions -- [ singletonMap QualificationActUnblock $ QualificationActUnblockData -- <$> apreq (textField & cfStrip & addDatalist suggestionsUnblock) (fslI MsgQualificationGrantReason) Nothing -- <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgQualificationBlockNotify) (Just False) --- , singletonMap QualificationActBlock $ QualificationActBlockData +-- , singletonMap QualificationActBlock $ QualificationActBlockData -- <$> apreq (textField & cfStrip & addDatalist suggestionsBlock) (fslI MsgQualificationBlockReason) Nothing -- <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgQualificationBlockNotify) (Just False) -- <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgQualificationBlockRemoveSupervisor) (Just False) -- , singletonMap QualificationActRenew $ pure QualificationActRenewData --- , singletonMap QualificationActGrant $ QualificationActGrantData +-- , singletonMap QualificationActGrant $ QualificationActGrantData -- <$> apopt dayField (fslI MsgLmsQualificationValidUntil) dayExpiry -- <* aformMessage msgGrantWarning -- ] isAdmin -- linkLmsUser = toMaybe isAdmin (LmsUserR sid qsh) --- linkUserName = bool ForProfileR ForProfileDataR isAdmin +-- linkUserName = bool ForProfileR ForProfileDataR isAdmin -- colChoices cmpMap = mconcat -- [ dbSelect (applying _2) id (return . view (hasEntity . _entityKey)) -- , colUserNameModalHdr MsgLmsUser linkUserName --- , colUserEmail +-- , colUserEmail -- , sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \( view resultCompanyUser -> cmps) -> -- let icnSuper = text2markup " " <> icon IconSupervisor --- cs = [ (cmpName, cmpSpr) --- | Entity _ UserCompany{userCompanyCompany=cmpId, userCompanySupervisor=cmpSpr} <- cmps +-- cs = [ (cmpName, cmpSpr) +-- | Entity _ UserCompany{userCompanyCompany=cmpId, userCompanySupervisor=cmpSpr} <- cmps -- , let cmpName = maybe (unCompanyKey cmpId) companyName $ Map.lookup cmpId cmpMap -- ] -- companies = intercalate (text2markup ", ") $ @@ -775,9 +808,9 @@ postFirmSupersR fsh = do -- , guardMonoid isAdmin colUserMatriclenr -- -- , sortable (Just "validity") (i18nCell MsgQualificationValidIndicator) (qualificationValidIconCell nowaday . view resultQualUser) -- , sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ \( view $ resultQualUser . _entityVal . _qualificationUserFirstHeld -> d) -> dayCell d --- , sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \( view $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> dayCell d +-- , sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \( view $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> dayCell d -- , sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) (dayCell . view ( resultQualUser . _entityVal . _qualificationUserValidUntil)) --- , sortable (Just "blocked") (i18nCell MsgQualificationValidIndicator & cellTooltip MsgTableQualificationBlockedTooltipSimple) $ \row -> +-- , sortable (Just "blocked") (i18nCell MsgQualificationValidIndicator & cellTooltip MsgTableQualificationBlockedTooltipSimple) $ \row -> -- qualificationValidReasonCell' (Just $ LmsUserR sid qsh) isAdmin nowaday (row ^? resultQualBlock) row -- , sortable (Just "schedule-renew")(i18nCell MsgTableQualificationNoRenewal & cellTooltip MsgTableQualificationNoRenewalTooltip -- ) $ \( view $ resultQualUser . _entityVal . _qualificationUserScheduleRenewal -> b) -> ifIconCell (not b) IconNoNotification @@ -788,13 +821,13 @@ postFirmSupersR fsh = do -- psValidator = def & defaultSorting [SortDescBy "last-refresh"] -- tbl <- mkQualificationTable isAdmin qent acts colChoices psValidator -- return (tbl, qent) - + -- formResult lmsRes $ \case -- (QualificationActRenewData, selectedUsers) | isAdmin -> do --- noks <- runDB $ renewValidQualificationUsers qid Nothing $ Set.toList selectedUsers +-- noks <- runDB $ renewValidQualificationUsers qid Nothing $ Set.toList selectedUsers -- addMessageI (if noks > 0 && noks == Set.size selectedUsers then Success else Warning) $ MsgTutorialUserRenewedQualification noks -- reloadKeepGetParams $ QualificationR sid qsh --- (QualificationActGrantData grantValidday, selectedUsers) | isAdmin -> do +-- (QualificationActGrantData grantValidday, selectedUsers) | isAdmin -> do -- runDB . forM_ selectedUsers $ upsertQualificationUser qid nowaday grantValidday Nothing -- addMessageI (if 0 < Set.size selectedUsers then Success else Warning) . MsgTutorialUserGrantedQualification $ Set.size selectedUsers -- reloadKeepGetParams $ QualificationR sid qsh @@ -807,18 +840,18 @@ postFirmSupersR fsh = do -- msgVal = upd & if isUnexpire then MsgQualificationSetUnexpire else MsgQualificationSetExpire -- addMessageI msgKind msgVal -- reloadKeepGetParams $ QualificationR sid qsh --- (action, selectedUsers) | isBlockAct action && (isAdmin || action == QualificationActBlockSupervisorData) -> do +-- (action, selectedUsers) | isBlockAct action && (isAdmin || action == QualificationActBlockSupervisorData) -> do -- let selUserIds = Set.toList selectedUsers --- (unblock, reason) = case action of --- QualificationActBlockSupervisorData -> (False, Right QualificationBlockReturnedByCompany) +-- (unblock, reason) = case action of +-- QualificationActBlockSupervisorData -> (False, Right QualificationBlockReturnedByCompany) -- QualificationActBlockData{..} -> (False, Left qualTableActBlockReason) -- QualificationActUnblockData{..} -> (True , Left qualTableActBlockReason) -- _ -> error "Handle.Qualification.isBlockAct returned non-block action" -- cannot occur due to earlier checks --- notify = case action of +-- notify = case action of -- QualificationActBlockData{qualTableActNotify} -> qualTableActNotify -- _ -> False - --- oks <- runDB $ do + +-- oks <- runDB $ do -- when (blockActRemoveSupervisors action) $ deleteWhere [UserSupervisorUser <-. selUserIds] -- qualificationUserBlocking qid selUserIds unblock Nothing reason notify -- let nrq = length selectedUsers diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index a2a5fc381..2e44c6323 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -1,10 +1,20 @@ --- SPDX-FileCopyrightText: 2022 Felix Hamann ,Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost ,Steffen Jost ,Winnie Ros +-- SPDX-FileCopyrightText: 2022-23 Felix Hamann ,Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost ,Steffen Jost ,Winnie Ros ,Steffen Jost -- -- 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 From a28786412e8f7b8b2b9e83cc7e528898bfd85f38 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 24 Oct 2023 16:13:31 +0000 Subject: [PATCH 14/50] chore(firm): add firm-all filters and code cleaning --- .../utils/table_column/de-de-formal.msg | 1 + messages/uniworx/utils/table_column/en-eu.msg | 1 + routes | 2 +- src/Database/Esqueleto/Utils.hs | 5 ++ src/Handler/Firm.hs | 85 +++++++------------ src/Handler/Qualification.hs | 3 +- src/Handler/Utils/Table/Columns.hs | 19 +++++ 7 files changed, 57 insertions(+), 59 deletions(-) diff --git a/messages/uniworx/utils/table_column/de-de-formal.msg b/messages/uniworx/utils/table_column/de-de-formal.msg index aee81f2bb..b96544ca9 100644 --- a/messages/uniworx/utils/table_column/de-de-formal.msg +++ b/messages/uniworx/utils/table_column/de-de-formal.msg @@ -75,6 +75,7 @@ TableExamOfficeLabelStatus: Label-Farbe TableExamOfficeLabelPriority: Label-Priorität TableQualifications: Qualifikationen TableCompany: Firma +TableCompanyFilter: Firma oder Nummer TableCompanyShort: Firmenkürzel TableCompanies: Firmen TableCompanyNo: Firmennummer diff --git a/messages/uniworx/utils/table_column/en-eu.msg b/messages/uniworx/utils/table_column/en-eu.msg index 70583dfc7..a4e62b00b 100644 --- a/messages/uniworx/utils/table_column/en-eu.msg +++ b/messages/uniworx/utils/table_column/en-eu.msg @@ -75,6 +75,7 @@ TableExamOfficeLabelStatus: Label colour TableExamOfficeLabelPriority: Label priority TableQualifications: Qualifications TableCompany: Company +TableCompanyFilter: Company/Nr TableCompanyShort: Company shorthand TableCompanies: Companies TableCompanyNo: Company number diff --git a/routes b/routes index e6e4618b7..b77b24c70 100644 --- a/routes +++ b/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 diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index f9a1dde82..1b4326ed5 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -46,6 +46,7 @@ module Database.Esqueleto.Utils , subSelectCountDistinct , selectCountRows, selectCountDistinct , selectMaybe + , num2text , day, day', dayMaybe, interval, diffDays, diffTimes , exprLift , explicitUnsafeCoerceSqlExprValue @@ -656,10 +657,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" diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 5aafa0ed9..7ce1cc857 100644 --- a/src/Handler/Firm.hs +++ b/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.Csv as Csv -- import qualified Data.Text as T --- import qualified Data.CaseInsensitive as CI +import qualified Data.CaseInsensitive as CI -- import qualified Data.Conduit.List as C -- import Database.Persist.Sql (updateWhereCount) import Database.Esqueleto.Experimental ((:&)(..)) @@ -35,8 +35,8 @@ import Database.Esqueleto.Utils.TH -- avoids repetition of local definitions --- single :: (k,a) -> Map k a --- single = uncurry Map.singleton +single :: (k,a) -> Map k a +single = uncurry Map.singleton getFirmR, postFirmR :: CompanyShorthand -> Handler Html @@ -106,6 +106,10 @@ 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) @@ -184,14 +188,7 @@ firmCountActiveReroutes' cmpy = E.subSelectCount $ do E.&&. usrSuper E.^. UserSupervisorRerouteNotifications -mkFirmAllTable :: - -- ( Functor h, ToSortable h - -- , AsCornice h p FirmAllActionData - -- (DBCell (MForm Handler) - -- (FormResult (First FirmAllActionData, DBFormResult CompanyId Bool FirmAllActionData)) - -- ) cols - -- ) => - Bool -> UserId -> DB (FormResult (FirmAllActionData, Set CompanyId), Widget) +mkFirmAllTable :: Bool -> UserId -> DB (FormResult (FirmAllActionData, Set CompanyId), Widget) mkFirmAllTable isAdmin uid = do -- now <- liftIO getCurrentTime let @@ -214,48 +211,14 @@ mkFirmAllTable isAdmin uid = do dbtProj = dbtProjId dbtColonnade = formColonnade $ mconcat - [ -- if not isAdmin then mempty else -- guardOnM idAdmin $ - {- hole :: (x -> f x) -> r -> f r - (FormResult - (DBFormResult (Key Company) Bool (DBRow (Entity Company, E.Value Word64, E.Value Word64, E.Value Word64, E.Value Word64, E.Value Word64, E.Value Word64)) - ) - -> f (FormResult - (DBFormResult - (Key Company) - Bool - (DBRow - (Entity Company, E.Value Word64, E.Value Word64, E.Value Word64, - E.Value Word64, E.Value Word64, E.Value Word64))))) - -> FormResult - (First FirmAllActionData, - DBFormResult CompanyId Bool FirmAllActionData) - -> f (FormResult - (First FirmAllActionData, - DBFormResult CompanyId Bool FirmAllActionData)) - - ------- - - ( (FormResult (DBFormResult (Key Company) Bool AllCompanyTableData)) - -> f (FormResult (DBFormResult (Key Company) Bool AllCompanyTableData)) - ) - -> (FormResult (First FirmAllActionData, DBFormResult CompanyId Bool FirmAllActionData)) - -> f (FormResult (First FirmAllActionData, DBFormResult CompanyId Bool FirmAllActionData)) - - ------ - Lens' (FormResult (DBFormResult (Key Company) Bool AllCompanyTableData)) - (FormResult (First FirmAllActionData, DBFormResult CompanyId Bool FirmAllActionData)) - ------ - Lens' (FormResult (Map (Key Company) (AllCompanyTableData,Bool -> Bool))) - (FormResult (First FirmAllActionData, (Map (CompanyId) (FirmAllActionData ,Bool -> Bool)))) - -- applying bringt uns unter das FormResult - -} + [ if not isAdmin then mempty else -- guardOnM idAdmin $ dbSelect (applying _2) id (return . view (resultAllCompanyEntity . _entityKey)) - , sortable (Just "name") (i18nCell MsgTableCompany) $ \(view resultAllCompany -> firm) -> + , 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 MsgTableCompanyNrSupersDefault) $ \(view resultAllCompanySupervisors -> nr) -> wgtCell $ word2widget nr @@ -276,10 +239,21 @@ 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 } acts :: Map FirmAllAction (AForm Handler FirmAllActionData) @@ -293,8 +267,7 @@ mkFirmAllTable isAdmin uid = do , dbParamsFormAttrs = [] , dbParamsFormSubmit = FormSubmit , dbParamsFormAdditional - = renderAForm FormStandard - $ (, mempty) . First . Just + = renderAForm FormStandard $ (, mempty) . First . Just <$> multiActionA acts (fslI MsgTableAction) Nothing , dbParamsFormEvaluate = liftHandler . runFormPost , dbParamsFormResult = id @@ -313,7 +286,7 @@ mkFirmAllTable isAdmin uid = do 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)) -- This type signature is not optional! + -- resultDBTableValidator :: PSValidator (MForm Handler) (FormResult (First FirmAllActionData, DBFormResult CompanyId Bool FirmAllActionData)) resultDBTableValidator = def & defaultSorting [SortAscBy "short"] over _1 postprocess <$> dbTable resultDBTableValidator resultDBTable diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs index 3068d6132..d29a0815d 100644 --- a/src/Handler/Qualification.hs +++ b/src/Handler/Qualification.hs @@ -504,8 +504,7 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do , dbParamsFormAttrs = [] , dbParamsFormSubmit = FormSubmit , dbParamsFormAdditional - = renderAForm FormStandard - $ (, mempty) . First . Just + = renderAForm FormStandard $ (, mempty) . First . Just <$> multiActionA acts (fslI MsgTableAction) Nothing , dbParamsFormEvaluate = liftHandler . runFormPost , dbParamsFormResult = id diff --git a/src/Handler/Utils/Table/Columns.hs b/src/Handler/Utils/Table/Columns.hs index 280becf18..e42451442 100644 --- a/src/Handler/Utils/Table/Columns.hs +++ b/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 -- From a29d8f3698bbddaae7413163859689a9bd8c6b3b Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 26 Oct 2023 10:30:27 +0000 Subject: [PATCH 15/50] chore(firm): add more useful supervisor counts --- .../utils/table_column/de-de-formal.msg | 3 + messages/uniworx/utils/table_column/en-eu.msg | 3 + src/Handler/Firm.hs | 110 +++++++++++++----- src/Utils/Icon.hs | 4 +- 4 files changed, 87 insertions(+), 33 deletions(-) diff --git a/messages/uniworx/utils/table_column/de-de-formal.msg b/messages/uniworx/utils/table_column/de-de-formal.msg index 62be3b1c8..f2beb2c56 100644 --- a/messages/uniworx/utils/table_column/de-de-formal.msg +++ b/messages/uniworx/utils/table_column/de-de-formal.msg @@ -82,6 +82,9 @@ TableCompanyNo: Firmennummer TableCompanyNos: Firmennummern TableCompanyNrUsers: Firmenangehörige TableCompanyNrSupers: Ansprechpartner +TableCompanyNrEmpSupervised: Firmenangehörige mit Ansprechpartner +TableCompanyNrEmpRerouted: Firmenangehörige mit Umleitung +TableCompanyNrEmpRerPost: Firmenangehörige mit postalischer Umleitung TableCompanyNrSupersActive: Mitarbeiter mit Ansprechpartner TableCompanyNrSupersDefault: Standard Ansprechpartner TableCompanyNrForeignSupers: Firmenfremde Ansprechpartner diff --git a/messages/uniworx/utils/table_column/en-eu.msg b/messages/uniworx/utils/table_column/en-eu.msg index a5063da7c..1fc9066c0 100644 --- a/messages/uniworx/utils/table_column/en-eu.msg +++ b/messages/uniworx/utils/table_column/en-eu.msg @@ -82,6 +82,9 @@ TableCompanyNo: Company number TableCompanyNos: Company numbers TableCompanyNrUsers: Associates TableCompanyNrSupers: Supervisors +TableCompanyNrEmpSupervised: Supervsied employees +TableCompanyNrEmpRerouted: Employees having reroute +TableCompanyNrEmpRerPost: Employees having postal reroute TableCompanyNrSupersActive: Associates having supervisors TableCompanyNrSupersDefault: Default supervisors TableCompanyNrForeignSupers: External Supervisors diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 7ce1cc857..f92144c2d 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -60,7 +60,7 @@ postFirmR fsh = do E.groupBy (usr E.^. UserId, usr E.^. UserDisplayName, usr E.^. UserSurname, 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 - 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', usr E.^. UserPrefersPostal) siteLayoutMsg (SomeMessage fsh) $ do setTitle $ citext2Html fsh @@ -72,8 +72,9 @@ postFirmR fsh = do

                      #{length cactSuper} Active Supervisors for Employees
                        - $forall (E.Value _, E.Value dn, E.Value sn, E.Value mbCsh, E.Value nr) <- cactSuper -
                      • #{nr} Employees supervised by ^{nameWidget dn sn} + $forall (E.Value _, E.Value dn, E.Value sn, E.Value mbCsh, E.Value nr, E.Value prefPost) <- cactSuper +
                      • #{nr} Employees supervised by ^{nameWidget dn sn} # + #{icon (bool IconAt IconLetter prefPost)} # $maybe csh <- mbCsh $if csh /= fshId from foreign company #{unCompanyKey csh} @@ -111,7 +112,7 @@ 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, E.Value Word64, E.Value Word64, E.Value Word64) resultAllCompanyEntity :: Lens' AllCompanyTableData (Entity Company) resultAllCompanyEntity = _dbrOutput . _1 @@ -124,17 +125,26 @@ resultAllCompanyUsers = _dbrOutput . _2 . _unValue resultAllCompanySupervisors :: Lens' AllCompanyTableData Word64 resultAllCompanySupervisors = _dbrOutput . _3 . _unValue +resultAllCompanyEmployeeSupervised :: Lens' AllCompanyTableData Word64 +resultAllCompanyEmployeeSupervised = _dbrOutput . _4 . _unValue + +resultAllCompanyEmployeeRerouted :: Lens' AllCompanyTableData Word64 +resultAllCompanyEmployeeRerouted = _dbrOutput . _5 . _unValue + +resultAllCompanyEmpRerPost :: Lens' AllCompanyTableData Word64 +resultAllCompanyEmpRerPost = _dbrOutput . _6 . _unValue + resultAllCompanyForeignSupers :: Lens' AllCompanyTableData Word64 -resultAllCompanyForeignSupers = _dbrOutput . _4 . _unValue +resultAllCompanyForeignSupers = _dbrOutput . _7 . _unValue resultAllCompanyDefaultReroutes :: Lens' AllCompanyTableData Word64 -resultAllCompanyDefaultReroutes = _dbrOutput . _5 . _unValue +resultAllCompanyDefaultReroutes = _dbrOutput . _8 . _unValue resultAllCompanyActiveReroutes :: Lens' AllCompanyTableData Word64 -resultAllCompanyActiveReroutes = _dbrOutput . _6 . _unValue +resultAllCompanyActiveReroutes = _dbrOutput . _9 . _unValue resultAllCompanyActiveReroutes' :: Lens' AllCompanyTableData Word64 -resultAllCompanyActiveReroutes' = _dbrOutput . _7 . _unValue +resultAllCompanyActiveReroutes' = _dbrOutput . _10 . _unValue fromUserCompany :: Maybe (E.SqlExpr (Entity UserCompany) -> E.SqlExpr (E.Value Bool)) -> E.SqlExpr (Entity Company) -> E.SqlQuery () fromUserCompany mbFltr cmpy = do @@ -157,6 +167,35 @@ firmCountSupervisors = E.subSelectCount . fromUserCompany (Just (E.^. UserCompa firmCountDefaultReroutes :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) firmCountDefaultReroutes = E.subSelectCount . fromUserCompany (Just (\uc -> uc E.^. UserCompanySupervisor E.&&. uc E.^. UserCompanySupervisorReroute)) +firmCountEmployeeSupervised :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) +firmCountEmployeeSupervised = E.subSelectCount . fromUserCompany $ Just fltr + where + fltr usrc = E.exists $ do + usrSuper <- E.from $ E.table @UserSupervisor + E.where_ $ usrSuper E.^. UserSupervisorUser E.==. usrc E.^. UserCompanyUser + +firmCountEmployeeRerouted :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) +firmCountEmployeeRerouted = E.subSelectCount . fromUserCompany $ Just fltr + where + fltr usrc = E.exists $ do + usrSuper <- E.from $ E.table @UserSupervisor + E.where_ $ usrSuper E.^. UserSupervisorUser E.==. usrc E.^. UserCompanyUser + E.&&. usrSuper E.^. UserSupervisorRerouteNotifications + +firmCountEmployeeRerPost :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) +firmCountEmployeeRerPost = E.subSelectCount . fromUserCompany $ Just fltr + where + fltr usrc = E.exists $ do + (usrSuper :& usr) <- + E.from $ E.table @UserSupervisor + `E.innerJoin` E.table @User + `E.on` (\(usrSuper :& usr) -> usrSuper E.^. UserSupervisorSupervisor E.==. usr E.^. UserId) + E.where_ $ usrSuper E.^. UserSupervisorUser E.==. usrc E.^. UserCompanyUser + E.&&. usrSuper E.^. UserSupervisorRerouteNotifications + E.&&. usr E.^. UserPrefersPostal + E.&&. E.isJust (usr E.^. UserPostAddress) + + -- firmCountForeignSupervisors :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) -- firmCountForeignSupervisors cmpy = E.coalesceDefault -- [E.subSelect $ do @@ -199,13 +238,16 @@ mkFirmAllTable isAdmin uid = do usrCmpy <- E.from $ E.table @UserCompany E.where_ $ usrCmpy E.^. UserCompanyCompany E.==. cmpy E.^. CompanyId E.&&. usrCmpy E.^. UserCompanyUser E.==. E.val uid - return ( cmpy - , cmpy & firmCountUsers - , cmpy & firmCountSupervisors - , cmpy & firmCountForeignSupervisors - , cmpy & firmCountDefaultReroutes - , cmpy & firmCountActiveReroutes - , cmpy & firmCountActiveReroutes' + return ( cmpy -- 1 + , cmpy & firmCountUsers -- 2 + , cmpy & firmCountSupervisors -- 3 + , cmpy & firmCountEmployeeSupervised -- 4 + , cmpy & firmCountEmployeeRerouted -- 5 + , cmpy & firmCountEmployeeRerPost -- 6 + , cmpy & firmCountForeignSupervisors -- 7 + , cmpy & firmCountDefaultReroutes -- 8 + , cmpy & firmCountActiveReroutes -- 9 + , cmpy & firmCountActiveReroutes' -- 10 ) dbtRowKey = (E.^. CompanyId) dbtProj = dbtProjId @@ -220,23 +262,29 @@ mkFirmAllTable isAdmin uid = do in anchorCell (FirmR fsh) $ toWgt fsh , 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 MsgTableCompanyNrSupersDefault) $ \(view resultAllCompanySupervisors -> nr) -> wgtCell $ word2widget nr - , sortable (Just "reroute-def") (i18nCell MsgTableCompanyNrRerouteDefault) $ \(view resultAllCompanyDefaultReroutes -> nr) -> wgtCell $ word2widget nr - , sortable (Just "foreigners") (i18nCell MsgTableCompanyNrForeignSupers) $ \(view resultAllCompanyForeignSupers -> nr) -> wgtCell $ word2widget nr - , sortable (Just "reroute-act") (i18nCell MsgTableCompanyNrRerouteActive) $ \(view resultAllCompanyActiveReroutes -> nr) -> wgtCell $ word2widget nr - , sortable (Just "reroute-all") (i18nCell MsgTableCompanyNrRerouteActive) $ \(view resultAllCompanyActiveReroutes' -> nr) -> wgtCell $ word2widget nr + , sortable (Just "users") (i18nCell MsgTableCompanyNrUsers) $ \(view resultAllCompanyUsers -> nr) -> wgtCell $ word2widget nr + , sortable (Just "supervisors") (i18nCell MsgTableCompanyNrSupersDefault) $ \(view resultAllCompanySupervisors -> nr) -> wgtCell $ word2widget nr + , sortable (Just "emp-supervised")(i18nCell MsgTableCompanyNrEmpSupervised) $ \(view resultAllCompanyEmployeeSupervised -> nr) -> wgtCell $ word2widget nr + , sortable (Just "emp-rerouted") (i18nCell MsgTableCompanyNrEmpRerouted) $ \(view resultAllCompanyEmployeeRerouted -> nr) -> wgtCell $ word2widget nr + , sortable (Just "emp-rer-post") (i18nCell MsgTableCompanyNrEmpRerPost) $ \(view resultAllCompanyEmpRerPost -> nr) -> wgtCell $ word2widget nr + , sortable (Just "reroute-def") (i18nCell MsgTableCompanyNrRerouteDefault) $ \(view resultAllCompanyDefaultReroutes -> nr) -> wgtCell $ word2widget nr + , sortable (Just "foreigners") (i18nCell MsgTableCompanyNrForeignSupers) $ \(view resultAllCompanyForeignSupers -> nr) -> wgtCell $ word2widget nr + , sortable (Just "reroute-act") (i18nCell MsgTableCompanyNrRerouteActive) $ \(view resultAllCompanyActiveReroutes -> nr) -> wgtCell $ word2widget nr + , sortable (Just "reroute-all") (i18nCell MsgTableCompanyNrRerouteActive) $ \(view resultAllCompanyActiveReroutes' -> nr) -> wgtCell $ word2widget nr ] dbtSorting = mconcat - [ singletonMap "name" $ SortColumn (E.^. CompanyName) - , singletonMap "short" $ SortColumn (E.^. CompanyShorthand) - , singletonMap "avsnr" $ SortColumn (E.^. CompanyAvsId) - , singletonMap "users" $ SortColumn firmCountUsers - , singletonMap "supervisors" $ SortColumn firmCountSupervisors - , singletonMap "reroute-def" $ SortColumn firmCountDefaultReroutes - , singletonMap "foreigners" $ SortColumn firmCountForeignSupervisors - , singletonMap "reroute-act" $ SortColumn firmCountActiveReroutes - , singletonMap "reroute-all" $ SortColumn firmCountActiveReroutes' + [ singletonMap "name" $ SortColumn (E.^. CompanyName) + , singletonMap "short" $ SortColumn (E.^. CompanyShorthand) + , singletonMap "avsnr" $ SortColumn (E.^. CompanyAvsId) + , singletonMap "users" $ SortColumn firmCountUsers + , singletonMap "supervisors" $ SortColumn firmCountSupervisors + , singletonMap "emp-supervised" $ SortColumn firmCountEmployeeSupervised + , singletonMap "emp-rerouted" $ SortColumn firmCountEmployeeRerouted + , singletonMap "emp-rer-post" $ SortColumn firmCountEmployeeRerPost + , singletonMap "reroute-def" $ SortColumn firmCountDefaultReroutes + , singletonMap "foreigners" $ SortColumn firmCountForeignSupervisors + , singletonMap "reroute-act" $ SortColumn firmCountActiveReroutes + , singletonMap "reroute-all" $ SortColumn firmCountActiveReroutes' ] dbtFilter = mconcat [ single $ fltrCompanyNameNr queryCompany @@ -255,7 +303,7 @@ mkFirmAllTable isAdmin uid = do [ fltrCompanyNameNrUI mPrev , prismAForm (singletonFilter "is-supervisor") mPrev $ aopt textField (fslI MsgTableSupervisor) ] - dbtStyle = def -- { dbsFilterLayout = defaultDBSFilterLayout } + dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } acts :: Map FirmAllAction (AForm Handler FirmAllActionData) acts = mconcat [ singletonMap FirmAllActNotify $ pure FirmAllActNotifyData diff --git a/src/Utils/Icon.hs b/src/Utils/Icon.hs index a3602faec..645e89e73 100644 --- a/src/Utils/Icon.hs +++ b/src/Utils/Icon.hs @@ -153,7 +153,7 @@ iconText = \case IconSFTHint -> "life-ring" -- for SheetFileType only IconSFTSolution -> "exclamation-circle" -- for SheetFileType only IconSFTMarking -> "check-circle" -- for SheetFileType only - IconEmail -> "envelope" -- envelope is no longer unamibuous + IconEmail -> "envelope" -- envelope is no longer unamibuous, use IconAt or IconLetter if email and postal need to be distinguished IconRegisterTemplate -> "file-alt" IconNoCorrectors -> "user-slash" IconRemoveUser -> "user-slash" @@ -199,7 +199,7 @@ iconText = \case IconCertificate -> "badge-check" IconPrintCenter -> "mail-bulk" -- From fontawesome v6 onwards: "envelope-bulk" IconLetter -> "mail-bulk" -- Problem "envelope" already used for email as well - IconAt -> "at" + IconAt -> "at" -- alternative for IconEmail to distinguish from IconLetter IconSupervisor -> "head-side" -- must be notably different to user -- IconWaitingForUser -> "user-cog" -- Waiting on a user to do something IconExpired -> "hourglass-end" From 954a23936a35ea6c32247d7e191312e63888c12d Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 26 Oct 2023 12:44:01 +0200 Subject: [PATCH 16/50] fix(build): minor --- src/Handler/Firm.hs | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index f92144c2d..f49fd755f 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -168,14 +168,15 @@ firmCountDefaultReroutes :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Wor firmCountDefaultReroutes = E.subSelectCount . fromUserCompany (Just (\uc -> uc E.^. UserCompanySupervisor E.&&. uc E.^. UserCompanySupervisorReroute)) firmCountEmployeeSupervised :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) -firmCountEmployeeSupervised = E.subSelectCount . fromUserCompany $ Just fltr - where +firmCountEmployeeSupervised = E.subSelectCount . fromUserCompany (Just fltr) + where + fltr :: E.SqlExpr (Entity UserCompany) -> E.SqlExpr (E.Value Bool) fltr usrc = E.exists $ do usrSuper <- E.from $ E.table @UserSupervisor E.where_ $ usrSuper E.^. UserSupervisorUser E.==. usrc E.^. UserCompanyUser firmCountEmployeeRerouted :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) -firmCountEmployeeRerouted = E.subSelectCount . fromUserCompany $ Just fltr +firmCountEmployeeRerouted = E.subSelectCount . fromUserCompany (Just fltr) where fltr usrc = E.exists $ do usrSuper <- E.from $ E.table @UserSupervisor @@ -183,7 +184,7 @@ firmCountEmployeeRerouted = E.subSelectCount . fromUserCompany $ Just fltr E.&&. usrSuper E.^. UserSupervisorRerouteNotifications firmCountEmployeeRerPost :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) -firmCountEmployeeRerPost = E.subSelectCount . fromUserCompany $ Just fltr +firmCountEmployeeRerPost = E.subSelectCount . fromUserCompany (Just fltr) where fltr usrc = E.exists $ do (usrSuper :& usr) <- From aae19268406e715425348e89a732d21380ec706f Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 26 Oct 2023 17:55:20 +0200 Subject: [PATCH 17/50] chore(firm): add explanation to firm page and clean navigation --- .../utils/navigation/menu/de-de-formal.msg | 2 + .../uniworx/utils/navigation/menu/en-eu.msg | 2 + src/Foundation/Navigation.hs | 20 +++++++-- src/Handler/Firm.hs | 21 ++++----- templates/i18n/firm-all/de-de-formal.hamlet | 42 ++++++++++++++++++ templates/i18n/firm-all/en-eu.hamlet | 43 +++++++++++++++++++ 6 files changed, 116 insertions(+), 14 deletions(-) create mode 100644 templates/i18n/firm-all/de-de-formal.hamlet create mode 100644 templates/i18n/firm-all/en-eu.hamlet diff --git a/messages/uniworx/utils/navigation/menu/de-de-formal.msg b/messages/uniworx/utils/navigation/menu/de-de-formal.msg index 9e1c55f5a..373cfc0e6 100644 --- a/messages/uniworx/utils/navigation/menu/de-de-formal.msg +++ b/messages/uniworx/utils/navigation/menu/de-de-formal.msg @@ -134,6 +134,8 @@ MenuLmsLearners: Export Benutzer E‑Learning MenuLmsReport: Ergebnisse E‑Learning MenuFirms: Firmen +MenuFirmUsers: Angehörige +MenuFirmSupervisors: Ansprechpartner MenuSap: SAP Schnittstelle diff --git a/messages/uniworx/utils/navigation/menu/en-eu.msg b/messages/uniworx/utils/navigation/menu/en-eu.msg index 6145f0d81..c46f047da 100644 --- a/messages/uniworx/utils/navigation/menu/en-eu.msg +++ b/messages/uniworx/utils/navigation/menu/en-eu.msg @@ -135,6 +135,8 @@ MenuLmsLearners: E‑learning Users MenuLmsReport: E‑learning Results MenuFirms: Companies +MenuFirmUsers: Associates +MenuFirmSupervisors: Supervisors MenuSap: SAP Interface diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index 4c405b25f..e53e6b3ae 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -123,10 +123,10 @@ breadcrumb ProblemFbutNoR = i18nCrumb MsgProblemsRWithoutFHeading $ Just breadcrumb ProblemAvsSynchR = i18nCrumb MsgProblemsAvsSynchHeading $ Just AdminProblemsR breadcrumb ProblemAvsErrorR = i18nCrumb MsgProblemsAvsErrorHeading $ Just ProblemAvsSynchR -breadcrumb FirmAllR = i18nCrumb MsgMenuFirms Nothing -breadcrumb FirmR{} = i18nCrumb MsgMenuFirms $ Just FirmAllR -breadcrumb FirmUsersR{} = i18nCrumb MsgMenuFirms $ Just FirmAllR -breadcrumb FirmSupersR{} = i18nCrumb MsgMenuFirms $ Just FirmAllR +breadcrumb FirmAllR = i18nCrumb MsgMenuFirms Nothing +breadcrumb FirmR{} = i18nCrumb MsgMenuAdminHeading $ Just FirmAllR -- TODO: change heading or remove +breadcrumb FirmUsersR{} = i18nCrumb MsgMenuFirmUsers $ Just FirmAllR +breadcrumb (FirmSupersR fsh)= i18nCrumb MsgMenuFirmSupervisors $ Just $ FirmUsersR fsh breadcrumb PrintCenterR = i18nCrumb MsgMenuApc Nothing breadcrumb PrintSendR = i18nCrumb MsgMenuPrintSend $ Just PrintCenterR @@ -2425,6 +2425,18 @@ pageActions (FirmR fsh) = return , navChildren = [] } ] +pageActions (FirmUsersR fsh) = return + [ NavPageActionPrimary + { navLink = defNavLink MsgTableCompanyNrSupers $ FirmSupersR fsh + , navChildren = [] + } + ] +pageActions (FirmSupersR fsh) = return + [ NavPageActionPrimary + { navLink = defNavLink MsgTableCompanyNrUsers $ FirmUsersR fsh + , navChildren = [] + } + ] pageActions PrintCenterR = do openDays <- useRunDB $ Ex.select $ do pj <- Ex.from $ Ex.table @PrintJob diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index f49fd755f..62e4a3079 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -65,6 +65,9 @@ postFirmR fsh = do siteLayoutMsg (SomeMessage fsh) $ do setTitle $ citext2Html fsh [whamlet| +

                        PROVISORISCHE DEBUG SEITE +

                        Diese Seite wird in der finalen Version nicht mehr enthalten sein. +

                        #{length csuper} Company Default Supervisors (non-foreign only)
                          $forall u <- csuper @@ -177,7 +180,7 @@ firmCountEmployeeSupervised = E.subSelectCount . fromUserCompany (Just fltr) firmCountEmployeeRerouted :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) firmCountEmployeeRerouted = E.subSelectCount . fromUserCompany (Just fltr) - where + where fltr usrc = E.exists $ do usrSuper <- E.from $ E.table @UserSupervisor E.where_ $ usrSuper E.^. UserSupervisorUser E.==. usrc E.^. UserCompanyUser @@ -257,18 +260,19 @@ mkFirmAllTable isAdmin uid = do [ 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 (FirmUsersR $ companyShorthand firm) . toWgt $ companyName firm , sortable (Just "short") (i18nCell MsgTableCompanyShort) $ \(view resultAllCompany -> firm) -> let fsh = companyShorthand firm - in anchorCell (FirmR fsh) $ toWgt fsh + in anchorCell (FirmUsersR fsh) $ toWgt fsh , 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 MsgTableCompanyNrSupersDefault) $ \(view resultAllCompanySupervisors -> nr) -> wgtCell $ word2widget nr + , sortable (Just "supervisors") (i18nCell MsgTableCompanyNrSupersDefault) $ \row -> + anchorCell (FirmSupersR $ row ^. resultAllCompany . _companyShorthand) $ word2widget $ row ^. resultAllCompanySupervisors + , sortable (Just "reroute-def") (i18nCell MsgTableCompanyNrRerouteDefault) $ \(view resultAllCompanyDefaultReroutes -> nr) -> wgtCell $ word2widget nr , sortable (Just "emp-supervised")(i18nCell MsgTableCompanyNrEmpSupervised) $ \(view resultAllCompanyEmployeeSupervised -> nr) -> wgtCell $ word2widget nr , sortable (Just "emp-rerouted") (i18nCell MsgTableCompanyNrEmpRerouted) $ \(view resultAllCompanyEmployeeRerouted -> nr) -> wgtCell $ word2widget nr - , sortable (Just "emp-rer-post") (i18nCell MsgTableCompanyNrEmpRerPost) $ \(view resultAllCompanyEmpRerPost -> nr) -> wgtCell $ word2widget nr - , sortable (Just "reroute-def") (i18nCell MsgTableCompanyNrRerouteDefault) $ \(view resultAllCompanyDefaultReroutes -> nr) -> wgtCell $ word2widget nr + , sortable (Just "emp-rer-post") (i18nCell MsgTableCompanyNrEmpRerPost) $ \(view resultAllCompanyEmpRerPost -> nr) -> wgtCell $ word2widget nr , sortable (Just "foreigners") (i18nCell MsgTableCompanyNrForeignSupers) $ \(view resultAllCompanyForeignSupers -> nr) -> wgtCell $ word2widget nr , sortable (Just "reroute-act") (i18nCell MsgTableCompanyNrRerouteActive) $ \(view resultAllCompanyActiveReroutes -> nr) -> wgtCell $ word2widget nr , sortable (Just "reroute-all") (i18nCell MsgTableCompanyNrRerouteActive) $ \(view resultAllCompanyActiveReroutes' -> nr) -> wgtCell $ word2widget nr @@ -352,10 +356,7 @@ postFirmAllR = do (FirmAllActResetSupervisionData, fids) -> addMessage Info $ text2Html $ "Reset " <> tshow (length fids) <> " companies. TODO" siteLayoutMsg MsgMenuFirms $ do setTitleI MsgMenuFirms - -- $(widgetFile "firm-all") - [whamlet|!!!STUB!!!TO DO!!! - ^{firmTable} - |] + $(i18nWidgetFile "firm-all") ----------------------- diff --git a/templates/i18n/firm-all/de-de-formal.hamlet b/templates/i18n/firm-all/de-de-formal.hamlet new file mode 100644 index 000000000..e4e59fc3e --- /dev/null +++ b/templates/i18n/firm-all/de-de-formal.hamlet @@ -0,0 +1,42 @@ +$newline never + +$# SPDX-FileCopyrightText: 2023 Steffen Jost +$# +$# SPDX-License-Identifier: AGPL-3.0-or-later + +
                          + + +

                          + Die Daten der Firmen wurden aus dem Ausweisverwaltungssystem (AVS) der Fraport AG + importiert und werden regelmäßig aktualisiert, + wenn Fahrlizenzinhaber oder deren Verwalter über das AVS einer Firma zugeordnet wurden. +

                          + ^{firmTable} + +

                          Hinweis zur Entwicklungsversion +

                          + Die Spalten zeigen derzeit folgende Informationen +

                            +
                          1. Firmenname +
                          2. Firmenkürzel +
                          3. AVS Firmennummer +
                          4. Anzahl der derzeit zugeordneten Firmenangehörigen. Eine Personen kann mehreren Firmen gleichzeitig angehören. +
                          5. Anzahl der Standard Ansprechpartner, welche einer neu in FRADrive eingetragnen Person dieser Firma derzeit zugeordnet werden. Eine Person kann beliebig viele Ansprechpartner haben. Wirkt sich nicht auf vorhandene Firmenangehörige aus. +
                          6. Anzahl der Standard Ansprechpartner der Firma mit Benachrichtigungsumleitung. Hat eine Person mehrere Ansprechpartner mit Umleitung, so wird ein Brief oder Email an alle Ansprechpartner verschickt. # + Ein Person kann auch ihr eigener Ansprechpartner sein, um eine Benachrichtigung sowohl an die Person selbst als auch an einen Ansprechpartner zu senden. # + Wirkt sich nicht auf vorhandene Firmenangehörige aus, sondern nur auf neu in FRADrive hinzukommende Firmenangehörige. +
                          7. Anzahl Firmenangehörige, für die derzeit mindestens ein Ansprechpartner eingetragen ist. Ansprechpartner müssen nicht notwendigerweise der gleichen Firma angehören! +
                          8. Anzahl Firmenangehörige, für die derzeit mindestens eine Benachrichtigungsumleitung an einen Ansprechpartner eingetragen ist. Ansprechpartner müssen nicht notwendigerweise der gleichen Firma angehören! +
                          9. Anzahl Firmenangehörige, für die derzeit mindestens eine Benachrichtigungsumleitung an einen Ansprechpartner eingetragen ist, welcher den Versand per Briefpost bevorzugt. # + Ob ein Ansprechpartner Email oder Briefpost wünscht ist eine individuelle Einstellung des Ansprechpartners und gilt für alle Benachrichtigungen an diesen Ansprechpartner. +
                          10. Anzahl der firmenfremden Ansprechpartner, welche mindestens einen Firmenangehörigen betreuen. Bei manchen Firmen ist es normal, dass die Ansprechpartner einer anderen Firma angehören, aber oft ist nur ein Fehler durch Firmenwechsel. +
                          11. Anzahl der Ansprechpartner mit derzeit aktiver Benachrichtigungsumleitung, egal ob Brief oder Email. +
                          12. Gesamtzahl der Brief und Emails, welche bei Benachrichtigung aller Firmenangehörigen derzeit verschickt würden. +

                            + Dies ist also die Gesamtzahl aller derzeit aktiven Benachrichtigungsumleitungen. +

                            + + Beispiel: Für eine Firma mit 2 Angehörigen, für die ein Mitarbeiter 1 Ansprechpartner mit aktiver Umleitung und einen Mitarbeiter mit 3 Ansprechpartnern mit aktiver Umleitung hätte, # + würde hier die Zahl 4 stehen, da bei einer Benachrichtigung an beide Mitarbeiter insgesamt 4 Briefe oder Emails versendet würden. + diff --git a/templates/i18n/firm-all/en-eu.hamlet b/templates/i18n/firm-all/en-eu.hamlet new file mode 100644 index 000000000..d1a659458 --- /dev/null +++ b/templates/i18n/firm-all/en-eu.hamlet @@ -0,0 +1,43 @@ +$newline never + +$# SPDX-FileCopyrightText: 2023 Steffen Jost +$# +$# SPDX-License-Identifier: AGPL-3.0-or-later + +

                            + + +

                            + Data of all companies that were taken from the id card management system (AVS) of Fraport AG. + A company is importet and regularly update if a driving licence holder or their supervisor + are associated with that company through the AVS. + +

                            + ^{firmTable} + +

                            Development Version Notes (TODO: translated paragraph) +

                            + Die Spalten zeigen derzeit folgende Informationen +

                              +
                            1. Firmenname +
                            2. Firmenkürzel +
                            3. AVS Firmennummer +
                            4. Anzahl der derzeit zugeordneten Firmenangehörigen. Eine Personen kann mehreren Firmen gleichzeitig angehören. +
                            5. Anzahl der Standard Ansprechpartner, welche einer neu in FRADrive eingetragnen Person dieser Firma derzeit zugeordnet werden. Eine Person kann beliebig viele Ansprechpartner haben. Wirkt sich nicht auf vorhandene Firmenangehörige aus. +
                            6. Anzahl der Standard Ansprechpartner der Firma mit Benachrichtigungsumleitung. Hat eine Person mehrere Ansprechpartner mit Umleitung, so wird ein Brief oder Email an alle Ansprechpartner verschickt. # + Ein Person kann auch ihr eigener Ansprechpartner sein, um eine Benachrichtigung sowohl an die Person selbst als auch an einen Ansprechpartner zu senden. # + Wirkt sich nicht auf vorhandene Firmenangehörige aus, sondern nur auf neu in FRADrive hinzukommende Firmenangehörige. +
                            7. Anzahl Firmenangehörige, für die derzeit mindestens ein Ansprechpartner eingetragen ist. Ansprechpartner müssen nicht notwendigerweise der gleichen Firma angehören! +
                            8. Anzahl Firmenangehörige, für die derzeit mindestens eine Benachrichtigungsumleitung an einen Ansprechpartner eingetragen ist. Ansprechpartner müssen nicht notwendigerweise der gleichen Firma angehören! +
                            9. Anzahl Firmenangehörige, für die derzeit mindestens eine Benachrichtigungsumleitung an einen Ansprechpartner eingetragen ist, welcher den Versand per Briefpost bevorzugt. # + Ob ein Ansprechpartner Email oder Briefpost wünscht ist eine individuelle Einstellung des Ansprechpartners und gilt für alle Benachrichtigungen an diesen Ansprechpartner. +
                            10. Anzahl der firmenfremden Ansprechpartner, welche mindestens einen Firmenangehörigen betreuen. Bei manchen Firmen ist es normal, dass die Ansprechpartner einer anderen Firma angehören, aber oft ist nur ein Fehler durch Firmenwechsel. +
                            11. Anzahl der Ansprechpartner mit derzeit aktiver Benachrichtigungsumleitung, egal ob Brief oder Email. +
                            12. Gesamtzahl der Brief und Emails, welche bei Benachrichtigung aller Firmenangehörigen derzeit verschickt würden. +

                              + Dies ist also die Gesamtzahl aller derzeit aktiven Benachrichtigungsumleitungen. +

                              + + Beispiel: Für eine Firma mit 2 Angehörigen, für die ein Mitarbeiter 1 Ansprechpartner mit aktiver Umleitung und einen Mitarbeiter mit 3 Ansprechpartnern mit aktiver Umleitung hätte, # + würde hier die Zahl 4 stehen, da bei einer Benachrichtigung an beide Mitarbeiter insgesamt 4 Briefe oder Emails versendet würden. + From 0f3bf98235a305f8e0400f04073e200b337c5fce Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 26 Oct 2023 19:13:01 +0200 Subject: [PATCH 18/50] chore(firm): firm users page shows company address --- .../uniworx/categories/firm/de-de-formal.msg | 3 +- messages/uniworx/categories/firm/en-eu.msg | 2 + src/Handler/Firm.hs | 75 +++++++++++++------ test/Database/Fill.hs | 6 +- 4 files changed, 60 insertions(+), 26 deletions(-) diff --git a/messages/uniworx/categories/firm/de-de-formal.msg b/messages/uniworx/categories/firm/de-de-formal.msg index 07bc13737..3758bc790 100644 --- a/messages/uniworx/categories/firm/de-de-formal.msg +++ b/messages/uniworx/categories/firm/de-de-formal.msg @@ -4,4 +4,5 @@ FirmAllActNotify: Mitteilung versenden FirmAllActResetSupervision: Ansprechpartner für alle Firmenangehörigen zurücksetzen - +FirmUserActNotify: Mitteilung versenden +FirmUserActMkSuper: Zum Firmenansprechparnter ernennen diff --git a/messages/uniworx/categories/firm/en-eu.msg b/messages/uniworx/categories/firm/en-eu.msg index dcfeea99c..34ede15a2 100644 --- a/messages/uniworx/categories/firm/en-eu.msg +++ b/messages/uniworx/categories/firm/en-eu.msg @@ -4,3 +4,5 @@ FirmAllActNotify: Send message FirmAllActResetSupervision: Reset supervisors for all company associates +FirmUserActNotify: Send message +FirmUserActMkSuper: Mark as company supervisor \ No newline at end of file diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 62e4a3079..48b7ac59e 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -119,35 +119,35 @@ type AllCompanyTableData = DBRow (Entity Company, E.Value Word64, E.Value Word64 resultAllCompanyEntity :: Lens' AllCompanyTableData (Entity Company) resultAllCompanyEntity = _dbrOutput . _1 -resultAllCompany :: Lens' AllCompanyTableData Company -resultAllCompany = resultAllCompanyEntity . _entityVal +resultAllCompany :: Lens' AllCompanyTableData Company +resultAllCompany = resultAllCompanyEntity . _entityVal -resultAllCompanyUsers :: Lens' AllCompanyTableData Word64 -resultAllCompanyUsers = _dbrOutput . _2 . _unValue +resultAllCompanyUsers :: Lens' AllCompanyTableData Word64 +resultAllCompanyUsers = _dbrOutput . _2 . _unValue -resultAllCompanySupervisors :: Lens' AllCompanyTableData Word64 -resultAllCompanySupervisors = _dbrOutput . _3 . _unValue +resultAllCompanySupervisors :: Lens' AllCompanyTableData Word64 +resultAllCompanySupervisors = _dbrOutput . _3 . _unValue resultAllCompanyEmployeeSupervised :: Lens' AllCompanyTableData Word64 resultAllCompanyEmployeeSupervised = _dbrOutput . _4 . _unValue -resultAllCompanyEmployeeRerouted :: Lens' AllCompanyTableData Word64 -resultAllCompanyEmployeeRerouted = _dbrOutput . _5 . _unValue +resultAllCompanyEmployeeRerouted :: Lens' AllCompanyTableData Word64 +resultAllCompanyEmployeeRerouted = _dbrOutput . _5 . _unValue -resultAllCompanyEmpRerPost :: Lens' AllCompanyTableData Word64 -resultAllCompanyEmpRerPost = _dbrOutput . _6 . _unValue +resultAllCompanyEmpRerPost :: Lens' AllCompanyTableData Word64 +resultAllCompanyEmpRerPost = _dbrOutput . _6 . _unValue -resultAllCompanyForeignSupers :: Lens' AllCompanyTableData Word64 -resultAllCompanyForeignSupers = _dbrOutput . _7 . _unValue +resultAllCompanyForeignSupers :: Lens' AllCompanyTableData Word64 +resultAllCompanyForeignSupers = _dbrOutput . _7 . _unValue -resultAllCompanyDefaultReroutes :: Lens' AllCompanyTableData Word64 -resultAllCompanyDefaultReroutes = _dbrOutput . _8 . _unValue +resultAllCompanyDefaultReroutes :: Lens' AllCompanyTableData Word64 +resultAllCompanyDefaultReroutes = _dbrOutput . _8 . _unValue -resultAllCompanyActiveReroutes :: Lens' AllCompanyTableData Word64 -resultAllCompanyActiveReroutes = _dbrOutput . _9 . _unValue +resultAllCompanyActiveReroutes :: Lens' AllCompanyTableData Word64 +resultAllCompanyActiveReroutes = _dbrOutput . _9 . _unValue -resultAllCompanyActiveReroutes' :: Lens' AllCompanyTableData Word64 -resultAllCompanyActiveReroutes' = _dbrOutput . _10 . _unValue +resultAllCompanyActiveReroutes' :: Lens' AllCompanyTableData Word64 +resultAllCompanyActiveReroutes' = _dbrOutput . _10 . _unValue fromUserCompany :: Maybe (E.SqlExpr (Entity UserCompany) -> E.SqlExpr (E.Value Bool)) -> E.SqlExpr (Entity Company) -> E.SqlQuery () fromUserCompany mbFltr cmpy = do @@ -362,13 +362,44 @@ postFirmAllR = do ----------------------- -- Firm Users Table +data FirmUserAction = FirmUserActNotify + | FirmUserActMkSuper + deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) + deriving anyclass (Universe, Finite) + +nullaryPathPiece ''FirmUserAction $ camelToPathPiece' 3 +embedRenderMessage ''UniWorX ''FirmUserAction id + +data FirmUserActionData = FirmUserActNotifyData + | FirmUserActMkSuperData + deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) + + + getFirmUsersR, postFirmUsersR :: CompanyShorthand -> Handler Html getFirmUsersR = postFirmUsersR postFirmUsersR fsh = do - let _fshId = CompanyKey fsh - siteLayout (citext2widget fsh) $ do - setTitle $ citext2Html fsh - [whamlet|!!!STUB!!!TO DO!!!|] + let fshId = CompanyKey fsh + Company{..} <- runDB $ get404 fshId + siteLayout (citext2widget companyName) $ do + setTitle $ citext2Html companyShorthand + [whamlet| +

                              + #{companyPostAddress} +

                              + Für neue Firmangehörige ist Benachrichtigungs-Voreinstellung: + $if companyPrefersPostal + #{icon IconLetter} Briefversand + $else + #{icon IconAt} Email +

                              + AVS Nummer #{companyAvsId} + +

                              + !!!STUB!!!TO DO!!! +

                              + Table showing all company associated users + |] ----------------------------- diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index 7161397c7..2343751ff 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -624,9 +624,9 @@ fillDb = do I am aware that violations in the form plagiarism or collaboration with third parties will lead to expulsion from the course. |] } - fraportAg <- insert' $ Company "Fraport AG" "Fraport" 1 False Nothing - fraGround <- insert' $ Company "Fraport Ground Handling Professionals GmbH" "FraGround" 2 False Nothing -- TODO: better testcases - nice <- insert' $ Company "N*ICE Aircraft Services & Support GmbH" "N*ICE" 33 False Nothing + fraportAg <- insert' $ Company "Fraport AG" "Fraport" 1 True $ Just $ markdownToStoredMarkup ("Frankfurt Airport Services Worldwide\n60547 Frankfurt am Main"::Text) + fraGround <- insert' $ Company "Fraport Ground Handling Professionals GmbH" "FraGround" 2 True $ Just $ markdownToStoredMarkup ("Sauerbierstraße 772 \nBürokomplex 80/C/1\n112233 Nieder-Tupfing-Hohen-Kreisingen\nTöpferbezirk"::Text) + nice <- insert' $ Company "N*ICE Aircraft Services & Support GmbH" "N*ICE" 33 False $ Just $ markdownToStoredMarkup ("69 Nevermore Blvd.\nHarlaemn\nNew York\nUSA"::Text) ffacil <- insert' $ Company "Fraport Facility Services GmbH" "GCS" 44 False Nothing bpol <- insert' $ Company "Bundespolizeidirektion Flughafen Frankfurt am Main" "BPol" 5555 False Nothing void . insert' $ UserCompany jost fraportAg True True From 0ab1cd17be5a0ab4c0945cd15577c6843827507a Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 27 Oct 2023 13:23:05 +0200 Subject: [PATCH 19/50] chore(firm): add contact preference column and make firm nr filter exact --- .../utils/table_column/de-de-formal.msg | 4 ++- messages/uniworx/utils/table_column/en-eu.msg | 4 ++- src/Database/Esqueleto/Utils.hs | 13 +++++++- src/Handler/Firm.hs | 4 ++- src/Handler/Utils/Table/Columns.hs | 31 ++++++++++++++----- templates/i18n/firm-all/de-de-formal.hamlet | 3 +- templates/i18n/firm-all/en-eu.hamlet | 1 + 7 files changed, 47 insertions(+), 13 deletions(-) diff --git a/messages/uniworx/utils/table_column/de-de-formal.msg b/messages/uniworx/utils/table_column/de-de-formal.msg index f2beb2c56..c08c769cd 100644 --- a/messages/uniworx/utils/table_column/de-de-formal.msg +++ b/messages/uniworx/utils/table_column/de-de-formal.msg @@ -90,6 +90,7 @@ TableCompanyNrSupersDefault: Standard Ansprechpartner TableCompanyNrForeignSupers: Firmenfremde Ansprechpartner TableCompanyNrRerouteDefault: Standard Umleitungen TableCompanyNrRerouteActive: Aktive Umleitungen +TableCompanyPostalPreference: Benachrichtigungspräferenz neue Firmenangehörige TableSupervisor: Ansprechpartner TableCreationTime: Erstellungszeit TableJob !ident-ok: Job @@ -100,4 +101,5 @@ TableJobCreationInstance: Ersteller ActJobDelete: Job entfernen TableJobActDeleteFeedback n@Int m@Int: #{n}/#{m} Jobs entfernt TableFilterComma: Es können mehrere alternative Suchkriterien mit Komma getrennt angegeben werden, wovon mindestens eines erfüllt werden muss. -TableFilterCommaPlus: Mehrere alternative Suchkriterien mit Komma trennen. Mindestens ein Suchkriterium muss erfüllt werden, zusätzlich zu allen Suchkriterien mit vorangestelltem Plus-Symbol. \ No newline at end of file +TableFilterCommaPlus: Mehrere alternative Suchkriterien mit Komma trennen. Mindestens ein Suchkriterium muss erfüllt werden, zusätzlich zu allen Suchkriterien mit vorangestelltem Plus-Symbol. +TableFilterCommaNameNr: Mehrere Namen oder Nummern mit Komma trennen. Nummern werden nur exakt gesucht. \ No newline at end of file diff --git a/messages/uniworx/utils/table_column/en-eu.msg b/messages/uniworx/utils/table_column/en-eu.msg index 1fc9066c0..dd7742a45 100644 --- a/messages/uniworx/utils/table_column/en-eu.msg +++ b/messages/uniworx/utils/table_column/en-eu.msg @@ -90,6 +90,7 @@ TableCompanyNrSupersDefault: Default supervisors TableCompanyNrForeignSupers: External Supervisors TableCompanyNrRerouteDefault: Default reroutes TableCompanyNrRerouteActive: Active reroutes +TableCompanyPostalPreference: Default notification preference TableSupervisor: Supervisor TableCreationTime: Creation TableJob !ident-ok: Job @@ -100,4 +101,5 @@ TableJobCreationInstance: Creator ActJobDelete: Delete job TableJobActDeleteFeedback n@Int m@Int: #{n}/#{m} queued jobs deleted TableFilterComma: Separate multiple alternative filter criteria by comma, at least one of which must be fulfilled. -TableFilterCommaPlus: Separate multiple alternative filter criteria by comma, at least one of which must be fulfilled in addition to all criteria preceded by a plus symbol. \ No newline at end of file +TableFilterCommaPlus: Separate multiple alternative filter criteria by comma, at least one of which must be fulfilled in addition to all criteria preceded by a plus symbol. +TableFilterCommaNameNr: Separate names and numbers by comma. Numbers have to match exact. \ No newline at end of file diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index 2aced9b9f..060a4df98 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -18,7 +18,7 @@ module Database.Esqueleto.Utils , or, and , any, all , subSelectAnd, subSelectOr - , mkExactFilter, mkExactFilterWith + , mkExactFilter, mkExactFilterWith, mkExactFilterWithComma , mkExactFilterLast, mkExactFilterLastWith , mkExactFilterMaybeLast, mkExactFilterMaybeLast' , mkContainsFilter, mkContainsFilterWith @@ -285,6 +285,17 @@ mkExactFilterWith cast lenslike row criterias | Set.null criterias = true | otherwise = lenslike row `E.in_` E.valList (cast <$> Set.toList criterias) +-- | like `mkExactFilterWith` but splits comma separared Texts into multiple criteria +mkExactFilterWithComma :: (PersistField b) + => (Text -> b) -- ^ type conversion + -> (t -> E.SqlExpr (E.Value b)) -- ^ getter from query to searched element + -> t -- ^ query row + -> Set.Set Text -- ^ needle collection + -> E.SqlExpr (E.Value Bool) +mkExactFilterWithComma cast lenslike row (foldMap commaSeparatedText -> criterias) + | Set.null criterias = true + | otherwise = lenslike row `E.in_` E.valList (cast <$> Set.toList criterias) + -- | generic filter creation for dbTable -- Given a lens-like function, make filter for exact matches against last element of a collection mkExactFilterLast :: (PersistField a) diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 48b7ac59e..1062ac2a5 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -276,11 +276,13 @@ mkFirmAllTable isAdmin uid = do , sortable (Just "foreigners") (i18nCell MsgTableCompanyNrForeignSupers) $ \(view resultAllCompanyForeignSupers -> nr) -> wgtCell $ word2widget nr , sortable (Just "reroute-act") (i18nCell MsgTableCompanyNrRerouteActive) $ \(view resultAllCompanyActiveReroutes -> nr) -> wgtCell $ word2widget nr , sortable (Just "reroute-all") (i18nCell MsgTableCompanyNrRerouteActive) $ \(view resultAllCompanyActiveReroutes' -> nr) -> wgtCell $ word2widget nr + , sortable (Just "postal-pref") (i18nCell MsgTableCompanyPostalPreference) $ \(view $ resultAllCompany . _companyPrefersPostal -> b) -> iconCell $ bool IconAt IconLetter b ] dbtSorting = mconcat [ singletonMap "name" $ SortColumn (E.^. CompanyName) , singletonMap "short" $ SortColumn (E.^. CompanyShorthand) , singletonMap "avsnr" $ SortColumn (E.^. CompanyAvsId) + , singletonMap "postal-pref" $ SortColumn (E.^. CompanyPrefersPostal) , singletonMap "users" $ SortColumn firmCountUsers , singletonMap "supervisors" $ SortColumn firmCountSupervisors , singletonMap "emp-supervised" $ SortColumn firmCountEmployeeSupervised @@ -387,7 +389,7 @@ postFirmUsersR fsh = do

                              #{companyPostAddress}

                              - Für neue Firmangehörige ist Benachrichtigungs-Voreinstellung: + Benachrichtigungs-Voreinstellung für neue Firmangehörige: # $if companyPrefersPostal #{icon IconLetter} Briefversand $else diff --git a/src/Handler/Utils/Table/Columns.hs b/src/Handler/Utils/Table/Columns.hs index e42451442..ce4147b03 100644 --- a/src/Handler/Utils/Table/Columns.hs +++ b/src/Handler/Utils/Table/Columns.hs @@ -754,23 +754,38 @@ sortUserCompany queryUser = ( "user-company" )) -- | 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 +-- [ mkContainsFilterWithComma CI.mk $ query >>> (E.^. CompanyName) +-- , mkContainsFilterWithComma CI.mk $ query >>> (E.^. CompanyShorthand) +-- , mkExactFilterWithComma id $ query >>> (E.num2text . (E.^. CompanyAvsId)) +-- ] +-- ) + 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)) - ] - ) - +fltrCompanyNameNr query = ("company-name-number", FilterColumn $ \needle (setFoldMap commaSeparatedText -> criterias) -> + let numCrits = setMapMaybe readMay criterias + fltrCName = mkContainsFilterWith CI.mk (query >>> (E.^. CompanyName)) needle criterias + fltrCShort = mkContainsFilterWith CI.mk (query >>> (E.^. CompanyShorthand)) needle criterias + fltrCno = mkExactFilter (query >>> (E.^. CompanyAvsId)) needle numCrits + in if null numCrits + then fltrCName E.||. fltrCShort + else fltrCName E.||. fltrCShort E.||. fltrCno + ) + where + setFoldMap :: (Text -> Set.Set Text) -> Set.Set Text -> Set.Set Text + setFoldMap = foldMap 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) + prismAForm (singletonFilter "company-name-number") mPrev $ aopt textField (fslI msg & setTooltip MsgTableFilterCommaNameNr) ---------------------------- diff --git a/templates/i18n/firm-all/de-de-formal.hamlet b/templates/i18n/firm-all/de-de-formal.hamlet index e4e59fc3e..49ab8a1d5 100644 --- a/templates/i18n/firm-all/de-de-formal.hamlet +++ b/templates/i18n/firm-all/de-de-formal.hamlet @@ -32,11 +32,12 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later Ob ein Ansprechpartner Email oder Briefpost wünscht ist eine individuelle Einstellung des Ansprechpartners und gilt für alle Benachrichtigungen an diesen Ansprechpartner.

                            13. Anzahl der firmenfremden Ansprechpartner, welche mindestens einen Firmenangehörigen betreuen. Bei manchen Firmen ist es normal, dass die Ansprechpartner einer anderen Firma angehören, aber oft ist nur ein Fehler durch Firmenwechsel.
                            14. Anzahl der Ansprechpartner mit derzeit aktiver Benachrichtigungsumleitung, egal ob Brief oder Email. -
                            15. Gesamtzahl der Brief und Emails, welche bei Benachrichtigung aller Firmenangehörigen derzeit verschickt würden. +
                            16. Gesamtzahl der Brief und Emails, welche bei Benachrichtigung aller Firmenangehörigen derzeit verschickt würden.

                              Dies ist also die Gesamtzahl aller derzeit aktiven Benachrichtigungsumleitungen.

                              Beispiel: Für eine Firma mit 2 Angehörigen, für die ein Mitarbeiter 1 Ansprechpartner mit aktiver Umleitung und einen Mitarbeiter mit 3 Ansprechpartnern mit aktiver Umleitung hätte, # würde hier die Zahl 4 stehen, da bei einer Benachrichtigung an beide Mitarbeiter insgesamt 4 Briefe oder Emails versendet würden. +

                            17. Voreinstellung der persönlichen Benachrichtigungspreferenz für Firmenangehörige welche neu aus dem AVS importiert werden (erst mit Umsetzung CR3 effektiv). diff --git a/templates/i18n/firm-all/en-eu.hamlet b/templates/i18n/firm-all/en-eu.hamlet index d1a659458..e8a2ccfb0 100644 --- a/templates/i18n/firm-all/en-eu.hamlet +++ b/templates/i18n/firm-all/en-eu.hamlet @@ -40,4 +40,5 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later Beispiel: Für eine Firma mit 2 Angehörigen, für die ein Mitarbeiter 1 Ansprechpartner mit aktiver Umleitung und einen Mitarbeiter mit 3 Ansprechpartnern mit aktiver Umleitung hätte, # würde hier die Zahl 4 stehen, da bei einer Benachrichtigung an beide Mitarbeiter insgesamt 4 Briefe oder Emails versendet würden. +
                            18. Voreinstellung der persönlichen Benachrichtigungspreferenz für Firmenangehörige welche neu aus dem AVS importiert werden (erst mit Umsetzung CR3 effektiv). From 230ca0c40f3a7cc334fd4b3a9a8435aab189ac74 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 27 Oct 2023 17:26:10 +0200 Subject: [PATCH 20/50] chore(auth): add firm routes to superviser auth tag --- .../categories/authorization/de-de-formal.msg | 2 ++ .../uniworx/categories/authorization/en-eu.msg | 2 ++ routes | 6 +++--- src/Foundation/Authorization.hs | 17 +++++++++++++++-- 4 files changed, 22 insertions(+), 5 deletions(-) diff --git a/messages/uniworx/categories/authorization/de-de-formal.msg b/messages/uniworx/categories/authorization/de-de-formal.msg index 0c8732515..f9a26de23 100644 --- a/messages/uniworx/categories/authorization/de-de-formal.msg +++ b/messages/uniworx/categories/authorization/de-de-formal.msg @@ -20,6 +20,8 @@ UnauthorizedTokenInvalidAuthorityValue: Ihr Authorisierungs-Token basiert auf Re UnauthorizedTokenInvalidImpersonation: Ihr Authorisierungs-Token enthält die Anweisung sich als ein Nutzer:in auszugeben, dies ist jedoch nicht allen Benutzer:innen, auf deren Rechten ihr Authorisierungs-Token basiert, erlaubt. UnauthorizedToken404: Authorisierungs-Tokens können nicht auf Fehlerseiten ausgewertet werden. UnauthorizedSupervisor: Sie sind kein Ansprechpartner:in für diesen Benutzer:in. +UnauthorizedAnySupervisor: Sie sind kein Ansprechpartner:in. +UnauthorizedCompanySupervisor fsh@CompanyShorthand: Sie sind kein Standard Ansprechpartner:in für Firma #{fsh}. UnauthorizedSiteAdmin: Sie sind nicht System-weiter Administrator:in. UnauthorizedSchoolAdmin: Sie sind nicht als Administrator:in für diesen Bereich eingetragen. UnauthorizedAdminEscalation: Sie sind nicht Administrator:in für alle Bereiche, für die dieser Nutzer/diese Nutzerin Administrator:in oder Veranstalter:in ist. diff --git a/messages/uniworx/categories/authorization/en-eu.msg b/messages/uniworx/categories/authorization/en-eu.msg index 87f044580..b539efbf1 100644 --- a/messages/uniworx/categories/authorization/en-eu.msg +++ b/messages/uniworx/categories/authorization/en-eu.msg @@ -20,6 +20,8 @@ UnauthorizedTokenInvalidAuthorityValue: The specification of the rights in which UnauthorizedTokenInvalidImpersonation: Your authorisation-token contains an instruction to impersonate an user. Not all users on whose rights your token is based however are permitted to do so. UnauthorizedToken404: Authorisation-tokens cannot be processed on error pages. UnauthorizedSupervisor: You are not a supervisor for the requested user. +UnauthorizedAnySupervisor: You are not a supervisor. +UnauthorizedCompanySupervisor fsh: You are not a default supervisor for company #{fsh}. UnauthorizedSiteAdmin: You are no system-wide administrator. UnauthorizedSchoolAdmin: You are no administrator for this department. UnauthorizedAdminEscalation: You aren't an administrator for all departments for which this user is an administrator. diff --git a/routes b/routes index b77b24c70..6b89c13f6 100644 --- a/routes +++ b/routes @@ -113,10 +113,10 @@ /for/#CryptoUUIDUser/user ForProfileR GET POST !supervisor !self /for/#CryptoUUIDUser/user/profile ForProfileDataR GET !supervisor !self -/firm FirmAllR GET POST +/firm FirmAllR GET POST !supervisor /firm/#CompanyShorthand FirmR GET POST -/firm/#CompanyShorthand/users FirmUsersR GET POST -/firm/#CompanyShorthand/supers FirmSupersR GET POST +/firm/#CompanyShorthand/users FirmUsersR GET POST !supervisor +/firm/#CompanyShorthand/supers FirmSupersR GET POST !supervisor /exam-office ExamOfficeR !exam-office: / EOExamsR GET POST !system-exam-office diff --git a/src/Foundation/Authorization.hs b/src/Foundation/Authorization.hs index 832cf62a7..7ca298622 100644 --- a/src/Foundation/Authorization.hs +++ b/src/Foundation/Authorization.hs @@ -539,8 +539,11 @@ tagAccessPredicate AuthAdmin = cacheAPSchoolFunction SchoolAdmin (Just $ Right d return Authorized tagAccessPredicate AuthSupervisor = APDB $ \_ _ mAuthId route _ -> case route of - ForProfileR cID -> checkSupervisor (mAuthId, cID) - ForProfileDataR cID -> checkSupervisor (mAuthId, cID) + ForProfileR cID -> checkSupervisor (mAuthId, cID) + ForProfileDataR cID -> checkSupervisor (mAuthId, cID) + FirmAllR -> checkAnySupervisor mAuthId + FirmUsersR fsh -> checkCompanySupervisor (mAuthId, fsh) + FirmSupersR fsh -> checkCompanySupervisor (mAuthId, fsh) r -> $unsupportedAuthPredicate AuthSupervisor r where checkSupervisor sup@(mAuthId, cID) = $cachedHereBinary sup . exceptT return return $ do @@ -549,6 +552,16 @@ tagAccessPredicate AuthSupervisor = APDB $ \_ _ mAuthId route _ -> case route of isSupervisor <- lift . existsBy $ UniqueUserSupervisor authId uid guardMExceptT isSupervisor (unauthorizedI MsgUnauthorizedSupervisor) return Authorized + checkCompanySupervisor sup@(mAuthId, fsh) = $cachedHereBinary sup . exceptT return return $ do + authId <- maybeExceptT AuthenticationRequired $ return mAuthId + isSupervisor <- lift . existsBy $ UniqueUserCompany authId $ CompanyKey fsh + guardMExceptT isSupervisor (unauthorizedI $ MsgUnauthorizedCompanySupervisor fsh) + return Authorized + checkAnySupervisor mAuthId = $cachedHereBinary mAuthId . exceptT return return $ do + authId <- maybeExceptT AuthenticationRequired $ return mAuthId + isSupervisor <- lift $ exists [UserSupervisorSupervisor ==. authId] + guardMExceptT isSupervisor (unauthorizedI MsgUnauthorizedAnySupervisor) + return Authorized tagAccessPredicate AuthSystemExamOffice = cacheAPSystemFunction SystemExamOffice (Just $ Right diffHour) $ \mAuthId' _ _ examOfficeList -> if | maybe True (`Set.notMember` examOfficeList) mAuthId' -> Right $ if From ff176faa12906087b18921a059cd7f0b2c68b362 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 27 Oct 2023 17:28:00 +0200 Subject: [PATCH 21/50] chore(users): remove duplicated link from company personal number --- src/Handler/Users.hs | 9 +++++---- src/Handler/Utils/Table/Cells.hs | 1 + src/Utils.hs | 4 ++-- src/Utils/Icon.hs | 2 +- 4 files changed, 9 insertions(+), 7 deletions(-) diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index ca93e58c7..1133c56d8 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -111,10 +111,11 @@ postUsersR = do companies = (\(E.Value cmpSh, E.Value cmpName, E.Value cmpSpr) -> simpleLink (citext2widget cmpName) (FirmR cmpSh) <> bool mempty icnSuper cmpSpr) <$> companies' pure $ intercalate (text2widget "; ") companies - , sortable (Just "personal-number") (i18nCell MsgCompanyPersonalNumber) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM - (AdminUserR <$> encrypt uid) - (toWgt userCompanyPersonalNumber) - , sortable (Just "company-department") (i18nCell MsgCompanyDepartment) $ \DBRow{ dbrOutput = Entity _uid User{..} } -> cellMaybe textCell userCompanyDepartment + -- , sortable (Just "personal-number") (i18nCell MsgCompanyPersonalNumber) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM + -- (AdminUserR <$> encrypt uid) + -- (toWgt userCompanyPersonalNumber) + , sortable (Just "personal-number") (i18nCell MsgCompanyPersonalNumber) $ \DBRow{ dbrOutput = Entity _uid User{..} } -> cellMaybe textCell userCompanyPersonalNumber + , sortable (Just "company-department") (i18nCell MsgCompanyDepartment) $ \DBRow{ dbrOutput = Entity _uid User{..} } -> cellMaybe textCell userCompanyDepartment -- , sortable (Just "last-name") (i18nCell MsgName) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM -- (AdminUserR <$> encrypt uid) -- (toWidget . display $ last $ impureNonNull $ words $ userDisplayName) diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index e19be03aa..bdc1cc611 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -91,6 +91,7 @@ guardAuthCell mkParams = over cellContents $ \act -> do --------------------- -- Icon cells +-- to be used with icons directly, for results of `icon`, use either `wgtCell` or `iconFixedCell` iconCell :: IsDBTable m a => Icon -> DBCell m a iconCell = cell . toWidget . icon diff --git a/src/Utils.hs b/src/Utils.hs index e91f92015..44b863ae9 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -846,8 +846,8 @@ _MapUnit = iso Map.keysSet $ Map.fromSet (const ()) -- | Just @flip (.)@ for convenient formatting in some cases, -- Deprecated in favor of Control.Arrow.(>>>) -compose :: (a -> b) -> (b -> c) -> (a -> c) -compose = flip (.) +-- compose :: (a -> b) -> (b -> c) -> (a -> c) +-- compose = flip (.) ----------- diff --git a/src/Utils/Icon.hs b/src/Utils/Icon.hs index 645e89e73..982d19b5f 100644 --- a/src/Utils/Icon.hs +++ b/src/Utils/Icon.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost ,Wolfgang Witt +-- SPDX-FileCopyrightText: 2022-23 Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost ,Wolfgang Witt ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later From 90703f4921f98e77d3923817127754167297c8d3 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 27 Oct 2023 17:30:46 +0200 Subject: [PATCH 22/50] chore(firm): implement firm-users dbTable --- .../utils/table_column/de-de-formal.msg | 1 + messages/uniworx/utils/table_column/en-eu.msg | 1 + src/Handler/Firm.hs | 172 +++++++++++++++--- src/Handler/LMS.hs | 2 +- 4 files changed, 147 insertions(+), 29 deletions(-) diff --git a/messages/uniworx/utils/table_column/de-de-formal.msg b/messages/uniworx/utils/table_column/de-de-formal.msg index c08c769cd..579e8ddf0 100644 --- a/messages/uniworx/utils/table_column/de-de-formal.msg +++ b/messages/uniworx/utils/table_column/de-de-formal.msg @@ -80,6 +80,7 @@ TableCompanyShort: Firmenkürzel TableCompanies: Firmen TableCompanyNo: Firmennummer TableCompanyNos: Firmennummern +TableCompanyUser: Firmenangehöriger TableCompanyNrUsers: Firmenangehörige TableCompanyNrSupers: Ansprechpartner TableCompanyNrEmpSupervised: Firmenangehörige mit Ansprechpartner diff --git a/messages/uniworx/utils/table_column/en-eu.msg b/messages/uniworx/utils/table_column/en-eu.msg index dd7742a45..b441ea783 100644 --- a/messages/uniworx/utils/table_column/en-eu.msg +++ b/messages/uniworx/utils/table_column/en-eu.msg @@ -80,6 +80,7 @@ TableCompanyShort: Company shorthand TableCompanies: Companies TableCompanyNo: Company number TableCompanyNos: Company numbers +TableCompanyUser: Associate TableCompanyNrUsers: Associates TableCompanyNrSupers: Supervisors TableCompanyNrEmpSupervised: Supervsied employees diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 1062ac2a5..46b08a864 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -28,7 +28,7 @@ import qualified Data.CaseInsensitive as CI -- import Database.Persist.Sql (updateWhereCount) import Database.Esqueleto.Experimental ((:&)(..)) import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma --- import qualified Database.Esqueleto.Legacy as EL +import qualified Database.Esqueleto.Legacy as EL (from, on) -- import qualified Database.Esqueleto.PostgreSQL as E import qualified Database.Esqueleto.Utils as E import Database.Esqueleto.Utils.TH @@ -77,7 +77,7 @@ postFirmR fsh = do
                                $forall (E.Value _, E.Value dn, E.Value sn, E.Value mbCsh, E.Value nr, E.Value prefPost) <- cactSuper
                              • #{nr} Employees supervised by ^{nameWidget dn sn} # - #{icon (bool IconAt IconLetter prefPost)} # + #{iconLetterOrEmail prefPost} # $maybe csh <- mbCsh $if csh /= fshId from foreign company #{unCompanyKey csh} @@ -112,8 +112,8 @@ data FirmAllActionData = FirmAllActNotifyData -- just in case for future extensions type AllCompanyTableExpr = E.SqlExpr (Entity Company) -queryCompany :: AllCompanyTableExpr -> E.SqlExpr (Entity Company) -queryCompany = id +queryAllCompany :: AllCompanyTableExpr -> E.SqlExpr (Entity Company) +queryAllCompany = id type AllCompanyTableData = DBRow (Entity Company, E.Value Word64, E.Value Word64, E.Value Word64, E.Value Word64, E.Value Word64, E.Value Word64, E.Value Word64, E.Value Word64, E.Value Word64) resultAllCompanyEntity :: Lens' AllCompanyTableData (Entity Company) @@ -255,10 +255,8 @@ mkFirmAllTable isAdmin uid = do ) dbtRowKey = (E.^. CompanyId) dbtProj = dbtProjId - dbtColonnade = formColonnade $ - mconcat - [ if not isAdmin then mempty else -- guardOnM idAdmin $ - dbSelect (applying _2) id (return . view (resultAllCompanyEntity . _entityKey)) + dbtColonnade = formColonnade $ mconcat + [ guardMonoid isAdmin $ dbSelect (applying _2) id (return . view (resultAllCompanyEntity . _entityKey)) , sortable (Just "name") (i18nCell MsgTableCompany) $ \(view resultAllCompany -> firm) -> anchorCell (FirmUsersR $ companyShorthand firm) . toWgt $ companyName firm , sortable (Just "short") (i18nCell MsgTableCompanyShort) $ \(view resultAllCompany -> firm) -> @@ -276,7 +274,7 @@ mkFirmAllTable isAdmin uid = do , sortable (Just "foreigners") (i18nCell MsgTableCompanyNrForeignSupers) $ \(view resultAllCompanyForeignSupers -> nr) -> wgtCell $ word2widget nr , sortable (Just "reroute-act") (i18nCell MsgTableCompanyNrRerouteActive) $ \(view resultAllCompanyActiveReroutes -> nr) -> wgtCell $ word2widget nr , sortable (Just "reroute-all") (i18nCell MsgTableCompanyNrRerouteActive) $ \(view resultAllCompanyActiveReroutes' -> nr) -> wgtCell $ word2widget nr - , sortable (Just "postal-pref") (i18nCell MsgTableCompanyPostalPreference) $ \(view $ resultAllCompany . _companyPrefersPostal -> b) -> iconCell $ bool IconAt IconLetter b + , sortable (Just "postal-pref") (i18nCell MsgTableCompanyPostalPreference) $ \(view $ resultAllCompany . _companyPrefersPostal -> b) -> iconFixedCell $ iconLetterOrEmail b ] dbtSorting = mconcat [ singletonMap "name" $ SortColumn (E.^. CompanyName) @@ -294,12 +292,12 @@ mkFirmAllTable isAdmin uid = do , singletonMap "reroute-all" $ SortColumn firmCountActiveReroutes' ] dbtFilter = mconcat - [ single $ fltrCompanyNameNr queryCompany + [ single $ fltrCompanyNameNr queryAllCompany , 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.where_ $ usrCmp E.^. UserCompanyCompany E.==. queryAllCompany 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) @@ -376,31 +374,149 @@ data FirmUserActionData = FirmUserActNotifyData | FirmUserActMkSuperData deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) +type UserCompanyTableExpr = E.SqlExpr (Entity User) `E.InnerJoin` E.SqlExpr (Entity UserCompany) + +queryUserUser :: UserCompanyTableExpr -> E.SqlExpr (Entity User) +queryUserUser = $(sqlIJproj 2 1) + +queryUserUserCompany :: UserCompanyTableExpr -> E.SqlExpr (Entity UserCompany) +queryUserUserCompany = $(sqlIJproj 2 2) + +type UserCompanyTableData = DBRow (Entity User, Entity UserCompany, E.Value Word64, E.Value Word64) + +resultUserUser :: Lens' UserCompanyTableData (Entity User) +resultUserUser = _dbrOutput . _1 + +resultUserUserCompany :: Lens' UserCompanyTableData (Entity UserCompany) +resultUserUserCompany = _dbrOutput . _2 + +resultUserCompanySupervisors :: Lens' UserCompanyTableData Word64 +resultUserCompanySupervisors = _dbrOutput . _3 . _unValue + +resultUserCompanyReroutes :: Lens' UserCompanyTableData Word64 +resultUserCompanyReroutes = _dbrOutput . _4 . _unValue + +instance HasEntity UserCompanyTableData User where + hasEntity = resultUserUser + +instance HasUser UserCompanyTableData where + hasUser = resultUserUser . _entityVal + + +firmCountUserSupervisors :: E.SqlExpr (Entity UserCompany) -> E.SqlExpr (E.Value Word64) +firmCountUserSupervisors usrCmp = E.subSelectCount $ do + usrSpr <- E.from $ E.table @UserSupervisor + E.where_ $ usrSpr E.^. UserSupervisorUser E.==. usrCmp E.^. UserCompanyUser + +firmCountUserSupervisorsReroute :: E.SqlExpr (Entity UserCompany) -> E.SqlExpr (E.Value Word64) +firmCountUserSupervisorsReroute usrCmp = E.subSelectCount $ do + usrSpr <- E.from $ E.table @UserSupervisor + E.where_ $ usrSpr E.^. UserSupervisorUser E.==. usrCmp E.^. UserCompanyUser + E.&&. usrSpr E.^. UserSupervisorRerouteNotifications + +mkFirmUserTable :: Bool -> CompanyId -> DB (FormResult (FirmUserActionData, Set UserId), Widget) +mkFirmUserTable isAdmin cid = do + let + resultDBTable = DBTable{..} + where + dbtSQLQuery = \(usr `E.InnerJoin` usrCmp) -> do + EL.on $ usr E.^. UserId E.==. usrCmp E.^. UserCompanyUser + E.where_ $ usrCmp E.^. UserCompanyCompany E.==. E.val cid + return (usr, usrCmp, firmCountUserSupervisors usrCmp, firmCountUserSupervisorsReroute usrCmp) + dbtRowKey = queryUserUser >>> (E.^. UserId) + dbtProj = dbtProjId + dbtColonnade = formColonnade $ mconcat + [ guardMonoid isAdmin $ dbSelect (applying _2) id (return . view (resultUserUser . _entityKey)) + , colUserNameModalHdr MsgTableCompanyUser ForProfileDataR + , sortable (Just "matriculation") (i18nCell MsgTableMatrikelNr) $ \(view resultUserUser -> entUsr ) -> cellHasMatrikelnummerLinked entUsr + , sortable (Just "personal-number") (i18nCell MsgCompanyPersonalNumber) $ \(view $ resultUserUser . _userCompanyPersonalNumber -> t) -> foldMap textCell t + , sortable (Just "supervisors") (i18nCell MsgTableCompanyNrSupers ) $ \(view resultUserCompanySupervisors -> nr) -> wgtCell $ word2widget nr + , sortable (Just "reroutes") (i18nCell MsgTableCompanyNrRerouteActive) $ \(view resultUserCompanyReroutes -> nr) -> wgtCell $ word2widget nr + , sortable (Just "postal-pref") (i18nCell MsgPrefersPostal) $ \(view $ resultUserUser . _userPrefersPostal -> b) -> iconFixedCell $ iconLetterOrEmail b + , colUserEmail + ] + dbtSorting = mconcat + [ single $ sortUserNameLink queryUserUser + , single $ sortUserEmail queryUserUser + , singletonMap "postal-pref" $ SortColumn $ queryUserUser >>> (E.^. UserPrefersPostal) + , singletonMap "matriculation" $ SortColumn $ queryUserUser >>> (E.^. UserMatrikelnummer) + , singletonMap "personal-number" $ SortColumn $ queryUserUser >>> (E.^. UserCompanyPersonalNumber) + , singletonMap "supervisors" $ SortColumn $ queryUserUserCompany >>> firmCountUserSupervisors + , singletonMap "reroutes" $ SortColumn $ queryUserUserCompany >>> firmCountUserSupervisorsReroute + ] + dbtFilter = mconcat + [ single $ fltrUserNameEmail queryUserUser + ] + dbtFilterUI mPrev = mconcat + [ fltrUserNameEmailHdrUI MsgTableCompanyUser mPrev + ] + dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } + acts :: Map FirmUserAction (AForm Handler FirmUserActionData) + acts = mconcat + [ singletonMap FirmUserActNotify $ pure FirmUserActNotifyData + , singletonMap FirmUserActMkSuper $ pure FirmUserActMkSuperData + ] + 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-users" + dbtCsvEncode = noCsvEncode + dbtCsvDecode = Nothing + dbtExtraReps = [] + + postprocess :: FormResult (First FirmUserActionData, DBFormResult UserId Bool UserCompanyTableData) + -> FormResult ( FirmUserActionData, Set UserId) + postprocess inp = do + (First (Just act), m) <- inp + let s = Map.keysSet . Map.filter id $ getDBFormResult (const False) m + return (act, s) + + -- resultDBTableValidator :: PSValidator (MForm Handler) (FormResult (First FirmAllActionData, DBFormResult CompanyId Bool FirmAllActionData)) + resultDBTableValidator = def + & defaultSorting [SortAscBy "user-name"] + over _1 postprocess <$> dbTable resultDBTableValidator resultDBTable + + getFirmUsersR, postFirmUsersR :: CompanyShorthand -> Handler Html getFirmUsersR = postFirmUsersR postFirmUsersR fsh = do + isAdmin <- hasReadAccessTo AdminR let fshId = CompanyKey fsh - Company{..} <- runDB $ get404 fshId + (Company{..}, (fusrRes, fusrTable)) <- runDB $ (,) + <$> get404 fshId + <*> mkFirmUserTable isAdmin fshId + formResult fusrRes $ \case + (FirmUserActNotifyData , fids) -> addMessage Info $ text2Html $ "Notify " <> tshow (length fids) <> " employees. TODO" + (FirmUserActMkSuperData, fids) -> addMessage Info $ text2Html $ "Make " <> tshow (length fids) <> " employees to supervisors. TODO" siteLayout (citext2widget companyName) $ do - setTitle $ citext2Html companyShorthand + setTitle $ toHtml $ CI.original companyShorthand <> " (" <> tshow companyAvsId <> ")" [whamlet| -

                                - #{companyPostAddress} -

                                - Benachrichtigungs-Voreinstellung für neue Firmangehörige: # - $if companyPrefersPostal - #{icon IconLetter} Briefversand - $else - #{icon IconAt} Email -

                                - AVS Nummer #{companyAvsId} - -

                                - !!!STUB!!!TO DO!!! -

                                - Table showing all company associated users +

                                +

                                + #{companyPostAddress} +

                                + Benachrichtigungs-Voreinstellung für neue Firmangehörige: # + $if companyPrefersPostal + #{icon IconLetter} Briefversand + $else + #{icon IconAt} Email +

                                +

                                + Company associated users, excluding foreign supervisors +

                                + ^{fusrTable} |] diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index c0e32c3f4..682e0c7f4 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -631,7 +631,7 @@ postLmsR sid qsh = do <* aformMessage msgRestartWarning ] colChoices cmpMap = mconcat - [ if not isAdmin then mempty else dbSelect (applying _2) id (return . view (resultUser . _entityKey)) + [ guardMonoid isAdmin $ dbSelect (applying _2) id (return . view (resultUser . _entityKey)) , colUserNameModalHdr MsgLmsUser AdminUserR , colUserEmail , sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \( view resultCompanyUser -> cmps) -> From 647964fc355665109fe9400e4c8cddf6e353ec0d Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 27 Oct 2023 18:23:39 +0200 Subject: [PATCH 23/50] chore(firm): add users filter for (foreign) supervisors --- .../uniworx/categories/firm/de-de-formal.msg | 4 +- messages/uniworx/categories/firm/en-eu.msg | 4 +- .../categories/settings/de-de-formal.msg | 3 +- .../uniworx/categories/settings/en-eu.msg | 3 +- src/Handler/Firm.hs | 538 +----------------- src/Handler/Profile.hs | 2 +- templates/profileData.hamlet | 2 +- 7 files changed, 37 insertions(+), 519 deletions(-) diff --git a/messages/uniworx/categories/firm/de-de-formal.msg b/messages/uniworx/categories/firm/de-de-formal.msg index 3758bc790..786e57dd6 100644 --- a/messages/uniworx/categories/firm/de-de-formal.msg +++ b/messages/uniworx/categories/firm/de-de-formal.msg @@ -5,4 +5,6 @@ FirmAllActNotify: Mitteilung versenden FirmAllActResetSupervision: Ansprechpartner für alle Firmenangehörigen zurücksetzen FirmUserActNotify: Mitteilung versenden -FirmUserActMkSuper: Zum Firmenansprechparnter ernennen +FirmUserActMkSuper: Zum Firmenansprechpartner ernennen +FilterSupervisor: Hat aktiven Ansprechpartner +FilterSupervisorCompany fsh@CompanyShorthand: Hat aktiven Ansprechpartner, der #{fsh} angehört diff --git a/messages/uniworx/categories/firm/en-eu.msg b/messages/uniworx/categories/firm/en-eu.msg index 34ede15a2..a9e105cc3 100644 --- a/messages/uniworx/categories/firm/en-eu.msg +++ b/messages/uniworx/categories/firm/en-eu.msg @@ -5,4 +5,6 @@ FirmAllActNotify: Send message FirmAllActResetSupervision: Reset supervisors for all company associates FirmUserActNotify: Send message -FirmUserActMkSuper: Mark as company supervisor \ No newline at end of file +FirmUserActMkSuper: Mark as company supervisor +FilterSupervisor: Has active supervisor +FilterSupervisorCompany fsh: Has active company supervisor belonging to #{fsh} \ No newline at end of file diff --git a/messages/uniworx/categories/settings/de-de-formal.msg b/messages/uniworx/categories/settings/de-de-formal.msg index 028c2085f..302c38b84 100644 --- a/messages/uniworx/categories/settings/de-de-formal.msg +++ b/messages/uniworx/categories/settings/de-de-formal.msg @@ -37,7 +37,8 @@ PDFPassword: Passwort zur Verschlüsselung von PDF Anhängen an Email Benachrich PDFPasswordTip: Achtung, dieses Passwort ist für FRADrive Administratoren einsehbar und wird unverschlüsselt gespeichert! PDFPasswordInvalid c@Char: Bitte ein nicht-triviales Passwort für PDF Email Anhänge eintragen! Ungültiges Zeichen: #{char2Text c} PDFPasswordTooShort n@Int: Bitte ein PDF Passwort mit mindestens #{show n} Zeichen wählen oder Post-Versand aktivieren -PrefersPostal: Sollen Benachrichtigung möglichst per Post versendet werden anstatt per Email? +PrefersPostal: Bevorzugte Benachrichtigung +PrefersPostalExp: Sollen Benachrichtigung möglichst per Post versendet werden anstatt per Email? PostalTip: Postversand kann in Rechnung gestellt werden und ist derzeit nur für Benachrichtigungen über Erneuerung und Ablauf von Qualifikation, wie z.B. Führerscheine, verfügbar. PostAddress: Postalische Adresse PostAddressTip: Mindestens eine Zeile mit Straße und Hausnummer und eine Zeile mit Postleitzahl und Ort. Kein Empfängername, denn dieser wird später automatisch hinzugefügt. diff --git a/messages/uniworx/categories/settings/en-eu.msg b/messages/uniworx/categories/settings/en-eu.msg index 5fa8840f5..1a4790f5e 100644 --- a/messages/uniworx/categories/settings/en-eu.msg +++ b/messages/uniworx/categories/settings/en-eu.msg @@ -37,7 +37,8 @@ PDFPassword: Password to lock PDF email attachments PDFPasswordTip: Please note that this password is displayed to FRADrive admins and is saved unencrypted PDFPasswordInvalid c: Please supply a sensible password for encrypting PDF email attachments! Invalid character #{char2Text c} PDFPasswordTooShort n: Please provide a password with at least #{show n} characters or choose postal mail -PrefersPostal: Should notifications preferably send by post instead of email? +PrefersPostal: Notification preference +PrefersPostalExp: Should notifications preferably send by post instead of email? PostalTip: Mailing may incur a fee and is currently only avaulable for qualification expiry notifications, such as driving lincence renewal. PostAddress: Postal address PostAddressTip: Should contain at least one line with street and house number and another line featuring zip code and town. Omit a recipient name, since it will be added later. diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 46b08a864..4fcad5788 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -417,6 +417,7 @@ firmCountUserSupervisorsReroute usrCmp = E.subSelectCount $ do mkFirmUserTable :: Bool -> CompanyId -> DB (FormResult (FirmUserActionData, Set UserId), Widget) mkFirmUserTable isAdmin cid = do let + fsh = unCompanyKey cid resultDBTable = DBTable{..} where dbtSQLQuery = \(usr `E.InnerJoin` usrCmp) -> do @@ -445,10 +446,33 @@ mkFirmUserTable isAdmin cid = do , singletonMap "reroutes" $ SortColumn $ queryUserUserCompany >>> firmCountUserSupervisorsReroute ] dbtFilter = mconcat - [ single $ fltrUserNameEmail queryUserUser + [ single $ fltrUserNameEmail queryUserUser + , singletonMap "has-supervisor" $ FilterColumn $ \row (getLast -> criterion) -> + let checkSuper = do + usrSpr <- E.from $ E.table @UserSupervisor + E.where_ $ usrSpr E.^. UserSupervisorUser E.==. queryUserUser row E.^. UserId + in case criterion of + Nothing -> E.true + Just True -> E.exists checkSuper + Just False -> E.notExists checkSuper + , singletonMap "has-company-supervisor" $ FilterColumn $ \row (getLast -> criterion) -> + let checkSuper = do + usrSpr <- E.from $ E.table @UserSupervisor + E.where_ $ usrSpr E.^. UserSupervisorUser E.==. queryUserUser row E.^. UserId + E.&&. E.exists (do + spr <- E.from $ E.table @UserCompany + E.where_ $ spr E.^. UserCompanyCompany E.==. E.val cid + E.&&. spr E.^. UserCompanyUser E.==. usrSpr E.^. UserSupervisorSupervisor + ) + in case criterion of + Nothing -> E.true + Just True -> E.exists checkSuper + Just False -> E.notExists checkSuper ] dbtFilterUI mPrev = mconcat [ fltrUserNameEmailHdrUI MsgTableCompanyUser mPrev + , prismAForm (singletonFilter "has-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterSupervisor) + , prismAForm (singletonFilter "has-company-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI $ MsgFilterSupervisorCompany fsh) ] dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } acts :: Map FirmUserAction (AForm Handler FirmUserActionData) @@ -487,8 +511,6 @@ mkFirmUserTable isAdmin cid = do over _1 postprocess <$> dbTable resultDBTableValidator resultDBTable - - getFirmUsersR, postFirmUsersR :: CompanyShorthand -> Handler Html getFirmUsersR = postFirmUsersR postFirmUsersR fsh = do @@ -530,513 +552,3 @@ postFirmSupersR fsh = do siteLayout (citext2widget fsh) $ do setTitle $ citext2Html fsh [whamlet|!!!STUB!!!TO DO!!!|] - - --- data QualificationTableCsv = QualificationTableCsv -- Q..T..C.. -> qtc.. --- { qtcDisplayName :: UserDisplayName --- , qtcEmail :: UserEmail --- , qtcCompany :: Maybe Text --- , qtcCompanyNumbers :: CsvSemicolonList Int --- , qtcValidUntil :: Day --- , qtcLastRefresh :: Day --- , qtcBlockStatus :: Maybe Bool --- , qtcBlockFrom :: Maybe UTCTime --- , qtcScheduleRenewal:: Bool --- , qtcLmsStatusTxt :: Maybe Text --- , qtcLmsStatusDay :: Maybe UTCTime --- } --- deriving Generic --- makeLenses_ ''QualificationTableCsv - --- qtcExample :: QualificationTableCsv --- qtcExample = QualificationTableCsv --- { qtcDisplayName = "Max Mustermann" --- , qtcEmail = "m.mustermann@example.com" --- , qtcCompany = Just "Example Brothers LLC, SecondaryJobs Inc" --- , qtcCompanyNumbers = CsvSemicolonList [27,69] --- , qtcValidUntil = compDay --- , qtcLastRefresh = compDay --- , qtcBlockStatus = Nothing --- , qtcBlockFrom = Nothing --- , qtcScheduleRenewal= True --- , qtcLmsStatusTxt = Just "Success" --- , qtcLmsStatusDay = Just compTime --- } --- where --- compTime :: UTCTime --- compTime = $compileTime --- compDay :: Day --- compDay = utctDay compTime - --- qtcOptions :: Csv.Options --- qtcOptions = Csv.defaultOptions { Csv.fieldLabelModifier = renameLtc } --- where --- renameLtc "qtcDisplayName" = "licensee" --- renameLtc other = replaceLtc $ camelToPathPiece' 1 other --- replaceLtc ('l':'m':'s':'-':t) = prefixLms t --- replaceLtc other = other --- prefixLms = ("elearn-" <>) - --- instance Csv.ToNamedRecord QualificationTableCsv where --- toNamedRecord = Csv.genericToNamedRecord qtcOptions - --- instance Csv.DefaultOrdered QualificationTableCsv where --- headerOrder = Csv.genericHeaderOrder qtcOptions - --- instance CsvColumnsExplained QualificationTableCsv where --- csvColumnsExplanations = genericCsvColumnsExplanations qtcOptions $ Map.fromList --- [ ('qtcDisplayName , SomeMessage MsgLmsUser) --- , ('qtcEmail , SomeMessage MsgTableLmsEmail) --- , ('qtcCompany , SomeMessage MsgTableCompanies) --- , ('qtcCompanyNumbers , SomeMessage MsgTableCompanyNos) --- , ('qtcValidUntil , SomeMessage MsgLmsQualificationValidUntil) --- , ('qtcLastRefresh , SomeMessage MsgTableQualificationLastRefresh) --- , ('qtcBlockStatus , SomeMessage MsgInfoQualificationBlockStatus) --- , ('qtcBlockFrom , SomeMessage MsgInfoQualificationBlockFrom) --- , ('qtcScheduleRenewal, SomeMessage MsgQualificationScheduleRenewalTooltip) --- , ('qtcLmsStatusTxt , SomeMessage MsgTableLmsStatus) --- , ('qtcLmsStatusDay , SomeMessage MsgTableLmsStatusDay) --- ] - - --- type QualificationTableExpr = ( E.SqlExpr (Entity QualificationUser) --- `E.InnerJoin` E.SqlExpr (Entity User) --- ) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity LmsUser)) --- `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity QualificationUserBlock)) - --- queryQualUser :: QualificationTableExpr -> E.SqlExpr (Entity QualificationUser) --- queryQualUser = $(sqlIJproj 2 1) . $(sqlLOJproj 3 1) - --- queryUser :: QualificationTableExpr -> E.SqlExpr (Entity User) --- queryUser = $(sqlIJproj 2 2) . $(sqlLOJproj 3 1) - --- queryLmsUser :: QualificationTableExpr -> E.SqlExpr (Maybe (Entity LmsUser)) --- queryLmsUser = $(sqlLOJproj 3 2) - --- queryQualBlock :: QualificationTableExpr -> E.SqlExpr (Maybe (Entity QualificationUserBlock)) --- queryQualBlock = $(sqlLOJproj 3 3) - --- type QualificationTableData = DBRow (Entity QualificationUser, Entity User, Maybe (Entity LmsUser), Maybe (Entity QualificationUserBlock), [Entity UserCompany]) - --- resultQualUser :: Lens' QualificationTableData (Entity QualificationUser) --- resultQualUser = _dbrOutput . _1 - --- resultUser :: Lens' QualificationTableData (Entity User) --- resultUser = _dbrOutput . _2 - --- resultLmsUser :: Traversal' QualificationTableData (Entity LmsUser) --- resultLmsUser = _dbrOutput . _3 . _Just - --- resultQualBlock :: Traversal' QualificationTableData (Entity QualificationUserBlock) --- resultQualBlock = _dbrOutput . _4 . _Just - --- resultCompanyUser :: Lens' QualificationTableData [Entity UserCompany] --- resultCompanyUser = _dbrOutput . _5 - - --- instance HasEntity QualificationTableData User where --- hasEntity = resultUser - --- instance HasUser QualificationTableData where --- hasUser = resultUser . _entityVal - --- instance HasEntity QualificationTableData QualificationUser where --- hasEntity = resultQualUser - --- instance HasQualificationUser QualificationTableData where --- hasQualificationUser = resultQualUser . _entityVal - --- -- instance HasEntity QualificationUserBlock where --- -- hasQualificationUserBlock = resultQualBlock - - --- data QualificationTableAction --- = QualificationActExpire --- | QualificationActUnexpire --- | QualificationActBlockSupervisor --- | QualificationActBlock --- | QualificationActUnblock --- | QualificationActRenew --- | QualificationActGrant --- deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) - --- instance Universe QualificationTableAction --- instance Finite QualificationTableAction --- nullaryPathPiece ''QualificationTableAction $ camelToPathPiece' 2 --- embedRenderMessage ''UniWorX ''QualificationTableAction id - --- {- --- isAdminAct :: QualificationTableAction -> Bool --- isAdminAct QualificationActExpire = False --- isAdminAct QualificationActUnexpire = False --- isAdminAct QualificationActBlockSupervisor = False --- isAdminAct _ = True --- -} - --- data QualificationTableActionData --- = QualificationActExpireData --- | QualificationActUnexpireData --- | QualificationActBlockSupervisorData --- | QualificationActBlockData { qualTableActBlockReason :: Text, qualTableActNotify :: Bool, qualTableActRemoveSupervisors :: Bool } --- | QualificationActUnblockData { qualTableActBlockReason :: Text, qualTableActNotify :: Bool} --- | QualificationActRenewData --- | QualificationActGrantData { qualTableActGrantUntil :: Day } --- deriving (Eq, Ord, Show, Generic) - --- isExpiryAct :: QualificationTableActionData -> Bool --- isExpiryAct QualificationActExpireData = True --- isExpiryAct QualificationActUnexpireData = True --- isExpiryAct _ = False - --- isBlockAct :: QualificationTableActionData -> Bool --- isBlockAct QualificationActBlockSupervisorData = True --- isBlockAct QualificationActBlockData{} = True --- isBlockAct QualificationActUnblockData{} = True --- isBlockAct _ = False - --- blockActRemoveSupervisors :: QualificationTableActionData -> Bool --- blockActRemoveSupervisors QualificationActBlockSupervisorData = True --- blockActRemoveSupervisors QualificationActBlockData{qualTableActRemoveSupervisors=res} = res --- blockActRemoveSupervisors _ = False - --- -- qualificationTableQuery :: QualificationId -> (_ -> E.SqlExpr (E.Value Bool)) -> QualificationTableExpr --- -- -> E.SqlQuery ( E.SqlExpr (Entity QualificationUser) --- -- , E.SqlExpr (Entity User) --- -- , E.SqlExpr (Maybe (Entity LmsUser)) --- -- ) --- -- qualificationTableQuery qid fltr (qualUser `E.InnerJoin` user `E.LeftOuterJoin` lmsUse) = do --- -- E.on $ user E.^. UserId E.=?. lmsUser E.?. LmsUserUser --- -- E.&&. E.val qid E.=?. lmsUser E.?. LmsUserQualification -- NOTE: condition was once erroneously placed in where-clause, which does not work --- -- E.on $ user E.^. UserId E.==. qualUser E.^. QualificationUserUser --- -- E.where_ $ fltr qualUser E.&&. (E.val qid E.==. qualUser E.^. QualificationUserQualification) --- -- return (qualUser, user, lmsUser) - --- qualificationTableQuery :: UTCTime -> QualificationId -> (_ -> E.SqlExpr (E.Value Bool)) -> QualificationTableExpr --- -> E.SqlQuery ( E.SqlExpr (Entity QualificationUser) --- , E.SqlExpr (Entity User) --- , E.SqlExpr (Maybe (Entity LmsUser)) --- , E.SqlExpr (Maybe (Entity QualificationUserBlock)) --- ) --- qualificationTableQuery now qid fltr (qualUser `E.InnerJoin` user `E.LeftOuterJoin` lmsUser `E.LeftOuterJoin` qualBlock) = do --- -- E.distinctOnOrderBy will not work: sorting with dbTable should work, except that columns contained in distinctOnOrderBy cannot be sorted inversely by user; but PostgreSQL leftJoin with distinct filters too many results, see SQL Example lead/lag under jost/misc DevOps --- -- --- E.on $ qualBlock E.?. QualificationUserBlockQualificationUser E.?=. qualUser E.^. QualificationUserId --- E.&&. qualBlock `isLatestBlockBefore` E.val now --- E.on $ user E.^. UserId E.=?. lmsUser E.?. LmsUserUser --- E.&&. E.val qid E.=?. lmsUser E.?. LmsUserQualification -- NOTE: condition was once erroneously placed in where-clause, which does not work --- E.on $ user E.^. UserId E.==. qualUser E.^. QualificationUserUser --- E.where_ $ fltr qualUser --- E.&&. (E.val qid E.==. qualUser E.^. QualificationUserQualification) --- return (qualUser, user, lmsUser, qualBlock) - - --- mkQualificationTable :: --- ( Functor h, ToSortable h --- , AsCornice h p QualificationTableData (DBCell (MForm Handler) (FormResult (First QualificationTableActionData, DBFormResult UserId Bool QualificationTableData))) cols --- ) --- => Bool --- -> Entity Qualification --- -> Map QualificationTableAction (AForm Handler QualificationTableActionData) --- -> (Map CompanyId Company -> cols) --- -> PSValidator (MForm Handler) (FormResult (First QualificationTableActionData, DBFormResult UserId Bool QualificationTableData)) --- -> DB (FormResult (QualificationTableActionData, Set UserId), Widget) --- mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do --- svs <- getSupervisees --- now <- liftIO getCurrentTime --- -- lookup all companies --- cmpMap <- memcachedBy (Just . Right $ 5 * diffMinute) ("CompanyDictionary"::Text) $ do --- cmps <- selectList [] [] -- [Asc CompanyShorthand] --- return $ Map.fromList $ fmap (\Entity{..} -> (entityKey, entityVal)) cmps --- let --- nowaday = utctDay now --- mbRenewal = addGregorianDurationClip <$> qualificationRefreshWithin quali <*> Just nowaday --- csvName = T.replace " " "-" $ CI.original (quali ^. _qualificationName) --- dbtIdent :: Text --- dbtIdent = "qualification" --- fltrSvs = if isAdmin then const E.true else \quser -> quser E.^. QualificationUserUser `E.in_` E.vals svs --- dbtSQLQuery = qualificationTableQuery now qid fltrSvs --- dbtRowKey = queryUser >>> (E.^. UserId) --- dbtProj = dbtProjSimple $ \(qualUsr, usr, lmsUsr, qUsrBlock) -> do --- -- cmps <- 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 (entityKey usr) --- -- E.orderBy [E.asc (comp E.^. CompanyName)] --- -- return (comp E.^. CompanyName, comp E.^. CompanyAvsId, usrComp E.^. UserCompanySupervisor) --- cmpUsr <- selectList [UserCompanyUser ==. entityKey usr] [Asc UserCompanyCompany] --- return (qualUsr, usr, lmsUsr, qUsrBlock, cmpUsr) --- dbtColonnade = cols cmpMap --- dbtSorting = mconcat --- [ single $ sortUserNameLink queryUser --- , single $ sortUserEmail queryUser --- , single $ sortUserMatriclenr queryUser --- , single ("first-held" , SortColumn $ queryQualUser >>> (E.^. QualificationUserFirstHeld)) --- , single ("last-refresh" , SortColumn $ queryQualUser >>> (E.^. QualificationUserLastRefresh)) --- , single ("last-notified" , SortColumn $ queryQualUser >>> (E.^. QualificationUserLastNotified)) --- , single ("valid-until" , SortColumn $ queryQualUser >>> (E.^. QualificationUserValidUntil)) --- , single ("blocked" , SortColumnNeverNull $ queryQualBlock >>> (E.?. QualificationUserBlockFrom)) --- , single ("lms-status-plus",SortColumnNeverNull $ \row -> E.coalesce [ E.joinV (queryLmsUser row E.?. LmsUserStatusDay) --- , E.joinV (queryLmsUser row E.?. LmsUserNotified) --- , queryLmsUser row E.?. LmsUserStarted]) --- , single ("schedule-renew", SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserScheduleRenewal)) --- , single ("user-company" , SortColumn $ \row -> E.subSelect $ E.from $ \(usrComp `E.InnerJoin` comp) -> do --- E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId --- E.where_ $ usrComp E.^. UserCompanyUser E.==. queryUser row E.^. UserId --- E.orderBy [E.asc (comp E.^. CompanyName)] --- return (comp E.^. CompanyName) --- ) --- -- , single ("validity", SortColumn $ queryQualUser >>> validQualification now) --- ] --- dbtFilter = mconcat --- [ single $ fltrUserNameEmail queryUser --- , single ("avs-number" , FilterColumn . E.mkExistsFilter $ \row criterion -> --- E.from $ \usrAvs -> -- do --- E.where_ $ usrAvs E.^. UserAvsUser E.==. queryUser row E.^. UserId --- E.&&. ((E.val criterion :: E.SqlExpr (E.Value (CI Text))) E.==. --- (E.explicitUnsafeCoerceSqlExprValue "citext" (usrAvs E.^. UserAvsNoPerson) :: E.SqlExpr (E.Value (CI Text))) )) --- , single ("avs-card" , FilterColumn $ \(queryUser -> user) (criterion :: Set.Set Text) -> case readAvsFullCardNo =<< Set.lookupMin criterion of --- Nothing -> E.false --- Just cardNo -> E.exists $ E.from $ \(avsCard `E.InnerJoin` usrAvs) -> do --- E.on $ usrAvs E.^. UserAvsPersonId E.==. avsCard E.^. UserAvsCardPersonId --- E.where_ $ usrAvs E.^. UserAvsUser E.==. user E.^. UserId --- E.&&. (avsCard E.^. UserAvsCardCardNo E.==. E.val cardNo) --- ) --- , single ("personal-number", FilterColumn $ \(queryUser -> user) (criteria :: Set.Set Text) -> if --- | Set.null criteria -> E.true --- | otherwise -> E.any (\c -> user E.^. UserCompanyPersonalNumber `E.hasInfix` E.val c) criteria --- ) --- , single ("user-company", FilterColumn . E.mkExistsFilter $ \row criterion -> --- E.from $ \(usrComp `E.InnerJoin` comp) -> do --- let testname = (E.val criterion :: E.SqlExpr (E.Value (CI Text))) `E.isInfixOf` --- (E.explicitUnsafeCoerceSqlExprValue "citext" (comp E.^. CompanyName) :: E.SqlExpr (E.Value (CI Text))) --- testnumber nr = E.val nr E.==. comp E.^. CompanyAvsId --- testcrit = maybe testname testnumber $ readMay $ CI.original criterion --- E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId --- E.where_ $ usrComp E.^. UserCompanyUser E.==. queryUser row E.^. UserId E.&&. testcrit --- ) --- , single ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) (validQualification now)) --- , single ("renewal-due" , FilterColumn $ \(queryQualUser -> quser) criterion -> --- if | Just renewal <- mbRenewal --- , Just True <- getLast criterion -> quser E.^. QualificationUserValidUntil E.<=. E.val renewal --- E.&&. quser E.^. QualificationUserValidUntil E.>=. E.val nowaday --- | otherwise -> E.true --- ) --- , single ("tobe-notified", FilterColumn $ \row criterion -> --- if | Just True <- getLast criterion -> quserToNotify now (queryQualUser row) (queryQualBlock row) --- | otherwise -> E.true --- ) --- , single ("status" , FilterColumn . E.mkExactFilterMaybeLast' (views (to queryLmsUser) (E.?. LmsUserId)) $ views (to queryLmsUser) (E.?. LmsUserStatus)) --- ] --- dbtFilterUI mPrev = mconcat --- [ fltrUserNameEmailHdrUI MsgLmsUser mPrev --- , prismAForm (singletonFilter "user-company") mPrev $ aopt textField (fslI MsgTableCompany) --- , prismAForm (singletonFilter "personal-number" ) mPrev $ aopt textField (fslI MsgCompanyPersonalNumber) --- , prismAForm (singletonFilter "avs-card" ) mPrev $ aopt textField (fslI MsgAvsCardNo) --- , prismAForm (singletonFilter "avs-number" ) mPrev $ aopt textField (fslI MsgAvsPersonNo) --- , prismAForm (singletonFilter "validity" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsValid) --- , if isNothing mbRenewal then mempty --- else prismAForm (singletonFilter "renewal-due" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsRenewal) --- , prismAForm (singletonFilter "tobe-notified" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsNotificationDue) --- , prismAForm (singletonFilter "status" . maybePrism _PathPiece) mPrev $ aopt (hoistField liftHandler (selectField optionsFinite) :: (Field _ (Maybe LmsStatus))) (fslI MsgTableLmsStatus) --- ] --- dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } --- dbtCsvEncode = Just DBTCsvEncode --- { dbtCsvExportForm = pure () --- , dbtCsvDoEncode = \() -> C.map (doEncode' . view _2) --- , dbtCsvName = csvName --- , dbtCsvSheetName = csvName --- , dbtCsvNoExportData = Just id --- , dbtCsvHeader = const $ return $ Csv.headerOrder qtcExample --- , dbtCsvExampleData = Just [qtcExample] --- } --- where --- doEncode' :: QualificationTableData -> QualificationTableCsv --- doEncode' = QualificationTableCsv --- <$> view (resultUser . _entityVal . _userDisplayName) --- <*> view (resultUser . _entityVal . _userDisplayEmail) --- <*> (view resultCompanyUser >>= getCompanies) --- <*> (view resultCompanyUser >>= getCompanyNos) --- <*> view (resultQualUser . _entityVal . _qualificationUserValidUntil) --- <*> view (resultQualUser . _entityVal . _qualificationUserLastRefresh) --- <*> preview (resultQualBlock. _entityVal . _qualificationUserBlockUnblock . _not) --- <*> preview (resultQualBlock. _entityVal . _qualificationUserBlockFrom) --- <*> view (resultQualUser . _entityVal . _qualificationUserScheduleRenewal) --- <*> getStatusPlusTxt --- <*> getStatusPlusDay --- getCompanies cmps = case mapMaybe (flip Map.lookup cmpMap . view (_entityVal . _userCompanyCompany)) cmps of --- [] -> pure Nothing --- somecmps -> pure $ Just $ intercalate ", " $ fmap (view (_companyName . _CI)) somecmps --- getCompanyNos = pure . CsvSemicolonList . mapMaybe (preview (_Just . _companyAvsId) . flip Map.lookup cmpMap . view (_entityVal . _userCompanyCompany)) - --- getStatusPlusTxt = --- (join . preview (resultLmsUser . _entityVal . _lmsUserStatus)) >>= \case --- Just LmsBlocked{} -> return $ Just "Failed" --- Just LmsExpired{} -> return $ Just "Expired" --- Just LmsSuccess{} -> return $ Just "Success" --- Nothing -> maybeM (return Nothing) (const $ return $ Just "Open") $ --- preview (resultLmsUser . _entityVal . _lmsUserStarted) --- getStatusPlusDay = --- (join . preview (resultLmsUser . _entityVal . _lmsUserStatusDay)) >>= \case --- lsd@(Just _) -> return lsd --- Nothing -> preview (resultLmsUser . _entityVal . _lmsUserStarted) - --- dbtCsvDecode = Nothing --- dbtExtraReps = [] --- 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 --- } - --- postprocess :: FormResult (First QualificationTableActionData, DBFormResult UserId Bool QualificationTableData) --- -> FormResult ( QualificationTableActionData, Set UserId) --- postprocess inp = do --- (First (Just act), usrMap) <- inp --- let usrSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) usrMap --- return (act, usrSet) - --- -- resultDBTableValidator :: PSValidator (MForm Handler) (FormResult (First QualificationTableActionData, DBFormResult UserId Bool QualificationTableActionData)) --- -- resultDBTableValidator = def --- -- & defaultSorting [SortAscBy csvLmsIdent] --- over _1 postprocess <$> dbTable psValidator DBTable{..} - --- getQualificationR, postQualificationR :: SchoolId -> QualificationShorthand -> Handler Html --- getQualificationR = postQualificationR --- postQualificationR sid qsh = do --- isAdmin <- hasReadAccessTo AdminR --- msgGrantWarning <- messageIconI Warning IconWarning MsgQualificationActGrantWarning --- msgUnexpire <- messageIconI Info IconWarning MsgQualificationActUnexpireWarning --- now <- liftIO getCurrentTime --- let nowaday = utctDay now --- ((lmsRes, qualificationTable), Entity qid quali) <- runDB $ do --- qent@Entity{ --- entityKey=qid --- , entityVal=Qualification{ --- qualificationAuditDuration=auditMonths --- , qualificationValidDuration=validMonths --- }} <- getBy404 $ SchoolQualificationShort sid qsh - --- -- Block copied to Handler/Qualifications TODO: refactor --- let getBlockReasons unblk = E.select $ do --- (quser :& qblock) <- E.from $ E.table @QualificationUser --- `E.innerJoin` E.table @QualificationUserBlock --- `E.on` (\(quser :& qblock) -> quser E.^. QualificationUserId E.==. qblock E.^. QualificationUserBlockQualificationUser) --- E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid --- E.&&. unblk (qblock E.^. QualificationUserBlockUnblock) --- E.groupBy (qblock E.^. QualificationUserBlockReason) --- let countRows' :: E.SqlExpr (E.Value Int64) = E.countRows --- E.orderBy [E.desc countRows'] --- E.limit 7 --- pure (qblock E.^. QualificationUserBlockReason) --- mkOption :: E.Value Text -> Option Text --- mkOption (E.unValue -> t) = Option{ optionDisplay = t, optionInternalValue = t, optionExternalValue = toPathPiece t } --- suggestionsBlock :: HandlerFor UniWorX (OptionList Text) --- suggestionsBlock = mkOptionList . fmap mkOption <$> runDB (getBlockReasons E.not_) --- suggestionsUnblock = mkOptionList . fmap mkOption <$> runDB (getBlockReasons id) --- dayExpiry = flip addGregorianDurationClip nowaday . fromMonths <$> validMonths --- acts :: Map QualificationTableAction (AForm Handler QualificationTableActionData) --- acts = mconcat $ --- [ singletonMap QualificationActExpire $ pure QualificationActExpireData --- , singletonMap QualificationActUnexpire $ QualificationActUnexpireData --- <$ aformMessage msgUnexpire --- ] ++ bool --- -- nonAdmin actions, ie. Supervisor --- [ singletonMap QualificationActBlockSupervisor $ pure QualificationActBlockSupervisorData ] --- -- Admin-only actions --- [ singletonMap QualificationActUnblock $ QualificationActUnblockData --- <$> apreq (textField & cfStrip & addDatalist suggestionsUnblock) (fslI MsgQualificationGrantReason) Nothing --- <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgQualificationBlockNotify) (Just False) --- , singletonMap QualificationActBlock $ QualificationActBlockData --- <$> apreq (textField & cfStrip & addDatalist suggestionsBlock) (fslI MsgQualificationBlockReason) Nothing --- <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgQualificationBlockNotify) (Just False) --- <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgQualificationBlockRemoveSupervisor) (Just False) --- , singletonMap QualificationActRenew $ pure QualificationActRenewData --- , singletonMap QualificationActGrant $ QualificationActGrantData --- <$> apopt dayField (fslI MsgLmsQualificationValidUntil) dayExpiry --- <* aformMessage msgGrantWarning --- ] isAdmin --- linkLmsUser = toMaybe isAdmin (LmsUserR sid qsh) --- linkUserName = bool ForProfileR ForProfileDataR isAdmin --- colChoices cmpMap = mconcat --- [ dbSelect (applying _2) id (return . view (hasEntity . _entityKey)) --- , colUserNameModalHdr MsgLmsUser linkUserName --- , colUserEmail --- , sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \( view resultCompanyUser -> cmps) -> --- let icnSuper = text2markup " " <> icon IconSupervisor --- cs = [ (cmpName, cmpSpr) --- | Entity _ UserCompany{userCompanyCompany=cmpId, userCompanySupervisor=cmpSpr} <- cmps --- , let cmpName = maybe (unCompanyKey cmpId) companyName $ Map.lookup cmpId cmpMap --- ] --- companies = intercalate (text2markup ", ") $ --- (\(cmpName, cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> cs --- in wgtCell companies --- , guardMonoid isAdmin colUserMatriclenr --- -- , sortable (Just "validity") (i18nCell MsgQualificationValidIndicator) (qualificationValidIconCell nowaday . view resultQualUser) --- , sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ \( view $ resultQualUser . _entityVal . _qualificationUserFirstHeld -> d) -> dayCell d --- , sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \( view $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> dayCell d --- , sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) (dayCell . view ( resultQualUser . _entityVal . _qualificationUserValidUntil)) --- , sortable (Just "blocked") (i18nCell MsgQualificationValidIndicator & cellTooltip MsgTableQualificationBlockedTooltipSimple) $ \row -> --- qualificationValidReasonCell' (Just $ LmsUserR sid qsh) isAdmin nowaday (row ^? resultQualBlock) row --- , sortable (Just "schedule-renew")(i18nCell MsgTableQualificationNoRenewal & cellTooltip MsgTableQualificationNoRenewalTooltip --- ) $ \( view $ resultQualUser . _entityVal . _qualificationUserScheduleRenewal -> b) -> ifIconCell (not b) IconNoNotification --- , sortable (Just "lms-status-plus")(i18nCell MsgTableLmsStatus & cellTooltipWgt Nothing (lmsStatusInfoCell isAdmin auditMonths)) --- $ \(preview $ resultLmsUser . _entityVal -> lu) -> foldMap (lmsStatusCell isAdmin linkLmsUser) lu --- , sortable (Just "last-notified") (i18nCell MsgTableQualificationLastNotified) $ \( view $ resultQualUser . _entityVal . _qualificationUserLastNotified -> d) -> dateTimeCell d --- ] --- psValidator = def & defaultSorting [SortDescBy "last-refresh"] --- tbl <- mkQualificationTable isAdmin qent acts colChoices psValidator --- return (tbl, qent) - --- formResult lmsRes $ \case --- (QualificationActRenewData, selectedUsers) | isAdmin -> do --- noks <- runDB $ renewValidQualificationUsers qid Nothing $ Set.toList selectedUsers --- addMessageI (if noks > 0 && noks == Set.size selectedUsers then Success else Warning) $ MsgTutorialUserRenewedQualification noks --- reloadKeepGetParams $ QualificationR sid qsh --- (QualificationActGrantData grantValidday, selectedUsers) | isAdmin -> do --- runDB . forM_ selectedUsers $ upsertQualificationUser qid nowaday grantValidday Nothing --- addMessageI (if 0 < Set.size selectedUsers then Success else Warning) . MsgTutorialUserGrantedQualification $ Set.size selectedUsers --- reloadKeepGetParams $ QualificationR sid qsh --- (action, selectedUsers) | isExpiryAct action -> do --- let isUnexpire = action == QualificationActUnexpireData --- upd <- runDB $ updateWhereCount --- [QualificationUserQualification ==. qid, QualificationUserUser <-. Set.toList selectedUsers] --- [QualificationUserScheduleRenewal =. isUnexpire] --- let msgKind = if upd > 0 then Success else Warning --- msgVal = upd & if isUnexpire then MsgQualificationSetUnexpire else MsgQualificationSetExpire --- addMessageI msgKind msgVal --- reloadKeepGetParams $ QualificationR sid qsh --- (action, selectedUsers) | isBlockAct action && (isAdmin || action == QualificationActBlockSupervisorData) -> do --- let selUserIds = Set.toList selectedUsers --- (unblock, reason) = case action of --- QualificationActBlockSupervisorData -> (False, Right QualificationBlockReturnedByCompany) --- QualificationActBlockData{..} -> (False, Left qualTableActBlockReason) --- QualificationActUnblockData{..} -> (True , Left qualTableActBlockReason) --- _ -> error "Handle.Qualification.isBlockAct returned non-block action" -- cannot occur due to earlier checks --- notify = case action of --- QualificationActBlockData{qualTableActNotify} -> qualTableActNotify --- _ -> False - --- oks <- runDB $ do --- when (blockActRemoveSupervisors action) $ deleteWhere [UserSupervisorUser <-. selUserIds] --- qualificationUserBlocking qid selUserIds unblock Nothing reason notify --- let nrq = length selectedUsers --- warnLevel = if --- | oks < 0 -> Error --- | oks == nrq -> Success --- | otherwise -> Warning --- fbmsg = if unblock then MsgQualificationStatusUnblock else MsgQualificationStatusBlock --- addMessageI warnLevel $ fbmsg qsh oks nrq --- reloadKeepGetParams $ QualificationR sid qsh --- _ -> addMessageI Error MsgInvalidFormAction - --- let heading = citext2widget $ qualificationName quali --- siteLayout heading $ do --- setTitle $ toHtml $ unSchoolKey sid <> "-" <> qsh --- $(widgetFile "qualification") diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index 3dde9b54d..e0a12e0b1 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -130,7 +130,7 @@ makeSettingForm template html = do <* aformSection MsgFormNotifications <*> aopt (textField & cfStrip) (fslI MsgPDFPassword & setTooltip MsgPDFPasswordTip) (stgPinPassword <$> template) - <*> apopt checkBoxField (fslI MsgPrefersPostal & setTooltip MsgPostalTip) (stgPrefersPostal <$> template) + <*> apopt checkBoxField (fslI MsgPrefersPostalExp & setTooltip MsgPostalTip) (stgPrefersPostal <$> template) <*> aopt htmlField (fslI MsgPostAddress & setTooltip MsgPostAddressTip) (stgPostAddress <$> template) <*> examOfficeForm (stgExamOfficeSettings <$> template) diff --git a/templates/profileData.hamlet b/templates/profileData.hamlet index 91f194fed..9eb2817af 100644 --- a/templates/profileData.hamlet +++ b/templates/profileData.hamlet @@ -49,7 +49,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later

                                ^{formatTimeW SelFormatDate bday}
                                - _{MsgPrefersPostal} + _{MsgPrefersPostalExp}
                                #{iconLetterOrEmail userPrefersPostal} $maybe addr <- userPostAddress From 13ee3e7315a724e2cab7638b61946d321e7540f0 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 30 Oct 2023 17:18:04 +0100 Subject: [PATCH 24/50] chore(firm): separate firm name nr filters --- .../utils/table_column/de-de-formal.msg | 1 + messages/uniworx/utils/table_column/en-eu.msg | 1 + src/Database/Esqueleto/Utils.hs | 4 +-- src/Handler/Firm.hs | 8 +++-- src/Handler/Utils/Table/Columns.hs | 29 ++++++++++++------- templates/i18n/firm-all/de-de-formal.hamlet | 4 +-- 6 files changed, 30 insertions(+), 17 deletions(-) diff --git a/messages/uniworx/utils/table_column/de-de-formal.msg b/messages/uniworx/utils/table_column/de-de-formal.msg index 579e8ddf0..295648b7e 100644 --- a/messages/uniworx/utils/table_column/de-de-formal.msg +++ b/messages/uniworx/utils/table_column/de-de-formal.msg @@ -103,4 +103,5 @@ ActJobDelete: Job entfernen TableJobActDeleteFeedback n@Int m@Int: #{n}/#{m} Jobs entfernt TableFilterComma: Es können mehrere alternative Suchkriterien mit Komma getrennt angegeben werden, wovon mindestens eines erfüllt werden muss. TableFilterCommaPlus: Mehrere alternative Suchkriterien mit Komma trennen. Mindestens ein Suchkriterium muss erfüllt werden, zusätzlich zu allen Suchkriterien mit vorangestelltem Plus-Symbol. +TableFilterCommaName: Mehrere Namen mit Komma trennen. TableFilterCommaNameNr: Mehrere Namen oder Nummern mit Komma trennen. Nummern werden nur exakt gesucht. \ No newline at end of file diff --git a/messages/uniworx/utils/table_column/en-eu.msg b/messages/uniworx/utils/table_column/en-eu.msg index b441ea783..5839e332c 100644 --- a/messages/uniworx/utils/table_column/en-eu.msg +++ b/messages/uniworx/utils/table_column/en-eu.msg @@ -103,4 +103,5 @@ ActJobDelete: Delete job TableJobActDeleteFeedback n@Int m@Int: #{n}/#{m} queued jobs deleted TableFilterComma: Separate multiple alternative filter criteria by comma, at least one of which must be fulfilled. TableFilterCommaPlus: Separate multiple alternative filter criteria by comma, at least one of which must be fulfilled in addition to all criteria preceded by a plus symbol. +TableFilterCommaName: Separate names by comma. TableFilterCommaNameNr: Separate names and numbers by comma. Numbers have to match exact. \ No newline at end of file diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index 060a4df98..3cba53920 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -287,14 +287,14 @@ mkExactFilterWith cast lenslike row criterias -- | like `mkExactFilterWith` but splits comma separared Texts into multiple criteria mkExactFilterWithComma :: (PersistField b) - => (Text -> b) -- ^ type conversion + => (Text -> Maybe b) -- ^ type conversion -> (t -> E.SqlExpr (E.Value b)) -- ^ getter from query to searched element -> t -- ^ query row -> Set.Set Text -- ^ needle collection -> E.SqlExpr (E.Value Bool) mkExactFilterWithComma cast lenslike row (foldMap commaSeparatedText -> criterias) | Set.null criterias = true - | otherwise = lenslike row `E.in_` E.valList (cast <$> Set.toList criterias) + | otherwise = lenslike row `E.in_` E.valList (mapMaybe cast $ Set.toList criterias) -- | generic filter creation for dbTable -- Given a lens-like function, make filter for exact matches against last element of a collection diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 4fcad5788..a41699946 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -293,7 +293,8 @@ mkFirmAllTable isAdmin uid = do ] dbtFilter = mconcat [ single $ fltrCompanyNameNr queryAllCompany - , single ("is-supervisor", FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do + , single ("company-number", FilterColumn $ E.mkExactFilterWithComma readMay (queryAllCompany >>> (E.^. CompanyAvsId))) + , 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) @@ -305,8 +306,9 @@ mkFirmAllTable isAdmin uid = do ) ] dbtFilterUI mPrev = mconcat - [ fltrCompanyNameNrUI mPrev - , prismAForm (singletonFilter "is-supervisor") mPrev $ aopt textField (fslI MsgTableSupervisor) + [ fltrCompanyNameUI mPrev + , prismAForm (singletonFilter "company-number") mPrev $ aopt textField (fslI MsgTableCompanyNo) + , prismAForm (singletonFilter "is-supervisor") mPrev $ aopt textField (fslI MsgTableSupervisor) ] dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } acts :: Map FirmAllAction (AForm Handler FirmAllActionData) diff --git a/src/Handler/Utils/Table/Columns.hs b/src/Handler/Utils/Table/Columns.hs index ce4147b03..6184d1314 100644 --- a/src/Handler/Utils/Table/Columns.hs +++ b/src/Handler/Utils/Table/Columns.hs @@ -753,16 +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 --- [ mkContainsFilterWithComma CI.mk $ query >>> (E.^. CompanyName) --- , mkContainsFilterWithComma CI.mk $ query >>> (E.^. CompanyShorthand) --- , mkExactFilterWithComma id $ query >>> (E.num2text . (E.^. CompanyAvsId)) --- ] --- ) +-- | Search companies by name or shorthand +fltrCompanyName :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)), IsString d) + => (a -> E.SqlExpr (Entity Company)) + -> (d, FilterColumn t fs) +fltrCompanyName query = ( "company-name", FilterColumn $ anyFilter + [ mkContainsFilterWithComma CI.mk $ query >>> (E.^. CompanyName) + , mkContainsFilterWithComma CI.mk $ query >>> (E.^. CompanyShorthand) + -- , mkExactFilterWithComma id $ query >>> (E.num2text . (E.^. CompanyAvsId)) + ] + ) + +fltrCompanyNameUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text]) +fltrCompanyNameUI = fltrCompanyNameNrHdrUI MsgTableCompany + +fltrCompanyNameHdrUI :: (RenderMessage UniWorX msg) => msg -> Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text]) +fltrCompanyNameHdrUI msg mPrev = + prismAForm (singletonFilter "company-name") mPrev $ aopt textField (fslI msg & setTooltip MsgTableFilterCommaNameNr) + + fltrCompanyNameNr :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)), IsString d) => (a -> E.SqlExpr (Entity Company)) diff --git a/templates/i18n/firm-all/de-de-formal.hamlet b/templates/i18n/firm-all/de-de-formal.hamlet index 49ab8a1d5..2f8893fea 100644 --- a/templates/i18n/firm-all/de-de-formal.hamlet +++ b/templates/i18n/firm-all/de-de-formal.hamlet @@ -8,8 +8,8 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later

                                - Die Daten der Firmen wurden aus dem Ausweisverwaltungssystem (AVS) der Fraport AG - importiert und werden regelmäßig aktualisiert, + Die Daten der Firmen wurden aus dem Ausweisverwaltungssystem (AVS) der Fraport AG # + importiert und werden regelmäßig aktualisiert, # wenn Fahrlizenzinhaber oder deren Verwalter über das AVS einer Firma zugeordnet wurden.

                                ^{firmTable} From ef0d71e19e1a754a6e5b46a0c64c8f63bbc48bb7 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 30 Oct 2023 18:01:12 +0100 Subject: [PATCH 25/50] chore(firm): add filter for foreign supervisors --- messages/uniworx/categories/firm/de-de-formal.msg | 1 + messages/uniworx/categories/firm/en-eu.msg | 3 ++- src/Handler/Firm.hs | 14 ++++++++++++++ 3 files changed, 17 insertions(+), 1 deletion(-) diff --git a/messages/uniworx/categories/firm/de-de-formal.msg b/messages/uniworx/categories/firm/de-de-formal.msg index 786e57dd6..57f5ddecf 100644 --- a/messages/uniworx/categories/firm/de-de-formal.msg +++ b/messages/uniworx/categories/firm/de-de-formal.msg @@ -8,3 +8,4 @@ FirmUserActNotify: Mitteilung versenden FirmUserActMkSuper: Zum Firmenansprechpartner ernennen FilterSupervisor: Hat aktiven Ansprechpartner FilterSupervisorCompany fsh@CompanyShorthand: Hat aktiven Ansprechpartner, der #{fsh} angehört +FilterSupervisorForeign fsh@CompanyShorthand: Hat aktiven Ansprechpartner, der selbst nicht #{fsh} angehört diff --git a/messages/uniworx/categories/firm/en-eu.msg b/messages/uniworx/categories/firm/en-eu.msg index a9e105cc3..9cabba5e9 100644 --- a/messages/uniworx/categories/firm/en-eu.msg +++ b/messages/uniworx/categories/firm/en-eu.msg @@ -7,4 +7,5 @@ FirmAllActResetSupervision: Reset supervisors for all company associates FirmUserActNotify: Send message FirmUserActMkSuper: Mark as company supervisor FilterSupervisor: Has active supervisor -FilterSupervisorCompany fsh: Has active company supervisor belonging to #{fsh} \ No newline at end of file +FilterSupervisorCompany fsh: Has active company supervisor belonging to #{fsh} +FilterSupervisorForeign fsh: Has active supervisor not belonging to #{fsh} \ No newline at end of file diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index a41699946..bf24fedb1 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -470,11 +470,25 @@ mkFirmUserTable isAdmin cid = do Nothing -> E.true Just True -> E.exists checkSuper Just False -> E.notExists checkSuper + , singletonMap "has-foreign-supervisor" $ FilterColumn $ \row (getLast -> criterion) -> + let checkSuper = do + usrSpr <- E.from $ E.table @UserSupervisor + E.where_ $ usrSpr E.^. UserSupervisorUser E.==. queryUserUser row E.^. UserId + E.&&. E.notExists (do + spr <- E.from $ E.table @UserCompany + E.where_ $ spr E.^. UserCompanyCompany E.==. E.val cid + E.&&. spr E.^. UserCompanyUser E.==. usrSpr E.^. UserSupervisorSupervisor + ) + in case criterion of + Nothing -> E.true + Just True -> E.exists checkSuper + Just False -> E.notExists checkSuper ] dbtFilterUI mPrev = mconcat [ fltrUserNameEmailHdrUI MsgTableCompanyUser mPrev , prismAForm (singletonFilter "has-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterSupervisor) , prismAForm (singletonFilter "has-company-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI $ MsgFilterSupervisorCompany fsh) + , prismAForm (singletonFilter "has-foreign-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI $ MsgFilterSupervisorForeign fsh) ] dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } acts :: Map FirmUserAction (AForm Handler FirmUserActionData) From bb7b7cf3dcf3602f25d2ced7ad1c483bec51200b Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 31 Oct 2023 17:06:56 +0100 Subject: [PATCH 26/50] chore(firm): add filters for firm postal address and foreign supervisors --- .../uniworx/categories/firm/de-de-formal.msg | 6 ++ messages/uniworx/categories/firm/en-eu.msg | 8 ++- models/company.model | 3 +- src/Handler/Firm.hs | 52 ++++++++++++---- templates/firm-users.hamlet | 60 +++++++++++++++++++ test/Database/Fill.hs | 2 +- 6 files changed, 116 insertions(+), 15 deletions(-) create mode 100644 templates/firm-users.hamlet diff --git a/messages/uniworx/categories/firm/de-de-formal.msg b/messages/uniworx/categories/firm/de-de-formal.msg index 57f5ddecf..9bef83c31 100644 --- a/messages/uniworx/categories/firm/de-de-formal.msg +++ b/messages/uniworx/categories/firm/de-de-formal.msg @@ -2,6 +2,10 @@ # # SPDX-License-Identifier: AGPL-3.0-or-later +FirmAssociates: Firmenangehörige, ohne externe Ansprechpartner +FirmEmail: Allgemeine Email +FirmAddress: Postanschrift +FirmDefaultPostalPreferenceInfo: Hinweis: Dies ist lediglich die Voreinstellung für neue Firmenangehörige FirmAllActNotify: Mitteilung versenden FirmAllActResetSupervision: Ansprechpartner für alle Firmenangehörigen zurücksetzen FirmUserActNotify: Mitteilung versenden @@ -9,3 +13,5 @@ FirmUserActMkSuper: Zum Firmenansprechpartner ernennen FilterSupervisor: Hat aktiven Ansprechpartner FilterSupervisorCompany fsh@CompanyShorthand: Hat aktiven Ansprechpartner, der #{fsh} angehört FilterSupervisorForeign fsh@CompanyShorthand: Hat aktiven Ansprechpartner, der selbst nicht #{fsh} angehört +FilterForeignSupervisor: Hat firmenfremde Ansprechpartner +FilterFirmPostalAddress: Postalische Firmenadresse vorhanden \ No newline at end of file diff --git a/messages/uniworx/categories/firm/en-eu.msg b/messages/uniworx/categories/firm/en-eu.msg index 9cabba5e9..71652d37e 100644 --- a/messages/uniworx/categories/firm/en-eu.msg +++ b/messages/uniworx/categories/firm/en-eu.msg @@ -2,10 +2,16 @@ # # SPDX-License-Identifier: AGPL-3.0-or-later +FirmAssociates: Company associated users, excluding foreign supervisors +FirmEmail: General company email +FirmAddress: Postal address +FirmDefaultPostalPreferenceInfo: Note that this is only the default setting for new company associates FirmAllActNotify: Send message FirmAllActResetSupervision: Reset supervisors for all company associates FirmUserActNotify: Send message FirmUserActMkSuper: Mark as company supervisor FilterSupervisor: Has active supervisor FilterSupervisorCompany fsh: Has active company supervisor belonging to #{fsh} -FilterSupervisorForeign fsh: Has active supervisor not belonging to #{fsh} \ No newline at end of file +FilterSupervisorForeign fsh: Has active supervisor not belonging to #{fsh} +FilterForeignSupervisor: Has company-external supervisors +FilterFirmPostalAddress: Postal company addresse known \ No newline at end of file diff --git a/models/company.model b/models/company.model index 5443b64b0..c022ad5f1 100644 --- a/models/company.model +++ b/models/company.model @@ -9,7 +9,8 @@ Company shorthand CompanyShorthand -- == (CI Text) and CompanyKey :: CompanyShorthand -> CompanyId FUTURE TODO: a shorthand will become available through the AVS interface in the future avsId Int default=0 -- primary key from avs prefersPostal Bool default=false -- new company users prefers letters by post instead of email - postAddress StoredMarkup Maybe -- default company postal address + postAddress StoredMarkup Maybe -- default company postal address + email UserEmail Maybe -- Case-insensitive generic company eMail address UniqueCompanyName name UniqueCompanyShorthand shorthand -- UniqueCompanyAvsId avsId -- should be the case, unclear if enforcing works here, since we cannot query avs by company id diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index bf24fedb1..d910c4ea9 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -304,11 +304,31 @@ mkFirmAllTable isAdmin uid = do E.||. (usr E.^. UserSurname `E.hasInfix` E.val criterion) ) ) + , single ("foreign-supervisor", FilterColumn $ \row (getLast -> criterion) -> + let checkSuper = do + usrSpr <- E.from $ E.table @UserSupervisor + E.where_ $ E.notExists (do + spr <- E.from $ E.table @UserCompany + E.where_ $ spr E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId + E.&&. spr E.^. UserCompanyUser E.==. usrSpr E.^. UserSupervisorSupervisor + ) E.&&. E.exists (do + usr <- E.from $ E.table @UserCompany + E.where_ $ usr E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId + E.&&. usr E.^. UserCompanyUser E.==. usrSpr E.^. UserSupervisorUser + ) + in case criterion of + Nothing -> E.true + Just True -> E.exists checkSuper + Just False -> E.notExists checkSuper + ) + , single ("company-postal", FilterColumn $ E.mkExactFilterLast $ views (to queryAllCompany) (E.isJust . (E.^. CompanyPostAddress))) ] dbtFilterUI mPrev = mconcat [ fltrCompanyNameUI mPrev - , prismAForm (singletonFilter "company-number") mPrev $ aopt textField (fslI MsgTableCompanyNo) - , prismAForm (singletonFilter "is-supervisor") mPrev $ aopt textField (fslI MsgTableSupervisor) + , prismAForm (singletonFilter "company-number") mPrev $ aopt textField (fslI MsgTableCompanyNo) + , prismAForm (singletonFilter "is-supervisor") mPrev $ aopt textField (fslI MsgTableSupervisor) + , prismAForm (singletonFilter "foreign-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterForeignSupervisor) + , prismAForm (singletonFilter "company-postal" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterFirmPostalAddress) ] dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } acts :: Map FirmAllAction (AForm Handler FirmAllActionData) @@ -541,18 +561,26 @@ postFirmUsersR fsh = do siteLayout (citext2widget companyName) $ do setTitle $ toHtml $ CI.original companyShorthand <> " (" <> tshow companyAvsId <> ")" [whamlet| -

                                -

                                - #{companyPostAddress} -

                                - Benachrichtigungs-Voreinstellung für neue Firmangehörige: # - $if companyPrefersPostal - #{icon IconLetter} Briefversand - $else - #{icon IconAt} Email +

                                +
                                +
                                + _{MsgPrefersPostal} +
                                + #{iconLetterOrEmail companyPrefersPostal} # + _{MsgFirmDefaultPostalPreferenceInfo} + $maybe fem <- companyEmail +
                                + #{iconLetterOrEmail False} _{MsgFirmEmail} +
                                + #{mailToHtml fem} + $maybe addr <- companyPostAddress +
                                + #{iconLetterOrEmail True} _{MsgFirmEmail} +
                                + #{addr}

                                - Company associated users, excluding foreign supervisors + _{MsgFirmAssociates}

                                ^{fusrTable} |] diff --git a/templates/firm-users.hamlet b/templates/firm-users.hamlet new file mode 100644 index 000000000..60ffd4d92 --- /dev/null +++ b/templates/firm-users.hamlet @@ -0,0 +1,60 @@ +$newline never + +$# SPDX-FileCopyrightText: 2022 Steffen Jost +$# +$# SPDX-License-Identifier: AGPL-3.0-or-later + +

                                +

                                + _{MsgProblemsHeadingDrivers} + +
                                +
                                ^{flagError driversHaveAvsIds} +
                                ^{simpleLinkI MsgProblemsDriversHaveAvsIds ProblemWithoutAvsId} + + $case diffLics + $of Left err +
                                ^{flagError False} +
                                ^{modal (i18n MsgProblemsAvsProblem) (Right err)} + + $of Right (ok0,ok1up,ok1down,ok2) +
                                ^{flagNonZero ok2} +
                                ^{simpleLinkI MsgProblemsDriverSynch2 ProblemAvsSynchR} + +
                                ^{flagNonZero ok1down} +
                                ^{simpleLinkI MsgProblemsDriverSynch1down ProblemAvsSynchR} + +
                                ^{flagNonZero ok1up} +
                                ^{simpleLinkI MsgProblemsDriverSynch1up ProblemAvsSynchR} + +
                                ^{flagNonZero ok0} +
                                ^{simpleLinkI MsgProblemsDriverSynch0 ProblemAvsSynchR} + +
                                ^{flagWarning rDriversHaveFs} +
                                ^{simpleLinkI MsgProblemsRDriversHaveFs ProblemFbutNoR} + + +
                                +

                                + _{MsgProblemsHeadingNotifications} + +
                                +
                                ^{flagError usersAreReachable} +
                                ^{simpleLinkI MsgProblemsUsersAreReachable ProblemUnreachableR} + +
                                ^{flagError noStalePrintJobs} +
                                ^{simpleLinkI (MsgProblemsNoStalePrintJobs cutOffPrintDays) PrintCenterR} + +
                                ^{flagError noBadAPCids} +
                                _{MsgProblemsNoBadAPCIds} + + $maybe reroute <- rerouteMail +
                                ^{flagWarning False} +
                                _{MsgMailRerouteTo reroute} + +
                                +

                                + _{MsgProblemsHeadingMisc} +
                                +
                                ^{flagError noAvsSynchProblems} +
                                ^{simpleLinkI MsgProblemsNoAvsSynchProblems ProblemAvsErrorR} diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index 2343751ff..850074cea 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -660,7 +660,7 @@ fillDb = do , UserSupervisor gkleen gkleen True , UserSupervisor tinaTester tinaTester False ] - ++ take 333 [ UserSupervisor fhamann uid True | Entity uid _ <- matUsers ] + ++ take 333 [ UserSupervisor fhamann uid True | Entity uid _ <- matUsers, uid /= jost] ++ take 111 [ UserSupervisor gkleen uid True | Entity uid _ <- drop 300 matUsers ] ++ take 11 [ UserSupervisor jost uid False | Entity uid _ <- drop 401 matUsers ] upsertManyWhere supvs [] [] [] From ce7597238daa47957060c7ae2f8254cc58440330 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 31 Oct 2023 17:14:14 +0100 Subject: [PATCH 27/50] fix build --- .../uniworx/categories/firm/de-de-formal.msg | 2 +- messages/uniworx/categories/firm/en-eu.msg | 2 +- src/Handler/Firm.hs | 25 +------ src/Handler/Utils/Company.hs | 4 +- templates/firm-users.hamlet | 75 ++++++------------- test/Database/Fill.hs | 11 +-- 6 files changed, 33 insertions(+), 86 deletions(-) diff --git a/messages/uniworx/categories/firm/de-de-formal.msg b/messages/uniworx/categories/firm/de-de-formal.msg index 9bef83c31..5872e4271 100644 --- a/messages/uniworx/categories/firm/de-de-formal.msg +++ b/messages/uniworx/categories/firm/de-de-formal.msg @@ -5,7 +5,7 @@ FirmAssociates: Firmenangehörige, ohne externe Ansprechpartner FirmEmail: Allgemeine Email FirmAddress: Postanschrift -FirmDefaultPostalPreferenceInfo: Hinweis: Dies ist lediglich die Voreinstellung für neue Firmenangehörige +FirmDefaultPostalPreferenceInfo: Diese Voreinstellung gilt nur für neue Firmenangehörige FirmAllActNotify: Mitteilung versenden FirmAllActResetSupervision: Ansprechpartner für alle Firmenangehörigen zurücksetzen FirmUserActNotify: Mitteilung versenden diff --git a/messages/uniworx/categories/firm/en-eu.msg b/messages/uniworx/categories/firm/en-eu.msg index 71652d37e..164526d1f 100644 --- a/messages/uniworx/categories/firm/en-eu.msg +++ b/messages/uniworx/categories/firm/en-eu.msg @@ -5,7 +5,7 @@ FirmAssociates: Company associated users, excluding foreign supervisors FirmEmail: General company email FirmAddress: Postal address -FirmDefaultPostalPreferenceInfo: Note that this is only the default setting for new company associates +FirmDefaultPostalPreferenceInfo: Default setting for new company associates only. FirmAllActNotify: Send message FirmAllActResetSupervision: Reset supervisors for all company associates FirmUserActNotify: Send message diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index d910c4ea9..998d1edf8 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -560,30 +560,7 @@ postFirmUsersR fsh = do (FirmUserActMkSuperData, fids) -> addMessage Info $ text2Html $ "Make " <> tshow (length fids) <> " employees to supervisors. TODO" siteLayout (citext2widget companyName) $ do setTitle $ toHtml $ CI.original companyShorthand <> " (" <> tshow companyAvsId <> ")" - [whamlet| -
                                -
                                -
                                - _{MsgPrefersPostal} -
                                - #{iconLetterOrEmail companyPrefersPostal} # - _{MsgFirmDefaultPostalPreferenceInfo} - $maybe fem <- companyEmail -
                                - #{iconLetterOrEmail False} _{MsgFirmEmail} -
                                - #{mailToHtml fem} - $maybe addr <- companyPostAddress -
                                - #{iconLetterOrEmail True} _{MsgFirmEmail} -
                                - #{addr} -
                                -

                                - _{MsgFirmAssociates} -

                                - ^{fusrTable} - |] + $(widgetFile "firm-users") ----------------------------- diff --git a/src/Handler/Utils/Company.hs b/src/Handler/Utils/Company.hs index 1b8b9dafa..440f6c8fa 100644 --- a/src/Handler/Utils/Company.hs +++ b/src/Handler/Utils/Company.hs @@ -40,14 +40,14 @@ upsertCompany cName cAddr = Nothing -> do let cShort = companyShorthandFromName cName cShort' <- findShort cName' $ CI.mk cShort - let compy = Company cName' cShort' 0 False cAddr -- TODO: Fix this once AVS CR3 SCF-165 is implemented + let compy = Company cName' cShort' 0 False cAddr Nothing -- TODO: Fix this once AVS CR3 SCF-165 is implemented either entityKey id <$> insertBy compy where findShort :: CompanyName -> CompanyShorthand -> DB CompanyShorthand findShort fna fsh = aux 0 where aux n = let fsh' = if n==0 then fsh else fsh <> CI.mk (tshow n) in - checkUnique (Company fna fsh' 0 False Nothing) >>= \case + checkUnique (Company fna fsh' 0 False Nothing Nothing) >>= \case Nothing -> return fsh' _other -> aux (n+1) diff --git a/templates/firm-users.hamlet b/templates/firm-users.hamlet index 60ffd4d92..fcddb64b0 100644 --- a/templates/firm-users.hamlet +++ b/templates/firm-users.hamlet @@ -1,60 +1,29 @@ $newline never -$# SPDX-FileCopyrightText: 2022 Steffen Jost +$# SPDX-FileCopyrightText: 2023 Steffen Jost $# $# SPDX-License-Identifier: AGPL-3.0-or-later +

                                +
                                +
                                + _{MsgPrefersPostal} +
                                + #{iconLetterOrEmail companyPrefersPostal} # + _{MsgFirmDefaultPostalPreferenceInfo} + $maybe fem <- companyEmail +
                                + _{MsgFirmEmail} #{iconLetterOrEmail False} +
                                + #{mailtoHtml fem} + $maybe addr <- companyPostAddress +
                                + _{MsgFirmAddress} #{iconLetterOrEmail True} +
                                + #{addr} +

                                - _{MsgProblemsHeadingDrivers} - -
                                -
                                ^{flagError driversHaveAvsIds} -
                                ^{simpleLinkI MsgProblemsDriversHaveAvsIds ProblemWithoutAvsId} - - $case diffLics - $of Left err -
                                ^{flagError False} -
                                ^{modal (i18n MsgProblemsAvsProblem) (Right err)} - - $of Right (ok0,ok1up,ok1down,ok2) -
                                ^{flagNonZero ok2} -
                                ^{simpleLinkI MsgProblemsDriverSynch2 ProblemAvsSynchR} - -
                                ^{flagNonZero ok1down} -
                                ^{simpleLinkI MsgProblemsDriverSynch1down ProblemAvsSynchR} - -
                                ^{flagNonZero ok1up} -
                                ^{simpleLinkI MsgProblemsDriverSynch1up ProblemAvsSynchR} - -
                                ^{flagNonZero ok0} -
                                ^{simpleLinkI MsgProblemsDriverSynch0 ProblemAvsSynchR} - -
                                ^{flagWarning rDriversHaveFs} -
                                ^{simpleLinkI MsgProblemsRDriversHaveFs ProblemFbutNoR} - - -
                                -

                                - _{MsgProblemsHeadingNotifications} - -
                                -
                                ^{flagError usersAreReachable} -
                                ^{simpleLinkI MsgProblemsUsersAreReachable ProblemUnreachableR} - -
                                ^{flagError noStalePrintJobs} -
                                ^{simpleLinkI (MsgProblemsNoStalePrintJobs cutOffPrintDays) PrintCenterR} - -
                                ^{flagError noBadAPCids} -
                                _{MsgProblemsNoBadAPCIds} - - $maybe reroute <- rerouteMail -
                                ^{flagWarning False} -
                                _{MsgMailRerouteTo reroute} - -
                                -

                                - _{MsgProblemsHeadingMisc} -
                                -
                                ^{flagError noAvsSynchProblems} -
                                ^{simpleLinkI MsgProblemsNoAvsSynchProblems ProblemAvsErrorR} + _{MsgFirmAssociates} +

                                + ^{fusrTable} \ No newline at end of file diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index 850074cea..9e1b9cea6 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -624,11 +624,12 @@ fillDb = do I am aware that violations in the form plagiarism or collaboration with third parties will lead to expulsion from the course. |] } - fraportAg <- insert' $ Company "Fraport AG" "Fraport" 1 True $ Just $ markdownToStoredMarkup ("Frankfurt Airport Services Worldwide\n60547 Frankfurt am Main"::Text) - fraGround <- insert' $ Company "Fraport Ground Handling Professionals GmbH" "FraGround" 2 True $ Just $ markdownToStoredMarkup ("Sauerbierstraße 772 \nBürokomplex 80/C/1\n112233 Nieder-Tupfing-Hohen-Kreisingen\nTöpferbezirk"::Text) - nice <- insert' $ Company "N*ICE Aircraft Services & Support GmbH" "N*ICE" 33 False $ Just $ markdownToStoredMarkup ("69 Nevermore Blvd.\nHarlaemn\nNew York\nUSA"::Text) - ffacil <- insert' $ Company "Fraport Facility Services GmbH" "GCS" 44 False Nothing - bpol <- insert' $ Company "Bundespolizeidirektion Flughafen Frankfurt am Main" "BPol" 5555 False Nothing + fraportAg <- insert' $ Company "Fraport AG" "Fraport" 1 True (Just $ markdownToStoredMarkup ("Frankfurt Airport Services Worldwide\n60547 Frankfurt am Main"::Text)) (Just "fraport@fraport.de") + fraGround <- insert' $ Company "Fraport Ground Handling Professionals GmbH" "FraGround" 2 True (Just $ markdownToStoredMarkup ("Sauerbierstraße 772 \nBürokomplex 80/C/1\n112233 Nieder-Tupfing-Hohen-Kreisingen\nTöpferbezirk"::Text)) Nothing + nice <- insert' $ Company "N*ICE Aircraft Services & Support GmbH" "N*ICE" 33 False (Just $ markdownToStoredMarkup ("69 Nevermore Blvd.\nHarlaemn\nNew York\nUSA"::Text)) (Just "badguy@nice.com") + ffacil <- insert' $ Company "Fraport Facility Services GmbH" "GCS" 44 False Nothing $ Just "gcs@gcs.com" + bpol <- insert' $ Company "Bundespolizeidirektion Flughafen Frankfurt am Main" "BPol" 5555 False Nothing Nothing + _noone <- insert' $ Company "Vollautomaten GmbH" "NoOne" 3 True Nothing Nothing void . insert' $ UserCompany jost fraportAg True True void . insert' $ UserCompany svaupel nice True False void . insert' $ UserCompany gkleen nice False False From a42e8a88f0a47463d42ddde43c3d3b898d5378b2 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 2 Nov 2023 18:54:39 +0100 Subject: [PATCH 28/50] chore(company): prune company all overview, extend individual company view --- .../uniworx/categories/firm/de-de-formal.msg | 4 +- messages/uniworx/categories/firm/en-eu.msg | 4 +- src/Handler/Firm.hs | 120 ++++++++++-------- templates/firm-users.hamlet | 55 +++++++- templates/i18n/firm-all/de-de-formal.hamlet | 28 ---- templates/i18n/firm-all/en-eu.hamlet | 28 ---- 6 files changed, 118 insertions(+), 121 deletions(-) diff --git a/messages/uniworx/categories/firm/de-de-formal.msg b/messages/uniworx/categories/firm/de-de-formal.msg index 5872e4271..024efc05f 100644 --- a/messages/uniworx/categories/firm/de-de-formal.msg +++ b/messages/uniworx/categories/firm/de-de-formal.msg @@ -2,10 +2,10 @@ # # SPDX-License-Identifier: AGPL-3.0-or-later -FirmAssociates: Firmenangehörige, ohne externe Ansprechpartner +FirmAssociates: Firmenangehörige FirmEmail: Allgemeine Email FirmAddress: Postanschrift -FirmDefaultPostalPreferenceInfo: Diese Voreinstellung gilt nur für neue Firmenangehörige +FirmDefaultPreferenceInfo: Diese Voreinstellungen gelten nur für neue Firmenangehörige FirmAllActNotify: Mitteilung versenden FirmAllActResetSupervision: Ansprechpartner für alle Firmenangehörigen zurücksetzen FirmUserActNotify: Mitteilung versenden diff --git a/messages/uniworx/categories/firm/en-eu.msg b/messages/uniworx/categories/firm/en-eu.msg index 164526d1f..869cc617a 100644 --- a/messages/uniworx/categories/firm/en-eu.msg +++ b/messages/uniworx/categories/firm/en-eu.msg @@ -2,10 +2,10 @@ # # SPDX-License-Identifier: AGPL-3.0-or-later -FirmAssociates: Company associated users, excluding foreign supervisors +FirmAssociates: Company associated users FirmEmail: General company email FirmAddress: Postal address -FirmDefaultPostalPreferenceInfo: Default setting for new company associates only. +FirmDefaultPreferenceInfo: Default setting for new company associates only FirmAllActNotify: Send message FirmAllActResetSupervision: Reset supervisors for all company associates FirmUserActNotify: Send message diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 998d1edf8..39c1840bd 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -115,7 +115,7 @@ type AllCompanyTableExpr = E.SqlExpr (Entity Company) queryAllCompany :: AllCompanyTableExpr -> E.SqlExpr (Entity Company) queryAllCompany = id -type AllCompanyTableData = DBRow (Entity Company, E.Value Word64, E.Value Word64, E.Value Word64, 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 Bool, E.Value Bool) resultAllCompanyEntity :: Lens' AllCompanyTableData (Entity Company) resultAllCompanyEntity = _dbrOutput . _1 @@ -125,29 +125,12 @@ resultAllCompany = resultAllCompanyEntity . _entityVal resultAllCompanyUsers :: Lens' AllCompanyTableData Word64 resultAllCompanyUsers = _dbrOutput . _2 . _unValue -resultAllCompanySupervisors :: Lens' AllCompanyTableData Word64 +resultAllCompanySupervisors :: Lens' AllCompanyTableData Bool resultAllCompanySupervisors = _dbrOutput . _3 . _unValue -resultAllCompanyEmployeeSupervised :: Lens' AllCompanyTableData Word64 -resultAllCompanyEmployeeSupervised = _dbrOutput . _4 . _unValue +resultAllCompanyDefaultReroutes :: Lens' AllCompanyTableData Bool +resultAllCompanyDefaultReroutes = _dbrOutput . _4 . _unValue -resultAllCompanyEmployeeRerouted :: Lens' AllCompanyTableData Word64 -resultAllCompanyEmployeeRerouted = _dbrOutput . _5 . _unValue - -resultAllCompanyEmpRerPost :: Lens' AllCompanyTableData Word64 -resultAllCompanyEmpRerPost = _dbrOutput . _6 . _unValue - -resultAllCompanyForeignSupers :: Lens' AllCompanyTableData Word64 -resultAllCompanyForeignSupers = _dbrOutput . _7 . _unValue - -resultAllCompanyDefaultReroutes :: Lens' AllCompanyTableData Word64 -resultAllCompanyDefaultReroutes = _dbrOutput . _8 . _unValue - -resultAllCompanyActiveReroutes :: Lens' AllCompanyTableData Word64 -resultAllCompanyActiveReroutes = _dbrOutput . _9 . _unValue - -resultAllCompanyActiveReroutes' :: Lens' AllCompanyTableData Word64 -resultAllCompanyActiveReroutes' = _dbrOutput . _10 . _unValue fromUserCompany :: Maybe (E.SqlExpr (Entity UserCompany) -> E.SqlExpr (E.Value Bool)) -> E.SqlExpr (Entity Company) -> E.SqlQuery () fromUserCompany mbFltr cmpy = do @@ -167,9 +150,16 @@ firmCountSupervisors = E.subSelectCount . fromUserCompany (Just (E.^. UserCompa -- E.&&. (usrCmpy E.^. UserCompanySupervisor E.==. E.true) -- return $ usrCmpy E.^. UserCompanyUser +firmHasSupervisors :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Bool) +firmHasSupervisors = E.exists . fromUserCompany (Just (E.^. UserCompanySupervisor)) + + firmCountDefaultReroutes :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) firmCountDefaultReroutes = E.subSelectCount . fromUserCompany (Just (\uc -> uc E.^. UserCompanySupervisor E.&&. uc E.^. UserCompanySupervisorReroute)) +firmHasDefaultReroutes :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Bool) +firmHasDefaultReroutes = E.exists . fromUserCompany (Just (\uc -> uc E.^. UserCompanySupervisor E.&&. uc E.^. UserCompanySupervisorReroute)) + firmCountEmployeeSupervised :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) firmCountEmployeeSupervised = E.subSelectCount . fromUserCompany (Just fltr) where @@ -217,15 +207,15 @@ firmCountForeignSupervisors cmpy = E.subSelectCountDistinct $ do E.&&. E.notExists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorSupervisor) cmpy) pure $ usrSuper E.^. UserSupervisorSupervisor -firmCountActiveReroutes :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) -firmCountActiveReroutes cmpy = E.subSelectCountDistinct $ do - usrSuper <- E.from $ E.table @UserSupervisor - E.where_ $ E.exists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorUser) cmpy) - E.&&. usrSuper E.^. UserSupervisorRerouteNotifications - pure $ usrSuper E.^. UserSupervisorSupervisor +-- firmCountActiveReroutes :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) +-- firmCountActiveReroutes cmpy = E.subSelectCountDistinct $ do +-- usrSuper <- E.from $ E.table @UserSupervisor +-- E.where_ $ E.exists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorUser) cmpy) +-- E.&&. usrSuper E.^. UserSupervisorRerouteNotifications +-- pure $ usrSuper E.^. UserSupervisorSupervisor -firmCountActiveReroutes' :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) -firmCountActiveReroutes' cmpy = E.subSelectCount $ do +firmCountActiveReroutes :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) +firmCountActiveReroutes cmpy = E.subSelectCount $ do usrSuper <- E.from $ E.table @UserSupervisor E.where_ $ E.exists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorUser) cmpy) E.&&. usrSuper E.^. UserSupervisorRerouteNotifications @@ -244,14 +234,14 @@ mkFirmAllTable isAdmin uid = do E.&&. usrCmpy E.^. UserCompanyUser E.==. E.val uid return ( cmpy -- 1 , cmpy & firmCountUsers -- 2 - , cmpy & firmCountSupervisors -- 3 - , cmpy & firmCountEmployeeSupervised -- 4 - , cmpy & firmCountEmployeeRerouted -- 5 - , cmpy & firmCountEmployeeRerPost -- 6 - , cmpy & firmCountForeignSupervisors -- 7 - , cmpy & firmCountDefaultReroutes -- 8 - , cmpy & firmCountActiveReroutes -- 9 - , cmpy & firmCountActiveReroutes' -- 10 + , cmpy & firmHasSupervisors -- 3 + , cmpy & firmHasDefaultReroutes -- 4 + -- , cmpy & firmCountEmployeeSupervised -- 4 + -- , cmpy & firmCountEmployeeRerouted -- 5 + -- , cmpy & firmCountEmployeeRerPost -- 6 + -- , cmpy & firmCountForeignSupervisors -- 7 + -- , cmpy & firmCountActiveReroutes -- 9 + -- , cmpy & firmCountActiveReroutes' -- 10 ) dbtRowKey = (E.^. CompanyId) dbtProj = dbtProjId @@ -266,14 +256,14 @@ mkFirmAllTable isAdmin uid = do anchorCell (FirmR $ companyShorthand firm) $ toWgt $ companyAvsId firm , sortable (Just "users") (i18nCell MsgTableCompanyNrUsers) $ \(view resultAllCompanyUsers -> nr) -> wgtCell $ word2widget nr , sortable (Just "supervisors") (i18nCell MsgTableCompanyNrSupersDefault) $ \row -> - anchorCell (FirmSupersR $ row ^. resultAllCompany . _companyShorthand) $ word2widget $ row ^. resultAllCompanySupervisors - , sortable (Just "reroute-def") (i18nCell MsgTableCompanyNrRerouteDefault) $ \(view resultAllCompanyDefaultReroutes -> nr) -> wgtCell $ word2widget nr - , sortable (Just "emp-supervised")(i18nCell MsgTableCompanyNrEmpSupervised) $ \(view resultAllCompanyEmployeeSupervised -> nr) -> wgtCell $ word2widget nr - , sortable (Just "emp-rerouted") (i18nCell MsgTableCompanyNrEmpRerouted) $ \(view resultAllCompanyEmployeeRerouted -> nr) -> wgtCell $ word2widget nr - , sortable (Just "emp-rer-post") (i18nCell MsgTableCompanyNrEmpRerPost) $ \(view resultAllCompanyEmpRerPost -> nr) -> wgtCell $ word2widget nr - , sortable (Just "foreigners") (i18nCell MsgTableCompanyNrForeignSupers) $ \(view resultAllCompanyForeignSupers -> nr) -> wgtCell $ word2widget nr - , sortable (Just "reroute-act") (i18nCell MsgTableCompanyNrRerouteActive) $ \(view resultAllCompanyActiveReroutes -> nr) -> wgtCell $ word2widget nr - , sortable (Just "reroute-all") (i18nCell MsgTableCompanyNrRerouteActive) $ \(view resultAllCompanyActiveReroutes' -> nr) -> wgtCell $ word2widget nr + anchorCell (FirmSupersR $ row ^. resultAllCompany . _companyShorthand) $ toWgt $ hasTickmark $ row ^. resultAllCompanySupervisors + , sortable (Just "reroute-def") (i18nCell MsgTableCompanyNrRerouteDefault) $ \(view resultAllCompanyDefaultReroutes -> ok) -> tickmarkCell ok + -- , sortable (Just "emp-supervised")(i18nCell MsgTableCompanyNrEmpSupervised) $ \(view resultAllCompanyEmployeeSupervised -> nr) -> wgtCell $ word2widget nr + -- , sortable (Just "emp-rerouted") (i18nCell MsgTableCompanyNrEmpRerouted) $ \(view resultAllCompanyEmployeeRerouted -> nr) -> wgtCell $ word2widget nr + -- , sortable (Just "emp-rer-post") (i18nCell MsgTableCompanyNrEmpRerPost) $ \(view resultAllCompanyEmpRerPost -> nr) -> wgtCell $ word2widget nr + -- , sortable (Just "foreigners") (i18nCell MsgTableCompanyNrForeignSupers) $ \(view resultAllCompanyForeignSupers -> nr) -> wgtCell $ word2widget nr + -- , sortable (Just "reroute-act") (i18nCell MsgTableCompanyNrRerouteActive) $ \(view resultAllCompanyActiveReroutes -> nr) -> wgtCell $ word2widget nr + -- , sortable (Just "reroute-all") (i18nCell MsgTableCompanyNrRerouteActive) $ \(view resultAllCompanyActiveReroutes' -> nr) -> wgtCell $ word2widget nr , sortable (Just "postal-pref") (i18nCell MsgTableCompanyPostalPreference) $ \(view $ resultAllCompany . _companyPrefersPostal -> b) -> iconFixedCell $ iconLetterOrEmail b ] dbtSorting = mconcat @@ -283,13 +273,13 @@ mkFirmAllTable isAdmin uid = do , singletonMap "postal-pref" $ SortColumn (E.^. CompanyPrefersPostal) , singletonMap "users" $ SortColumn firmCountUsers , singletonMap "supervisors" $ SortColumn firmCountSupervisors - , singletonMap "emp-supervised" $ SortColumn firmCountEmployeeSupervised - , singletonMap "emp-rerouted" $ SortColumn firmCountEmployeeRerouted - , singletonMap "emp-rer-post" $ SortColumn firmCountEmployeeRerPost + -- , singletonMap "emp-supervised" $ SortColumn firmCountEmployeeSupervised + -- , singletonMap "emp-rerouted" $ SortColumn firmCountEmployeeRerouted + -- , singletonMap "emp-rer-post" $ SortColumn firmCountEmployeeRerPost , singletonMap "reroute-def" $ SortColumn firmCountDefaultReroutes - , singletonMap "foreigners" $ SortColumn firmCountForeignSupervisors - , singletonMap "reroute-act" $ SortColumn firmCountActiveReroutes - , singletonMap "reroute-all" $ SortColumn firmCountActiveReroutes' + -- , singletonMap "foreigners" $ SortColumn firmCountForeignSupervisors + -- , singletonMap "reroute-act" $ SortColumn firmCountActiveReroutes + -- , singletonMap "reroute-all" $ SortColumn firmCountActiveReroutes' ] dbtFilter = mconcat [ single $ fltrCompanyNameNr queryAllCompany @@ -552,9 +542,31 @@ getFirmUsersR = postFirmUsersR postFirmUsersR fsh = do isAdmin <- hasReadAccessTo AdminR let fshId = CompanyKey fsh - (Company{..}, (fusrRes, fusrTable)) <- runDB $ (,) - <$> get404 fshId - <*> mkFirmUserTable isAdmin fshId + (( Entity{entityVal=Company{..}} + , E.Value nrCompanyUsers + , E.Value nrCompanySupervisors + , E.Value nrCompanyForeignSupers + , E.Value nrCompanyEmployeeSupervised + , E.Value nrCompanyEmployeeRerouted + , E.Value nrCompanyEmployeeRerPost + , E.Value nrCompanyDefaultReroutes + , E.Value nrCompanyActiveReroutes + ) , (fusrRes, fusrTable)) <- runDB $ (,) + <$> fromMaybeM notFound (E.selectOne $ do + cmpy <- E.from $ E.table @Company + E.where_ $ cmpy E.^. CompanyId E.==. E.val fshId + return ( cmpy + , cmpy & firmCountUsers + , cmpy & firmCountSupervisors + , cmpy & firmCountForeignSupervisors + , cmpy & firmCountEmployeeSupervised + , cmpy & firmCountEmployeeRerouted + , cmpy & firmCountEmployeeRerPost + , cmpy & firmCountDefaultReroutes + , cmpy & firmCountActiveReroutes + )) + <*> mkFirmUserTable isAdmin fshId + formResult fusrRes $ \case (FirmUserActNotifyData , fids) -> addMessage Info $ text2Html $ "Notify " <> tshow (length fids) <> " employees. TODO" (FirmUserActMkSuperData, fids) -> addMessage Info $ text2Html $ "Make " <> tshow (length fids) <> " employees to supervisors. TODO" diff --git a/templates/firm-users.hamlet b/templates/firm-users.hamlet index fcddb64b0..f9224bd3a 100644 --- a/templates/firm-users.hamlet +++ b/templates/firm-users.hamlet @@ -4,13 +4,8 @@ $# SPDX-FileCopyrightText: 2023 Steffen Jost $# $# SPDX-License-Identifier: AGPL-3.0-or-later -

                                +
                                -
                                - _{MsgPrefersPostal} -
                                - #{iconLetterOrEmail companyPrefersPostal} # - _{MsgFirmDefaultPostalPreferenceInfo} $maybe fem <- companyEmail
                                _{MsgFirmEmail} #{iconLetterOrEmail False} @@ -21,7 +16,53 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later _{MsgFirmAddress} #{iconLetterOrEmail True}
                                #{addr} - + +
                                +
                                + + + + + + + + +
                                _{MsgTableCompanyNrSupersDefault} + _{MsgTableCompanyNrRerouteDefault} + _{MsgPrefersPostal} + +
                                #{nrCompanySupervisors} + #{nrCompanyDefaultReroutes} + #{iconLetterOrEmail companyPrefersPostal} + _{MsgFirmDefaultPreferenceInfo} +
                                _{MsgTableCompanyNrUsers} + _{MsgTableCompanyNrForeignSupers} +
                                #{nrCompanyUsers} + #{nrCompanyForeignSupers} + + Anzahl der firmenfremden Ansprechpartner, welche mindestens einen Firmenangehörigen betreuen. Bei manchen Firmen ist es normal, dass die Ansprechpartner einer anderen Firma angehören, aber oft ist nur ein Fehler durch Firmenwechsel. + +
                                _{MsgTableCompanyNrEmpSupervised} + _{MsgTableCompanyNrEmpRerouted} + _{MsgTableCompanyNrEmpRerPost} + _{MsgTableCompanyNrRerouteActive} +
                                #{nrCompanyEmployeeSupervised} + #{nrCompanyEmployeeRerouted} + #{nrCompanyEmployeeRerPost} + #{nrCompanyActiveReroutes} +
                                + Anzahl Firmenangehörige, für die derzeit mindestens ein Ansprechpartner eingetragen ist. Ansprechpartner müssen nicht notwendigerweise der gleichen Firma angehören! + + Anzahl Firmenangehörige, für die derzeit mindestens eine Benachrichtigungsumleitung an einen Ansprechpartner eingetragen ist. Ansprechpartner müssen nicht notwendigerweise der gleichen Firma angehören! + + Anzahl Firmenangehörige, für die derzeit mindestens eine Benachrichtigungsumleitung an einen Ansprechpartner eingetragen ist, welcher den Versand per Briefpost bevorzugt. # + Ob ein Ansprechpartner Email oder Briefpost wünscht ist eine individuelle Einstellung des Ansprechpartners und gilt für alle Benachrichtigungen an diesen Ansprechpartner. + + Gesamtzahl aller aktiven Benachrichtigungsumleitungen. # + + Beispiel: Für eine Firma mit 2 Angehörigen, für die ein Mitarbeiter 1 Ansprechpartner mit aktiver Umleitung und einen Mitarbeiter mit 3 Ansprechpartnern mit aktiver Umleitung hätte, # + würde hier die Zahl 4 stehen, da bei einer Benachrichtigung an beide Mitarbeiter insgesamt 4 Briefe oder Emails versendet würden. +

                                _{MsgFirmAssociates} diff --git a/templates/i18n/firm-all/de-de-formal.hamlet b/templates/i18n/firm-all/de-de-formal.hamlet index 2f8893fea..480a6fbe9 100644 --- a/templates/i18n/firm-all/de-de-formal.hamlet +++ b/templates/i18n/firm-all/de-de-formal.hamlet @@ -13,31 +13,3 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later wenn Fahrlizenzinhaber oder deren Verwalter über das AVS einer Firma zugeordnet wurden.

                                ^{firmTable} - -

                                Hinweis zur Entwicklungsversion -

                                - Die Spalten zeigen derzeit folgende Informationen -

                                  -
                                1. Firmenname -
                                2. Firmenkürzel -
                                3. AVS Firmennummer -
                                4. Anzahl der derzeit zugeordneten Firmenangehörigen. Eine Personen kann mehreren Firmen gleichzeitig angehören. -
                                5. Anzahl der Standard Ansprechpartner, welche einer neu in FRADrive eingetragnen Person dieser Firma derzeit zugeordnet werden. Eine Person kann beliebig viele Ansprechpartner haben. Wirkt sich nicht auf vorhandene Firmenangehörige aus. -
                                6. Anzahl der Standard Ansprechpartner der Firma mit Benachrichtigungsumleitung. Hat eine Person mehrere Ansprechpartner mit Umleitung, so wird ein Brief oder Email an alle Ansprechpartner verschickt. # - Ein Person kann auch ihr eigener Ansprechpartner sein, um eine Benachrichtigung sowohl an die Person selbst als auch an einen Ansprechpartner zu senden. # - Wirkt sich nicht auf vorhandene Firmenangehörige aus, sondern nur auf neu in FRADrive hinzukommende Firmenangehörige. -
                                7. Anzahl Firmenangehörige, für die derzeit mindestens ein Ansprechpartner eingetragen ist. Ansprechpartner müssen nicht notwendigerweise der gleichen Firma angehören! -
                                8. Anzahl Firmenangehörige, für die derzeit mindestens eine Benachrichtigungsumleitung an einen Ansprechpartner eingetragen ist. Ansprechpartner müssen nicht notwendigerweise der gleichen Firma angehören! -
                                9. Anzahl Firmenangehörige, für die derzeit mindestens eine Benachrichtigungsumleitung an einen Ansprechpartner eingetragen ist, welcher den Versand per Briefpost bevorzugt. # - Ob ein Ansprechpartner Email oder Briefpost wünscht ist eine individuelle Einstellung des Ansprechpartners und gilt für alle Benachrichtigungen an diesen Ansprechpartner. -
                                10. Anzahl der firmenfremden Ansprechpartner, welche mindestens einen Firmenangehörigen betreuen. Bei manchen Firmen ist es normal, dass die Ansprechpartner einer anderen Firma angehören, aber oft ist nur ein Fehler durch Firmenwechsel. -
                                11. Anzahl der Ansprechpartner mit derzeit aktiver Benachrichtigungsumleitung, egal ob Brief oder Email. -
                                12. Gesamtzahl der Brief und Emails, welche bei Benachrichtigung aller Firmenangehörigen derzeit verschickt würden. -

                                  - Dies ist also die Gesamtzahl aller derzeit aktiven Benachrichtigungsumleitungen. -

                                  - - Beispiel: Für eine Firma mit 2 Angehörigen, für die ein Mitarbeiter 1 Ansprechpartner mit aktiver Umleitung und einen Mitarbeiter mit 3 Ansprechpartnern mit aktiver Umleitung hätte, # - würde hier die Zahl 4 stehen, da bei einer Benachrichtigung an beide Mitarbeiter insgesamt 4 Briefe oder Emails versendet würden. -

                                13. Voreinstellung der persönlichen Benachrichtigungspreferenz für Firmenangehörige welche neu aus dem AVS importiert werden (erst mit Umsetzung CR3 effektiv). - diff --git a/templates/i18n/firm-all/en-eu.hamlet b/templates/i18n/firm-all/en-eu.hamlet index e8a2ccfb0..2e32522f3 100644 --- a/templates/i18n/firm-all/en-eu.hamlet +++ b/templates/i18n/firm-all/en-eu.hamlet @@ -14,31 +14,3 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later

                                  ^{firmTable} - -

                                  Development Version Notes (TODO: translated paragraph) -

                                  - Die Spalten zeigen derzeit folgende Informationen -

                                    -
                                  1. Firmenname -
                                  2. Firmenkürzel -
                                  3. AVS Firmennummer -
                                  4. Anzahl der derzeit zugeordneten Firmenangehörigen. Eine Personen kann mehreren Firmen gleichzeitig angehören. -
                                  5. Anzahl der Standard Ansprechpartner, welche einer neu in FRADrive eingetragnen Person dieser Firma derzeit zugeordnet werden. Eine Person kann beliebig viele Ansprechpartner haben. Wirkt sich nicht auf vorhandene Firmenangehörige aus. -
                                  6. Anzahl der Standard Ansprechpartner der Firma mit Benachrichtigungsumleitung. Hat eine Person mehrere Ansprechpartner mit Umleitung, so wird ein Brief oder Email an alle Ansprechpartner verschickt. # - Ein Person kann auch ihr eigener Ansprechpartner sein, um eine Benachrichtigung sowohl an die Person selbst als auch an einen Ansprechpartner zu senden. # - Wirkt sich nicht auf vorhandene Firmenangehörige aus, sondern nur auf neu in FRADrive hinzukommende Firmenangehörige. -
                                  7. Anzahl Firmenangehörige, für die derzeit mindestens ein Ansprechpartner eingetragen ist. Ansprechpartner müssen nicht notwendigerweise der gleichen Firma angehören! -
                                  8. Anzahl Firmenangehörige, für die derzeit mindestens eine Benachrichtigungsumleitung an einen Ansprechpartner eingetragen ist. Ansprechpartner müssen nicht notwendigerweise der gleichen Firma angehören! -
                                  9. Anzahl Firmenangehörige, für die derzeit mindestens eine Benachrichtigungsumleitung an einen Ansprechpartner eingetragen ist, welcher den Versand per Briefpost bevorzugt. # - Ob ein Ansprechpartner Email oder Briefpost wünscht ist eine individuelle Einstellung des Ansprechpartners und gilt für alle Benachrichtigungen an diesen Ansprechpartner. -
                                  10. Anzahl der firmenfremden Ansprechpartner, welche mindestens einen Firmenangehörigen betreuen. Bei manchen Firmen ist es normal, dass die Ansprechpartner einer anderen Firma angehören, aber oft ist nur ein Fehler durch Firmenwechsel. -
                                  11. Anzahl der Ansprechpartner mit derzeit aktiver Benachrichtigungsumleitung, egal ob Brief oder Email. -
                                  12. Gesamtzahl der Brief und Emails, welche bei Benachrichtigung aller Firmenangehörigen derzeit verschickt würden. -

                                    - Dies ist also die Gesamtzahl aller derzeit aktiven Benachrichtigungsumleitungen. -

                                    - - Beispiel: Für eine Firma mit 2 Angehörigen, für die ein Mitarbeiter 1 Ansprechpartner mit aktiver Umleitung und einen Mitarbeiter mit 3 Ansprechpartnern mit aktiver Umleitung hätte, # - würde hier die Zahl 4 stehen, da bei einer Benachrichtigung an beide Mitarbeiter insgesamt 4 Briefe oder Emails versendet würden. -

                                  13. Voreinstellung der persönlichen Benachrichtigungspreferenz für Firmenangehörige welche neu aus dem AVS importiert werden (erst mit Umsetzung CR3 effektiv). - From 53f54189f9f5907e5115b7b3ab2009cef6fa6e5e Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 3 Nov 2023 17:55:56 +0100 Subject: [PATCH 29/50] chore(firm): add supervisor table stub --- .../uniworx/categories/firm/de-de-formal.msg | 3 + messages/uniworx/categories/firm/en-eu.msg | 3 + src/Handler/Firm.hs | 154 +++++++++++++++++- templates/firm-users.hamlet | 13 +- 4 files changed, 164 insertions(+), 9 deletions(-) diff --git a/messages/uniworx/categories/firm/de-de-formal.msg b/messages/uniworx/categories/firm/de-de-formal.msg index 024efc05f..4fb1d392d 100644 --- a/messages/uniworx/categories/firm/de-de-formal.msg +++ b/messages/uniworx/categories/firm/de-de-formal.msg @@ -10,6 +10,9 @@ FirmAllActNotify: Mitteilung versenden FirmAllActResetSupervision: Ansprechpartner für alle Firmenangehörigen zurücksetzen FirmUserActNotify: Mitteilung versenden FirmUserActMkSuper: Zum Firmenansprechpartner ernennen +FirmSuperActNotify: Mitteilung versenden +FirmSuperActRMSuperDef: Standard Firmenansprechpartner entfernen +FirmSuperActRMSuperAll: Als aktiven Ansprechpartner komplett entfernen FilterSupervisor: Hat aktiven Ansprechpartner FilterSupervisorCompany fsh@CompanyShorthand: Hat aktiven Ansprechpartner, der #{fsh} angehört FilterSupervisorForeign fsh@CompanyShorthand: Hat aktiven Ansprechpartner, der selbst nicht #{fsh} angehört diff --git a/messages/uniworx/categories/firm/en-eu.msg b/messages/uniworx/categories/firm/en-eu.msg index 869cc617a..a4df65482 100644 --- a/messages/uniworx/categories/firm/en-eu.msg +++ b/messages/uniworx/categories/firm/en-eu.msg @@ -10,6 +10,9 @@ FirmAllActNotify: Send message FirmAllActResetSupervision: Reset supervisors for all company associates FirmUserActNotify: Send message FirmUserActMkSuper: Mark as company supervisor +FirmSuperActNotify: Send message +FirmSuperActRMSuperDef: Remove as default supervisor +FirmSuperActRMSuperAll: Remove all active supervisions for this company FilterSupervisor: Has active supervisor FilterSupervisorCompany fsh: Has active company supervisor belonging to #{fsh} FilterSupervisorForeign fsh: Has active supervisor not belonging to #{fsh} diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 39c1840bd..3f6d46207 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -578,10 +578,160 @@ postFirmUsersR fsh = do ----------------------------- -- Firm Supervisors Table +data FirmSuperAction = FirmSuperActNotify + | FirmSuperActRMSuperDef + | FirmSuperActRMSuperAll + deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) + deriving anyclass (Universe, Finite) + +nullaryPathPiece ''FirmSuperAction $ camelToPathPiece' 3 +embedRenderMessage ''UniWorX ''FirmSuperAction id + +data FirmSuperActionData = FirmSuperActNotifyData + | FirmSuperActRMSuperDefData + | FirmSuperActRMSuperAllData + deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) + +type SuperCompanyTableExpr = E.SqlExpr (Entity User) + +querySuperUser :: SuperCompanyTableExpr -> E.SqlExpr (Entity User) +querySuperUser = id + +type SuperCompanyTableData = DBRow (Entity User, E.Value Word64, E.Value Word64) + +resultSuperUser :: Lens' SuperCompanyTableData (Entity User) +resultSuperUser = _dbrOutput . _1 + +resultSuperCompanySupervised :: Lens' SuperCompanyTableData Word64 +resultSuperCompanySupervised = _dbrOutput . _2 . _unValue + +resultSuperCompanyReroutes :: Lens' SuperCompanyTableData Word64 +resultSuperCompanyReroutes = _dbrOutput . _3 . _unValue + +instance HasEntity SuperCompanyTableData User where + hasEntity = resultSuperUser + +instance HasUser SuperCompanyTableData where + hasUser = resultSuperUser . _entityVal + + +mkFirmSuperTable :: Bool -> CompanyId -> DB (FormResult (FirmSuperActionData, Set UserId), Widget) +mkFirmSuperTable isAdmin cid = do + let + -- fsh = unCompanyKey cid + resultDBTable = DBTable{..} + where + dbtSQLQuery = \usr -> do + -- refactor this + let subs = do + (usrSpr :& usrCmp) <- E.from $ E.table @UserSupervisor + `E.innerJoin` E.table @UserCompany + `E.on` (\(usrSpr :& usrCmp) -> usrSpr E.^. UserSupervisorUser E.==. usrCmp E.^. UserCompanyUser) + E.where_ $ usrSpr E.^. UserSupervisorSupervisor E.==. usr E.^. UserId + E.&&. usrCmp E.^. UserCompanyCompany E.==. E.val cid + subs' = do + (usrSpr :& usrCmp) <- E.from $ E.table @UserSupervisor + `E.innerJoin` E.table @UserCompany + `E.on` (\(usrSpr :& usrCmp) -> usrSpr E.^. UserSupervisorUser E.==. usrCmp E.^. UserCompanyUser) + E.where_ $ usrSpr E.^. UserSupervisorSupervisor E.==. usr E.^. UserId + E.&&. usrCmp E.^. UserCompanyCompany E.==. E.val cid + E.&&. usrSpr E.^. UserSupervisorRerouteNotifications + E.where_ $ E.exists subs + return (usr, E.subSelectCount subs, E.subSelectCount subs') + dbtRowKey = querySuperUser >>> (E.^. UserId) + dbtProj = dbtProjId + dbtColonnade = formColonnade $ mconcat + [ guardMonoid isAdmin $ dbSelect (applying _2) id (return . view (resultSuperUser . _entityKey)) + , colUserNameModalHdr MsgTableSupervisor ForProfileDataR + , sortable (Just "matriculation") (i18nCell MsgTableMatrikelNr) $ \(view resultSuperUser -> entUsr) -> cellHasMatrikelnummerLinked entUsr + , sortable (Just "personal-number") (i18nCell MsgCompanyPersonalNumber) $ \(view $ resultSuperUser . _userCompanyPersonalNumber -> t) -> foldMap textCell t + , sortable (Just "postal-pref") (i18nCell MsgPrefersPostal) $ \(view $ resultSuperUser . _userPrefersPostal -> b) -> iconFixedCell $ iconLetterOrEmail b + , colUserEmail + , sortable Nothing (i18nCell MsgTableCompanyNrEmpSupervised) $ \(view resultSuperCompanySupervised -> nr) -> wgtCell $ word2widget nr + , sortable Nothing (i18nCell MsgTableCompanyNrEmpRerouted ) $ \(view resultSuperCompanyReroutes -> nr) -> wgtCell $ word2widget nr + ] + dbtSorting = mconcat + [ single $ sortUserNameLink querySuperUser + , single $ sortUserEmail querySuperUser + , singletonMap "matriculation" $ SortColumn $ querySuperUser >>> (E.^. UserMatrikelnummer) + , singletonMap "personal-number" $ SortColumn $ querySuperUser >>> (E.^. UserCompanyPersonalNumber) + , singletonMap "postal-pref" $ SortColumn $ querySuperUser >>> (E.^. UserPrefersPostal) + ] + dbtFilter = mconcat + [ single $ fltrUserNameEmail querySuperUser + ] + dbtFilterUI mPrev = mconcat + [ fltrUserNameEmailHdrUI MsgTableSupervisor mPrev + ] + dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } + acts :: Map FirmSuperAction (AForm Handler FirmSuperActionData) + acts = mconcat + [ singletonMap FirmSuperActNotify $ pure FirmSuperActNotifyData + , singletonMap FirmSuperActRMSuperDef $ pure FirmSuperActRMSuperDefData + , singletonMap FirmSuperActRMSuperAll $ pure FirmSuperActRMSuperAllData + ] + 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-supervisors" + dbtCsvEncode = noCsvEncode + dbtCsvDecode = Nothing + dbtExtraReps = [] + + postprocess :: FormResult (First FirmSuperActionData, DBFormResult UserId Bool SuperCompanyTableData) + -> FormResult ( FirmSuperActionData, Set UserId) + postprocess inp = do + (First (Just act), m) <- inp + let s = Map.keysSet . Map.filter id $ getDBFormResult (const False) m + return (act, s) + + resultDBTableValidator = def + & defaultSorting [SortAscBy "user-name"] + over _1 postprocess <$> dbTable resultDBTableValidator resultDBTable + + getFirmSupersR, postFirmSupersR :: CompanyShorthand -> Handler Html getFirmSupersR = postFirmSupersR postFirmSupersR fsh = do - let _fshId = CompanyKey fsh + isAdmin <- hasReadAccessTo AdminR + let fshId = CompanyKey fsh + (Company{..},(fsprRes,fsprTable)) <- runDB $ (,) + <$> get404 fshId + <*> mkFirmSuperTable isAdmin fshId + + formResult fsprRes $ \case + (FirmSuperActNotifyData , fids) -> addMessage Info $ text2Html $ "Notify " <> tshow (length fids) <> " supervisors. TODO" + (FirmSuperActRMSuperDefData, fids) -> addMessage Info $ text2Html $ "Remove " <> tshow (length fids) <> " default supervisors. TODO" + (FirmSuperActRMSuperAllData, fids) -> addMessage Info $ text2Html $ "Make " <> tshow (length fids) <> " default and active supervisors. TODO" + siteLayout (citext2widget fsh) $ do setTitle $ citext2Html fsh - [whamlet|!!!STUB!!!TO DO!!!|] + -- TODO: factor out company info section hamlet here and from user table + [whamlet| +
                                    +

                                    !!!STUB!!!TO DO!!! +
                                    +
                                    + $maybe fem <- companyEmail +
                                    + _{MsgFirmEmail} #{iconLetterOrEmail False} +
                                    + #{mailtoHtml fem} + $maybe addr <- companyPostAddress +
                                    + _{MsgFirmAddress} #{iconLetterOrEmail True} +
                                    + #{addr} +
                                    + ^{fsprTable} + |] diff --git a/templates/firm-users.hamlet b/templates/firm-users.hamlet index f9224bd3a..0da59383f 100644 --- a/templates/firm-users.hamlet +++ b/templates/firm-users.hamlet @@ -32,12 +32,12 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later

                                		_{MsgFirmDefaultPreferenceInfo}
                                _{MsgTableCompanyNrUsers} - _{MsgTableCompanyNrForeignSupers} + _{MsgTableCompanyNrForeignSupers}
                                #{nrCompanyUsers} #{nrCompanyForeignSupers} - - Anzahl der firmenfremden Ansprechpartner, welche mindestens einen Firmenangehörigen betreuen. Bei manchen Firmen ist es normal, dass die Ansprechpartner einer anderen Firma angehören, aber oft ist nur ein Fehler durch Firmenwechsel. + + Anzahl der firmenfremden Ansprechpartner, welche mindestens einen Firmenangehörigen betreuen. Bei manchen Firmen ist es normal, dass die Ansprechpartner einer anderen Firma angehören, aber oft ist nur ein Fehler durch Firmenwechsel.
                                _{MsgTableCompanyNrEmpSupervised} @@ -51,12 +51,11 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later #{nrCompanyActiveReroutes}
                                - Anzahl Firmenangehörige, für die derzeit mindestens ein Ansprechpartner eingetragen ist. Ansprechpartner müssen nicht notwendigerweise der gleichen Firma angehören! + Ansprechpartner müssen nicht notwendigerweise der gleichen Firma angehören! - Anzahl Firmenangehörige, für die derzeit mindestens eine Benachrichtigungsumleitung an einen Ansprechpartner eingetragen ist. Ansprechpartner müssen nicht notwendigerweise der gleichen Firma angehören! + Mindestens ein Ansprechpartner mit Umleitung. - Anzahl Firmenangehörige, für die derzeit mindestens eine Benachrichtigungsumleitung an einen Ansprechpartner eingetragen ist, welcher den Versand per Briefpost bevorzugt. # - Ob ein Ansprechpartner Email oder Briefpost wünscht ist eine individuelle Einstellung des Ansprechpartners und gilt für alle Benachrichtigungen an diesen Ansprechpartner. + Email oder Brief ist individuelle Einstellung des Ansprechpartners und gilt für alle Benachrichtigungen an diesen Ansprechpartner. Gesamtzahl aller aktiven Benachrichtigungsumleitungen. # From 2c12477c57fc455ba2a5f0186ea33eaac7363490 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 3 Nov 2023 18:05:18 +0100 Subject: [PATCH 30/50] fix minor typo --- messages/uniworx/utils/table_column/en-eu.msg | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/messages/uniworx/utils/table_column/en-eu.msg b/messages/uniworx/utils/table_column/en-eu.msg index 5839e332c..3b7962522 100644 --- a/messages/uniworx/utils/table_column/en-eu.msg +++ b/messages/uniworx/utils/table_column/en-eu.msg @@ -83,7 +83,7 @@ TableCompanyNos: Company numbers TableCompanyUser: Associate TableCompanyNrUsers: Associates TableCompanyNrSupers: Supervisors -TableCompanyNrEmpSupervised: Supervsied employees +TableCompanyNrEmpSupervised: Supervised employees TableCompanyNrEmpRerouted: Employees having reroute TableCompanyNrEmpRerPost: Employees having postal reroute TableCompanyNrSupersActive: Associates having supervisors From 069561763cb0f705f1ff7358f8cb7d43017b45a8 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 6 Nov 2023 12:17:11 +0100 Subject: [PATCH 31/50] refactor(firm); supervisor table sorting and company column --- src/Handler/Firm.hs | 62 +++++++++++++++++++++----------- src/Handler/Utils/Table/Cells.hs | 3 ++ templates/firm-users.hamlet | 3 +- 3 files changed, 45 insertions(+), 23 deletions(-) diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 3f6d46207..de7a86d06 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -597,7 +597,7 @@ type SuperCompanyTableExpr = E.SqlExpr (Entity User) querySuperUser :: SuperCompanyTableExpr -> E.SqlExpr (Entity User) querySuperUser = id -type SuperCompanyTableData = DBRow (Entity User, E.Value Word64, E.Value Word64) +type SuperCompanyTableData = DBRow (Entity User, E.Value Word64, E.Value Word64, [(E.Value CompanyName, E.Value CompanyShorthand, E.Value Bool)]) resultSuperUser :: Lens' SuperCompanyTableData (Entity User) resultSuperUser = _dbrOutput . _1 @@ -608,12 +608,27 @@ resultSuperCompanySupervised = _dbrOutput . _2 . _unValue resultSuperCompanyReroutes :: Lens' SuperCompanyTableData Word64 resultSuperCompanyReroutes = _dbrOutput . _3 . _unValue +resultSuperCompanies :: Lens' SuperCompanyTableData [(E.Value CompanyName, E.Value CompanyShorthand, E.Value Bool)] +resultSuperCompanies = _dbrOutput . _4 + + instance HasEntity SuperCompanyTableData User where hasEntity = resultSuperUser instance HasUser SuperCompanyTableData where hasUser = resultSuperUser . _entityVal +firmQuerySupervisedBy :: CompanyId -> Maybe (E.SqlExpr (Entity UserSupervisor) -> E.SqlExpr (E.Value Bool)) -> E.SqlExpr (Entity User) -> E.SqlQuery () +firmQuerySupervisedBy cid mbFltr usr = do + (usrSpr :& usrCmp) <- E.from $ E.table @UserSupervisor + `E.innerJoin` E.table @UserCompany + `E.on` (\(usrSpr :& usrCmp) -> usrSpr E.^. UserSupervisorUser E.==. usrCmp E.^. UserCompanyUser) + let basecond = usrSpr E.^. UserSupervisorSupervisor E.==. usr E.^. UserId + E.&&. usrCmp E.^. UserCompanyCompany E.==. E.val cid + E.where_ $ maybe basecond ((basecond E.&&.).($ usrSpr)) mbFltr + +firmCountForSupervisor :: CompanyId -> Maybe (E.SqlExpr (Entity UserSupervisor) -> E.SqlExpr (E.Value Bool)) -> E.SqlExpr (Entity User) -> E.SqlExpr (E.Value Word64) +firmCountForSupervisor = ((E.subSelectCount .) .) . firmQuerySupervisedBy mkFirmSuperTable :: Bool -> CompanyId -> DB (FormResult (FirmSuperActionData, Set UserId), Widget) mkFirmSuperTable isAdmin cid = do @@ -621,34 +636,31 @@ mkFirmSuperTable isAdmin cid = do -- fsh = unCompanyKey cid resultDBTable = DBTable{..} where - dbtSQLQuery = \usr -> do - -- refactor this - let subs = do - (usrSpr :& usrCmp) <- E.from $ E.table @UserSupervisor - `E.innerJoin` E.table @UserCompany - `E.on` (\(usrSpr :& usrCmp) -> usrSpr E.^. UserSupervisorUser E.==. usrCmp E.^. UserCompanyUser) - E.where_ $ usrSpr E.^. UserSupervisorSupervisor E.==. usr E.^. UserId - E.&&. usrCmp E.^. UserCompanyCompany E.==. E.val cid - subs' = do - (usrSpr :& usrCmp) <- E.from $ E.table @UserSupervisor - `E.innerJoin` E.table @UserCompany - `E.on` (\(usrSpr :& usrCmp) -> usrSpr E.^. UserSupervisorUser E.==. usrCmp E.^. UserCompanyUser) - E.where_ $ usrSpr E.^. UserSupervisorSupervisor E.==. usr E.^. UserId - E.&&. usrCmp E.^. UserCompanyCompany E.==. E.val cid - E.&&. usrSpr E.^. UserSupervisorRerouteNotifications - E.where_ $ E.exists subs - return (usr, E.subSelectCount subs, E.subSelectCount subs') + dbtSQLQuery = \usr -> do + E.where_ $ E.exists $ firmQuerySupervisedBy cid Nothing usr + return ( usr + , usr & firmCountForSupervisor cid Nothing + , usr & firmCountForSupervisor cid (Just (E.^. UserSupervisorRerouteNotifications)) + ) dbtRowKey = querySuperUser >>> (E.^. UserId) - dbtProj = dbtProjId + dbtProj = dbtProjSimple $ \(usr, supervised, rerouted) -> do + cmps <- E.select $ do + (cmp :& usrCmp) <- E.from $ E.table @Company `E.innerJoin` E.table @UserCompany `E.on` (\(cmp :& usrCmp) -> cmp E.^. CompanyId E.==. usrCmp E.^. UserCompanyCompany) + E.where_ $ usrCmp E.^. UserCompanyUser E.==. E.val (entityKey usr) + E.orderBy [E.asc $ cmp E.^. CompanyName] + return (cmp E.^. CompanyName, cmp E.^. CompanyShorthand, usrCmp E.^. UserCompanySupervisor) + return (usr, supervised, rerouted, cmps) dbtColonnade = formColonnade $ mconcat [ guardMonoid isAdmin $ dbSelect (applying _2) id (return . view (resultSuperUser . _entityKey)) , colUserNameModalHdr MsgTableSupervisor ForProfileDataR , sortable (Just "matriculation") (i18nCell MsgTableMatrikelNr) $ \(view resultSuperUser -> entUsr) -> cellHasMatrikelnummerLinked entUsr + , sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \( view resultSuperCompanies -> cmps) -> + intercalate semicolonCell [companyCell cmpShort cmpName isSuper | (E.Value cmpName, E.Value cmpShort, E.Value isSuper) <- cmps] , sortable (Just "personal-number") (i18nCell MsgCompanyPersonalNumber) $ \(view $ resultSuperUser . _userCompanyPersonalNumber -> t) -> foldMap textCell t , sortable (Just "postal-pref") (i18nCell MsgPrefersPostal) $ \(view $ resultSuperUser . _userPrefersPostal -> b) -> iconFixedCell $ iconLetterOrEmail b , colUserEmail - , sortable Nothing (i18nCell MsgTableCompanyNrEmpSupervised) $ \(view resultSuperCompanySupervised -> nr) -> wgtCell $ word2widget nr - , sortable Nothing (i18nCell MsgTableCompanyNrEmpRerouted ) $ \(view resultSuperCompanyReroutes -> nr) -> wgtCell $ word2widget nr + , sortable (Just "supervised") (i18nCell MsgTableCompanyNrEmpSupervised) $ \(view resultSuperCompanySupervised -> nr) -> wgtCell $ word2widget nr + , sortable (Just "rerouted") (i18nCell MsgTableCompanyNrEmpRerouted ) $ \(view resultSuperCompanyReroutes -> nr) -> wgtCell $ word2widget nr ] dbtSorting = mconcat [ single $ sortUserNameLink querySuperUser @@ -656,6 +668,14 @@ mkFirmSuperTable isAdmin cid = do , singletonMap "matriculation" $ SortColumn $ querySuperUser >>> (E.^. UserMatrikelnummer) , singletonMap "personal-number" $ SortColumn $ querySuperUser >>> (E.^. UserCompanyPersonalNumber) , singletonMap "postal-pref" $ SortColumn $ querySuperUser >>> (E.^. UserPrefersPostal) + , singletonMap "supervised" $ SortColumn $ querySuperUser >>> firmCountForSupervisor cid Nothing + , singletonMap "rerouted" $ SortColumn $ querySuperUser >>> firmCountForSupervisor cid (Just (E.^. UserSupervisorRerouteNotifications)) + , singletonMap "user-company" $ SortColumn (\row -> E.subSelect $ do + (cmp :& usrCmp) <- E.from $ E.table @Company `E.innerJoin` E.table @UserCompany `E.on` (\(cmp :& usrCmp) -> cmp E.^. CompanyId E.==. usrCmp E.^. UserCompanyCompany) + E.where_ $ usrCmp E.^. UserCompanyUser E.==. querySuperUser row E.^. UserId + E.orderBy [E.asc $ cmp E.^. CompanyName] + return (cmp E.^. CompanyName) + ) ] dbtFilter = mconcat [ single $ fltrUserNameEmail querySuperUser diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index bdc1cc611..cf5051ef5 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -29,6 +29,9 @@ type CourseLink = (TermId, SchoolId, CourseShorthand) -- TODO: Refactor with Wit spacerCell :: IsDBTable m a => DBCell m a spacerCell = cell [whamlet| |] +semicolonCell :: IsDBTable m a => DBCell m a +semicolonCell = cell [whamlet|; |] + tellCell :: IsDBTable m a => a -> DBCell m a -> DBCell m a tellCell = flip mappend . writerCell . tell diff --git a/templates/firm-users.hamlet b/templates/firm-users.hamlet index 0da59383f..9acaf1c2f 100644 --- a/templates/firm-users.hamlet +++ b/templates/firm-users.hamlet @@ -23,8 +23,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
                                _{MsgTableCompanyNrSupersDefault} _{MsgTableCompanyNrRerouteDefault} - _{MsgPrefersPostal} - + _{MsgPrefersPostal}
                                #{nrCompanySupervisors} #{nrCompanyDefaultReroutes} From 3865bda64d488c161b55e1f6eb48ca1b742dff98 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 7 Nov 2023 17:29:57 +0100 Subject: [PATCH 32/50] fix(lms): improve sorting for firm all --- src/Handler/Firm.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index de7a86d06..1b27ad612 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -272,11 +272,11 @@ mkFirmAllTable isAdmin uid = do , singletonMap "avsnr" $ SortColumn (E.^. CompanyAvsId) , singletonMap "postal-pref" $ SortColumn (E.^. CompanyPrefersPostal) , singletonMap "users" $ SortColumn firmCountUsers - , singletonMap "supervisors" $ SortColumn firmCountSupervisors + , singletonMap "supervisors" $ SortColumn firmHasSupervisors -- , singletonMap "emp-supervised" $ SortColumn firmCountEmployeeSupervised -- , singletonMap "emp-rerouted" $ SortColumn firmCountEmployeeRerouted -- , singletonMap "emp-rer-post" $ SortColumn firmCountEmployeeRerPost - , singletonMap "reroute-def" $ SortColumn firmCountDefaultReroutes + , singletonMap "reroute-def" $ SortColumn firmHasDefaultReroutes -- , singletonMap "foreigners" $ SortColumn firmCountForeignSupervisors -- , singletonMap "reroute-act" $ SortColumn firmCountActiveReroutes -- , singletonMap "reroute-all" $ SortColumn firmCountActiveReroutes' From 631d157688b79dd80916ee27ef08f209ccfb1f3b Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 7 Nov 2023 18:38:21 +0100 Subject: [PATCH 33/50] chore(firm): add messaging action (WIP) --- .../uniworx/categories/firm/de-de-formal.msg | 2 + messages/uniworx/categories/firm/en-eu.msg | 2 + routes | 5 +- src/Handler/Firm.hs | 100 ++++++++++++++++-- src/Handler/Utils/Communication.hs | 1 + 5 files changed, 103 insertions(+), 7 deletions(-) diff --git a/messages/uniworx/categories/firm/de-de-formal.msg b/messages/uniworx/categories/firm/de-de-formal.msg index 4fb1d392d..65e8291f1 100644 --- a/messages/uniworx/categories/firm/de-de-formal.msg +++ b/messages/uniworx/categories/firm/de-de-formal.msg @@ -13,6 +13,8 @@ FirmUserActMkSuper: Zum Firmenansprechpartner ernennen FirmSuperActNotify: Mitteilung versenden FirmSuperActRMSuperDef: Standard Firmenansprechpartner entfernen FirmSuperActRMSuperAll: Als aktiven Ansprechpartner komplett entfernen +FirmsNotification: Firmen Benachrichtigung versenden +FirmNotification fsh@CompanyShorthand: Benachrichtigung an #{fsh} versenden FilterSupervisor: Hat aktiven Ansprechpartner FilterSupervisorCompany fsh@CompanyShorthand: Hat aktiven Ansprechpartner, der #{fsh} angehört FilterSupervisorForeign fsh@CompanyShorthand: Hat aktiven Ansprechpartner, der selbst nicht #{fsh} angehört diff --git a/messages/uniworx/categories/firm/en-eu.msg b/messages/uniworx/categories/firm/en-eu.msg index a4df65482..68e4add9b 100644 --- a/messages/uniworx/categories/firm/en-eu.msg +++ b/messages/uniworx/categories/firm/en-eu.msg @@ -13,6 +13,8 @@ FirmUserActMkSuper: Mark as company supervisor FirmSuperActNotify: Send message FirmSuperActRMSuperDef: Remove as default supervisor FirmSuperActRMSuperAll: Remove all active supervisions for this company +FirmsNotification: Send company notification +FirmNotification fsh: Send notification to company #{fsh} FilterSupervisor: Has active supervisor FilterSupervisorCompany fsh: Has active company supervisor belonging to #{fsh} FilterSupervisorForeign fsh: Has active supervisor not belonging to #{fsh} diff --git a/routes b/routes index 6b89c13f6..694386474 100644 --- a/routes +++ b/routes @@ -113,10 +113,13 @@ /for/#CryptoUUIDUser/user ForProfileR GET POST !supervisor !self /for/#CryptoUUIDUser/user/profile ForProfileDataR GET !supervisor !self -/firm FirmAllR GET POST !supervisor +/firms FirmAllR GET POST !supervisor +/firms/comm FirmsCommR GET POST /firm/#CompanyShorthand FirmR GET POST /firm/#CompanyShorthand/users FirmUsersR GET POST !supervisor /firm/#CompanyShorthand/supers FirmSupersR GET POST !supervisor +/firm/#CompanyShorthand/comm FirmCommR GET POST + /exam-office ExamOfficeR !exam-office: / EOExamsR GET POST !system-exam-office diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 1b27ad612..b6eb43e95 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -11,6 +11,8 @@ module Handler.Firm , getFirmR , postFirmR , getFirmUsersR , postFirmUsersR , getFirmSupersR, postFirmSupersR + , getFirmCommR , postFirmCommR + , getFirmsCommR, postFirmsCommR ) where @@ -18,6 +20,7 @@ import Import -- import Jobs import Handler.Utils +import Handler.Utils.Communication import qualified Data.Set as Set import qualified Data.Map as Map @@ -494,8 +497,10 @@ mkFirmUserTable isAdmin cid = do Just True -> E.exists checkSuper Just False -> E.notExists checkSuper ] + -- superField = selectField $ ???? dbtFilterUI mPrev = mconcat [ fltrUserNameEmailHdrUI MsgTableCompanyUser mPrev + , prismAForm (singletonFilter "supervisor-is" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift termField) (fslI MsgTableTerm) , prismAForm (singletonFilter "has-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterSupervisor) , prismAForm (singletonFilter "has-company-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI $ MsgFilterSupervisorCompany fsh) , prismAForm (singletonFilter "has-foreign-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI $ MsgFilterSupervisorForeign fsh) @@ -541,7 +546,7 @@ getFirmUsersR, postFirmUsersR :: CompanyShorthand -> Handler Html getFirmUsersR = postFirmUsersR postFirmUsersR fsh = do isAdmin <- hasReadAccessTo AdminR - let fshId = CompanyKey fsh + let cid = CompanyKey fsh (( Entity{entityVal=Company{..}} , E.Value nrCompanyUsers , E.Value nrCompanySupervisors @@ -551,10 +556,10 @@ postFirmUsersR fsh = do , E.Value nrCompanyEmployeeRerPost , E.Value nrCompanyDefaultReroutes , E.Value nrCompanyActiveReroutes - ) , (fusrRes, fusrTable)) <- runDB $ (,) + ) , (fusrRes, fusrTable)) <- runDB $ (,) <$> fromMaybeM notFound (E.selectOne $ do cmpy <- E.from $ E.table @Company - E.where_ $ cmpy E.^. CompanyId E.==. E.val fshId + E.where_ $ cmpy E.^. CompanyId E.==. E.val cid return ( cmpy , cmpy & firmCountUsers , cmpy & firmCountSupervisors @@ -565,11 +570,18 @@ postFirmUsersR fsh = do , cmpy & firmCountDefaultReroutes , cmpy & firmCountActiveReroutes )) - <*> mkFirmUserTable isAdmin fshId + -- superVs <- E.select $ do + -- usr <- E.from $ E.table @User + -- E.where_ $ E.exists $ firmQuerySupervisedBy cmpyId Nothing usr + -- return usr + <*> mkFirmUserTable isAdmin cid - formResult fusrRes $ \case - (FirmUserActNotifyData , fids) -> addMessage Info $ text2Html $ "Notify " <> tshow (length fids) <> " employees. TODO" + formResult fusrRes $ \case (FirmUserActMkSuperData, fids) -> addMessage Info $ text2Html $ "Make " <> tshow (length fids) <> " employees to supervisors. TODO" + (FirmUserActNotifyData , fids) -> do + cuids <- traverse encrypt $ Set.toList fids :: Handler [CryptoUUIDUser] + redirect (FirmCommR fsh, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids]) + siteLayout (citext2widget companyName) $ do setTitle $ toHtml $ CI.original companyShorthand <> " (" <> tshow companyAvsId <> ")" $(widgetFile "firm-users") @@ -755,3 +767,79 @@ postFirmSupersR fsh = do
                                ^{fsprTable} |] + + +getFirmCommR, postFirmCommR :: CompanyShorthand -> Handler Html +getFirmCommR = postFirmCommR +postFirmCommR fsh = handleFirmCommR (SomeRoute FirmUsersR) (Just fsh) + + +getFirmsCommR, postFirmsCommR :: Handler Html +getFirmsCommR = postFirmsCommR +postFirmsCommR = handleFirmCommR (SomeRoute FirmAllR) Nothing + + +handleFirmCommR :: SomeRoute UniWorX -> Maybe CompanyShorthand -> Handler Html +handleFirmCommR ultDest mbFsh = do + let decrypt' :: CryptoUUIDUser -> Handler UserId + decrypt' = decrypt + + mbCid = CompanyKey <$> mbFsh + + -- queryEmpys :: CompanyId -> Handler [UserId] + queryEmpys cid = E.unValue <<$>> runDB (E.select $ do + (emp :& uc) <- E.from $ E.table @User `E.innerJoin` E.table @UserCompany `E.on` (\(emp :& uc) -> emp E.^. UserId E.==. uc E.^. UserCompanyUser) + E.where_ $ uc E.^. UserCompanyCompany E.==. E.val cid + return $ emp E.^. UserId + ) + + chosen <- mapM decrypt =<< lookupGlobalGetParams GetRecipient -- retrieve selected users + empys <- maybe (return chosen) queryEmpys mbCid -- get all employees or stick with selected users, if no company was pre-selected (to limit choices) + + cmpys <- runDB $ E.select $ do + cmpy <- E.from $ E.table @Company + E.where_ $ E.exists $ do + usrCmpy <- E.table @UserCompany + E.where_ $ usrCmpy E.^. UserCompanyUser `E.in_` E.valList chosen + E.&&. usrCmpy E.^. UserCompanyCompany E.==. cmpy E.^. CompanyId + return $ cmpy E.^.CompanyId + + let queryCmpy :: Bool -> CompanyId -> E.SqlQuery (E.SqlExpr (Entity User)) + queryCmpy sORe acid = do + (usr :& uc) <- E.from $ E.table @User `E.innerJoin` E.table @UserCompany `E.on` (\(emp :& uc) -> emp E.^. UserId E.==. uc E.^. UserCompanyUser) + E.where_ $ uc E.^. UserCompanyCompany E.==. E.val acid + E.&&. (if sORe + then -- supervisors only + E.exists $ do + usrSpr <- E.table @UserSupervisor + E.where_ $ usrSpr E.^. UserSupervisorSupervisor E.==. usr E.^. UserId + E.&&. usrSpr E.^. UserSupervisorUser E.in_ E.valList empys + else -- chosen employees for this company only + usr E.^. UserId E.in_ E.valList empys + ) + + commR CommunicationRoute + { crHeading = SomeMessage $ maybe MsgFirmsNotification MsgFirmNotification mbFsh + , crUltDest = ultDest + , crJobs = error "TODO" -- CONTINUE HERE -- :: Communication -> ConduitT () Job (YesodDB UniWorX) () + , crTestJobs = error "TODO" -- CONTINUE HERE -- :: Communication -> ConduitT () Job (YesodDB UniWorX) () + , crRecipientAuth = Nothing -- :: Maybe (UserId -> DB AuthResult) -- an optional filter passed to guardAuthResult + , crRecipients = -- :: [(RecipientGroup, SqlQuery (SqlExpr (Entity User)))] + [(RGFirmSupervisor $ unCompanyKey acid, queryCmpy True acid) | acid <- cmpys ] <> + [(RGFirmEmployees $ unCompanyKey acid, queryCmpy False acid) | acid <- cmpys ] + } + +{- + ??? x + + Alle Supervisor von Leuten in X, gruppiert nach Firma + Alle Teilnehmer von X + + Ansprechpartner aus X + - Fred + Ansprechpartner aus Y + - Otto + Angestellte aus X + - Fred + - Meier + -} diff --git a/src/Handler/Utils/Communication.hs b/src/Handler/Utils/Communication.hs index 93577f8ed..3ec2dd854 100644 --- a/src/Handler/Utils/Communication.hs +++ b/src/Handler/Utils/Communication.hs @@ -30,6 +30,7 @@ data RecipientGroup = RGCourseParticipants | RGCourseLecturers | RGCourseCorrect | RGTutorialParticipants CryptoUUIDTutorial | RGExamRegistered CryptoUUIDExam | RGSheetSubmittor CryptoUUIDSheet + | RGFirmSupervisor CompanyShorthand | RGFirmEmployees CompanyShorthand deriving (Eq, Ord, Read, Show, Generic) instance LowerBounded RecipientGroup where From a98c3190e0837fbf42222476139f199d89fd776e Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 8 Nov 2023 13:00:31 +0100 Subject: [PATCH 34/50] chore(firm): messaging almost complete - illegal variable name splicing dispatch --- .../categories/jobs_handler/de-de-formal.msg | 1 - .../uniworx/categories/jobs_handler/en-eu.msg | 1 - .../utils/navigation/menu/de-de-formal.msg | 1 + .../uniworx/utils/navigation/menu/en-eu.msg | 1 + messages/uniworx/utils/utils/de-de-formal.msg | 1 + messages/uniworx/utils/utils/en-eu.msg | 1 + src/Foundation/Navigation.hs | 2 + src/Handler/Firm.hs | 62 ++++++++++--------- src/Handler/Utils/Communication.hs | 25 +++++++- src/Jobs/Handler/SendCourseCommunication.hs | 31 +++++++++- src/Jobs/Types.hs | 7 +++ 11 files changed, 99 insertions(+), 34 deletions(-) diff --git a/messages/uniworx/categories/jobs_handler/de-de-formal.msg b/messages/uniworx/categories/jobs_handler/de-de-formal.msg index 94fae99d1..dcb48a3fa 100644 --- a/messages/uniworx/categories/jobs_handler/de-de-formal.msg +++ b/messages/uniworx/categories/jobs_handler/de-de-formal.msg @@ -15,7 +15,6 @@ ResetPassword: FRADrive-Passwort ändern bzw. setzen MailSubjectChangeUserDisplayEmail: E-Mail-Adresse in FRADrive verwenden MailIntroChangeUserDisplayEmail displayEmail@UserEmail: Der oben genannte Benutzer/Die oben genannte Benutzerin möchte „#{displayEmail}“ als E-Mail-Adresse in FRADrive verwenden. Wenn Sie diese Aktion nicht selbst ausgelöst haben, ignorieren Sie diese Mitteilung bitte! MailTitleChangeUserDisplayEmail displayName@Text: #{displayName} möchte diese E-Mail-Adresse in FRADrive verwenden -CommCourseSubject: Kursartmitteilung InvitationAcceptDecline: Einladung annehmen/ablehnen InvitationFromTip displayName@Text: Sie erhalten diese Einladung, weil #{displayName} ihren Versand in FRADrive ausgelöst hat. InvitationFromTipAnonymous: Sie erhalten diese Einladung, weil ein nicht eingeloggter Benutzer/eine nichteingeloggte Benutzerin ihren Versand in FRADrive ausgelöst hat. diff --git a/messages/uniworx/categories/jobs_handler/en-eu.msg b/messages/uniworx/categories/jobs_handler/en-eu.msg index 3367e7a7a..e18244502 100644 --- a/messages/uniworx/categories/jobs_handler/en-eu.msg +++ b/messages/uniworx/categories/jobs_handler/en-eu.msg @@ -15,7 +15,6 @@ ResetPassword: Reselt FRADrive password MailSubjectChangeUserDisplayEmail: Set email address in FRADrive MailIntroChangeUserDisplayEmail displayEmail: The user mentioned above wants to set “#{displayEmail}” as their own email address. If you have not caused this email to be sent, please ignore it! MailTitleChangeUserDisplayEmail displayName: #{displayName} wants to set this email address as their own in FRADrive -CommCourseSubject: Course type message InvitationAcceptDecline: Accept/Decline invitation InvitationFromTip displayName: You are receiving this invitation because #{displayName} has caused it to be sent from within FRADrive. InvitationFromTipAnonymous: You are receiving this invitiation because an user who didn't log in has caused it to be send from within FRADrive. diff --git a/messages/uniworx/utils/navigation/menu/de-de-formal.msg b/messages/uniworx/utils/navigation/menu/de-de-formal.msg index 373cfc0e6..b306bfdfc 100644 --- a/messages/uniworx/utils/navigation/menu/de-de-formal.msg +++ b/messages/uniworx/utils/navigation/menu/de-de-formal.msg @@ -136,6 +136,7 @@ MenuLmsReport: Ergebnisse E‑Learning MenuFirms: Firmen MenuFirmUsers: Angehörige MenuFirmSupervisors: Ansprechpartner +MenuFirmsComm: Mitteilung MenuSap: SAP Schnittstelle diff --git a/messages/uniworx/utils/navigation/menu/en-eu.msg b/messages/uniworx/utils/navigation/menu/en-eu.msg index c46f047da..c8c18365f 100644 --- a/messages/uniworx/utils/navigation/menu/en-eu.msg +++ b/messages/uniworx/utils/navigation/menu/en-eu.msg @@ -137,6 +137,7 @@ MenuLmsReport: E‑learning Results MenuFirms: Companies MenuFirmUsers: Associates MenuFirmSupervisors: Supervisors +MenuFirmsComm: Messaging MenuSap: SAP Interface diff --git a/messages/uniworx/utils/utils/de-de-formal.msg b/messages/uniworx/utils/utils/de-de-formal.msg index 13bae27f0..c02cbe1fb 100644 --- a/messages/uniworx/utils/utils/de-de-formal.msg +++ b/messages/uniworx/utils/utils/de-de-formal.msg @@ -13,6 +13,7 @@ RGCourseUnacceptedApplicants: Nicht akzeptierte Bewerber:innen RecipientToggleAll: Alle/Keine CommCourseTestSubject customSubject@Text !ident-ok: [TEST] #{customSubject} UtilCommCourseSubject: Kursartmitteilung +UtilCommFirmSubject: Firmenmitteilung CommRecipients: Empfänger:innen CommRecipientsTip: Sie selbst erhalten immer eine Kopie der Nachricht CommRecipientsList: Die an Sie selbst verschickte Kopie der Nachricht wird, zu Archivierungszwecken, eine vollständige Liste aller Empfänger:innen enthalten. Die Empfängerliste wird im CSV-Format an die E-Mail angehängt. Andere Empfänger:innen erhalten die Liste nicht. Bitte entfernen Sie dementsprechend den Anhang bevor Sie die E-Mail weiterleiten oder anderweitig mit Dritten teilen. diff --git a/messages/uniworx/utils/utils/en-eu.msg b/messages/uniworx/utils/utils/en-eu.msg index 27a7eecad..1135dbade 100644 --- a/messages/uniworx/utils/utils/en-eu.msg +++ b/messages/uniworx/utils/utils/en-eu.msg @@ -13,6 +13,7 @@ RGCourseUnacceptedApplicants: Applicants not accepted RecipientToggleAll: All/None CommCourseTestSubject customSubject: [TEST] #{customSubject} UtilCommCourseSubject: Course type message +UtilCommFirmSubject: Company message CommRecipients: Recipients CommRecipientsTip: You always receive a copy of the message CommRecipientsList: For archival purposes the copy of the message sent to you will contain a complete list of all recipients. The list of recipients will be attached to the email in CSV-format. Other recipients do not receive the list. Thus, please remove the attachment before you forward the email or otherwise share it with third parties. diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index e53e6b3ae..0c8cbd1a2 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -124,9 +124,11 @@ breadcrumb ProblemAvsSynchR = i18nCrumb MsgProblemsAvsSynchHeading $ Just breadcrumb ProblemAvsErrorR = i18nCrumb MsgProblemsAvsErrorHeading $ Just ProblemAvsSynchR breadcrumb FirmAllR = i18nCrumb MsgMenuFirms Nothing +breadcrumb FirmsCommR = i18nCrumb MsgMenuFirmsComm $ Just FirmAllR breadcrumb FirmR{} = i18nCrumb MsgMenuAdminHeading $ Just FirmAllR -- TODO: change heading or remove breadcrumb FirmUsersR{} = i18nCrumb MsgMenuFirmUsers $ Just FirmAllR breadcrumb (FirmSupersR fsh)= i18nCrumb MsgMenuFirmSupervisors $ Just $ FirmUsersR fsh +breadcrumb (FirmCommR fsh)= i18nCrumb MsgMenuFirmsComm $ Just $ FirmUsersR fsh breadcrumb PrintCenterR = i18nCrumb MsgMenuApc Nothing breadcrumb PrintSendR = i18nCrumb MsgMenuPrintSend $ Just PrintCenterR diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index b6eb43e95..5087e68c1 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -771,7 +771,7 @@ postFirmSupersR fsh = do getFirmCommR, postFirmCommR :: CompanyShorthand -> Handler Html getFirmCommR = postFirmCommR -postFirmCommR fsh = handleFirmCommR (SomeRoute FirmUsersR) (Just fsh) +postFirmCommR fsh = handleFirmCommR (SomeRoute $ FirmUsersR fsh) (Just fsh) getFirmsCommR, postFirmsCommR :: Handler Html @@ -781,29 +781,36 @@ postFirmsCommR = handleFirmCommR (SomeRoute FirmAllR) Nothing handleFirmCommR :: SomeRoute UniWorX -> Maybe CompanyShorthand -> Handler Html handleFirmCommR ultDest mbFsh = do - let decrypt' :: CryptoUUIDUser -> Handler UserId - decrypt' = decrypt + let decryptUserId :: CryptoUUIDUser -> Handler UserId + decryptUserId = decrypt mbCid = CompanyKey <$> mbFsh - -- queryEmpys :: CompanyId -> Handler [UserId] + {- + queryEmpys :: CompanyId -> Handler [UserId] queryEmpys cid = E.unValue <<$>> runDB (E.select $ do (emp :& uc) <- E.from $ E.table @User `E.innerJoin` E.table @UserCompany `E.on` (\(emp :& uc) -> emp E.^. UserId E.==. uc E.^. UserCompanyUser) E.where_ $ uc E.^. UserCompanyCompany E.==. E.val cid return $ emp E.^. UserId ) + -} - chosen <- mapM decrypt =<< lookupGlobalGetParams GetRecipient -- retrieve selected users - empys <- maybe (return chosen) queryEmpys mbCid -- get all employees or stick with selected users, if no company was pre-selected (to limit choices) + selected <- mapM decryptUserId =<< lookupGlobalGetParams GetRecipient -- retrieve selected users + empys <- ifMaybeM mbCid selected (\cid -> -- get all employees or stick with selected users, if no company was pre-selected (to limit choices) + E.unValue <<$>> runDB (E.select $ do + (emp :& uc) <- E.from $ E.table @User `E.innerJoin` E.table @UserCompany `E.on` (\(emp :& uc) -> emp E.^. UserId E.==. uc E.^. UserCompanyUser) + E.where_ $ uc E.^. UserCompanyCompany E.==. E.val cid + return $ emp E.^. UserId + )) - cmpys <- runDB $ E.select $ do + cmpys <- E.unValue <<$>> runDB (E.select $ do cmpy <- E.from $ E.table @Company E.where_ $ E.exists $ do - usrCmpy <- E.table @UserCompany - E.where_ $ usrCmpy E.^. UserCompanyUser `E.in_` E.valList chosen + usrCmpy <- E.from $ E.table @UserCompany + E.where_ $ usrCmpy E.^. UserCompanyUser `E.in_` E.valList selected E.&&. usrCmpy E.^. UserCompanyCompany E.==. cmpy E.^. CompanyId return $ cmpy E.^.CompanyId - + ) let queryCmpy :: Bool -> CompanyId -> E.SqlQuery (E.SqlExpr (Entity User)) queryCmpy sORe acid = do (usr :& uc) <- E.from $ E.table @User `E.innerJoin` E.table @UserCompany `E.on` (\(emp :& uc) -> emp E.^. UserId E.==. uc E.^. UserCompanyUser) @@ -811,35 +818,30 @@ handleFirmCommR ultDest mbFsh = do E.&&. (if sORe then -- supervisors only E.exists $ do - usrSpr <- E.table @UserSupervisor + usrSpr <- E.from $ E.table @UserSupervisor E.where_ $ usrSpr E.^. UserSupervisorSupervisor E.==. usr E.^. UserId - E.&&. usrSpr E.^. UserSupervisorUser E.in_ E.valList empys - else -- chosen employees for this company only - usr E.^. UserId E.in_ E.valList empys - ) + E.&&. usrSpr E.^. UserSupervisorUser `E.in_` E.valList empys + else -- selected employees for this company only + usr E.^. UserId `E.in_` E.valList empys + ) + return usr commR CommunicationRoute { crHeading = SomeMessage $ maybe MsgFirmsNotification MsgFirmNotification mbFsh , crUltDest = ultDest - , crJobs = error "TODO" -- CONTINUE HERE -- :: Communication -> ConduitT () Job (YesodDB UniWorX) () - , crTestJobs = error "TODO" -- CONTINUE HERE -- :: Communication -> ConduitT () Job (YesodDB UniWorX) () + , crJobs = crJobsFirmCommunication mbFsh -- :: Communication -> ConduitT () Job (YesodDB UniWorX) () + , crTestJobs = crTestFirmCommunication mbFsh -- :: Communication -> ConduitT () Job (YesodDB UniWorX) () , crRecipientAuth = Nothing -- :: Maybe (UserId -> DB AuthResult) -- an optional filter passed to guardAuthResult , crRecipients = -- :: [(RecipientGroup, SqlQuery (SqlExpr (Entity User)))] [(RGFirmSupervisor $ unCompanyKey acid, queryCmpy True acid) | acid <- cmpys ] <> [(RGFirmEmployees $ unCompanyKey acid, queryCmpy False acid) | acid <- cmpys ] } -{- - ??? x - - Alle Supervisor von Leuten in X, gruppiert nach Firma - Alle Teilnehmer von X - - Ansprechpartner aus X - - Fred - Ansprechpartner aus Y - - Otto - Angestellte aus X - - Fred - - Meier + {- Auswahlbox für Mitteilung: + Wenn Firma gewählt, dann zeige: + Alle Supervisor von Leuten in X, gruppiert nach deren Firma + Alle Teilnehmer von X + Wenn keine Firma gewählt, dann zeige: + Alle Supervisor von gewählten Leuten, gruppiert nach deren Firma + Alle gewählten Personen, gruppiert nach deren Firma -} diff --git a/src/Handler/Utils/Communication.hs b/src/Handler/Utils/Communication.hs index 3ec2dd854..91e66d4b8 100644 --- a/src/Handler/Utils/Communication.hs +++ b/src/Handler/Utils/Communication.hs @@ -8,6 +8,7 @@ module Handler.Utils.Communication , Communication(..) , commR , crJobsCourseCommunication, crTestJobsCourseCommunication + , crJobsFirmCommunication, crTestFirmCommunication -- * Re-Exports , Job(..) ) where @@ -108,6 +109,28 @@ crTestJobsCourseCommunication jCourse comm = do crJobsCourseCommunication jCourse comm' .| C.filter ((== Right jSender) . jRecipientEmail) +crJobsFirmCommunication :: Maybe CompanyShorthand -> Communication -> ConduitT () Job (YesodDB UniWorX) () +crJobsFirmCommunication jCompany Communication{..} = do + jSender <- requireAuthId + let jMailContent = cContent + allRecipients = Set.toList $ Set.insert (Right jSender) cRecipients + jMailObjectUUID <- liftIO getRandom + jAllRecipientAddresses <- lift . fmap Set.fromList . forM allRecipients $ \case + Left email -> return . Address Nothing $ CI.original email + Right rid -> userAddress <$> getJust rid + forM_ allRecipients $ \jRecipientEmail -> + yield JobSendFirmCommunication{..} + +crTestFirmCommunication :: Maybe CompanyShorthand -> Communication -> ConduitT () Job (YesodDB UniWorX) () +crTestFirmCommunication jCompany comm = do + jSender <- requireAuthId + MsgRenderer mr <- getMsgRenderer + let comm' = comm & _cContent . _ccSubject %~ Just . mr . MsgCommCourseTestSubject . fromMaybe (mr MsgUtilCommFirmSubject) + crJobsFirmCommunication jCompany comm' .| C.filter ((== Right jSender) . jRecipientEmail) + + + + commR :: CommunicationRoute -> Handler Html commR CommunicationRoute{..} = do cUser <- maybeAuth @@ -133,7 +156,7 @@ commR CommunicationRoute{..} = do let lookupUser :: UserId -> User lookupUser lId - = entityVal . unsafeHead . filter ((== lId) . entityKey) $ concat (view _2 <$> suggestedRecipients) ++ chosenRecipients + = entityVal . unsafeHead . filter ((== lId) . entityKey) $ concatMap (view _2) suggestedRecipients ++ chosenRecipients let chosenRecipients' = Map.fromList $ [ ( (BoundedPosition $ RecipientGroup g, pos) diff --git a/src/Jobs/Handler/SendCourseCommunication.hs b/src/Jobs/Handler/SendCourseCommunication.hs index a8a629f60..fa4fbcb69 100644 --- a/src/Jobs/Handler/SendCourseCommunication.hs +++ b/src/Jobs/Handler/SendCourseCommunication.hs @@ -4,6 +4,7 @@ module Jobs.Handler.SendCourseCommunication ( dispatchJobSendCourseCommunication + , dispatchJobSendFirmCommunication ) where import Import @@ -37,7 +38,35 @@ dispatchJobSendCourseCommunication jRecipientEmail jAllRecipientAddresses jCours _mailFrom .= userAddressFrom sender addMailHeader "Cc" [st|#{mr MsgCommUndisclosedRecipients}:;|] addMailHeader "Auto-Submitted" "no" - setSubjectI . prependCourseTitle courseTerm courseSchool courseShorthand $ maybe (SomeMessage MsgCommCourseSubject) SomeMessage ccSubject + setSubjectI . prependCourseTitle courseTerm courseSchool courseShorthand $ maybe (SomeMessage MsgUtilCommCourseSubject) SomeMessage ccSubject + addHtmlMarkdownAlternatives ($(ihamletFile "templates/mail/courseCommunication.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX)) + forM_ ccAttachments $ addPart' . toMailPart + when (jRecipientEmail == Right jSender) $ + addPart' $ do + partIsAttachmentCsv MsgCommAllRecipients + toMailPart (MsgCommAllRecipientsSheet, toDefaultOrderedCsvRendered jAllRecipientAddresses) + + +dispatchJobSendFirmCommunication :: Either UserEmail UserId + -> Set Address + -> Maybe CompanyShorthand + -> UserId + -> UUID + -> CommunicationContent + -> JobHandler UniWorX +dispatchJobSendFirmCommunication jRecipientEmail jAllRecipientAddresses _jCompany jSender jMailObjectUUID CommunicationContent{..} = JobHandlerException $ do + -- (sender,mbComp) <- runDB $ (,) + -- <$> getJust jSender + -- <*> ifMaybeM jCompany Nothing get + sender <- runDB $ getJust jSender + either (\email -> mailT def . (assign _mailTo (pure . Address Nothing $ CI.original email) *>)) userMailT jRecipientEmail $ do + MsgRenderer mr <- getMailMsgRenderer + + void $ setMailObjectUUID jMailObjectUUID + _mailFrom .= userAddressFrom sender + addMailHeader "Cc" [st|#{mr MsgCommUndisclosedRecipients}:;|] + addMailHeader "Auto-Submitted" "no" + setSubjectI $ maybe (SomeMessage MsgUtilCommFirmSubject) SomeMessage ccSubject addHtmlMarkdownAlternatives ($(ihamletFile "templates/mail/courseCommunication.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX)) forM_ ccAttachments $ addPart' . toMailPart when (jRecipientEmail == Right jSender) $ diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs index a0717099a..6c665adb4 100644 --- a/src/Jobs/Types.hs +++ b/src/Jobs/Types.hs @@ -74,6 +74,13 @@ data Job , jMailObjectUUID :: UUID , jMailContent :: CommunicationContent } + | JobSendFirmCommunication { jRecipientEmail :: Either UserEmail UserId + , jAllRecipientAddresses :: Set Address + , jCompany :: Maybe CompanyShorthand + , jSender :: UserId + , jMailObjectUUID :: UUID + , jMailContent :: CommunicationContent + } | JobInvitation { jInviter :: Maybe UserId , jInvitee :: UserEmail , jInvitationUrl :: Text From a24e44efc9a20d3934d96640bb9e21b3b6d55b96 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 8 Nov 2023 13:16:09 +0100 Subject: [PATCH 35/50] fix(build): fix whitespace in routes --- routes | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/routes b/routes index 694386474..9c895eae7 100644 --- a/routes +++ b/routes @@ -116,10 +116,9 @@ /firms FirmAllR GET POST !supervisor /firms/comm FirmsCommR GET POST /firm/#CompanyShorthand FirmR GET POST +/firm/#CompanyShorthand/comm FirmCommR GET POST /firm/#CompanyShorthand/users FirmUsersR GET POST !supervisor /firm/#CompanyShorthand/supers FirmSupersR GET POST !supervisor -/firm/#CompanyShorthand/comm FirmCommR GET POST - /exam-office ExamOfficeR !exam-office: / EOExamsR GET POST !system-exam-office From 9ee80f8f7f8b7c65de8bb3540e5b6c4581978bff Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 8 Nov 2023 17:41:59 +0100 Subject: [PATCH 36/50] chore(lms): message action done for firm views --- .../uniworx/categories/firm/de-de-formal.msg | 6 ++++-- messages/uniworx/categories/firm/en-eu.msg | 4 +++- routes | 2 +- src/Handler/Firm.hs | 19 ++++++++++++++----- src/Handler/Utils/Communication.hs | 1 + .../communication/recipientLayout.hamlet | 4 ++++ 6 files changed, 27 insertions(+), 9 deletions(-) diff --git a/messages/uniworx/categories/firm/de-de-formal.msg b/messages/uniworx/categories/firm/de-de-formal.msg index 65e8291f1..c50120e92 100644 --- a/messages/uniworx/categories/firm/de-de-formal.msg +++ b/messages/uniworx/categories/firm/de-de-formal.msg @@ -16,7 +16,9 @@ FirmSuperActRMSuperAll: Als aktiven Ansprechpartner komplett entfernen FirmsNotification: Firmen Benachrichtigung versenden FirmNotification fsh@CompanyShorthand: Benachrichtigung an #{fsh} versenden FilterSupervisor: Hat aktiven Ansprechpartner -FilterSupervisorCompany fsh@CompanyShorthand: Hat aktiven Ansprechpartner, der #{fsh} angehört +FilterSupervisorCompany fsh@CompanyShorthand: Hat aktiven Ansprechpartner, #{fsh} der angehört FilterSupervisorForeign fsh@CompanyShorthand: Hat aktiven Ansprechpartner, der selbst nicht #{fsh} angehört FilterForeignSupervisor: Hat firmenfremde Ansprechpartner -FilterFirmPostalAddress: Postalische Firmenadresse vorhanden \ No newline at end of file +FilterFirmPostalAddress: Postalische Firmenadresse vorhanden +FirmSupervisorOf fsh@CompanyShorthand: Ansprechpartner #{fsh} angehörig +FirmEmployeeOf fsh@CompanyShorthand: Firmenangehörige #{fsh} \ No newline at end of file diff --git a/messages/uniworx/categories/firm/en-eu.msg b/messages/uniworx/categories/firm/en-eu.msg index 68e4add9b..3e24de5c5 100644 --- a/messages/uniworx/categories/firm/en-eu.msg +++ b/messages/uniworx/categories/firm/en-eu.msg @@ -19,4 +19,6 @@ FilterSupervisor: Has active supervisor FilterSupervisorCompany fsh: Has active company supervisor belonging to #{fsh} FilterSupervisorForeign fsh: Has active supervisor not belonging to #{fsh} FilterForeignSupervisor: Has company-external supervisors -FilterFirmPostalAddress: Postal company addresse known \ No newline at end of file +FilterFirmPostalAddress: Postal company addresse known +FirmSupervisorOf fsh@CompanyShorthand: Supervisors belonging to #{fsh} +FirmEmployeeOf fsh@CompanyShorthand: #{fsh} associated users \ No newline at end of file diff --git a/routes b/routes index 9c895eae7..931c52909 100644 --- a/routes +++ b/routes @@ -116,7 +116,7 @@ /firms FirmAllR GET POST !supervisor /firms/comm FirmsCommR GET POST /firm/#CompanyShorthand FirmR GET POST -/firm/#CompanyShorthand/comm FirmCommR GET POST +/firm/#CompanyShorthand/comm FirmCommR GET POST /firm/#CompanyShorthand/users FirmUsersR GET POST !supervisor /firm/#CompanyShorthand/supers FirmSupersR GET POST !supervisor diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 5087e68c1..9e6cdd55e 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -366,9 +366,15 @@ 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" + formResult firmRes $ \case + (FirmAllActResetSupervisionData, fids) -> addMessage Info $ text2Html $ "Reset " <> tshow (length fids) <> " companies. TODO" + (FirmAllActNotifyData , fids) -> do + usrs <- runDB $ E.select $ E.distinct $ do + (usr :& uc) <- E.from $ E.table @User `E.innerJoin` E.table @UserCompany `E.on` (\(emp :& uc) -> emp E.^. UserId E.==. uc E.^. UserCompanyUser) + E.where_ $ uc E.^. UserCompanyCompany `E.in_` E.valList (Set.toList fids) + return $ usr E.^. UserId + cuids <- traverse (encrypt . E.unValue) usrs :: Handler [CryptoUUIDUser] + redirect (FirmsCommR, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids]) siteLayoutMsg MsgMenuFirms $ do setTitleI MsgMenuFirms $(i18nWidgetFile "firm-all") @@ -742,9 +748,12 @@ postFirmSupersR fsh = do <*> mkFirmSuperTable isAdmin fshId formResult fsprRes $ \case - (FirmSuperActNotifyData , fids) -> addMessage Info $ text2Html $ "Notify " <> tshow (length fids) <> " supervisors. TODO" (FirmSuperActRMSuperDefData, fids) -> addMessage Info $ text2Html $ "Remove " <> tshow (length fids) <> " default supervisors. TODO" (FirmSuperActRMSuperAllData, fids) -> addMessage Info $ text2Html $ "Make " <> tshow (length fids) <> " default and active supervisors. TODO" + (FirmSuperActNotifyData , fids) -> do + cuids <- traverse encrypt $ Set.toList fids :: Handler [CryptoUUIDUser] + redirect (FirmCommR fsh, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids]) + siteLayout (citext2widget fsh) $ do setTitle $ citext2Html fsh @@ -834,7 +843,7 @@ handleFirmCommR ultDest mbFsh = do , crRecipientAuth = Nothing -- :: Maybe (UserId -> DB AuthResult) -- an optional filter passed to guardAuthResult , crRecipients = -- :: [(RecipientGroup, SqlQuery (SqlExpr (Entity User)))] [(RGFirmSupervisor $ unCompanyKey acid, queryCmpy True acid) | acid <- cmpys ] <> - [(RGFirmEmployees $ unCompanyKey acid, queryCmpy False acid) | acid <- cmpys ] + [(RGFirmEmployees $ unCompanyKey acid, queryCmpy False acid) | acid <- cmpys, maybe True (acid ==) mbCid] } {- Auswahlbox für Mitteilung: diff --git a/src/Handler/Utils/Communication.hs b/src/Handler/Utils/Communication.hs index 91e66d4b8..893b22d14 100644 --- a/src/Handler/Utils/Communication.hs +++ b/src/Handler/Utils/Communication.hs @@ -28,6 +28,7 @@ import qualified Data.Conduit.Combinators as C data RecipientGroup = RGCourseParticipants | RGCourseLecturers | RGCourseCorrectors | RGCourseTutors | RGCourseParticipantsInTutorial | RGCourseUnacceptedApplicants + -- WARNING: no RenderMessage instance, but a pattern match in templates/widgets/communication/recipientLayout.hamlet that needs to be extended | RGTutorialParticipants CryptoUUIDTutorial | RGExamRegistered CryptoUUIDExam | RGSheetSubmittor CryptoUUIDSheet diff --git a/templates/widgets/communication/recipientLayout.hamlet b/templates/widgets/communication/recipientLayout.hamlet index 7b7f188d1..9dc2beea0 100644 --- a/templates/widgets/communication/recipientLayout.hamlet +++ b/templates/widgets/communication/recipientLayout.hamlet @@ -31,6 +31,10 @@ $if not (null activeCategories) ^{rgSheetSubmittorCaption sid} $of RecipientGroup RGCourseUnacceptedApplicants _{MsgRGCourseUnacceptedApplicants} + $of RecipientGroup (RGFirmSupervisor fsh) + _{MsgFirmSupervisorOf fsh} + $of RecipientGroup (RGFirmEmployees fsh) + _{MsgFirmEmployeeOf fsh} $if hasContent category
                                From 5d8802732a5dbebe99e5c2eef383039d96e8a6da Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 9 Nov 2023 18:07:39 +0100 Subject: [PATCH 37/50] debug(firm): attempt to find error when using firm communication --- package.yaml | 1 + src/Handler/Firm.hs | 4 ++-- src/Handler/Utils/Communication.hs | 10 ++++++++-- 3 files changed, 11 insertions(+), 4 deletions(-) diff --git a/package.yaml b/package.yaml index de481c5b4..fad286442 100644 --- a/package.yaml +++ b/package.yaml @@ -259,6 +259,7 @@ ghc-options: - -j - -freduction-depth=0 - -fprof-auto-calls + - -g when: - condition: flag(pedantic) ghc-options: diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 9e6cdd55e..09da67f7d 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -2,7 +2,7 @@ -- -- SPDX-License-Identifier: AGPL-3.0-or-later -{-# OPTIONS -Wno-unused-top-binds -Wno-unused-imports #-} -- TODO: remove me, for debugging only +{-# OPTIONS -Wno-unused-top-binds -Wno-unused-imports -Wno-unused-binds #-} -- TODO: remove me, for debugging only {-# OPTIONS_GHC -fno-warn-orphans #-} -- needed for HasEntity instances {-# LANGUAGE TypeApplications #-} @@ -804,7 +804,7 @@ handleFirmCommR ultDest mbFsh = do ) -} - selected <- mapM decryptUserId =<< lookupGlobalGetParams GetRecipient -- retrieve selected users + selected <- mapM decryptUserId =<< lookupGlobalGetParams GetRecipient -- retrieve selected users empys <- ifMaybeM mbCid selected (\cid -> -- get all employees or stick with selected users, if no company was pre-selected (to limit choices) E.unValue <<$>> runDB (E.select $ do (emp :& uc) <- E.from $ E.table @User `E.innerJoin` E.table @UserCompany `E.on` (\(emp :& uc) -> emp E.^. UserId E.==. uc E.^. UserCompanyUser) diff --git a/src/Handler/Utils/Communication.hs b/src/Handler/Utils/Communication.hs index 893b22d14..7e81ba69a 100644 --- a/src/Handler/Utils/Communication.hs +++ b/src/Handler/Utils/Communication.hs @@ -134,6 +134,7 @@ crTestFirmCommunication jCompany comm = do commR :: CommunicationRoute -> Handler Html commR CommunicationRoute{..} = do + $logWarnS "COMM" "Communication handleer started" cUser <- maybeAuth MsgRenderer mr <- getMsgRenderer @@ -153,6 +154,7 @@ commR CommunicationRoute{..} = do chosen' <- fmap (maybe id cons cUser . catMaybes) $ mapM decrypt' =<< lookupGlobalGetParams GetRecipient return (suggested, chosen') + $logWarnS "COMM" "Communication handler DB done" let lookupUser :: UserId -> User @@ -236,6 +238,7 @@ commR CommunicationRoute{..} = do recipientsListMsg <- messageI Info MsgCommRecipientsList + $logWarnS "COMM" "Communication handler some definitions done" attachmentsMaxSize <- getsYesod $ view _appCommunicationAttachmentsMaxSize let attachmentField = genericFileField $ return FileField { fieldIdent = Nothing @@ -246,6 +249,7 @@ commR CommunicationRoute{..} = do , fieldMaxFileSize = Nothing, fieldMaxCumulativeSize = attachmentsMaxSize , fieldAllEmptyOk = True } + $logWarnS "COMM" "Communication handler some parameters done" -SEEN ((commRes,commWdgt),commEncoding) <- runFormPost . identifyForm FIDCommunication . withButtonForm' universeF . renderAForm FormStandard $ Communication <$> recipientAForm <* aformMessage recipientsListMsg @@ -253,7 +257,8 @@ commR CommunicationRoute{..} = do <$> aopt textField (fslI MsgCommSubject & addAttr "uw-enter-as-tab" "") Nothing <*> (markupOutput <$> areq htmlField (fslI MsgCommBody) Nothing) <*> fmap fold (aopt (convertFieldM (runConduit . (.| C.foldMap Set.singleton)) yieldMany attachmentField) (fslI MsgCommAttachments & setTooltip MsgCommAttachmentsTip) Nothing) - ) + ) + $logWarnS "COMM" "Communication handler run form post done" -- NOT SEEN formResult commRes $ \case (comm, BtnCommunicationSend) -> do runDBJobs . runConduit $ transPipe (mapReaderT lift) (crJobs comm) .| sinkDBJobs @@ -262,13 +267,14 @@ commR CommunicationRoute{..} = do (comm, BtnCommunicationTest) -> do runDBJobs . runConduit $ transPipe (mapReaderT lift) (crTestJobs comm) .| sinkDBJobs addMessageI Info MsgCommTestSuccess - + $logWarnS "COMM" "Communication handler form result done" let formWdgt = wrapForm commWdgt def { formMethod = POST , formAction = SomeRoute <$> mbCurrentRoute , formEncoding = commEncoding , formSubmit = FormNoSubmit } + $logWarnS "COMM" "Communication handler finished" siteLayoutMsg crHeading $ do setTitleI crHeading let commTestTip = $(i18nWidgetFile "comm-test-tip") From 63e6d94df2fd1ce879cb59d14bc854f3c2556586 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 9 Nov 2023 17:02:17 +0000 Subject: [PATCH 38/50] fix(firm): add sql indices for frequent filters to greatly enhance performance --- src/Model/Migration/Definitions.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/Model/Migration/Definitions.hs b/src/Model/Migration/Definitions.hs index 5f9940449..fd2e9c810 100644 --- a/src/Model/Migration/Definitions.hs +++ b/src/Model/Migration/Definitions.hs @@ -141,6 +141,8 @@ migrateManual = do , ("idx_print_job_apc_ident" ,"CREATE INDEX idx_print_job_apc_ident ON \"print_job\" (\"apc_ident\")") , ("idx_user_avs_card_person_id" ,"CREATE INDEX idx_user_avs_card_person_id ON \"user_avs_card\" (\"person_id\")") , ("idx_lms_report_log_q_ident_time" ,"CREATE INDEX idx_lms_report_log_q_ident_time ON \"lms_report_log\" (\"qualification\",\"ident\",\"timestamp\")") + , ("idx_user_company_company" ,"CREATE INDEX idx_user_company_company ON \"user_company\" (\"company\")") -- composed index from unique cannot be used for frequently used filters on company + , ("idx_user_supervisor_user" ,"CREATE INDEX idx_user_supervisor_user ON \"user_supervisor\" (\"user\")") -- composed index from unique cannot be used for frequently used filters on user ] where addIndex :: Text -> Sql -> Migration From 674f6fd81f374e6e9d1719b611444a8d735c2f85 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 10 Nov 2023 08:01:02 +0000 Subject: [PATCH 39/50] fix(build) --- src/Handler/Utils/Communication.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Handler/Utils/Communication.hs b/src/Handler/Utils/Communication.hs index 7e81ba69a..ee7cb9ae6 100644 --- a/src/Handler/Utils/Communication.hs +++ b/src/Handler/Utils/Communication.hs @@ -249,7 +249,7 @@ commR CommunicationRoute{..} = do , fieldMaxFileSize = Nothing, fieldMaxCumulativeSize = attachmentsMaxSize , fieldAllEmptyOk = True } - $logWarnS "COMM" "Communication handler some parameters done" -SEEN + $logWarnS "COMM" "Communication handler some parameters done" -- SEEN ((commRes,commWdgt),commEncoding) <- runFormPost . identifyForm FIDCommunication . withButtonForm' universeF . renderAForm FormStandard $ Communication <$> recipientAForm <* aformMessage recipientsListMsg @@ -258,7 +258,7 @@ commR CommunicationRoute{..} = do <*> (markupOutput <$> areq htmlField (fslI MsgCommBody) Nothing) <*> fmap fold (aopt (convertFieldM (runConduit . (.| C.foldMap Set.singleton)) yieldMany attachmentField) (fslI MsgCommAttachments & setTooltip MsgCommAttachmentsTip) Nothing) ) - $logWarnS "COMM" "Communication handler run form post done" -- NOT SEEN + $logWarnS "COMM" "Communication handler run form post done" -- NOT SEEN ANYMORE formResult commRes $ \case (comm, BtnCommunicationSend) -> do runDBJobs . runConduit $ transPipe (mapReaderT lift) (crJobs comm) .| sinkDBJobs From 71c290996da79ac3f2d5a0644ec421f703beb2a6 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 10 Nov 2023 17:00:10 +0100 Subject: [PATCH 40/50] refactor(firm): performance foreign-supervisor filter --- src/Handler/Firm.hs | 36 ++++++++++++++++++++++++------------ 1 file changed, 24 insertions(+), 12 deletions(-) diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 09da67f7d..ce9b2afea 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -298,18 +298,30 @@ mkFirmAllTable isAdmin uid = do ) ) , single ("foreign-supervisor", FilterColumn $ \row (getLast -> criterion) -> - let checkSuper = do - usrSpr <- E.from $ E.table @UserSupervisor - E.where_ $ E.notExists (do - spr <- E.from $ E.table @UserCompany - E.where_ $ spr E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId - E.&&. spr E.^. UserCompanyUser E.==. usrSpr E.^. UserSupervisorSupervisor - ) E.&&. E.exists (do - usr <- E.from $ E.table @UserCompany - E.where_ $ usr E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId - E.&&. usr E.^. UserCompanyUser E.==. usrSpr E.^. UserSupervisorUser - ) - in case criterion of + -- let checkSuper = do + -- usrSpr <- E.from $ E.table @UserSupervisor + -- E.where_ $ E.notExists (do + -- spr <- E.from $ E.table @UserCompany + -- E.where_ $ spr E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId + -- E.&&. spr E.^. UserCompanyUser E.==. usrSpr E.^. UserSupervisorSupervisor + -- ) E.&&. E.exists (do + -- usr <- E.from $ E.table @UserCompany + -- E.where_ $ usr E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId + -- E.&&. usr E.^. UserCompanyUser E.==. usrSpr E.^. UserSupervisorUser + -- ) + let checkSuper = do + usr <- E.from $ E.table @UserCompany + E.where_ $ usr E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId + E.&&. E.exists (do + usrSpr <- E.from $ E.table @UserSupervisor + E.where_ $ usrSpr E.^. UserSupervisorUser E.==. usr E.^. UserCompanyUser + E.&&. E.notExists (do + sprCmp <- E.from $ E.table @UserCompany + E.where_ $ sprCmp E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId + E.&&. sprCmp E.^. UserCompanyUser E.==. usrSpr E.^. UserSupervisorSupervisor + ) + ) + in case criterion of Nothing -> E.true Just True -> E.exists checkSuper Just False -> E.notExists checkSuper From a6fb00f072c6dc92e2d5c85cbc1bd849493bdb99 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 13 Nov 2023 17:10:27 +0100 Subject: [PATCH 41/50] minor refactor --- src/Handler/Firm.hs | 2 +- src/Handler/Utils/Communication.hs | 32 ++++++++++--------- .../Handler/SendNotification/Qualification.hs | 2 +- 3 files changed, 19 insertions(+), 17 deletions(-) diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index ce9b2afea..25f52f89f 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -298,7 +298,7 @@ mkFirmAllTable isAdmin uid = do ) ) , single ("foreign-supervisor", FilterColumn $ \row (getLast -> criterion) -> - -- let checkSuper = do + -- let checkSuper = do -- expensive -- usrSpr <- E.from $ E.table @UserSupervisor -- E.where_ $ E.notExists (do -- spr <- E.from $ E.table @UserCompany diff --git a/src/Handler/Utils/Communication.hs b/src/Handler/Utils/Communication.hs index ee7cb9ae6..8da181737 100644 --- a/src/Handler/Utils/Communication.hs +++ b/src/Handler/Utils/Communication.hs @@ -239,25 +239,27 @@ commR CommunicationRoute{..} = do recipientsListMsg <- messageI Info MsgCommRecipientsList $logWarnS "COMM" "Communication handler some definitions done" - attachmentsMaxSize <- getsYesod $ view _appCommunicationAttachmentsMaxSize - let attachmentField = genericFileField $ return FileField - { fieldIdent = Nothing - , fieldUnpackZips = FileFieldUserOption True False - , fieldMultiple = True - , fieldRestrictExtensions = Nothing - , fieldAdditionalFiles = _FileReferenceFileReferenceTitleMap # Map.empty - , fieldMaxFileSize = Nothing, fieldMaxCumulativeSize = attachmentsMaxSize - , fieldAllEmptyOk = True - } + -- attachmentsMaxSize <- getsYesod $ view _appCommunicationAttachmentsMaxSize + -- let attachmentField = genericFileField $ return FileField + -- { fieldIdent = Nothing + -- , fieldUnpackZips = FileFieldUserOption True False + -- , fieldMultiple = True + -- , fieldRestrictExtensions = Nothing + -- , fieldAdditionalFiles = _FileReferenceFileReferenceTitleMap # Map.empty + -- , fieldMaxFileSize = Nothing, fieldMaxCumulativeSize = attachmentsMaxSize + -- , fieldAllEmptyOk = True + -- } $logWarnS "COMM" "Communication handler some parameters done" -- SEEN ((commRes,commWdgt),commEncoding) <- runFormPost . identifyForm FIDCommunication . withButtonForm' universeF . renderAForm FormStandard $ Communication <$> recipientAForm <* aformMessage recipientsListMsg - <*> ( CommunicationContent - <$> aopt textField (fslI MsgCommSubject & addAttr "uw-enter-as-tab" "") Nothing - <*> (markupOutput <$> areq htmlField (fslI MsgCommBody) Nothing) - <*> fmap fold (aopt (convertFieldM (runConduit . (.| C.foldMap Set.singleton)) yieldMany attachmentField) (fslI MsgCommAttachments & setTooltip MsgCommAttachmentsTip) Nothing) - ) + <*> (pure (CommunicationContent (Just "subject") (text2Html "body") Set.empty) :: AForm Handler CommunicationContent) + -- <*> ( CommunicationContent + -- <$> aopt textField (fslI MsgCommSubject & addAttr "uw-enter-as-tab" "") Nothing + -- <*> (markupOutput <$> areq htmlField (fslI MsgCommBody) Nothing) + -- <*> fmap fold (aopt (convertFieldM (runConduit . (.| C.foldMap Set.singleton)) yieldMany attachmentField) + -- (fslI MsgCommAttachments & setTooltip MsgCommAttachmentsTip) Nothing) + -- ) $logWarnS "COMM" "Communication handler run form post done" -- NOT SEEN ANYMORE formResult commRes $ \case (comm, BtnCommunicationSend) -> do diff --git a/src/Jobs/Handler/SendNotification/Qualification.hs b/src/Jobs/Handler/SendNotification/Qualification.hs index d5d8d595e..e169f1552 100644 --- a/src/Jobs/Handler/SendNotification/Qualification.hs +++ b/src/Jobs/Handler/SendNotification/Qualification.hs @@ -81,7 +81,7 @@ dispatchNotificationQualificationExpired nQualification jRecipient = do $logInfoS "LMS" $ "Notified " <> tshow encRecipient <> " about expired qualification " <> qname else $logErrorS "LMS" $ "Failed to notify " <> tshow encRecipient <> " about expired qualification " <> qname - else $logErrorS "LMS" $ "Suppressed repeated notification " <> tshow encRecipient <> " about expired qualification " <> qname + else $logInfoS "LMS" $ "Suppressed repeated notification " <> tshow encRecipient <> " about expired qualification " <> qname _ -> $logErrorS "LMS" $ "Failed to notify " <> tshow encRecipient <> " about expired qualification " <> tshow nQualification From 25c4ba71360de04959039a4d7afe742927eb0b46 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 13 Nov 2023 18:07:30 +0100 Subject: [PATCH 42/50] chore(messaging): add debugging statements --- src/Handler/Firm.hs | 3 ++- src/Handler/Utils/Communication.hs | 6 +++--- 2 files changed, 5 insertions(+), 4 deletions(-) diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 25f52f89f..2c428eb7e 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -816,7 +816,8 @@ handleFirmCommR ultDest mbFsh = do ) -} - selected <- mapM decryptUserId =<< lookupGlobalGetParams GetRecipient -- retrieve selected users + selected <- mapM decryptUserId =<< lookupGlobalGetParams GetRecipient -- retrieve selected users + empys <- ifMaybeM mbCid selected (\cid -> -- get all employees or stick with selected users, if no company was pre-selected (to limit choices) E.unValue <<$>> runDB (E.select $ do (emp :& uc) <- E.from $ E.table @User `E.innerJoin` E.table @UserCompany `E.on` (\(emp :& uc) -> emp E.^. UserId E.==. uc E.^. UserCompanyUser) diff --git a/src/Handler/Utils/Communication.hs b/src/Handler/Utils/Communication.hs index 8da181737..bd222f25c 100644 --- a/src/Handler/Utils/Communication.hs +++ b/src/Handler/Utils/Communication.hs @@ -152,14 +152,14 @@ commR CommunicationRoute{..} = do getEntity uid chosen' <- fmap (maybe id cons cUser . catMaybes) $ mapM decrypt' =<< lookupGlobalGetParams GetRecipient - + return (suggested, chosen') - $logWarnS "COMM" "Communication handler DB done" + $logWarnS "COMM" ("Communication handler DB done with (sugg:" <> tshow (length suggestedRecipients) <> ", chosen:" <> tshow (length chosenRecipients) <> ")") let lookupUser :: UserId -> User lookupUser lId - = entityVal . unsafeHead . filter ((== lId) . entityKey) $ concatMap (view _2) suggestedRecipients ++ chosenRecipients + = entityVal . headDef (error $ "this is it" <> show lId) . filter ((== lId) . entityKey) $ concatMap (view _2) suggestedRecipients ++ chosenRecipients let chosenRecipients' = Map.fromList $ [ ( (BoundedPosition $ RecipientGroup g, pos) From 42ff02d27e431a8855db7bf3046a1b74d297e6da Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 14 Nov 2023 12:57:51 +0100 Subject: [PATCH 43/50] fix(firm): sending messages works, but not test messages --- src/Handler/Utils/Communication.hs | 68 ++++++++++++++---------------- 1 file changed, 32 insertions(+), 36 deletions(-) diff --git a/src/Handler/Utils/Communication.hs b/src/Handler/Utils/Communication.hs index bd222f25c..28473dfc1 100644 --- a/src/Handler/Utils/Communication.hs +++ b/src/Handler/Utils/Communication.hs @@ -134,32 +134,29 @@ crTestFirmCommunication jCompany comm = do commR :: CommunicationRoute -> Handler Html commR CommunicationRoute{..} = do - $logWarnS "COMM" "Communication handleer started" - cUser <- maybeAuth - - MsgRenderer mr <- getMsgRenderer - mbCurrentRoute <- getCurrentRoute - - (suggestedRecipients, chosenRecipients) <- runDB $ do - suggestedUsers <- for crRecipients $ \(_,user) -> E.select user - let suggested = zip (view _1 <$> crRecipients) suggestedUsers - - let - decrypt' :: CryptoUUIDUser -> DB (Maybe (Entity User)) + let decrypt' :: CryptoUUIDUser -> DB (Maybe (Entity User)) decrypt' cID = do uid <- decrypt cID whenIsJust crRecipientAuth $ guardAuthResult <=< ($ uid) getEntity uid - chosen' <- fmap (maybe id cons cUser . catMaybes) $ mapM decrypt' =<< lookupGlobalGetParams GetRecipient - - return (suggested, chosen') + cUser <- maybeAuth + + MsgRenderer mr <- getMsgRenderer + mbCurrentRoute <- getCurrentRoute + + (suggestedRecipients, chosenRecipients) <- runDB $ (,) + <$> for crRecipients (\(grp,usrQry) -> (grp,) <$> E.select usrQry) + <*> fmap (maybe id cons cUser . catMaybes) (mapM decrypt' =<< lookupGlobalGetParams GetRecipient) $logWarnS "COMM" ("Communication handler DB done with (sugg:" <> tshow (length suggestedRecipients) <> ", chosen:" <> tshow (length chosenRecipients) <> ")") let - lookupUser :: UserId -> User - lookupUser lId - = entityVal . headDef (error $ "this is it" <> show lId) . filter ((== lId) . entityKey) $ concatMap (view _2) suggestedRecipients ++ chosenRecipients + lookupUser :: UserId -> (UserDisplayName,UserSurname) + lookupUser = + let usrMap = Map.fromList $ fmap (\u -> (entityKey u, entityVal u)) $ chosenRecipients ++ concatMap (view _2) suggestedRecipients + usrNames Nothing = ("???","???") -- this case only happens during runFormPost when POST Data is present and no form is displayed + usrNames (Just User{userDisplayName, userSurname}) = (userDisplayName, userSurname) + in usrNames . flip Map.lookup usrMap let chosenRecipients' = Map.fromList $ [ ( (BoundedPosition $ RecipientGroup g, pos) @@ -187,7 +184,7 @@ commR CommunicationRoute{..} = do miCell _ (Left (CI.original -> email)) initRes nudge csrf = do (tickRes, tickView) <- mpreq checkBoxField ("" & addName (nudge "tick")) $ initRes <|> Just True return (tickRes, $(widgetFile "widgets/communication/recipientEmail")) - miCell _ (Right uid@(lookupUser -> User{..})) initRes nudge csrf = do + miCell _ (Right uid@(lookupUser -> (userDisplayName, userSurname))) initRes nudge csrf = do (tickRes, tickView) <- if | fmap entityKey cUser == Just uid -> mforced checkBoxField ("" & addName (nudge "tick")) True @@ -239,27 +236,26 @@ commR CommunicationRoute{..} = do recipientsListMsg <- messageI Info MsgCommRecipientsList $logWarnS "COMM" "Communication handler some definitions done" - -- attachmentsMaxSize <- getsYesod $ view _appCommunicationAttachmentsMaxSize - -- let attachmentField = genericFileField $ return FileField - -- { fieldIdent = Nothing - -- , fieldUnpackZips = FileFieldUserOption True False - -- , fieldMultiple = True - -- , fieldRestrictExtensions = Nothing - -- , fieldAdditionalFiles = _FileReferenceFileReferenceTitleMap # Map.empty - -- , fieldMaxFileSize = Nothing, fieldMaxCumulativeSize = attachmentsMaxSize - -- , fieldAllEmptyOk = True - -- } + attachmentsMaxSize <- getsYesod $ view _appCommunicationAttachmentsMaxSize + let attachmentField = genericFileField $ return FileField + { fieldIdent = Nothing + , fieldUnpackZips = FileFieldUserOption True False + , fieldMultiple = True + , fieldRestrictExtensions = Nothing + , fieldAdditionalFiles = _FileReferenceFileReferenceTitleMap # Map.empty + , fieldMaxFileSize = Nothing, fieldMaxCumulativeSize = attachmentsMaxSize + , fieldAllEmptyOk = True + } $logWarnS "COMM" "Communication handler some parameters done" -- SEEN ((commRes,commWdgt),commEncoding) <- runFormPost . identifyForm FIDCommunication . withButtonForm' universeF . renderAForm FormStandard $ Communication <$> recipientAForm <* aformMessage recipientsListMsg - <*> (pure (CommunicationContent (Just "subject") (text2Html "body") Set.empty) :: AForm Handler CommunicationContent) - -- <*> ( CommunicationContent - -- <$> aopt textField (fslI MsgCommSubject & addAttr "uw-enter-as-tab" "") Nothing - -- <*> (markupOutput <$> areq htmlField (fslI MsgCommBody) Nothing) - -- <*> fmap fold (aopt (convertFieldM (runConduit . (.| C.foldMap Set.singleton)) yieldMany attachmentField) - -- (fslI MsgCommAttachments & setTooltip MsgCommAttachmentsTip) Nothing) - -- ) + <*> ( CommunicationContent + <$> aopt textField (fslI MsgCommSubject & addAttr "uw-enter-as-tab" "") Nothing + <*> (markupOutput <$> areq htmlField (fslI MsgCommBody) Nothing) + <*> fmap fold (aopt (convertFieldM (runConduit . (.| C.foldMap Set.singleton)) yieldMany attachmentField) + (fslI MsgCommAttachments & setTooltip MsgCommAttachmentsTip) Nothing) + ) $logWarnS "COMM" "Communication handler run form post done" -- NOT SEEN ANYMORE formResult commRes $ \case (comm, BtnCommunicationSend) -> do From 65cdc8ddfef19eb3a5578c536575f91ba9717a13 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 14 Nov 2023 16:55:14 +0100 Subject: [PATCH 44/50] fix(firm): firm messaging now works fine --- .../uniworx/categories/firm/de-de-formal.msg | 1 + messages/uniworx/categories/firm/en-eu.msg | 1 + routes | 2 +- src/Foundation/Navigation.hs | 2 +- src/Handler/Firm.hs | 110 ++++++----- src/Handler/Utils/Communication.hs | 187 +++++++++--------- src/Jobs/Handler/SendCourseCommunication.hs | 4 +- src/Jobs/Types.hs | 2 +- src/Model/Types/Common.hs | 3 +- .../communication/recipientLayout.hamlet | 2 + 10 files changed, 160 insertions(+), 154 deletions(-) diff --git a/messages/uniworx/categories/firm/de-de-formal.msg b/messages/uniworx/categories/firm/de-de-formal.msg index c50120e92..3e27e0ba5 100644 --- a/messages/uniworx/categories/firm/de-de-formal.msg +++ b/messages/uniworx/categories/firm/de-de-formal.msg @@ -21,4 +21,5 @@ FilterSupervisorForeign fsh@CompanyShorthand: Hat aktiven Ansprechpartner, der s FilterForeignSupervisor: Hat firmenfremde Ansprechpartner FilterFirmPostalAddress: Postalische Firmenadresse vorhanden FirmSupervisorOf fsh@CompanyShorthand: Ansprechpartner #{fsh} angehörig +FirmSupervisorIndependent: Ansprechpartner ohne jegliche Firmenzugehörigkeit FirmEmployeeOf fsh@CompanyShorthand: Firmenangehörige #{fsh} \ No newline at end of file diff --git a/messages/uniworx/categories/firm/en-eu.msg b/messages/uniworx/categories/firm/en-eu.msg index 3e24de5c5..ddef25a86 100644 --- a/messages/uniworx/categories/firm/en-eu.msg +++ b/messages/uniworx/categories/firm/en-eu.msg @@ -21,4 +21,5 @@ FilterSupervisorForeign fsh: Has active supervisor not belonging to #{fsh} FilterForeignSupervisor: Has company-external supervisors FilterFirmPostalAddress: Postal company addresse known FirmSupervisorOf fsh@CompanyShorthand: Supervisors belonging to #{fsh} +FirmSupervisorIndependent: Independent supervisors FirmEmployeeOf fsh@CompanyShorthand: #{fsh} associated users \ No newline at end of file diff --git a/routes b/routes index 931c52909..d341734ac 100644 --- a/routes +++ b/routes @@ -114,7 +114,7 @@ /for/#CryptoUUIDUser/user/profile ForProfileDataR GET !supervisor !self /firms FirmAllR GET POST !supervisor -/firms/comm FirmsCommR GET POST +/firms/comm/+Companies FirmsCommR GET POST /firm/#CompanyShorthand FirmR GET POST /firm/#CompanyShorthand/comm FirmCommR GET POST /firm/#CompanyShorthand/users FirmUsersR GET POST !supervisor diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index 0c8cbd1a2..b029cc0ee 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -124,7 +124,7 @@ breadcrumb ProblemAvsSynchR = i18nCrumb MsgProblemsAvsSynchHeading $ Just breadcrumb ProblemAvsErrorR = i18nCrumb MsgProblemsAvsErrorHeading $ Just ProblemAvsSynchR breadcrumb FirmAllR = i18nCrumb MsgMenuFirms Nothing -breadcrumb FirmsCommR = i18nCrumb MsgMenuFirmsComm $ Just FirmAllR +breadcrumb FirmsCommR{} = i18nCrumb MsgMenuFirmsComm $ Just FirmAllR breadcrumb FirmR{} = i18nCrumb MsgMenuAdminHeading $ Just FirmAllR -- TODO: change heading or remove breadcrumb FirmUsersR{} = i18nCrumb MsgMenuFirmUsers $ Just FirmAllR breadcrumb (FirmSupersR fsh)= i18nCrumb MsgMenuFirmSupervisors $ Just $ FirmUsersR fsh diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 2c428eb7e..bfcb14794 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -380,13 +380,13 @@ postFirmAllR = do (firmRes, firmTable) <- runDB $ mkFirmAllTable isAdmin uid -- filters to associated companies for non-admins formResult firmRes $ \case (FirmAllActResetSupervisionData, fids) -> addMessage Info $ text2Html $ "Reset " <> tshow (length fids) <> " companies. TODO" - (FirmAllActNotifyData , fids) -> do + (FirmAllActNotifyData , Set.toList -> fids) -> do usrs <- runDB $ E.select $ E.distinct $ do (usr :& uc) <- E.from $ E.table @User `E.innerJoin` E.table @UserCompany `E.on` (\(emp :& uc) -> emp E.^. UserId E.==. uc E.^. UserCompanyUser) - E.where_ $ uc E.^. UserCompanyCompany `E.in_` E.valList (Set.toList fids) + E.where_ $ uc E.^. UserCompanyCompany `E.in_` E.valList fids return $ usr E.^. UserId cuids <- traverse (encrypt . E.unValue) usrs :: Handler [CryptoUUIDUser] - redirect (FirmsCommR, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids]) + redirect (FirmsCommR $ fmap unCompanyKey fids, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids]) siteLayoutMsg MsgMenuFirms $ do setTitleI MsgMenuFirms $(i18nWidgetFile "firm-all") @@ -792,71 +792,77 @@ postFirmSupersR fsh = do getFirmCommR, postFirmCommR :: CompanyShorthand -> Handler Html getFirmCommR = postFirmCommR -postFirmCommR fsh = handleFirmCommR (SomeRoute $ FirmUsersR fsh) (Just fsh) +postFirmCommR fsh = handleFirmCommR (SomeRoute $ FirmUsersR fsh) [fsh] -getFirmsCommR, postFirmsCommR :: Handler Html +getFirmsCommR, postFirmsCommR :: Companies -> Handler Html getFirmsCommR = postFirmsCommR -postFirmsCommR = handleFirmCommR (SomeRoute FirmAllR) Nothing +postFirmsCommR = handleFirmCommR (SomeRoute FirmAllR) -handleFirmCommR :: SomeRoute UniWorX -> Maybe CompanyShorthand -> Handler Html -handleFirmCommR ultDest mbFsh = do - let decryptUserId :: CryptoUUIDUser -> Handler UserId - decryptUserId = decrypt - - mbCid = CompanyKey <$> mbFsh - - {- - queryEmpys :: CompanyId -> Handler [UserId] - queryEmpys cid = E.unValue <<$>> runDB (E.select $ do - (emp :& uc) <- E.from $ E.table @User `E.innerJoin` E.table @UserCompany `E.on` (\(emp :& uc) -> emp E.^. UserId E.==. uc E.^. UserCompanyUser) - E.where_ $ uc E.^. UserCompanyCompany E.==. E.val cid - return $ emp E.^. UserId - ) - -} - - selected <- mapM decryptUserId =<< lookupGlobalGetParams GetRecipient -- retrieve selected users - - empys <- ifMaybeM mbCid selected (\cid -> -- get all employees or stick with selected users, if no company was pre-selected (to limit choices) - E.unValue <<$>> runDB (E.select $ do +handleFirmCommR :: SomeRoute UniWorX -> Companies -> Handler Html +handleFirmCommR _ [] = invalidArgs ["At least one company name must be provided."] +handleFirmCommR ultDest cs = do + let csKey = CompanyKey <$> cs + -- get employees of chosen companies + empys <- E.unValue <<$>> runDB (E.select $ do (emp :& uc) <- E.from $ E.table @User `E.innerJoin` E.table @UserCompany `E.on` (\(emp :& uc) -> emp E.^. UserId E.==. uc E.^. UserCompanyUser) - E.where_ $ uc E.^. UserCompanyCompany E.==. E.val cid + E.where_ $ uc E.^. UserCompanyCompany `E.in_` E.valList csKey return $ emp E.^. UserId - )) - - cmpys <- E.unValue <<$>> runDB (E.select $ do + ) + -- get supervisors of employees + sprs <- E.unValue <<$>> runDB (E.select $ do + spr <- E.from $ E.table @User + E.where_ $ E.exists $ do + usrSpr <- E.from $ E.table @UserSupervisor + E.where_ $ usrSpr E.^. UserSupervisorSupervisor E.==. spr E.^. UserId + E.&&. usrSpr E.^. UserSupervisorUser `E.in_` E.valList empys + return $ spr E.^. UserId + ) + -- get companies of all supervisors + sprCmpys <- E.unValue <<$>> runDB (E.select $ do cmpy <- E.from $ E.table @Company - E.where_ $ E.exists $ do + E.where_ $ E.exists $ do usrCmpy <- E.from $ E.table @UserCompany - E.where_ $ usrCmpy E.^. UserCompanyUser `E.in_` E.valList selected - E.&&. usrCmpy E.^. UserCompanyCompany E.==. cmpy E.^. CompanyId + E.where_ $ usrCmpy E.^. UserCompanyCompany E.==. cmpy E.^. CompanyId + E.&&. usrCmpy E.^. UserCompanyUser `E.in_` E.valList sprs return $ cmpy E.^.CompanyId ) - let queryCmpy :: Bool -> CompanyId -> E.SqlQuery (E.SqlExpr (Entity User)) - queryCmpy sORe acid = do - (usr :& uc) <- E.from $ E.table @User `E.innerJoin` E.table @UserCompany `E.on` (\(emp :& uc) -> emp E.^. UserId E.==. uc E.^. UserCompanyUser) - E.where_ $ uc E.^. UserCompanyCompany E.==. E.val acid - E.&&. (if sORe - then -- supervisors only - E.exists $ do - usrSpr <- E.from $ E.table @UserSupervisor - E.where_ $ usrSpr E.^. UserSupervisorSupervisor E.==. usr E.^. UserId - E.&&. usrSpr E.^. UserSupervisorUser `E.in_` E.valList empys - else -- selected employees for this company only - usr E.^. UserId `E.in_` E.valList empys - ) - return usr + let + queryLoners :: E.SqlQuery (E.SqlExpr (Entity User)) -- get supervisors without any company affiliation + queryLoners = do + spr <- E.from $ E.table @User + E.where_ $ spr E.^. UserId `E.in_` E.valList empys + E.&&. E.notExists (do + sprCmp <- E.from $ E.table @UserCompany + E.where_ $ sprCmp E.^. UserCompanyUser E.==. spr E.^. UserId + ) + return $ spr + + queryCmpy :: Bool -> CompanyId -> E.SqlQuery (E.SqlExpr (Entity User)) + queryCmpy sORe acid = do + (usr :& uc) <- E.from $ E.table @User `E.innerJoin` E.table @UserCompany `E.on` (\(emp :& uc) -> emp E.^. UserId E.==. uc E.^. UserCompanyUser) + E.where_ $ uc E.^. UserCompanyCompany E.==. E.val acid + E.&&. (if sORe + then -- supervisors only + E.exists $ do + usrSpr <- E.from $ E.table @UserSupervisor + E.where_ $ usrSpr E.^. UserSupervisorSupervisor E.==. usr E.^. UserId + E.&&. usrSpr E.^. UserSupervisorUser `E.in_` E.valList empys + else E.true + ) + return usr commR CommunicationRoute - { crHeading = SomeMessage $ maybe MsgFirmsNotification MsgFirmNotification mbFsh + { crHeading = SomeMessage $ case cs of { [c] -> MsgFirmNotification c; _ -> MsgFirmsNotification } , crUltDest = ultDest - , crJobs = crJobsFirmCommunication mbFsh -- :: Communication -> ConduitT () Job (YesodDB UniWorX) () - , crTestJobs = crTestFirmCommunication mbFsh -- :: Communication -> ConduitT () Job (YesodDB UniWorX) () + , crJobs = crJobsFirmCommunication cs -- :: Communication -> ConduitT () Job (YesodDB UniWorX) () + , crTestJobs = crTestFirmCommunication cs -- :: Communication -> ConduitT () Job (YesodDB UniWorX) () , crRecipientAuth = Nothing -- :: Maybe (UserId -> DB AuthResult) -- an optional filter passed to guardAuthResult , crRecipients = -- :: [(RecipientGroup, SqlQuery (SqlExpr (Entity User)))] - [(RGFirmSupervisor $ unCompanyKey acid, queryCmpy True acid) | acid <- cmpys ] <> - [(RGFirmEmployees $ unCompanyKey acid, queryCmpy False acid) | acid <- cmpys, maybe True (acid ==) mbCid] + [(RGFirmSupervisor $ unCompanyKey acid, queryCmpy True acid) | acid <- sprCmpys ] ++ + (RGFirmIndependent, queryLoners) : + [(RGFirmEmployees $ unCompanyKey acid, queryCmpy False acid) | acid <- csKey ] } {- Auswahlbox für Mitteilung: diff --git a/src/Handler/Utils/Communication.hs b/src/Handler/Utils/Communication.hs index 28473dfc1..333d088cb 100644 --- a/src/Handler/Utils/Communication.hs +++ b/src/Handler/Utils/Communication.hs @@ -32,7 +32,7 @@ data RecipientGroup = RGCourseParticipants | RGCourseLecturers | RGCourseCorrect | RGTutorialParticipants CryptoUUIDTutorial | RGExamRegistered CryptoUUIDExam | RGSheetSubmittor CryptoUUIDSheet - | RGFirmSupervisor CompanyShorthand | RGFirmEmployees CompanyShorthand + | RGFirmSupervisor CompanyShorthand | RGFirmEmployees CompanyShorthand | RGFirmIndependent deriving (Eq, Ord, Read, Show, Generic) instance LowerBounded RecipientGroup where @@ -110,8 +110,8 @@ crTestJobsCourseCommunication jCourse comm = do crJobsCourseCommunication jCourse comm' .| C.filter ((== Right jSender) . jRecipientEmail) -crJobsFirmCommunication :: Maybe CompanyShorthand -> Communication -> ConduitT () Job (YesodDB UniWorX) () -crJobsFirmCommunication jCompany Communication{..} = do +crJobsFirmCommunication :: Companies -> Communication -> ConduitT () Job (YesodDB UniWorX) () +crJobsFirmCommunication jCompanies Communication{..} = do jSender <- requireAuthId let jMailContent = cContent allRecipients = Set.toList $ Set.insert (Right jSender) cRecipients @@ -122,12 +122,12 @@ crJobsFirmCommunication jCompany Communication{..} = do forM_ allRecipients $ \jRecipientEmail -> yield JobSendFirmCommunication{..} -crTestFirmCommunication :: Maybe CompanyShorthand -> Communication -> ConduitT () Job (YesodDB UniWorX) () -crTestFirmCommunication jCompany comm = do +crTestFirmCommunication :: Companies -> Communication -> ConduitT () Job (YesodDB UniWorX) () +crTestFirmCommunication jCompanies comm = do jSender <- requireAuthId MsgRenderer mr <- getMsgRenderer let comm' = comm & _cContent . _ccSubject %~ Just . mr . MsgCommCourseTestSubject . fromMaybe (mr MsgUtilCommFirmSubject) - crJobsFirmCommunication jCompany comm' .| C.filter ((== Right jSender) . jRecipientEmail) + crJobsFirmCommunication jCompanies comm' .| C.filter ((== Right jSender) . jRecipientEmail) @@ -139,103 +139,100 @@ commR CommunicationRoute{..} = do uid <- decrypt cID whenIsJust crRecipientAuth $ guardAuthResult <=< ($ uid) getEntity uid - cUser <- maybeAuth + (chosenRecipients, suggestedRecipients) <- runDB $ (,) + <$> (maybe id cons cUser . catMaybes <$> (mapM decrypt' =<< lookupGlobalGetParams GetRecipient)) + <*> (filter (notNull . snd) <$> for crRecipients (\(grp,usrQry) -> (grp,) <$> E.select usrQry)) + $logWarnS "COMM" ("Communication handlerwith (sugg:" <> tshow (length suggestedRecipients) <> ", chosen:" <> tshow (length chosenRecipients) <> ")") MsgRenderer mr <- getMsgRenderer mbCurrentRoute <- getCurrentRoute - (suggestedRecipients, chosenRecipients) <- runDB $ (,) - <$> for crRecipients (\(grp,usrQry) -> (grp,) <$> E.select usrQry) - <*> fmap (maybe id cons cUser . catMaybes) (mapM decrypt' =<< lookupGlobalGetParams GetRecipient) - $logWarnS "COMM" ("Communication handler DB done with (sugg:" <> tshow (length suggestedRecipients) <> ", chosen:" <> tshow (length chosenRecipients) <> ")") - let lookupUser :: UserId -> (UserDisplayName,UserSurname) - lookupUser = - let usrMap = Map.fromList $ fmap (\u -> (entityKey u, entityVal u)) $ chosenRecipients ++ concatMap (view _2) suggestedRecipients - usrNames Nothing = ("???","???") -- this case only happens during runFormPost when POST Data is present and no form is displayed + lookupUser = + let usrMap = Map.fromList $ fmap (\u -> (entityKey u, entityVal u)) $ chosenRecipients ++ concatMap (view _2) suggestedRecipients + usrNames Nothing = ("???","???") -- this case only happens during runFormPost when POST Data is present and no form is display usrNames (Just User{userDisplayName, userSurname}) = (userDisplayName, userSurname) in usrNames . flip Map.lookup usrMap - let chosenRecipients' = Map.fromList $ - [ ( (BoundedPosition $ RecipientGroup g, pos) - , (Right recp, recp `elem` map entityKey chosenRecipients) - ) - | (g, recps) <- suggestedRecipients - , (pos, recp) <- zip [0..] $ map entityKey recps - ] ++ - [ ( (BoundedPosition RecipientCustom, pos) - , (Right recp, True) - ) - | (pos, recp) <- zip [0..] . Set.toList $ Set.fromList (map entityKey chosenRecipients) \\ Set.fromList (concatMap (map entityKey) $ view _2 <$> suggestedRecipients) - ] - activeCategories = map RecipientGroup (view _1 <$> suggestedRecipients) `snoc` RecipientCustom + chosenRecipients' = Map.fromList $ + [ ( (BoundedPosition $ RecipientGroup g, pos) + , (Right recp, recp `elem` map entityKey chosenRecipients) + ) + | (g, recps) <- suggestedRecipients + , (pos, recp) <- zip [0..] $ map entityKey recps + ] ++ + [ ( (BoundedPosition RecipientCustom, pos) + , (Right recp, True) + ) + | (pos, recp) <- zip [0..] . Set.toList $ Set.fromList (map entityKey chosenRecipients) \\ Set.fromList (concatMap (map entityKey) $ view _2 <$> suggestedRecipients) + ] + activeCategories = map RecipientGroup (view _1 <$> suggestedRecipients) `snoc` RecipientCustom - let recipientAForm :: AForm Handler (Set (Either UserEmail UserId)) - recipientAForm = postProcess <$> massInputA MassInput{..} (fslI MsgCommRecipients & setTooltip MsgCommRecipientsTip) True (Just chosenRecipients') - where - miAdd pos@(BoundedPosition RecipientCustom, 0) dim@1 liveliness nudge submitView = guardOn (miAllowAdd pos dim liveliness) $ \csrf -> do - (addRes, addView) <- mpreq (multiUserField True Nothing) (fslpI MsgUtilEMail (mr MsgUtilEMail) & setTooltip MsgUtilMultiEmailFieldTip & addName (nudge "email")) Nothing - let - addRes' = addRes <&> \nEmails ((Map.elems &&& maybe 0 (succ . snd . fst) . Map.lookupMax) . Map.filterWithKey (\(BoundedPosition c, _) _ -> c == RecipientCustom) -> (oEmails, kStart)) -> FormSuccess . Map.fromList . zip (map (BoundedPosition RecipientCustom, ) [kStart..]) . Set.toList $ nEmails `Set.difference` Set.fromList oEmails - return (addRes', $(widgetFile "widgets/communication/recipientAdd")) - miAdd _ _ _ _ _ = Nothing - miCell _ (Left (CI.original -> email)) initRes nudge csrf = do - (tickRes, tickView) <- mpreq checkBoxField ("" & addName (nudge "tick")) $ initRes <|> Just True - return (tickRes, $(widgetFile "widgets/communication/recipientEmail")) - miCell _ (Right uid@(lookupUser -> (userDisplayName, userSurname))) initRes nudge csrf = do - (tickRes, tickView) <- if - | fmap entityKey cUser == Just uid - -> mforced checkBoxField ("" & addName (nudge "tick")) True - | otherwise - -> mpreq checkBoxField ("" & addName (nudge "tick")) $ initRes <|> Just True - return (tickRes, $(widgetFile "widgets/communication/recipientName")) - miAllowAdd (BoundedPosition RecipientCustom, 0) 1 _ = True - miAllowAdd _ _ _ = False - miAddEmpty _ 0 _ = Set.singleton (BoundedPosition RecipientCustom, 0) - miAddEmpty _ _ _ = Set.empty - miButtonAction :: forall p . PathPiece p => p -> Maybe (SomeRoute UniWorX) - miButtonAction anchor = SomeRoute . (:#: anchor) <$> mbCurrentRoute - miLayout :: MapLiveliness (BoundedLiveliness RecipientCategory) ListLength - -> Map (BoundedPosition RecipientCategory, ListPosition) (_, FormResult Bool) - -> Map (BoundedPosition RecipientCategory, ListPosition) Widget - -> Map (BoundedPosition RecipientCategory, ListPosition) (FieldView UniWorX) - -> Map (Natural, (BoundedPosition RecipientCategory, ListPosition)) Widget - -> Widget - miLayout liveliness cState cellWdgts _delButtons addWdgts = do - checkedIdentBase <- newIdent - let checkedCategories = Set.mapMonotonic (unBoundedPosition . fst) . Set.filter (\k' -> Map.foldrWithKey (\k (_, checkState) -> (||) $ k == k' && checkState /= FormSuccess False && (checkState /= FormMissing || maybe True snd (chosenRecipients' !? k))) False cState) $ Map.keysSet cState - checkedIdent c = checkedIdentBase <> "-" <> toPathPiece c - hasContent c = not (null $ categoryIndices c) || Map.member (1, (BoundedPosition c, 0)) addWdgts - categoryIndices c = Set.filter ((== c) . unBoundedPosition . fst) $ review liveCoords liveliness - rgTutorialParticipantsCaption :: CryptoUUIDTutorial -> Widget - rgTutorialParticipantsCaption cID = do - tutId <- decrypt cID - Tutorial{..} <- liftHandler . runDBRead $ get404 tutId - i18n $ MsgRGTutorialParticipants tutorialName - rgExamRegisteredCaption :: CryptoUUIDExam -> Widget - rgExamRegisteredCaption cID = do - eId <- decrypt cID - Exam{..} <- liftHandler . runDBRead $ get404 eId - i18n $ MsgRGExamRegistered examName - rgSheetSubmittorCaption :: CryptoUUIDSheet -> Widget - rgSheetSubmittorCaption cID = do - sId <- decrypt cID - Sheet{..} <- liftHandler . runDBRead $ get404 sId - i18n $ MsgRGSheetSubmittor sheetName - $(widgetFile "widgets/communication/recipientLayout") - miDelete :: Map (BoundedPosition RecipientCategory, ListPosition) (Either UserEmail UserId) -> (BoundedPosition RecipientCategory, ListPosition) -> MaybeT (MForm Handler) (Map (BoundedPosition RecipientCategory, ListPosition) (BoundedPosition RecipientCategory, ListPosition)) - -- miDelete liveliness@(MapLiveliness lMap) (BoundedPosition RecipientCustom, delPos) = mappend (Map.fromSet id . Set.filter (\(BoundedPosition c, _) -> c /= RecipientCustom) $ review liveCoords liveliness) . fmap (BoundedPosition RecipientCustom, ) . Map.mapKeysMonotonic (BoundedPosition RecipientCustom, ) <$> miDeleteList (lMap ! BoundedPosition RecipientCustom) delPos - miDelete _ _ = mzero - miIdent :: Text - miIdent = "recipients" - postProcess :: Map (BoundedPosition RecipientCategory, ListPosition) (Either UserEmail UserId, Bool) -> Set (Either UserEmail UserId) - postProcess = Set.fromList . map fst . filter snd . Map.elems + recipientAForm :: AForm Handler (Set (Either UserEmail UserId)) + recipientAForm = postProcess <$> massInputA MassInput{..} (fslI MsgCommRecipients & setTooltip MsgCommRecipientsTip) True (Just chosenRecipients') + where + miAdd pos@(BoundedPosition RecipientCustom, 0) dim@1 liveliness nudge submitView = guardOn (miAllowAdd pos dim liveliness) $ \csrf -> do + (addRes, addView) <- mpreq (multiUserField True Nothing) (fslpI MsgUtilEMail (mr MsgUtilEMail) & setTooltip MsgUtilMultiEmailFieldTip & addName (nudge "email")) Nothing + let + addRes' = addRes <&> \nEmails ((Map.elems &&& maybe 0 (succ . snd . fst) . Map.lookupMax) . Map.filterWithKey (\(BoundedPosition c, _) _ -> c == RecipientCustom) -> (oEmails, kStart)) -> FormSuccess . Map.fromList . zip (map (BoundedPosition RecipientCustom, ) [kStart..]) . Set.toList $ nEmails `Set.difference` Set.fromList oEmails + return (addRes', $(widgetFile "widgets/communication/recipientAdd")) + miAdd _ _ _ _ _ = Nothing + miCell _ (Left (CI.original -> email)) initRes nudge csrf = do + (tickRes, tickView) <- mpreq checkBoxField ("" & addName (nudge "tick")) $ initRes <|> Just True + return (tickRes, $(widgetFile "widgets/communication/recipientEmail")) + miCell _ (Right uid@(lookupUser -> (userDisplayName, userSurname))) initRes nudge csrf = do + (tickRes, tickView) <- if + | fmap entityKey cUser == Just uid + -> mforced checkBoxField ("" & addName (nudge "tick")) True + | otherwise + -> mpreq checkBoxField ("" & addName (nudge "tick")) $ initRes <|> Just True + return (tickRes, $(widgetFile "widgets/communication/recipientName")) + miAllowAdd (BoundedPosition RecipientCustom, 0) 1 _ = True + miAllowAdd _ _ _ = False + miAddEmpty _ 0 _ = Set.singleton (BoundedPosition RecipientCustom, 0) + miAddEmpty _ _ _ = Set.empty + miButtonAction :: forall p . PathPiece p => p -> Maybe (SomeRoute UniWorX) + miButtonAction anchor = SomeRoute . (:#: anchor) <$> mbCurrentRoute + miLayout :: MapLiveliness (BoundedLiveliness RecipientCategory) ListLength + -> Map (BoundedPosition RecipientCategory, ListPosition) (_, FormResult Bool) + -> Map (BoundedPosition RecipientCategory, ListPosition) Widget + -> Map (BoundedPosition RecipientCategory, ListPosition) (FieldView UniWorX) + -> Map (Natural, (BoundedPosition RecipientCategory, ListPosition)) Widget + -> Widget + miLayout liveliness cState cellWdgts _delButtons addWdgts = do + checkedIdentBase <- newIdent + let checkedCategories = Set.mapMonotonic (unBoundedPosition . fst) . Set.filter (\k' -> Map.foldrWithKey (\k (_, checkState) -> (||) $ k == k' && checkState /= FormSuccess False && (checkState /= FormMissing || maybe True snd (chosenRecipients' !? k))) False cState) $ Map.keysSet cState + checkedIdent c = checkedIdentBase <> "-" <> toPathPiece c + hasContent c = not (null $ categoryIndices c) || Map.member (1, (BoundedPosition c, 0)) addWdgts + categoryIndices c = Set.filter ((== c) . unBoundedPosition . fst) $ review liveCoords liveliness + rgTutorialParticipantsCaption :: CryptoUUIDTutorial -> Widget + rgTutorialParticipantsCaption cID = do + tutId <- decrypt cID + Tutorial{..} <- liftHandler . runDBRead $ get404 tutId + i18n $ MsgRGTutorialParticipants tutorialName + rgExamRegisteredCaption :: CryptoUUIDExam -> Widget + rgExamRegisteredCaption cID = do + eId <- decrypt cID + Exam{..} <- liftHandler . runDBRead $ get404 eId + i18n $ MsgRGExamRegistered examName + rgSheetSubmittorCaption :: CryptoUUIDSheet -> Widget + rgSheetSubmittorCaption cID = do + sId <- decrypt cID + Sheet{..} <- liftHandler . runDBRead $ get404 sId + i18n $ MsgRGSheetSubmittor sheetName + $(widgetFile "widgets/communication/recipientLayout") + miDelete :: Map (BoundedPosition RecipientCategory, ListPosition) (Either UserEmail UserId) -> (BoundedPosition RecipientCategory, ListPosition) -> MaybeT (MForm Handler) (Map (BoundedPosition RecipientCategory, ListPosition) (BoundedPosition RecipientCategory, ListPosition)) + -- miDelete liveliness@(MapLiveliness lMap) (BoundedPosition RecipientCustom, delPos) = mappend (Map.fromSet id . Set.filter (\(BoundedPosition c, _) -> c /= RecipientCustom) $ review liveCoords liveliness) . fmap (BoundedPosition RecipientCustom, ) . Map.mapKeysMonotonic (BoundedPosition RecipientCustom, ) <$> miDeleteList (lMap ! BoundedPosition RecipientCustom) delPos + miDelete _ _ = mzero + miIdent :: Text + miIdent = "recipients" + postProcess :: Map (BoundedPosition RecipientCategory, ListPosition) (Either UserEmail UserId, Bool) -> Set (Either UserEmail UserId) + postProcess = Set.fromList . map fst . filter snd . Map.elems recipientsListMsg <- messageI Info MsgCommRecipientsList - - $logWarnS "COMM" "Communication handler some definitions done" + attachmentsMaxSize <- getsYesod $ view _appCommunicationAttachmentsMaxSize let attachmentField = genericFileField $ return FileField { fieldIdent = Nothing @@ -246,7 +243,7 @@ commR CommunicationRoute{..} = do , fieldMaxFileSize = Nothing, fieldMaxCumulativeSize = attachmentsMaxSize , fieldAllEmptyOk = True } - $logWarnS "COMM" "Communication handler some parameters done" -- SEEN + ((commRes,commWdgt),commEncoding) <- runFormPost . identifyForm FIDCommunication . withButtonForm' universeF . renderAForm FormStandard $ Communication <$> recipientAForm <* aformMessage recipientsListMsg @@ -255,8 +252,7 @@ commR CommunicationRoute{..} = do <*> (markupOutput <$> areq htmlField (fslI MsgCommBody) Nothing) <*> fmap fold (aopt (convertFieldM (runConduit . (.| C.foldMap Set.singleton)) yieldMany attachmentField) (fslI MsgCommAttachments & setTooltip MsgCommAttachmentsTip) Nothing) - ) - $logWarnS "COMM" "Communication handler run form post done" -- NOT SEEN ANYMORE + ) formResult commRes $ \case (comm, BtnCommunicationSend) -> do runDBJobs . runConduit $ transPipe (mapReaderT lift) (crJobs comm) .| sinkDBJobs @@ -265,14 +261,13 @@ commR CommunicationRoute{..} = do (comm, BtnCommunicationTest) -> do runDBJobs . runConduit $ transPipe (mapReaderT lift) (crTestJobs comm) .| sinkDBJobs addMessageI Info MsgCommTestSuccess - $logWarnS "COMM" "Communication handler form result done" + let formWdgt = wrapForm commWdgt def { formMethod = POST , formAction = SomeRoute <$> mbCurrentRoute , formEncoding = commEncoding , formSubmit = FormNoSubmit - } - $logWarnS "COMM" "Communication handler finished" + } siteLayoutMsg crHeading $ do setTitleI crHeading let commTestTip = $(i18nWidgetFile "comm-test-tip") diff --git a/src/Jobs/Handler/SendCourseCommunication.hs b/src/Jobs/Handler/SendCourseCommunication.hs index fa4fbcb69..4edaa2d4d 100644 --- a/src/Jobs/Handler/SendCourseCommunication.hs +++ b/src/Jobs/Handler/SendCourseCommunication.hs @@ -49,12 +49,12 @@ dispatchJobSendCourseCommunication jRecipientEmail jAllRecipientAddresses jCours dispatchJobSendFirmCommunication :: Either UserEmail UserId -> Set Address - -> Maybe CompanyShorthand + -> Companies -> UserId -> UUID -> CommunicationContent -> JobHandler UniWorX -dispatchJobSendFirmCommunication jRecipientEmail jAllRecipientAddresses _jCompany jSender jMailObjectUUID CommunicationContent{..} = JobHandlerException $ do +dispatchJobSendFirmCommunication jRecipientEmail jAllRecipientAddresses _jCompanies jSender jMailObjectUUID CommunicationContent{..} = JobHandlerException $ do -- (sender,mbComp) <- runDB $ (,) -- <$> getJust jSender -- <*> ifMaybeM jCompany Nothing get diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs index 6c665adb4..78b4fe50b 100644 --- a/src/Jobs/Types.hs +++ b/src/Jobs/Types.hs @@ -76,7 +76,7 @@ data Job } | JobSendFirmCommunication { jRecipientEmail :: Either UserEmail UserId , jAllRecipientAddresses :: Set Address - , jCompany :: Maybe CompanyShorthand + , jCompanies :: Companies , jSender :: UserId , jMailObjectUUID :: UUID , jMailContent :: CommunicationContent diff --git a/src/Model/Types/Common.hs b/src/Model/Types/Common.hs index 836d2741e..df9bc1a79 100644 --- a/src/Model/Types/Common.hs +++ b/src/Model/Types/Common.hs @@ -42,7 +42,8 @@ type SchoolName = CI Text type SchoolShorthand = CI Text type CompanyName = CI Text -type CompanyShorthand = CI Text +type CompanyShorthand = CI Text +type Companies = [CI Text] type CourseName = CI Text type CourseShorthand = CI Text diff --git a/templates/widgets/communication/recipientLayout.hamlet b/templates/widgets/communication/recipientLayout.hamlet index 9dc2beea0..cd5546277 100644 --- a/templates/widgets/communication/recipientLayout.hamlet +++ b/templates/widgets/communication/recipientLayout.hamlet @@ -35,6 +35,8 @@ $if not (null activeCategories) _{MsgFirmSupervisorOf fsh} $of RecipientGroup (RGFirmEmployees fsh) _{MsgFirmEmployeeOf fsh} + $of RecipientGroup (RGFirmIndependent) + _{MsgFirmSupervisorIndependent} $if hasContent category
                                From 698a9c54970d6eae110702376bc69f66d4e7beb0 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 14 Nov 2023 17:37:05 +0100 Subject: [PATCH 45/50] refactor(firm): msg, titles and headings --- messages/uniworx/categories/firm/de-de-formal.msg | 4 +++- messages/uniworx/categories/firm/en-eu.msg | 4 +++- src/Handler/Course/Communication.hs | 4 +++- src/Handler/Firm.hs | 9 +++++---- src/Handler/Tutorial/Communication.hs | 5 +++-- src/Handler/Utils/Communication.hs | 3 ++- 6 files changed, 19 insertions(+), 10 deletions(-) diff --git a/messages/uniworx/categories/firm/de-de-formal.msg b/messages/uniworx/categories/firm/de-de-formal.msg index 3e27e0ba5..89399a379 100644 --- a/messages/uniworx/categories/firm/de-de-formal.msg +++ b/messages/uniworx/categories/firm/de-de-formal.msg @@ -15,11 +15,13 @@ FirmSuperActRMSuperDef: Standard Firmenansprechpartner entfernen FirmSuperActRMSuperAll: Als aktiven Ansprechpartner komplett entfernen FirmsNotification: Firmen Benachrichtigung versenden FirmNotification fsh@CompanyShorthand: Benachrichtigung an #{fsh} versenden +FirmsNotificationTitle: Firmen benachrichtigen +FirmNotificationTitle fsh@CompanyShorthand: #{fsh} benachrichtigen FilterSupervisor: Hat aktiven Ansprechpartner FilterSupervisorCompany fsh@CompanyShorthand: Hat aktiven Ansprechpartner, #{fsh} der angehört FilterSupervisorForeign fsh@CompanyShorthand: Hat aktiven Ansprechpartner, der selbst nicht #{fsh} angehört FilterForeignSupervisor: Hat firmenfremde Ansprechpartner -FilterFirmPostalAddress: Postalische Firmenadresse vorhanden +FilterFirmExtern: Externe Firma FirmSupervisorOf fsh@CompanyShorthand: Ansprechpartner #{fsh} angehörig FirmSupervisorIndependent: Ansprechpartner ohne jegliche Firmenzugehörigkeit FirmEmployeeOf fsh@CompanyShorthand: Firmenangehörige #{fsh} \ No newline at end of file diff --git a/messages/uniworx/categories/firm/en-eu.msg b/messages/uniworx/categories/firm/en-eu.msg index ddef25a86..044bebd48 100644 --- a/messages/uniworx/categories/firm/en-eu.msg +++ b/messages/uniworx/categories/firm/en-eu.msg @@ -15,11 +15,13 @@ FirmSuperActRMSuperDef: Remove as default supervisor FirmSuperActRMSuperAll: Remove all active supervisions for this company FirmsNotification: Send company notification FirmNotification fsh: Send notification to company #{fsh} +FirmsNotificationTitle: Company notification +FirmNotificationTitle fsh@CompanyShorthand: #{fsh} notification FilterSupervisor: Has active supervisor FilterSupervisorCompany fsh: Has active company supervisor belonging to #{fsh} FilterSupervisorForeign fsh: Has active supervisor not belonging to #{fsh} FilterForeignSupervisor: Has company-external supervisors -FilterFirmPostalAddress: Postal company addresse known +FilterFirmExtern: External company FirmSupervisorOf fsh@CompanyShorthand: Supervisors belonging to #{fsh} FirmSupervisorIndependent: Independent supervisors FirmEmployeeOf fsh@CompanyShorthand: #{fsh} associated users \ No newline at end of file diff --git a/src/Handler/Course/Communication.hs b/src/Handler/Course/Communication.hs index 07bce86e7..a584267a5 100644 --- a/src/Handler/Course/Communication.hs +++ b/src/Handler/Course/Communication.hs @@ -64,8 +64,10 @@ postCCommR tid ssh csh = do return (cid, tuts, exams, sheets) + let heading = SomeMessage . prependCourseTitle tid ssh csh $ SomeMessage MsgCommCourseHeading commR CommunicationRoute - { crHeading = SomeMessage . prependCourseTitle tid ssh csh $ SomeMessage MsgCommCourseHeading + { crHeading = heading + , crTitle = heading , crUltDest = SomeRoute $ CourseR tid ssh csh CCommR , crJobs = crJobsCourseCommunication cid , crTestJobs = crTestJobsCourseCommunication cid diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index bfcb14794..7ad115f43 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -333,7 +333,7 @@ mkFirmAllTable isAdmin uid = do , prismAForm (singletonFilter "company-number") mPrev $ aopt textField (fslI MsgTableCompanyNo) , prismAForm (singletonFilter "is-supervisor") mPrev $ aopt textField (fslI MsgTableSupervisor) , prismAForm (singletonFilter "foreign-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterForeignSupervisor) - , prismAForm (singletonFilter "company-postal" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterFirmPostalAddress) + , prismAForm (singletonFilter "company-postal" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterFirmExtern) ] dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } acts :: Map FirmAllAction (AForm Handler FirmAllActionData) @@ -601,7 +601,7 @@ postFirmUsersR fsh = do redirect (FirmCommR fsh, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids]) siteLayout (citext2widget companyName) $ do - setTitle $ toHtml $ CI.original companyShorthand <> " (" <> tshow companyAvsId <> ")" + setTitle $ toHtml $ CI.original companyShorthand <> "-" <> tshow companyAvsId $(widgetFile "firm-users") @@ -768,7 +768,7 @@ postFirmSupersR fsh = do siteLayout (citext2widget fsh) $ do - setTitle $ citext2Html fsh + setTitle $ citext2Html $ fsh <> " Supers" -- TODO: factor out company info section hamlet here and from user table [whamlet|
                                @@ -854,7 +854,8 @@ handleFirmCommR ultDest cs = do return usr commR CommunicationRoute - { crHeading = SomeMessage $ case cs of { [c] -> MsgFirmNotification c; _ -> MsgFirmsNotification } + { crHeading = SomeMessage $ case cs of { [c] -> MsgFirmNotification c ; _ -> MsgFirmsNotification } + , crTitle = SomeMessage $ case cs of { [c] -> MsgFirmNotificationTitle c ; _ -> MsgFirmsNotificationTitle } , crUltDest = ultDest , crJobs = crJobsFirmCommunication cs -- :: Communication -> ConduitT () Job (YesodDB UniWorX) () , crTestJobs = crTestFirmCommunication cs -- :: Communication -> ConduitT () Job (YesodDB UniWorX) () diff --git a/src/Handler/Tutorial/Communication.hs b/src/Handler/Tutorial/Communication.hs index ede48066a..ed5349e03 100644 --- a/src/Handler/Tutorial/Communication.hs +++ b/src/Handler/Tutorial/Communication.hs @@ -32,9 +32,10 @@ postTCommR tid ssh csh tutn = do ) return (tutData, usertuts) - + let heading = SomeMessage . prependCourseTitle tid ssh csh $ SomeMessage MsgCommTutorialHeading commR CommunicationRoute - { crHeading = SomeMessage . prependCourseTitle tid ssh csh $ SomeMessage MsgCommTutorialHeading + { crHeading = heading + , crTitle = heading , crUltDest = SomeRoute $ CTutorialR tid ssh csh tutn TCommR , crJobs = crJobsCourseCommunication cid , crTestJobs = crTestJobsCourseCommunication cid diff --git a/src/Handler/Utils/Communication.hs b/src/Handler/Utils/Communication.hs index 333d088cb..d94f79706 100644 --- a/src/Handler/Utils/Communication.hs +++ b/src/Handler/Utils/Communication.hs @@ -80,6 +80,7 @@ data CommunicationRoute = CommunicationRoute , crRecipientAuth :: Maybe (UserId -> DB AuthResult) -- ^ Only resolve userids given as GET-Parameter if they fulfil this criterion , crJobs, crTestJobs :: Communication -> ConduitT () Job (YesodDB UniWorX) () , crHeading :: SomeMessage UniWorX + , crTitle :: SomeMessage UniWorX , crUltDest :: SomeRoute UniWorX } @@ -269,7 +270,7 @@ commR CommunicationRoute{..} = do , formSubmit = FormNoSubmit } siteLayoutMsg crHeading $ do - setTitleI crHeading + setTitleI crTitle let commTestTip = $(i18nWidgetFile "comm-test-tip") [whamlet| $newline never From ecde6b0faca4828bc3a17a9d94ea86c547748456 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 14 Nov 2023 18:25:03 +0100 Subject: [PATCH 46/50] chore(firm): add supervisor reset utility functions --- src/Handler/Firm.hs | 54 +++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 52 insertions(+), 2 deletions(-) diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 7ad115f43..dc46d5f9a 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -28,11 +28,11 @@ import qualified Data.Map as Map -- import qualified Data.Text as T import qualified Data.CaseInsensitive as CI -- import qualified Data.Conduit.List as C --- import Database.Persist.Sql (updateWhereCount) +import Database.Persist.Sql (deleteWhereCount) import Database.Esqueleto.Experimental ((:&)(..)) import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma import qualified Database.Esqueleto.Legacy as EL (from, on) --- import qualified Database.Esqueleto.PostgreSQL as E +import qualified Database.Esqueleto.PostgreSQL as E import qualified Database.Esqueleto.Utils as E import Database.Esqueleto.Utils.TH @@ -42,6 +42,56 @@ single :: (k,a) -> Map k a single = uncurry Map.singleton +--------------------------- +-- Firm specific utilities +-- for filters and counts see before FirmAllR Handlers + +-- remove supervisors: +deleteSupervisors :: NonEmpty UserId -> DB Int64 +deleteSupervisors usrs = deleteWhereCount [UserSupervisorUser <-. toList usrs] + +-- reset supervisors given employees of a company to default company supervision, deleting all other supervisors +resetSupervisors :: CompanyId -> NonEmpty UserId -> DB Int64 +resetSupervisors cid employees = do + nr_del <- deleteSupervisors employees + nr_add <- addDefaultSupervisors cid employees + return $ max nr_del nr_add + +-- adds the default company supervisors as supervisor to a given set of users, which themselves may belong to any company +addDefaultSupervisors :: CompanyId -> NonEmpty UserId -> DB Int64 +addDefaultSupervisors cid employees = do + E.insertSelectWithConflictCount UniqueUserSupervisor + (do + (spr :& usr) <- E.from $ E.table @UserCompany `E.crossJoin` E.toValues employees + E.where_ $ spr E.^. UserCompanyCompany E.==. E.val cid + E.&&. spr E.^. UserCompanySupervisor + return $ UserSupervisor + E.<# (spr E.^. UserCompanyUser) + E.<&> usr + E.<&> (spr E.^. UserCompanySupervisorReroute) + ) + (\_old new -> [UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications] ) + +-- like `addDefaultSupervisors`, but selects all employees from database +addDefaultSupervisorsAll :: CompanyId -> DB Int64 +addDefaultSupervisorsAll cid = do + E.insertSelectWithConflictCount UniqueUserSupervisor + (do + (spr :& usr) <- E.from $ E.table @UserCompany `E.innerJoin` E.table @UserCompany `E.on` (\(spr :& usr) -> spr E.^. UserCompanyCompany E.==. usr E.^. UserCompanyCompany) + E.where_ $ spr E.^. UserCompanyCompany E.==. E.val cid + E.&&. spr E.^. UserCompanySupervisor + return $ UserSupervisor + E.<# (spr E.^. UserCompanyUser) + E.<&> (usr E.^. UserCompanyUser) + E.<&> (spr E.^. UserCompanySupervisorReroute) + ) + (\_old new -> [UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications] ) + + + +------------------ +-- Debug Handler + getFirmR, postFirmR :: CompanyShorthand -> Handler Html getFirmR = postFirmR postFirmR fsh = do From 612d97538411788a24412f40cf54fb471197025e Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 15 Nov 2023 18:02:52 +0100 Subject: [PATCH 47/50] chore(firm): reset supervisors for FirmAllR working --- .../uniworx/categories/firm/de-de-formal.msg | 6 ++- messages/uniworx/categories/firm/en-eu.msg | 6 ++- src/Database/Esqueleto/Utils.hs | 4 +- src/Handler/Firm.hs | 42 ++++++++++++++----- 4 files changed, 44 insertions(+), 14 deletions(-) diff --git a/messages/uniworx/categories/firm/de-de-formal.msg b/messages/uniworx/categories/firm/de-de-formal.msg index 89399a379..459750323 100644 --- a/messages/uniworx/categories/firm/de-de-formal.msg +++ b/messages/uniworx/categories/firm/de-de-formal.msg @@ -8,8 +8,11 @@ FirmAddress: Postanschrift FirmDefaultPreferenceInfo: Diese Voreinstellungen gelten nur für neue Firmenangehörige FirmAllActNotify: Mitteilung versenden FirmAllActResetSupervision: Ansprechpartner für alle Firmenangehörigen zurücksetzen +FirmAllActResetSuperKeep: Bisherige Ansprechpartner der Firmenangehörigen zusätzlich beibehalten? +FirmAllActResetMutualSupervision: Ansprechpartner beaufsichtigen sich gegenseitig FirmUserActNotify: Mitteilung versenden FirmUserActMkSuper: Zum Firmenansprechpartner ernennen +FirmResetSupervision rem@Int64 set@Int64: #{tshow set} Ansprechpartner gesetzt#{bool mempty (", " <> tshow rem <> " zuvor gelöscht") (rem > 0)} FirmSuperActNotify: Mitteilung versenden FirmSuperActRMSuperDef: Standard Firmenansprechpartner entfernen FirmSuperActRMSuperAll: Als aktiven Ansprechpartner komplett entfernen @@ -24,4 +27,5 @@ FilterForeignSupervisor: Hat firmenfremde Ansprechpartner FilterFirmExtern: Externe Firma FirmSupervisorOf fsh@CompanyShorthand: Ansprechpartner #{fsh} angehörig FirmSupervisorIndependent: Ansprechpartner ohne jegliche Firmenzugehörigkeit -FirmEmployeeOf fsh@CompanyShorthand: Firmenangehörige #{fsh} \ No newline at end of file +FirmEmployeeOf fsh@CompanyShorthand: Firmenangehörige #{fsh} +NoCompanySelected: Bitte wählen Sie mindestens eine Firm aus. \ No newline at end of file diff --git a/messages/uniworx/categories/firm/en-eu.msg b/messages/uniworx/categories/firm/en-eu.msg index 044bebd48..6d497c91e 100644 --- a/messages/uniworx/categories/firm/en-eu.msg +++ b/messages/uniworx/categories/firm/en-eu.msg @@ -9,6 +9,9 @@ FirmDefaultPreferenceInfo: Default setting for new company associates only FirmAllActNotify: Send message FirmAllActResetSupervision: Reset supervisors for all company associates FirmUserActNotify: Send message +FirmAllActResetSuperKeep: Additionally keep existing supervisors of company associates? +FirmAllActResetMutualSupervision: Supervisors supervise each other +FirmResetSupervision rem set: #{tshow set} supervisors set#{bool mempty (", " <> tshow rem <> " deleted before") (rem > 0)} FirmUserActMkSuper: Mark as company supervisor FirmSuperActNotify: Send message FirmSuperActRMSuperDef: Remove as default supervisor @@ -24,4 +27,5 @@ FilterForeignSupervisor: Has company-external supervisors FilterFirmExtern: External company FirmSupervisorOf fsh@CompanyShorthand: Supervisors belonging to #{fsh} FirmSupervisorIndependent: Independent supervisors -FirmEmployeeOf fsh@CompanyShorthand: #{fsh} associated users \ No newline at end of file +FirmEmployeeOf fsh@CompanyShorthand: #{fsh} associated users +NoCompanySelected: Select at least one company, please. \ No newline at end of file diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index 3cba53920..2e97195e8 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -227,8 +227,8 @@ explicitUnsafeCoerceSqlExprValue typ (E.ERaw _m1 f1) = E.ERaw E.noMeta $ \_nPare ) and, or :: Foldable f => f (E.SqlExpr (E.Value Bool)) -> E.SqlExpr (E.Value Bool) -and = F.foldr (E.&&.) true -or = F.foldr (E.||.) false +and = F.foldl' (E.&&.) true -- we can use foldl' since Postgresql reorders conditions anyway +or = F.foldl' (E.||.) false -- | Given a test and a set of values, check whether anyone succeeds the test -- WARNING: SQL leaves it explicitely unspecified whether `||` is short curcuited (i.e. lazily evaluated) diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index dc46d5f9a..e7020fab4 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -70,16 +70,18 @@ addDefaultSupervisors cid employees = do E.<&> usr E.<&> (spr E.^. UserCompanySupervisorReroute) ) - (\_old new -> [UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications] ) + (\_old new -> [UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications]) -- like `addDefaultSupervisors`, but selects all employees from database -addDefaultSupervisorsAll :: CompanyId -> DB Int64 -addDefaultSupervisorsAll cid = do +addDefaultSupervisorsAll :: (MonoFoldable mono, CompanyId ~ Element mono) => Bool -> mono -> DB Int64 +addDefaultSupervisorsAll mutualSupervision cids = do E.insertSelectWithConflictCount UniqueUserSupervisor (do (spr :& usr) <- E.from $ E.table @UserCompany `E.innerJoin` E.table @UserCompany `E.on` (\(spr :& usr) -> spr E.^. UserCompanyCompany E.==. usr E.^. UserCompanyCompany) - E.where_ $ spr E.^. UserCompanyCompany E.==. E.val cid - E.&&. spr E.^. UserCompanySupervisor + E.where_ $ E.and $ guardMonoid (not mutualSupervision) [ E.not_ $ usr E.^. UserCompanySupervisor ] + <> [ spr E.^. UserCompanyCompany `E.in_` E.vals cids + , spr E.^. UserCompanySupervisor + ] return $ UserSupervisor E.<# (spr E.^. UserCompanyUser) E.<&> (usr E.^. UserCompanyUser) @@ -160,8 +162,11 @@ nullaryPathPiece ''FirmAllAction $ camelToPathPiece' 3 embedRenderMessage ''UniWorX ''FirmAllAction id data FirmAllActionData = FirmAllActNotifyData - | FirmAllActResetSupervisionData - deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) + | FirmAllActResetSupervisionData + { firmAllActResetKeepOldSupers :: Maybe Bool + , firmAllActResetMutualSupervision :: Maybe Bool + } + deriving (Eq, Ord, Read, Show, Generic) -- just in case for future extensions type AllCompanyTableExpr = E.SqlExpr (Entity Company) @@ -389,7 +394,9 @@ mkFirmAllTable isAdmin uid = do acts :: Map FirmAllAction (AForm Handler FirmAllActionData) acts = mconcat [ singletonMap FirmAllActNotify $ pure FirmAllActNotifyData - , singletonMap FirmAllActResetSupervision $ pure FirmAllActResetSupervisionData + , singletonMap FirmAllActResetSupervision $ FirmAllActResetSupervisionData + <$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmAllActResetSuperKeep) (Just $ Just False) + <*> aopt checkBoxField (fslI MsgFirmAllActResetMutualSupervision) (Just $ Just True ) ] dbtParams = DBParamsForm { dbParamsFormMethod = POST @@ -429,7 +436,21 @@ postFirmAllR = do isAdmin <- hasReadAccessTo AdminR (firmRes, firmTable) <- runDB $ mkFirmAllTable isAdmin uid -- filters to associated companies for non-admins formResult firmRes $ \case - (FirmAllActResetSupervisionData, fids) -> addMessage Info $ text2Html $ "Reset " <> tshow (length fids) <> " companies. TODO" + (_, fids) | null fids -> addMessageI Error MsgNoCompanySelected + + (FirmAllActResetSupervisionData{..}, fids) -> runDB $ do + delSupers <- if firmAllActResetKeepOldSupers == Just False + then E.deleteCount $ do + spr <- E.from $ E.table @UserSupervisor + E.where_ $ E.exists $ do + usr <- E.from $ E.table @UserCompany + E.where_ $ usr E.^. UserCompanyCompany `E.in_` E.vals fids + E.&&. usr E.^. UserCompanyUser E.==. spr E.^. UserSupervisorUser + else return 0 + newSupers <- addDefaultSupervisorsAll (firmAllActResetMutualSupervision /= Just False) fids + addMessageI Info $ MsgFirmResetSupervision newSupers delSupers + reloadKeepGetParams FirmAllR -- reload to reflect changes + (FirmAllActNotifyData , Set.toList -> fids) -> do usrs <- runDB $ E.select $ E.distinct $ do (usr :& uc) <- E.from $ E.table @User `E.innerJoin` E.table @UserCompany `E.on` (\(emp :& uc) -> emp E.^. UserId E.==. uc E.^. UserCompanyUser) @@ -437,6 +458,7 @@ postFirmAllR = do return $ usr E.^. UserId cuids <- traverse (encrypt . E.unValue) usrs :: Handler [CryptoUUIDUser] redirect (FirmsCommR $ fmap unCompanyKey fids, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids]) + siteLayoutMsg MsgMenuFirms $ do setTitleI MsgMenuFirms $(i18nWidgetFile "firm-all") @@ -887,7 +909,7 @@ handleFirmCommR ultDest cs = do sprCmp <- E.from $ E.table @UserCompany E.where_ $ sprCmp E.^. UserCompanyUser E.==. spr E.^. UserId ) - return $ spr + return spr queryCmpy :: Bool -> CompanyId -> E.SqlQuery (E.SqlExpr (Entity User)) queryCmpy sORe acid = do From 715b751363e1fd646a20b76413623ad1baf145b7 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 16 Nov 2023 18:49:41 +0100 Subject: [PATCH 48/50] chore(firm): add columns and filters and refactor some --- .../uniworx/categories/firm/de-de-formal.msg | 4 +- messages/uniworx/categories/firm/en-eu.msg | 4 +- src/Handler/Firm.hs | 322 +++++++++++------- src/Handler/Utils/Table/Pagination.hs | 9 +- src/Utils/Icon.hs | 5 +- 5 files changed, 209 insertions(+), 135 deletions(-) diff --git a/messages/uniworx/categories/firm/de-de-formal.msg b/messages/uniworx/categories/firm/de-de-formal.msg index 459750323..71c910999 100644 --- a/messages/uniworx/categories/firm/de-de-formal.msg +++ b/messages/uniworx/categories/firm/de-de-formal.msg @@ -28,4 +28,6 @@ FilterFirmExtern: Externe Firma FirmSupervisorOf fsh@CompanyShorthand: Ansprechpartner #{fsh} angehörig FirmSupervisorIndependent: Ansprechpartner ohne jegliche Firmenzugehörigkeit FirmEmployeeOf fsh@CompanyShorthand: Firmenangehörige #{fsh} -NoCompanySelected: Bitte wählen Sie mindestens eine Firm aus. \ No newline at end of file +NoCompanySelected: Bitte wählen Sie mindestens eine Firm aus. +TableIsDefaultSupervisor: Standardansprechpartner +TableIsDefaultReroute: Standardumleitung \ No newline at end of file diff --git a/messages/uniworx/categories/firm/en-eu.msg b/messages/uniworx/categories/firm/en-eu.msg index 6d497c91e..7491437fe 100644 --- a/messages/uniworx/categories/firm/en-eu.msg +++ b/messages/uniworx/categories/firm/en-eu.msg @@ -28,4 +28,6 @@ FilterFirmExtern: External company FirmSupervisorOf fsh@CompanyShorthand: Supervisors belonging to #{fsh} FirmSupervisorIndependent: Independent supervisors FirmEmployeeOf fsh@CompanyShorthand: #{fsh} associated users -NoCompanySelected: Select at least one company, please. \ No newline at end of file +NoCompanySelected: Select at least one company, please. +TableIsDefaultSupervisor: Default supervisor +TableIsDefaultReroute: Default reroute \ No newline at end of file diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index e7020fab4..17990295c 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -41,6 +41,11 @@ import Database.Esqueleto.Utils.TH single :: (k,a) -> Map k a single = uncurry Map.singleton +decryptUser :: (MonadHandler m, HandlerSite m ~ UniWorX) => CryptoUUIDUser -> m UserId +decryptUser = decrypt + +encryptUser :: (MonadHandler m, HandlerSite m ~ UniWorX) => UserId -> m CryptoUUIDUser +encryptUser = encrypt --------------------------- -- Firm specific utilities @@ -90,6 +95,120 @@ addDefaultSupervisorsAll mutualSupervision cids = do (\_old new -> [UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications] ) +------------------------------ +-- repeatedly useful queries + +fromUserCompany :: Maybe (E.SqlExpr (Entity UserCompany) -> E.SqlExpr (E.Value Bool)) -> E.SqlExpr (Entity Company) -> E.SqlQuery () +fromUserCompany mbFltr cmpy = do + usrCmpy <- E.from $ E.table @UserCompany + let basecond = usrCmpy E.^. UserCompanyCompany E.==. cmpy E.^. CompanyId + E.where_ $ maybe basecond ((basecond E.&&.).($ usrCmpy)) mbFltr + +firmCountUsers :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) +firmCountUsers = E.subSelectCount . fromUserCompany Nothing + +firmCountSupervisors :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) +firmCountSupervisors = E.subSelectCount . fromUserCompany (Just (E.^. UserCompanySupervisor)) +-- firmCountSupervisors :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) +-- firmCountSupervisors cmpy = E.subSelectCount $ E.distinct $ do +-- usrCmpy <- E.from $ E.table @UserCompany +-- E.where_ $ (usrCmpy E.^. UserCompanyCompany E.==. cmpy E.^. CompanyId) +-- E.&&. (usrCmpy E.^. UserCompanySupervisor E.==. E.true) +-- return $ usrCmpy E.^. UserCompanyUser + +firmHasSupervisors :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Bool) +firmHasSupervisors = E.exists . fromUserCompany (Just (E.^. UserCompanySupervisor)) + + +firmCountDefaultReroutes :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) +firmCountDefaultReroutes = E.subSelectCount . fromUserCompany (Just (\uc -> uc E.^. UserCompanySupervisor E.&&. uc E.^. UserCompanySupervisorReroute)) + +firmHasDefaultReroutes :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Bool) +firmHasDefaultReroutes = E.exists . fromUserCompany (Just (\uc -> uc E.^. UserCompanySupervisor E.&&. uc E.^. UserCompanySupervisorReroute)) + +firmCountEmployeeSupervised :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) +firmCountEmployeeSupervised = E.subSelectCount . fromUserCompany (Just fltr) + where + fltr :: E.SqlExpr (Entity UserCompany) -> E.SqlExpr (E.Value Bool) + fltr usrc = E.exists $ do + usrSuper <- E.from $ E.table @UserSupervisor + E.where_ $ usrSuper E.^. UserSupervisorUser E.==. usrc E.^. UserCompanyUser + +firmCountEmployeeRerouted :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) +firmCountEmployeeRerouted = E.subSelectCount . fromUserCompany (Just fltr) + where + fltr usrc = E.exists $ do + usrSuper <- E.from $ E.table @UserSupervisor + E.where_ $ usrSuper E.^. UserSupervisorUser E.==. usrc E.^. UserCompanyUser + E.&&. usrSuper E.^. UserSupervisorRerouteNotifications + +firmCountEmployeeRerPost :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) +firmCountEmployeeRerPost = E.subSelectCount . fromUserCompany (Just fltr) + where + fltr usrc = E.exists $ do + (usrSuper :& usr) <- + E.from $ E.table @UserSupervisor + `E.innerJoin` E.table @User + `E.on` (\(usrSuper :& usr) -> usrSuper E.^. UserSupervisorSupervisor E.==. usr E.^. UserId) + E.where_ $ usrSuper E.^. UserSupervisorUser E.==. usrc E.^. UserCompanyUser + E.&&. usrSuper E.^. UserSupervisorRerouteNotifications + E.&&. usr E.^. UserPrefersPostal + E.&&. E.isJust (usr E.^. UserPostAddress) + + +-- firmCountForeignSupervisors :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) +-- firmCountForeignSupervisors cmpy = E.coalesceDefault +-- [E.subSelect $ do +-- usrSuper <- E.from $ E.table @UserSupervisor +-- E.groupBy (usrSuper E.^. UserSupervisorSupervisor) +-- E.where_ $ E.exists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorUser) cmpy) +-- E.&&. E.notExists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorSupervisor) cmpy) +-- return E.countRows +-- ] (E.val 0) + +firmCountForeignSupervisors :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) +firmCountForeignSupervisors cmpy = E.subSelectCountDistinct $ do + usrSuper <- E.from $ E.table @UserSupervisor + E.where_ $ E.exists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorUser) cmpy) + E.&&. E.notExists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorSupervisor) cmpy) + pure $ usrSuper E.^. UserSupervisorSupervisor + +-- firmCountActiveReroutes :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) +-- firmCountActiveReroutes cmpy = E.subSelectCountDistinct $ do +-- usrSuper <- E.from $ E.table @UserSupervisor +-- E.where_ $ E.exists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorUser) cmpy) +-- E.&&. usrSuper E.^. UserSupervisorRerouteNotifications +-- pure $ usrSuper E.^. UserSupervisorSupervisor + +firmCountActiveReroutes :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) +firmCountActiveReroutes cmpy = E.subSelectCount $ do + usrSuper <- E.from $ E.table @UserSupervisor + E.where_ $ E.exists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorUser) cmpy) + E.&&. usrSuper E.^. UserSupervisorRerouteNotifications + +firmQuerySupervisedBy :: CompanyId -> Maybe (E.SqlExpr (Entity UserSupervisor) -> E.SqlExpr (E.Value Bool)) -> E.SqlExpr (Entity User) -> E.SqlQuery () +firmQuerySupervisedBy cid mbFltr usr = do + (usrSpr :& usrCmp) <- E.from $ E.table @UserSupervisor + `E.innerJoin` E.table @UserCompany + `E.on` (\(usrSpr :& usrCmp) -> usrSpr E.^. UserSupervisorUser E.==. usrCmp E.^. UserCompanyUser) + let basecond = usrSpr E.^. UserSupervisorSupervisor E.==. usr E.^. UserId + E.&&. usrCmp E.^. UserCompanyCompany E.==. E.val cid + E.where_ $ maybe basecond ((basecond E.&&.).($ usrSpr)) mbFltr + +firmCountForSupervisor :: CompanyId -> Maybe (E.SqlExpr (Entity UserSupervisor) -> E.SqlExpr (E.Value Bool)) -> E.SqlExpr (Entity User) -> E.SqlExpr (E.Value Word64) +firmCountForSupervisor = ((E.subSelectCount .) .) . firmQuerySupervisedBy + +firmCountUserSupervisors :: E.SqlExpr (Entity UserCompany) -> E.SqlExpr (E.Value Word64) +firmCountUserSupervisors usrCmp = E.subSelectCount $ do + usrSpr <- E.from $ E.table @UserSupervisor + E.where_ $ usrSpr E.^. UserSupervisorUser E.==. usrCmp E.^. UserCompanyUser + +firmCountUserSupervisorsReroute :: E.SqlExpr (Entity UserCompany) -> E.SqlExpr (E.Value Word64) +firmCountUserSupervisorsReroute usrCmp = E.subSelectCount $ do + usrSpr <- E.from $ E.table @UserSupervisor + E.where_ $ usrSpr E.^. UserSupervisorUser E.==. usrCmp E.^. UserCompanyUser + E.&&. usrSpr E.^. UserSupervisorRerouteNotifications + ------------------ -- Debug Handler @@ -190,95 +309,6 @@ resultAllCompanyDefaultReroutes :: Lens' AllCompanyTableData Bool resultAllCompanyDefaultReroutes = _dbrOutput . _4 . _unValue -fromUserCompany :: Maybe (E.SqlExpr (Entity UserCompany) -> E.SqlExpr (E.Value Bool)) -> E.SqlExpr (Entity Company) -> E.SqlQuery () -fromUserCompany mbFltr cmpy = do - usrCmpy <- E.from $ E.table @UserCompany - let basecond = usrCmpy E.^. UserCompanyCompany E.==. cmpy E.^. CompanyId - E.where_ $ maybe basecond ((basecond E.&&.).($ usrCmpy)) mbFltr - -firmCountUsers :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) -firmCountUsers = E.subSelectCount . fromUserCompany Nothing - -firmCountSupervisors :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) -firmCountSupervisors = E.subSelectCount . fromUserCompany (Just (E.^. UserCompanySupervisor)) --- firmCountSupervisors :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) --- firmCountSupervisors cmpy = E.subSelectCount $ E.distinct $ do --- usrCmpy <- E.from $ E.table @UserCompany --- E.where_ $ (usrCmpy E.^. UserCompanyCompany E.==. cmpy E.^. CompanyId) --- E.&&. (usrCmpy E.^. UserCompanySupervisor E.==. E.true) --- return $ usrCmpy E.^. UserCompanyUser - -firmHasSupervisors :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Bool) -firmHasSupervisors = E.exists . fromUserCompany (Just (E.^. UserCompanySupervisor)) - - -firmCountDefaultReroutes :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) -firmCountDefaultReroutes = E.subSelectCount . fromUserCompany (Just (\uc -> uc E.^. UserCompanySupervisor E.&&. uc E.^. UserCompanySupervisorReroute)) - -firmHasDefaultReroutes :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Bool) -firmHasDefaultReroutes = E.exists . fromUserCompany (Just (\uc -> uc E.^. UserCompanySupervisor E.&&. uc E.^. UserCompanySupervisorReroute)) - -firmCountEmployeeSupervised :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) -firmCountEmployeeSupervised = E.subSelectCount . fromUserCompany (Just fltr) - where - fltr :: E.SqlExpr (Entity UserCompany) -> E.SqlExpr (E.Value Bool) - fltr usrc = E.exists $ do - usrSuper <- E.from $ E.table @UserSupervisor - E.where_ $ usrSuper E.^. UserSupervisorUser E.==. usrc E.^. UserCompanyUser - -firmCountEmployeeRerouted :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) -firmCountEmployeeRerouted = E.subSelectCount . fromUserCompany (Just fltr) - where - fltr usrc = E.exists $ do - usrSuper <- E.from $ E.table @UserSupervisor - E.where_ $ usrSuper E.^. UserSupervisorUser E.==. usrc E.^. UserCompanyUser - E.&&. usrSuper E.^. UserSupervisorRerouteNotifications - -firmCountEmployeeRerPost :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) -firmCountEmployeeRerPost = E.subSelectCount . fromUserCompany (Just fltr) - where - fltr usrc = E.exists $ do - (usrSuper :& usr) <- - E.from $ E.table @UserSupervisor - `E.innerJoin` E.table @User - `E.on` (\(usrSuper :& usr) -> usrSuper E.^. UserSupervisorSupervisor E.==. usr E.^. UserId) - E.where_ $ usrSuper E.^. UserSupervisorUser E.==. usrc E.^. UserCompanyUser - E.&&. usrSuper E.^. UserSupervisorRerouteNotifications - E.&&. usr E.^. UserPrefersPostal - E.&&. E.isJust (usr E.^. UserPostAddress) - - --- firmCountForeignSupervisors :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) --- firmCountForeignSupervisors cmpy = E.coalesceDefault --- [E.subSelect $ do --- usrSuper <- E.from $ E.table @UserSupervisor --- E.groupBy (usrSuper E.^. UserSupervisorSupervisor) --- E.where_ $ E.exists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorUser) cmpy) --- E.&&. E.notExists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorSupervisor) cmpy) --- return E.countRows --- ] (E.val 0) - -firmCountForeignSupervisors :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) -firmCountForeignSupervisors cmpy = E.subSelectCountDistinct $ do - usrSuper <- E.from $ E.table @UserSupervisor - E.where_ $ E.exists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorUser) cmpy) - E.&&. E.notExists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorSupervisor) cmpy) - pure $ usrSuper E.^. UserSupervisorSupervisor - --- firmCountActiveReroutes :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) --- firmCountActiveReroutes cmpy = E.subSelectCountDistinct $ do --- usrSuper <- E.from $ E.table @UserSupervisor --- E.where_ $ E.exists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorUser) cmpy) --- E.&&. usrSuper E.^. UserSupervisorRerouteNotifications --- pure $ usrSuper E.^. UserSupervisorSupervisor - -firmCountActiveReroutes :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) -firmCountActiveReroutes cmpy = E.subSelectCount $ do - usrSuper <- E.from $ E.table @UserSupervisor - E.where_ $ E.exists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorUser) cmpy) - E.&&. usrSuper E.^. UserSupervisorRerouteNotifications - - mkFirmAllTable :: Bool -> UserId -> DB (FormResult (FirmAllActionData, Set CompanyId), Widget) mkFirmAllTable isAdmin uid = do -- now <- liftIO getCurrentTime @@ -438,17 +468,18 @@ postFirmAllR = do formResult firmRes $ \case (_, fids) | null fids -> addMessageI Error MsgNoCompanySelected - (FirmAllActResetSupervisionData{..}, fids) -> runDB $ do - delSupers <- if firmAllActResetKeepOldSupers == Just False - then E.deleteCount $ do - spr <- E.from $ E.table @UserSupervisor - E.where_ $ E.exists $ do - usr <- E.from $ E.table @UserCompany - E.where_ $ usr E.^. UserCompanyCompany `E.in_` E.vals fids - E.&&. usr E.^. UserCompanyUser E.==. spr E.^. UserSupervisorUser - else return 0 - newSupers <- addDefaultSupervisorsAll (firmAllActResetMutualSupervision /= Just False) fids - addMessageI Info $ MsgFirmResetSupervision newSupers delSupers + (FirmAllActResetSupervisionData{..}, fids) -> do + runDB $ do + delSupers <- if firmAllActResetKeepOldSupers == Just False + then E.deleteCount $ do + spr <- E.from $ E.table @UserSupervisor + E.where_ $ E.exists $ do + usr <- E.from $ E.table @UserCompany + E.where_ $ usr E.^. UserCompanyCompany `E.in_` E.vals fids + E.&&. usr E.^. UserCompanyUser E.==. spr E.^. UserSupervisorUser + else return 0 + newSupers <- addDefaultSupervisorsAll (firmAllActResetMutualSupervision /= Just False) fids + addMessageI Info $ MsgFirmResetSupervision newSupers delSupers reloadKeepGetParams FirmAllR -- reload to reflect changes (FirmAllActNotifyData , Set.toList -> fids) -> do @@ -508,20 +539,23 @@ instance HasUser UserCompanyTableData where hasUser = resultUserUser . _entityVal -firmCountUserSupervisors :: E.SqlExpr (Entity UserCompany) -> E.SqlExpr (E.Value Word64) -firmCountUserSupervisors usrCmp = E.subSelectCount $ do - usrSpr <- E.from $ E.table @UserSupervisor - E.where_ $ usrSpr E.^. UserSupervisorUser E.==. usrCmp E.^. UserCompanyUser - -firmCountUserSupervisorsReroute :: E.SqlExpr (Entity UserCompany) -> E.SqlExpr (E.Value Word64) -firmCountUserSupervisorsReroute usrCmp = E.subSelectCount $ do - usrSpr <- E.from $ E.table @UserSupervisor - E.where_ $ usrSpr E.^. UserSupervisorUser E.==. usrCmp E.^. UserCompanyUser - E.&&. usrSpr E.^. UserSupervisorRerouteNotifications - mkFirmUserTable :: Bool -> CompanyId -> DB (FormResult (FirmUserActionData, Set UserId), Widget) mkFirmUserTable isAdmin cid = do let + mkSprOption (E.Value uid, E.Value udn) = do + uuid <- toPathPiece <$> encryptUser uid + return Option{ optionDisplay = udn, optionInternalValue = uid, optionExternalValue = uuid } + procOptions = fmap mkOptionList . traverse mkSprOption + + rawSupers <- E.select $ do + usr <- E.from $ E.table @User + E.where_ $ E.exists $ firmQuerySupervisedBy cid Nothing usr + return (usr E.^. UserId, usr E.^. UserDisplayName) + let + -- supervisorField :: Field Handler UserId + supervisorField = selectField $ procOptions rawSupers + supervisorsField = multiSelectField $ procOptions rawSupers + fsh = unCompanyKey cid resultDBTable = DBTable{..} where @@ -586,11 +620,30 @@ mkFirmUserTable isAdmin cid = do Nothing -> E.true Just True -> E.exists checkSuper Just False -> E.notExists checkSuper + , singletonMap "supervisor-is" $ FilterColumn $ \row (getLast -> criterion) -> + case criterion of + Just uid -> do + -- uid <- decryptUser uuid + E.exists $ do + usrSpr <- E.from $ E.table @UserSupervisor + E.where_ $ usrSpr E.^. UserSupervisorUser E.==. queryUserUser row E.^. UserId + E.&&. usrSpr E.^. UserSupervisorSupervisor E.==. E.val uid + _otherwise -> E.true + , singletonMap "supervisors-are" $ FilterColumn $ \row criteria -> + case criteria of + _ | Set.null criteria -> E.true + | otherwise -> do + -- uids <- traverse decryptUser criteria + E.exists $ do + usrSpr <- E.from $ E.table @UserSupervisor + E.where_ $ usrSpr E.^. UserSupervisorUser E.==. queryUserUser row E.^. UserId + E.&&. usrSpr E.^. UserSupervisorSupervisor `E.in_` E.vals criteria ] -- superField = selectField $ ???? dbtFilterUI mPrev = mconcat [ fltrUserNameEmailHdrUI MsgTableCompanyUser mPrev - , prismAForm (singletonFilter "supervisor-is" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift termField) (fslI MsgTableTerm) + , prismAForm (singletonFilter "supervisor-is" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift supervisorField) (fslI MsgFilterSupervisor) + -- , prismAForm (multiFilter "supervisors-are" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift supervisorsField) (fslI MsgFilterSupervisor) , prismAForm (singletonFilter "has-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterSupervisor) , prismAForm (singletonFilter "has-company-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI $ MsgFilterSupervisorCompany fsh) , prismAForm (singletonFilter "has-foreign-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI $ MsgFilterSupervisorForeign fsh) @@ -694,12 +747,18 @@ data FirmSuperActionData = FirmSuperActNotifyData | FirmSuperActRMSuperAllData deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) -type SuperCompanyTableExpr = E.SqlExpr (Entity User) +type SuperCompanyTableExpr = E.SqlExpr (Entity User) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity UserCompany)) querySuperUser :: SuperCompanyTableExpr -> E.SqlExpr (Entity User) -querySuperUser = id +querySuperUser = $(sqlLOJproj 2 1) -type SuperCompanyTableData = DBRow (Entity User, E.Value Word64, E.Value Word64, [(E.Value CompanyName, E.Value CompanyShorthand, E.Value Bool)]) +querySuperUserCompany :: SuperCompanyTableExpr -> E.SqlExpr (Maybe (Entity UserCompany)) +querySuperUserCompany = $(sqlLOJproj 2 2) + +type SuperCompanyTableData = DBRow (Entity User, E.Value Word64, E.Value Word64 + , [(E.Value CompanyName, E.Value CompanyShorthand, E.Value Bool)] + , E.Value (Maybe Bool), E.Value (Maybe Bool) -- Maybe (Entity UserCompany) + ) resultSuperUser :: Lens' SuperCompanyTableData (Entity User) resultSuperUser = _dbrOutput . _1 @@ -713,6 +772,11 @@ resultSuperCompanyReroutes = _dbrOutput . _3 . _unValue resultSuperCompanies :: Lens' SuperCompanyTableData [(E.Value CompanyName, E.Value CompanyShorthand, E.Value Bool)] resultSuperCompanies = _dbrOutput . _4 +resultSuperCompanyDefaultSuper :: Lens' SuperCompanyTableData (Maybe Bool) +resultSuperCompanyDefaultSuper = _dbrOutput . _5 . _unValue + +resultSuperCompanyDefaultReroute :: Lens' SuperCompanyTableData (Maybe Bool) +resultSuperCompanyDefaultReroute = _dbrOutput . _6 . _unValue instance HasEntity SuperCompanyTableData User where hasEntity = resultSuperUser @@ -720,17 +784,6 @@ instance HasEntity SuperCompanyTableData User where instance HasUser SuperCompanyTableData where hasUser = resultSuperUser . _entityVal -firmQuerySupervisedBy :: CompanyId -> Maybe (E.SqlExpr (Entity UserSupervisor) -> E.SqlExpr (E.Value Bool)) -> E.SqlExpr (Entity User) -> E.SqlQuery () -firmQuerySupervisedBy cid mbFltr usr = do - (usrSpr :& usrCmp) <- E.from $ E.table @UserSupervisor - `E.innerJoin` E.table @UserCompany - `E.on` (\(usrSpr :& usrCmp) -> usrSpr E.^. UserSupervisorUser E.==. usrCmp E.^. UserCompanyUser) - let basecond = usrSpr E.^. UserSupervisorSupervisor E.==. usr E.^. UserId - E.&&. usrCmp E.^. UserCompanyCompany E.==. E.val cid - E.where_ $ maybe basecond ((basecond E.&&.).($ usrSpr)) mbFltr - -firmCountForSupervisor :: CompanyId -> Maybe (E.SqlExpr (Entity UserSupervisor) -> E.SqlExpr (E.Value Bool)) -> E.SqlExpr (Entity User) -> E.SqlExpr (E.Value Word64) -firmCountForSupervisor = ((E.subSelectCount .) .) . firmQuerySupervisedBy mkFirmSuperTable :: Bool -> CompanyId -> DB (FormResult (FirmSuperActionData, Set UserId), Widget) mkFirmSuperTable isAdmin cid = do @@ -738,20 +791,23 @@ mkFirmSuperTable isAdmin cid = do -- fsh = unCompanyKey cid resultDBTable = DBTable{..} where - dbtSQLQuery = \usr -> do + dbtSQLQuery = \(usr `E.LeftOuterJoin` usrCmp) -> do + EL.on $ usr E.^. UserId E.=?. usrCmp E.?. UserCompanyUser E.&&. usrCmp E.?. UserCompanyCompany E.?=. E.val cid E.where_ $ E.exists $ firmQuerySupervisedBy cid Nothing usr return ( usr , usr & firmCountForSupervisor cid Nothing , usr & firmCountForSupervisor cid (Just (E.^. UserSupervisorRerouteNotifications)) + , usrCmp E.?. UserCompanySupervisor + , usrCmp E.?. UserCompanySupervisorReroute ) dbtRowKey = querySuperUser >>> (E.^. UserId) - dbtProj = dbtProjSimple $ \(usr, supervised, rerouted) -> do + dbtProj = dbtProjSimple $ \(usr, supervised, rerouted, supervisor, reroute) -> do cmps <- E.select $ do (cmp :& usrCmp) <- E.from $ E.table @Company `E.innerJoin` E.table @UserCompany `E.on` (\(cmp :& usrCmp) -> cmp E.^. CompanyId E.==. usrCmp E.^. UserCompanyCompany) E.where_ $ usrCmp E.^. UserCompanyUser E.==. E.val (entityKey usr) E.orderBy [E.asc $ cmp E.^. CompanyName] return (cmp E.^. CompanyName, cmp E.^. CompanyShorthand, usrCmp E.^. UserCompanySupervisor) - return (usr, supervised, rerouted, cmps) + return (usr, supervised, rerouted, cmps, supervisor, reroute) dbtColonnade = formColonnade $ mconcat [ guardMonoid isAdmin $ dbSelect (applying _2) id (return . view (resultSuperUser . _entityKey)) , colUserNameModalHdr MsgTableSupervisor ForProfileDataR @@ -761,8 +817,10 @@ mkFirmSuperTable isAdmin cid = do , sortable (Just "personal-number") (i18nCell MsgCompanyPersonalNumber) $ \(view $ resultSuperUser . _userCompanyPersonalNumber -> t) -> foldMap textCell t , sortable (Just "postal-pref") (i18nCell MsgPrefersPostal) $ \(view $ resultSuperUser . _userPrefersPostal -> b) -> iconFixedCell $ iconLetterOrEmail b , colUserEmail - , sortable (Just "supervised") (i18nCell MsgTableCompanyNrEmpSupervised) $ \(view resultSuperCompanySupervised -> nr) -> wgtCell $ word2widget nr - , sortable (Just "rerouted") (i18nCell MsgTableCompanyNrEmpRerouted ) $ \(view resultSuperCompanyReroutes -> nr) -> wgtCell $ word2widget nr + , sortable (Just "supervised") (i18nCell MsgTableCompanyNrEmpSupervised) $ \(view resultSuperCompanySupervised -> nr) -> wgtCell $ word2widget nr + , sortable (Just "rerouted") (i18nCell MsgTableCompanyNrEmpRerouted ) $ \(view resultSuperCompanyReroutes -> nr) -> wgtCell $ word2widget nr + , sortable (Just "def-super") (i18nCell MsgTableIsDefaultSupervisor) $ \(view resultSuperCompanyDefaultSuper -> mb) -> case mb of { Nothing -> iconCell IconSupervisorForeign; Just True -> iconCell IconSupervisor; Just False -> iconSpacerCell } + , sortable (Just "def-reroute") (i18nCell MsgTableIsDefaultReroute) $ \(view resultSuperCompanyDefaultReroute -> mb) -> tickmarkCell (mb == Just True) ] dbtSorting = mconcat [ single $ sortUserNameLink querySuperUser @@ -778,6 +836,8 @@ mkFirmSuperTable isAdmin cid = do E.orderBy [E.asc $ cmp E.^. CompanyName] return (cmp E.^. CompanyName) ) + , singletonMap "def-super" $ SortColumn $ querySuperUserCompany >>> (E.?. UserCompanySupervisor) + , singletonMap "def-reroute" $ SortColumn $ querySuperUserCompany >>> (E.?. UserCompanySupervisorReroute) ] dbtFilter = mconcat [ single $ fltrUserNameEmail querySuperUser diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index 2e44c6323..415fb255b 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -37,7 +37,7 @@ module Handler.Utils.Table.Pagination , dbtProjFilteredPostId, dbtProjFilteredPostSimple , noCsvEncode, simpleCsvEncode, simpleCsvEncodeM , withCsvExtraRep - , singletonFilter + , singletonFilter, multiFilter , DBParams(..) , cellAttrs, cellContents , addCellClass @@ -647,6 +647,13 @@ singletonFilter key = prism' fromInner (fmap Just . fromOuter) fromInner = maybe Map.empty $ Map.singleton key . pure fromOuter = Map.lookup key >=> listToMaybe +multiFilter :: Ord k => k -> Prism' (Map k [v]) (Maybe [v]) +-- ^ for use with @prismAForm@ +multiFilter key = prism' fromInner fromOuter + where + -- prism' :: (Maybe [v] -> (Map k [v])) -> ((Map k [v]) -> Maybe (Maybe [v])) -> Prism' (Map k [v]) (Maybe [v]) + fromInner = maybe Map.empty (Map.singleton key) + fromOuter = Just . Map.lookup key data DBTCsvEncode r' k' csv = forall exportData filename sheetName. ( ToNamedRecord csv, CsvColumnsExplained csv diff --git a/src/Utils/Icon.hs b/src/Utils/Icon.hs index 982d19b5f..0018e74e0 100644 --- a/src/Utils/Icon.hs +++ b/src/Utils/Icon.hs @@ -109,12 +109,14 @@ data Icon | IconLetter | IconAt | IconSupervisor + | IconSupervisorForeign -- | IconWaitingForUser | IconExpired | IconLocked | IconUnlocked | IconResetTries -- also see IconReset | IconCompany + deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic) deriving anyclass (Universe, Finite, NFData) @@ -201,12 +203,13 @@ iconText = \case IconLetter -> "mail-bulk" -- Problem "envelope" already used for email as well IconAt -> "at" -- alternative for IconEmail to distinguish from IconLetter IconSupervisor -> "head-side" -- must be notably different to user + IconSupervisorForeign -> "alien" -- IconWaitingForUser -> "user-cog" -- Waiting on a user to do something IconExpired -> "hourglass-end" IconLocked -> "lock" IconUnlocked -> "lock-open-alt" IconResetTries -> "trash-undo" - IconCompany -> "building" + IconCompany -> "building" nullaryPathPiece ''Icon $ camelToPathPiece' 1 deriveLift ''Icon From 44c4b3b6a8a6e7a8154bb10a9b0bfbeab61b232f Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 17 Nov 2023 18:54:34 +0100 Subject: [PATCH 49/50] chore(firm): implement several table actions; add supervisor form --- .../uniworx/categories/firm/de-de-formal.msg | 8 +- messages/uniworx/categories/firm/en-eu.msg | 8 +- messages/uniworx/utils/utils/de-de-formal.msg | 3 + messages/uniworx/utils/utils/en-eu.msg | 3 + src/Foundation/I18n.hs | 5 + src/Handler/Firm.hs | 167 +++++++++++++----- src/Handler/Utils/Form.hs | 15 +- src/Utils/Form.hs | 1 + .../i18n/firm-supervisors/de-de-formal.hamlet | 27 +++ templates/i18n/firm-supervisors/en-eu.hamlet | 26 +++ 10 files changed, 212 insertions(+), 51 deletions(-) create mode 100644 templates/i18n/firm-supervisors/de-de-formal.hamlet create mode 100644 templates/i18n/firm-supervisors/en-eu.hamlet diff --git a/messages/uniworx/categories/firm/de-de-formal.msg b/messages/uniworx/categories/firm/de-de-formal.msg index 71c910999..49fc0d066 100644 --- a/messages/uniworx/categories/firm/de-de-formal.msg +++ b/messages/uniworx/categories/firm/de-de-formal.msg @@ -11,6 +11,7 @@ FirmAllActResetSupervision: Ansprechpartner für alle Firmenangehörigen zurück FirmAllActResetSuperKeep: Bisherige Ansprechpartner der Firmenangehörigen zusätzlich beibehalten? FirmAllActResetMutualSupervision: Ansprechpartner beaufsichtigen sich gegenseitig FirmUserActNotify: Mitteilung versenden +FirmUserActResetSupervision: Ansprechpartner auf Firmenstandard zurücksetzen FirmUserActMkSuper: Zum Firmenansprechpartner ernennen FirmResetSupervision rem@Int64 set@Int64: #{tshow set} Ansprechpartner gesetzt#{bool mempty (", " <> tshow rem <> " zuvor gelöscht") (rem > 0)} FirmSuperActNotify: Mitteilung versenden @@ -30,4 +31,9 @@ FirmSupervisorIndependent: Ansprechpartner ohne jegliche Firmenzugehörigkeit FirmEmployeeOf fsh@CompanyShorthand: Firmenangehörige #{fsh} NoCompanySelected: Bitte wählen Sie mindestens eine Firm aus. TableIsDefaultSupervisor: Standardansprechpartner -TableIsDefaultReroute: Standardumleitung \ No newline at end of file +TableIsDefaultReroute: Standardumleitung +ASReqPostal: Benachrichtigungseinstellung +ASReqPostalTip: Gilt für alle Benachrichtigungen an diese Person, nicht nur für Umleitungen an diesen Ansprechpartner +ASReqEmpty: Es konnten keine Ansprechpartner hinzugefügt werden +ASReqSetSupers n@Int64 postal@(Maybe Bool): #{n} Standardansprechpartner eingetragen #{maybeBoolMessage postal "" "und auf Briefversand geschaltet" "und Benachrichtigungen per Email gesetzt"}, aber nicht nicht aktiviert. +RemoveDefaultSupervisors n@Int64: #{n} Standard Ansprechpartner entfernt, aber noch nicht deaktiviert. \ No newline at end of file diff --git a/messages/uniworx/categories/firm/en-eu.msg b/messages/uniworx/categories/firm/en-eu.msg index 7491437fe..39e46d552 100644 --- a/messages/uniworx/categories/firm/en-eu.msg +++ b/messages/uniworx/categories/firm/en-eu.msg @@ -11,6 +11,7 @@ FirmAllActResetSupervision: Reset supervisors for all company associates FirmUserActNotify: Send message FirmAllActResetSuperKeep: Additionally keep existing supervisors of company associates? FirmAllActResetMutualSupervision: Supervisors supervise each other +FirmUserActResetSupervision: Reset supervisors to company default FirmResetSupervision rem set: #{tshow set} supervisors set#{bool mempty (", " <> tshow rem <> " deleted before") (rem > 0)} FirmUserActMkSuper: Mark as company supervisor FirmSuperActNotify: Send message @@ -30,4 +31,9 @@ FirmSupervisorIndependent: Independent supervisors FirmEmployeeOf fsh@CompanyShorthand: #{fsh} associated users NoCompanySelected: Select at least one company, please. TableIsDefaultSupervisor: Default supervisor -TableIsDefaultReroute: Default reroute \ No newline at end of file +TableIsDefaultReroute: Default reroute +ASReqPostal: Notification type +ASReqPostalTip: Affects all notifications to this person, not just reroutes to this supervisor +ASReqEmpty: No supervisors added +ASReqSetSupers n postal: #{n} default company supervisors set #{maybeBoolMessage postal "" "and switched to postal notifications" "and switched to email notifications"}, but not yet activated. +RemoveDefaultSupervisors n: #{n} default supervisors removed, but not yet deactivated. \ No newline at end of file diff --git a/messages/uniworx/utils/utils/de-de-formal.msg b/messages/uniworx/utils/utils/de-de-formal.msg index c02cbe1fb..f25770b33 100644 --- a/messages/uniworx/utils/utils/de-de-formal.msg +++ b/messages/uniworx/utils/utils/de-de-formal.msg @@ -18,6 +18,8 @@ CommRecipients: Empfänger:innen CommRecipientsTip: Sie selbst erhalten immer eine Kopie der Nachricht CommRecipientsList: Die an Sie selbst verschickte Kopie der Nachricht wird, zu Archivierungszwecken, eine vollständige Liste aller Empfänger:innen enthalten. Die Empfängerliste wird im CSV-Format an die E-Mail angehängt. Andere Empfänger:innen erhalten die Liste nicht. Bitte entfernen Sie dementsprechend den Anhang bevor Sie die E-Mail weiterleiten oder anderweitig mit Dritten teilen. UtilEMail: E-Mail +UtilPostal: Brief +UtilUnchanged: Nicht verändern UtilMultiEmailFieldTip: Es sind mehrere, Komma-separierte, E-Mail-Adressen möglich RGTutorialParticipants tutn@TutorialName: Kursteilnehmer:innen (#{tutn}) RGExamRegistered examn@ExamName: Angemeldet zur Prüfung „#{examn}“ @@ -94,6 +96,7 @@ RoomReferenceLinkLink !ident-ok: Link RoomReferenceLinkLinkPlaceholder !ident-ok: URL RoomReferenceLinkInstructions: Anweisungen RoomReferenceLinkInstructionsPlaceholder: Anweisungen +UtilEmptyChoice: Auswahl war leer #invitation.hs InvitationAction: Aktion diff --git a/messages/uniworx/utils/utils/en-eu.msg b/messages/uniworx/utils/utils/en-eu.msg index 1135dbade..97f5daa22 100644 --- a/messages/uniworx/utils/utils/en-eu.msg +++ b/messages/uniworx/utils/utils/en-eu.msg @@ -18,6 +18,8 @@ CommRecipients: Recipients CommRecipientsTip: You always receive a copy of the message CommRecipientsList: For archival purposes the copy of the message sent to you will contain a complete list of all recipients. The list of recipients will be attached to the email in CSV-format. Other recipients do not receive the list. Thus, please remove the attachment before you forward the email or otherwise share it with third parties. UtilEMail: Email +UtilPostal: Postal +UtilUnchanged: No change UtilMultiEmailFieldTip: Multiple emails addresses may be specified (comma-separated) RGTutorialParticipants tutn: Course participants (#{tutn}) RGExamRegistered examn: Registered for exam “#{examn}” @@ -94,6 +96,7 @@ RoomReferenceLinkLink: Link RoomReferenceLinkLinkPlaceholder: URL RoomReferenceLinkInstructions: Instructions RoomReferenceLinkInstructionsPlaceholder: Instructions +UtilEmptyChoice: Empty selection #invitation.hs InvitationAction: Action diff --git a/src/Foundation/I18n.hs b/src/Foundation/I18n.hs index a7fd0ac1d..8c8a0137b 100644 --- a/src/Foundation/I18n.hs +++ b/src/Foundation/I18n.hs @@ -203,6 +203,11 @@ maybeToMessage :: ToMessage m => Text -> Maybe m -> Text -> Text maybeToMessage _ Nothing _ = mempty maybeToMessage before (Just x) after = before <> toMessage x <> after +maybeBoolMessage :: Maybe Bool -> Text -> Text -> Text -> Text +maybeBoolMessage Nothing n _ _ = n +maybeBoolMessage (Just True) _ t _ = t +maybeBoolMessage (Just False) _ _ f = f + newtype ShortTermIdentifier = ShortTermIdentifier TermIdentifier deriving stock (Eq, Ord, Read, Show) diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 17990295c..c55eee0fb 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -21,6 +21,7 @@ import Import -- import Jobs import Handler.Utils import Handler.Utils.Communication +import Handler.Utils.Avs (guessAvsUser) import qualified Data.Set as Set import qualified Data.Map as Map @@ -28,7 +29,7 @@ import qualified Data.Map as Map -- import qualified Data.Text as T import qualified Data.CaseInsensitive as CI -- import qualified Data.Conduit.List as C -import Database.Persist.Sql (deleteWhereCount) +import Database.Persist.Sql (deleteWhereCount, updateWhereCount) import Database.Esqueleto.Experimental ((:&)(..)) import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma import qualified Database.Esqueleto.Legacy as EL (from, on) @@ -77,16 +78,18 @@ addDefaultSupervisors cid employees = do ) (\_old new -> [UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications]) --- like `addDefaultSupervisors`, but selects all employees from database -addDefaultSupervisorsAll :: (MonoFoldable mono, CompanyId ~ Element mono) => Bool -> mono -> DB Int64 +-- like `addDefaultSupervisors`, but selects all employees of given companies from database +addDefaultSupervisorsAll :: (CompanyId ~ Element mono, MonoFoldable mono) => Bool -> mono -> DB Int64 addDefaultSupervisorsAll mutualSupervision cids = do E.insertSelectWithConflictCount UniqueUserSupervisor (do (spr :& usr) <- E.from $ E.table @UserCompany `E.innerJoin` E.table @UserCompany `E.on` (\(spr :& usr) -> spr E.^. UserCompanyCompany E.==. usr E.^. UserCompanyCompany) - E.where_ $ E.and $ guardMonoid (not mutualSupervision) [ E.not_ $ usr E.^. UserCompanySupervisor ] - <> [ spr E.^. UserCompanyCompany `E.in_` E.vals cids - , spr E.^. UserCompanySupervisor - ] + E.where_ $ E.and $ guardMonoid (not mutualSupervision) + [ E.not_ $ usr E.^. UserCompanySupervisor ] + <> [ spr E.^. UserCompanySupervisor + , spr E.^. UserCompanyCompany `E.in_` E.vals cids + , usr E.^. UserCompanyCompany `E.in_` E.vals cids + ] return $ UserSupervisor E.<# (spr E.^. UserCompanyUser) E.<&> (usr E.^. UserCompanyUser) @@ -216,12 +219,12 @@ firmCountUserSupervisorsReroute usrCmp = E.subSelectCount $ do getFirmR, postFirmR :: CompanyShorthand -> Handler Html getFirmR = postFirmR postFirmR fsh = do - let fshId = CompanyKey fsh + let cid = CompanyKey fsh cusers <- runDB $ do - cusers <- selectList [UserCompanyCompany ==. fshId] [] + cusers <- selectList [UserCompanyCompany ==. cid] [] selectList [UserId <-. fmap (userCompanyUser . entityVal) cusers] [Asc UserDisplayName] csuper <- runDB $ do - csuper <- selectList [UserCompanyCompany ==. fshId, UserCompanySupervisor ==. True] [] + csuper <- selectList [UserCompanyCompany ==. cid, UserCompanySupervisor ==. True] [] selectList [UserId <-. fmap (userCompanyUser . entityVal) csuper] [Asc UserDisplayName] cactSuper <- runDB $ E.select $ do (usr :& spr :& scmpy) <- E.from $ @@ -253,7 +256,7 @@ postFirmR fsh = do
                              • #{nr} Employees supervised by ^{nameWidget dn sn} # #{iconLetterOrEmail prefPost} # $maybe csh <- mbCsh - $if csh /= fshId + $if csh /= cid from foreign company #{unCompanyKey csh} $else from this company @@ -478,8 +481,8 @@ postFirmAllR = do E.where_ $ usr E.^. UserCompanyCompany `E.in_` E.vals fids E.&&. usr E.^. UserCompanyUser E.==. spr E.^. UserSupervisorUser else return 0 - newSupers <- addDefaultSupervisorsAll (firmAllActResetMutualSupervision /= Just False) fids - addMessageI Info $ MsgFirmResetSupervision newSupers delSupers + newSupers <- addDefaultSupervisorsAll (firmAllActResetMutualSupervision /= Just False) fids + addMessageI Info $ MsgFirmResetSupervision delSupers newSupers reloadKeepGetParams FirmAllR -- reload to reflect changes (FirmAllActNotifyData , Set.toList -> fids) -> do @@ -499,6 +502,7 @@ postFirmAllR = do -- Firm Users Table data FirmUserAction = FirmUserActNotify + | FirmUserActResetSupervision | FirmUserActMkSuper deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) deriving anyclass (Universe, Finite) @@ -507,8 +511,14 @@ nullaryPathPiece ''FirmUserAction $ camelToPathPiece' 3 embedRenderMessage ''UniWorX ''FirmUserAction id data FirmUserActionData = FirmUserActNotifyData + | FirmUserActResetSupervisionData + { firmUserActResetKeepOldSupers :: Maybe Bool + -- , firmUserActResetMutualSupervision :: Maybe Bool + } | FirmUserActMkSuperData - deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) + { firmUserActMkSuperReroute :: Maybe Bool } + + deriving (Eq, Ord, Read, Show, Generic) type UserCompanyTableExpr = E.SqlExpr (Entity User) `E.InnerJoin` E.SqlExpr (Entity UserCompany) @@ -651,8 +661,12 @@ mkFirmUserTable isAdmin cid = do dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } acts :: Map FirmUserAction (AForm Handler FirmUserActionData) acts = mconcat - [ singletonMap FirmUserActNotify $ pure FirmUserActNotifyData - , singletonMap FirmUserActMkSuper $ pure FirmUserActMkSuperData + [ singletonMap FirmUserActNotify $ pure FirmUserActNotifyData + , singletonMap FirmUserActResetSupervision $ FirmUserActResetSupervisionData + <$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmAllActResetSuperKeep) (Just $ Just False) + -- <*> aopt checkBoxField (fslI MsgFirmAllActResetMutualSupervision) (Just $ Just True ) + , singletonMap FirmUserActMkSuper $ FirmUserActMkSuperData + <$> aopt checkBoxField (fslI MsgTableIsDefaultReroute) (Just $ Just True) ] dbtParams = DBParamsForm { dbParamsFormMethod = POST @@ -720,10 +734,23 @@ postFirmUsersR fsh = do <*> mkFirmUserTable isAdmin cid formResult fusrRes $ \case - (FirmUserActMkSuperData, fids) -> addMessage Info $ text2Html $ "Make " <> tshow (length fids) <> " employees to supervisors. TODO" - (FirmUserActNotifyData , fids) -> do - cuids <- traverse encrypt $ Set.toList fids :: Handler [CryptoUUIDUser] + (_, uids) | null uids -> addMessageI Error MsgUtilEmptyChoice + (FirmUserActMkSuperData{..}, uids) -> do + nrMkSuper <- runDB $ updateWhereCount [UserCompanyUser <-. uids, UserCompanyCompany ==. cid] [UserCompanySupervisor =. True, UserCompanySupervisorReroute =. firmUserActMkSuperReroute] + addMessageI Info $ MsgASReqSetSupers nrMkSuper Nothing + reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes + (FirmUserActNotifyData , uids) -> do + cuids <- traverse encrypt $ Set.toList uids :: Handler [CryptoUUIDUser] redirect (FirmCommR fsh, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids]) + (FirmUserActResetSupervisionData{..}, Set.toList -> uids') -> do + let uids = fromList uids' -- guaranteed to be non-empty due to first case clause + runDB $ do + delSupers <- if firmUserActResetKeepOldSupers == Just False + then deleteSupervisors uids + else return 0 + newSupers <- addDefaultSupervisors cid uids + addMessageI Info $ MsgFirmResetSupervision delSupers newSupers + reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes siteLayout (citext2widget companyName) $ do setTitle $ toHtml $ CI.original companyShorthand <> "-" <> tshow companyAvsId @@ -745,7 +772,33 @@ embedRenderMessage ''UniWorX ''FirmSuperAction id data FirmSuperActionData = FirmSuperActNotifyData | FirmSuperActRMSuperDefData | FirmSuperActRMSuperAllData - deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) + deriving (Eq, Ord, Read, Show, Generic) + + +data AddSupervisorRequest = AddSupervisorRequest + { asReqSupers :: Set Text + , asReqReroute :: Bool + , asReqPostal :: Maybe Bool + } deriving (Eq, Ord, Show, Generic) + +instance Default AddSupervisorRequest where + def = AddSupervisorRequest + { asReqSupers = mempty + , asReqReroute = True + , asReqPostal = Nothing + } + +postalEmailField :: (MonadHandler m, HandlerSite m ~ UniWorX) => Field m Bool +postalEmailField = boolFieldCustom (SomeMessage MsgUtilPostal) (SomeMessage MsgUtilEMail) $ Just $ SomeMessage MsgUtilUnchanged + +makeAddSupervisorForm :: Maybe AddSupervisorRequest -> Form AddSupervisorRequest +makeAddSupervisorForm template html = do + flip (renderAForm FormStandard) html $ AddSupervisorRequest + <$> areq (textField & cfAnySeparatedSet) + (fslI MsgTableIsDefaultSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) (asReqSupers <$> template) + <*> areq checkBoxField (fslI MsgTableIsDefaultReroute ) (asReqReroute <$> template) + <*> aopt postalEmailField (fslI MsgASReqPostal & setTooltip MsgASReqPostalTip) (asReqPostal <$> template) + type SuperCompanyTableExpr = E.SqlExpr (Entity User) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity UserCompany)) @@ -886,41 +939,59 @@ getFirmSupersR, postFirmSupersR :: CompanyShorthand -> Handler Html getFirmSupersR = postFirmSupersR postFirmSupersR fsh = do isAdmin <- hasReadAccessTo AdminR - let fshId = CompanyKey fsh + let cid = CompanyKey fsh (Company{..},(fsprRes,fsprTable)) <- runDB $ (,) - <$> get404 fshId - <*> mkFirmSuperTable isAdmin fshId + <$> get404 cid + <*> mkFirmSuperTable isAdmin cid formResult fsprRes $ \case - (FirmSuperActRMSuperDefData, fids) -> addMessage Info $ text2Html $ "Remove " <> tshow (length fids) <> " default supervisors. TODO" - (FirmSuperActRMSuperAllData, fids) -> addMessage Info $ text2Html $ "Make " <> tshow (length fids) <> " default and active supervisors. TODO" - (FirmSuperActNotifyData , fids) -> do - cuids <- traverse encrypt $ Set.toList fids :: Handler [CryptoUUIDUser] + (_, uids) | null uids -> addMessageI Error MsgUtilEmptyChoice + (FirmSuperActRMSuperDefData, uids) -> do + nrRmSuper <- runDB $ updateWhereCount [UserCompanyUser <-. uids, UserCompanyCompany ==. cid] [UserCompanySupervisor =. False, UserCompanySupervisorReroute =. False] + addMessageI Info $ MsgRemoveDefaultSupervisors nrRmSuper + reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes + (FirmSuperActRMSuperAllData, uids) -> addMessage Info $ text2Html $ "Make " <> tshow (length uids) <> " default and active supervisors. TODO" + (FirmSuperActNotifyData , uids) -> do + cuids <- traverse encrypt $ Set.toList uids :: Handler [CryptoUUIDUser] redirect (FirmCommR fsh, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids]) + ((asReqRes, asReqWgt), asReqEnctype) <- runFormPost . identifyForm FIDAddSupervisor $ makeAddSupervisorForm (Just def) + let addSuperAnchor = "add-supervisors-form" :: Text + routeAddSuperForm = FirmSupersR fsh :#: addSuperAnchor + addSuperForm = wrapForm asReqWgt FormSettings + { formMethod = POST + , formAction = Just . SomeRoute $ routeAddSuperForm + , formEncoding = asReqEnctype + , formAttrs = [] + , formSubmit = FormSubmit + , formAnchor = Just addSuperAnchor + } + formResult asReqRes $ \AddSupervisorRequest{..} -> do + avsUsers :: Map Text (Maybe UserId) <- sequenceA $ Map.fromSet guessAvsUser asReqSupers + let (usersFound', usersNotFound) = partition (is _Just . view _2) $ Map.toList avsUsers + usersFound = mapMaybe snd usersFound' + unless (null usersNotFound) $ + let msgContent = [whamlet| + $newline never +
                                  + $forall (usr,_) <- usersNotFound +
                                • #{usr} + |] + in addMessageModal Error (i18n . MsgCourseParticipantsRegisterNotFoundInAvs $ length usersNotFound) (Right msgContent) + when (null usersFound) $ do + addMessageI Warning MsgASReqEmpty + redirect routeAddSuperForm + runDB $ do + putMany [UserCompany uid cid True asReqReroute | uid <- usersFound] + whenIsJust asReqPostal $ \prefPostal -> + updateWhere [UserId <-. usersFound] [UserPrefersPostal =. prefPostal] + addMessageI Info $ MsgASReqSetSupers (fromIntegral $ length usersFound) asReqPostal + redirect $ FirmSupersR fsh siteLayout (citext2widget fsh) $ do - setTitle $ citext2Html $ fsh <> " Supers" - -- TODO: factor out company info section hamlet here and from user table - [whamlet| -
                                  -

                                  !!!STUB!!!TO DO!!! -
                                  -
                                  - $maybe fem <- companyEmail -
                                  - _{MsgFirmEmail} #{iconLetterOrEmail False} -
                                  - #{mailtoHtml fem} - $maybe addr <- companyPostAddress -
                                  - _{MsgFirmAddress} #{iconLetterOrEmail True} -
                                  - #{addr} -
                                  - ^{fsprTable} - |] - + setTitle $ citext2Html $ fsh <> " Supers" + $(i18nWidgetFile "firm-supervisors") + getFirmCommR, postFirmCommR :: CompanyShorthand -> Handler Html getFirmCommR = postFirmCommR diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 28b1b9d32..f992e76d8 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -1498,7 +1498,20 @@ boolField mkNone = radioGroupField mkNone $ do _other -> Nothing } - +-- | like `boolField` but with custom labels +boolFieldCustom :: (MonadHandler m, HandlerSite m ~ UniWorX) + => SomeMessage UniWorX -> SomeMessage UniWorX -> Maybe (SomeMessage UniWorX) -> Field m Bool +boolFieldCustom mkTrue mkFalse mkNone = radioGroupField mkNone $ do + mr <- getMessageRender + return OptionList + { olOptions = [ Option (mr mkFalse) False "false" + , Option (mr mkTrue) True "true" + ] + , olReadExternal = \case + "false" -> Just False + "true" -> Just True + _other -> Nothing + } sectionedFuncForm :: forall f k v m sec. ( TraversableWithIndex k f diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 2d00d373e..69ec53464 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -316,6 +316,7 @@ data FormIdentifier | FIDBtnAvsImportUnknown | FIDBtnAvsRevokeUnknown | FIDHijackUser + | FIDAddSupervisor deriving (Eq, Ord, Read, Show) instance PathPiece FormIdentifier where diff --git a/templates/i18n/firm-supervisors/de-de-formal.hamlet b/templates/i18n/firm-supervisors/de-de-formal.hamlet new file mode 100644 index 000000000..d81248e80 --- /dev/null +++ b/templates/i18n/firm-supervisors/de-de-formal.hamlet @@ -0,0 +1,27 @@ +$newline never + +$# SPDX-FileCopyrightText: 2023 Steffen Jost +$# +$# SPDX-License-Identifier: AGPL-3.0-or-later + +
                                  + Bitte beachten, dass Ansprechpartner-Beziehung unabhängig von Firmenzugehörigkeit zwischen Einzelpersonen bestehen. + Daraus folgt zum Beispiel, dass wenn x ein Standard-Ansprechpartner für Firma a ist + und wenn y sowohl Firma a als auch b angehört, + dass dann x als firmenfremd in der Liste der Ansprechpartner von Firma b angezeigt wird. +
                                  +
                                  + $maybe fem <- companyEmail +
                                  + _{MsgFirmEmail} #{iconLetterOrEmail False} +
                                  + #{mailtoHtml fem} + $maybe addr <- companyPostAddress +
                                  + _{MsgFirmAddress} #{iconLetterOrEmail True} +
                                  + #{addr} +
                                  + ^{fsprTable} +
                                  + ^{addSuperForm} \ No newline at end of file diff --git a/templates/i18n/firm-supervisors/en-eu.hamlet b/templates/i18n/firm-supervisors/en-eu.hamlet new file mode 100644 index 000000000..400fc543b --- /dev/null +++ b/templates/i18n/firm-supervisors/en-eu.hamlet @@ -0,0 +1,26 @@ +$newline never + +$# SPDX-FileCopyrightText: 2023 Steffen Jost +$# +$# SPDX-License-Identifier: AGPL-3.0-or-later + +
                                  + Note that supervision is company independent. + For example, if x is a regular supervisor for company a and y belongs to companies a and b, + then x will be listed as a foreign supervisor for company b. +
                                  +
                                  + $maybe fem <- companyEmail +
                                  + _{MsgFirmEmail} #{iconLetterOrEmail False} +
                                  + #{mailtoHtml fem} + $maybe addr <- companyPostAddress +
                                  + _{MsgFirmAddress} #{iconLetterOrEmail True} +
                                  + #{addr} +
                                  + ^{fsprTable} +
                                  + ^{addSuperForm} From 4fa7385154852cbf838e8ce841a74de5501df46c Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 17 Nov 2023 18:55:03 +0100 Subject: [PATCH 50/50] fix build --- src/Handler/Firm.hs | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index c55eee0fb..a37f59caa 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -735,15 +735,14 @@ postFirmUsersR fsh = do formResult fusrRes $ \case (_, uids) | null uids -> addMessageI Error MsgUtilEmptyChoice - (FirmUserActMkSuperData{..}, uids) -> do - nrMkSuper <- runDB $ updateWhereCount [UserCompanyUser <-. uids, UserCompanyCompany ==. cid] [UserCompanySupervisor =. True, UserCompanySupervisorReroute =. firmUserActMkSuperReroute] + (FirmUserActMkSuperData{..}, Set.toList -> uids) -> do + nrMkSuper <- runDB $ updateWhereCount [UserCompanyUser <-. uids, UserCompanyCompany ==. cid] [UserCompanySupervisor =. True, UserCompanySupervisorReroute =. (firmUserActMkSuperReroute == Just True)] addMessageI Info $ MsgASReqSetSupers nrMkSuper Nothing reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes (FirmUserActNotifyData , uids) -> do cuids <- traverse encrypt $ Set.toList uids :: Handler [CryptoUUIDUser] redirect (FirmCommR fsh, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids]) - (FirmUserActResetSupervisionData{..}, Set.toList -> uids') -> do - let uids = fromList uids' -- guaranteed to be non-empty due to first case clause + (FirmUserActResetSupervisionData{..}, set2NonEmpty (error "Unexpected empty user list in getFirmUserR action handler.") -> uids) -> do -- set guaranteed to be non-empty due to first case clause runDB $ do delSupers <- if firmUserActResetKeepOldSupers == Just False then deleteSupervisors uids @@ -946,11 +945,11 @@ postFirmSupersR fsh = do formResult fsprRes $ \case (_, uids) | null uids -> addMessageI Error MsgUtilEmptyChoice - (FirmSuperActRMSuperDefData, uids) -> do + (FirmSuperActRMSuperDefData, Set.toList -> uids) -> do nrRmSuper <- runDB $ updateWhereCount [UserCompanyUser <-. uids, UserCompanyCompany ==. cid] [UserCompanySupervisor =. False, UserCompanySupervisorReroute =. False] addMessageI Info $ MsgRemoveDefaultSupervisors nrRmSuper reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes - (FirmSuperActRMSuperAllData, uids) -> addMessage Info $ text2Html $ "Make " <> tshow (length uids) <> " default and active supervisors. TODO" + (FirmSuperActRMSuperAllData, uids) -> addMessage Warning $ text2Html $ "TODO Make " <> tshow (length uids) <> " default and active supervisors. TODO" (FirmSuperActNotifyData , uids) -> do cuids <- traverse encrypt $ Set.toList uids :: Handler [CryptoUUIDUser] redirect (FirmCommR fsh, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids])