From be527ada321b6f3c4fe08e44a4ca11a1bb39eea3 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 6 Oct 2023 15:07:34 +0000 Subject: [PATCH 001/159] 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 002/159] 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 003/159] 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 004/159] 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 005/159] 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 006/159] 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 007/159] 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 008/159] 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 009/159] 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 010/159] 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 011/159] 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 012/159] 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 013/159] 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 014/159] 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 015/159] 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 016/159] 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 017/159] 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 018/159] 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 019/159] 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 020/159] 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 021/159] 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 022/159] 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 023/159] 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 024/159] 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 025/159] 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 026/159] 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 027/159] 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 028/159] 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 d7a94b96197dbcf90463803a204e082b3b64424a Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 3 Nov 2023 14:41:31 +0100 Subject: [PATCH 029/159] chore(lms): include lms ids in qualification audit log events triggered by e-learning --- .../categories/qualification/de-de-formal.msg | 1 + .../categories/qualification/en-eu.msg | 1 + models/lms.model | 9 ++-- src/Audit/Types.hs | 1 + src/Handler/Qualification.hs | 9 ++-- src/Handler/Tutorial/Users.hs | 2 +- src/Handler/Utils/Qualification.hs | 18 ++++---- src/Jobs/Handler/LMS.hs | 20 ++++++--- src/Model/Types/Lms.hs | 42 ++++++++++++------- 9 files changed, 65 insertions(+), 38 deletions(-) diff --git a/messages/uniworx/categories/qualification/de-de-formal.msg b/messages/uniworx/categories/qualification/de-de-formal.msg index ce59e03ed..113121211 100644 --- a/messages/uniworx/categories/qualification/de-de-formal.msg +++ b/messages/uniworx/categories/qualification/de-de-formal.msg @@ -38,6 +38,7 @@ QualificationScheduleRenewalTooltip: Wird eine Benachrichtigung versendet, falls QualificationUserNoRenewal: Läuft ohne Benachrichtigung aus QualificationUserNone: Für diese Person sind keine Qualifikationen registriert. QualificationGrantReason: Erteilungsbegründung +QualificationRenewReason: Verlängerungsbegründung QualificationBlockReason: Entzugsbegründung QualificationBlockNotify: Benachrichtigung verschicken QualificationBlockRemoveSupervisor: Alle Ansprechpartner löschen diff --git a/messages/uniworx/categories/qualification/en-eu.msg b/messages/uniworx/categories/qualification/en-eu.msg index 6e949fc4f..1cab2c3dd 100644 --- a/messages/uniworx/categories/qualification/en-eu.msg +++ b/messages/uniworx/categories/qualification/en-eu.msg @@ -38,6 +38,7 @@ QualificationScheduleRenewalTooltip: Will there be a notification, if this quali QualificationUserNoRenewal: Expires without further notification QualificationUserNone: No registered qualifications for this person. QualificationGrantReason: Reason for granting +QualificationRenewReason: Reason for renewal QualificationBlockReason: Reason for revoking QualificationBlockNotify: Send notification QualificationBlockRemoveSupervisor: Remove all supervisors diff --git a/models/lms.model b/models/lms.model index 616940762..bf62961ad 100644 --- a/models/lms.model +++ b/models/lms.model @@ -144,7 +144,7 @@ LmsUser -- UniqueLmsUserStatus lmsUser -- enforcing uniqueness prohibits history -- deriving Generic --- LmsUserlist stores LMS upload for later processing only +-- DEPRECATED V1 LmsUserlist stores LMS upload for later processing only LmsUserlist qualification QualificationId OnDeleteCascade OnUpdateCascade ident LmsIdent @@ -153,7 +153,7 @@ LmsUserlist UniqueLmsUserlist qualification ident deriving Generic Show --- LmsResult stores LMS upload for later processing only +-- DEPRECATED V1 LmsResult stores LMS upload for later processing only LmsResult qualification QualificationId OnDeleteCascade OnUpdateCascade ident LmsIdent @@ -162,6 +162,7 @@ LmsResult UniqueLmsResult qualification ident -- required by DBTable deriving Generic +-- V2 Stores LMS upload for processing in Background Job LmsReport qualification QualificationId OnDeleteCascade OnUpdateCascade ident LmsIdent @@ -170,4 +171,6 @@ LmsReport lock Bool -- (0|1) timestamp UTCTime default=now() UniqueLmsReport qualification ident -- required by DBTable - deriving Generic \ No newline at end of file + deriving Generic + +-- LmsAudit removed by commit 71cde92a diff --git a/src/Audit/Types.hs b/src/Audit/Types.hs index 50dbc8811..ed3927a03 100644 --- a/src/Audit/Types.hs +++ b/src/Audit/Types.hs @@ -216,6 +216,7 @@ data Transaction , transactionQualification :: QualificationId , transactionQualificationValidUntil :: Day , transactionQualificationScheduleRenewal :: Maybe Bool -- Maybe, because some update may leave it unchanged (also avoids DB Migration) + , transactionNote :: Maybe Text } | TransactionQualificationUserDelete { transactionUser :: UserId diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs index 689a96e2b..cb04bc67b 100644 --- a/src/Handler/Qualification.hs +++ b/src/Handler/Qualification.hs @@ -296,7 +296,7 @@ data QualificationTableActionData | QualificationActBlockSupervisorData | QualificationActBlockData { qualTableActBlockReason :: Text, qualTableActNotify :: Bool, qualTableActRemoveSupervisors :: Bool } | QualificationActUnblockData { qualTableActBlockReason :: Text, qualTableActNotify :: Bool} - | QualificationActRenewData + | QualificationActRenewData { qualTableActChangeReason :: Text} | QualificationActGrantData { qualTableActGrantUntil :: Day } deriving (Eq, Ord, Show, Generic) @@ -574,7 +574,8 @@ postQualificationR sid qsh = do <$> 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 QualificationActRenew $ QualificationActRenewData + <$> apreq (textField & cfStrip & addDatalist suggestionsBlock) (fslI MsgQualificationRenewReason) Nothing , singletonMap QualificationActGrant $ QualificationActGrantData <$> apopt dayField (fslI MsgLmsQualificationValidUntil) dayExpiry <* aformMessage msgGrantWarning @@ -612,8 +613,8 @@ postQualificationR sid qsh = do return (tbl, qent) formResult lmsRes $ \case - (QualificationActRenewData, selectedUsers) | isAdmin -> do - noks <- runDB $ renewValidQualificationUsers qid Nothing $ Set.toList selectedUsers + (QualificationActRenewData renewReason, selectedUsers) | isAdmin -> do + noks <- runDB $ renewValidQualificationUsers qid (canonical $ Just $ Left renewReason) 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 diff --git a/src/Handler/Tutorial/Users.hs b/src/Handler/Tutorial/Users.hs index 5a02a6d35..46d15e16b 100644 --- a/src/Handler/Tutorial/Users.hs +++ b/src/Handler/Tutorial/Users.hs @@ -146,7 +146,7 @@ postTUsersR tid ssh csh tutn = do redirect $ CTutorialR tid ssh csh tutn TUsersR (TutorialUserRenewQualificationData{..}, selectedUsers) | tuQualification `Set.member` courseQids -> do - noks <- runDB $ renewValidQualificationUsers tuQualification Nothing $ Set.toList selectedUsers + noks <- runDB $ renewValidQualificationUsers tuQualification Nothing Nothing $ Set.toList selectedUsers addMessageI (if noks > 0 && noks == Set.size selectedUsers then Success else Warning) $ MsgTutorialUserRenewedQualification noks redirect $ CTutorialR tid ssh csh tutn TUsersR (TutorialUserSendMailData{}, selectedUsers) -> do diff --git a/src/Handler/Utils/Qualification.hs b/src/Handler/Utils/Qualification.hs index f104f0073..4f1e6fd97 100644 --- a/src/Handler/Utils/Qualification.hs +++ b/src/Handler/Utils/Qualification.hs @@ -24,10 +24,10 @@ statusQualificationBlock s = statusHtml (bool Error Success s) $ iconQualificati -- needs refactoring, probbably no longer helpful -mkQualificationBlocked :: QualificationBlockStandardReason -> UTCTime -> QualificationUserId -> QualificationUserBlock +mkQualificationBlocked :: QualificationStandardReason -> UTCTime -> QualificationUserId -> QualificationUserBlock mkQualificationBlocked reason qualificationUserBlockFrom qualificationUserBlockQualificationUser = QualificationUserBlock{..} where - qualificationUserBlockReason = qualificationBlockedReasonText reason + qualificationUserBlockReason = tshow reason qualificationUserBlockUnblock = False qualificationUserBlockBlocker = Nothing @@ -158,6 +158,7 @@ upsertQualificationUser qualificationUserQualification startTime qualificationU , transactionUser = qualificationUserUser , transactionQualificationValidUntil = qualificationUserValidUntil , transactionQualificationScheduleRenewal = mbScheduleRenewal + , transactionNote = canonical $ Just reason } -- | Renew an existing valid qualification, ignoring all blocks otherwise @@ -174,8 +175,8 @@ renewValidQualificationUsers :: , HasAppSettings (HandlerSite m) , MonadHandler m , MonadCatch m - ) => QualificationId -> Maybe UTCTime -> [UserId] -> ReaderT (YesodPersistBackend (HandlerSite m)) m Int -renewValidQualificationUsers qid renewalTime uids = + ) => QualificationId -> Maybe QualificationChangeReason -> Maybe UTCTime -> [UserId] -> ReaderT (YesodPersistBackend (HandlerSite m)) m Int +renewValidQualificationUsers qid reason renewalTime uids = -- The following short code snippet suffices in principle, but would not allow audit log entries. Are these still needed? -- E.update $ \qu -> do -- E.set qu [ QualificationUserValidUntil E.+=. E.interval (CalendarDiffDays 2 0) ] -- TODO: for Testing only @@ -199,6 +200,7 @@ renewValidQualificationUsers qid renewalTime uids = , transactionUser = qualificationUserUser , transactionQualificationValidUntil = newValidTo , transactionQualificationScheduleRenewal = Nothing + , transactionNote = qualificationChangeReasonText <$> reason } return $ length quEnts _ -> return (-1) -- qualificationId not found, isNothing qualificationValidDuration, etc. @@ -217,8 +219,8 @@ qualificationUserBlocking :: , MonadHandler m , MonadCatch m , Num n - ) => QualificationId -> [UserId] -> Bool -> Maybe UTCTime -> QualificationBlockReason -> Bool -> ReaderT (YesodPersistBackend (HandlerSite m)) m n -qualificationUserBlocking qid uids unblock mbBlockTime (qualificationBlockReasonText -> reason) notify = do + ) => QualificationId -> [UserId] -> Bool -> Maybe UTCTime -> QualificationChangeReason -> Bool -> ReaderT (YesodPersistBackend (HandlerSite m)) m n +qualificationUserBlocking qid uids unblock mbBlockTime (qualificationChangeReasonText -> reason) notify = do $logInfoS "BLOCK" $ Text.intercalate " - " [tshow qid, tshow uids, tshow unblock, tshow mbBlockTime, tshow reason, tshow notify] authUsr <- liftHandler maybeAuthId now <- liftIO getCurrentTime @@ -269,8 +271,8 @@ qualificationUserUnblockByReason :: , MonadHandler m , MonadCatch m , Num n - ) => QualificationId -> [UserId] -> Maybe UTCTime -> QualificationBlockReason -> QualificationBlockReason -> Bool -> ReaderT (YesodPersistBackend (HandlerSite m)) m n -qualificationUserUnblockByReason qid uids mbUnblockTime (qualificationBlockReasonText -> reason) undo_reason notify = do + ) => QualificationId -> [UserId] -> Maybe UTCTime -> QualificationChangeReason -> QualificationChangeReason -> Bool -> ReaderT (YesodPersistBackend (HandlerSite m)) m n +qualificationUserUnblockByReason qid uids mbUnblockTime (qualificationChangeReasonText -> reason) undo_reason notify = do cutoff <- maybe (liftIO getCurrentTime) return mbUnblockTime toUnblock <- E.select $ do quser <- E.from $ E.table @QualificationUser diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index 1b6cf4359..50e31babf 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -317,7 +317,7 @@ dispatchJobLmsReports qid = JobHandlerAtomic act let lrFltrBlock luser lreport = E.isNothing (luser E.^. LmsUserStatus) E.&&. lreport E.^. LmsReportResult E.==. E.val LmsFailed procBlock (Entity luid luser, Entity _ lreport) = do let repDay = lmsReportDate lreport <|> Just now - ok_block <- qualificationUserBlocking qid [lmsUserUser luser] False (lmsReportDate lreport) (Right QualificationBlockFailedELearning) True -- only valid qualifications are blocked; transcribes to audit log + ok_block <- qualificationUserBlocking qid [lmsUserUser luser] False (lmsReportDate lreport) (Right $ QualificationBlockFailedELearningBy $ lmsUserIdent luser) True -- only valid qualifications are blocked; transcribes to audit log update luid [LmsUserStatus =. Just LmsBlocked, LmsUserStatusDay =. repDay] return $ Sum ok_block in lrepQry lrFltrBlock @@ -327,12 +327,13 @@ dispatchJobLmsReports qid = JobHandlerAtomic act let lrFltrSuccess luser lreport = E.isNothing (luser E.^. LmsUserStatus) E.&&. lreport E.^. LmsReportResult E.==. E.val LmsPassed procRenew (Entity luid luser, Entity _ lreport) = do let repDay = lmsReportDate lreport <|> Just now + reason = Just $ Right $ QualificationRenewELearningBy $ lmsUserIdent luser -- LMS WORKAROUND 2: [supposedly fixed now] sometimes we receive success and failure simultaneously; success is correct, hence we must unblock if the reason was e-learning -- let reason_undo = Left $ "LMS Workaround undoing: " <> qualificationBlockedReasonText QualificationBlockFailedELearning -- ok_unblock <- qualificationUserUnblockByReason qid [lmsUserUser luser] repTime (Right QualificationBlockFailedELearning) reason_undo False -- affects audit log -- when (ok_unblock > 0) ($logWarnS "LMS" [st|LMS Result: workaround triggered, unblocking #{tshow ok_unblock} e-learners for #{tshow qid} having success reported after initially failed e-learning|]) - -- END LMS WORKAROUND 2 - ok_renew <- renewValidQualificationUsers qid repDay [lmsUserUser luser]-- only valid qualifications are truly renewed; transcribes to audit log + -- END LMS WORKAROUND 2 + ok_renew <- renewValidQualificationUsers qid reason repDay [lmsUserUser luser]-- only valid qualifications are truly renewed; transcribes to audit log update luid [LmsUserStatus =. Just LmsSuccess, LmsUserStatusDay =. repDay] return $ Sum ok_renew in lrepQry lrFltrSuccess @@ -379,6 +380,13 @@ dispatchJobLmsReports qid = JobHandlerAtomic act updateReceivedLocked True >>= \nr -> $logInfoS "LMS" $ "Report processing marked " <> tshow nr <> " rows as locked and received for qualification " <> tshow qid -- debug, remove later -- G) Truncate LmsReport for qid and log + + -- CONTINUE HERE + -- E.insertSelect $ do + -- lreport <- E.from $ E.table @LmsReport + -- E.where_ $ lreport E.^. LmsReportQualification E.==. E.val qid + -- E.&&. + repProc <- deleteWhereCount [LmsReportQualification ==. qid] $logInfoS "LMS" [st|Processed #{tshow repProc} e-learning status reports for qualification #{tshow qid}.|] @@ -416,11 +424,11 @@ dispatchJobLmsResults qid = JobHandlerAtomic act note <- if saneDate && (lmsUserStatus /= Just LmsSuccess) then do -- WORKAROUND LMS-Bug [supposedly fixed now, but isnt]: sometimes we receive success and failure simultaneously; success is correct, hence we must unblock if the reason was e-learning - let reason_undo = Left $ "LMS Workaround undoing: " <> qualificationBlockedReasonText QualificationBlockFailedELearning - ok_unblock <- qualificationUserUnblockByReason qid [qualificationUserUser] Nothing (Right QualificationBlockFailedELearning) reason_undo False -- affects audit log + let reason_undo = Left $ "LMS Workaround undoing: " <> tshow (QualificationBlockFailedELearningBy lmsUserIdent) + ok_unblock <- qualificationUserUnblockByReason qid [qualificationUserUser] Nothing (Right $ QualificationBlockFailedELearningBy lmsUserIdent) reason_undo False -- affects audit log when (ok_unblock > 0) ($logWarnS "LMS" [st|LMS Result: workaround triggered, unblocking #{tshow ok_unblock} e-learners for #{tshow qid}|]) - _ok_renew <- renewValidQualificationUsers qid Nothing [qualificationUserUser] -- only unblocked are renewed + _ok_renew <- renewValidQualificationUsers qid (Just $ Right $ QualificationRenewELearningBy lmsUserIdent) Nothing [qualificationUserUser] -- only unblocked are renewed -- when (ok==1) $ update luid -- we end lms regardless of whether or not a regular renewal was successful, since BPol users may simultaneoysly have on-premise renewal courses and E-Learnings update luid diff --git a/src/Model/Types/Lms.hs b/src/Model/Types/Lms.hs index b8eaf90e1..c0c2097db 100644 --- a/src/Model/Types/Lms.hs +++ b/src/Model/Types/Lms.hs @@ -12,8 +12,8 @@ module Model.Types.Lms ) where import Import.NoModel -import qualified Data.Map as Map -import Data.Map ((!)) +-- import qualified Data.Map as Map +-- import Data.Map ((!)) import Database.Persist.Sql import qualified Database.Esqueleto.Experimental as E import qualified Data.Csv as Csv @@ -56,27 +56,37 @@ instance Csv.ToField LmsStatus where -- | Default Block/Unblock reasons -data QualificationBlockStandardReason - = QualificationBlockFailedELearning +data QualificationStandardReason + = QualificationRenewELearningBy LmsIdent + | QualificationBlockFailedELearningBy LmsIdent + | QualificationBlockFailedELearning | QualificationBlockReturnedByCompany | QualificationBlockExpired - deriving (Eq, Ord, Enum, Bounded, Universe, Finite) + + -- deriving (Eq, Ord, Enum, Bounded, Universe, Finite) -instance Show QualificationBlockStandardReason where - show QualificationBlockFailedELearning = "E-Learning durchgefallen" - show QualificationBlockReturnedByCompany = "Rückgabe Firma" - show QualificationBlockExpired = "Abgelaufen" - -qualificationBlockedReasonText :: QualificationBlockStandardReason -> Text +instance Show QualificationStandardReason where + show (QualificationRenewELearningBy lid) = "E-Learning bestanden für " <> show lid + show (QualificationBlockFailedELearningBy lid) = "E-Learning durchgefallen für " <> show lid + show QualificationBlockFailedELearning = "E-Learning durchgefallen" + show QualificationBlockReturnedByCompany = "Rückgabe Firma" + show QualificationBlockExpired = "Abgelaufen" + +{- +qualificationBlockedReasonText :: QualificationStandardReason -> Text qualificationBlockedReasonText = - let dictionary :: Map.Map QualificationBlockStandardReason Text = Map.fromList [(r, tshow r) | r <- universeF] + let dictionary :: Map.Map QualificationStandardReason Text = Map.fromList [(r, tshow r) | r <- universeF] in (dictionary !) -- cannot fail due to universeF -type QualificationBlockReason = Either Text QualificationBlockStandardReason +qualificationBlockedReasonText :: QualificationStandardReason -> Text +qualificationBlockedReasonText = tshow +-} -qualificationBlockReasonText :: QualificationBlockReason -> Text -qualificationBlockReasonText (Left reason) = reason -qualificationBlockReasonText (Right stdreason) = qualificationBlockedReasonText stdreason +type QualificationChangeReason = Either Text QualificationStandardReason + +qualificationChangeReasonText :: QualificationChangeReason -> Text +qualificationChangeReasonText (Left reason) = reason +qualificationChangeReasonText (Right stdreason) = tshow stdreason -- | LMS interface requires Bool to be encoded by 0 or 1 only newtype LmsBool = LmsBool { lms2bool :: Bool } From 7373bc91471adaf71e162514307a0d7c76e663cd Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 3 Nov 2023 15:38:41 +0100 Subject: [PATCH 030/159] chore(lms): re-add dedicated lms audit log table removed in commit 71cde92, but freuquent lms errors make a dedicated log table for all unprocessed input necessary --- models/lms.model | 9 +++++++++ src/Jobs/Handler/LMS.hs | 28 ++++++++++++++++++++-------- 2 files changed, 29 insertions(+), 8 deletions(-) diff --git a/models/lms.model b/models/lms.model index bf62961ad..e72c7fc82 100644 --- a/models/lms.model +++ b/models/lms.model @@ -174,3 +174,12 @@ LmsReport deriving Generic -- LmsAudit removed by commit 71cde92a +-- due to frequent transmit errors, a separate lms tranmission log is necessary again +LmsReportLog + qualification QualificationId OnDeleteCascade OnUpdateCascade + ident LmsIdent + date UTCTime Maybe -- BEWARE: timezone is local as submitted by LMS + result LmsState -- (0|1|2) 0=LmsFailed[too many tries], 1=LmsOpen, 2=LmsPassed[success] + lock Bool -- (0|1) + timestamp UTCTime default=now() + deriving Generic \ No newline at end of file diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index 50e31babf..586b2404e 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -257,6 +257,7 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act deleteWhere [LmsUserlistQualification ==. qid, LmsUserlistIdent <-. delusers] deleteWhere [LmsResultQualification ==. qid, LmsResultIdent <-. delusers] -- deleteWhere [LmsAuditQualification ==. qid, LmsAuditIdent <-. delusers] + deleteWhere [LmsReportLogQualification ==. qid, LmsReportLogTimestamp <. auditCutoff ] dispatchJobLmsReports :: QualificationId -> JobHandler UniWorX @@ -379,14 +380,25 @@ dispatchJobLmsReports qid = JobHandlerAtomic act >>= \nr -> $logInfoS "LMS" $ "Report processing marked " <> tshow nr <> " rows as unlocked and received for qualification " <> tshow qid -- debug, remove later updateReceivedLocked True >>= \nr -> $logInfoS "LMS" $ "Report processing marked " <> tshow nr <> " rows as locked and received for qualification " <> tshow qid -- debug, remove later - -- G) Truncate LmsReport for qid and log - - -- CONTINUE HERE - -- E.insertSelect $ do - -- lreport <- E.from $ E.table @LmsReport - -- E.where_ $ lreport E.^. LmsReportQualification E.==. E.val qid - -- E.&&. - + -- G) Truncate LmsReport for qid, after updating log + E.insertSelect $ do + lreport <- E.from $ E.table @LmsReport + let samelog = E.subSelect $ do + lrl <- E.from $ E.table @LmsReportLog + E.where_ $ lrl E.^. LmsReportLogQualification E.==. E.val qid + E.&&. lrl E.^. LmsReportLogIdent E.==. lreport E.^. LmsReportIdent + E.orderBy [E.desc $ lrl E.^. LmsReportLogTimestamp] + return $ lreport E.^. LmsReportResult E.==. lrl E.^. LmsReportLogResult + E.&&. lreport E.^. LmsReportLock E.==. lrl E.^. LmsReportLogLock + E.where_ $ lreport E.^. LmsReportQualification E.==. E.val qid + E.&&. E.not_ (E.isTrue samelog) + return (LmsReportLog + E.<# (lreport E.^. LmsReportQualification) + E.<&> (lreport E.^. LmsReportIdent ) + E.<&> (lreport E.^. LmsReportDate ) + E.<&> (lreport E.^. LmsReportResult ) + E.<&> (lreport E.^. LmsReportLock ) + E.<&> (lreport E.^. LmsReportTimestamp )) repProc <- deleteWhereCount [LmsReportQualification ==. qid] $logInfoS "LMS" [st|Processed #{tshow repProc} e-learning status reports for qualification #{tshow qid}.|] From 5f7b2aac262d50d55857bb51816ee50d0757a6f3 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 3 Nov 2023 15:38:41 +0100 Subject: [PATCH 031/159] chore(sap): more test for compileBlocks --- models/lms.model | 9 +++++++++ src/Jobs/Handler/LMS.hs | 28 ++++++++++++++++++++-------- 2 files changed, 29 insertions(+), 8 deletions(-) diff --git a/models/lms.model b/models/lms.model index bf62961ad..e72c7fc82 100644 --- a/models/lms.model +++ b/models/lms.model @@ -174,3 +174,12 @@ LmsReport deriving Generic -- LmsAudit removed by commit 71cde92a +-- due to frequent transmit errors, a separate lms tranmission log is necessary again +LmsReportLog + qualification QualificationId OnDeleteCascade OnUpdateCascade + ident LmsIdent + date UTCTime Maybe -- BEWARE: timezone is local as submitted by LMS + result LmsState -- (0|1|2) 0=LmsFailed[too many tries], 1=LmsOpen, 2=LmsPassed[success] + lock Bool -- (0|1) + timestamp UTCTime default=now() + deriving Generic \ No newline at end of file diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index 50e31babf..586b2404e 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -257,6 +257,7 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act deleteWhere [LmsUserlistQualification ==. qid, LmsUserlistIdent <-. delusers] deleteWhere [LmsResultQualification ==. qid, LmsResultIdent <-. delusers] -- deleteWhere [LmsAuditQualification ==. qid, LmsAuditIdent <-. delusers] + deleteWhere [LmsReportLogQualification ==. qid, LmsReportLogTimestamp <. auditCutoff ] dispatchJobLmsReports :: QualificationId -> JobHandler UniWorX @@ -379,14 +380,25 @@ dispatchJobLmsReports qid = JobHandlerAtomic act >>= \nr -> $logInfoS "LMS" $ "Report processing marked " <> tshow nr <> " rows as unlocked and received for qualification " <> tshow qid -- debug, remove later updateReceivedLocked True >>= \nr -> $logInfoS "LMS" $ "Report processing marked " <> tshow nr <> " rows as locked and received for qualification " <> tshow qid -- debug, remove later - -- G) Truncate LmsReport for qid and log - - -- CONTINUE HERE - -- E.insertSelect $ do - -- lreport <- E.from $ E.table @LmsReport - -- E.where_ $ lreport E.^. LmsReportQualification E.==. E.val qid - -- E.&&. - + -- G) Truncate LmsReport for qid, after updating log + E.insertSelect $ do + lreport <- E.from $ E.table @LmsReport + let samelog = E.subSelect $ do + lrl <- E.from $ E.table @LmsReportLog + E.where_ $ lrl E.^. LmsReportLogQualification E.==. E.val qid + E.&&. lrl E.^. LmsReportLogIdent E.==. lreport E.^. LmsReportIdent + E.orderBy [E.desc $ lrl E.^. LmsReportLogTimestamp] + return $ lreport E.^. LmsReportResult E.==. lrl E.^. LmsReportLogResult + E.&&. lreport E.^. LmsReportLock E.==. lrl E.^. LmsReportLogLock + E.where_ $ lreport E.^. LmsReportQualification E.==. E.val qid + E.&&. E.not_ (E.isTrue samelog) + return (LmsReportLog + E.<# (lreport E.^. LmsReportQualification) + E.<&> (lreport E.^. LmsReportIdent ) + E.<&> (lreport E.^. LmsReportDate ) + E.<&> (lreport E.^. LmsReportResult ) + E.<&> (lreport E.^. LmsReportLock ) + E.<&> (lreport E.^. LmsReportTimestamp )) repProc <- deleteWhereCount [LmsReportQualification ==. qid] $logInfoS "LMS" [st|Processed #{tshow repProc} e-learning status reports for qualification #{tshow qid}.|] From 2aa14ee2e131308980e27659c2fcabfb69c8a247 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 3 Nov 2023 15:28:42 +0000 Subject: [PATCH 032/159] chore(release): 27.4.46 --- CHANGELOG.md | 8 ++++++++ nix/docker/version.json | 2 +- package-lock.json | 2 +- package.json | 2 +- package.yaml | 2 +- 5 files changed, 12 insertions(+), 4 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 5d9b7616d..d52c1fcc2 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,14 @@ All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines. +## [27.4.46](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.45...v27.4.46) (2023-11-03) + + +### Bug Fixes + +* **course:** grant qualifications now issues and unblocks ([5d8d8cf](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/5d8d8cf17e634ecb950a1c329c859fb93f94ef77)) +* **users:** allow prefer postal setting for users with fraport department ([a9d56c5](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/a9d56c51dcc727f8637b09a0e849372e75032f5e)) + ## [27.4.45](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.44...v27.4.45) (2023-10-18) diff --git a/nix/docker/version.json b/nix/docker/version.json index 77bb560f7..2e7f57f38 100644 --- a/nix/docker/version.json +++ b/nix/docker/version.json @@ -1,3 +1,3 @@ { - "version": "27.4.45" + "version": "27.4.46" } diff --git a/package-lock.json b/package-lock.json index 31b4132f1..2c3044679 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.4.45", + "version": "27.4.46", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index 014db6ed0..b9d237fac 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.4.45", + "version": "27.4.46", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index 42efdc6bb..5bc45e960 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 27.4.45 +version: 27.4.46 dependencies: - base - yesod From d2b20674f54a9bb2b5ce68032faaf14c1a12e052 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 3 Nov 2023 15:29:40 +0000 Subject: [PATCH 033/159] chore(release): 27.4.47 --- CHANGELOG.md | 2 ++ nix/docker/version.json | 2 +- package-lock.json | 2 +- package.json | 2 +- package.yaml | 2 +- 5 files changed, 6 insertions(+), 4 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index d52c1fcc2..231e3501f 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,8 @@ All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines. +## [27.4.47](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.46...v27.4.47) (2023-11-03) + ## [27.4.46](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.45...v27.4.46) (2023-11-03) diff --git a/nix/docker/version.json b/nix/docker/version.json index 2e7f57f38..ab8350d96 100644 --- a/nix/docker/version.json +++ b/nix/docker/version.json @@ -1,3 +1,3 @@ { - "version": "27.4.46" + "version": "27.4.47" } diff --git a/package-lock.json b/package-lock.json index 2c3044679..db2b94dbc 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.4.46", + "version": "27.4.47", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index b9d237fac..24ecd1bcc 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.4.46", + "version": "27.4.47", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index 5bc45e960..edd6f7dcc 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 27.4.46 +version: 27.4.47 dependencies: - base - yesod From 53f54189f9f5907e5115b7b3ab2009cef6fa6e5e Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 3 Nov 2023 17:55:56 +0100 Subject: [PATCH 034/159] 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 035/159] 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 036/159] 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 8165892b2e4f945780bb8420cfc4eed50fdd294d Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 7 Nov 2023 11:35:12 +0000 Subject: [PATCH 037/159] fix(lms): mark as ended only if not seen for at least one day --- src/Jobs/Handler/LMS.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index 586b2404e..5ff83df0d 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -347,6 +347,7 @@ dispatchJobLmsReports qid = JobHandlerAtomic act E.&&. E.isNothing (luser E.^. LmsUserEnded ) E.&&. E.isJust (luser E.^. LmsUserStatus ) -- status is decided E.&&. E.isJust (luser E.^. LmsUserReceived) -- seen before, for otherwise it might not have been started yet + E.&&. luser E.^. LmsUserReceived E.<= E.justVal (addUTCTime (-nominalDay) now) E.&&. E.notExists (do lreport <- E.from $ E.table @LmsReport E.where_ $ lreport E.^. LmsReportIdent E.==. luser E.^. LmsUserIdent From 5936435c54f15a45941836deb43d7574f62bbc96 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 7 Nov 2023 11:50:01 +0000 Subject: [PATCH 038/159] Revert "fix(lms): mark as ended only if not seen for at least one day" This reverts commit 8165892b2e4f945780bb8420cfc4eed50fdd294d --- src/Jobs/Handler/LMS.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index 5ff83df0d..586b2404e 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -347,7 +347,6 @@ dispatchJobLmsReports qid = JobHandlerAtomic act E.&&. E.isNothing (luser E.^. LmsUserEnded ) E.&&. E.isJust (luser E.^. LmsUserStatus ) -- status is decided E.&&. E.isJust (luser E.^. LmsUserReceived) -- seen before, for otherwise it might not have been started yet - E.&&. luser E.^. LmsUserReceived E.<= E.justVal (addUTCTime (-nominalDay) now) E.&&. E.notExists (do lreport <- E.from $ E.table @LmsReport E.where_ $ lreport E.^. LmsReportIdent E.==. luser E.^. LmsUserIdent From 2d37315d18e97e18ea1441dd595a4dc39c7e9d3f Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 7 Nov 2023 17:06:46 +0100 Subject: [PATCH 039/159] chore(lms): log newly unreported idents --- models/lms.model | 1 + src/Jobs/Handler/LMS.hs | 30 +++++++++++++++++++++++++++--- src/Model/Migration/Definitions.hs | 3 ++- 3 files changed, 30 insertions(+), 4 deletions(-) diff --git a/models/lms.model b/models/lms.model index e72c7fc82..4ba0f3927 100644 --- a/models/lms.model +++ b/models/lms.model @@ -182,4 +182,5 @@ LmsReportLog result LmsState -- (0|1|2) 0=LmsFailed[too many tries], 1=LmsOpen, 2=LmsPassed[success] lock Bool -- (0|1) timestamp UTCTime default=now() + missing Bool default=false deriving Generic \ No newline at end of file diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index 586b2404e..0f510f64c 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -389,16 +389,40 @@ dispatchJobLmsReports qid = JobHandlerAtomic act E.&&. lrl E.^. LmsReportLogIdent E.==. lreport E.^. LmsReportIdent E.orderBy [E.desc $ lrl E.^. LmsReportLogTimestamp] return $ lreport E.^. LmsReportResult E.==. lrl E.^. LmsReportLogResult - E.&&. lreport E.^. LmsReportLock E.==. lrl E.^. LmsReportLogLock + E.&&. lreport E.^. LmsReportLock E.==. lrl E.^. LmsReportLogLock + E.&&. E.not_ (lrl E.^. LmsReportLogMissing) E.where_ $ lreport E.^. LmsReportQualification E.==. E.val qid E.&&. E.not_ (E.isTrue samelog) return (LmsReportLog E.<# (lreport E.^. LmsReportQualification) E.<&> (lreport E.^. LmsReportIdent ) - E.<&> (lreport E.^. LmsReportDate ) + E.<&> E.nothing E.<&> (lreport E.^. LmsReportResult ) E.<&> (lreport E.^. LmsReportLock ) - E.<&> (lreport E.^. LmsReportTimestamp )) + E.<&> (lreport E.^. LmsReportTimestamp ) + E.<&> E.false) + E.insertSelect $ do + lrl <- E.from $ E.table @LmsReportLog + E.where_ $ E.not_ (lrl E.^. LmsReportLogMissing) + E.&&. E.notExists (do + lreport <- E.from $ E.table @LmsReport + E.where_ $ lreport E.^. LmsReportQualification E.==. E.val qid + E.&&. lreport E.^. LmsReportIdent E.==. lrl E.^. LmsReportLogIdent + ) + E.&&. E.notExists (do + lrl_old <- E.from $ E.table @LmsReportLog + E.where_ $ lrl_old E.^. LmsReportLogQualification E.==. E.val qid + E.&&. lrl_old E.^. LmsReportLogIdent E.==. lrl E.^. LmsReportLogIdent + E.&&. lrl_old E.^. LmsReportLogTimestamp E.>. lrl E.^. LmsReportLogTimestamp + ) + return (LmsReportLog + E.<# (lrl E.^. LmsReportLogQualification) + E.<&> (lrl E.^. LmsReportLogIdent ) + E.<&> (lrl E.^. LmsReportLogDate ) + E.<&> (lrl E.^. LmsReportLogResult ) + E.<&> (lrl E.^. LmsReportLogLock ) + E.<&> E.val now + E.<&> E.true) repProc <- deleteWhereCount [LmsReportQualification ==. qid] $logInfoS "LMS" [st|Processed #{tshow repProc} e-learning status reports for qualification #{tshow qid}.|] diff --git a/src/Model/Migration/Definitions.hs b/src/Model/Migration/Definitions.hs index 4224ab7b7..5f9940449 100644 --- a/src/Model/Migration/Definitions.hs +++ b/src/Model/Migration/Definitions.hs @@ -139,7 +139,8 @@ migrateManual = do , ("idx_qualification_user_block_unblock","CREATE INDEX idx_qualification_user_block_unblock ON \"qualification_user_block\" (\"unblock\")") , ("idx_qualification_user_block_from" ,"CREATE INDEX idx_qualification_user_block_from ON \"qualification_user_block\" (\"from\")") , ("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_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\")") ] where addIndex :: Text -> Sql -> Migration From 3865bda64d488c161b55e1f6eb48ca1b742dff98 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 7 Nov 2023 17:29:57 +0100 Subject: [PATCH 040/159] 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 041/159] 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 8500e72dee66ae3bbb88d7450a4307b284b58c85 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 7 Nov 2023 21:03:15 +0000 Subject: [PATCH 042/159] chore(release): 27.4.48 --- CHANGELOG.md | 7 +++++++ nix/docker/version.json | 2 +- package-lock.json | 2 +- package.json | 2 +- package.yaml | 2 +- 5 files changed, 11 insertions(+), 4 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 231e3501f..bc81a5744 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,13 @@ All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines. +## [27.4.48](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.47...v27.4.48) (2023-11-07) + + +### Bug Fixes + +* **lms:** mark as ended only if not seen for at least one day ([8165892](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/8165892b2e4f945780bb8420cfc4eed50fdd294d)) + ## [27.4.47](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.46...v27.4.47) (2023-11-03) ## [27.4.46](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.45...v27.4.46) (2023-11-03) diff --git a/nix/docker/version.json b/nix/docker/version.json index ab8350d96..128f6e4a8 100644 --- a/nix/docker/version.json +++ b/nix/docker/version.json @@ -1,3 +1,3 @@ { - "version": "27.4.47" + "version": "27.4.48" } diff --git a/package-lock.json b/package-lock.json index db2b94dbc..67f032ee5 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.4.47", + "version": "27.4.48", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index 24ecd1bcc..04e02d31c 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.4.47", + "version": "27.4.48", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index edd6f7dcc..de481c5b4 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 27.4.47 +version: 27.4.48 dependencies: - base - yesod From a98c3190e0837fbf42222476139f199d89fd776e Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 8 Nov 2023 13:00:31 +0100 Subject: [PATCH 043/159] 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 044/159] 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 390ff317ea3bb4ef8918c9cda858f5f228e4a882 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 8 Nov 2023 15:56:35 +0000 Subject: [PATCH 045/159] fix(lms): report log did not match qualification --- src/Jobs/Handler/LMS.hs | 41 +++++++++++++++++++++-------------------- 1 file changed, 21 insertions(+), 20 deletions(-) diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index 0f510f64c..06451d5a6 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -164,7 +164,7 @@ dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act maybeM (pure Nothing) (E.insertUniqueEntity . mkLmsUser lpw) (randomLMSIdentBut qprefix identsInUse) -- runMaybeT $ do -- lid <- MaybeT $ randomLMSIdentBu qprefix identsInUse - -- MaybeT $ E.insertUniqueEntity $ mkLmsUser lpw lid + -- MaybeT $ E.insertUniqueEntity $ mkLmsUser lpw lid inserted <- untilJustMaxM maxLmsUserIdentRetries startLmsUser case inserted of Nothing -> do @@ -187,7 +187,7 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act quali <- getJust qid -- may throw an error, aborting the job let qshort = CI.original $ qualificationShorthand quali $logInfoS "LMS" $ "Processing e-learning results for qualification " <> qshort - now <- liftIO getCurrentTime + now <- liftIO getCurrentTime -- end users that expired by doing nothing expiredUsers <- E.select $ do (quser :& luser) <- E.from $ @@ -201,7 +201,7 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act -- 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) + 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) @@ -214,7 +214,7 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act when (quali ^. _qualificationExpiryNotification) $ do -- notifies expired and previously lms-failed drivers notifyInvalidDrivers <- E.select $ do - (quser :& qblock) <- E.from $ + (quser :& qblock) <- E.from $ E.table @QualificationUser `E.leftJoin` E.table @QualificationUserBlock `E.on` (\(quser :& qblock) -> qblock E.?. QualificationUserBlockQualificationUser E.?=. quser E.^. QualificationUserId @@ -267,7 +267,7 @@ dispatchJobLmsReports qid = JobHandlerAtomic act act = whenM (exists [LmsReportQualification ==. qid]) $ do -- executing twice must be prohibited due to assertion that ALL learners are always sent (D fails otherwise) now <- liftIO getCurrentTime -- DEBUG 2rows; remove later - totalrows <- count [LmsReportQualification ==. qid] + totalrows <- count [LmsReportQualification ==. qid] $logInfoS "LMS" $ "Report processing " <> tshow totalrows <> " rows for qualification " <> tshow qid when (totalrows > 0) $ do let -- locDay = localDay $ TZ.utcToLocalTimeTZ appTZ now -- no longer necessary, since LMS reports dates only @@ -293,7 +293,7 @@ dispatchJobLmsReports qid = JobHandlerAtomic act E.&&. lreport E.^. LmsReportQualification E.==. E.val qid E.&&. E.isNothing (luser E.^. LmsUserEnded) -- ignore all closed learners E.&&. lrFltr luser lreport - return (luser, lreport) + return (luser, lreport) -- A) reset status for learners that had their tries just resetted as indicated by LmsOpen E.update $ \luser -> do E.set luser [ LmsUserStatus E.=. E.nothing @@ -316,13 +316,13 @@ dispatchJobLmsReports qid = JobHandlerAtomic act in luserQry luserFltrNew (const $ const E.true) >>= mapM_ notifyNewLearner -- C) block qualifications for failed learners by calling qualificationUserBlocking [uids] (includes audit), notified during expiry let lrFltrBlock luser lreport = E.isNothing (luser E.^. LmsUserStatus) E.&&. lreport E.^. LmsReportResult E.==. E.val LmsFailed - procBlock (Entity luid luser, Entity _ lreport) = do + procBlock (Entity luid luser, Entity _ lreport) = do let repDay = lmsReportDate lreport <|> Just now ok_block <- qualificationUserBlocking qid [lmsUserUser luser] False (lmsReportDate lreport) (Right $ QualificationBlockFailedELearningBy $ lmsUserIdent luser) True -- only valid qualifications are blocked; transcribes to audit log update luid [LmsUserStatus =. Just LmsBlocked, LmsUserStatusDay =. repDay] return $ Sum ok_block - in lrepQry lrFltrBlock - >>= foldMapM procBlock + in lrepQry lrFltrBlock + >>= foldMapM procBlock >>= \s -> $logInfoS "LMS" $ "Report processing: " <> tshow (getSum s) <> " status set to blocked for qualification " <> tshow qid -- debug, remove later -- D) renew qualifications for all successfull learners let lrFltrSuccess luser lreport = E.isNothing (luser E.^. LmsUserStatus) E.&&. lreport E.^. LmsReportResult E.==. E.val LmsPassed @@ -330,14 +330,14 @@ dispatchJobLmsReports qid = JobHandlerAtomic act let repDay = lmsReportDate lreport <|> Just now reason = Just $ Right $ QualificationRenewELearningBy $ lmsUserIdent luser -- LMS WORKAROUND 2: [supposedly fixed now] sometimes we receive success and failure simultaneously; success is correct, hence we must unblock if the reason was e-learning - -- let reason_undo = Left $ "LMS Workaround undoing: " <> qualificationBlockedReasonText QualificationBlockFailedELearning + -- let reason_undo = Left $ "LMS Workaround undoing: " <> qualificationBlockedReasonText QualificationBlockFailedELearning -- ok_unblock <- qualificationUserUnblockByReason qid [lmsUserUser luser] repTime (Right QualificationBlockFailedELearning) reason_undo False -- affects audit log -- when (ok_unblock > 0) ($logWarnS "LMS" [st|LMS Result: workaround triggered, unblocking #{tshow ok_unblock} e-learners for #{tshow qid} having success reported after initially failed e-learning|]) - -- END LMS WORKAROUND 2 + -- END LMS WORKAROUND 2 ok_renew <- renewValidQualificationUsers qid reason repDay [lmsUserUser luser]-- only valid qualifications are truly renewed; transcribes to audit log update luid [LmsUserStatus =. Just LmsSuccess, LmsUserStatusDay =. repDay] return $ Sum ok_renew - in lrepQry lrFltrSuccess + in lrepQry lrFltrSuccess >>= foldMapM procRenew >>= \s -> $logInfoS "LMS" $ "Report processing: " <> tshow (getSum s) <> " renewed and status set to success for qualification " <> tshow qid -- debug, remove later -- E) mark all previuosly reported, but now unreported users as ended (LMS deleted them as expected) @@ -380,8 +380,8 @@ dispatchJobLmsReports qid = JobHandlerAtomic act >>= \nr -> $logInfoS "LMS" $ "Report processing marked " <> tshow nr <> " rows as unlocked and received for qualification " <> tshow qid -- debug, remove later updateReceivedLocked True >>= \nr -> $logInfoS "LMS" $ "Report processing marked " <> tshow nr <> " rows as locked and received for qualification " <> tshow qid -- debug, remove later - -- G) Truncate LmsReport for qid, after updating log - E.insertSelect $ do + -- G) Truncate LmsReport for qid, after updating log + E.insertSelect $ do lreport <- E.from $ E.table @LmsReport let samelog = E.subSelect $ do lrl <- E.from $ E.table @LmsReportLog @@ -389,22 +389,23 @@ dispatchJobLmsReports qid = JobHandlerAtomic act E.&&. lrl E.^. LmsReportLogIdent E.==. lreport E.^. LmsReportIdent E.orderBy [E.desc $ lrl E.^. LmsReportLogTimestamp] return $ lreport E.^. LmsReportResult E.==. lrl E.^. LmsReportLogResult - E.&&. lreport E.^. LmsReportLock E.==. lrl E.^. LmsReportLogLock + E.&&. lreport E.^. LmsReportLock E.==. lrl E.^. LmsReportLogLock E.&&. E.not_ (lrl E.^. LmsReportLogMissing) E.where_ $ lreport E.^. LmsReportQualification E.==. E.val qid E.&&. E.not_ (E.isTrue samelog) return (LmsReportLog E.<# (lreport E.^. LmsReportQualification) E.<&> (lreport E.^. LmsReportIdent ) - E.<&> E.nothing + E.<&> (lreport E.^. LmsReportDate ) E.<&> (lreport E.^. LmsReportResult ) E.<&> (lreport E.^. LmsReportLock ) E.<&> (lreport E.^. LmsReportTimestamp ) E.<&> E.false) - E.insertSelect $ do + E.insertSelect $ do lrl <- E.from $ E.table @LmsReportLog E.where_ $ E.not_ (lrl E.^. LmsReportLogMissing) - E.&&. E.notExists (do + E.&&. lrl E.^. LmsReportLogQualification E.==. E.val qid + E.&&. E.notExists (do lreport <- E.from $ E.table @LmsReport E.where_ $ lreport E.^. LmsReportQualification E.==. E.val qid E.&&. lreport E.^. LmsReportIdent E.==. lrl E.^. LmsReportLogIdent @@ -418,7 +419,7 @@ dispatchJobLmsReports qid = JobHandlerAtomic act return (LmsReportLog E.<# (lrl E.^. LmsReportLogQualification) E.<&> (lrl E.^. LmsReportLogIdent ) - E.<&> (lrl E.^. LmsReportLogDate ) + E.<&> E.nothing E.<&> (lrl E.^. LmsReportLogResult ) E.<&> (lrl E.^. LmsReportLogLock ) E.<&> E.val now @@ -514,7 +515,7 @@ dispatchJobLmsUserlist qid = JobHandlerAtomic act | otherwise -> return () -- users likely not yet started (Entity luid luser, Just (Entity _lulid lulist)) -> do - let lReceived = lmsUserlistTimestamp lulist + let lReceived = lmsUserlistTimestamp lulist update luid [LmsUserReceived =. Just lReceived] -- LmsUserNotified is only updated upon sending notifications when (isNothing $ lmsUserNotified luser) $ do -- notify users that lms is available From 9ee80f8f7f8b7c65de8bb3540e5b6c4581978bff Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 8 Nov 2023 17:41:59 +0100 Subject: [PATCH 046/159] 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 a360101d4437784ae792817522dabc566aa643fe Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 9 Nov 2023 03:33:42 +0000 Subject: [PATCH 047/159] chore(release): 27.4.49 --- CHANGELOG.md | 7 +++++++ nix/docker/version.json | 2 +- package-lock.json | 2 +- package.json | 2 +- package.yaml | 2 +- 5 files changed, 11 insertions(+), 4 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index bc81a5744..7238033c9 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,13 @@ All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines. +## [27.4.49](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.48...v27.4.49) (2023-11-09) + + +### Bug Fixes + +* **lms:** report log did not match qualification ([390ff31](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/390ff317ea3bb4ef8918c9cda858f5f228e4a882)) + ## [27.4.48](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.47...v27.4.48) (2023-11-07) diff --git a/nix/docker/version.json b/nix/docker/version.json index 128f6e4a8..ae41d9f2a 100644 --- a/nix/docker/version.json +++ b/nix/docker/version.json @@ -1,3 +1,3 @@ { - "version": "27.4.48" + "version": "27.4.49" } diff --git a/package-lock.json b/package-lock.json index 67f032ee5..a24e9106c 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.4.48", + "version": "27.4.49", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index 04e02d31c..b11cc7651 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.4.48", + "version": "27.4.49", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index de481c5b4..04e5ca14e 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 27.4.48 +version: 27.4.49 dependencies: - base - yesod From 5d8802732a5dbebe99e5c2eef383039d96e8a6da Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 9 Nov 2023 18:07:39 +0100 Subject: [PATCH 048/159] 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 049/159] 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 050/159] 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 051/159] 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 052/159] 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 053/159] 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 054/159] 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 055/159] 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 056/159] 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 057/159] 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 6761767c6ca8cab62a22aa6f755e6231e07ab411 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 15 Nov 2023 12:42:04 +0100 Subject: [PATCH 058/159] fix(lms): LMS restart failing due to old LmsUser entry --- src/Jobs/Handler/LMS.hs | 35 +++++++++++++++++++++-------------- 1 file changed, 21 insertions(+), 14 deletions(-) diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index 06451d5a6..bb1e1c1ce 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -142,6 +142,7 @@ dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act pure lui now <- liftIO getCurrentTime let identsInUse = Set.fromList (E.unValue <$> identsInUseVs) + uniqLmsUse = UniqueLmsQualificationUser qid uid mkLmsUser lpin lid = LmsUser { lmsUserQualification = qid , lmsUserUser = uid @@ -157,26 +158,32 @@ dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act , lmsUserEnded = Nothing , lmsUserResetTries = False , lmsUserLocked = True -- initially display locked, since it is not yet available until the first feedback - } + } -- startLmsUser :: YesodJobDB UniWorX (Maybe (Entity LmsUser)) startLmsUser = do - lpw <- randomLMSpw + lpw <- randomLMSpw maybeM (pure Nothing) (E.insertUniqueEntity . mkLmsUser lpw) (randomLMSIdentBut qprefix identsInUse) -- runMaybeT $ do -- lid <- MaybeT $ randomLMSIdentBu qprefix identsInUse -- MaybeT $ E.insertUniqueEntity $ mkLmsUser lpw lid - inserted <- untilJustMaxM maxLmsUserIdentRetries startLmsUser - case inserted of - Nothing -> do - uuid :: CryptoUUIDUser <- encrypt uid - $logErrorS "LMS" $ "Generating and inserting fresh LmsIdent failed for uuid " <> tshow uuid <> " and qid " <> tshow qid <> "!" - (Just Entity{entityKey=lkey, entityVal=LmsUser{lmsUserIdent=lid, lmsUserUser=luid, lmsUserQualification=lqid}}) -> -- lmsUser started, but not yet notified - audit $ TransactionLmsStart - { transactionQualification = lqid - , transactionLmsIdent = lid - , transactionLmsUser = luid - , transactionLmsUserKey = lkey - } + getBy uniqLmsUse >>= \case + Just Entity{entityVal=LmsUser{..}} + | isNothing lmsUserEnded, isNothing lmsUserStatus || lmsUserStatus == Just LmsSuccess -> do + uuid :: CryptoUUIDUser <- encrypt uid + $logErrorS "LMS" $ "Generating fresh LmsIdent failed for uuid " <> tshow uuid <> " and qid " <> tshow qid <> " due to LMS still existing!" + other -> do + when (isJust other) $ deleteBy uniqLmsUse + untilJustMaxM maxLmsUserIdentRetries startLmsUser >>= \case + Nothing -> do + uuid :: CryptoUUIDUser <- encrypt uid + $logErrorS "LMS" $ "Generating and inserting fresh LmsIdent failed for uuid " <> tshow uuid <> " and qid " <> tshow qid <> " for unknown reason!" + (Just Entity{entityKey=lkey, entityVal=LmsUser{lmsUserIdent=lid, lmsUserUser=luid, lmsUserQualification=lqid}}) -> -- lmsUser started, but not yet notified + audit $ TransactionLmsStart + { transactionQualification = lqid + , transactionLmsIdent = lid + , transactionLmsUser = luid + , transactionLmsUserKey = lkey + } -- purge LmsIdent after QualificationAuditDuration expired From 8c4f848675e1125547d1fdfa05560affe4794118 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 15 Nov 2023 15:30:37 +0100 Subject: [PATCH 059/159] fix(avs): preserve unset pin passwords in update --- src/Handler/Utils/Avs.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index ce86e627d..42275f139 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -494,7 +494,7 @@ upsertAvsUserById api = do whenIsJust pinCard $ \pCard -> -- update pin, but only if it was unset or set to the value of an old card unlessM (exists [UserAvsCardCardNo ==. getFullCardNo pCard]) $ do let oldPins = Just . personCard2pin . userAvsCardCard . entityVal <$> oldCards - updateWhere [UserId ==. uid, UserPinPassword !=. userPin, UserPinPassword <-. Nothing:oldPins] + updateWhere [UserId ==. uid, UserPinPassword !=. userPin, UserPinPassword <-. oldPins] -- check for old pin ensures that unset/manually set passwords remain unchanged [UserPinPassword =. userPin] insert_ $ UserAvsCard api (getFullCardNo pCard) pCard now upsertUserCompany uid mbCompany userFirmAddr From 612d97538411788a24412f40cf54fb471197025e Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 15 Nov 2023 18:02:52 +0100 Subject: [PATCH 060/159] 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 061/159] 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 062/159] 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 063/159] 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]) From 8f8b6d84ae8676d725f4dafd99f74d4d9a5f8024 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 17 Nov 2023 18:26:26 +0000 Subject: [PATCH 064/159] chore(release): 27.4.50 --- CHANGELOG.md | 15 +++++++++++++++ nix/docker/version.json | 2 +- package-lock.json | 2 +- package.json | 2 +- package.yaml | 2 +- 5 files changed, 19 insertions(+), 4 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 7238033c9..08967c314 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,21 @@ All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines. +## [27.4.50](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.49...v27.4.50) (2023-11-17) + + +### Bug Fixes + +* **avs:** preserve unset pin passwords in update ([8c4f848](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/8c4f848675e1125547d1fdfa05560affe4794118)) +* **build:** fix whitespace in routes ([a24e44e](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/a24e44efc9a20d3934d96640bb9e21b3b6d55b96)) +* **build:** minor ([954a239](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/954a23936a35ea6c32247d7e191312e63888c12d)) +* **firm:** add sql indices for frequent filters to greatly enhance performance ([63e6d94](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/63e6d94df2fd1ce879cb59d14bc854f3c2556586)) +* **firm:** firm messaging now works fine ([65cdc8d](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/65cdc8ddfef19eb3a5578c536575f91ba9717a13)) +* **firm:** foreign supervisor counts correct and sortable ([601ce7a](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/601ce7abdf2a392d30f1ff799a2338968be795f1)) +* **firm:** sending messages works, but not test messages ([42ff02d](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/42ff02d27e431a8855db7bf3046a1b74d297e6da)) +* **lms:** improve sorting for firm all ([3865bda](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/3865bda64d488c161b55e1f6eb48ca1b742dff98)) +* **lms:** LMS restart failing due to old LmsUser entry ([6761767](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/6761767c6ca8cab62a22aa6f755e6231e07ab411)) + ## [27.4.49](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.48...v27.4.49) (2023-11-09) diff --git a/nix/docker/version.json b/nix/docker/version.json index ae41d9f2a..2140ac34f 100644 --- a/nix/docker/version.json +++ b/nix/docker/version.json @@ -1,3 +1,3 @@ { - "version": "27.4.49" + "version": "27.4.50" } diff --git a/package-lock.json b/package-lock.json index a24e9106c..0f9458042 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.4.49", + "version": "27.4.50", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index b11cc7651..06948aab1 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.4.49", + "version": "27.4.50", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index 51bf68fd4..4cacc5a3b 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 27.4.49 +version: 27.4.50 dependencies: - base - yesod From 0f9a7a8c53d216ca7a6d0a25462b19ab1fa00bb4 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 20 Nov 2023 15:02:44 +0100 Subject: [PATCH 065/159] fix(firm): show default supervisors with no employees too --- src/Handler/Firm.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index a37f59caa..479b2009f 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -845,7 +845,8 @@ mkFirmSuperTable isAdmin cid = do where 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 + E.where_ $ E.isTrue (usrCmp E.?. UserCompanySupervisor) + E.||. E.exists (firmQuerySupervisedBy cid Nothing usr) return ( usr , usr & firmCountForSupervisor cid Nothing , usr & firmCountForSupervisor cid (Just (E.^. UserSupervisorRerouteNotifications)) From b7d6474acefbafb700241ec4cf60166965c1ac1c Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 21 Nov 2023 13:33:12 +0100 Subject: [PATCH 066/159] refactor(firm): messaging performance --- src/Handler/Firm.hs | 89 +++++++++++++++++++-------------------------- src/Utils.hs | 3 ++ 2 files changed, 40 insertions(+), 52 deletions(-) diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 479b2009f..1c2a8943a 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -1006,56 +1006,42 @@ postFirmsCommR = handleFirmCommR (SomeRoute FirmAllR) 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.in_` E.valList csKey - return $ emp E.^. UserId - ) - -- 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 - usrCmpy <- E.from $ E.table @UserCompany - E.where_ $ usrCmpy E.^. UserCompanyCompany E.==. cmpy E.^. CompanyId - E.&&. usrCmpy E.^. UserCompanyUser `E.in_` E.valList sprs - return $ cmpy E.^.CompanyId - ) 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 - ) + queryGiven :: [UserId] -> E.SqlQuery (E.SqlExpr (Entity User)) -- get users from a list of UserIds + queryGiven usrs = do + usr <- E.from $ E.table @User + E.where_ $ usr E.^. UserId `E.in_` E.valList usrs return usr - + mkCompanyUsrList :: [(E.Value (Maybe CompanyId), E.Value UserId)] -> Map.Map (Maybe CompanyId) [UserId] + mkCompanyUsrList l = Map.fromAscListWith (++) [(c,[u]) | (E.Value c, E.Value u) <- l] + toGrp = maybe RGFirmIndependent (RGFirmSupervisor . unCompanyKey) + csKeys = CompanyKey <$> cs + mbUser <- maybeAuthId + -- get employees of chosen companies + empys <- mkCompanyUsrList <$> runDB (E.select $ do + (emp :& cmp) <- E.from $ E.table @User `E.innerJoin` E.table @UserCompany `E.on` (\(emp :& cmp) -> emp E.^. UserId E.==. cmp E.^. UserCompanyUser) + E.where_ $ cmp E.^. UserCompanyCompany `E.in_` E.valList csKeys + E.orderBy [E.ascNullsFirst $ cmp E.^. UserCompanyCompany] + return (E.just $ cmp E.^. UserCompanyCompany, emp E.^. UserId) + ) + -- get supervisors of employees + --sprs <- mkCompanyUsrList <$> runDB (E.select $ do + sprs' <- runDB (E.select $ do + (spr :& cmp) <- E.from $ E.table @User `E.leftJoin` E.table @UserCompany `E.on` (\(spr :& cmp) -> spr E.^. UserId E.=?. cmp E.?. UserCompanyUser) + E.where_ $ (E.isTrue (cmp E.?. UserCompanySupervisor) E.&&. cmp E.?. UserCompanyCompany `E.in_` E.justValList csKeys) + E.||. (spr E.^. UserId E.=?. E.val mbUser) + E.||. 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 (concat $ Map.elems empys) + ) + E.orderBy [E.ascNullsFirst $ cmp E.?. UserCompanyCompany] + return (cmp E.?. UserCompanyCompany, spr E.^. UserId) + ) + $logInfoS "Firm" "!!!Messaging here!!!" + unless (checkAsc (fst <$> sprs')) ($logErrorS "Firm" ("Supervisor list isn't ascending!!!" <> tshow (fst <$> sprs'))) -- TODO: REMOVE THIS CHECK AND THE FOLLOWING LINE FOR PRODUCTION !!! + let sprs = mkCompanyUsrList sprs' + commR CommunicationRoute { crHeading = SomeMessage $ case cs of { [c] -> MsgFirmNotification c ; _ -> MsgFirmsNotification } , crTitle = SomeMessage $ case cs of { [c] -> MsgFirmNotificationTitle c ; _ -> MsgFirmsNotificationTitle } @@ -1063,10 +1049,9 @@ handleFirmCommR ultDest cs = do , 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 <- sprCmpys ] ++ - (RGFirmIndependent, queryLoners) : - [(RGFirmEmployees $ unCompanyKey acid, queryCmpy False acid) | acid <- csKey ] + , crRecipients = -- :: [(RecipientGroup, SqlQuery (SqlExpr (Entity User)))] + [(toGrp acid, queryGiven usrs) | (acid, usrs) <- Map.toAscList sprs ] ++ + [(RGFirmEmployees $ unCompanyKey acid, queryGiven usrs) | (Just acid, usrs) <- Map.toAscList empys ] } {- Auswahlbox für Mitteilung: diff --git a/src/Utils.hs b/src/Utils.hs index 44b863ae9..6ec20b881 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -771,6 +771,9 @@ pattern NonEmpty :: forall a. a -> [a] -> NonEmpty a pattern NonEmpty x xs = x :| xs {-# COMPLETE NonEmpty #-} +checkAsc :: Ord a => [a] -> Bool +checkAsc (x:r@(y:_)) = x<=y && checkAsc r +checkAsc _ = True ---------- -- Sets -- From b9f2d3bda4fe80017c40438583e6e139a022fd0a Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 21 Nov 2023 16:53:06 +0100 Subject: [PATCH 067/159] chore(firm): add setting for global communications cc --- src/Handler/Firm.hs | 8 ++------ src/Handler/Utils/Communication.hs | 14 +++++++++----- src/Settings.hs | 2 ++ 3 files changed, 13 insertions(+), 11 deletions(-) diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 1c2a8943a..f8cf257dc 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -1025,8 +1025,7 @@ handleFirmCommR ultDest cs = do return (E.just $ cmp E.^. UserCompanyCompany, emp E.^. UserId) ) -- get supervisors of employees - --sprs <- mkCompanyUsrList <$> runDB (E.select $ do - sprs' <- runDB (E.select $ do + sprs <- mkCompanyUsrList <$> runDB (E.select $ do (spr :& cmp) <- E.from $ E.table @User `E.leftJoin` E.table @UserCompany `E.on` (\(spr :& cmp) -> spr E.^. UserId E.=?. cmp E.?. UserCompanyUser) E.where_ $ (E.isTrue (cmp E.?. UserCompanySupervisor) E.&&. cmp E.?. UserCompanyCompany `E.in_` E.justValList csKeys) E.||. (spr E.^. UserId E.=?. E.val mbUser) @@ -1037,10 +1036,7 @@ handleFirmCommR ultDest cs = do ) E.orderBy [E.ascNullsFirst $ cmp E.?. UserCompanyCompany] return (cmp E.?. UserCompanyCompany, spr E.^. UserId) - ) - $logInfoS "Firm" "!!!Messaging here!!!" - unless (checkAsc (fst <$> sprs')) ($logErrorS "Firm" ("Supervisor list isn't ascending!!!" <> tshow (fst <$> sprs'))) -- TODO: REMOVE THIS CHECK AND THE FOLLOWING LINE FOR PRODUCTION !!! - let sprs = mkCompanyUsrList sprs' + ) commR CommunicationRoute { crHeading = SomeMessage $ case cs of { [c] -> MsgFirmNotification c ; _ -> MsgFirmsNotification } diff --git a/src/Handler/Utils/Communication.hs b/src/Handler/Utils/Communication.hs index d94f79706..70c8e45e2 100644 --- a/src/Handler/Utils/Communication.hs +++ b/src/Handler/Utils/Communication.hs @@ -139,7 +139,7 @@ commR CommunicationRoute{..} = do decrypt' cID = do uid <- decrypt cID whenIsJust crRecipientAuth $ guardAuthResult <=< ($ uid) - getEntity uid + getEntity uid cUser <- maybeAuth (chosenRecipients, suggestedRecipients) <- runDB $ (,) <$> (maybe id cons cUser . catMaybes <$> (mapM decrypt' =<< lookupGlobalGetParams GetRecipient)) @@ -148,7 +148,8 @@ commR CommunicationRoute{..} = do MsgRenderer mr <- getMsgRenderer mbCurrentRoute <- getCurrentRoute - + globalCC <- getsYesod $ view _appCommunicationGlobalCC + let lookupUser :: UserId -> (UserDisplayName,UserSurname) lookupUser = @@ -156,7 +157,7 @@ commR CommunicationRoute{..} = do 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 - + chosenRecipients' = Map.fromList $ [ ( (BoundedPosition $ RecipientGroup g, pos) , (Right recp, recp `elem` map entityKey chosenRecipients) @@ -165,9 +166,12 @@ commR CommunicationRoute{..} = do , (pos, recp) <- zip [0..] $ map entityKey recps ] ++ [ ( (BoundedPosition RecipientCustom, pos) - , (Right recp, True) + , (recp, True) ) - | (pos, recp) <- zip [0..] . Set.toList $ Set.fromList (map entityKey chosenRecipients) \\ Set.fromList (concatMap (map entityKey) $ view _2 <$> suggestedRecipients) + | (pos, recp) <- zip [0..] + ( mcons (Left <$> globalCC) + (Right <$> Set.toList (Set.fromList (map entityKey chosenRecipients) \\ Set.fromList (concatMap (map entityKey) $ view _2 <$> suggestedRecipients))) + ) ] activeCategories = map RecipientGroup (view _1 <$> suggestedRecipients) `snoc` RecipientCustom diff --git a/src/Settings.hs b/src/Settings.hs index 5b6c139cb..0916f439f 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -245,6 +245,7 @@ data AppSettings = AppSettings , appJobMaxFlush :: Maybe Natural , appCommunicationAttachmentsMaxSize :: Maybe Natural + , appCommunicationGlobalCC :: Maybe UserEmail , appFileChunkingParams :: FastCDCParameters @@ -804,6 +805,7 @@ instance FromJSON AppSettings where appJobMaxFlush <- o .:? "job-max-flush" appCommunicationAttachmentsMaxSize <- o .:? "communication-attachments-max-size" + appCommunicationGlobalCC <- o .:? "communication-global-cc" appLegalExternal <- o .: "legal-external" From 83bab6b86bd4743114c733ac952dee9539e97938 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 21 Nov 2023 18:45:51 +0100 Subject: [PATCH 068/159] chore(firm): implement fix #67 Maske Firmen --- .../uniworx/categories/firm/de-de-formal.msg | 9 +- messages/uniworx/categories/firm/en-eu.msg | 9 +- .../utils/table_column/de-de-formal.msg | 3 +- messages/uniworx/utils/table_column/en-eu.msg | 3 +- src/Handler/Firm.hs | 86 +++++++++++++++---- src/Handler/Utils/Table/Cells.hs | 10 +++ src/Utils/Form.hs | 1 + src/Utils/Icon.hs | 4 +- templates/firm-users.hamlet | 5 +- 9 files changed, 103 insertions(+), 27 deletions(-) diff --git a/messages/uniworx/categories/firm/de-de-formal.msg b/messages/uniworx/categories/firm/de-de-formal.msg index 49fc0d066..8c9cf7a8e 100644 --- a/messages/uniworx/categories/firm/de-de-formal.msg +++ b/messages/uniworx/categories/firm/de-de-formal.msg @@ -16,7 +16,7 @@ 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 +FirmSuperActRMSuperActive: Auch aktive Ansprechpartnerbeziehungen innerhalb dieser Firma beenden FirmsNotification: Firmen Benachrichtigung versenden FirmNotification fsh@CompanyShorthand: Benachrichtigung an #{fsh} versenden FirmsNotificationTitle: Firmen benachrichtigen @@ -32,8 +32,9 @@ FirmEmployeeOf fsh@CompanyShorthand: Firmenangehörige #{fsh} NoCompanySelected: Bitte wählen Sie mindestens eine Firm aus. TableIsDefaultSupervisor: Standardansprechpartner TableIsDefaultReroute: Standardumleitung -ASReqPostal: Benachrichtigungseinstellung -ASReqPostalTip: Gilt für alle Benachrichtigungen an diese Person, nicht nur für Umleitungen an diesen Ansprechpartner +FormReqPostal: Benachrichtigungseinstellung +FormReqPostalTip: 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 +RemoveSupervisors ndef@Int64 nact@Int64: #{ndef} Standard Ansprechpartner entfernt#{bool ", aber noch nicht deaktiviert" (", " <> tshow nact <> " aktive Ansprechpartnerbeziehungen gelöscht") (nact > 0)} +FirmUserChanges n@Int64: Benachrichtigungseinstellung für #{n} Firmenangehörige wurden geändert \ 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 39e46d552..0d7ef77eb 100644 --- a/messages/uniworx/categories/firm/en-eu.msg +++ b/messages/uniworx/categories/firm/en-eu.msg @@ -16,7 +16,7 @@ FirmResetSupervision rem set: #{tshow set} supervisors set#{bool mempty (", " <> FirmUserActMkSuper: Mark as company supervisor FirmSuperActNotify: Send message FirmSuperActRMSuperDef: Remove as default supervisor -FirmSuperActRMSuperAll: Remove all active supervisions for this company +FirmSuperActRMSuperActive: Also remove active supervisions within this company FirmsNotification: Send company notification FirmNotification fsh: Send notification to company #{fsh} FirmsNotificationTitle: Company notification @@ -32,8 +32,9 @@ FirmEmployeeOf fsh@CompanyShorthand: #{fsh} associated users NoCompanySelected: Select at least one company, please. TableIsDefaultSupervisor: Default supervisor TableIsDefaultReroute: Default reroute -ASReqPostal: Notification type -ASReqPostalTip: Affects all notifications to this person, not just reroutes to this supervisor +FormReqPostal: Notification type +FormReqPostalTip: 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 +RemoveSupervisors ndef nact: #{ndef} default supervisors removed#{bool ", but not yet deactivated" (" and " <> tshow nact <> " active supervisons terminated") (nact > 0)} +FirmUserChanges n: Notification settings changed for #{n} company associates \ No newline at end of file diff --git a/messages/uniworx/utils/table_column/de-de-formal.msg b/messages/uniworx/utils/table_column/de-de-formal.msg index 295648b7e..71e251d18 100644 --- a/messages/uniworx/utils/table_column/de-de-formal.msg +++ b/messages/uniworx/utils/table_column/de-de-formal.msg @@ -104,4 +104,5 @@ 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 +TableFilterCommaNameNr: Mehrere Namen oder Nummern mit Komma trennen. Nummern werden nur exakt gesucht. +TableUserEdit: Benutzer bearbeiten \ 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 3b7962522..b000a6d7d 100644 --- a/messages/uniworx/utils/table_column/en-eu.msg +++ b/messages/uniworx/utils/table_column/en-eu.msg @@ -104,4 +104,5 @@ 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 +TableFilterCommaNameNr: Separate names and numbers by comma. Numbers have to match exact. +TableUserEdit: Edit user \ No newline at end of file diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index f8cf257dc..f102c1734 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -50,7 +50,10 @@ encryptUser = encrypt --------------------------- -- Firm specific utilities --- for filters and counts see before FirmAllR Handlers +-- for filters and counts also see before FirmAllR Handlers + +postalEmailField :: (MonadHandler m, HandlerSite m ~ UniWorX) => Field m Bool +postalEmailField = boolFieldCustom (SomeMessage MsgUtilPostal) (SomeMessage MsgUtilEMail) $ Just $ SomeMessage MsgUtilUnchanged -- remove supervisors: deleteSupervisors :: NonEmpty UserId -> DB Int64 @@ -501,6 +504,25 @@ postFirmAllR = do ----------------------- -- Firm Users Table +data FirmUserChangeRequest = FirmUserChangeRequest + { fucrPostalPref :: Maybe Bool + , fucrPostalAddr :: Maybe StoredMarkup + } + deriving (Eq, Ord, Show, Generic) + +instance Default FirmUserChangeRequest where + def = FirmUserChangeRequest + { fucrPostalPref = Nothing + , fucrPostalAddr = Nothing + } + +makeFirmUserChangeRequestForm :: Maybe FirmUserChangeRequest -> Form FirmUserChangeRequest +makeFirmUserChangeRequestForm template html = do + flip (renderAForm FormStandard) html $ FirmUserChangeRequest + <$> aopt postalEmailField (fslI MsgFormReqPostal & setTooltip MsgFormReqPostalTip) (fucrPostalPref <$> template) + <*> aopt htmlField (fslI MsgPostAddress & setTooltip MsgPostAddressTip) (fucrPostalAddr <$> template) + + data FirmUserAction = FirmUserActNotify | FirmUserActResetSupervision | FirmUserActMkSuper @@ -518,7 +540,7 @@ data FirmUserActionData = FirmUserActNotifyData | FirmUserActMkSuperData { firmUserActMkSuperReroute :: Maybe Bool } - deriving (Eq, Ord, Read, Show, Generic) + deriving (Eq, Ord, Show, Generic) type UserCompanyTableExpr = E.SqlExpr (Entity User) `E.InnerJoin` E.SqlExpr (Entity UserCompany) @@ -584,6 +606,7 @@ mkFirmUserTable isAdmin cid = do , 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 + , sortable Nothing (i18nCell MsgTableUserEdit) $ \(view resultUserUser -> entUsr) -> cellEditUserModal entUsr ] dbtSorting = mconcat [ single $ sortUserNameLink queryUserUser @@ -750,6 +773,29 @@ postFirmUsersR fsh = do newSupers <- addDefaultSupervisors cid uids addMessageI Info $ MsgFirmResetSupervision delSupers newSupers reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes + + ((fucrRes, fucrWgt), fucrEnctype) <- runFormPost . identifyForm FIDFirmUserChangeRequest $ makeFirmUserChangeRequestForm (Just def) + let addFormAnchor = "firm-user-change-form" :: Text + routeForm = FirmUsersR fsh :#: addFormAnchor + fucrForm = wrapForm fucrWgt FormSettings + { formMethod = POST + , formAction = Just . SomeRoute $ routeForm + , formEncoding = fucrEnctype + , formAttrs = [] + , formSubmit = FormSubmit + , formAnchor = Just addFormAnchor + } + formResult fucrRes $ \FirmUserChangeRequest{..} -> when (isJust fucrPostalAddr || isJust fucrPostalAddr) $ do + let changes = foldMap (\pp -> [UserPrefersPostal E.=. E.val pp]) fucrPostalPref <> + foldMap (\pa -> [UserPostAddress E.=. E.justVal pa]) fucrPostalAddr -- seems weird, but: Nothing means no change, and not delete address! + nrChanged <- runDB $ E.updateCount $ \usr -> do + E.set usr changes + E.where_ $ E.exists $ do + usrCmpy <- E.from $ E.table @UserCompany + E.where_ $ usrCmpy E.^. UserCompanyCompany E.==. E.val cid + E.&&. usrCmpy E.^. UserCompanyUser E.==. usr E.^. UserId + addMessageI Info $ MsgFirmUserChanges nrChanged + reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes siteLayout (citext2widget companyName) $ do setTitle $ toHtml $ CI.original companyShorthand <> "-" <> tshow companyAvsId @@ -761,7 +807,7 @@ postFirmUsersR fsh = do data FirmSuperAction = FirmSuperActNotify | FirmSuperActRMSuperDef - | FirmSuperActRMSuperAll + deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) deriving anyclass (Universe, Finite) @@ -770,8 +816,9 @@ embedRenderMessage ''UniWorX ''FirmSuperAction id data FirmSuperActionData = FirmSuperActNotifyData | FirmSuperActRMSuperDefData - | FirmSuperActRMSuperAllData - deriving (Eq, Ord, Read, Show, Generic) + { firmSuperActRMSuperActive :: Maybe Bool } + + deriving (Eq, Ord, Show, Generic) data AddSupervisorRequest = AddSupervisorRequest @@ -787,16 +834,13 @@ instance Default AddSupervisorRequest where , 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) + <*> aopt postalEmailField (fslI MsgFormReqPostal & setTooltip MsgFormReqPostalTip) (asReqPostal <$> template) type SuperCompanyTableExpr = E.SqlExpr (Entity User) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity UserCompany)) @@ -874,6 +918,7 @@ mkFirmSuperTable isAdmin cid = do , 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) + , sortable Nothing (i18nCell MsgTableUserEdit) $ \(view resultSuperUser -> entUsr) -> cellEditUserModal entUsr ] dbtSorting = mconcat [ single $ sortUserNameLink querySuperUser @@ -902,8 +947,8 @@ mkFirmSuperTable isAdmin cid = do acts :: Map FirmSuperAction (AForm Handler FirmSuperActionData) acts = mconcat [ singletonMap FirmSuperActNotify $ pure FirmSuperActNotifyData - , singletonMap FirmSuperActRMSuperDef $ pure FirmSuperActRMSuperDefData - , singletonMap FirmSuperActRMSuperAll $ pure FirmSuperActRMSuperAllData + , singletonMap FirmSuperActRMSuperDef $ FirmSuperActRMSuperDefData + <$> aopt checkBoxField (fslI MsgFirmSuperActRMSuperActive) (Just $ Just True) ] dbtParams = DBParamsForm { dbParamsFormMethod = POST @@ -946,11 +991,22 @@ postFirmSupersR fsh = do formResult fsprRes $ \case (_, uids) | null uids -> addMessageI Error MsgUtilEmptyChoice - (FirmSuperActRMSuperDefData, Set.toList -> uids) -> do - nrRmSuper <- runDB $ updateWhereCount [UserCompanyUser <-. uids, UserCompanyCompany ==. cid] [UserCompanySupervisor =. False, UserCompanySupervisorReroute =. False] - addMessageI Info $ MsgRemoveDefaultSupervisors nrRmSuper + (FirmSuperActRMSuperDefData{..}, Set.toList -> uids) -> do + (nrRmSuper,nrRmActual) <- runDB $ (,) + <$> updateWhereCount [UserCompanyUser <-. uids, UserCompanyCompany ==. cid] [UserCompanySupervisor =. False, UserCompanySupervisorReroute =. False] + <*> if firmSuperActRMSuperActive /= Just True + then return 0 + else E.deleteCount $ do + spr <- E.from $ E.table @UserSupervisor + E.where_ $ spr E.^. UserSupervisorSupervisor `E.in_` E.vals uids + E.&&. E.exists (do + usr <- E.from $ E.table @UserCompany + E.where_ $ usr E.^. UserCompanyCompany E.==. E.val cid + E.&&. usr E.^. UserCompanyUser E.==. spr E.^. UserSupervisorUser + ) + addMessageI Info $ MsgRemoveSupervisors nrRmSuper nrRmActual reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes - (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]) diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index cf5051ef5..2dee91389 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -229,6 +229,16 @@ cellHasUserModal toLink user = modal nWdgt (Left $ SomeRoute $ toLink uuid) in cell lWdgt +-- | like `cellHasUserModal` but with fixed route and showing an edit icon instead +cellEditUserModal :: (IsDBTable m c, HasEntity u User) => u -> DBCell m c +cellEditUserModal user = + let userEntity = user ^. hasEntityUser + uid = userEntity ^. _entityKey + nWdgt = toWidget $ icon IconUserEdit + lWdgt = do + uuid <- liftHandler $ encrypt uid + modal nWdgt (Left $ SomeRoute $ ForProfileR uuid) + in cell lWdgt cellHasMatrikelnummer :: (IsDBTable m a, HasUser u) => u -> DBCell m a cellHasMatrikelnummer = maybe mempty textCell . view _userMatrikelnummer diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 69ec53464..43b1ad82d 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -317,6 +317,7 @@ data FormIdentifier | FIDBtnAvsRevokeUnknown | FIDHijackUser | FIDAddSupervisor + | FIDFirmUserChangeRequest deriving (Eq, Ord, Read, Show) instance PathPiece FormIdentifier where diff --git a/src/Utils/Icon.hs b/src/Utils/Icon.hs index 0018e74e0..fb2771e85 100644 --- a/src/Utils/Icon.hs +++ b/src/Utils/Icon.hs @@ -116,6 +116,7 @@ data Icon | IconUnlocked | IconResetTries -- also see IconReset | IconCompany + | IconUserEdit deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic) deriving anyclass (Universe, Finite, NFData) @@ -209,7 +210,8 @@ iconText = \case IconLocked -> "lock" IconUnlocked -> "lock-open-alt" IconResetTries -> "trash-undo" - IconCompany -> "building" + IconCompany -> "building" + IconUserEdit -> "user-edit" nullaryPathPiece ''Icon $ camelToPathPiece' 1 deriveLift ''Icon diff --git a/templates/firm-users.hamlet b/templates/firm-users.hamlet index 9acaf1c2f..981255a1f 100644 --- a/templates/firm-users.hamlet +++ b/templates/firm-users.hamlet @@ -65,4 +65,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later

                                  _{MsgFirmAssociates}

                                  - ^{fusrTable} \ No newline at end of file + ^{fusrTable} + +

                                  + ^{fucrForm} \ No newline at end of file From 5163ed06c6b6e0652ba2f137f7350483470e1078 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 21 Nov 2023 18:49:33 +0100 Subject: [PATCH 069/159] fix(build) --- src/Handler/Firm.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index f102c1734..d4e9176f6 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -785,7 +785,7 @@ postFirmUsersR fsh = do , formSubmit = FormSubmit , formAnchor = Just addFormAnchor } - formResult fucrRes $ \FirmUserChangeRequest{..} -> when (isJust fucrPostalAddr || isJust fucrPostalAddr) $ do + formResult fucrRes $ \FirmUserChangeRequest{..} -> when (isJust fucrPostalPref || isJust fucrPostalAddr) $ do let changes = foldMap (\pp -> [UserPrefersPostal E.=. E.val pp]) fucrPostalPref <> foldMap (\pa -> [UserPostAddress E.=. E.justVal pa]) fucrPostalAddr -- seems weird, but: Nothing means no change, and not delete address! nrChanged <- runDB $ E.updateCount $ \usr -> do From cf5759bc606779548dbec9a6786764fec3b9c80e Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 22 Nov 2023 17:02:12 +0100 Subject: [PATCH 070/159] chore(firm): hide general actions --- templates/firm-users.hamlet | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/templates/firm-users.hamlet b/templates/firm-users.hamlet index 981255a1f..2346ac4dd 100644 --- a/templates/firm-users.hamlet +++ b/templates/firm-users.hamlet @@ -68,4 +68,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later ^{fusrTable}
                                  - ^{fucrForm} \ No newline at end of file +

                                  + Heading TODO +
                                  + ^{fucrForm} \ No newline at end of file From 4ae59fc1fa658e1462139ddddd6dc80308d85872 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 22 Nov 2023 17:03:01 +0100 Subject: [PATCH 071/159] fix(cache): remove risky caching for submissions --- src/Handler/Submission/List.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Handler/Submission/List.hs b/src/Handler/Submission/List.hs index 72c17f0e5..4590b9f48 100644 --- a/src/Handler/Submission/List.hs +++ b/src/Handler/Submission/List.hs @@ -397,7 +397,7 @@ colSubmissionLink = sortable (Just "submission") (i18nCell MsgTableSubmission) $ csh = x ^. resultCourseShorthand shn = x ^. resultSheet . _entityVal . _sheetName subCID = x ^. resultCryptoID - in anchorCellC $cacheIdentHere (CSubmissionR tid ssh csh shn subCID SubShowR) (toPathPiece subCID) + in anchorCell (CSubmissionR tid ssh csh shn subCID SubShowR) (toPathPiece subCID) colSelect :: forall act h epId. (Semigroup act, Monoid act, Headedness h, Ord epId) => Colonnade h CorrectionTableData (DBCell _ (FormResult (act, DBFormResult CryptoFileNameSubmission Bool CorrectionTableData), SheetTypeSummary epId)) colSelect = dbSelect (_1 . applying _2) id $ views resultCryptoID return From 7fc6e431311979919d8d753a6a6d4651668d64b7 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 22 Nov 2023 17:58:03 +0100 Subject: [PATCH 072/159] chore(profile): allow editing phone numbers --- models/users.model | 2 +- src/Handler/Profile.hs | 22 ++++++++++++++++------ src/Utils.hs | 6 ++++++ 3 files changed, 23 insertions(+), 7 deletions(-) diff --git a/models/users.model b/models/users.model index 8a686feac..b29f71eb3 100644 --- a/models/users.model +++ b/models/users.model @@ -34,7 +34,7 @@ User json -- Each Uni2work user has a corresponding row in this table; create timeFormat DateTimeFormat "default='%R'" -- preferred Time-only display format for user; user-defined downloadFiles Bool default=false -- Should files be opened in browser or downloaded? (users often oblivious that their browser has a setting for this) languages Languages Maybe -- Preferred language; user-defined - notificationSettings NotificationSettings "default='{}'::jsonb" -- Bit-array for which events email notifications are requested by user; user-defined + notificationSettings NotificationSettings "default='{}'::jsonb" -- Bit-array for which events email notifications are requested by user; user-defined; missing fields in json object will be parsed to default trigger warningDays NominalDiffTime default=1209600 -- timedistance to pending deadlines for homepage infos csvOptions CsvOptions "default='{}'::jsonb" sex Sex Maybe -- currently ignored diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index e0a12e0b1..a92c54571 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -70,6 +70,9 @@ data SettingsForm = SettingsForm , stgPrefersPostal :: Bool , stgPostAddress :: Maybe StoredMarkup + , stgTelephone :: Maybe Text + , stgMobile :: Maybe Text + , stgExamOfficeSettings :: ExamOfficeSettings , stgSchools :: Set SchoolId , stgNotificationSettings :: NotificationSettings @@ -129,9 +132,12 @@ makeSettingForm template html = do <*> apopt checkBoxField (fslI MsgShowSex & setTooltip MsgShowSexTip) (stgShowSex <$> template) <* aformSection MsgFormNotifications - <*> aopt (textField & cfStrip) (fslI MsgPDFPassword & setTooltip MsgPDFPasswordTip) (stgPinPassword <$> template) + <*> aopt (textField & cfStrip) (fslI MsgPDFPassword & setTooltip MsgPDFPasswordTip) (stgPinPassword <$> template) <*> apopt checkBoxField (fslI MsgPrefersPostalExp & setTooltip MsgPostalTip) (stgPrefersPostal <$> template) - <*> aopt htmlField (fslI MsgPostAddress & setTooltip MsgPostAddressTip) (stgPostAddress <$> template) + <*> aopt htmlField (fslI MsgPostAddress & setTooltip MsgPostAddressTip) (stgPostAddress <$> template) + + <*> aopt (textField & cfStrip) (fslI MsgUserTelephone) (stgTelephone <$> template) + <*> aopt (textField & cfStrip) (fslI MsgUserMobile ) (stgMobile <$> template) <*> examOfficeForm (stgExamOfficeSettings <$> template) <*> schoolsForm (stgSchools <$> template) @@ -362,14 +368,14 @@ validateSettings User{..} = do validEmail' userDisplayEmail' userPostAddress' <- use _stgPostAddress - let postalNotSet = isNothing userPostAddress' + let postalNotSet = isNothing userPostAddress' -- TODO $ canonical userPostAddress' postalIsValid = validPostAddress userPostAddress' guardValidation MsgUserPostalInvalid $ postalNotSet || postalIsValid userPrefersPostal' <- use _stgPrefersPostal guardValidation MsgUserPrefersPostalInvalid $ - not $ userPrefersPostal' && (postalNotSet || isJust userCompanyDepartment) + not $ userPrefersPostal' && postalNotSet && isNothing userCompanyDepartment userPinPassword' <- use _stgPinPassword let pinBad = validCmdArgument =<< userPinPassword' @@ -439,6 +445,8 @@ serveProfileR (uid, user@User{..}) = do , stgPinPassword = userPinPassword , stgPostAddress = userPostAddress , stgPrefersPostal = userPrefersPostal + , stgTelephone = userTelephone + , stgMobile = userMobile , stgExamOfficeSettings = ExamOfficeSettings { eosettingsGetSynced = userExamOfficeGetSynced , eosettingsGetLabels = userExamOfficeGetLabels @@ -467,9 +475,11 @@ serveProfileR (uid, user@User{..}) = do , UserWarningDays =. stgWarningDays , UserNotificationSettings =. stgNotificationSettings , UserShowSex =. stgShowSex - , UserPinPassword =. stgPinPassword - , UserPostAddress =. stgPostAddress + , UserPinPassword =. stgPinPassword -- TODO & canonical + , UserPostAddress =. stgPostAddress -- TODO & canonical , UserPrefersPostal =. stgPrefersPostal + , UserTelephone =. stgTelephone & canonical + , UserMobile =. stgMobile & canonical , UserExamOfficeGetSynced =. (stgExamOfficeSettings & eosettingsGetSynced) , UserExamOfficeGetLabels =. (stgExamOfficeSettings & eosettingsGetLabels) ] diff --git a/src/Utils.hs b/src/Utils.hs index 6ec20b881..b879a2164 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -1986,3 +1986,9 @@ instance {-# OVERLAPPABLE #-} (Canonical mono, MonoFoldable mono, Eq mono) => Ca -- this instance is more of a convenient abuse of the class (expand to Foldable) instance (Ord a, Canonical a) => Canonical (Set a) where canonical = Set.map canonical + +instance Canonical (Maybe Text) where + canonical Nothing = Nothing + canonical (Just t) = + let t' = Text.strip t + in if Text.null t' then Nothing else Just t' From c5c4a62de0c92bde660f177d062c4874e232d8bc Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 22 Nov 2023 17:59:15 +0100 Subject: [PATCH 073/159] chore(firm): various - multiSelectField working - section hiding demo working - modal links access rights checking --- src/Handler/Firm.hs | 35 +++++++++++++++++++------------- src/Handler/Utils/Table/Cells.hs | 19 +++++++++-------- src/Handler/Utils/Widgets.hs | 9 ++++++++ src/Utils/Frontend/Modal.hs | 2 +- 4 files changed, 42 insertions(+), 23 deletions(-) diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index d4e9176f6..9e4c7655d 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -325,7 +325,12 @@ 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 E.&&. usrCmpy E.^. UserCompanySupervisor) + E.||. E.exists (do + usrSpr <- E.from $ E.table @UserSupervisor + E.where_ $ usrSpr E.^. UserSupervisorUser E.==. usrCmpy E.^. UserCompanyUser + E.&&. usrSpr E.^. UserSupervisorSupervisor E.==. E.val uid + )) return ( cmpy -- 1 , cmpy & firmCountUsers -- 2 , cmpy & firmHasSupervisors -- 3 @@ -598,7 +603,7 @@ mkFirmUserTable isAdmin cid = do dbtRowKey = queryUserUser >>> (E.^. UserId) dbtProj = dbtProjId dbtColonnade = formColonnade $ mconcat - [ guardMonoid isAdmin $ dbSelect (applying _2) id (return . view (resultUserUser . _entityKey)) + [ 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 @@ -676,7 +681,7 @@ mkFirmUserTable isAdmin cid = do dbtFilterUI mPrev = mconcat [ fltrUserNameEmailHdrUI MsgTableCompanyUser mPrev , 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 (multiFilter "supervisors-are" . maybePrism monoPathPieces) 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) @@ -785,17 +790,19 @@ postFirmUsersR fsh = do , formSubmit = FormSubmit , formAnchor = Just addFormAnchor } - formResult fucrRes $ \FirmUserChangeRequest{..} -> when (isJust fucrPostalPref || isJust fucrPostalAddr) $ do - let changes = foldMap (\pp -> [UserPrefersPostal E.=. E.val pp]) fucrPostalPref <> - foldMap (\pa -> [UserPostAddress E.=. E.justVal pa]) fucrPostalAddr -- seems weird, but: Nothing means no change, and not delete address! - nrChanged <- runDB $ E.updateCount $ \usr -> do - E.set usr changes - E.where_ $ E.exists $ do - usrCmpy <- E.from $ E.table @UserCompany - E.where_ $ usrCmpy E.^. UserCompanyCompany E.==. E.val cid - E.&&. usrCmpy E.^. UserCompanyUser E.==. usr E.^. UserId - addMessageI Info $ MsgFirmUserChanges nrChanged - reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes + formResult fucrRes $ \FirmUserChangeRequest{fucrPostalPref=fucrPPref, fucrPostalAddr=fucrPAddr} -> do + -- let fucrPAddr = canonical fucrPAddr' TODO + when (isJust fucrPPref || isJust fucrPAddr) $ do + let changes = foldMap (\pp -> [UserPrefersPostal E.=. E.val pp]) fucrPPref <> + foldMap (\pa -> [UserPostAddress E.=. E.justVal pa]) fucrPAddr -- seems weird, but: Nothing means no change, and not delete address! + nrChanged <- runDB $ E.updateCount $ \usr -> do + E.set usr changes + E.where_ $ E.exists $ do + usrCmpy <- E.from $ E.table @UserCompany + E.where_ $ usrCmpy E.^. UserCompanyCompany E.==. E.val cid + E.&&. usrCmpy E.^. UserCompanyUser E.==. usr E.^. UserId + addMessageI Info $ MsgFirmUserChanges nrChanged + reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes siteLayout (citext2widget companyName) $ do setTitle $ toHtml $ CI.original companyShorthand <> "-" <> tshow companyAvsId diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index 2dee91389..2cab48fc2 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -226,7 +226,7 @@ cellHasUserModal toLink user = nWdgt = nameWidget (userEntity ^. _entityVal . _userDisplayName) (userEntity ^. _entityVal . _userSurname) lWdgt = do uuid <- liftHandler $ encrypt uid - modal nWdgt (Left $ SomeRoute $ toLink uuid) + modalAccess False nWdgt nWdgt $ toLink uuid in cell lWdgt -- | like `cellHasUserModal` but with fixed route and showing an edit icon instead @@ -234,10 +234,10 @@ cellEditUserModal :: (IsDBTable m c, HasEntity u User) => u -> DBCell m c cellEditUserModal user = let userEntity = user ^. hasEntityUser uid = userEntity ^. _entityKey - nWdgt = toWidget $ icon IconUserEdit + nWdgt = toWidget $ icon IconUserEdit lWdgt = do uuid <- liftHandler $ encrypt uid - modal nWdgt (Left $ SomeRoute $ ForProfileR uuid) + modalAccess True nWdgt mempty $ ForProfileR uuid in cell lWdgt cellHasMatrikelnummer :: (IsDBTable m a, HasUser u) => u -> DBCell m a cellHasMatrikelnummer = maybe mempty textCell . view _userMatrikelnummer @@ -246,7 +246,7 @@ cellHasMatrikelnummerLinked :: (IsDBTable m a, HasEntity u User) => u -> DBCell cellHasMatrikelnummerLinked usr | Just matNr <- usrEntity ^. _userMatrikelnummer = cell $ do uuid <- liftHandler $ encrypt $ usrEntity ^. _entityKey - modal (text2widget matNr) (Left $ SomeRoute $ AdminAvsUserR uuid) + modalAccess False (text2widget matNr) mempty (AdminAvsUserR uuid) | otherwise = mempty where usrEntity = usr ^. hasEntityUser @@ -364,7 +364,7 @@ qualificationValidUntilCell' mbToLink d qb qu = cell $ case mbToLink of Nothing -> headWgt <> dateWgt Just toLink -> do uuid <- liftHandler $ encrypt $ qu ^. hasQualificationUser . _qualificationUserUser - let modalWgt = modal dateWgt (Left $ SomeRoute $ toLink uuid) + let modalWgt = modalAccess False dateWgt dateWgt $ toLink uuid headWgt <> modalWgt where dateWgt = formatTimeW SelFormatDate (qu ^. hasQualificationUser . _qualificationUserValidUntil) @@ -385,7 +385,8 @@ qualificationValidReasonCell' mbToLink showReason d qb qu = ic <> foldMap blc qb dc tstamp | Just toLink <- mbToLink = cell $ do uuid <- liftHandler $ encrypt uid - modal (formatTimeW SelFormatDate tstamp) (Left $ SomeRoute $ toLink uuid) + let dWgt = formatTimeW SelFormatDate tstamp + modalAccess False dWgt dWgt $ toLink uuid -- anchorCellM (toLink <$> encrypt uid) | otherwise = dateCell tstamp uid = qu ^. hasQualificationUser . _qualificationUserUser @@ -403,7 +404,8 @@ qualificationValidReasonCell'' mbToLink showReason d qb qu extValid = ic <> icEr dc tstamp | Just toLink <- mbToLink = cell $ do uuid <- liftHandler $ encrypt uid - modal (formatTimeW SelFormatDate tstamp) (Left $ SomeRoute $ toLink uuid) + let dWgt = formatTimeW SelFormatDate tstamp + modalAccess False dWgt dWgt $ toLink uuid -- anchorCellM (toLink <$> encrypt uid) | otherwise = dateCell tstamp uid = qu ^. hasQualificationUser . _qualificationUserUser @@ -463,7 +465,8 @@ avsPersonNoCell = numCell . view _userAvsNoPerson avsPersonNoLinkedCell :: (IsDBTable m c, HasUserAvs a) => a -> DBCell m c avsPersonNoLinkedCell a = cell $ do uuid <- liftHandler $ encrypt $ a ^. _userAvsUser - modal (toWgt $ toMessage $ a ^. _userAvsNoPerson) (Left $ SomeRoute $ AdminAvsUserR uuid) + let nWgt = toWgt $ toMessage $ a ^. _userAvsNoPerson + modalAccess False nWgt nWgt $ AdminAvsUserR uuid avsPersonCardCell :: (IsDBTable m c) => Set AvsDataPersonCard -> DBCell m c avsPersonCardCell cards = wgtCell diff --git a/src/Handler/Utils/Widgets.hs b/src/Handler/Utils/Widgets.hs index 23a4b3a37..61c3c298e 100644 --- a/src/Handler/Utils/Widgets.hs +++ b/src/Handler/Utils/Widgets.hs @@ -123,6 +123,15 @@ editedByW fmt tm usr = do [whamlet|_{MsgUtilEditedBy usr ft}|] +-- | like `modal`, but checks access rights to the link +modalAccess :: Bool -> Widget -> Widget -> Route UniWorX -> Widget +modalAccess writeAccess wdgtYes wdgtNo route = do + authOk <- liftHandler $ bool hasReadAccessTo hasWriteAccessTo writeAccess route + if authOk + then modal wdgtYes (Left $ SomeRoute route) + else wdgtNo + + ---------- -- HEAT -- ---------- diff --git a/src/Utils/Frontend/Modal.hs b/src/Utils/Frontend/Modal.hs index c7c3ad8d0..304326ccc 100644 --- a/src/Utils/Frontend/Modal.hs +++ b/src/Utils/Frontend/Modal.hs @@ -38,7 +38,7 @@ customModal Modal{..} = do route <- traverse toTextUrl $ modalContent ^? _Left modalTrigger route triggerId' --- | Create a link to a modal +-- | Create a link to a modal, does not check link, see `Handler.Utils.Widget.modalAccess` for a checking variant modal :: WidgetFor site () -- ^ Widget that represents the link -> Either (SomeRoute site) (WidgetFor site ()) -- ^ Modal contant: either dynamic link or static widget -> WidgetFor site () -- ^ result widget From 400a3449c5e68994ba0e872b590bef9c0acaf728 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 23 Nov 2023 13:27:57 +0100 Subject: [PATCH 074/159] refactor(firm): fix build too --- .../uniworx/categories/firm/de-de-formal.msg | 2 ++ messages/uniworx/categories/firm/en-eu.msg | 2 ++ src/Handler/Firm.hs | 2 ++ src/Handler/Profile.hs | 8 +++---- src/Model/Types/Markup.hs | 7 ++++++ src/Utils.hs | 11 +++++---- templates/firm-contact-info.hamlet | 23 +++++++++++++++++++ templates/firm-users.hamlet | 13 +---------- .../i18n/firm-supervisors/de-de-formal.hamlet | 16 ++++--------- templates/i18n/firm-supervisors/en-eu.hamlet | 16 ++++--------- 10 files changed, 55 insertions(+), 45 deletions(-) create mode 100644 templates/firm-contact-info.hamlet diff --git a/messages/uniworx/categories/firm/de-de-formal.msg b/messages/uniworx/categories/firm/de-de-formal.msg index 8c9cf7a8e..5d81a2b03 100644 --- a/messages/uniworx/categories/firm/de-de-formal.msg +++ b/messages/uniworx/categories/firm/de-de-formal.msg @@ -3,6 +3,8 @@ # SPDX-License-Identifier: AGPL-3.0-or-later FirmAssociates: Firmenangehörige +FirmContact: Firmenkontakt +FirmNoContact: Keine allgemeinen Kontaktinformationen bekannt. FirmEmail: Allgemeine Email FirmAddress: Postanschrift FirmDefaultPreferenceInfo: Diese Voreinstellungen gelten nur für neue Firmenangehörige diff --git a/messages/uniworx/categories/firm/en-eu.msg b/messages/uniworx/categories/firm/en-eu.msg index 0d7ef77eb..250b9ca38 100644 --- a/messages/uniworx/categories/firm/en-eu.msg +++ b/messages/uniworx/categories/firm/en-eu.msg @@ -3,6 +3,8 @@ # SPDX-License-Identifier: AGPL-3.0-or-later FirmAssociates: Company associated users +FirmContact: Company Contact +FirmNoContact: No general contact information known. FirmEmail: General company email FirmAddress: Postal address FirmDefaultPreferenceInfo: Default setting for new company associates only diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 9e4c7655d..9442d841a 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -806,6 +806,7 @@ postFirmUsersR fsh = do siteLayout (citext2widget companyName) $ do setTitle $ toHtml $ CI.original companyShorthand <> "-" <> tshow companyAvsId + let firmContactInfo = $(widgetFile "firm-contact-info") $(widgetFile "firm-users") @@ -1053,6 +1054,7 @@ postFirmSupersR fsh = do siteLayout (citext2widget fsh) $ do setTitle $ citext2Html $ fsh <> " Supers" + let firmContactInfo = $(widgetFile "firm-contact-info") $(i18nWidgetFile "firm-supervisors") diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index a92c54571..3a0103c58 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -475,11 +475,11 @@ serveProfileR (uid, user@User{..}) = do , UserWarningDays =. stgWarningDays , UserNotificationSettings =. stgNotificationSettings , UserShowSex =. stgShowSex - , UserPinPassword =. stgPinPassword -- TODO & canonical - , UserPostAddress =. stgPostAddress -- TODO & canonical + , UserPinPassword =. (stgPinPassword & canonical) + , UserPostAddress =. (stgPostAddress & canonical) , UserPrefersPostal =. stgPrefersPostal - , UserTelephone =. stgTelephone & canonical - , UserMobile =. stgMobile & canonical + , UserTelephone =. (stgTelephone & canonical) + , UserMobile =. (stgMobile & canonical) , UserExamOfficeGetSynced =. (stgExamOfficeSettings & eosettingsGetSynced) , UserExamOfficeGetLabels =. (stgExamOfficeSettings & eosettingsGetLabels) ] diff --git a/src/Model/Types/Markup.hs b/src/Model/Types/Markup.hs index c5555ceba..0715b65b5 100644 --- a/src/Model/Types/Markup.hs +++ b/src/Model/Types/Markup.hs @@ -50,6 +50,13 @@ data StoredMarkup = StoredMarkup deriving (Read, Show, Generic) deriving anyclass (Binary, Hashable, NFData) +instance Canonical (Maybe StoredMarkup) where + canonical Nothing = Nothing + canonical r@(Just s@StoredMarkup{..}) = let mi' = LT.strip markupInput in if + | LT.null mi' -> Nothing + | markupInput == mi' -> r + | otherwise -> Just s{markupInput = mi'} + htmlToStoredMarkup :: Html -> StoredMarkup htmlToStoredMarkup html = StoredMarkup { markupInputFormat = MarkupHtml diff --git a/src/Utils.hs b/src/Utils.hs index b879a2164..324f71aa7 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -1987,8 +1987,9 @@ instance {-# OVERLAPPABLE #-} (Canonical mono, MonoFoldable mono, Eq mono) => Ca instance (Ord a, Canonical a) => Canonical (Set a) where canonical = Set.map canonical -instance Canonical (Maybe Text) where - canonical Nothing = Nothing - canonical (Just t) = - let t' = Text.strip t - in if Text.null t' then Nothing else Just t' +instance Canonical (Maybe Text) where -- a split into Canonical Text and Canonical a => Maybe seems nicer, but the latter instance would be troublesome + canonical Nothing = Nothing + canonical r@(Just t) = let t' = Text.strip t in if + | Text.null t' -> Nothing + | t == t' -> r + | otherwise -> Just t' diff --git a/templates/firm-contact-info.hamlet b/templates/firm-contact-info.hamlet new file mode 100644 index 000000000..8aea13ab1 --- /dev/null +++ b/templates/firm-contact-info.hamlet @@ -0,0 +1,23 @@ +$newline never + +$# SPDX-FileCopyrightText: 2023 Steffen Jost +$# +$# SPDX-License-Identifier: AGPL-3.0-or-later + +
                                  +

                                  _{MsgFirmContact} +
                                  + $maybe fem <- companyEmail +
                                  + _{MsgFirmEmail} #{iconLetterOrEmail False} +
                                  + #{mailtoHtml fem} + $maybe addr <- companyPostAddress +
                                  + _{MsgFirmAddress} #{iconLetterOrEmail True} +
                                  + #{addr} + $nothing + $maybe _ <- companyEmail + $nothing + _{MsgFirmNoContact} diff --git a/templates/firm-users.hamlet b/templates/firm-users.hamlet index 2346ac4dd..19c41bb64 100644 --- a/templates/firm-users.hamlet +++ b/templates/firm-users.hamlet @@ -4,18 +4,7 @@ $# SPDX-FileCopyrightText: 2023 Steffen Jost $# $# SPDX-License-Identifier: AGPL-3.0-or-later -
                                  -
                                  - $maybe fem <- companyEmail -
                                  - _{MsgFirmEmail} #{iconLetterOrEmail False} -
                                  - #{mailtoHtml fem} - $maybe addr <- companyPostAddress -
                                  - _{MsgFirmAddress} #{iconLetterOrEmail True} -
                                  - #{addr} +^{firmContactInfo}
                                  diff --git a/templates/i18n/firm-supervisors/de-de-formal.hamlet b/templates/i18n/firm-supervisors/de-de-formal.hamlet index d81248e80..5e432e780 100644 --- a/templates/i18n/firm-supervisors/de-de-formal.hamlet +++ b/templates/i18n/firm-supervisors/de-de-formal.hamlet @@ -9,19 +9,11 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later 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} + +^{firmContactInfo} +
                                  ^{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 index 400fc543b..b34a75431 100644 --- a/templates/i18n/firm-supervisors/en-eu.hamlet +++ b/templates/i18n/firm-supervisors/en-eu.hamlet @@ -8,19 +8,11 @@ $# 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} + +^{firmContactInfo} +
                                  ^{fsprTable} +
                                  ^{addSuperForm} From dc6079ec3b4eae32fe0e4325f958955edbcef965 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 23 Nov 2023 18:05:16 +0100 Subject: [PATCH 075/159] chore(nix): attempt to create alias for killall-uni2work --- shell.nix | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/shell.nix b/shell.nix index 0988cc475..9acbf8a78 100644 --- a/shell.nix +++ b/shell.nix @@ -257,6 +257,10 @@ let done ''; + environment.interactiveShellInit = '' + alias killuni2work='killall-uni2work' + ''; + diffRunning = pkgs.writeScriptBin "diff-running" '' #!${pkgs.zsh}/bin/zsh From 8973ea5849a69b72b559bae20f3c6f9564f8030f Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 23 Nov 2023 18:06:00 +0100 Subject: [PATCH 076/159] refactor(firm): WIP generalize firm actions --- .../uniworx/categories/firm/de-de-formal.msg | 6 + messages/uniworx/categories/firm/en-eu.msg | 8 +- src/Handler/Firm.hs | 183 ++++++++++++++---- src/Handler/Utils.hs | 4 +- src/Utils/Form.hs | 1 + .../i18n/firm-supervisors/de-de-formal.hamlet | 2 + templates/i18n/firm-supervisors/en-eu.hamlet | 4 +- 7 files changed, 161 insertions(+), 47 deletions(-) diff --git a/messages/uniworx/categories/firm/de-de-formal.msg b/messages/uniworx/categories/firm/de-de-formal.msg index 5d81a2b03..d5cda6037 100644 --- a/messages/uniworx/categories/firm/de-de-formal.msg +++ b/messages/uniworx/categories/firm/de-de-formal.msg @@ -8,6 +8,12 @@ FirmNoContact: Keine allgemeinen Kontaktinformationen bekannt. FirmEmail: Allgemeine Email FirmAddress: Postanschrift FirmDefaultPreferenceInfo: Diese Voreinstellungen gelten nur für neue Firmenangehörige +FirmAction: Firmenweite Aktion +FirmActNotify: Mitteilung versenden +FirmActResetSupervision: Ansprechpartner für alle Firmenangehörigen zurücksetzen +FirmActResetSuperKeep: Bisherige Ansprechpartner der Firmenangehörigen zusätzlich beibehalten? +FirmActResetMutualSupervision: Ansprechpartner beaufsichtigen sich gegenseitig +FirmActAddSupervisors: Ansprechpartner hinzufügen FirmAllActNotify: Mitteilung versenden FirmAllActResetSupervision: Ansprechpartner für alle Firmenangehörigen zurücksetzen FirmAllActResetSuperKeep: Bisherige Ansprechpartner der Firmenangehörigen zusätzlich beibehalten? diff --git a/messages/uniworx/categories/firm/en-eu.msg b/messages/uniworx/categories/firm/en-eu.msg index 250b9ca38..953055b25 100644 --- a/messages/uniworx/categories/firm/en-eu.msg +++ b/messages/uniworx/categories/firm/en-eu.msg @@ -8,11 +8,17 @@ FirmNoContact: No general contact information known. FirmEmail: General company email FirmAddress: Postal address FirmDefaultPreferenceInfo: Default setting for new company associates only +FirmAction: Companywide action +FirmActNotify: Send message +FirmActResetSupervision: Reset supervisors for all company associates +FirmActResetSuperKeep: Additionally keep existing supervisors of company associates? +FirmActResetMutualSupervision: Supervisors supervise each other +FirmActAddSupervisors: Add supervisors 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 +FirmUserActNotify: Send message 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 diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 9442d841a..12efe6594 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -48,12 +48,134 @@ decryptUser = decrypt encryptUser :: (MonadHandler m, HandlerSite m ~ UniWorX) => UserId -> m CryptoUUIDUser encryptUser = encrypt +postalEmailField :: (MonadHandler m, HandlerSite m ~ UniWorX) => Field m Bool +postalEmailField = boolFieldCustom (SomeMessage MsgUtilPostal) (SomeMessage MsgUtilEMail) $ Just $ SomeMessage MsgUtilUnchanged + +--------------------------------- +-- General firm affecting actions + +data FirmAction = FirmActNotify + | FirmActResetSupervision + -- | FirmActAddSupervisors + deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) + deriving anyclass (Universe, Finite) + +nullaryPathPiece ''FirmAction $ camelToPathPiece' 3 +embedRenderMessage ''UniWorX ''FirmAction id + +data FirmActionData = FirmActNotifyData + | FirmActResetSupervisionData + { firmActResetKeepOldSupers :: Maybe Bool + , firmActResetMutualSupervision :: Maybe Bool + } + -- | FirmActAddSupervisorsData + -- { firmActAddSupervisorIds :: Set Text + -- , firmActAddSupervisorReroute :: Bool + -- , firmActAddSupervisorPostal :: Maybe Bool + -- } + deriving (Eq, Ord, Read, Show, Generic) + +firmActionMap :: [FirmAction] -> Map FirmAction (AForm Handler FirmActionData) +firmActionMap acts = mconcat (mkAct <$> acts) + where + mkAct FirmActNotify = singletonMap FirmActNotify $ pure FirmActNotifyData + mkAct FirmActResetSupervision = singletonMap FirmActResetSupervision $ FirmActResetSupervisionData + <$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep) (Just $ Just False) + <*> aopt checkBoxField (fslI MsgFirmActResetMutualSupervision) (Just $ Just True ) + -- mkAct FirmActAddSupervisors = singletonMap FirmActAddSupervisors $ FirmActAddSupervisorsData + -- <$> areq (textField & cfAnySeparatedSet) (fslI MsgTableIsDefaultSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) (Just mempty) + -- <*> areq checkBoxField (fslI MsgTableIsDefaultReroute ) (Just True) + -- <*> aopt postalEmailField (fslI MsgFormReqPostal & setTooltip MsgFormReqPostalTip) (Just Nothing) + +firmActionForm :: [FirmAction] -> AForm Handler FirmActionData +firmActionForm acts = multiActionA (firmActionMap acts) (fslI MsgTableAction) Nothing + + +makeFirmActionForm :: CompanyId -> [FirmAction] -> Form (FirmActionData, Set CompanyId) +makeFirmActionForm cid acts html = flip (renderAForm FormStandard) html $ (,Set.singleton cid) <$> firmActionForm acts + +-- makeFirmActionTableForm :: Monoid t => [FirmAction] -> Text.Blaze.Internal.Markup -> Control.Monad.Trans.RWS.Lazy.RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints Handler (FormResult (First FirmActionData, t), WidgetFor UniWorX ()) +-- makeFirmActionTableForm acts = renderAForm FormStandard $ (, mempty) . First . Just <$> firmActionForm acts + +firmActionHandler :: Route UniWorX -> FormResult (FirmActionData, Set CompanyId) -> Handler () +firmActionHandler route = flip formResult faHandler + where + faHandler (_,fids) | null fids = addMessageI Error MsgNoCompanySelected + faHandler (FirmActResetSupervisionData{..}, fids) = do + runDB $ do + delSupers <- if firmActResetKeepOldSupers == 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 (firmActResetMutualSupervision /= Just False) fids + addMessageI Info $ MsgFirmResetSupervision delSupers newSupers + reloadKeepGetParams route -- reload to reflect changes + + faHandler (FirmActNotifyData, 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 fids + return $ usr E.^. UserId + cuids <- traverse (encrypt . E.unValue) usrs :: Handler [CryptoUUIDUser] + redirect (FirmsCommR $ fmap unCompanyKey fids, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids]) + + -- faHandler (FirmActAddSupervisorsData{..}, Set.toList -> [cid]) = do + -- avsUsers :: Map Text (Maybe UserId) <- sequenceA $ Map.fromSet guessAvsUser firmActAddSupervisorIds + -- 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 + -- reloadKeepGetParams route + -- runDB $ do + -- putMany [UserCompany uid cid True firmActAddSupervisorReroute | uid <- usersFound] + -- whenIsJust firmActAddSupervisorPostal $ \prefPostal -> + -- updateWhere [UserId <-. usersFound] [UserPrefersPostal =. prefPostal] + -- addMessageI Info $ MsgASReqSetSupers (fromIntegral $ length usersFound) firmActAddSupervisorPostal + -- redirect route + -- faHandler _ = addMessageI Error MsgErrorUnknownFormAction + + +runFirmActionFormPost :: CompanyId -> Route UniWorX -> [FirmAction] -> Handler Widget +runFirmActionFormPost cid route acts = do + -- ((faRes, faWgt), faEnctype) <- runFormPost . identifyForm FIDFirmAction $ makeFirmActionForm cid acts + ((faRes, faWgt), faEnctype) <- runFormPost $ makeFirmActionForm cid acts + let faAnchor = "firm-action-form" :: Text + faRoute = route :#: faAnchor + faForm = wrapForm faWgt FormSettings + { formMethod = POST + , formAction = Just . SomeRoute $ faRoute + , formEncoding = faEnctype + , formAttrs = [] + , formSubmit = FormSubmit + , formAnchor = Just faAnchor + } + firmActionHandler route faRes + return [whamlet| +
                                    +

                                    + _{MsgFirmAction} +
                                    + ^{faForm} + |] + + --------------------------- -- Firm specific utilities -- for filters and counts also see before FirmAllR Handlers -postalEmailField :: (MonadHandler m, HandlerSite m ~ UniWorX) => Field m Bool -postalEmailField = boolFieldCustom (SomeMessage MsgUtilPostal) (SomeMessage MsgUtilEMail) $ Just $ SomeMessage MsgUtilUnchanged + -- remove supervisors: deleteSupervisors :: NonEmpty UserId -> DB Int64 @@ -315,7 +437,7 @@ resultAllCompanyDefaultReroutes :: Lens' AllCompanyTableData Bool resultAllCompanyDefaultReroutes = _dbrOutput . _4 . _unValue -mkFirmAllTable :: Bool -> UserId -> DB (FormResult (FirmAllActionData, Set CompanyId), Widget) +mkFirmAllTable :: Bool -> UserId -> DB (FormResult (FirmActionData, Set CompanyId), Widget) mkFirmAllTable isAdmin uid = do -- now <- liftIO getCurrentTime let @@ -432,21 +554,14 @@ mkFirmAllTable isAdmin uid = do , prismAForm (singletonFilter "company-postal" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterFirmExtern) ] dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } - acts :: Map FirmAllAction (AForm Handler FirmAllActionData) - acts = mconcat - [ singletonMap FirmAllActNotify $ pure FirmAllActNotifyData - , singletonMap FirmAllActResetSupervision $ FirmAllActResetSupervisionData - <$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmAllActResetSuperKeep) (Just $ Just False) - <*> aopt checkBoxField (fslI MsgFirmAllActResetMutualSupervision) (Just $ Just True ) - ] dbtParams = DBParamsForm { dbParamsFormMethod = POST , dbParamsFormAction = Nothing , dbParamsFormAttrs = [] , dbParamsFormSubmit = FormSubmit - , dbParamsFormAdditional - = renderAForm FormStandard $ (, mempty) . First . Just - <$> multiActionA acts (fslI MsgTableAction) Nothing + -- , dbParamsFormAdditional = renderAForm FormStandard $ (, mempty) . First . Just <$> firmActionForm [FirmActNotify, FirmActResetSupervision] + , dbParamsFormAdditional = renderAForm FormStandard $ (, mempty) . First . Just + <$> multiActionA (firmActionMap [FirmActNotify, FirmActResetSupervision]) (fslI MsgTableAction) Nothing , dbParamsFormEvaluate = liftHandler . runFormPost , dbParamsFormResult = id , dbParamsFormIdent = def @@ -457,14 +572,14 @@ mkFirmAllTable isAdmin uid = do dbtCsvDecode = Nothing dbtExtraReps = [] - postprocess :: FormResult (First FirmAllActionData, DBFormResult CompanyId Bool AllCompanyTableData) - -> FormResult ( FirmAllActionData, Set CompanyId) + postprocess :: FormResult (First FirmActionData, DBFormResult CompanyId Bool AllCompanyTableData) + -> FormResult ( FirmActionData, Set CompanyId) postprocess inp = do (First (Just act), cmpMap) <- inp let cmpSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) cmpMap return (act, cmpSet) - -- resultDBTableValidator :: PSValidator (MForm Handler) (FormResult (First FirmAllActionData, DBFormResult CompanyId Bool FirmAllActionData)) + -- resultDBTableValidator :: PSValidator (MForm Handler) (FormResult (First FirmActionData, DBFormResult CompanyId Bool FirmActionData)) resultDBTableValidator = def & defaultSorting [SortAscBy "short"] over _1 postprocess <$> dbTable resultDBTableValidator resultDBTable @@ -475,32 +590,8 @@ 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 - (_, fids) | null fids -> addMessageI Error MsgNoCompanySelected - - (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 delSupers newSupers - 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) - E.where_ $ uc E.^. UserCompanyCompany `E.in_` E.valList fids - return $ usr E.^. UserId - cuids <- traverse (encrypt . E.unValue) usrs :: Handler [CryptoUUIDUser] - redirect (FirmsCommR $ fmap unCompanyKey fids, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids]) - + (_firmRes, firmTable) <- runDB $ mkFirmAllTable isAdmin uid -- filters to associated companies for non-admins + -- firmActionHandler FirmAllR firmRes siteLayoutMsg MsgMenuFirms $ do setTitleI MsgMenuFirms $(i18nWidgetFile "firm-all") @@ -1019,6 +1110,8 @@ postFirmSupersR fsh = do cuids <- traverse encrypt $ Set.toList uids :: Handler [CryptoUUIDUser] redirect (FirmCommR fsh, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids]) + formFirmAction <- runFirmActionFormPost cid (FirmSupersR fsh) [FirmActNotify, FirmActResetSupervision] -- TODO ,FirmActAddSupervisors] + ((asReqRes, asReqWgt), asReqEnctype) <- runFormPost . identifyForm FIDAddSupervisor $ makeAddSupervisorForm (Just def) let addSuperAnchor = "add-supervisors-form" :: Text routeAddSuperForm = FirmSupersR fsh :#: addSuperAnchor @@ -1056,7 +1149,11 @@ postFirmSupersR fsh = do setTitle $ citext2Html $ fsh <> " Supers" let firmContactInfo = $(widgetFile "firm-contact-info") $(i18nWidgetFile "firm-supervisors") - + + +------------------------ +-- Firm Communications + getFirmCommR, postFirmCommR :: CompanyShorthand -> Handler Html getFirmCommR = postFirmCommR diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs index 2460eb65d..715c910a5 100644 --- a/src/Handler/Utils.hs +++ b/src/Handler/Utils.hs @@ -146,7 +146,7 @@ redirectAlternatives = go reload :: (MonadHandler m, HandlerSite m ~ UniWorX) => Route (HandlerSite m) -> m a reload r = getCurrentRoute >>= redirect . fromMaybe r --- | like `reload`, preserving all GET parameters +-- | like `reload` to current route, but also preserving all GET parameters, using the current route, if known reloadKeepGetParams :: (MonadHandler m, HandlerSite m ~ UniWorX) => Route (HandlerSite m) -> m a reloadKeepGetParams r = liftHandler $ do getps <- reqGetParams <$> getRequest @@ -155,7 +155,7 @@ reloadKeepGetParams r = liftHandler $ do -- RECALL: redirect GET parameters are used like so: -- redirect (UsersR, [("users-user-company","fraport")]) redirect (route, getps) --- | redirect preserving all GET parameters +-- | like `reloadKeepGetParams`, but always leading to the specific route instead of the current route redirectKeepGetParams :: (MonadHandler m, HandlerSite m ~ UniWorX) => Route (HandlerSite m) -> m a redirectKeepGetParams route = liftHandler $ do getps <- reqGetParams <$> getRequest diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 43b1ad82d..39107331e 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -318,6 +318,7 @@ data FormIdentifier | FIDHijackUser | FIDAddSupervisor | FIDFirmUserChangeRequest + | FIDFirmAction 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 index 5e432e780..bd9fdf4db 100644 --- a/templates/i18n/firm-supervisors/de-de-formal.hamlet +++ b/templates/i18n/firm-supervisors/de-de-formal.hamlet @@ -12,6 +12,8 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later ^{firmContactInfo} +^{formFirmAction} +
                                    ^{fsprTable} diff --git a/templates/i18n/firm-supervisors/en-eu.hamlet b/templates/i18n/firm-supervisors/en-eu.hamlet index b34a75431..8edcdeeec 100644 --- a/templates/i18n/firm-supervisors/en-eu.hamlet +++ b/templates/i18n/firm-supervisors/en-eu.hamlet @@ -11,8 +11,10 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later ^{firmContactInfo} +^{formFirmAction} +
                                    ^{fsprTable} - +
                                    ^{addSuperForm} From b10cbc39cca0d4e23c0d2a3f8b65d9f3343e6bd4 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 23 Nov 2023 18:22:00 +0100 Subject: [PATCH 077/159] refactor(firm): FirmAllR messaging working old way --- src/Handler/Firm.hs | 48 +++++++++++++++++++++++++++++++++++++++------ 1 file changed, 42 insertions(+), 6 deletions(-) diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 12efe6594..5014bec27 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -437,7 +437,7 @@ resultAllCompanyDefaultReroutes :: Lens' AllCompanyTableData Bool resultAllCompanyDefaultReroutes = _dbrOutput . _4 . _unValue -mkFirmAllTable :: Bool -> UserId -> DB (FormResult (FirmActionData, Set CompanyId), Widget) +mkFirmAllTable :: Bool -> UserId -> DB (FormResult (FirmAllActionData, Set CompanyId), Widget) mkFirmAllTable isAdmin uid = do -- now <- liftIO getCurrentTime let @@ -554,14 +554,25 @@ mkFirmAllTable isAdmin uid = do , prismAForm (singletonFilter "company-postal" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterFirmExtern) ] dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } + acts :: Map FirmAllAction (AForm Handler FirmAllActionData) + acts = mconcat + [ singletonMap FirmAllActNotify $ pure FirmAllActNotifyData + , singletonMap FirmAllActResetSupervision $ FirmAllActResetSupervisionData + <$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmAllActResetSuperKeep) (Just $ Just False) + <*> aopt checkBoxField (fslI MsgFirmAllActResetMutualSupervision) (Just $ Just True ) + ] + dbtParams = DBParamsForm { dbParamsFormMethod = POST , dbParamsFormAction = Nothing , dbParamsFormAttrs = [] , dbParamsFormSubmit = FormSubmit -- , dbParamsFormAdditional = renderAForm FormStandard $ (, mempty) . First . Just <$> firmActionForm [FirmActNotify, FirmActResetSupervision] - , dbParamsFormAdditional = renderAForm FormStandard $ (, mempty) . First . Just - <$> multiActionA (firmActionMap [FirmActNotify, FirmActResetSupervision]) (fslI MsgTableAction) Nothing + -- , dbParamsFormAdditional = renderAForm FormStandard $ (, mempty) . First . Just + -- <$> multiActionA (firmActionMap [FirmActNotify, FirmActResetSupervision]) (fslI MsgTableAction) Nothing + , dbParamsFormAdditional + = renderAForm FormStandard $ (, mempty) . First . Just + <$> multiActionA acts (fslI MsgTableAction) Nothing , dbParamsFormEvaluate = liftHandler . runFormPost , dbParamsFormResult = id , dbParamsFormIdent = def @@ -572,8 +583,8 @@ mkFirmAllTable isAdmin uid = do dbtCsvDecode = Nothing dbtExtraReps = [] - postprocess :: FormResult (First FirmActionData, DBFormResult CompanyId Bool AllCompanyTableData) - -> FormResult ( FirmActionData, Set CompanyId) + 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 @@ -590,8 +601,33 @@ getFirmAllR = postFirmAllR postFirmAllR = do uid <- requireAuthId isAdmin <- hasReadAccessTo AdminR - (_firmRes, firmTable) <- runDB $ mkFirmAllTable isAdmin uid -- filters to associated companies for non-admins + (firmRes, firmTable) <- runDB $ mkFirmAllTable isAdmin uid -- filters to associated companies for non-admins -- firmActionHandler FirmAllR firmRes + formResult firmRes $ \case + (_, fids) | null fids -> addMessageI Error MsgNoCompanySelected + + (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 delSupers newSupers + 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) + E.where_ $ uc E.^. UserCompanyCompany `E.in_` E.valList fids + 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") From 577a2fb45d8274f26677275f9fc892ac64afa3e6 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 23 Nov 2023 18:29:12 +0100 Subject: [PATCH 078/159] refactor(firm): FirmAllR messaging no longer works now What did change? Nothing here is essential?! --- src/Handler/Firm.hs | 30 +++++++++++++++--------------- 1 file changed, 15 insertions(+), 15 deletions(-) diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 5014bec27..bbb69ad23 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -437,7 +437,7 @@ resultAllCompanyDefaultReroutes :: Lens' AllCompanyTableData Bool resultAllCompanyDefaultReroutes = _dbrOutput . _4 . _unValue -mkFirmAllTable :: Bool -> UserId -> DB (FormResult (FirmAllActionData, Set CompanyId), Widget) +mkFirmAllTable :: Bool -> UserId -> DB (FormResult (FirmActionData, Set CompanyId), Widget) mkFirmAllTable isAdmin uid = do -- now <- liftIO getCurrentTime let @@ -554,12 +554,12 @@ mkFirmAllTable isAdmin uid = do , prismAForm (singletonFilter "company-postal" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterFirmExtern) ] dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } - acts :: Map FirmAllAction (AForm Handler FirmAllActionData) + acts :: Map FirmAction (AForm Handler FirmActionData) acts = mconcat - [ singletonMap FirmAllActNotify $ pure FirmAllActNotifyData - , singletonMap FirmAllActResetSupervision $ FirmAllActResetSupervisionData - <$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmAllActResetSuperKeep) (Just $ Just False) - <*> aopt checkBoxField (fslI MsgFirmAllActResetMutualSupervision) (Just $ Just True ) + [ singletonMap FirmActNotify $ pure FirmActNotifyData + , singletonMap FirmActResetSupervision $ FirmActResetSupervisionData + <$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep) (Just $ Just False) + <*> aopt checkBoxField (fslI MsgFirmActResetMutualSupervision) (Just $ Just True ) ] dbtParams = DBParamsForm @@ -583,8 +583,8 @@ mkFirmAllTable isAdmin uid = do dbtCsvDecode = Nothing dbtExtraReps = [] - postprocess :: FormResult (First FirmAllActionData, DBFormResult CompanyId Bool AllCompanyTableData) - -> FormResult ( FirmAllActionData, Set CompanyId) + postprocess :: FormResult (First FirmActionData, DBFormResult CompanyId Bool AllCompanyTableData) + -> FormResult ( FirmActionData, Set CompanyId) postprocess inp = do (First (Just act), cmpMap) <- inp let cmpSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) cmpMap @@ -606,9 +606,9 @@ postFirmAllR = do formResult firmRes $ \case (_, fids) | null fids -> addMessageI Error MsgNoCompanySelected - (FirmAllActResetSupervisionData{..}, fids) -> do + (FirmActResetSupervisionData{..}, fids) -> do runDB $ do - delSupers <- if firmAllActResetKeepOldSupers == Just False + delSupers <- if firmActResetKeepOldSupers == Just False then E.deleteCount $ do spr <- E.from $ E.table @UserSupervisor E.where_ $ E.exists $ do @@ -616,11 +616,11 @@ 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 + newSupers <- addDefaultSupervisorsAll (firmActResetMutualSupervision /= Just False) fids addMessageI Info $ MsgFirmResetSupervision delSupers newSupers reloadKeepGetParams FirmAllR -- reload to reflect changes - (FirmAllActNotifyData , Set.toList -> fids) -> do + (FirmActNotifyData , 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 fids @@ -818,8 +818,8 @@ mkFirmUserTable isAdmin cid = do acts = mconcat [ singletonMap FirmUserActNotify $ pure FirmUserActNotifyData , singletonMap FirmUserActResetSupervision $ FirmUserActResetSupervisionData - <$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmAllActResetSuperKeep) (Just $ Just False) - -- <*> aopt checkBoxField (fslI MsgFirmAllActResetMutualSupervision) (Just $ Just True ) + <$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep) (Just $ Just False) + -- <*> aopt checkBoxField (fslI MsgFirmActResetMutualSupervision) (Just $ Just True ) , singletonMap FirmUserActMkSuper $ FirmUserActMkSuperData <$> aopt checkBoxField (fslI MsgTableIsDefaultReroute) (Just $ Just True) ] @@ -848,7 +848,7 @@ mkFirmUserTable isAdmin cid = do 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 :: PSValidator (MForm Handler) (FormResult (First FirmActionData, DBFormResult CompanyId Bool FirmActionData)) resultDBTableValidator = def & defaultSorting [SortAscBy "user-name"] over _1 postprocess <$> dbTable resultDBTableValidator resultDBTable From e645517d327734ebd0e2b5a4e877bb440c9b0af0 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 23 Nov 2023 18:36:02 +0100 Subject: [PATCH 079/159] refactor(firm): FirmAllR messaging no works again! --- src/Handler/Firm.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index bbb69ad23..73302520b 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -60,7 +60,7 @@ data FirmAction = FirmActNotify deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) deriving anyclass (Universe, Finite) -nullaryPathPiece ''FirmAction $ camelToPathPiece' 3 +nullaryPathPiece ''FirmAction $ camelToPathPiece' 2 embedRenderMessage ''UniWorX ''FirmAction id data FirmActionData = FirmActNotifyData From 076dff2a60de1c066148131a93ba541f7777079e Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 24 Nov 2023 11:44:16 +0100 Subject: [PATCH 080/159] Revert "chore(nix): attempt to create alias for killall-uni0work" This reverts commit dc6079ec3b4eae32fe0e4325f958955edbcef965. --- src/Handler/Firm.hs | 117 +++++++++++++++----------------------------- 1 file changed, 40 insertions(+), 77 deletions(-) diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 73302520b..384db461f 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -56,7 +56,7 @@ postalEmailField = boolFieldCustom (SomeMessage MsgUtilPostal) (SomeMessage MsgU data FirmAction = FirmActNotify | FirmActResetSupervision - -- | FirmActAddSupervisors + | FirmActAddSupervisors deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) deriving anyclass (Universe, Finite) @@ -68,11 +68,11 @@ data FirmActionData = FirmActNotifyData { firmActResetKeepOldSupers :: Maybe Bool , firmActResetMutualSupervision :: Maybe Bool } - -- | FirmActAddSupervisorsData - -- { firmActAddSupervisorIds :: Set Text - -- , firmActAddSupervisorReroute :: Bool - -- , firmActAddSupervisorPostal :: Maybe Bool - -- } + | FirmActAddSupervisorsData + { firmActAddSupervisorIds :: Set Text + , firmActAddSupervisorReroute :: Bool + , firmActAddSupervisorPostal :: Maybe Bool + } deriving (Eq, Ord, Read, Show, Generic) firmActionMap :: [FirmAction] -> Map FirmAction (AForm Handler FirmActionData) @@ -82,10 +82,10 @@ firmActionMap acts = mconcat (mkAct <$> acts) mkAct FirmActResetSupervision = singletonMap FirmActResetSupervision $ FirmActResetSupervisionData <$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep) (Just $ Just False) <*> aopt checkBoxField (fslI MsgFirmActResetMutualSupervision) (Just $ Just True ) - -- mkAct FirmActAddSupervisors = singletonMap FirmActAddSupervisors $ FirmActAddSupervisorsData - -- <$> areq (textField & cfAnySeparatedSet) (fslI MsgTableIsDefaultSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) (Just mempty) - -- <*> areq checkBoxField (fslI MsgTableIsDefaultReroute ) (Just True) - -- <*> aopt postalEmailField (fslI MsgFormReqPostal & setTooltip MsgFormReqPostalTip) (Just Nothing) + mkAct FirmActAddSupervisors = singletonMap FirmActAddSupervisors $ FirmActAddSupervisorsData + <$> areq (textField & cfAnySeparatedSet) (fslI MsgTableIsDefaultSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing + <*> areq checkBoxField (fslI MsgTableIsDefaultReroute ) (Just True) + <*> aopt postalEmailField (fslI MsgFormReqPostal & setTooltip MsgFormReqPostalTip) Nothing firmActionForm :: [FirmAction] -> AForm Handler FirmActionData firmActionForm acts = multiActionA (firmActionMap acts) (fslI MsgTableAction) Nothing @@ -123,28 +123,28 @@ firmActionHandler route = flip formResult faHandler cuids <- traverse (encrypt . E.unValue) usrs :: Handler [CryptoUUIDUser] redirect (FirmsCommR $ fmap unCompanyKey fids, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids]) - -- faHandler (FirmActAddSupervisorsData{..}, Set.toList -> [cid]) = do - -- avsUsers :: Map Text (Maybe UserId) <- sequenceA $ Map.fromSet guessAvsUser firmActAddSupervisorIds - -- 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 - -- reloadKeepGetParams route - -- runDB $ do - -- putMany [UserCompany uid cid True firmActAddSupervisorReroute | uid <- usersFound] - -- whenIsJust firmActAddSupervisorPostal $ \prefPostal -> - -- updateWhere [UserId <-. usersFound] [UserPrefersPostal =. prefPostal] - -- addMessageI Info $ MsgASReqSetSupers (fromIntegral $ length usersFound) firmActAddSupervisorPostal - -- redirect route - -- faHandler _ = addMessageI Error MsgErrorUnknownFormAction + faHandler (FirmActAddSupervisorsData{..}, Set.toList -> [cid]) = do + avsUsers :: Map Text (Maybe UserId) <- sequenceA $ Map.fromSet guessAvsUser firmActAddSupervisorIds + 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 + reloadKeepGetParams route + runDB $ do + putMany [UserCompany uid cid True firmActAddSupervisorReroute | uid <- usersFound] + whenIsJust firmActAddSupervisorPostal $ \prefPostal -> + updateWhere [UserId <-. usersFound] [UserPrefersPostal =. prefPostal] + addMessageI Info $ MsgASReqSetSupers (fromIntegral $ length usersFound) firmActAddSupervisorPostal + redirect route + faHandler _ = addMessageI Error MsgErrorUnknownFormAction runFirmActionFormPost :: CompanyId -> Route UniWorX -> [FirmAction] -> Handler Widget @@ -554,25 +554,14 @@ mkFirmAllTable isAdmin uid = do , prismAForm (singletonFilter "company-postal" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterFirmExtern) ] dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } - acts :: Map FirmAction (AForm Handler FirmActionData) - acts = mconcat - [ singletonMap FirmActNotify $ pure FirmActNotifyData - , singletonMap FirmActResetSupervision $ FirmActResetSupervisionData - <$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep) (Just $ Just False) - <*> aopt checkBoxField (fslI MsgFirmActResetMutualSupervision) (Just $ Just True ) - ] - dbtParams = DBParamsForm { dbParamsFormMethod = POST , dbParamsFormAction = Nothing , dbParamsFormAttrs = [] , dbParamsFormSubmit = FormSubmit -- , dbParamsFormAdditional = renderAForm FormStandard $ (, mempty) . First . Just <$> firmActionForm [FirmActNotify, FirmActResetSupervision] - -- , dbParamsFormAdditional = renderAForm FormStandard $ (, mempty) . First . Just - -- <$> multiActionA (firmActionMap [FirmActNotify, FirmActResetSupervision]) (fslI MsgTableAction) Nothing - , dbParamsFormAdditional - = renderAForm FormStandard $ (, mempty) . First . Just - <$> multiActionA acts (fslI MsgTableAction) Nothing + , dbParamsFormAdditional = renderAForm FormStandard $ (, mempty) . First . Just + <$> multiActionA (firmActionMap [FirmActNotify, FirmActResetSupervision]) (fslI MsgTableAction) Nothing , dbParamsFormEvaluate = liftHandler . runFormPost , dbParamsFormResult = id , dbParamsFormIdent = def @@ -602,32 +591,7 @@ postFirmAllR = do uid <- requireAuthId isAdmin <- hasReadAccessTo AdminR (firmRes, firmTable) <- runDB $ mkFirmAllTable isAdmin uid -- filters to associated companies for non-admins - -- firmActionHandler FirmAllR firmRes - formResult firmRes $ \case - (_, fids) | null fids -> addMessageI Error MsgNoCompanySelected - - (FirmActResetSupervisionData{..}, fids) -> do - runDB $ do - delSupers <- if firmActResetKeepOldSupers == 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 (firmActResetMutualSupervision /= Just False) fids - addMessageI Info $ MsgFirmResetSupervision delSupers newSupers - reloadKeepGetParams FirmAllR -- reload to reflect changes - - (FirmActNotifyData , 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 fids - return $ usr E.^. UserId - cuids <- traverse (encrypt . E.unValue) usrs :: Handler [CryptoUUIDUser] - redirect (FirmsCommR $ fmap unCompanyKey fids, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids]) - + firmActionHandler FirmAllR firmRes siteLayoutMsg MsgMenuFirms $ do setTitleI MsgMenuFirms $(i18nWidgetFile "firm-all") @@ -818,8 +782,8 @@ mkFirmUserTable isAdmin cid = do acts = mconcat [ singletonMap FirmUserActNotify $ pure FirmUserActNotifyData , singletonMap FirmUserActResetSupervision $ FirmUserActResetSupervisionData - <$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep) (Just $ Just False) - -- <*> aopt checkBoxField (fslI MsgFirmActResetMutualSupervision) (Just $ Just True ) + <$> 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) ] @@ -848,7 +812,7 @@ mkFirmUserTable isAdmin cid = do let s = Map.keysSet . Map.filter id $ getDBFormResult (const False) m return (act, s) - -- resultDBTableValidator :: PSValidator (MForm Handler) (FormResult (First FirmActionData, DBFormResult CompanyId Bool FirmActionData)) + -- resultDBTableValidator :: PSValidator (MForm Handler) (FormResult (First FirmAllActionData, DBFormResult CompanyId Bool FirmAllActionData)) resultDBTableValidator = def & defaultSorting [SortAscBy "user-name"] over _1 postprocess <$> dbTable resultDBTableValidator resultDBTable @@ -917,8 +881,7 @@ postFirmUsersR fsh = do , formSubmit = FormSubmit , formAnchor = Just addFormAnchor } - formResult fucrRes $ \FirmUserChangeRequest{fucrPostalPref=fucrPPref, fucrPostalAddr=fucrPAddr} -> do - -- let fucrPAddr = canonical fucrPAddr' TODO + formResult fucrRes $ \FirmUserChangeRequest{fucrPostalPref=fucrPPref, fucrPostalAddr=(canonical -> fucrPAddr)} -> do when (isJust fucrPPref || isJust fucrPAddr) $ do let changes = foldMap (\pp -> [UserPrefersPostal E.=. E.val pp]) fucrPPref <> foldMap (\pa -> [UserPostAddress E.=. E.justVal pa]) fucrPAddr -- seems weird, but: Nothing means no change, and not delete address! @@ -1146,7 +1109,7 @@ postFirmSupersR fsh = do cuids <- traverse encrypt $ Set.toList uids :: Handler [CryptoUUIDUser] redirect (FirmCommR fsh, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids]) - formFirmAction <- runFirmActionFormPost cid (FirmSupersR fsh) [FirmActNotify, FirmActResetSupervision] -- TODO ,FirmActAddSupervisors] + formFirmAction <- runFirmActionFormPost cid (FirmSupersR fsh) [FirmActAddSupervisors, FirmActResetSupervision] ((asReqRes, asReqWgt), asReqEnctype) <- runFormPost . identifyForm FIDAddSupervisor $ makeAddSupervisorForm (Just def) let addSuperAnchor = "add-supervisors-form" :: Text From 0b00fffd2715a3908b5cc0055aada7c0fd2c1673 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 24 Nov 2023 11:45:07 +0100 Subject: [PATCH 081/159] chore(nix): change killall-uni2work to killuni2work for ease of use --- shell.nix | 6 +----- 1 file changed, 1 insertion(+), 5 deletions(-) diff --git a/shell.nix b/shell.nix index 9acbf8a78..42c65ae1f 100644 --- a/shell.nix +++ b/shell.nix @@ -223,7 +223,7 @@ let fi ''; - killallUni2work = pkgs.writeScriptBin "killall-uni2work" '' + killallUni2work = pkgs.writeScriptBin "killuni2work" '' #!${pkgs.zsh}/bin/zsh set -o pipefail @@ -257,10 +257,6 @@ let done ''; - environment.interactiveShellInit = '' - alias killuni2work='killall-uni2work' - ''; - diffRunning = pkgs.writeScriptBin "diff-running" '' #!${pkgs.zsh}/bin/zsh From fb41caceffbaed591e5bd95485b0f2e082c506cf Mon Sep 17 00:00:00 2001 From: David Mosbach Date: Fri, 24 Nov 2023 15:56:34 +0000 Subject: [PATCH 082/159] Resolve "Crontab appQualificationCheckHour funktioniert nicht" --- config/settings.yml | 5 +- .../categories/qualification/de-de-formal.msg | 4 +- .../categories/qualification/en-eu.msg | 10 ++-- src/Handler/LMS.hs | 7 ++- src/Jobs/Crontab.hs | 25 ++++---- src/Settings.hs | 6 +- templates/i18n/lms-all/de-de-formal.hamlet | 57 +++++++++++++++++++ templates/i18n/lms-all/en-eu.hamlet | 57 +++++++++++++++++++ templates/lms-all.hamlet | 18 ------ 9 files changed, 144 insertions(+), 45 deletions(-) create mode 100644 templates/i18n/lms-all/de-de-formal.hamlet create mode 100644 templates/i18n/lms-all/en-eu.hamlet delete mode 100644 templates/lms-all.hamlet diff --git a/config/settings.yml b/config/settings.yml index ecc94093d..b3c228991 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -90,8 +90,9 @@ synchronise-avs-users-interval: "_env:SYNCHRONISE_AVS_INTERVAL:21600" # alle 6 study-features-recache-relevance-within: 172800 study-features-recache-relevance-interval: 293 -# Enqueue at specified hour, dequeue 30min later -# qualification-check-hour: 3 +# Enqueue at specified hour, a few minutes later +job-lms-qualifications-enqueue-hour: 15 +job-lms-qualifications-dequeue-hour: 3 log-settings: detailed: "_env:DETAILED_LOGGING:false" diff --git a/messages/uniworx/categories/qualification/de-de-formal.msg b/messages/uniworx/categories/qualification/de-de-formal.msg index 113121211..1571d7ac1 100644 --- a/messages/uniworx/categories/qualification/de-de-formal.msg +++ b/messages/uniworx/categories/qualification/de-de-formal.msg @@ -138,7 +138,5 @@ LmsNotificationSend n@Int: E‑Learning Benachrichtigungen an #{n} #{pluralDE n LmsPinRenewal n@Int: E‑Learning Passwort ausgetauscht für #{n} #{pluralDE n "Prüfling" "Prüflinge"}. LmsActionFailed n@Int: Aktion nicht durchgeführt für #{n} #{pluralDE n "Person" "Personen"}, da diese derzeit nicht an einer Prüfung teilnehmen. LmsStarted: E‑Learning eröffnet -LmsAutomaticQueuing n@Natural: Die folgenden Funktionen werden normalerweise einmal pro Tag um #{show n} Uhr ausgeführt. -LmsManualQueuing: Die folgenden Funktionen sollten einmal pro Tag ausgeführt werden. BtnLmsEnqueue: Nutzer mit ablaufenden Qualifikationen zum E‑Learning anmelden und benachrichtigen -BtnLmsDequeue: Nutzer mit beendetem E‑Learning ggf. benachrichtigen und aufräumen +BtnLmsDequeue: Nutzer mit beendetem E‑Learning aufräumen und ggf. benachrichtigen diff --git a/messages/uniworx/categories/qualification/en-eu.msg b/messages/uniworx/categories/qualification/en-eu.msg index 1cab2c3dd..5d466355b 100644 --- a/messages/uniworx/categories/qualification/en-eu.msg +++ b/messages/uniworx/categories/qualification/en-eu.msg @@ -7,7 +7,7 @@ QualificationName: Qualification QualificationDescription: Description QualificationValidIndicator: Validity QualificationValidDuration: Validity period -QualificationAuditDuration: Audit log keept +QualificationAuditDuration: Audit log retention period QualificationAuditDurationTooltip n@Int: Optional period for deletion of e‑learning data. Note that the e‑learning server may delete its anonymised data earlier, at most #{n} days after closing. QualificationRefreshWithin: Refresh within QualificationRefreshWithinTooltip: Optional period before expiry to start e‑learning and send a notification by post or email. @@ -19,7 +19,7 @@ QualificationExpiryNotificationTooltip: Qualification holder are notfied upon in TableQualificationCountActive: Active TableQualificationCountActiveTooltip: Number of currently valid qualification holders TableQualificationCountTotal: Total -TableQualificationIsAvsLicence: AVS Driving License +TableQualificationIsAvsLicence: AVS driving license TableQualificationIsAvsLicenceTooltip: Under which name is this qualification synchronized with AVS, if any? Only applies to qualification holders having an AVS PersonID. TableQualificationSapExport: Sent to SAP TableQualificationSapExportTooltip: Is this qualification transmitted to SAP? Only applies to qualification holder having a Fraport AG personnel number. @@ -138,7 +138,5 @@ LmsNotificationSend n: E‑learning notifications will be sent to #{n} #{pluralE LmsPinRenewal n: E‑learning password replaced randomly for #{n} #{pluralENs n "examinee"}. LmsActionFailed n: No action for #{n} #{pluralENs n "person"}, since there was no ongoing examination. LmsStarted: E‑learning open since -LmsAutomaticQueuing n@Natural: The following functions are executed daily at #{show n} o'clock. -LmsManualQueuing: The following functions should be executed daily. -BtnLmsEnqueue: Enqueue users with expiring qualifications for e‑learning and notify them. -BtnLmsDequeue: Dequeue users with finished e‑learning and notify, if appropriate. +BtnLmsEnqueue: Enqueue users with expiring qualifications for e‑learning and notify them +BtnLmsDequeue: Dequeue users with finished e‑learning and notify failed users diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index 682e0c7f4..2c4f6e437 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -75,7 +75,7 @@ embedRenderMessage ''UniWorX ''ButtonManualLms id instance Button UniWorX ButtonManualLms where btnClasses BtnLmsEnqueue = [BCIsButton, BCPrimary] - btnClasses BtnLmsDequeue = [BCIsButton, BCDefault] + btnClasses BtnLmsDequeue = [BCIsButton, BCPrimary] getLmsSchoolR :: SchoolId -> Handler Html @@ -85,7 +85,8 @@ getLmsAllR, postLmsAllR :: Handler Html getLmsAllR = postLmsAllR postLmsAllR = do isAdmin <- hasReadAccessTo AdminR - mbQcheck <- getsYesod $ view _appQualificationCheckHour + mbJLQenqueue <- getsYesod $ view _appJobLmsQualificationsEnqueueHour + mbJLQdequeue <- getsYesod $ view _appJobLmsQualificationsDequeueHour -- TODO: Move this functionality elsewhere without the need for `isAdmin` mbBtnForm <- if not isAdmin then return Nothing else do ((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm ("buttons" :: Text) (buttonForm :: Form ButtonManualLms) @@ -109,7 +110,7 @@ postLmsAllR = do view _2 <$> mkLmsAllTable isAdmin lmsDeletionDays siteLayoutMsg MsgMenuLms $ do setTitleI MsgMenuLms - $(widgetFile "lms-all") + $(i18nWidgetFile "lms-all") type AllQualificationTableData = DBRow (Entity Qualification, Ex.Value Word64, Ex.Value Word64) resultAllQualification :: Lens' AllQualificationTableData Qualification diff --git a/src/Jobs/Crontab.hs b/src/Jobs/Crontab.hs index e352758ef..093c5cbde 100644 --- a/src/Jobs/Crontab.hs +++ b/src/Jobs/Crontab.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-2023 Sarah Vaupel , David Mosbach , Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -392,28 +392,31 @@ determineCrontab = execWriterT $ do -- , cronNotAfter = Right . CronTimestamp . utcToLocalTimeTZ appTZ $ addUTCTime appStudyFeaturesRecacheRelevanceInterval nextIntervalTime -- } - whenIsJust appQualificationCheckHour $ \hour -> tell $ HashMap.singleton + + whenIsJust appJobLmsQualificationsEnqueueHour $ \hour -> tell $ HashMap.singleton (JobCtlQueue JobLmsQualificationsEnqueue) Cron { cronInitial = CronAsap -- time after scheduling - , cronRepeat = CronRepeatScheduled $ cronCalendarAny { cronHour = cronMatchOne hour -- cronHour = CronMatchSome (impureNonNull $ Set.fromList [3,15] ) - , cronMinute = cronMatchOne 3 + , cronRepeat = CronRepeatScheduled $ cronCalendarAny { cronDayOfWeek = CronMatchSome . impureNonNull . Set.fromList $ [1..5] + , cronHour = cronMatchOne hour -- cronHour = CronMatchSome (impureNonNull $ Set.fromList [3,15] ) + , cronMinute = cronMatchOne 2 , cronSecond = cronMatchOne 27 } - , cronRateLimit = nominalDay / 2 -- minimal time between two executions, before the second job is skipped - , cronNotAfter = Left nominalDay -- maximal delay of an execution, before it is skipped entirely + , cronRateLimit = 600 -- minimal time between two executions, before the second job is skipped + , cronNotAfter = Right CronNotScheduled -- maximal delay of an execution, before it is skipped entirely } - whenIsJust appQualificationCheckHour $ \hour -> tell $ HashMap.singleton + whenIsJust appJobLmsQualificationsDequeueHour $ \hour -> tell $ HashMap.singleton (JobCtlQueue JobLmsQualificationsDequeue) Cron { cronInitial = CronAsap -- time after scheduling - , cronRepeat = CronRepeatScheduled $ cronCalendarAny { cronHour = cronMatchOne hour -- cronHour = CronMatchSome (impureNonNull $ Set.fromList [3,15] ) - , cronMinute = cronMatchOne 33 + , cronRepeat = CronRepeatScheduled $ cronCalendarAny { cronDayOfWeek = CronMatchSome . impureNonNull . Set.fromList $ [1..5] + , cronHour = cronMatchOne hour -- cronHour = CronMatchSome (impureNonNull $ Set.fromList [3,15] ) + , cronMinute = cronMatchOne 7 , cronSecond = cronMatchOne 27 } - , cronRateLimit = nominalDay / 2 -- minimal time between two executions, before the second job is skipped - , cronNotAfter = Left nominalDay -- maximal delay of an execution, before it is skipped entirely + , cronRateLimit = 600 -- minimal time between two executions, before the second job is skipped + , cronNotAfter = Right CronNotScheduled -- maximal delay of an execution, before it is skipped entirely } let diff --git a/src/Settings.hs b/src/Settings.hs index 0916f439f..e3fcc6105 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -233,7 +233,8 @@ data AppSettings = AppSettings , appStudyFeaturesRecacheRelevanceWithin :: Maybe NominalDiffTime , appStudyFeaturesRecacheRelevanceInterval :: NominalDiffTime - , appQualificationCheckHour :: Maybe Natural + , appJobLmsQualificationsEnqueueHour :: Maybe Natural + , appJobLmsQualificationsDequeueHour :: Maybe Natural , appFileSourceARCConf :: Maybe (ARCConf Int) , appFileSourcePrewarmConf :: Maybe PrewarmCacheConf @@ -785,7 +786,8 @@ instance FromJSON AppSettings where appStudyFeaturesRecacheRelevanceWithin <- o .:? "study-features-recache-relevance-within" appStudyFeaturesRecacheRelevanceInterval <- o .: "study-features-recache-relevance-interval" - appQualificationCheckHour <- o .:? "qualification-check-hour" + appJobLmsQualificationsEnqueueHour <- o .:? "job-lms-qualifications-enqueue-hour" + appJobLmsQualificationsDequeueHour <- o .:? "job-lms-qualifications-dequeue-hour" appFileSourceARCConf <- assertM isValidARCConf <$> o .:? "file-source-arc" diff --git a/templates/i18n/lms-all/de-de-formal.hamlet b/templates/i18n/lms-all/de-de-formal.hamlet new file mode 100644 index 000000000..c93ddfb58 --- /dev/null +++ b/templates/i18n/lms-all/de-de-formal.hamlet @@ -0,0 +1,57 @@ +$newline never + +$# SPDX-FileCopyrightText: 2022 Steffen Jost +$# +$# SPDX-License-Identifier: AGPL-3.0-or-later + +
                                        + ^{lmsTable} + +$maybe btnForm <- mbBtnForm +
                                        +

                                        + E‑Learning Starten und Aufräumen +

                                        + Die folgenden Funktionen sollten normalerweise mindestens einmal pro Tag ausgeführt werden, # + können aber auch bedenkenlos mehrfach pro Tag ausgeführt werden. # + + Die erste Funktion benachrichtigt Inhaber von ablaufenden Lizenzen und # + lädt diese ggf. zum E‑Learning ein. # + + Die zweite Funktion benachrichtigt Inhaber von bereits abgelaufenen Lizenzen und # + räumte beendete E‑Learning Teilnehmer auf, falls der jeweilige Aufbewahrungszeitraum abgelaufen ist. # + + Ein Abgleich mit dem Ausweisverwaltungssystem findet dadurch jedoch noch nicht statt. # + +

                                        +

                                        + Automatische Ausführung + +
                                        +
                                        + Start E‑Learning: # +
                                        +   + $maybe hour <- mbJLQenqueue + jeden Wochentag kurz nach # + + #{hour} Uhr + $nothing + + keine automatische Ausführung +
                                        + Sperren/Aufräumen: # +
                                        +   + $maybe hour <- mbJLQdequeue + jeden Wochentag kurz nach # + + #{hour} Uhr + $nothing + + keine automatische Ausführung +

                                        +

                                        + Manuelle Ausführung + + ^{btnForm} \ No newline at end of file diff --git a/templates/i18n/lms-all/en-eu.hamlet b/templates/i18n/lms-all/en-eu.hamlet new file mode 100644 index 000000000..69aa8df82 --- /dev/null +++ b/templates/i18n/lms-all/en-eu.hamlet @@ -0,0 +1,57 @@ +$newline never + +$# SPDX-FileCopyrightText: 2022 Steffen Jost +$# +$# SPDX-License-Identifier: AGPL-3.0-or-later + +
                                        + ^{lmsTable} + +$maybe btnForm <- mbBtnForm +
                                        +

                                        + Starting and cleaning e‑learning +

                                        + The following functions should be executed at least once per day, # + but a repeated execution is harmless. # + + The first function notifies holders of expiring licences and # + enlists them for e‑learning, if appropriate for the respective qualification. # + + The second function notifies holders of already expired licences and # + cleans finished e‑learnings after their respective rentention periods. # + + Note that these functions do not trigger an AVS-synchronisation. # + +

                                        +

                                        + Automatic execution + +
                                        +
                                        + Start e‑learning: # +
                                        +   + $maybe hour <- mbJLQenqueue + every weekday shortly after # + + #{hour} o'clock + $nothing + + no automatic execution +
                                        + Block/Clean: # +
                                        +   + $maybe hour <- mbJLQdequeue + every weekday shortly after # + + #{hour} o'clock + $nothing + + no automatic execution +

                                        +

                                        + Manual execution + + ^{btnForm} \ No newline at end of file diff --git a/templates/lms-all.hamlet b/templates/lms-all.hamlet deleted file mode 100644 index b4e5077fd..000000000 --- a/templates/lms-all.hamlet +++ /dev/null @@ -1,18 +0,0 @@ -$newline never - -$# SPDX-FileCopyrightText: 2022 Steffen Jost -$# -$# SPDX-License-Identifier: AGPL-3.0-or-later - -

                                        - ^{lmsTable} - -$maybe btnForm <- mbBtnForm -

                                        -

                                        - $maybe qcheck <- mbQcheck - _{MsgLmsAutomaticQueuing qcheck} - $nothing - _{MsgLmsManualQueuing} -

                                        - ^{btnForm} \ No newline at end of file From 2636c9d41aa50726f05c6952f45ed7b08a3b3507 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 24 Nov 2023 17:31:34 +0100 Subject: [PATCH 083/159] refactor(firm): clean firm interface - multiactions working - several code redundancies removed --- .../uniworx/categories/firm/de-de-formal.msg | 24 +- messages/uniworx/categories/firm/en-eu.msg | 22 +- src/Handler/Firm.hs | 422 ++++++++---------- src/Utils.hs | 7 + templates/firm-contact-info.hamlet | 8 +- templates/firm-users.hamlet | 8 +- .../i18n/firm-supervisors/de-de-formal.hamlet | 8 +- templates/i18n/firm-supervisors/en-eu.hamlet | 7 +- 8 files changed, 234 insertions(+), 272 deletions(-) diff --git a/messages/uniworx/categories/firm/de-de-formal.msg b/messages/uniworx/categories/firm/de-de-formal.msg index d5cda6037..3158130c1 100644 --- a/messages/uniworx/categories/firm/de-de-formal.msg +++ b/messages/uniworx/categories/firm/de-de-formal.msg @@ -9,18 +9,23 @@ FirmEmail: Allgemeine Email FirmAddress: Postanschrift FirmDefaultPreferenceInfo: Diese Voreinstellungen gelten nur für neue Firmenangehörige FirmAction: Firmenweite Aktion +FirmActionInfo: Betrifft alle Firmenangehörigen. FirmActNotify: Mitteilung versenden FirmActResetSupervision: Ansprechpartner für alle Firmenangehörigen zurücksetzen FirmActResetSuperKeep: Bisherige Ansprechpartner der Firmenangehörigen zusätzlich beibehalten? FirmActResetMutualSupervision: Ansprechpartner beaufsichtigen sich gegenseitig -FirmActAddSupervisors: Ansprechpartner hinzufügen -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 +FirmActAddSupersvisors: Ansprechpartner hinzufügen +FirmActAddSupersEmpty: Es konnten keine Ansprechpartner hinzugefügt werden +FirmActAddSupersSet n@Int64 postal@(Maybe Bool): #{n} Standardansprechpartner eingetragen #{maybeBoolMessage postal "" "und auf Briefversand geschaltet" "und Benachrichtigungen per Email gesetzt"}, aber nicht nicht aktiviert. +RemoveSupervisors ndef@Int64 nact@Int64: #{ndef} Standard Ansprechpartner entfernt#{bool ", aber noch nicht deaktiviert" (", " <> tshow nact <> " aktive Ansprechpartnerbeziehungen gelöscht") (nact > 0)} +FirmActChangeContactUser: Kontaktinformationen von Firmenangehörigen ändern +FirmActChangeContactFirm: Kontaktinformationen der Firma ändern +FirmActChangeContactFirmInfo: Firmenkontaktinformationen werden nur für neue Firmenangehörige verwendet, für die sonst keine Kontaktinformationen vorliegen. +FirmActChangeContactFirmResult: Firmenkontaktinformationen geändert. Betrifft nur neue Firmenangehörige ohne eigene Kontaktinformationen FirmUserActNotify: Mitteilung versenden FirmUserActResetSupervision: Ansprechpartner auf Firmenstandard zurücksetzen FirmUserActMkSuper: Zum Firmenansprechpartner ernennen +FirmUserActChangeContact: Kontaktinformationen für ausgewählte Firmenangehörige ändern 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 @@ -37,12 +42,9 @@ 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. +NoCompanySelected: Bitte wählen Sie mindestens eine Firma aus. TableIsDefaultSupervisor: Standardansprechpartner TableIsDefaultReroute: Standardumleitung -FormReqPostal: Benachrichtigungseinstellung -FormReqPostalTip: 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. -RemoveSupervisors ndef@Int64 nact@Int64: #{ndef} Standard Ansprechpartner entfernt#{bool ", aber noch nicht deaktiviert" (", " <> tshow nact <> " aktive Ansprechpartnerbeziehungen gelöscht") (nact > 0)} +FormFieldPostal: Benachrichtigungseinstellung +FormFieldPostalTip: Gilt für alle Benachrichtigungen an diese Person, nicht nur für Umleitungen an diesen Ansprechpartner FirmUserChanges n@Int64: Benachrichtigungseinstellung für #{n} Firmenangehörige wurden geändert \ 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 953055b25..b73afc808 100644 --- a/messages/uniworx/categories/firm/en-eu.msg +++ b/messages/uniworx/categories/firm/en-eu.msg @@ -9,18 +9,23 @@ FirmEmail: General company email FirmAddress: Postal address FirmDefaultPreferenceInfo: Default setting for new company associates only FirmAction: Companywide action +FirmActionInfo: Affects alle company associates. FirmActNotify: Send message FirmActResetSupervision: Reset supervisors for all company associates FirmActResetSuperKeep: Additionally keep existing supervisors of company associates? FirmActResetMutualSupervision: Supervisors supervise each other -FirmActAddSupervisors: Add supervisors -FirmAllActNotify: Send message -FirmAllActResetSupervision: Reset supervisors for all company associates -FirmAllActResetSuperKeep: Additionally keep existing supervisors of company associates? -FirmAllActResetMutualSupervision: Supervisors supervise each other +FirmActAddSupersvisors: Add supervisors +FirmActAddSupersEmpty: No supervisors added +FirmActAddSupersSet n postal: #{n} default company supervisors set #{maybeBoolMessage postal "" "and switched to postal notifications" "and switched to email notifications"}, but not yet activated. +RemoveSupervisors ndef nact: #{ndef} default supervisors removed#{bool ", but not yet deactivated" (" and " <> tshow nact <> " active supervisons terminated") (nact > 0)} +FirmActChangeContactUser: Change contact data for company associates +FirmActChangeContactFirm: Change company contact data +FirmActChangeContactFirmInfo: The company contact data is only used for new company associates that would habe no contact information of their own otherwise. +FirmActChangeContactFirmResult: Company contact data changed, affecting future company associates without contact information only FirmUserActNotify: Send message FirmUserActResetSupervision: Reset supervisors to company default FirmResetSupervision rem set: #{tshow set} supervisors set#{bool mempty (", " <> tshow rem <> " deleted before") (rem > 0)} +FirmUserActChangeContact: Change contact data for selected company associates FirmUserActMkSuper: Mark as company supervisor FirmSuperActNotify: Send message FirmSuperActRMSuperDef: Remove as default supervisor @@ -40,9 +45,6 @@ FirmEmployeeOf fsh@CompanyShorthand: #{fsh} associated users NoCompanySelected: Select at least one company, please. TableIsDefaultSupervisor: Default supervisor TableIsDefaultReroute: Default reroute -FormReqPostal: Notification type -FormReqPostalTip: 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. -RemoveSupervisors ndef nact: #{ndef} default supervisors removed#{bool ", but not yet deactivated" (" and " <> tshow nact <> " active supervisons terminated") (nact > 0)} +FormFieldPostal: Notification type +FormFieldPostalTip: Affects all notifications to this person, not just reroutes to this supervisor FirmUserChanges n: Notification settings changed for #{n} company associates \ No newline at end of file diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 384db461f..9ed737280 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 -Wno-unused-binds #-} -- TODO: remove me, for debugging only +{-# OPTIONS -Wno-unused-top-binds #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- needed for HasEntity instances {-# LANGUAGE TypeApplications #-} @@ -32,7 +32,7 @@ import qualified Data.CaseInsensitive as CI 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) +import qualified Database.Esqueleto.Legacy as EL (on) import qualified Database.Esqueleto.PostgreSQL as E import qualified Database.Esqueleto.Utils as E import Database.Esqueleto.Utils.TH @@ -42,11 +42,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 +-- decryptUser :: (MonadHandler m, HandlerSite m ~ UniWorX) => CryptoUUIDUser -> m UserId +-- decryptUser = decrypt encryptUser :: (MonadHandler m, HandlerSite m ~ UniWorX) => UserId -> m CryptoUUIDUser -encryptUser = encrypt +encryptUser = encrypt postalEmailField :: (MonadHandler m, HandlerSite m ~ UniWorX) => Field m Bool postalEmailField = boolFieldCustom (SomeMessage MsgUtilPostal) (SomeMessage MsgUtilEMail) $ Just $ SomeMessage MsgUtilUnchanged @@ -56,7 +56,9 @@ postalEmailField = boolFieldCustom (SomeMessage MsgUtilPostal) (SomeMessage MsgU data FirmAction = FirmActNotify | FirmActResetSupervision - | FirmActAddSupervisors + | FirmActAddSupersvisors + | FirmActChangeContactFirm + | FirmActChangeContactUser deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) deriving anyclass (Universe, Finite) @@ -64,41 +66,54 @@ nullaryPathPiece ''FirmAction $ camelToPathPiece' 2 embedRenderMessage ''UniWorX ''FirmAction id data FirmActionData = FirmActNotifyData - | FirmActResetSupervisionData - { firmActResetKeepOldSupers :: Maybe Bool - , firmActResetMutualSupervision :: Maybe Bool + | FirmActResetSupervisionData + { firmActResetKeepOldSupers :: Maybe Bool + , firmActResetMutualSupervision :: Maybe Bool } - | FirmActAddSupervisorsData - { firmActAddSupervisorIds :: Set Text - , firmActAddSupervisorReroute :: Bool - , firmActAddSupervisorPostal :: Maybe Bool + | FirmActAddSupersvisorsData + { firmActAddSupervisorIds :: Set Text + , firmActAddSupervisorReroute :: Bool + , firmActAddSupervisorPostal :: Maybe Bool + } + | FirmActChangeContactFirmData + { firmActCCFPostalAddr :: Maybe StoredMarkup + , firmActCCFEmail :: Maybe UserEmail + , firmActCCFPostalPref :: Maybe Bool + } + | FirmActChangeContactUserData + { firmActCCUPostalAddr :: Maybe StoredMarkup + , firmActCCUPostalPref :: Maybe Bool } deriving (Eq, Ord, Read, Show, Generic) -firmActionMap :: [FirmAction] -> Map FirmAction (AForm Handler FirmActionData) -firmActionMap acts = mconcat (mkAct <$> acts) +firmActionMap :: _ -> [FirmAction] -> Map FirmAction (AForm Handler FirmActionData) +firmActionMap mr acts = mconcat (mkAct <$> acts) where mkAct FirmActNotify = singletonMap FirmActNotify $ pure FirmActNotifyData mkAct FirmActResetSupervision = singletonMap FirmActResetSupervision $ FirmActResetSupervisionData - <$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep) (Just $ Just False) - <*> aopt checkBoxField (fslI MsgFirmActResetMutualSupervision) (Just $ Just True ) - mkAct FirmActAddSupervisors = singletonMap FirmActAddSupervisors $ FirmActAddSupervisorsData - <$> areq (textField & cfAnySeparatedSet) (fslI MsgTableIsDefaultSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing - <*> areq checkBoxField (fslI MsgTableIsDefaultReroute ) (Just True) - <*> aopt postalEmailField (fslI MsgFormReqPostal & setTooltip MsgFormReqPostalTip) Nothing + <$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep) (Just $ Just False) + <*> aopt checkBoxField (fslI MsgFirmActResetMutualSupervision) (Just $ Just True ) + mkAct FirmActAddSupersvisors = singletonMap FirmActAddSupersvisors $ FirmActAddSupersvisorsData + <$> areq (textField & cfAnySeparatedSet) (fslI MsgTableIsDefaultSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing + <*> areq checkBoxField (fslI MsgTableIsDefaultReroute ) (Just True) + <*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip) Nothing + mkAct FirmActChangeContactFirm = singletonMap FirmActChangeContactFirm $ FirmActChangeContactFirmData + <$> aopt htmlField (fslI MsgPostAddress & setTooltip MsgPostAddressTip) Nothing + <*> aopt (emailField & cfStrip & cfCI) (fslI MsgUserDisplayEmail) Nothing + <*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip) Nothing + <* aformMessage (Message Info (toHtml $ mr MsgFirmActChangeContactFirmInfo) (Just IconNotificationNonactive)) + mkAct FirmActChangeContactUser = singletonMap FirmActChangeContactUser $ FirmActChangeContactUserData + <$> aopt htmlField (fslI MsgPostAddress & setTooltip MsgPostAddressTip) Nothing + <*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip) Nothing -firmActionForm :: [FirmAction] -> AForm Handler FirmActionData -firmActionForm acts = multiActionA (firmActionMap acts) (fslI MsgTableAction) Nothing +firmActionForm :: _ -> [FirmAction] -> AForm Handler FirmActionData +firmActionForm mr acts = multiActionA (firmActionMap mr acts) (fslI MsgTableAction) Nothing - -makeFirmActionForm :: CompanyId -> [FirmAction] -> Form (FirmActionData, Set CompanyId) -makeFirmActionForm cid acts html = flip (renderAForm FormStandard) html $ (,Set.singleton cid) <$> firmActionForm acts - --- makeFirmActionTableForm :: Monoid t => [FirmAction] -> Text.Blaze.Internal.Markup -> Control.Monad.Trans.RWS.Lazy.RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints Handler (FormResult (First FirmActionData, t), WidgetFor UniWorX ()) --- makeFirmActionTableForm acts = renderAForm FormStandard $ (, mempty) . First . Just <$> firmActionForm acts +makeFirmActionForm :: CompanyId -> _ -> [FirmAction] -> Form (FirmActionData, Set CompanyId) +makeFirmActionForm cid mr acts html = flip (renderAForm FormStandard) html $ (,Set.singleton cid) <$> firmActionForm mr acts firmActionHandler :: Route UniWorX -> FormResult (FirmActionData, Set CompanyId) -> Handler () -firmActionHandler route = flip formResult faHandler +firmActionHandler route = flip formResult faHandler where faHandler (_,fids) | null fids = addMessageI Error MsgNoCompanySelected faHandler (FirmActResetSupervisionData{..}, fids) = do @@ -109,10 +124,10 @@ firmActionHandler route = flip formResult faHandler 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 (firmActResetMutualSupervision /= Just False) fids - addMessageI Info $ MsgFirmResetSupervision delSupers newSupers + E.&&. usr E.^. UserCompanyUser E.==. spr E.^. UserSupervisorUser + else return 0 + newSupers <- addDefaultSupervisorsAll (firmActResetMutualSupervision /= Just False) fids + addMessageI Success $ MsgFirmResetSupervision delSupers newSupers reloadKeepGetParams route -- reload to reflect changes faHandler (FirmActNotifyData, Set.toList -> fids) = do @@ -123,7 +138,7 @@ firmActionHandler route = flip formResult faHandler cuids <- traverse (encrypt . E.unValue) usrs :: Handler [CryptoUUIDUser] redirect (FirmsCommR $ fmap unCompanyKey fids, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids]) - faHandler (FirmActAddSupervisorsData{..}, Set.toList -> [cid]) = do + faHandler (FirmActAddSupersvisorsData{..}, Set.toList -> [cid]) = do avsUsers :: Map Text (Maybe UserId) <- sequenceA $ Map.fromSet guessAvsUser firmActAddSupervisorIds let (usersFound', usersNotFound) = partition (is _Just . view _2) $ Map.toList avsUsers usersFound = mapMaybe snd usersFound' @@ -136,24 +151,51 @@ firmActionHandler route = flip formResult faHandler |] in addMessageModal Error (i18n . MsgCourseParticipantsRegisterNotFoundInAvs $ length usersNotFound) (Right msgContent) when (null usersFound) $ do - addMessageI Warning MsgASReqEmpty + addMessageI Warning MsgFirmActAddSupersEmpty reloadKeepGetParams route runDB $ do putMany [UserCompany uid cid True firmActAddSupervisorReroute | uid <- usersFound] whenIsJust firmActAddSupervisorPostal $ \prefPostal -> updateWhere [UserId <-. usersFound] [UserPrefersPostal =. prefPostal] - addMessageI Info $ MsgASReqSetSupers (fromIntegral $ length usersFound) firmActAddSupervisorPostal + addMessageI Success $ MsgFirmActAddSupersSet (fromIntegral $ length usersFound) firmActAddSupervisorPostal redirect route + + faHandler (FirmActChangeContactFirmData{..}, Set.toList -> [cid]) = + let changes = catMaybes + [ (CompanyPostAddress =.) . Just <$> canonical firmActCCFPostalAddr + , (CompanyEmail =.) . Just <$> canonical firmActCCFEmail + , (CompanyPrefersPostal =.) <$> firmActCCFPostalPref + ] + in unless (null changes) $ do + runDB $ updateBy (UniqueCompanyShorthand $ unCompanyKey cid) changes + addMessageI Success MsgFirmActChangeContactFirmResult + reloadKeepGetParams route + + faHandler (FirmActChangeContactUserData{..}, Set.toList -> [cid]) = + let changes = catMaybes + [ (UserPostAddress E.=.) . E.justVal <$> canonical firmActCCUPostalAddr -- note that Nothing means no change and not delete address! + , (UserPrefersPostal E.=.) . E.val <$> firmActCCUPostalPref + ] + in unless (null changes) $ do + nrChanged <- runDB $ E.updateCount $ \usr -> do + E.set usr changes + E.where_ $ E.exists $ do + usrCmpy <- E.from $ E.table @UserCompany + E.where_ $ usrCmpy E.^. UserCompanyCompany E.==. E.val cid + E.&&. usrCmpy E.^. UserCompanyUser E.==. usr E.^. UserId + addMessageI Success $ MsgFirmUserChanges nrChanged + reloadKeepGetParams route -- reload to reflect changes + faHandler _ = addMessageI Error MsgErrorUnknownFormAction runFirmActionFormPost :: CompanyId -> Route UniWorX -> [FirmAction] -> Handler Widget -runFirmActionFormPost cid route acts = do - -- ((faRes, faWgt), faEnctype) <- runFormPost . identifyForm FIDFirmAction $ makeFirmActionForm cid acts - ((faRes, faWgt), faEnctype) <- runFormPost $ makeFirmActionForm cid acts +runFirmActionFormPost cid route acts = do + mr <- getMessageRender + ((faRes, faWgt), faEnctype) <- runFormPost . identifyForm FIDFirmAction $ makeFirmActionForm cid mr acts let faAnchor = "firm-action-form" :: Text faRoute = route :#: faAnchor - faForm = wrapForm faWgt FormSettings + faForm = wrapForm faWgt FormSettings { formMethod = POST , formAction = Just . SomeRoute $ faRoute , formEncoding = faEnctype @@ -162,14 +204,17 @@ runFirmActionFormPost cid route acts = do , formAnchor = Just faAnchor } firmActionHandler route faRes - return [whamlet| + return [whamlet|

                                        _{MsgFirmAction} -
                                        - ^{faForm} +
                                        +

                                        + _{MsgFirmActionInfo} +

                                        + ^{faForm} |] - + --------------------------- -- Firm specific utilities @@ -190,9 +235,9 @@ resetSupervisors cid employees = do -- 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 +addDefaultSupervisors cid employees = do E.insertSelectWithConflictCount UniqueUserSupervisor - (do + (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 @@ -205,12 +250,12 @@ addDefaultSupervisors cid employees = do -- 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 +addDefaultSupervisorsAll mutualSupervision cids = do E.insertSelectWithConflictCount UniqueUserSupervisor - (do + (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 ] + 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 @@ -264,7 +309,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 @@ -272,7 +317,7 @@ firmCountEmployeeRerouted = E.subSelectCount . fromUserCompany (Just fltr) firmCountEmployeeRerPost :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) firmCountEmployeeRerPost = E.subSelectCount . fromUserCompany (Just fltr) - where + where fltr usrc = E.exists $ do (usrSuper :& usr) <- E.from $ E.table @UserSupervisor @@ -330,7 +375,7 @@ firmCountUserSupervisors :: E.SqlExpr (Entity UserCompany) -> E.SqlExpr (E.Value 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 @@ -367,7 +412,7 @@ postFirmR fsh = do siteLayoutMsg (SomeMessage fsh) $ do setTitle $ citext2Html fsh [whamlet| -

                                        PROVISORISCHE DEBUG SEITE +

                                        PROVISORISCHE DEBUG SEITE

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

                                        #{length csuper} Company Default Supervisors (non-foreign only) @@ -400,21 +445,6 @@ postFirmR fsh = do ----------------------- -- 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 - { firmAllActResetKeepOldSupers :: Maybe Bool - , firmAllActResetMutualSupervision :: Maybe Bool - } - deriving (Eq, Ord, Read, Show, Generic) - -- just in case for future extensions type AllCompanyTableExpr = E.SqlExpr (Entity Company) queryAllCompany :: AllCompanyTableExpr -> E.SqlExpr (Entity Company) @@ -440,6 +470,7 @@ resultAllCompanyDefaultReroutes = _dbrOutput . _4 . _unValue mkFirmAllTable :: Bool -> UserId -> DB (FormResult (FirmActionData, Set CompanyId), Widget) mkFirmAllTable isAdmin uid = do -- now <- liftIO getCurrentTime + mr <- getMessageRender let resultDBTable = DBTable{..} where @@ -448,7 +479,7 @@ 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 E.&&. usrCmpy E.^. UserCompanySupervisor) - E.||. E.exists (do + E.||. E.exists (do usrSpr <- E.from $ E.table @UserSupervisor E.where_ $ usrSpr E.^. UserSupervisorUser E.==. usrCmpy E.^. UserCompanyUser E.&&. usrSpr E.^. UserSupervisorSupervisor E.==. E.val uid @@ -476,12 +507,12 @@ 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 MsgTableCompanyNrSupersDefault) $ \row -> + , sortable (Just "supervisors") (i18nCell MsgTableCompanyNrSupersDefault) $ \row -> 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 "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 @@ -508,14 +539,14 @@ mkFirmAllTable isAdmin uid = do , 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.on` (\(usr :& usrCmp) -> usr E.^. UserId E.==. usrCmp E.^. UserCompanyUser) 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) ) ) - , single ("foreign-supervisor", FilterColumn $ \row (getLast -> criterion) -> + , single ("foreign-supervisor", FilterColumn $ \row (getLast -> criterion) -> -- let checkSuper = do -- expensive -- usrSpr <- E.from $ E.table @UserSupervisor -- E.where_ $ E.notExists (do @@ -546,7 +577,7 @@ mkFirmAllTable isAdmin uid = do ) , single ("company-postal", FilterColumn $ E.mkExactFilterLast $ views (to queryAllCompany) (E.isJust . (E.^. CompanyPostAddress))) ] - dbtFilterUI mPrev = mconcat + dbtFilterUI mPrev = mconcat [ fltrCompanyNameUI mPrev , prismAForm (singletonFilter "company-number") mPrev $ aopt textField (fslI MsgTableCompanyNo) , prismAForm (singletonFilter "is-supervisor") mPrev $ aopt textField (fslI MsgTableSupervisor) @@ -559,9 +590,7 @@ mkFirmAllTable isAdmin uid = do , dbParamsFormAction = Nothing , dbParamsFormAttrs = [] , dbParamsFormSubmit = FormSubmit - -- , dbParamsFormAdditional = renderAForm FormStandard $ (, mempty) . First . Just <$> firmActionForm [FirmActNotify, FirmActResetSupervision] - , dbParamsFormAdditional = renderAForm FormStandard $ (, mempty) . First . Just - <$> multiActionA (firmActionMap [FirmActNotify, FirmActResetSupervision]) (fslI MsgTableAction) Nothing + , dbParamsFormAdditional = renderAForm FormStandard $ (, mempty) . First . Just <$> firmActionForm mr [FirmActNotify, FirmActResetSupervision] , dbParamsFormEvaluate = liftHandler . runFormPost , dbParamsFormResult = id , dbParamsFormIdent = def @@ -600,28 +629,11 @@ postFirmAllR = do ----------------------- -- Firm Users Table -data FirmUserChangeRequest = FirmUserChangeRequest - { fucrPostalPref :: Maybe Bool - , fucrPostalAddr :: Maybe StoredMarkup - } - deriving (Eq, Ord, Show, Generic) -instance Default FirmUserChangeRequest where - def = FirmUserChangeRequest - { fucrPostalPref = Nothing - , fucrPostalAddr = Nothing - } - -makeFirmUserChangeRequestForm :: Maybe FirmUserChangeRequest -> Form FirmUserChangeRequest -makeFirmUserChangeRequestForm template html = do - flip (renderAForm FormStandard) html $ FirmUserChangeRequest - <$> aopt postalEmailField (fslI MsgFormReqPostal & setTooltip MsgFormReqPostalTip) (fucrPostalPref <$> template) - <*> aopt htmlField (fslI MsgPostAddress & setTooltip MsgPostAddressTip) (fucrPostalAddr <$> template) - - -data FirmUserAction = FirmUserActNotify +data FirmUserAction = FirmUserActNotify | FirmUserActResetSupervision | FirmUserActMkSuper + | FirmUserActChangeContact deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) deriving anyclass (Universe, Finite) @@ -630,12 +642,15 @@ embedRenderMessage ''UniWorX ''FirmUserAction id data FirmUserActionData = FirmUserActNotifyData | FirmUserActResetSupervisionData - { firmUserActResetKeepOldSupers :: Maybe Bool + { firmUserActResetKeepOldSupers :: Maybe Bool -- , firmUserActResetMutualSupervision :: Maybe Bool } | FirmUserActMkSuperData { firmUserActMkSuperReroute :: Maybe Bool } - + | FirmUserActChangeContactData + { firmUserActPostalAddr :: Maybe StoredMarkup + , firmUserActPostalPref :: Maybe Bool + } deriving (Eq, Ord, Show, Generic) type UserCompanyTableExpr = E.SqlExpr (Entity User) `E.InnerJoin` E.SqlExpr (Entity UserCompany) @@ -649,7 +664,7 @@ 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 +resultUserUser = _dbrOutput . _1 resultUserUserCompany :: Lens' UserCompanyTableData (Entity UserCompany) resultUserUserCompany = _dbrOutput . _2 @@ -660,10 +675,10 @@ resultUserCompanySupervisors = _dbrOutput . _3 . _unValue resultUserCompanyReroutes :: Lens' UserCompanyTableData Word64 resultUserCompanyReroutes = _dbrOutput . _4 . _unValue -instance HasEntity UserCompanyTableData User where +instance HasEntity UserCompanyTableData User where hasEntity = resultUserUser -instance HasUser UserCompanyTableData where +instance HasUser UserCompanyTableData where hasUser = resultUserUser . _entityVal @@ -675,7 +690,7 @@ mkFirmUserTable isAdmin cid = do return Option{ optionDisplay = udn, optionInternalValue = uid, optionExternalValue = uuid } procOptions = fmap mkOptionList . traverse mkSprOption - rawSupers <- E.select $ do + 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) @@ -694,7 +709,7 @@ mkFirmUserTable isAdmin cid = do dbtRowKey = queryUserUser >>> (E.^. UserId) dbtProj = dbtProjId dbtColonnade = formColonnade $ mconcat - [ guardMonoid isAdmin $ dbSelect (applying _2) id (return . view (resultUserUser . _entityKey)) + [ 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 @@ -715,16 +730,16 @@ mkFirmUserTable isAdmin cid = do ] dbtFilter = mconcat [ single $ fltrUserNameEmail queryUserUser - , singletonMap "has-supervisor" $ FilterColumn $ \row (getLast -> criterion) -> - let checkSuper = do + , 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 + , 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 @@ -736,8 +751,8 @@ 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 + , 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 @@ -750,20 +765,20 @@ mkFirmUserTable isAdmin cid = do Just True -> E.exists checkSuper Just False -> E.notExists checkSuper , singletonMap "supervisor-is" $ FilterColumn $ \row (getLast -> criterion) -> - case criterion of - Just uid -> do + case criterion of + Just uid -> do -- uid <- decryptUser uuid - E.exists $ do + 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 + case criteria of _ | Set.null criteria -> E.true | otherwise -> do -- uids <- traverse decryptUser criteria - E.exists $ do + 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 @@ -771,7 +786,7 @@ mkFirmUserTable isAdmin cid = do -- superField = selectField $ ???? dbtFilterUI mPrev = mconcat [ fltrUserNameEmailHdrUI MsgTableCompanyUser mPrev - , prismAForm (singletonFilter "supervisor-is" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift supervisorField) (fslI MsgFilterSupervisor) + , prismAForm (singletonFilter "supervisor-is" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift supervisorField) (fslI MsgFilterSupervisor) , prismAForm (multiFilter "supervisors-are" . maybePrism monoPathPieces) 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) @@ -782,10 +797,13 @@ mkFirmUserTable isAdmin cid = do acts = mconcat [ singletonMap FirmUserActNotify $ pure FirmUserActNotifyData , singletonMap FirmUserActResetSupervision $ FirmUserActResetSupervisionData - <$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmAllActResetSuperKeep) (Just $ Just False) - -- <*> aopt checkBoxField (fslI MsgFirmAllActResetMutualSupervision) (Just $ Just True ) + <$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep) (Just $ Just False) + -- <*> aopt checkBoxField (fslI MsgFirmActResetMutualSupervision) (Just $ Just True ) , singletonMap FirmUserActMkSuper $ FirmUserActMkSuperData <$> aopt checkBoxField (fslI MsgTableIsDefaultReroute) (Just $ Just True) + , singletonMap FirmUserActChangeContact $ FirmUserActChangeContactData + <$> aopt htmlField (fslI MsgPostAddress & setTooltip MsgPostAddressTip) Nothing + <*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip) Nothing ] dbtParams = DBParamsForm { dbParamsFormMethod = POST @@ -812,7 +830,7 @@ mkFirmUserTable isAdmin cid = do 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 :: PSValidator (MForm Handler) (FormResult (First FirmActionData, DBFormResult CompanyId Bool FirmActionData)) resultDBTableValidator = def & defaultSorting [SortAscBy "user-name"] over _1 postprocess <$> dbTable resultDBTableValidator resultDBTable @@ -832,7 +850,7 @@ 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 cid @@ -846,17 +864,17 @@ postFirmUsersR fsh = do , cmpy & firmCountDefaultReroutes , cmpy & firmCountActiveReroutes )) - -- superVs <- E.select $ do + -- superVs <- E.select $ do -- usr <- E.from $ E.table @User -- E.where_ $ E.exists $ firmQuerySupervisedBy cmpyId Nothing usr -- return usr - <*> mkFirmUserTable isAdmin cid + <*> mkFirmUserTable isAdmin cid - formResult fusrRes $ \case + formResult fusrRes $ \case (_, uids) | null uids -> addMessageI Error MsgUtilEmptyChoice - (FirmUserActMkSuperData{..}, Set.toList -> uids) -> do + (FirmUserActMkSuperData{..}, Set.toList -> uids) -> do nrMkSuper <- runDB $ updateWhereCount [UserCompanyUser <-. uids, UserCompanyCompany ==. cid] [UserCompanySupervisor =. True, UserCompanySupervisorReroute =. (firmUserActMkSuperReroute == Just True)] - addMessageI Info $ MsgASReqSetSupers nrMkSuper Nothing + addMessageI Info $ MsgFirmActAddSupersSet nrMkSuper Nothing reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes (FirmUserActNotifyData , uids) -> do cuids <- traverse encrypt $ Set.toList uids :: Handler [CryptoUUIDUser] @@ -865,34 +883,21 @@ postFirmUsersR fsh = do runDB $ do delSupers <- if firmUserActResetKeepOldSupers == Just False then deleteSupervisors uids - else return 0 + else return 0 newSupers <- addDefaultSupervisors cid uids addMessageI Info $ MsgFirmResetSupervision delSupers newSupers reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes - - ((fucrRes, fucrWgt), fucrEnctype) <- runFormPost . identifyForm FIDFirmUserChangeRequest $ makeFirmUserChangeRequestForm (Just def) - let addFormAnchor = "firm-user-change-form" :: Text - routeForm = FirmUsersR fsh :#: addFormAnchor - fucrForm = wrapForm fucrWgt FormSettings - { formMethod = POST - , formAction = Just . SomeRoute $ routeForm - , formEncoding = fucrEnctype - , formAttrs = [] - , formSubmit = FormSubmit - , formAnchor = Just addFormAnchor - } - formResult fucrRes $ \FirmUserChangeRequest{fucrPostalPref=fucrPPref, fucrPostalAddr=(canonical -> fucrPAddr)} -> do - when (isJust fucrPPref || isJust fucrPAddr) $ do - let changes = foldMap (\pp -> [UserPrefersPostal E.=. E.val pp]) fucrPPref <> - foldMap (\pa -> [UserPostAddress E.=. E.justVal pa]) fucrPAddr -- seems weird, but: Nothing means no change, and not delete address! - nrChanged <- runDB $ E.updateCount $ \usr -> do - E.set usr changes - E.where_ $ E.exists $ do - usrCmpy <- E.from $ E.table @UserCompany - E.where_ $ usrCmpy E.^. UserCompanyCompany E.==. E.val cid - E.&&. usrCmpy E.^. UserCompanyUser E.==. usr E.^. UserId - addMessageI Info $ MsgFirmUserChanges nrChanged - reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes + (FirmUserActChangeContactData{..}, Set.toList -> uids) -> + let changes = catMaybes + [ (UserPostAddress =.) . Just <$> canonical firmUserActPostalAddr -- note that Nothing means no change and not delete address! + , (UserPrefersPostal =.) <$> firmUserActPostalPref + ] + in unless (null changes) $ do + nrChanged <- runDB $ updateWhereCount [UserId <-. uids] changes + addMessageI Success $ MsgFirmUserChanges nrChanged + reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes + + formFirmAction <- runFirmActionFormPost cid (FirmUsersR fsh) [FirmActNotify, FirmActResetSupervision, FirmActAddSupersvisors, FirmActChangeContactFirm, FirmActChangeContactUser] siteLayout (citext2widget companyName) $ do setTitle $ toHtml $ CI.original companyShorthand <> "-" <> tshow companyAvsId @@ -903,9 +908,9 @@ postFirmUsersR fsh = do ----------------------------- -- Firm Supervisors Table -data FirmSuperAction = FirmSuperActNotify +data FirmSuperAction = FirmSuperActNotify | FirmSuperActRMSuperDef - + deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) deriving anyclass (Universe, Finite) @@ -915,32 +920,10 @@ embedRenderMessage ''UniWorX ''FirmSuperAction id data FirmSuperActionData = FirmSuperActNotifyData | FirmSuperActRMSuperDefData { firmSuperActRMSuperActive :: Maybe Bool } - + deriving (Eq, Ord, 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 - } - -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 MsgFormReqPostal & setTooltip MsgFormReqPostalTip) (asReqPostal <$> template) - - type SuperCompanyTableExpr = E.SqlExpr (Entity User) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity UserCompany)) querySuperUser :: SuperCompanyTableExpr -> E.SqlExpr (Entity User) @@ -955,7 +938,7 @@ type SuperCompanyTableData = DBRow (Entity User, E.Value Word64, E.Value Word64 ) resultSuperUser :: Lens' SuperCompanyTableData (Entity User) -resultSuperUser = _dbrOutput . _1 +resultSuperUser = _dbrOutput . _1 resultSuperCompanySupervised :: Lens' SuperCompanyTableData Word64 resultSuperCompanySupervised = _dbrOutput . _2 . _unValue @@ -972,10 +955,10 @@ resultSuperCompanyDefaultSuper = _dbrOutput . _5 . _unValue resultSuperCompanyDefaultReroute :: Lens' SuperCompanyTableData (Maybe Bool) resultSuperCompanyDefaultReroute = _dbrOutput . _6 . _unValue -instance HasEntity SuperCompanyTableData User where +instance HasEntity SuperCompanyTableData User where hasEntity = resultSuperUser -instance HasUser SuperCompanyTableData where +instance HasUser SuperCompanyTableData where hasUser = resultSuperUser . _entityVal @@ -997,7 +980,7 @@ mkFirmSuperTable isAdmin cid = do ) dbtRowKey = querySuperUser >>> (E.^. UserId) dbtProj = dbtProjSimple $ \(usr, supervised, rerouted, supervisor, reroute) -> do - cmps <- E.select $ 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] @@ -1020,7 +1003,7 @@ mkFirmSuperTable isAdmin cid = do ] dbtSorting = mconcat [ single $ sortUserNameLink querySuperUser - , single $ sortUserEmail querySuperUser + , single $ sortUserEmail querySuperUser , singletonMap "matriculation" $ SortColumn $ querySuperUser >>> (E.^. UserMatrikelnummer) , singletonMap "personal-number" $ SortColumn $ querySuperUser >>> (E.^. UserCompanyPersonalNumber) , singletonMap "postal-pref" $ SortColumn $ querySuperUser >>> (E.^. UserPrefersPostal) @@ -1045,7 +1028,7 @@ mkFirmSuperTable isAdmin cid = do acts :: Map FirmSuperAction (AForm Handler FirmSuperActionData) acts = mconcat [ singletonMap FirmSuperActNotify $ pure FirmSuperActNotifyData - , singletonMap FirmSuperActRMSuperDef $ FirmSuperActRMSuperDefData + , singletonMap FirmSuperActRMSuperDef $ FirmSuperActRMSuperDefData <$> aopt checkBoxField (fslI MsgFirmSuperActRMSuperActive) (Just $ Just True) ] dbtParams = DBParamsForm @@ -1072,7 +1055,7 @@ mkFirmSuperTable isAdmin cid = 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 @@ -1089,7 +1072,7 @@ postFirmSupersR fsh = do formResult fsprRes $ \case (_, uids) | null uids -> addMessageI Error MsgUtilEmptyChoice - (FirmSuperActRMSuperDefData{..}, Set.toList -> uids) -> do + (FirmSuperActRMSuperDefData{..}, Set.toList -> uids) -> do (nrRmSuper,nrRmActual) <- runDB $ (,) <$> updateWhereCount [UserCompanyUser <-. uids, UserCompanyCompany ==. cid] [UserCompanySupervisor =. False, UserCompanySupervisorReroute =. False] <*> if firmSuperActRMSuperActive /= Just True @@ -1100,49 +1083,16 @@ postFirmSupersR fsh = do E.&&. E.exists (do usr <- E.from $ E.table @UserCompany E.where_ $ usr E.^. UserCompanyCompany E.==. E.val cid - E.&&. usr E.^. UserCompanyUser E.==. spr E.^. UserSupervisorUser - ) + E.&&. usr E.^. UserCompanyUser E.==. spr E.^. UserSupervisorUser + ) addMessageI Info $ MsgRemoveSupervisors nrRmSuper nrRmActual reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes - - (FirmSuperActNotifyData , uids) -> do + + (FirmSuperActNotifyData , uids) -> do cuids <- traverse encrypt $ Set.toList uids :: Handler [CryptoUUIDUser] redirect (FirmCommR fsh, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids]) - formFirmAction <- runFirmActionFormPost cid (FirmSupersR fsh) [FirmActAddSupervisors, FirmActResetSupervision] - - ((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 + formFirmAction <- runFirmActionFormPost cid (FirmSupersR fsh) [FirmActAddSupersvisors, FirmActResetSupervision, FirmActChangeContactFirm] siteLayout (citext2widget fsh) $ do setTitle $ citext2Html $ fsh <> " Supers" @@ -1167,9 +1117,9 @@ postFirmsCommR = handleFirmCommR (SomeRoute FirmAllR) handleFirmCommR :: SomeRoute UniWorX -> Companies -> Handler Html handleFirmCommR _ [] = invalidArgs ["At least one company name must be provided."] handleFirmCommR ultDest cs = do - let + let queryGiven :: [UserId] -> E.SqlQuery (E.SqlExpr (Entity User)) -- get users from a list of UserIds - queryGiven usrs = do + queryGiven usrs = do usr <- E.from $ E.table @User E.where_ $ usr E.^. UserId `E.in_` E.valList usrs return usr @@ -1179,14 +1129,14 @@ handleFirmCommR ultDest cs = do csKeys = CompanyKey <$> cs mbUser <- maybeAuthId -- get employees of chosen companies - empys <- mkCompanyUsrList <$> runDB (E.select $ do + empys <- mkCompanyUsrList <$> runDB (E.select $ do (emp :& cmp) <- E.from $ E.table @User `E.innerJoin` E.table @UserCompany `E.on` (\(emp :& cmp) -> emp E.^. UserId E.==. cmp E.^. UserCompanyUser) - E.where_ $ cmp E.^. UserCompanyCompany `E.in_` E.valList csKeys + E.where_ $ cmp E.^. UserCompanyCompany `E.in_` E.valList csKeys E.orderBy [E.ascNullsFirst $ cmp E.^. UserCompanyCompany] return (E.just $ cmp E.^. UserCompanyCompany, emp E.^. UserId) ) - -- get supervisors of employees - sprs <- mkCompanyUsrList <$> runDB (E.select $ do + -- get supervisors of employees + sprs <- mkCompanyUsrList <$> runDB (E.select $ do (spr :& cmp) <- E.from $ E.table @User `E.leftJoin` E.table @UserCompany `E.on` (\(spr :& cmp) -> spr E.^. UserId E.=?. cmp E.?. UserCompanyUser) E.where_ $ (E.isTrue (cmp E.?. UserCompanySupervisor) E.&&. cmp E.?. UserCompanyCompany `E.in_` E.justValList csKeys) E.||. (spr E.^. UserId E.=?. E.val mbUser) @@ -1197,24 +1147,24 @@ handleFirmCommR ultDest cs = do ) E.orderBy [E.ascNullsFirst $ cmp E.?. UserCompanyCompany] return (cmp E.?. UserCompanyCompany, spr E.^. UserId) - ) - + ) + commR CommunicationRoute { 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) () - , crRecipientAuth = Nothing -- :: Maybe (UserId -> DB AuthResult) -- an optional filter passed to guardAuthResult - , crRecipients = -- :: [(RecipientGroup, SqlQuery (SqlExpr (Entity User)))] + , 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)))] [(toGrp acid, queryGiven usrs) | (acid, usrs) <- Map.toAscList sprs ] ++ [(RGFirmEmployees $ unCompanyKey acid, queryGiven usrs) | (Just acid, usrs) <- Map.toAscList empys ] } {- Auswahlbox für Mitteilung: Wenn Firma gewählt, dann zeige: - Alle Supervisor von Leuten in X, gruppiert nach deren Firma - Alle Teilnehmer von X + 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/Utils.hs b/src/Utils.hs index 324f71aa7..a2b35c37a 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -1993,3 +1993,10 @@ instance Canonical (Maybe Text) where -- a split into Canonical Text and Canonic | Text.null t' -> Nothing | t == t' -> r | otherwise -> Just t' + +instance Canonical (Maybe (CI Text)) where -- a split into Canonical Text and Canonical a => Maybe seems nicer, but the latter instance would be troublesome + canonical Nothing = Nothing + canonical r@(Just t) = let t' = CI.map Text.strip t in if + | mempty == t'-> Nothing + | t == t' -> r + | otherwise -> Just t' diff --git a/templates/firm-contact-info.hamlet b/templates/firm-contact-info.hamlet index 8aea13ab1..a251650db 100644 --- a/templates/firm-contact-info.hamlet +++ b/templates/firm-contact-info.hamlet @@ -9,12 +9,16 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
                                          $maybe fem <- companyEmail
                                          - _{MsgFirmEmail} #{iconLetterOrEmail False} + _{MsgFirmEmail} + $if not companyPrefersPostal +   #{iconLetterOrEmail False}
                                          #{mailtoHtml fem} $maybe addr <- companyPostAddress
                                          - _{MsgFirmAddress} #{iconLetterOrEmail True} + _{MsgFirmAddress} + $if companyPrefersPostal +   #{iconLetterOrEmail True}
                                          #{addr} $nothing diff --git a/templates/firm-users.hamlet b/templates/firm-users.hamlet index 19c41bb64..c10c06e13 100644 --- a/templates/firm-users.hamlet +++ b/templates/firm-users.hamlet @@ -6,6 +6,8 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later ^{firmContactInfo} +^{formFirmAction} +
                                          @@ -55,9 +57,3 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later _{MsgFirmAssociates}

                                          ^{fusrTable} - -

                                          -

                                          - Heading TODO -
                                          - ^{fucrForm} \ No newline at end of file diff --git a/templates/i18n/firm-supervisors/de-de-formal.hamlet b/templates/i18n/firm-supervisors/de-de-formal.hamlet index bd9fdf4db..ddd921f87 100644 --- a/templates/i18n/firm-supervisors/de-de-formal.hamlet +++ b/templates/i18n/firm-supervisors/de-de-formal.hamlet @@ -15,7 +15,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later ^{formFirmAction}
                                          - ^{fsprTable} - -
                                          - ^{addSuperForm} \ No newline at end of file +

                                          + _{MsgTableSupervisor} +
                                          + ^{fsprTable} diff --git a/templates/i18n/firm-supervisors/en-eu.hamlet b/templates/i18n/firm-supervisors/en-eu.hamlet index 8edcdeeec..09a6a37c5 100644 --- a/templates/i18n/firm-supervisors/en-eu.hamlet +++ b/templates/i18n/firm-supervisors/en-eu.hamlet @@ -14,7 +14,8 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later ^{formFirmAction}
                                          - ^{fsprTable} +

                                          + _{MsgTableSupervisor} +
                                          + ^{fsprTable} -
                                          - ^{addSuperForm} From 212cb7180764109924fb09ce3ed748695f0f2cd2 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 24 Nov 2023 17:44:27 +0100 Subject: [PATCH 084/159] chore(firm): limit firm action access to admins --- routes | 4 +-- src/Handler/Firm.hs | 61 +++++++++++++++++++++++---------------------- 2 files changed, 33 insertions(+), 32 deletions(-) diff --git a/routes b/routes index d341734ac..df8c32fa2 100644 --- a/routes +++ b/routes @@ -115,9 +115,9 @@ /firms FirmAllR GET POST !supervisor /firms/comm/+Companies FirmsCommR GET POST -/firm/#CompanyShorthand FirmR GET POST +/firm/#CompanyShorthand/debug FirmR GET POST /firm/#CompanyShorthand/comm FirmCommR GET POST -/firm/#CompanyShorthand/users FirmUsersR GET POST !supervisor +/firm/#CompanyShorthand FirmUsersR GET POST !supervisor /firm/#CompanyShorthand/supers FirmSupersR GET POST !supervisor /exam-office ExamOfficeR !exam-office: diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 9ed737280..429f7db72 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -62,7 +62,7 @@ data FirmAction = FirmActNotify deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) deriving anyclass (Universe, Finite) -nullaryPathPiece ''FirmAction $ camelToPathPiece' 2 +nullaryPathPiece ''FirmAction $ camelToPathPiece' 1 embedRenderMessage ''UniWorX ''FirmAction id data FirmActionData = FirmActNotifyData @@ -86,28 +86,29 @@ data FirmActionData = FirmActNotifyData } deriving (Eq, Ord, Read, Show, Generic) -firmActionMap :: _ -> [FirmAction] -> Map FirmAction (AForm Handler FirmActionData) -firmActionMap mr acts = mconcat (mkAct <$> acts) +firmActionMap :: _ -> Bool -> [FirmAction] -> Map FirmAction (AForm Handler FirmActionData) +firmActionMap mr isAdmin acts = mconcat (mkAct isAdmin <$> acts) where - mkAct FirmActNotify = singletonMap FirmActNotify $ pure FirmActNotifyData - mkAct FirmActResetSupervision = singletonMap FirmActResetSupervision $ FirmActResetSupervisionData - <$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep) (Just $ Just False) - <*> aopt checkBoxField (fslI MsgFirmActResetMutualSupervision) (Just $ Just True ) - mkAct FirmActAddSupersvisors = singletonMap FirmActAddSupersvisors $ FirmActAddSupersvisorsData - <$> areq (textField & cfAnySeparatedSet) (fslI MsgTableIsDefaultSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing - <*> areq checkBoxField (fslI MsgTableIsDefaultReroute ) (Just True) - <*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip) Nothing - mkAct FirmActChangeContactFirm = singletonMap FirmActChangeContactFirm $ FirmActChangeContactFirmData - <$> aopt htmlField (fslI MsgPostAddress & setTooltip MsgPostAddressTip) Nothing - <*> aopt (emailField & cfStrip & cfCI) (fslI MsgUserDisplayEmail) Nothing - <*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip) Nothing - <* aformMessage (Message Info (toHtml $ mr MsgFirmActChangeContactFirmInfo) (Just IconNotificationNonactive)) - mkAct FirmActChangeContactUser = singletonMap FirmActChangeContactUser $ FirmActChangeContactUserData - <$> aopt htmlField (fslI MsgPostAddress & setTooltip MsgPostAddressTip) Nothing - <*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip) Nothing + mkAct True FirmActNotify = singletonMap FirmActNotify $ pure FirmActNotifyData + mkAct _ FirmActResetSupervision = singletonMap FirmActResetSupervision $ FirmActResetSupervisionData + <$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep) (Just $ Just False) + <*> aopt checkBoxField (fslI MsgFirmActResetMutualSupervision) (Just $ Just True ) + mkAct _ FirmActAddSupersvisors = singletonMap FirmActAddSupersvisors $ FirmActAddSupersvisorsData + <$> areq (textField & cfAnySeparatedSet) (fslI MsgTableIsDefaultSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing + <*> areq checkBoxField (fslI MsgTableIsDefaultReroute ) (Just True) + <*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip) Nothing + mkAct _ FirmActChangeContactFirm = singletonMap FirmActChangeContactFirm $ FirmActChangeContactFirmData + <$> aopt htmlField (fslI MsgPostAddress & setTooltip MsgPostAddressTip) Nothing + <*> aopt (emailField & cfStrip & cfCI) (fslI MsgUserDisplayEmail) Nothing + <*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip) Nothing + <* aformMessage (Message Info (toHtml $ mr MsgFirmActChangeContactFirmInfo) (Just IconNotificationNonactive)) + mkAct _ FirmActChangeContactUser = singletonMap FirmActChangeContactUser $ FirmActChangeContactUserData + <$> aopt htmlField (fslI MsgPostAddress & setTooltip MsgPostAddressTip) Nothing + <*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip) Nothing + mkAct _ _ = mempty -firmActionForm :: _ -> [FirmAction] -> AForm Handler FirmActionData -firmActionForm mr acts = multiActionA (firmActionMap mr acts) (fslI MsgTableAction) Nothing +firmActionForm :: () -> Bool -> [FirmAction] -> AForm Handler FirmActionData +firmActionForm mr isAdmin acts = multiActionA (firmActionMap mr isAdmin acts) (fslI MsgTableAction) Nothing makeFirmActionForm :: CompanyId -> _ -> [FirmAction] -> Form (FirmActionData, Set CompanyId) makeFirmActionForm cid mr acts html = flip (renderAForm FormStandard) html $ (,Set.singleton cid) <$> firmActionForm mr acts @@ -189,10 +190,10 @@ firmActionHandler route = flip formResult faHandler faHandler _ = addMessageI Error MsgErrorUnknownFormAction -runFirmActionFormPost :: CompanyId -> Route UniWorX -> [FirmAction] -> Handler Widget -runFirmActionFormPost cid route acts = do +runFirmActionFormPost :: CompanyId -> Route UniWorX -> Bool -> [FirmAction] -> Handler Widget +runFirmActionFormPost cid route isAdmin acts = do mr <- getMessageRender - ((faRes, faWgt), faEnctype) <- runFormPost . identifyForm FIDFirmAction $ makeFirmActionForm cid mr acts + ((faRes, faWgt), faEnctype) <- runFormPost . identifyForm FIDFirmAction $ makeFirmActionForm cid mr isAdmin acts let faAnchor = "firm-action-form" :: Text faRoute = route :#: faAnchor faForm = wrapForm faWgt FormSettings @@ -590,7 +591,7 @@ mkFirmAllTable isAdmin uid = do , dbParamsFormAction = Nothing , dbParamsFormAttrs = [] , dbParamsFormSubmit = FormSubmit - , dbParamsFormAdditional = renderAForm FormStandard $ (, mempty) . First . Just <$> firmActionForm mr [FirmActNotify, FirmActResetSupervision] + , dbParamsFormAdditional = renderAForm FormStandard $ (, mempty) . First . Just <$> firmActionForm mr isAdmin [FirmActNotify, FirmActResetSupervision] , dbParamsFormEvaluate = liftHandler . runFormPost , dbParamsFormResult = id , dbParamsFormIdent = def @@ -618,7 +619,7 @@ getFirmAllR, postFirmAllR :: Handler Html getFirmAllR = postFirmAllR postFirmAllR = do uid <- requireAuthId - isAdmin <- hasReadAccessTo AdminR + isAdmin <- checkAdmin (firmRes, firmTable) <- runDB $ mkFirmAllTable isAdmin uid -- filters to associated companies for non-admins firmActionHandler FirmAllR firmRes siteLayoutMsg MsgMenuFirms $ do @@ -839,7 +840,7 @@ mkFirmUserTable isAdmin cid = do getFirmUsersR, postFirmUsersR :: CompanyShorthand -> Handler Html getFirmUsersR = postFirmUsersR postFirmUsersR fsh = do - isAdmin <- hasReadAccessTo AdminR + isAdmin <- checkAdmin let cid = CompanyKey fsh (( Entity{entityVal=Company{..}} , E.Value nrCompanyUsers @@ -897,7 +898,7 @@ postFirmUsersR fsh = do addMessageI Success $ MsgFirmUserChanges nrChanged reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes - formFirmAction <- runFirmActionFormPost cid (FirmUsersR fsh) [FirmActNotify, FirmActResetSupervision, FirmActAddSupersvisors, FirmActChangeContactFirm, FirmActChangeContactUser] + formFirmAction <- runFirmActionFormPost cid (FirmUsersR fsh) isAdmin [FirmActNotify, FirmActResetSupervision, FirmActAddSupersvisors, FirmActChangeContactFirm, FirmActChangeContactUser] siteLayout (citext2widget companyName) $ do setTitle $ toHtml $ CI.original companyShorthand <> "-" <> tshow companyAvsId @@ -1064,7 +1065,7 @@ mkFirmSuperTable isAdmin cid = do getFirmSupersR, postFirmSupersR :: CompanyShorthand -> Handler Html getFirmSupersR = postFirmSupersR postFirmSupersR fsh = do - isAdmin <- hasReadAccessTo AdminR + isAdmin <- checkAdmin let cid = CompanyKey fsh (Company{..},(fsprRes,fsprTable)) <- runDB $ (,) <$> get404 cid @@ -1092,7 +1093,7 @@ postFirmSupersR fsh = do cuids <- traverse encrypt $ Set.toList uids :: Handler [CryptoUUIDUser] redirect (FirmCommR fsh, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids]) - formFirmAction <- runFirmActionFormPost cid (FirmSupersR fsh) [FirmActAddSupersvisors, FirmActResetSupervision, FirmActChangeContactFirm] + formFirmAction <- runFirmActionFormPost cid (FirmSupersR fsh) isAdmin [FirmActAddSupersvisors, FirmActResetSupervision, FirmActChangeContactFirm] siteLayout (citext2widget fsh) $ do setTitle $ citext2Html $ fsh <> " Supers" From 06bb44cf715375b5dd0141a46f8e10924ad6cd9c Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 24 Nov 2023 18:02:03 +0100 Subject: [PATCH 085/159] fix(build): minor errors firm handler --- src/Handler/Firm.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 429f7db72..0eeaa5edd 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -86,7 +86,7 @@ data FirmActionData = FirmActNotifyData } deriving (Eq, Ord, Read, Show, Generic) -firmActionMap :: _ -> Bool -> [FirmAction] -> Map FirmAction (AForm Handler FirmActionData) +firmActionMap :: (_ -> Text) -> Bool -> [FirmAction] -> Map FirmAction (AForm Handler FirmActionData) firmActionMap mr isAdmin acts = mconcat (mkAct isAdmin <$> acts) where mkAct True FirmActNotify = singletonMap FirmActNotify $ pure FirmActNotifyData @@ -107,11 +107,11 @@ firmActionMap mr isAdmin acts = mconcat (mkAct isAdmin <$> acts) <*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip) Nothing mkAct _ _ = mempty -firmActionForm :: () -> Bool -> [FirmAction] -> AForm Handler FirmActionData +firmActionForm :: _ -> Bool -> [FirmAction] -> AForm Handler FirmActionData firmActionForm mr isAdmin acts = multiActionA (firmActionMap mr isAdmin acts) (fslI MsgTableAction) Nothing -makeFirmActionForm :: CompanyId -> _ -> [FirmAction] -> Form (FirmActionData, Set CompanyId) -makeFirmActionForm cid mr acts html = flip (renderAForm FormStandard) html $ (,Set.singleton cid) <$> firmActionForm mr acts +makeFirmActionForm :: CompanyId -> _ -> Bool -> [FirmAction] -> Form (FirmActionData, Set CompanyId) +makeFirmActionForm cid mr isAdmin acts html = flip (renderAForm FormStandard) html $ (,Set.singleton cid) <$> firmActionForm mr isAdmin acts firmActionHandler :: Route UniWorX -> FormResult (FirmActionData, Set CompanyId) -> Handler () firmActionHandler route = flip formResult faHandler From 17bde4de09fd535f0012e59af79b10ca33dadae2 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 24 Nov 2023 19:55:43 +0000 Subject: [PATCH 086/159] chore(release): 27.4.51 --- CHANGELOG.md | 9 +++++++++ nix/docker/version.json | 2 +- package-lock.json | 2 +- package.json | 2 +- package.yaml | 2 +- 5 files changed, 13 insertions(+), 4 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 08967c314..54de9bc9a 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,15 @@ All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines. +## [27.4.51](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.50...v27.4.51) (2023-11-24) + + +### Bug Fixes + +* **build:** minor errors firm handler ([06bb44c](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/06bb44cf715375b5dd0141a46f8e10924ad6cd9c)) +* **cache:** remove risky caching for submissions ([4ae59fc](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/4ae59fc1fa658e1462139ddddd6dc80308d85872)) +* **firm:** show default supervisors with no employees too ([0f9a7a8](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/0f9a7a8c53d216ca7a6d0a25462b19ab1fa00bb4)) + ## [27.4.50](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.49...v27.4.50) (2023-11-17) diff --git a/nix/docker/version.json b/nix/docker/version.json index 2140ac34f..ac2140316 100644 --- a/nix/docker/version.json +++ b/nix/docker/version.json @@ -1,3 +1,3 @@ { - "version": "27.4.50" + "version": "27.4.51" } diff --git a/package-lock.json b/package-lock.json index 0f9458042..8c57be9a2 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.4.50", + "version": "27.4.51", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index 06948aab1..31aa2b12d 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.4.50", + "version": "27.4.51", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index 4cacc5a3b..5856789ac 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 27.4.50 +version: 27.4.51 dependencies: - base - yesod From 640a2e61d146f16c32b1cdfa7f13d277860cde21 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 27 Nov 2023 12:07:17 +0100 Subject: [PATCH 087/159] chore(messages): Add SomeMessages newtype SomeMessages provides a RenderMessage instance for a list of messages. --- messages/uniworx/utils/utils/de-de-formal.msg | 1 + messages/uniworx/utils/utils/en-eu.msg | 1 + src/Foundation/I18n.hs | 14 ++++++++++++++ src/Handler/Firm.hs | 14 +++++++------- src/Handler/Utils/Table/Pagination.hs | 1 + 5 files changed, 24 insertions(+), 7 deletions(-) diff --git a/messages/uniworx/utils/utils/de-de-formal.msg b/messages/uniworx/utils/utils/de-de-formal.msg index f25770b33..067b7ba11 100644 --- a/messages/uniworx/utils/utils/de-de-formal.msg +++ b/messages/uniworx/utils/utils/de-de-formal.msg @@ -97,6 +97,7 @@ RoomReferenceLinkLinkPlaceholder !ident-ok: URL RoomReferenceLinkInstructions: Anweisungen RoomReferenceLinkInstructionsPlaceholder: Anweisungen UtilEmptyChoice: Auswahl war leer +UtilEmptyNoChangeTip: Eine leere Eingabe belässt den vorherigen Wert unverändert. #invitation.hs InvitationAction: Aktion diff --git a/messages/uniworx/utils/utils/en-eu.msg b/messages/uniworx/utils/utils/en-eu.msg index 97f5daa22..cafb5fac8 100644 --- a/messages/uniworx/utils/utils/en-eu.msg +++ b/messages/uniworx/utils/utils/en-eu.msg @@ -97,6 +97,7 @@ RoomReferenceLinkLinkPlaceholder: URL RoomReferenceLinkInstructions: Instructions RoomReferenceLinkInstructionsPlaceholder: Instructions UtilEmptyChoice: Empty selection +UtilEmptyNoChangeTip: Existing values remain unchanged if this field is left empty. #invitation.hs InvitationAction: Action diff --git a/src/Foundation/I18n.hs b/src/Foundation/I18n.hs index 8c8a0137b..571fd0249 100644 --- a/src/Foundation/I18n.hs +++ b/src/Foundation/I18n.hs @@ -43,6 +43,8 @@ module Foundation.I18n , UniWorXMessages(..) , uniworxMessages , unRenderMessage, unRenderMessage', unRenderMessageLenient + , SomeMessages(..) + , someMessages , module Foundation.I18n.TH ) where @@ -266,6 +268,18 @@ mkMessageAddition ''UniWorX "Avs" "messages/uniworx/categories/avs" "de-de-forma embedRenderMessage ''UniWorX ''LmsStatus (uncurry ((<>) . (<> "Status")) . Text.splitAt 3) + +newtype SomeMessages master = SomeMessages [SomeMessage master] + deriving newtype (Semigroup, Monoid) + +instance master ~ master' => RenderMessage master (SomeMessages master') where + renderMessage a b (SomeMessages msgs) = Text.intercalate " " $ renderMessage a b <$> msgs + +-- | convenienience function if all messages happen to belong to the exact same type +someMessages :: RenderMessage master msg => [msg] -> SomeMessages master +someMessages msgs = SomeMessages $ SomeMessage <$> msgs + + instance RenderMessage UniWorX (Maybe LmsStatus) where -- useful for Filter with optionsFinite renderMessage f ls (Just s) = renderMessage f ls s renderMessage f ls Nothing = renderMessage f ls MsgLmsStateOpen diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 0eeaa5edd..d5cd1da0b 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -98,13 +98,13 @@ firmActionMap mr isAdmin acts = mconcat (mkAct isAdmin <$> acts) <*> areq checkBoxField (fslI MsgTableIsDefaultReroute ) (Just True) <*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip) Nothing mkAct _ FirmActChangeContactFirm = singletonMap FirmActChangeContactFirm $ FirmActChangeContactFirmData - <$> aopt htmlField (fslI MsgPostAddress & setTooltip MsgPostAddressTip) Nothing - <*> aopt (emailField & cfStrip & cfCI) (fslI MsgUserDisplayEmail) Nothing - <*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip) Nothing + <$> aopt htmlField (fslI MsgPostAddress & setTooltip (SomeMessages [SomeMessage MsgPostAddressTip, SomeMessage MsgUtilEmptyNoChangeTip])) Nothing + <*> aopt (emailField & cfStrip & cfCI) (fslI MsgUserDisplayEmail & setTooltip MsgUtilEmptyNoChangeTip) Nothing + <*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip) Nothing <* aformMessage (Message Info (toHtml $ mr MsgFirmActChangeContactFirmInfo) (Just IconNotificationNonactive)) mkAct _ FirmActChangeContactUser = singletonMap FirmActChangeContactUser $ FirmActChangeContactUserData - <$> aopt htmlField (fslI MsgPostAddress & setTooltip MsgPostAddressTip) Nothing - <*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip) Nothing + <$> aopt htmlField (fslI MsgPostAddress & setTooltip (SomeMessages [SomeMessage MsgPostAddressTip, SomeMessage MsgUtilEmptyNoChangeTip])) Nothing + <*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip) Nothing mkAct _ _ = mempty firmActionForm :: _ -> Bool -> [FirmAction] -> AForm Handler FirmActionData @@ -803,8 +803,8 @@ mkFirmUserTable isAdmin cid = do , singletonMap FirmUserActMkSuper $ FirmUserActMkSuperData <$> aopt checkBoxField (fslI MsgTableIsDefaultReroute) (Just $ Just True) , singletonMap FirmUserActChangeContact $ FirmUserActChangeContactData - <$> aopt htmlField (fslI MsgPostAddress & setTooltip MsgPostAddressTip) Nothing - <*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip) Nothing + <$> aopt htmlField (fslI MsgPostAddress & setTooltip (SomeMessages [SomeMessage MsgPostAddressTip, SomeMessage MsgUtilEmptyNoChangeTip])) Nothing + <*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip) Nothing ] dbtParams = DBParamsForm { dbParamsFormMethod = POST diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index 415fb255b..0d5182704 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -1723,6 +1723,7 @@ i18nCell msg = cell $ do cellTooltip :: (RenderMessage UniWorX msg, IsDBTable m a) => msg -> DBCell m a -> DBCell m a cellTooltip = cellTooltipIcon Nothing +-- note that you can also use `cellTooltip` with `SomeMessages`, which uses ' ' for separation only cellTooltips :: (RenderMessage UniWorX msg, IsDBTable m a) => [msg] -> DBCell m a -> DBCell m a cellTooltips msgs = cellTooltipWgt Nothing [whamlet| $forall msg <- msgs From 0a06efd76c63180c996657c2c7d78efc5bddd83d Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 27 Nov 2023 17:49:06 +0100 Subject: [PATCH 088/159] fix(firm): restrict firm access to company supervisors only --- .../uniworx/categories/firm/de-de-formal.msg | 4 +- messages/uniworx/categories/firm/en-eu.msg | 6 +- src/Foundation/Authorization.hs | 3 +- src/Foundation/I18n.hs | 2 +- src/Handler/Firm.hs | 66 ++++++++++++++----- 5 files changed, 57 insertions(+), 24 deletions(-) diff --git a/messages/uniworx/categories/firm/de-de-formal.msg b/messages/uniworx/categories/firm/de-de-formal.msg index 3158130c1..0d872dba0 100644 --- a/messages/uniworx/categories/firm/de-de-formal.msg +++ b/messages/uniworx/categories/firm/de-de-formal.msg @@ -9,7 +9,7 @@ FirmEmail: Allgemeine Email FirmAddress: Postanschrift FirmDefaultPreferenceInfo: Diese Voreinstellungen gelten nur für neue Firmenangehörige FirmAction: Firmenweite Aktion -FirmActionInfo: Betrifft alle Firmenangehörigen. +FirmActionInfo: Betrifft alle Firmenangehörigen unter Ihrer Aufsicht. FirmActNotify: Mitteilung versenden FirmActResetSupervision: Ansprechpartner für alle Firmenangehörigen zurücksetzen FirmActResetSuperKeep: Bisherige Ansprechpartner der Firmenangehörigen zusätzlich beibehalten? @@ -18,7 +18,7 @@ FirmActAddSupersvisors: Ansprechpartner hinzufügen FirmActAddSupersEmpty: Es konnten keine Ansprechpartner hinzugefügt werden FirmActAddSupersSet n@Int64 postal@(Maybe Bool): #{n} Standardansprechpartner eingetragen #{maybeBoolMessage postal "" "und auf Briefversand geschaltet" "und Benachrichtigungen per Email gesetzt"}, aber nicht nicht aktiviert. RemoveSupervisors ndef@Int64 nact@Int64: #{ndef} Standard Ansprechpartner entfernt#{bool ", aber noch nicht deaktiviert" (", " <> tshow nact <> " aktive Ansprechpartnerbeziehungen gelöscht") (nact > 0)} -FirmActChangeContactUser: Kontaktinformationen von Firmenangehörigen ändern +FirmActChangeContactUser: Kontaktinformationen von allen Firmenangehörigen ändern FirmActChangeContactFirm: Kontaktinformationen der Firma ändern FirmActChangeContactFirmInfo: Firmenkontaktinformationen werden nur für neue Firmenangehörige verwendet, für die sonst keine Kontaktinformationen vorliegen. FirmActChangeContactFirmResult: Firmenkontaktinformationen geändert. Betrifft nur neue Firmenangehörige ohne eigene Kontaktinformationen diff --git a/messages/uniworx/categories/firm/en-eu.msg b/messages/uniworx/categories/firm/en-eu.msg index b73afc808..0554ce6e9 100644 --- a/messages/uniworx/categories/firm/en-eu.msg +++ b/messages/uniworx/categories/firm/en-eu.msg @@ -9,7 +9,7 @@ FirmEmail: General company email FirmAddress: Postal address FirmDefaultPreferenceInfo: Default setting for new company associates only FirmAction: Companywide action -FirmActionInfo: Affects alle company associates. +FirmActionInfo: Affects alle company associates under your supervision. FirmActNotify: Send message FirmActResetSupervision: Reset supervisors for all company associates FirmActResetSuperKeep: Additionally keep existing supervisors of company associates? @@ -17,8 +17,8 @@ FirmActResetMutualSupervision: Supervisors supervise each other FirmActAddSupersvisors: Add supervisors FirmActAddSupersEmpty: No supervisors added FirmActAddSupersSet n postal: #{n} default company supervisors set #{maybeBoolMessage postal "" "and switched to postal notifications" "and switched to email notifications"}, but not yet activated. -RemoveSupervisors ndef nact: #{ndef} default supervisors removed#{bool ", but not yet deactivated" (" and " <> tshow nact <> " active supervisons terminated") (nact > 0)} -FirmActChangeContactUser: Change contact data for company associates +RemoveSupervisors ndef nact: #{ndef} default supervisors removed#{bool ", but not yet deactivated" (" and " <> tshow nact <> " active supervisions terminated") (nact > 0)} +FirmActChangeContactUser: Change contact data for all company associates FirmActChangeContactFirm: Change company contact data FirmActChangeContactFirmInfo: The company contact data is only used for new company associates that would habe no contact information of their own otherwise. FirmActChangeContactFirmResult: Company contact data changed, affecting future company associates without contact information only diff --git a/src/Foundation/Authorization.hs b/src/Foundation/Authorization.hs index 7ca298622..0243b0609 100644 --- a/src/Foundation/Authorization.hs +++ b/src/Foundation/Authorization.hs @@ -554,7 +554,8 @@ tagAccessPredicate AuthSupervisor = APDB $ \_ _ mAuthId route _ -> case route of return Authorized checkCompanySupervisor sup@(mAuthId, fsh) = $cachedHereBinary sup . exceptT return return $ do authId <- maybeExceptT AuthenticationRequired $ return mAuthId - isSupervisor <- lift . existsBy $ UniqueUserCompany authId $ CompanyKey fsh + -- isSupervisor <- lift . existsBy $ UniqueUserCompany authId $ CompanyKey fsh + isSupervisor <- lift $ exists [UserCompanyUser ==. authId, UserCompanyCompany ==. CompanyKey fsh, UserCompanySupervisor ==. True] guardMExceptT isSupervisor (unauthorizedI $ MsgUnauthorizedCompanySupervisor fsh) return Authorized checkAnySupervisor mAuthId = $cachedHereBinary mAuthId . exceptT return return $ do diff --git a/src/Foundation/I18n.hs b/src/Foundation/I18n.hs index 571fd0249..fd2bb9479 100644 --- a/src/Foundation/I18n.hs +++ b/src/Foundation/I18n.hs @@ -273,7 +273,7 @@ newtype SomeMessages master = SomeMessages [SomeMessage master] deriving newtype (Semigroup, Monoid) instance master ~ master' => RenderMessage master (SomeMessages master') where - renderMessage a b (SomeMessages msgs) = Text.intercalate " " $ renderMessage a b <$> msgs + renderMessage a b (SomeMessages msgs) = Text.intercalate "\n " $ renderMessage a b <$> msgs -- | convenienience function if all messages happen to belong to the exact same type someMessages :: RenderMessage master msg => [msg] -> SomeMessages master diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index d5cd1da0b..6030a9052 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -113,23 +113,10 @@ firmActionForm mr isAdmin acts = multiActionA (firmActionMap mr isAdmin acts) (f makeFirmActionForm :: CompanyId -> _ -> Bool -> [FirmAction] -> Form (FirmActionData, Set CompanyId) makeFirmActionForm cid mr isAdmin acts html = flip (renderAForm FormStandard) html $ (,Set.singleton cid) <$> firmActionForm mr isAdmin acts -firmActionHandler :: Route UniWorX -> FormResult (FirmActionData, Set CompanyId) -> Handler () -firmActionHandler route = flip formResult faHandler +firmActionHandler :: Route UniWorX -> Bool -> FormResult (FirmActionData, Set CompanyId) -> Handler () +firmActionHandler route isAdmin = flip formResult faHandler where faHandler (_,fids) | null fids = addMessageI Error MsgNoCompanySelected - faHandler (FirmActResetSupervisionData{..}, fids) = do - runDB $ do - delSupers <- if firmActResetKeepOldSupers == 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 (firmActResetMutualSupervision /= Just False) fids - addMessageI Success $ MsgFirmResetSupervision delSupers newSupers - reloadKeepGetParams route -- reload to reflect changes faHandler (FirmActNotifyData, Set.toList -> fids) = do usrs <- runDB $ E.select $ E.distinct $ do @@ -139,6 +126,26 @@ firmActionHandler route = flip formResult faHandler cuids <- traverse (encrypt . E.unValue) usrs :: Handler [CryptoUUIDUser] redirect (FirmsCommR $ fmap unCompanyKey fids, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids]) + faHandler (FirmActResetSupervisionData{..}, fids) = do + madId <- bool maybeAuthId (return Nothing) isAdmin + let suprFltr = if + | isAdmin -> const E.true + | (Just suprId) <- madId -> \spr -> spr E.^. UserSupervisorSupervisor E.==. E.val suprId + | otherwise -> const E.false + runDB $ do + delSupers <- if firmActResetKeepOldSupers == Just False + then E.deleteCount $ do + spr <- E.from $ E.table @UserSupervisor + E.where_ $ suprFltr spr E.&&. 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 <- addDefaultSupervisorsFor madId (firmActResetMutualSupervision /= Just False) fids + addMessageI Success $ MsgFirmResetSupervision delSupers newSupers + reloadKeepGetParams route -- reload to reflect changes + faHandler (FirmActAddSupersvisorsData{..}, Set.toList -> [cid]) = do avsUsers :: Map Text (Maybe UserId) <- sequenceA $ Map.fromSet guessAvsUser firmActAddSupervisorIds let (usersFound', usersNotFound) = partition (is _Just . view _2) $ Map.toList avsUsers @@ -204,11 +211,12 @@ runFirmActionFormPost cid route isAdmin acts = do , formSubmit = FormSubmit , formAnchor = Just faAnchor } - firmActionHandler route faRes + firmActionHandler route isAdmin faRes return [whamlet|

                                          _{MsgFirmAction} + $

                                          _{MsgFirmActionInfo} @@ -249,6 +257,30 @@ addDefaultSupervisors cid employees = do ) (\_old new -> [UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications]) +-- like `addDefaultSupervisors`, but selects all employees of given companies from database, optionally filtered by being under supervision of a given individual +addDefaultSupervisorsFor :: (CompanyId ~ Element mono, MonoFoldable mono) => Maybe UserId -> Bool -> mono -> DB Int64 +addDefaultSupervisorsFor mbSuperId 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 ] + <> maybeEmpty mbSuperId (\sprId -> [E.exists $ do + superv <- E.from $ E.table @UserSupervisor + E.where_ $ superv E.^. UserSupervisorSupervisor E.==. E.val sprId + E.&&. superv E.^. UserSupervisorUser E.==. usr E.^. UserCompanyUser + ]) + <> [ 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) + E.<&> (spr E.^. UserCompanySupervisorReroute) + ) + (\_old new -> [UserSupervisorRerouteNotifications E.=. new E.^. UserSupervisorRerouteNotifications] ) + -- 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 @@ -621,7 +653,7 @@ postFirmAllR = do uid <- requireAuthId isAdmin <- checkAdmin (firmRes, firmTable) <- runDB $ mkFirmAllTable isAdmin uid -- filters to associated companies for non-admins - firmActionHandler FirmAllR firmRes + firmActionHandler FirmAllR isAdmin firmRes siteLayoutMsg MsgMenuFirms $ do setTitleI MsgMenuFirms $(i18nWidgetFile "firm-all") From 92aca1b830f3bac78543e26956ec2707eb194187 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 28 Nov 2023 15:32:33 +0100 Subject: [PATCH 089/159] refactor(performance): disable modalAccess use for known admins modalAccess displays a link to modal only if the user has the rights to follow that link. However, for large dbTables this checking takes too long. So we use a conventional modal instead again. Worst-case: some non-admins are shown links that they cannot follow --- src/Handler/Admin/Avs.hs | 4 +- src/Handler/Course/Users.hs | 2 +- src/Handler/Exam/Users.hs | 2 +- src/Handler/Firm.hs | 7 ++-- src/Handler/LMS.hs | 4 +- src/Handler/Qualification.hs | 2 +- src/Handler/Tutorial/Users.hs | 4 +- src/Handler/Users.hs | 2 +- src/Handler/Utils/Table/Cells.hs | 62 ++++++++++++++++++++++++------ src/Handler/Utils/Table/Columns.hs | 8 +++- src/Handler/Utils/Widgets.hs | 7 ++-- src/Utils/Frontend/Modal.hs | 2 +- 12 files changed, 74 insertions(+), 32 deletions(-) diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs index 3773a9c85..f65f44f50 100644 --- a/src/Handler/Admin/Avs.hs +++ b/src/Handler/Admin/Avs.hs @@ -548,7 +548,7 @@ mkLicenceTable apidStatus dbtIdent aLic apids = do [ dbSelect (applying _2) id $ return . view (resultUserAvs . _userAvsPersonId) -- (\DBRow{dbrOutput=(_,_,apid,_)} -> return apid -- return . view resultAvsPID) -- does not type due to traversal , colUserNameLink AdminUserR - , sortable (Just "avspersonno") (i18nCell MsgAvsPersonNo) $ \(view resultUserAvs -> a) -> avsPersonNoLinkedCell a + , sortable (Just "avspersonno") (i18nCell MsgAvsPersonNo) $ \(view resultUserAvs -> a) -> avsPersonNoLinkedCellAdmin a -- , colUserCompany , sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \(view (resultUser . _entityKey) -> uid) -> flip (set' cellContents) mempty $ do -- why does sqlCell not work here? Mismatch "YesodDB UniWorX" and "RWST (Maybe (Env,FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX" companies' <- liftHandler . runDB . E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do @@ -752,7 +752,7 @@ getProblemAvsErrorR = do dbtRowKey = qerryUsrAvs >>> (E.^. UserAvsId) dbtProj = dbtProjId dbtColonnade = dbColonnade $ mconcat - [ colUserNameModalHdr MsgLmsUser AdminUserR + [ colUserNameModalHdrAdmin MsgLmsUser AdminUserR , sortable (Just "avs-nr") (i18nCell MsgAvsPersonNo) $ avsPersonNoLinkedCell . view reserrUsrAvs , sortable Nothing (i18nCell MsgAvsPersonId) diff --git a/src/Handler/Course/Users.hs b/src/Handler/Course/Users.hs index c2056d6c8..4a4e11e9d 100644 --- a/src/Handler/Course/Users.hs +++ b/src/Handler/Course/Users.hs @@ -660,7 +660,7 @@ postCUsersR tid ssh csh = do , pure . cap' $ colUserNameLink (CourseR tid ssh csh . CUserR) , guardOn showSex . cap' $ colUserSex' , pure . cap' $ colUserEmail - , pure . cap' $ colUserMatriclenr + , pure . cap' $ colUserMatriclenr False , pure . cap' $ colUserQualifications nowaday , guardOn hasSubmissionGroups $ cap' colUserSubmissionGroup , guardOn hasTutorials . cap' $ colUserTutorials tid ssh csh diff --git a/src/Handler/Exam/Users.hs b/src/Handler/Exam/Users.hs index 89d0bf40f..cd06ea982 100644 --- a/src/Handler/Exam/Users.hs +++ b/src/Handler/Exam/Users.hs @@ -484,7 +484,7 @@ postEUsersR tid ssh csh examn = do dbtColonnade = mconcat $ catMaybes [ pure $ dbSelect (_2 . applying _2) _1 $ return . view (resultExamRegistration . _entityKey) , pure $ colUserNameLink (CourseR tid ssh csh . CUserR) - , pure colUserMatriclenr + , pure $ colUserMatriclenr False , pure $ colStudyFeatures resultStudyFeatures , pure $ sortable (Just "occurrence") (i18nCell MsgTableExamOccurrence) $ maybe mempty (anchorCell' (\n -> CExamR tid ssh csh examn EShowR :#: [st|exam-occurrence__#{n}|]) id . examOccurrenceName . entityVal) . view _userTableOccurrence , guardOn showPasses $ sortable Nothing (i18nCell MsgAchievedPasses) $ \(view $ resultUser . _entityKey -> uid) -> diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 6030a9052..eb95a1e40 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -215,8 +215,7 @@ runFirmActionFormPost cid route isAdmin acts = do return [whamlet|

                                          - _{MsgFirmAction} - $ + _{MsgFirmAction}

                                          _{MsgFirmActionInfo} @@ -744,7 +743,7 @@ mkFirmUserTable isAdmin cid = do 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 + , guardMonoid isAdmin $ sortable (Just "matriculation") (i18nCell MsgTableMatrikelNr) $ \(view resultUserUser -> entUsr ) -> cellHasMatrikelnummerLinkedAdmin 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 @@ -1022,7 +1021,7 @@ mkFirmSuperTable isAdmin cid = do 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 + , guardMonoid isAdmin $ sortable (Just "matriculation") (i18nCell MsgTableMatrikelNr) $ \(view resultSuperUser -> entUsr) -> cellHasMatrikelnummerLinkedAdmin 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 diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index 682e0c7f4..9d363f449 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -632,7 +632,7 @@ postLmsR sid qsh = do ] colChoices cmpMap = mconcat [ guardMonoid isAdmin $ dbSelect (applying _2) id (return . view (resultUser . _entityKey)) - , colUserNameModalHdr MsgLmsUser AdminUserR + , colUserNameModalHdrAdmin MsgLmsUser AdminUserR , colUserEmail , sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \( view resultCompanyUser -> cmps) -> let cs = [ companyCell (unCompanyKey cmpId) cmpName cmpSpr @@ -640,7 +640,7 @@ postLmsR sid qsh = do , let cmpName = maybe (unCompanyKey cmpId) companyName $ Map.lookup cmpId cmpMap ] in intercalate spacerCell cs - , colUserMatriclenr + , colUserMatriclenr isAdmin -- , 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 diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs index 65710b884..5b2c315af 100644 --- a/src/Handler/Qualification.hs +++ b/src/Handler/Qualification.hs @@ -591,7 +591,7 @@ postQualificationR sid qsh = do , let cmpName = maybe (unCompanyKey cmpId) companyName $ Map.lookup cmpId cmpMap ] in intercalate spacerCell cs - , guardMonoid isAdmin colUserMatriclenr + , guardMonoid isAdmin $ colUserMatriclenr isAdmin -- , 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 diff --git a/src/Handler/Tutorial/Users.hs b/src/Handler/Tutorial/Users.hs index 46d15e16b..973366f0a 100644 --- a/src/Handler/Tutorial/Users.hs +++ b/src/Handler/Tutorial/Users.hs @@ -71,8 +71,8 @@ postTUsersR tid ssh csh tutn = do colChoices = mconcat $ catMaybes [ pure $ dbSelect (applying _2) id (return . view (hasEntity . _entityKey)) , pure $ colUserNameModalHdr MsgTableCourseMembers ForProfileDataR - , pure colUserEmail - , pure colUserMatriclenr + , pure colUserEmail + , pure $ colUserMatriclenr isAdmin , pure $ colUserQualifications nowaday , pure $ colUserQualificationBlocked isAdmin nowaday ] diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index 1133c56d8..0cbbbde66 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -100,7 +100,7 @@ postUsersR = do , sortable (Just "name") (i18nCell MsgName) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM (AdminUserR <$> encrypt uid) (nameWidget userDisplayName userSurname) - , sortable (Just "matriculation") (i18nCell MsgTableMatrikelNr) $ \DBRow{ dbrOutput = entUsr } -> cellHasMatrikelnummerLinked entUsr + , sortable (Just "matriculation") (i18nCell MsgTableMatrikelNr) $ \DBRow{ dbrOutput = entUsr } -> cellHasMatrikelnummerLinkedAdmin entUsr , sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \DBRow{ dbrOutput = Entity uid _ } -> flip (set' cellContents) mempty $ do -- why does sqlCell not work here? Mismatch "YesodDB UniWorX" and "RWST (Maybe (Env,FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX" companies' <- liftHandler . runDB . E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index 2cab48fc2..6b776cd41 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -218,7 +218,7 @@ cellHasUserLink toLink user = nWdgt = nameWidget (userEntity ^. _entityVal . _userDisplayName) (userEntity ^. _entityVal . _userSurname) in anchorCellM (toLink <$> encrypt uid) nWdgt --- | like `cellHasUserLink` but opens the user in a modal instead +-- | like `cellHasUserLink` but opens the user in a modal instead; link is only displayed if the user has sufficient rights cellHasUserModal :: (IsDBTable m c, HasEntity u User) => (CryptoUUIDUser -> Route UniWorX) -> u -> DBCell m c cellHasUserModal toLink user = let userEntity = user ^. hasEntityUser @@ -226,10 +226,21 @@ cellHasUserModal toLink user = nWdgt = nameWidget (userEntity ^. _entityVal . _userDisplayName) (userEntity ^. _entityVal . _userSurname) lWdgt = do uuid <- liftHandler $ encrypt uid - modalAccess False nWdgt nWdgt $ toLink uuid + modalAccess nWdgt nWdgt False $ toLink uuid in cell lWdgt --- | like `cellHasUserModal` but with fixed route and showing an edit icon instead +-- | like `cellHasUserModal` but but always display link without prior access rights checks +cellHasUserModalAdmin :: (IsDBTable m c, HasEntity u User) => (CryptoUUIDUser -> Route UniWorX) -> u -> DBCell m c +cellHasUserModalAdmin toLink user = + let userEntity = user ^. hasEntityUser + uid = userEntity ^. _entityKey + nWdgt = nameWidget (userEntity ^. _entityVal . _userDisplayName) (userEntity ^. _entityVal . _userSurname) + lWdgt = do + uuid <- liftHandler $ encrypt uid + modal nWdgt $ Left $ SomeRoute $ toLink uuid + in cell lWdgt + +-- | like `cellHasUserModal` but with fixed route and showing an edit icon instead; link is only displayed if the user has sufficient rights cellEditUserModal :: (IsDBTable m c, HasEntity u User) => u -> DBCell m c cellEditUserModal user = let userEntity = user ^. hasEntityUser @@ -237,16 +248,39 @@ cellEditUserModal user = nWdgt = toWidget $ icon IconUserEdit lWdgt = do uuid <- liftHandler $ encrypt uid - modalAccess True nWdgt mempty $ ForProfileR uuid + modalAccess mempty nWdgt True $ ForProfileR uuid in cell lWdgt + +-- | like `cellEditUserModal` but always displays the link without prior access rights checks +cellEditUserModalAdmin :: (IsDBTable m c, HasEntity u User) => u -> DBCell m c +cellEditUserModalAdmin user = + let userEntity = user ^. hasEntityUser + uid = userEntity ^. _entityKey + nWdgt = toWidget $ icon IconUserEdit + lWdgt = do + uuid <- liftHandler $ encrypt uid + modal nWdgt (Left $ SomeRoute $ ForProfileR uuid) + in cell lWdgt + cellHasMatrikelnummer :: (IsDBTable m a, HasUser u) => u -> DBCell m a cellHasMatrikelnummer = maybe mempty textCell . view _userMatrikelnummer -cellHasMatrikelnummerLinked :: (IsDBTable m a, HasEntity u User) => u -> DBCell m a -cellHasMatrikelnummerLinked usr +cellHasMatrikelnummerLinked :: (IsDBTable m a, HasEntity u User) => Bool -> u -> DBCell m a +cellHasMatrikelnummerLinked isAdmin usr | Just matNr <- usrEntity ^. _userMatrikelnummer = cell $ do uuid <- liftHandler $ encrypt $ usrEntity ^. _entityKey - modalAccess False (text2widget matNr) mempty (AdminAvsUserR uuid) + if isAdmin + then modal (text2widget matNr) (Left $ SomeRoute $ AdminAvsUserR uuid) + else modalAccess mempty (text2widget matNr) False (AdminAvsUserR uuid) + | otherwise = mempty + where + usrEntity = usr ^. hasEntityUser + +cellHasMatrikelnummerLinkedAdmin :: (IsDBTable m a, HasEntity u User) => u -> DBCell m a +cellHasMatrikelnummerLinkedAdmin usr + | Just matNr <- usrEntity ^. _userMatrikelnummer = cell $ do + uuid <- liftHandler $ encrypt $ usrEntity ^. _entityKey + modal (text2widget matNr) (Left $ SomeRoute $ AdminAvsUserR uuid) | otherwise = mempty where usrEntity = usr ^. hasEntityUser @@ -364,7 +398,7 @@ qualificationValidUntilCell' mbToLink d qb qu = cell $ case mbToLink of Nothing -> headWgt <> dateWgt Just toLink -> do uuid <- liftHandler $ encrypt $ qu ^. hasQualificationUser . _qualificationUserUser - let modalWgt = modalAccess False dateWgt dateWgt $ toLink uuid + let modalWgt = modalAccess dateWgt dateWgt False $ toLink uuid headWgt <> modalWgt where dateWgt = formatTimeW SelFormatDate (qu ^. hasQualificationUser . _qualificationUserValidUntil) @@ -386,7 +420,7 @@ qualificationValidReasonCell' mbToLink showReason d qb qu = ic <> foldMap blc qb | Just toLink <- mbToLink = cell $ do uuid <- liftHandler $ encrypt uid let dWgt = formatTimeW SelFormatDate tstamp - modalAccess False dWgt dWgt $ toLink uuid + modalAccess dWgt dWgt False $ toLink uuid -- anchorCellM (toLink <$> encrypt uid) | otherwise = dateCell tstamp uid = qu ^. hasQualificationUser . _qualificationUserUser @@ -405,7 +439,7 @@ qualificationValidReasonCell'' mbToLink showReason d qb qu extValid = ic <> icEr | Just toLink <- mbToLink = cell $ do uuid <- liftHandler $ encrypt uid let dWgt = formatTimeW SelFormatDate tstamp - modalAccess False dWgt dWgt $ toLink uuid + modalAccess dWgt dWgt False $ toLink uuid -- anchorCellM (toLink <$> encrypt uid) | otherwise = dateCell tstamp uid = qu ^. hasQualificationUser . _qualificationUserUser @@ -466,7 +500,13 @@ avsPersonNoLinkedCell :: (IsDBTable m c, HasUserAvs a) => a -> DBCell m c avsPersonNoLinkedCell a = cell $ do uuid <- liftHandler $ encrypt $ a ^. _userAvsUser let nWgt = toWgt $ toMessage $ a ^. _userAvsNoPerson - modalAccess False nWgt nWgt $ AdminAvsUserR uuid + modalAccess nWgt nWgt False $ AdminAvsUserR uuid + +avsPersonNoLinkedCellAdmin :: (IsDBTable m c, HasUserAvs a) => a -> DBCell m c +avsPersonNoLinkedCellAdmin a = cell $ do + uuid <- liftHandler $ encrypt $ a ^. _userAvsUser + let nWgt = toWgt $ toMessage $ a ^. _userAvsNoPerson + modal nWgt (Left $ SomeRoute $ AdminAvsUserR uuid) avsPersonCardCell :: (IsDBTable m c) => Set AvsDataPersonCard -> DBCell m c avsPersonCardCell cards = wgtCell diff --git a/src/Handler/Utils/Table/Columns.hs b/src/Handler/Utils/Table/Columns.hs index 6184d1314..c0f768e99 100644 --- a/src/Handler/Utils/Table/Columns.hs +++ b/src/Handler/Utils/Table/Columns.hs @@ -336,6 +336,10 @@ colUserNameLinkHdr colHeader userLink = sortable (Just "user-name") (i18nCell co colUserNameModalHdr :: (IsDBTable m c, HasEntity a User, RenderMessage UniWorX msg) => msg -> (CryptoUUIDUser -> Route UniWorX) -> Colonnade Sortable a (DBCell m c) colUserNameModalHdr colHeader userLink = sortable (Just "user-name") (i18nCell colHeader) (cellHasUserModal userLink) +-- | like `colUserNameModalHdr` but without checking access rights before displaying the link (no risk, but non-admins may see links that are unusable for them) +colUserNameModalHdrAdmin :: (IsDBTable m c, HasEntity a User, RenderMessage UniWorX msg) => msg -> (CryptoUUIDUser -> Route UniWorX) -> Colonnade Sortable a (DBCell m c) +colUserNameModalHdrAdmin colHeader userLink = sortable (Just "user-name") (i18nCell colHeader) (cellHasUserModalAdmin userLink) + -- | Intended to work with @nameWidget@, showing highlighter Surname within Displayname sortUserName :: IsString a => (t -> E.SqlExpr (Entity User)) -> (a, SortColumn t r') sortUserName = ("user-name",) . sortUserNameBare @@ -442,8 +446,8 @@ fltrUserMatriculationUI :: DBFilterUI fltrUserMatriculationUI mPrev = prismAForm (singletonFilter "user-matriculation") mPrev $ aopt textField (fslI MsgTableUserMatriculation) -colUserMatriclenr :: (IsDBTable m c, HasEntity a User) => Colonnade Sortable a (DBCell m c) -colUserMatriclenr = sortable (Just "user-matriclenumber") (i18nCell MsgTableMatrikelNr) cellHasMatrikelnummerLinked +colUserMatriclenr :: (IsDBTable m c, HasEntity a User) => Bool -> Colonnade Sortable a (DBCell m c) +colUserMatriclenr isAdmin = sortable (Just "user-matriclenumber") (i18nCell MsgTableMatrikelNr) $ cellHasMatrikelnummerLinked isAdmin sortUserMatriclenr :: IsString d => (t -> E.SqlExpr (Entity User)) -> (d, SortColumn t r') sortUserMatriclenr queryUser = ("user-matriclenumber", SortColumn $ queryUser >>> (E.^. UserMatrikelnummer)) diff --git a/src/Handler/Utils/Widgets.hs b/src/Handler/Utils/Widgets.hs index 61c3c298e..1e5f6bdc2 100644 --- a/src/Handler/Utils/Widgets.hs +++ b/src/Handler/Utils/Widgets.hs @@ -123,15 +123,14 @@ editedByW fmt tm usr = do [whamlet|_{MsgUtilEditedBy usr ft}|] --- | like `modal`, but checks access rights to the link -modalAccess :: Bool -> Widget -> Widget -> Route UniWorX -> Widget -modalAccess writeAccess wdgtYes wdgtNo route = do +-- | like `modal`, but only conditionally displays the modal link only after checking access rights. WARNING: this might be too slow for large dbTable. Use `modalAccessCheckOnClick` instead +modalAccess :: Widget -> Widget -> Bool -> Route UniWorX -> Widget +modalAccess wdgtNo wdgtYes writeAccess route = do authOk <- liftHandler $ bool hasReadAccessTo hasWriteAccessTo writeAccess route if authOk then modal wdgtYes (Left $ SomeRoute route) else wdgtNo - ---------- -- HEAT -- ---------- diff --git a/src/Utils/Frontend/Modal.hs b/src/Utils/Frontend/Modal.hs index 304326ccc..d8180f58d 100644 --- a/src/Utils/Frontend/Modal.hs +++ b/src/Utils/Frontend/Modal.hs @@ -40,7 +40,7 @@ customModal Modal{..} = do -- | Create a link to a modal, does not check link, see `Handler.Utils.Widget.modalAccess` for a checking variant modal :: WidgetFor site () -- ^ Widget that represents the link - -> Either (SomeRoute site) (WidgetFor site ()) -- ^ Modal contant: either dynamic link or static widget + -> Either (SomeRoute site) (WidgetFor site ()) -- ^ Modal content: either dynamic link or static widget -> WidgetFor site () -- ^ result widget modal modalTrigger' modalContent = customModal Modal{..} where From eb541b4e91ecf86f7cba1c3b080675543a1f1dbd Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 28 Nov 2023 18:54:16 +0100 Subject: [PATCH 090/159] chore(firm): add action to change individual supervisors --- .../uniworx/categories/firm/de-de-formal.msg | 4 ++ messages/uniworx/categories/firm/en-eu.msg | 4 ++ .../send/send_notifications/de-de-formal.msg | 2 +- .../send/send_notifications/en-eu.msg | 2 +- src/Handler/Firm.hs | 43 ++++++++++++++++--- 5 files changed, 48 insertions(+), 7 deletions(-) diff --git a/messages/uniworx/categories/firm/de-de-formal.msg b/messages/uniworx/categories/firm/de-de-formal.msg index 0d872dba0..2772c864a 100644 --- a/messages/uniworx/categories/firm/de-de-formal.msg +++ b/messages/uniworx/categories/firm/de-de-formal.msg @@ -24,6 +24,10 @@ FirmActChangeContactFirmInfo: Firmenkontaktinformationen werden nur für neue Fi FirmActChangeContactFirmResult: Firmenkontaktinformationen geändert. Betrifft nur neue Firmenangehörige ohne eigene Kontaktinformationen FirmUserActNotify: Mitteilung versenden FirmUserActResetSupervision: Ansprechpartner auf Firmenstandard zurücksetzen +FirmUserActSetSupervisor: Ansprechpartner ändern +FirmNewSupervisor: Neue individuelle Ansprechpartner hinzufügen +FirmSetSupervisor: Existierende Ansprechpartner hinzufügen +FirmSetSupersReport nusr@Int64 nspr@Int64 nrem@Int64: Für #{nusr} Firmenangehörige wurden #{nspr} individuelle Ansprechpartner eingetragen#{bool "." (" und " <> tshow nrem <> " individuelle Ansprechpartnerbeziehungen gelöscht.") (nrem >0)} FirmUserActMkSuper: Zum Firmenansprechpartner ernennen FirmUserActChangeContact: Kontaktinformationen für ausgewählte Firmenangehörige ändern FirmResetSupervision rem@Int64 set@Int64: #{tshow set} Ansprechpartner gesetzt#{bool mempty (", " <> tshow rem <> " zuvor gelöscht") (rem > 0)} diff --git a/messages/uniworx/categories/firm/en-eu.msg b/messages/uniworx/categories/firm/en-eu.msg index 0554ce6e9..a91186f6e 100644 --- a/messages/uniworx/categories/firm/en-eu.msg +++ b/messages/uniworx/categories/firm/en-eu.msg @@ -24,6 +24,10 @@ FirmActChangeContactFirmInfo: The company contact data is only used for new comp FirmActChangeContactFirmResult: Company contact data changed, affecting future company associates without contact information only FirmUserActNotify: Send message FirmUserActResetSupervision: Reset supervisors to company default +FirmUserActSetSupervisor: Change supervision +FirmNewSupervisor: Appoint new individual supervisors +FirmSetSupervisor: Add existing supervisors +FirmSetSupersReport nusr@Int64 nspr@Int64 nrem@Int64: #{nspr} individal supervisors set for #{nusr} company associates#{bool "." (" and " <> tshow nrem <> " other individual supervisions terminated.") (nrem >0)} FirmResetSupervision rem set: #{tshow set} supervisors set#{bool mempty (", " <> tshow rem <> " deleted before") (rem > 0)} FirmUserActChangeContact: Change contact data for selected company associates FirmUserActMkSuper: Mark as company supervisor diff --git a/messages/uniworx/categories/send/send_notifications/de-de-formal.msg b/messages/uniworx/categories/send/send_notifications/de-de-formal.msg index b2a350b3e..cba2c8110 100644 --- a/messages/uniworx/categories/send/send_notifications/de-de-formal.msg +++ b/messages/uniworx/categories/send/send_notifications/de-de-formal.msg @@ -103,4 +103,4 @@ MailSupervisorNoCopy: Warnung: Diese Nachricht wurde nicht an den eigentlichen E MailSupervisedNote: Hinweis MailSupervisedBody: Eine Kopie dieser Nachricht wurde auch an folgende in FRADrive eingetragene Ansprechpartner gesendet: MailSupervisorReroute: Benachrichtigungsumleitung -MailSupervisorRerouteTooltip: Alle Benachrichtigungen werden stattdessen an alle Ansprechpartner mit Benachrichtigungsumleitung gesandt \ No newline at end of file +MailSupervisorRerouteTooltip: Alle Benachrichtigungen werden stattdessen an diese Ansprechpartner mit Benachrichtigungsumleitung gesandt \ No newline at end of file diff --git a/messages/uniworx/categories/send/send_notifications/en-eu.msg b/messages/uniworx/categories/send/send_notifications/en-eu.msg index b06a1c2eb..04fe30088 100644 --- a/messages/uniworx/categories/send/send_notifications/en-eu.msg +++ b/messages/uniworx/categories/send/send_notifications/en-eu.msg @@ -103,4 +103,4 @@ MailSupervisorNoCopy: Warning: This message was not sent to the original recipie MailSupervisedNote: Please note MailSupervisedBody: A copy of this message has been sent to all supervisors registered for you in FRADrive, namely: MailSupervisorReroute: Reroute notifications -MailSupervisorRerouteTooltip: All notification will be sent to all supervisors with notification rerouting instead \ No newline at end of file +MailSupervisorRerouteTooltip: All notification will be rerouted to these supervisors instead \ No newline at end of file diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index eb95a1e40..547c4e07c 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -664,6 +664,7 @@ postFirmAllR = do data FirmUserAction = FirmUserActNotify | FirmUserActResetSupervision + | FirmUserActSetSupervisor | FirmUserActMkSuper | FirmUserActChangeContact deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) @@ -672,11 +673,17 @@ data FirmUserAction = FirmUserActNotify nullaryPathPiece ''FirmUserAction $ camelToPathPiece' 3 embedRenderMessage ''UniWorX ''FirmUserAction id -data FirmUserActionData = FirmUserActNotifyData +data FirmUserActionData = FirmUserActNotifyData | FirmUserActResetSupervisionData { firmUserActResetKeepOldSupers :: Maybe Bool -- , firmUserActResetMutualSupervision :: Maybe Bool } + | FirmUserActSetSupervisorData + { firmUserActSetSuperNames :: Set Text + , firmUserActSetSuperIds :: [UserId] + , firmUserActSetSuperReroute :: Bool + , firmUserActSetSuperKeep :: Bool + } | FirmUserActMkSuperData { firmUserActMkSuperReroute :: Maybe Bool } | FirmUserActChangeContactData @@ -831,6 +838,11 @@ mkFirmUserTable isAdmin cid = do , singletonMap FirmUserActResetSupervision $ FirmUserActResetSupervisionData <$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep) (Just $ Just False) -- <*> aopt checkBoxField (fslI MsgFirmActResetMutualSupervision) (Just $ Just True ) + , singletonMap FirmUserActSetSupervisor $ FirmUserActSetSupervisorData + <$> apopt (textField & cfAnySeparatedSet) (fslI MsgFirmNewSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing + <*> apopt supervisorsField (fslI MsgFirmSetSupervisor) Nothing + <*> apopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip) (Just False) + <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep) (Just False) , singletonMap FirmUserActMkSuper $ FirmUserActMkSuperData <$> aopt checkBoxField (fslI MsgTableIsDefaultReroute) (Just $ Just True) , singletonMap FirmUserActChangeContact $ FirmUserActChangeContactData @@ -904,10 +916,6 @@ postFirmUsersR fsh = do formResult fusrRes $ \case (_, uids) | null uids -> addMessageI Error MsgUtilEmptyChoice - (FirmUserActMkSuperData{..}, Set.toList -> uids) -> do - nrMkSuper <- runDB $ updateWhereCount [UserCompanyUser <-. uids, UserCompanyCompany ==. cid] [UserCompanySupervisor =. True, UserCompanySupervisorReroute =. (firmUserActMkSuperReroute == Just True)] - addMessageI Info $ MsgFirmActAddSupersSet 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]) @@ -919,6 +927,31 @@ postFirmUsersR fsh = do newSupers <- addDefaultSupervisors cid uids addMessageI Info $ MsgFirmResetSupervision delSupers newSupers reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes + (FirmUserActSetSupervisorData{..}, set2NonEmpty (error "Unexpected empty user list in getFirmUserR action handler.") -> uids) -> do + avsUsers :: Map Text (Maybe UserId) <- sequenceA $ Map.fromSet guessAvsUser firmUserActSetSuperNames + let (usersFound', usersNotFound) = partition (is _Just . view _2) $ Map.toList avsUsers + usersFound = mapMaybe snd usersFound' + newSupers = Set.toList $ Set.fromList firmUserActSetSuperIds <> Set.fromList usersFound + nrSupers = fromIntegral $ length newSupers + nrUsers = fromIntegral $ length uids + unless (null usersNotFound) $ + let msgContent = [whamlet| + $newline never +

                                            + $forall (usr,_) <- usersNotFound +
                                          • #{usr} + |] + in addMessageModal Error (i18n . MsgCourseParticipantsRegisterNotFoundInAvs $ length usersNotFound) (Right msgContent) + delSupers <- runDB + $ bool (deleteSupervisors uids) (return 0) firmUserActSetSuperKeep + <* putMany [UserSupervisor s u firmUserActSetSuperReroute | u <- toList uids, s <- newSupers] + addMessageI Success $ MsgFirmSetSupersReport nrUsers nrSupers delSupers + reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes + + (FirmUserActMkSuperData{..}, Set.toList -> uids) -> do + nrMkSuper <- runDB $ updateWhereCount [UserCompanyUser <-. uids, UserCompanyCompany ==. cid] [UserCompanySupervisor =. True, UserCompanySupervisorReroute =. (firmUserActMkSuperReroute == Just True)] + addMessageI Info $ MsgFirmActAddSupersSet nrMkSuper Nothing + reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes (FirmUserActChangeContactData{..}, Set.toList -> uids) -> let changes = catMaybes [ (UserPostAddress =.) . Just <$> canonical firmUserActPostalAddr -- note that Nothing means no change and not delete address! From 57d9447b4f94b68e356461f6e25f6289ff03e430 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 29 Nov 2023 13:18:30 +0100 Subject: [PATCH 091/159] chore(firm): update table action access rights --- src/Handler/Firm.hs | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 547c4e07c..79236d154 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -530,7 +530,7 @@ mkFirmAllTable isAdmin uid = do dbtRowKey = (E.^. CompanyId) dbtProj = dbtProjId dbtColonnade = formColonnade $ mconcat - [ guardMonoid isAdmin $ dbSelect (applying _2) id (return . view (resultAllCompanyEntity . _entityKey)) + [ 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) -> @@ -748,7 +748,7 @@ mkFirmUserTable isAdmin cid = do dbtRowKey = queryUserUser >>> (E.^. UserId) dbtProj = dbtProjId dbtColonnade = formColonnade $ mconcat - [ guardMonoid isAdmin $ dbSelect (applying _2) id (return . view (resultUserUser . _entityKey)) + [ dbSelect (applying _2) id (return . view (resultUserUser . _entityKey)) , colUserNameModalHdr MsgTableCompanyUser ForProfileDataR , guardMonoid isAdmin $ sortable (Just "matriculation") (i18nCell MsgTableMatrikelNr) $ \(view resultUserUser -> entUsr ) -> cellHasMatrikelnummerLinkedAdmin entUsr , sortable (Just "personal-number") (i18nCell MsgCompanyPersonalNumber) $ \(view $ resultUserUser . _userCompanyPersonalNumber -> t) -> foldMap textCell t @@ -834,7 +834,7 @@ mkFirmUserTable isAdmin cid = do dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } acts :: Map FirmUserAction (AForm Handler FirmUserActionData) acts = mconcat - [ singletonMap FirmUserActNotify $ pure FirmUserActNotifyData + [ guardMonoid isAdmin $ singletonMap FirmUserActNotify $ pure FirmUserActNotifyData , singletonMap FirmUserActResetSupervision $ FirmUserActResetSupervisionData <$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep) (Just $ Just False) -- <*> aopt checkBoxField (fslI MsgFirmActResetMutualSupervision) (Just $ Just True ) @@ -883,7 +883,7 @@ mkFirmUserTable isAdmin cid = do getFirmUsersR, postFirmUsersR :: CompanyShorthand -> Handler Html getFirmUsersR = postFirmUsersR postFirmUsersR fsh = do - isAdmin <- checkAdmin + isAdmin <- checkAdmin let cid = CompanyKey fsh (( Entity{entityVal=Company{..}} , E.Value nrCompanyUsers @@ -1052,7 +1052,7 @@ mkFirmSuperTable isAdmin cid = do return (cmp E.^. CompanyName, cmp E.^. CompanyShorthand, usrCmp E.^. UserCompanySupervisor) return (usr, supervised, rerouted, cmps, supervisor, reroute) dbtColonnade = formColonnade $ mconcat - [ guardMonoid isAdmin $ dbSelect (applying _2) id (return . view (resultSuperUser . _entityKey)) + [ dbSelect (applying _2) id (return . view (resultSuperUser . _entityKey)) , colUserNameModalHdr MsgTableSupervisor ForProfileDataR , guardMonoid isAdmin $ sortable (Just "matriculation") (i18nCell MsgTableMatrikelNr) $ \(view resultSuperUser -> entUsr) -> cellHasMatrikelnummerLinkedAdmin entUsr , sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \( view resultSuperCompanies -> cmps) -> @@ -1092,7 +1092,7 @@ mkFirmSuperTable isAdmin cid = do dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } acts :: Map FirmSuperAction (AForm Handler FirmSuperActionData) acts = mconcat - [ singletonMap FirmSuperActNotify $ pure FirmSuperActNotifyData + [ guardMonoid isAdmin $ singletonMap FirmSuperActNotify $ pure FirmSuperActNotifyData , singletonMap FirmSuperActRMSuperDef $ FirmSuperActRMSuperDefData <$> aopt checkBoxField (fslI MsgFirmSuperActRMSuperActive) (Just $ Just True) ] From 929eb1b1755c1df294fb789928fb15665bce3628 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 29 Nov 2023 13:22:34 +0100 Subject: [PATCH 092/159] chore(firm): hide supervision key data by default --- messages/uniworx/categories/firm/de-de-formal.msg | 3 ++- messages/uniworx/categories/firm/en-eu.msg | 3 ++- templates/firm-users.hamlet | 4 +++- 3 files changed, 7 insertions(+), 3 deletions(-) diff --git a/messages/uniworx/categories/firm/de-de-formal.msg b/messages/uniworx/categories/firm/de-de-formal.msg index 2772c864a..2f5a807ef 100644 --- a/messages/uniworx/categories/firm/de-de-formal.msg +++ b/messages/uniworx/categories/firm/de-de-formal.msg @@ -51,4 +51,5 @@ TableIsDefaultSupervisor: Standardansprechpartner TableIsDefaultReroute: Standardumleitung FormFieldPostal: Benachrichtigungseinstellung FormFieldPostalTip: Gilt für alle Benachrichtigungen an diese Person, nicht nur für Umleitungen an diesen Ansprechpartner -FirmUserChanges n@Int64: Benachrichtigungseinstellung für #{n} Firmenangehörige wurden geändert \ No newline at end of file +FirmUserChanges n@Int64: Benachrichtigungseinstellung für #{n} Firmenangehörige wurden geändert +FirmSupervisionKeyData: Kennzahlen Ansprechpartner \ 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 a91186f6e..b14df5fba 100644 --- a/messages/uniworx/categories/firm/en-eu.msg +++ b/messages/uniworx/categories/firm/en-eu.msg @@ -51,4 +51,5 @@ TableIsDefaultSupervisor: Default supervisor TableIsDefaultReroute: Default reroute FormFieldPostal: Notification type FormFieldPostalTip: Affects all notifications to this person, not just reroutes to this supervisor -FirmUserChanges n: Notification settings changed for #{n} company associates \ No newline at end of file +FirmUserChanges n: Notification settings changed for #{n} company associates +FirmSupervisionKeyData: Supervision key data \ No newline at end of file diff --git a/templates/firm-users.hamlet b/templates/firm-users.hamlet index c10c06e13..05e90f8ed 100644 --- a/templates/firm-users.hamlet +++ b/templates/firm-users.hamlet @@ -8,7 +8,9 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later ^{formFirmAction} -
                                            +
                                            +

                                            + _{MsgFirmSupervisionKeyData}

                                          From ef9a5dc5a9bd729e4a8c5a8af2193fead366726e Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 29 Nov 2023 16:22:09 +0100 Subject: [PATCH 093/159] chore(firm): disallow supervisors on firm routes for now --- routes | 6 +++--- src/Handler/Firm.hs | 4 ++-- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/routes b/routes index df8c32fa2..b024c577f 100644 --- a/routes +++ b/routes @@ -113,12 +113,12 @@ /for/#CryptoUUIDUser/user ForProfileR GET POST !supervisor !self /for/#CryptoUUIDUser/user/profile ForProfileDataR GET !supervisor !self -/firms FirmAllR GET POST !supervisor +/firms FirmAllR GET POST -- not yet !supervisor /firms/comm/+Companies FirmsCommR GET POST /firm/#CompanyShorthand/debug FirmR GET POST /firm/#CompanyShorthand/comm FirmCommR GET POST -/firm/#CompanyShorthand FirmUsersR GET POST !supervisor -/firm/#CompanyShorthand/supers FirmSupersR GET POST !supervisor +/firm/#CompanyShorthand FirmUsersR GET POST -- not yet !supervisor +/firm/#CompanyShorthand/supers FirmSupersR GET POST -- not yet !supervisor /exam-office ExamOfficeR !exam-office: / EOExamsR GET POST !system-exam-office diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 79236d154..6e88accfa 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -735,7 +735,7 @@ mkFirmUserTable isAdmin cid = do return (usr E.^. UserId, usr E.^. UserDisplayName) let -- supervisorField :: Field Handler UserId - supervisorField = selectField $ procOptions rawSupers + -- supervisorField = selectField $ procOptions rawSupers supervisorsField = multiSelectField $ procOptions rawSupers fsh = unCompanyKey cid @@ -825,7 +825,7 @@ mkFirmUserTable isAdmin cid = do -- superField = selectField $ ???? dbtFilterUI mPrev = mconcat [ fltrUserNameEmailHdrUI MsgTableCompanyUser mPrev - , prismAForm (singletonFilter "supervisor-is" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift supervisorField) (fslI MsgFilterSupervisor) + -- , prismAForm (singletonFilter "supervisor-is" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift supervisorField) (fslI MsgFilterSupervisor) , prismAForm (multiFilter "supervisors-are" . maybePrism monoPathPieces) 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) From 75e4975c52e0ab1beff0251d9b654cdaab1d1af8 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 30 Nov 2023 18:32:25 +0100 Subject: [PATCH 094/159] refactor(mail): course and firm message are sent only once to each supervisor --- .../uniworx/categories/firm/de-de-formal.msg | 2 +- messages/uniworx/categories/firm/en-eu.msg | 2 +- src/Handler/Firm.hs | 2 +- src/Handler/Utils/Communication.hs | 40 +++--- src/Handler/Utils/Mail.hs | 8 +- src/Handler/Utils/Users.hs | 118 ++++++++++-------- src/Jobs/Handler/SendCourseCommunication.hs | 4 +- src/Mail.hs | 13 +- src/Utils/Set.hs | 13 +- 9 files changed, 121 insertions(+), 81 deletions(-) diff --git a/messages/uniworx/categories/firm/de-de-formal.msg b/messages/uniworx/categories/firm/de-de-formal.msg index 2f5a807ef..e53e55b50 100644 --- a/messages/uniworx/categories/firm/de-de-formal.msg +++ b/messages/uniworx/categories/firm/de-de-formal.msg @@ -34,7 +34,7 @@ FirmResetSupervision rem@Int64 set@Int64: #{tshow set} Ansprechpartner gesetzt#{ FirmSuperActNotify: Mitteilung versenden FirmSuperActRMSuperDef: Standard Firmenansprechpartner entfernen FirmSuperActRMSuperActive: Auch aktive Ansprechpartnerbeziehungen innerhalb dieser Firma beenden -FirmsNotification: Firmen Benachrichtigung versenden +FirmsNotification: Firmen E-Mail versenden FirmNotification fsh@CompanyShorthand: Benachrichtigung an #{fsh} versenden FirmsNotificationTitle: Firmen benachrichtigen FirmNotificationTitle fsh@CompanyShorthand: #{fsh} benachrichtigen diff --git a/messages/uniworx/categories/firm/en-eu.msg b/messages/uniworx/categories/firm/en-eu.msg index b14df5fba..be6d003ad 100644 --- a/messages/uniworx/categories/firm/en-eu.msg +++ b/messages/uniworx/categories/firm/en-eu.msg @@ -34,7 +34,7 @@ FirmUserActMkSuper: Mark as company supervisor FirmSuperActNotify: Send message FirmSuperActRMSuperDef: Remove as default supervisor FirmSuperActRMSuperActive: Also remove active supervisions within this company -FirmsNotification: Send company notification +FirmsNotification: Send company notification e-mail FirmNotification fsh: Send notification to company #{fsh} FirmsNotificationTitle: Company notification FirmNotificationTitle fsh@CompanyShorthand: #{fsh} notification diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 6e88accfa..fcf60c8a6 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -535,7 +535,7 @@ mkFirmAllTable isAdmin uid = do anchorCell (FirmUsersR $ companyShorthand firm) . toWgt $ companyName firm , sortable (Just "short") (i18nCell MsgTableCompanyShort) $ \(view resultAllCompany -> firm) -> let fsh = companyShorthand firm - in anchorCell (FirmUsersR fsh) $ toWgt fsh + in anchorCell (FirmSupersR 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 diff --git a/src/Handler/Utils/Communication.hs b/src/Handler/Utils/Communication.hs index 70c8e45e2..3783ba0aa 100644 --- a/src/Handler/Utils/Communication.hs +++ b/src/Handler/Utils/Communication.hs @@ -15,6 +15,7 @@ module Handler.Utils.Communication import Import import Handler.Utils +import Handler.Utils.Users import Jobs.Queue @@ -95,35 +96,40 @@ makeLenses_ ''Communication crJobsCourseCommunication, crTestJobsCourseCommunication :: CourseId -> Communication -> ConduitT () Job (YesodDB UniWorX) () crJobsCourseCommunication jCourse 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 JobSendCourseCommunication{..} + let jMailContent = cContent + (rawReceiverMails, rawReceiverIds) = setPartitionEithers cRecipients + adrReceiverMails = Set.map (Address Nothing . CI.original) rawReceiverMails + netReceiverAddresses <- lift $ do + netReceiverIds <- getReceiversFor $ jSender : Set.toList rawReceiverIds -- ensure supervisors get only one email + (userAddress . entityVal) <<$>> selectList [UserId <-. netReceiverIds] [] + -- let jAllRecipientAddresses = Set.fromList netReceiverAddresses <> adrReceiverMails + let jAllRecipientAddresses = Set.map getAddress (Set.fromList (AddressEqIgnoreName <$> netReceiverAddresses) <> Set.map AddressEqIgnoreName adrReceiverMails) + forM_ jAllRecipientAddresses $ \raddr -> + yield JobSendCourseCommunication{jRecipientEmail = Left $ CI.mk $ addressEmail raddr, ..} -- using Left UserMail ensures that no further reroutes are used, thus supervised supervisors also receive an email + crTestJobsCourseCommunication jCourse comm = do jSender <- requireAuthId - MsgRenderer mr <- getMsgRenderer let comm' = comm & _cContent . _ccSubject %~ Just . mr . MsgCommCourseTestSubject . fromMaybe (mr MsgUtilCommCourseSubject) crJobsCourseCommunication jCourse comm' .| C.filter ((== Right jSender) . jRecipientEmail) -crJobsFirmCommunication :: Companies -> Communication -> ConduitT () Job (YesodDB UniWorX) () +crJobsFirmCommunication, crTestFirmCommunication :: Companies -> Communication -> ConduitT () Job (YesodDB UniWorX) () crJobsFirmCommunication jCompanies 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{..} + let jMailContent = cContent + (rawReceiverMails, rawReceiverIds) = setPartitionEithers cRecipients + adrReceiverMails = Set.map (Address Nothing . CI.original) rawReceiverMails + netReceiverAddresses <- lift $ do + netReceiverIds <- getReceiversFor $ jSender : Set.toList rawReceiverIds -- ensure supervisors get only one email + (userAddress . entityVal) <<$>> selectList [UserId <-. netReceiverIds] [] + -- let jAllRecipientAddresses = Set.fromList netReceiverAddresses <> adrReceiverMails + let jAllRecipientAddresses = Set.map getAddress (Set.fromList (AddressEqIgnoreName <$> netReceiverAddresses) <> Set.map AddressEqIgnoreName adrReceiverMails) + forM_ jAllRecipientAddresses $ \raddr -> + yield JobSendFirmCommunication{jRecipientEmail = Left $ CI.mk $ addressEmail raddr, ..} -- using Left UserMail ensures that no further reroutes are used, thus supervised supervisors also receive an email -crTestFirmCommunication :: Companies -> Communication -> ConduitT () Job (YesodDB UniWorX) () crTestFirmCommunication jCompanies comm = do jSender <- requireAuthId MsgRenderer mr <- getMsgRenderer diff --git a/src/Handler/Utils/Mail.hs b/src/Handler/Utils/Mail.hs index 6a5e7be61..851928033 100644 --- a/src/Handler/Utils/Mail.hs +++ b/src/Handler/Utils/Mail.hs @@ -4,7 +4,8 @@ module Handler.Utils.Mail ( addRecipientsDB - , userAddress, userAddressFrom + , userAddress, userAddress' + , userAddressFrom , userMailT, userMailTdirect , addFileDB , addHtmlMarkdownAlternatives @@ -52,6 +53,11 @@ userAddress :: User -> Address userAddress User{userEmail, userDisplayEmail, userDisplayName} = Address (Just userDisplayName) $ CI.original $ pickValidEmail userDisplayEmail userEmail +userAddress' :: UserEmail -> UserEmail -> UserDisplayName -> Address +-- Like userAddress', but does not require a complete entity +userAddress' userEmail userDisplayEmail userDisplayName + = Address (Just userDisplayName) $ CI.original $ pickValidEmail userDisplayEmail userEmail + userAddressError :: (MonadHandler m, HandlerSite m ~ UniWorX) => User -> m (Bool, Address) userAddressError User{userEmail, userDisplayEmail, userDisplayName} | Just okEmail <- pickValidEmail' userDisplayEmail userEmail = pure (True, Address (Just userDisplayName) $ CI.original okEmail) diff --git a/src/Handler/Utils/Users.hs b/src/Handler/Utils/Users.hs index fb19f07a7..1e4a28487 100644 --- a/src/Handler/Utils/Users.hs +++ b/src/Handler/Utils/Users.hs @@ -1,7 +1,9 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-23 Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later +{-# LANGUAGE TypeApplications #-} + -- NOTE: Also see Handler.Utils.Profile for similar utilities module Handler.Utils.Users ( computeUserAuthenticationDigest @@ -17,7 +19,7 @@ module Handler.Utils.Users , getEmailAddress , getPostalAddress, getPostalPreferenceAndAddress , abbrvName - , getReceivers + , getReceivers, getReceiversFor , getSupervisees ) where @@ -38,7 +40,9 @@ import qualified Data.Set as Set -- import qualified Data.List as List import qualified Data.CaseInsensitive as CI -import qualified Database.Esqueleto.Legacy as E +import Database.Esqueleto.Experimental ((:&)(..)) +import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma +import qualified Database.Esqueleto.Legacy as EL (on,from) import qualified Database.Esqueleto.PostgreSQL as E import qualified Database.Esqueleto.Utils as E @@ -111,6 +115,14 @@ getReceivers uid = do then directResult else return (underling, receivers, uid `elem` (entityKey <$> receivers)) +-- | For user with mailTdirect, since this query will also return supervisors that have reroute supervisors themselves, who would then receive multiple duplicates +getReceiversFor :: (MonoFoldable mono, UserId ~ Element mono) => mono -> DB [UserId] +getReceiversFor uids = (E.unValue <<$>>) $ E.select $ E.distinct $ do + usr :& spr <- E.from $ E.table @User `E.leftJoin` E.table @UserSupervisor + `E.on` (\(usr :& spr) -> usr E.^. UserId E.=?. spr E.?. UserSupervisorUser E.&&. E.isTrue (spr E.?. UserSupervisorRerouteNotifications)) + E.where_ $ usr E.^. UserId `E.in_` E.vals uids + return $ E.coalesceDefault [spr E.?. UserSupervisorSupervisor] $ usr E.^. UserId + -- | return underlings for currently logged in user getSupervisees :: DB (Set UserId) getSupervisees = do @@ -185,7 +197,7 @@ guessUser (((Set.toList . toNullable) <$>) . Set.toList . dnfTerms -> criteria) GuessUserFirstName userFirstName' -> user E.^. UserFirstName `containsAsSet` userFirstName' go didLdap = do - let retrieveUsers = E.select . E.from $ \user -> do + let retrieveUsers = E.select . EL.from $ \user -> do E.where_ . E.or $ map (E.and . map (toSql user)) criteria when (is _Just mQueryLimit) $ (E.limit . fromJust) mQueryLimit return user @@ -307,7 +319,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do E.insertSelectWithConflict UniqueCourseFavourite - (E.from $ \courseFavourite -> do + (EL.from $ \courseFavourite -> do E.where_ $ courseFavourite E.^. CourseFavouriteUser E.==. E.val oldUserId return $ CourseFavourite E.<# E.val newUserId @@ -320,7 +332,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do E.insertSelectWithConflict UniqueCourseNoFavourite - (E.from $ \courseNoFavourite -> do + (EL.from $ \courseNoFavourite -> do E.where_ $ courseNoFavourite E.^. CourseNoFavouriteUser E.==. E.val oldUserId return $ CourseNoFavourite E.<# E.val newUserId @@ -331,7 +343,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do E.insertSelectWithConflict UniqueExamOfficeField - (E.from $ \examOfficeField -> do + (EL.from $ \examOfficeField -> do E.where_ $ examOfficeField E.^. ExamOfficeFieldOffice E.==. E.val oldUserId return $ ExamOfficeField E.<# E.val newUserId @@ -343,7 +355,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do E.insertSelectWithConflict UniqueExamOfficeUser - (E.from $ \examOfficeUser -> do + (EL.from $ \examOfficeUser -> do E.where_ $ examOfficeUser E.^. ExamOfficeUserOffice E.==. E.val oldUserId return $ ExamOfficeUser E.<# E.val newUserId @@ -353,7 +365,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do deleteWhere [ ExamOfficeUserOffice ==. oldUserId ] E.insertSelectWithConflict UniqueExamOfficeUser - (E.from $ \examOfficeUser -> do + (EL.from $ \examOfficeUser -> do E.where_ $ examOfficeUser E.^. ExamOfficeUserUser E.==. E.val oldUserId return $ ExamOfficeUser E.<# (examOfficeUser E.^. ExamOfficeUserOffice) @@ -362,7 +374,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do (\_current _excluded -> []) deleteWhere [ ExamOfficeUserUser ==. oldUserId ] - E.insertSelect . E.from $ \examOfficeResultSynced -> do + E.insertSelect . EL.from $ \examOfficeResultSynced -> do E.where_ $ examOfficeResultSynced E.^. ExamOfficeResultSyncedOffice E.==. E.val oldUserId return $ ExamOfficeResultSynced E.<# (examOfficeResultSynced E.^. ExamOfficeResultSyncedSchool) @@ -371,7 +383,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do E.<&> (examOfficeResultSynced E.^. ExamOfficeResultSyncedTime) deleteWhere [ ExamOfficeResultSyncedOffice ==. oldUserId ] - E.insertSelect . E.from $ \examOfficeExternalResultSynced -> do + E.insertSelect . EL.from $ \examOfficeExternalResultSynced -> do E.where_ $ examOfficeExternalResultSynced E.^. ExamOfficeExternalResultSyncedOffice E.==. E.val oldUserId return $ ExamOfficeExternalResultSynced E.<# (examOfficeExternalResultSynced E.^. ExamOfficeExternalResultSyncedSchool) @@ -400,7 +412,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do E.insertSelectWithConflict UniqueExternalExamStaff - (E.from $ \externalExamStaff -> do + (EL.from $ \externalExamStaff -> do E.where_ $ externalExamStaff E.^. ExternalExamStaffUser E.==. E.val oldUserId return $ ExternalExamStaff E.<# E.val newUserId @@ -415,7 +427,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do E.insertSelectWithConflict UniqueSubmissionUser - (E.from $ \submissionUser -> do + (EL.from $ \submissionUser -> do E.where_ $ submissionUser E.^. SubmissionUserUser E.==. E.val oldUserId return $ SubmissionUser E.<# E.val newUserId @@ -425,19 +437,19 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do deleteWhere [ SubmissionUserUser ==. oldUserId ] do - collisions <- E.select . E.from $ \((submissionGroupUserA `E.InnerJoin` submissionGroupA) `E.InnerJoin` (submissionGroupUserB `E.InnerJoin` submissionGroupB)) -> do - E.on $ submissionGroupB E.^. SubmissionGroupId E.==. submissionGroupUserB E.^. SubmissionGroupUserSubmissionGroup - E.on $ submissionGroupUserA E.^. SubmissionGroupUserSubmissionGroup E.!=. submissionGroupUserB E.^. SubmissionGroupUserSubmissionGroup + collisions <- E.select . EL.from $ \((submissionGroupUserA `E.InnerJoin` submissionGroupA) `E.InnerJoin` (submissionGroupUserB `E.InnerJoin` submissionGroupB)) -> do + EL.on $ submissionGroupB E.^. SubmissionGroupId E.==. submissionGroupUserB E.^. SubmissionGroupUserSubmissionGroup + EL.on $ submissionGroupUserA E.^. SubmissionGroupUserSubmissionGroup E.!=. submissionGroupUserB E.^. SubmissionGroupUserSubmissionGroup E.&&. submissionGroupUserA E.^. SubmissionGroupUserUser E.==. E.val oldUserId E.&&. submissionGroupUserB E.^. SubmissionGroupUserUser E.==. E.val newUserId - E.on $ submissionGroupA E.^. SubmissionGroupId E.==. submissionGroupUserA E.^. SubmissionGroupUserSubmissionGroup + EL.on $ submissionGroupA E.^. SubmissionGroupId E.==. submissionGroupUserA E.^. SubmissionGroupUserSubmissionGroup E.where_ $ submissionGroupA E.^. SubmissionGroupCourse E.==. submissionGroupB E.^. SubmissionGroupCourse return (submissionGroupUserA, submissionGroupUserB) forM_ collisions $ \(submissionGroupUserA, submissionGroupUserB) -> tellWarning $ UserAssimilateSubmissionGroupUserMultiple submissionGroupUserA submissionGroupUserB E.insertSelectWithConflict UniqueSubmissionGroupUser - (E.from $ \submissionGroupUser -> do + (EL.from $ \submissionGroupUser -> do E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. E.val oldUserId return $ SubmissionGroupUser E.<# (submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup) @@ -454,7 +466,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do E.insertSelectWithConflict UniqueLecturer - (E.from $ \lecturer -> do + (EL.from $ \lecturer -> do E.where_ $ lecturer E.^. LecturerUser E.==. E.val oldUserId return $ Lecturer E.<# E.val newUserId @@ -466,7 +478,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do E.insertSelectWithConflict UniqueParticipant - (E.from $ \courseParticipant -> do + (EL.from $ \courseParticipant -> do E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. E.val oldUserId return $ CourseParticipant E.<# (courseParticipant E.^. CourseParticipantCourse) @@ -496,7 +508,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do E.insertSelectWithConflict UniqueCourseUserExamOfficeOptOut - (E.from $ \examOfficeOptOut -> do + (EL.from $ \examOfficeOptOut -> do E.where_ $ examOfficeOptOut E.^. CourseUserExamOfficeOptOutUser E.==. E.val oldUserId return $ CourseUserExamOfficeOptOut E.<# (examOfficeOptOut E.^. CourseUserExamOfficeOptOutCourse) @@ -508,7 +520,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do E.insertSelectWithConflict UniqueUserFunction - (E.from $ \userFunction -> do + (EL.from $ \userFunction -> do E.where_ $ userFunction E.^. UserFunctionUser E.==. E.val oldUserId return $ UserFunction E.<# E.val newUserId @@ -520,7 +532,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do E.insertSelectWithConflict UniqueUserSystemFunction - (E.from $ \userSystemFunction -> do + (EL.from $ \userSystemFunction -> do E.where_ $ userSystemFunction E.^. UserSystemFunctionUser E.==. E.val oldUserId return $ UserSystemFunction E.<# E.val newUserId @@ -533,7 +545,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do E.insertSelectWithConflict UniqueUserExamOffice - (E.from $ \userExamOffice -> do + (EL.from $ \userExamOffice -> do E.where_ $ userExamOffice E.^. UserExamOfficeUser E.==. E.val oldUserId return $ UserExamOffice E.<# E.val newUserId @@ -544,7 +556,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do E.insertSelectWithConflict UniqueUserSchool - (E.from $ \userSchool -> do + (EL.from $ \userSchool -> do E.where_ $ userSchool E.^. UserSchoolUser E.==. E.val oldUserId return $ UserSchool E.<# E.val newUserId @@ -557,7 +569,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do updateWhere [ UserGroupMemberUser ==. oldUserId, UserGroupMemberPrimary ==. Active ] [ UserGroupMemberUser =. newUserId ] E.insertSelectWithConflict UniqueUserGroupMember - (E.from $ \userGroupMember -> do + (EL.from $ \userGroupMember -> do E.where_ $ userGroupMember E.^. UserGroupMemberUser E.==. E.val oldUserId return $ UserGroupMember E.<# (userGroupMember E.^. UserGroupMemberGroup) @@ -568,8 +580,8 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do deleteWhere [ UserGroupMemberUser ==. oldUserId ] do - collisions <- E.select . E.from $ \(examRegistrationA `E.InnerJoin` examRegistrationB) -> do - E.on $ examRegistrationA E.^. ExamRegistrationExam E.==. examRegistrationB E.^. ExamRegistrationExam + collisions <- E.select . EL.from $ \(examRegistrationA `E.InnerJoin` examRegistrationB) -> do + EL.on $ examRegistrationA E.^. ExamRegistrationExam E.==. examRegistrationB E.^. ExamRegistrationExam E.&&. examRegistrationA E.^. ExamRegistrationUser E.==. E.val oldUserId E.&&. examRegistrationB E.^. ExamRegistrationUser E.==. E.val newUserId E.where_ $ examRegistrationA E.^. ExamRegistrationOccurrence E.!=. examRegistrationB E.^. ExamRegistrationOccurrence @@ -580,7 +592,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do -> tellWarning $ UserAssimilateExamRegistrationDifferentOccurrence oldExamRegistration newExamRegistration E.insertSelectWithConflict UniqueExamRegistration - (E.from $ \examRegistration -> do + (EL.from $ \examRegistration -> do E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. E.val oldUserId return $ ExamRegistration E.<# (examRegistration E.^. ExamRegistrationExam) @@ -592,8 +604,8 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do deleteWhere [ ExamRegistrationUser ==. oldUserId ] do - collision <- E.selectMaybe . E.from $ \(examPartResultA `E.InnerJoin` examPartResultB) -> do - E.on $ examPartResultA E.^. ExamPartResultExamPart E.==. examPartResultB E.^. ExamPartResultExamPart + collision <- E.selectMaybe . EL.from $ \(examPartResultA `E.InnerJoin` examPartResultB) -> do + EL.on $ examPartResultA E.^. ExamPartResultExamPart E.==. examPartResultB E.^. ExamPartResultExamPart E.&&. examPartResultA E.^. ExamPartResultUser E.==. E.val oldUserId E.&&. examPartResultB E.^. ExamPartResultUser E.==. E.val newUserId E.where_ $ examPartResultA E.^. ExamPartResultResult E.!=. examPartResultB E.^. ExamPartResultResult @@ -602,7 +614,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do -> tellError $ UserAssimilateExamPartResultDifferentResult oldExamPartResult newExamPartResult E.insertSelectWithConflict UniqueExamPartResult - (E.from $ \examPartResult -> do + (EL.from $ \examPartResult -> do E.where_ $ examPartResult E.^. ExamPartResultUser E.==. E.val oldUserId return $ ExamPartResult E.<# (examPartResult E.^. ExamPartResultExamPart) @@ -614,8 +626,8 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do deleteWhere [ ExamPartResultUser ==. oldUserId ] do - collision <- E.selectMaybe . E.from $ \(examBonusA `E.InnerJoin` examBonusB) -> do - E.on $ examBonusA E.^. ExamBonusExam E.==. examBonusB E.^. ExamBonusExam + collision <- E.selectMaybe . EL.from $ \(examBonusA `E.InnerJoin` examBonusB) -> do + EL.on $ examBonusA E.^. ExamBonusExam E.==. examBonusB E.^. ExamBonusExam E.&&. examBonusA E.^. ExamBonusUser E.==. E.val oldUserId E.&&. examBonusB E.^. ExamBonusUser E.==. E.val newUserId E.where_ $ examBonusA E.^. ExamBonusBonus E.!=. examBonusB E.^. ExamBonusBonus @@ -624,7 +636,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do -> tellError $ UserAssimilateExamBonusDifferentBonus oldExamBonus newExamBonus E.insertSelectWithConflict UniqueExamBonus - (E.from $ \examBonus -> do + (EL.from $ \examBonus -> do E.where_ $ examBonus E.^. ExamBonusUser E.==. E.val oldUserId return $ ExamBonus E.<# (examBonus E.^. ExamBonusExam) @@ -657,8 +669,8 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do Entity newECId _ <- upsert examCorrector{ examCorrectorUser = newUserId } [] E.insertSelectWithConflict UniqueExamPartCorrector - (E.from $ \(examPartCorrector `E.InnerJoin` examCorrector') -> do - E.on $ examCorrector' E.^. ExamCorrectorId E.==. examPartCorrector E.^. ExamPartCorrectorCorrector + (EL.from $ \(examPartCorrector `E.InnerJoin` examCorrector') -> do + EL.on $ examCorrector' E.^. ExamCorrectorId E.==. examPartCorrector E.^. ExamPartCorrectorCorrector E.where_ $ examCorrector' E.^. ExamCorrectorUser E.==. E.val oldUserId E.&&. examCorrector' E.^. ExamCorrectorExam E.==. E.val (examCorrectorExam examCorrector) return $ ExamPartCorrector @@ -704,8 +716,8 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do in runConduit $ getSheetCorrectors .| C.mapM_ upsertSheetCorrector do - collision <- E.selectMaybe . E.from $ \(personalisedSheetFileA `E.InnerJoin` personalisedSheetFileB) -> do - E.on $ personalisedSheetFileA E.^. PersonalisedSheetFileSheet E.==. personalisedSheetFileB E.^. PersonalisedSheetFileSheet + collision <- E.selectMaybe . EL.from $ \(personalisedSheetFileA `E.InnerJoin` personalisedSheetFileB) -> do + EL.on $ personalisedSheetFileA E.^. PersonalisedSheetFileSheet E.==. personalisedSheetFileB E.^. PersonalisedSheetFileSheet E.&&. personalisedSheetFileA E.^. PersonalisedSheetFileType E.==. personalisedSheetFileB E.^. PersonalisedSheetFileType E.&&. personalisedSheetFileA E.^. PersonalisedSheetFileTitle E.==. personalisedSheetFileB E.^. PersonalisedSheetFileTitle E.&&. personalisedSheetFileA E.^. PersonalisedSheetFileUser E.==. E.val oldUserId @@ -716,7 +728,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do -> tellError $ UserAssimilatePersonalisedSheetFileDifferentContent oldPersonalisedSheetFile newPersonalisedSheetFile E.insertSelectWithConflict UniquePersonalisedSheetFile - (E.from $ \personalisedSheetFile -> do + (EL.from $ \personalisedSheetFile -> do E.where_ $ personalisedSheetFile E.^. PersonalisedSheetFileUser E.==. E.val oldUserId return $ PersonalisedSheetFile E.<# (personalisedSheetFile E.^. PersonalisedSheetFileSheet) @@ -731,7 +743,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do E.insertSelectWithConflict UniqueTutor - (E.from $ \tutor -> do + (EL.from $ \tutor -> do E.where_ $ tutor E.^. TutorUser E.==. E.val oldUserId return $ Tutor E.<# (tutor E.^. TutorTutorial) @@ -740,12 +752,12 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do (\_current _excluded -> []) do - collision <- E.selectMaybe . E.from $ \((tutorialA `E.InnerJoin` tutorialParticipantA) `E.InnerJoin` (tutorialB `E.InnerJoin` tutorialParticipantB)) -> do - E.on $ tutorialParticipantB E.^. TutorialParticipantTutorial E.==. tutorialB E.^. TutorialId - E.on $ tutorialA E.^. TutorialCourse E.==. tutorialB E.^. TutorialCourse + collision <- E.selectMaybe . EL.from $ \((tutorialA `E.InnerJoin` tutorialParticipantA) `E.InnerJoin` (tutorialB `E.InnerJoin` tutorialParticipantB)) -> do + EL.on $ tutorialParticipantB E.^. TutorialParticipantTutorial E.==. tutorialB E.^. TutorialId + EL.on $ tutorialA E.^. TutorialCourse E.==. tutorialB E.^. TutorialCourse E.&&. tutorialParticipantB E.^. TutorialParticipantUser E.==. E.val newUserId E.&&. tutorialParticipantA E.^. TutorialParticipantUser E.==. E.val oldUserId - E.on $ tutorialParticipantA E.^. TutorialParticipantTutorial E.==. tutorialA E.^. TutorialId + EL.on $ tutorialParticipantA E.^. TutorialParticipantTutorial E.==. tutorialA E.^. TutorialId E.where_ $ tutorialA E.^. TutorialId E.!=. tutorialB E.^. TutorialId E.&&. tutorialA E.^. TutorialRegGroup E.==. tutorialB E.^. TutorialRegGroup return (tutorialParticipantA, tutorialParticipantB) @@ -753,7 +765,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do -> tellError $ UserAssimilateTutorialParticipantCollidingRegGroups tutorialUserA tutorialUserB E.insertSelectWithConflict UniqueTutorialParticipant - (E.from $ \tutorialParticipant -> do + (EL.from $ \tutorialParticipant -> do E.where_ $ tutorialParticipant E.^. TutorialParticipantUser E.==. E.val oldUserId return $ TutorialParticipant E.<# (tutorialParticipant E.^. TutorialParticipantTutorial) @@ -764,7 +776,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do E.insertSelectWithConflict UniqueSystemMessageHidden - (E.from $ \systemMessageHidden -> do + (EL.from $ \systemMessageHidden -> do E.where_ $ systemMessageHidden E.^. SystemMessageHiddenUser E.==. E.val oldUserId return $ SystemMessageHidden E.<# (systemMessageHidden E.^. SystemMessageHiddenMessage) @@ -789,7 +801,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do ] E.insertSelectWithConflict UniqueRelevantStudyFeatures - (E.from $ \relevantStudyFeatures -> do + (EL.from $ \relevantStudyFeatures -> do E.where_ $ relevantStudyFeatures E.^. RelevantStudyFeaturesStudyFeatures E.==. E.val oldSFId return $ RelevantStudyFeatures E.<# (relevantStudyFeatures E.^. RelevantStudyFeaturesTerm) @@ -815,8 +827,8 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do unless (Set.null qResolvable) $ deleteWhere [ LmsUserUser ==. oldUserId, LmsUserQualification <-. Set.toList qResolvable ] -- delete conflicting and finished LMS, which are still within auditDuration updateWhere [ LmsUserUser ==. oldUserId ] [ LmsUserUser =. newUserId ] updateWhere [ QualificationEditUser ==. oldUserId ] [ QualificationEditUser =. newUserId ] - usrQualis <- E.select $ E.from $ \(oldQual `E.LeftOuterJoin` newQual) -> do - E.on ( newQual E.?. QualificationUserQualification E.?=. oldQual E.^. QualificationUserQualification + usrQualis <- E.select $ EL.from $ \(oldQual `E.LeftOuterJoin` newQual) -> do + EL.on ( newQual E.?. QualificationUserQualification E.?=. oldQual E.^. QualificationUserQualification E.&&. newQual E.?. QualificationUserUser E.?=. E.val newUserId ) E.where_ $ oldQual E.^. QualificationUserUser E.==. E.val oldUserId @@ -838,7 +850,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do -- Supervision is fully merged E.insertSelectWithConflict UniqueUserSupervisor - (E.from $ \userSupervisor -> do + (EL.from $ \userSupervisor -> do E.where_ $ userSupervisor E.^. UserSupervisorSupervisor E.==. E.val oldUserId return $ UserSupervisor E.<# E.val newUserId @@ -850,7 +862,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do E.insertSelectWithConflict UniqueUserSupervisor - (E.from $ \userSupervisor -> do + (EL.from $ \userSupervisor -> do E.where_ $ userSupervisor E.^. UserSupervisorUser E.==. E.val oldUserId return $ UserSupervisor E.<# (userSupervisor E.^. UserSupervisorSupervisor) @@ -863,7 +875,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do -- Companies, in conflict, keep the newUser-Company as is E.insertSelectWithConflict UniqueUserCompany - (E.from $ \userCompany -> do + (EL.from $ \userCompany -> do E.where_ $ userCompany E.^. UserCompanyUser E.==. E.val oldUserId return $ UserCompany E.<# E.val newUserId diff --git a/src/Jobs/Handler/SendCourseCommunication.hs b/src/Jobs/Handler/SendCourseCommunication.hs index 4edaa2d4d..1a065726c 100644 --- a/src/Jobs/Handler/SendCourseCommunication.hs +++ b/src/Jobs/Handler/SendCourseCommunication.hs @@ -31,7 +31,7 @@ dispatchJobSendCourseCommunication jRecipientEmail jAllRecipientAddresses jCours (sender, Course{..}) <- runDB $ (,) <$> getJust jSender <*> getJust jCourse - either (\email -> mailT def . (assign _mailTo (pure . Address Nothing $ CI.original email) *>)) userMailT jRecipientEmail $ do + either (\email -> mailT def . (assign _mailTo (pure . Address Nothing $ CI.original email) *>)) userMailT jRecipientEmail $ do -- userMailT obeys reroutes, userMailT direct does not MsgRenderer mr <- getMailMsgRenderer void $ setMailObjectUUID jMailObjectUUID @@ -59,7 +59,7 @@ dispatchJobSendFirmCommunication jRecipientEmail jAllRecipientAddresses _jCompan -- <$> 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 + either (\email -> mailT def . (assign _mailTo (pure . Address Nothing $ CI.original email) *>)) userMailT jRecipientEmail $ do -- userMailT obeys reroutes, userMailT direct does not MsgRenderer mr <- getMailMsgRenderer void $ setMailObjectUUID jMailObjectUUID diff --git a/src/Mail.hs b/src/Mail.hs index 6f8879b71..4f9ab00d6 100644 --- a/src/Mail.hs +++ b/src/Mail.hs @@ -10,6 +10,7 @@ module Mail ( -- * Structured MIME emails module Network.Mail.Mime + , AddressEqIgnoreName(..) -- * MailT , MailT, defMailT , MailSmtpData(..), _smtpEnvelopeFrom, _smtpRecipients @@ -137,6 +138,14 @@ import Network.HTTP.Types.Header (hETag) import Web.HttpApiData (ToHttpApiData(toHeader)) +newtype AddressEqIgnoreName = AddressEqIgnoreName { getAddress :: Address } + deriving (Show, Generic) +instance Eq AddressEqIgnoreName where + (==) = (==) `on` (addressEmail . getAddress) +instance Ord AddressEqIgnoreName where + compare = compare `on` (addressEmail . getAddress) + + makeLenses_ ''Address makeLenses_ ''Mail makeLenses_ ''Part @@ -339,8 +348,8 @@ defMailT ls (MailT mailC) = do return $ mail0 & _mailFrom .~ fromAddress & _mailReplyTo .~ sender - mailRerouteTo' <- mailRerouteTo - let (mail2, smtpData1) = maybe (mail1,smtpData0) switchRecipient mailRerouteTo' -- switch receiver on enveloper, if rerouting is active + mailRerouteTo' <- mailRerouteTo -- this is the general reroute, e.g. for test instances, not for supervisors + let (mail2, smtpData1) = maybe (mail1,smtpData0) switchRecipient mailRerouteTo' -- switch receiver on envelope, if rerouting is active switchRecipient rerouteTo = (Mime.addPart switchInfo mail1, smtpData0 { smtpRecipients = Set.singleton rerouteTo } ) switchInfo = [plainPart $ LT.fromStrict $ "Due to setting 'mail-reroute-to', this mail was diverted; it was intended to be sent to: " <> tshow (smtpRecipients smtpData0)] mail3 <- liftIO $ LBS.toStrict <$> renderMail' mail2 diff --git a/src/Utils/Set.hs b/src/Utils/Set.hs index 7ef167280..79e11c662 100644 --- a/src/Utils/Set.hs +++ b/src/Utils/Set.hs @@ -5,7 +5,7 @@ module Utils.Set ( setIntersectNotOne , setIntersections -, setMapMaybe +, setMapMaybe, setMapMaybeMonotonic , concatMapSet , setSymmDiff , setProduct @@ -56,6 +56,10 @@ setIntersections (h:t) = foldl' Set.intersection h t setMapMaybe :: Ord b => (a -> Maybe b) -> Set a -> Set b setMapMaybe f = Set.fromList . mapMaybe f . Set.toList +-- | like `setMapMaybe`, but only when f is strictly increasing +setMapMaybeMonotonic :: (a -> Maybe b) -> Set a -> Set b +setMapMaybeMonotonic f = Set.fromDistinctAscList . mapMaybe f . Set.toAscList + concatMapSet :: Ord b => (a -> Set b) -> Set a -> Set b concatMapSet f = Set.foldl ((. f) . (<>)) mempty -- concatMapSet f = foldMap f --- requires Ord a as well, which we ought to have anyway @@ -68,8 +72,11 @@ setProduct :: Set a -> Set b -> Set (a, b) -- ^ Depends on the valid internal structure of the given sets setProduct (Set.toAscList -> as) (Set.toAscList -> bs) = Set.fromDistinctAscList $ (,) <$> as <*> bs -setPartitionEithers :: (Ord a, Ord b) => Set (Either a b) -> (Set a, Set b) -setPartitionEithers = (,) <$> setMapMaybe (preview _Left) <*> setMapMaybe (preview _Right) +-- setPartitionEithers :: (Ord a, Ord b) => Set (Either a b) -> (Set a, Set b) +-- setPartitionEithers = (,) <$> setMapMaybe (preview _Left) <*> setMapMaybe (preview _Right) +-- +setPartitionEithers :: Set (Either a b) -> (Set a, Set b) +setPartitionEithers = (,) <$> setMapMaybeMonotonic (preview _Left) <*> setMapMaybeMonotonic (preview _Right) setFromFunc :: (Finite k, Ord k) => (k -> Bool) -> Set k setFromFunc = Set.fromList . flip filter universeF From b1ce55597ec44774f5e293d176236bb35144b0ac Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 1 Dec 2023 13:29:38 +0100 Subject: [PATCH 095/159] chore(lms): remove debug code --- .../uniworx/categories/firm/de-de-formal.msg | 2 +- messages/uniworx/categories/firm/en-eu.msg | 2 +- messages/uniworx/misc/de-de-formal.msg | 1 + messages/uniworx/misc/en-eu.msg | 1 + models/users.model | 2 +- routes | 1 - src/Foundation/Navigation.hs | 11 --- src/Handler/Admin/Avs.hs | 2 +- src/Handler/Firm.hs | 67 +------------------ src/Handler/Users.hs | 2 +- src/Handler/Utils/Table/Cells.hs | 2 +- 11 files changed, 11 insertions(+), 82 deletions(-) diff --git a/messages/uniworx/categories/firm/de-de-formal.msg b/messages/uniworx/categories/firm/de-de-formal.msg index e53e55b50..1668a06c3 100644 --- a/messages/uniworx/categories/firm/de-de-formal.msg +++ b/messages/uniworx/categories/firm/de-de-formal.msg @@ -35,7 +35,7 @@ FirmSuperActNotify: Mitteilung versenden FirmSuperActRMSuperDef: Standard Firmenansprechpartner entfernen FirmSuperActRMSuperActive: Auch aktive Ansprechpartnerbeziehungen innerhalb dieser Firma beenden FirmsNotification: Firmen E-Mail versenden -FirmNotification fsh@CompanyShorthand: Benachrichtigung an #{fsh} versenden +FirmNotification fsh@CompanyShorthand: E-Mail an #{fsh} senden FirmsNotificationTitle: Firmen benachrichtigen FirmNotificationTitle fsh@CompanyShorthand: #{fsh} benachrichtigen FilterSupervisor: Hat aktiven Ansprechpartner diff --git a/messages/uniworx/categories/firm/en-eu.msg b/messages/uniworx/categories/firm/en-eu.msg index be6d003ad..7539257d1 100644 --- a/messages/uniworx/categories/firm/en-eu.msg +++ b/messages/uniworx/categories/firm/en-eu.msg @@ -35,7 +35,7 @@ FirmSuperActNotify: Send message FirmSuperActRMSuperDef: Remove as default supervisor FirmSuperActRMSuperActive: Also remove active supervisions within this company FirmsNotification: Send company notification e-mail -FirmNotification fsh: Send notification to company #{fsh} +FirmNotification fsh: Send e-mail to #{fsh} FirmsNotificationTitle: Company notification FirmNotificationTitle fsh@CompanyShorthand: #{fsh} notification FilterSupervisor: Has active supervisor diff --git a/messages/uniworx/misc/de-de-formal.msg b/messages/uniworx/misc/de-de-formal.msg index ef68eb735..eaa02c0fa 100644 --- a/messages/uniworx/misc/de-de-formal.msg +++ b/messages/uniworx/misc/de-de-formal.msg @@ -10,6 +10,7 @@ BoolIrrelevant !ident-ok: — FieldPrimary: Hauptfach FieldSecondary: Nebenfach MultiEmailFieldTip: Es sind mehrere, Komma-separierte, E-Mail-Adressen möglich +MultiSelectTip: Mehrfachauswahl mit Strg-Klick WeekDay: Wochentag LdapIdentificationOrEmail: Fraport AG-Kennung / E-Mail-Adresse Months num@Int64: #{num} #{pluralDE num "Monat" "Monate"} diff --git a/messages/uniworx/misc/en-eu.msg b/messages/uniworx/misc/en-eu.msg index 97423bdda..5b6b15f5b 100644 --- a/messages/uniworx/misc/en-eu.msg +++ b/messages/uniworx/misc/en-eu.msg @@ -10,6 +10,7 @@ BoolIrrelevant: — FieldPrimary: Major FieldSecondary: Minor MultiEmailFieldTip: Multiple emails addresses may be specified (comma-separated) +MultiSelectTip: Multiple selection via Ctrl-Click WeekDay: Day of the week LdapIdentificationOrEmail: Fraport AG-Kennung / email address Months num: #{num} #{pluralEN num "Month" "Months"} diff --git a/models/users.model b/models/users.model index b29f71eb3..b23fe85b2 100644 --- a/models/users.model +++ b/models/users.model @@ -2,7 +2,7 @@ -- -- SPDX-License-Identifier: AGPL-3.0-or-later --- The files in /models determine the database scheme. +-- The files in /models determine t he database scheme. -- The organisational split into several files has no operational effects. -- White-space and case matters: Each SQL table is named in 1st column of this file -- Indendent lower-case lines describe the SQL-columns of the table with name, type and options diff --git a/routes b/routes index b024c577f..0ea40300c 100644 --- a/routes +++ b/routes @@ -115,7 +115,6 @@ /firms FirmAllR GET POST -- not yet !supervisor /firms/comm/+Companies FirmsCommR GET POST -/firm/#CompanyShorthand/debug FirmR GET POST /firm/#CompanyShorthand/comm FirmCommR GET POST /firm/#CompanyShorthand FirmUsersR GET POST -- not yet !supervisor /firm/#CompanyShorthand/supers FirmSupersR GET POST -- not yet !supervisor diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index b029cc0ee..1d0258e31 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -125,7 +125,6 @@ breadcrumb ProblemAvsErrorR = i18nCrumb MsgProblemsAvsErrorHeading $ Just 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 @@ -2417,16 +2416,6 @@ pageActions ApiDocsR = return , navChildren = [] } ] -pageActions (FirmR fsh) = return - [ NavPageActionPrimary - { navLink = defNavLink MsgTableCompanyNrSupers $ FirmSupersR fsh - , navChildren = [] - } - , NavPageActionPrimary - { navLink = defNavLink MsgTableCompanyNrUsers $ FirmUsersR fsh - , navChildren = [] - } - ] pageActions (FirmUsersR fsh) = return [ NavPageActionPrimary { navLink = defNavLink MsgTableCompanyNrSupers $ FirmSupersR fsh diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs index f65f44f50..9521912c9 100644 --- a/src/Handler/Admin/Avs.hs +++ b/src/Handler/Admin/Avs.hs @@ -558,7 +558,7 @@ mkLicenceTable apidStatus dbtIdent aLic apids = do 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' + (\(E.Value cmpSh, E.Value cmpName, E.Value cmpSpr) -> simpleLink (citext2widget cmpName) (FirmUsersR cmpSh) <> bool mempty icnSuper cmpSpr) <$> companies' pure $ intercalate (text2widget "; ") companies , sortable (Just "qualification") (i18nCell MsgTableQualifications) $ \(preview resultQualification -> q) -> cellMaybe lmsShortCell q diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index fcf60c8a6..881be6223 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -7,8 +7,7 @@ {-# LANGUAGE TypeApplications #-} module Handler.Firm - ( getFirmAllR , postFirmAllR - , getFirmR , postFirmR + ( getFirmAllR , postFirmAllR , getFirmUsersR , postFirmUsersR , getFirmSupersR, postFirmSupersR , getFirmCommR , postFirmCommR @@ -415,65 +414,6 @@ firmCountUserSupervisorsReroute usrCmp = E.subSelectCount $ do E.&&. usrSpr E.^. UserSupervisorRerouteNotifications ------------------- --- Debug Handler - -getFirmR, postFirmR :: CompanyShorthand -> Handler Html -getFirmR = postFirmR -postFirmR fsh = do - let cid = CompanyKey fsh - cusers <- runDB $ do - cusers <- selectList [UserCompanyCompany ==. cid] [] - selectList [UserId <-. fmap (userCompanyUser . entityVal) cusers] [Asc UserDisplayName] - csuper <- runDB $ do - csuper <- selectList [UserCompanyCompany ==. cid, UserCompanySupervisor ==. True] [] - selectList [UserId <-. fmap (userCompanyUser . entityVal) csuper] [Asc UserDisplayName] - 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', usr E.^. UserPrefersPostal) - - 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 -
                                          • ^{linkUserWidget ForProfileDataR u} - -

                                            #{length cactSuper} Active Supervisors for Employees -
                                              - $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} # - #{iconLetterOrEmail prefPost} # - $maybe csh <- mbCsh - $if csh /= cid - from foreign company #{unCompanyKey csh} - $else - from this company - $nothing - having no associated company - -

                                              #{length cusers} Employees -
                                                - $forall u <- cusers -
                                              • ^{linkUserWidget ForProfileDataR u} - - In the end, this needs to be a dbTable, of course! - |] - - ----------------------- -- All Firms Table @@ -536,8 +476,7 @@ mkFirmAllTable isAdmin uid = do , sortable (Just "short") (i18nCell MsgTableCompanyShort) $ \(view resultAllCompany -> firm) -> let fsh = companyShorthand firm in anchorCell (FirmSupersR fsh) $ toWgt fsh - , sortable (Just "avsnr") (i18nCell MsgTableCompanyNo) $ \(view resultAllCompany -> firm) -> - anchorCell (FirmR $ companyShorthand firm) $ toWgt $ companyAvsId firm + , sortable (Just "avsnr") (i18nCell MsgTableCompanyNo) $ \(view resultAllCompany -> firm) -> numCell $ companyAvsId firm , sortable (Just "users") (i18nCell MsgTableCompanyNrUsers) $ \(view resultAllCompanyUsers -> nr) -> wgtCell $ word2widget nr , sortable (Just "supervisors") (i18nCell MsgTableCompanyNrSupersDefault) $ \row -> anchorCell (FirmSupersR $ row ^. resultAllCompany . _companyShorthand) $ toWgt $ hasTickmark $ row ^. resultAllCompanySupervisors @@ -826,7 +765,7 @@ mkFirmUserTable isAdmin cid = do dbtFilterUI mPrev = mconcat [ fltrUserNameEmailHdrUI MsgTableCompanyUser mPrev -- , prismAForm (singletonFilter "supervisor-is" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift supervisorField) (fslI MsgFilterSupervisor) - , prismAForm (multiFilter "supervisors-are" . maybePrism monoPathPieces) mPrev $ aopt (hoistField lift supervisorsField) (fslI MsgFilterSupervisor) + , prismAForm (multiFilter "supervisors-are" . maybePrism monoPathPieces) mPrev $ aopt (hoistField lift supervisorsField) (fslI MsgFilterSupervisor & setTooltip MsgMultiSelectTip ) , 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) diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index 0cbbbde66..b2c8d3073 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -109,7 +109,7 @@ postUsersR = do 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' + (\(E.Value cmpSh, E.Value cmpName, E.Value cmpSpr) -> simpleLink (citext2widget cmpName) (FirmUsersR 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) diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index 6b776cd41..a1ca0a18a 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -358,7 +358,7 @@ courseCell Course{..} = anchorCell link name `mappend` desc companyCell :: IsDBTable m a => CompanyShorthand -> CompanyName -> Bool -> DBCell m a companyCell cid cname isSupervisor = anchorCell link name where - link = FirmR cid + link = FirmUsersR cid corg = ciOriginal cname name | isSupervisor = text2markup (corg <> " ") <> icon IconSupervisor From 34c0928718a0dcac57a0ba97f7b9f0e24383c9ed Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 1 Dec 2023 16:12:10 +0100 Subject: [PATCH 096/159] chore(firm): add switch supervisor status --- .../uniworx/categories/firm/de-de-formal.msg | 6 ++++-- messages/uniworx/categories/firm/en-eu.msg | 6 ++++-- src/Handler/Firm.hs | 21 +++++++++++++++++-- 3 files changed, 27 insertions(+), 6 deletions(-) diff --git a/messages/uniworx/categories/firm/de-de-formal.msg b/messages/uniworx/categories/firm/de-de-formal.msg index 1668a06c3..f938dbaa9 100644 --- a/messages/uniworx/categories/firm/de-de-formal.msg +++ b/messages/uniworx/categories/firm/de-de-formal.msg @@ -16,7 +16,7 @@ FirmActResetSuperKeep: Bisherige Ansprechpartner der Firmenangehörigen zusätzl FirmActResetMutualSupervision: Ansprechpartner beaufsichtigen sich gegenseitig FirmActAddSupersvisors: Ansprechpartner hinzufügen FirmActAddSupersEmpty: Es konnten keine Ansprechpartner hinzugefügt werden -FirmActAddSupersSet n@Int64 postal@(Maybe Bool): #{n} Standardansprechpartner eingetragen #{maybeBoolMessage postal "" "und auf Briefversand geschaltet" "und Benachrichtigungen per Email gesetzt"}, aber nicht nicht aktiviert. +FirmActAddSupersSet n@Int64 postal@(Maybe Bool): #{n} Standardansprechpartner geändert #{maybeBoolMessage postal "" "und auf Briefversand geschaltet" "und Benachrichtigungen per Email gesetzt"}, aber nicht nicht aktiviert. RemoveSupervisors ndef@Int64 nact@Int64: #{ndef} Standard Ansprechpartner entfernt#{bool ", aber noch nicht deaktiviert" (", " <> tshow nact <> " aktive Ansprechpartnerbeziehungen gelöscht") (nact > 0)} FirmActChangeContactUser: Kontaktinformationen von allen Firmenangehörigen ändern FirmActChangeContactFirm: Kontaktinformationen der Firma ändern @@ -32,7 +32,9 @@ FirmUserActMkSuper: Zum Firmenansprechpartner ernennen FirmUserActChangeContact: Kontaktinformationen für ausgewählte Firmenangehörige ändern 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 +FirmSuperActSwitchSuper: Standard Firmenansprechpartner abändern +FirmSuperActSwitchSuperInfo: Betrifft keine firmenfremden Ansprechpartner und ändert keine aktiven individuellen Ansprechpartnerbeziehungen. Gegebenfalls im Anschluss die Funktion "Ansprechpartner auf Firmenstandard zurücksetzen" nutzen. +FirmSuperActRMSuperDef: Firmenansprechpartner entfernen FirmSuperActRMSuperActive: Auch aktive Ansprechpartnerbeziehungen innerhalb dieser Firma beenden FirmsNotification: Firmen E-Mail versenden FirmNotification fsh@CompanyShorthand: E-Mail an #{fsh} senden diff --git a/messages/uniworx/categories/firm/en-eu.msg b/messages/uniworx/categories/firm/en-eu.msg index 7539257d1..747900397 100644 --- a/messages/uniworx/categories/firm/en-eu.msg +++ b/messages/uniworx/categories/firm/en-eu.msg @@ -16,7 +16,7 @@ FirmActResetSuperKeep: Additionally keep existing supervisors of company associa FirmActResetMutualSupervision: Supervisors supervise each other FirmActAddSupersvisors: Add supervisors FirmActAddSupersEmpty: No supervisors added -FirmActAddSupersSet n postal: #{n} default company supervisors set #{maybeBoolMessage postal "" "and switched to postal notifications" "and switched to email notifications"}, but not yet activated. +FirmActAddSupersSet n postal: #{n} default company supervisors changed #{maybeBoolMessage postal "" "and switched to postal notifications" "and switched to email notifications"}, but not yet activated. RemoveSupervisors ndef nact: #{ndef} default supervisors removed#{bool ", but not yet deactivated" (" and " <> tshow nact <> " active supervisions terminated") (nact > 0)} FirmActChangeContactUser: Change contact data for all company associates FirmActChangeContactFirm: Change company contact data @@ -32,7 +32,9 @@ FirmResetSupervision rem set: #{tshow set} supervisors set#{bool mempty (", " <> FirmUserActChangeContact: Change contact data for selected company associates FirmUserActMkSuper: Mark as company supervisor FirmSuperActNotify: Send message -FirmSuperActRMSuperDef: Remove as default supervisor +FirmSuperActSwitchSuper: Change default company supervisor +FirmSuperActSwitchSuperInfo: Does not affect company-external supervisors and does not change any active individal supervisions. Additionally use reset action, if desired. +FirmSuperActRMSuperDef: Remove default supervisor FirmSuperActRMSuperActive: Also remove active supervisions within this company FirmsNotification: Send company notification e-mail FirmNotification fsh: Send e-mail to #{fsh} diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 881be6223..11ff2e4fa 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -913,6 +913,7 @@ postFirmUsersR fsh = do -- Firm Supervisors Table data FirmSuperAction = FirmSuperActNotify + | FirmSuperActSwitchSuper | FirmSuperActRMSuperDef deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) @@ -922,6 +923,10 @@ nullaryPathPiece ''FirmSuperAction $ camelToPathPiece' 3 embedRenderMessage ''UniWorX ''FirmSuperAction id data FirmSuperActionData = FirmSuperActNotifyData + | FirmSuperActSwitchSuperData + { firmSuperActSwitchSuper :: Maybe Bool + , firmSuperActSwitchReroute :: Maybe Bool + } | FirmSuperActRMSuperDefData { firmSuperActRMSuperActive :: Maybe Bool } @@ -968,6 +973,7 @@ instance HasUser SuperCompanyTableData where mkFirmSuperTable :: Bool -> CompanyId -> DB (FormResult (FirmSuperActionData, Set UserId), Widget) mkFirmSuperTable isAdmin cid = do + msgSupervisorUnchanged <- messageI Info MsgFirmSuperActSwitchSuperInfo let -- fsh = unCompanyKey cid resultDBTable = DBTable{..} @@ -1032,6 +1038,10 @@ mkFirmSuperTable isAdmin cid = do acts :: Map FirmSuperAction (AForm Handler FirmSuperActionData) acts = mconcat [ guardMonoid isAdmin $ singletonMap FirmSuperActNotify $ pure FirmSuperActNotifyData + , singletonMap FirmSuperActSwitchSuper $ FirmSuperActSwitchSuperData + <$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgTableIsDefaultSupervisor) (Just $ Just True) + <*> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgTableIsDefaultReroute) (Nothing) + <* aformMessage msgSupervisorUnchanged , singletonMap FirmSuperActRMSuperDef $ FirmSuperActRMSuperDefData <$> aopt checkBoxField (fslI MsgFirmSuperActRMSuperActive) (Just $ Just True) ] @@ -1079,7 +1089,7 @@ postFirmSupersR fsh = do (FirmSuperActRMSuperDefData{..}, Set.toList -> uids) -> do (nrRmSuper,nrRmActual) <- runDB $ (,) <$> updateWhereCount [UserCompanyUser <-. uids, UserCompanyCompany ==. cid] [UserCompanySupervisor =. False, UserCompanySupervisorReroute =. False] - <*> if firmSuperActRMSuperActive /= Just True + <*> if firmSuperActRMSuperActive /= Just True then return 0 else E.deleteCount $ do spr <- E.from $ E.table @UserSupervisor @@ -1091,7 +1101,14 @@ postFirmSupersR fsh = do ) addMessageI Info $ MsgRemoveSupervisors nrRmSuper nrRmActual reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes - + (FirmSuperActSwitchSuperData{..}, Set.toList -> uids) -> do + let fltrSpr = guardMonoid (isNothing firmSuperActSwitchSuper) [UserCompanySupervisor ==. True] + changes = maybeEmpty firmSuperActSwitchSuper (pure . (UserCompanySupervisor =.)) + <> guardMonoid (firmSuperActSwitchSuper /= Just False || firmSuperActSwitchReroute == Just False) ( + maybeEmpty firmSuperActSwitchReroute (pure . (UserCompanySupervisorReroute =.))) + nrSuperChanges <- runDB $ updateWhereCount (fltrSpr <> [UserCompanyUser <-. uids, UserCompanyCompany ==. cid]) changes + addMessageI Info $ MsgFirmActAddSupersSet nrSuperChanges Nothing + reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes (FirmSuperActNotifyData , uids) -> do cuids <- traverse encrypt $ Set.toList uids :: Handler [CryptoUUIDUser] redirect (FirmCommR fsh, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cuids]) From 1d3345cbba1cb65ee49c6f62e145750545439642 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 1 Dec 2023 16:55:51 +0100 Subject: [PATCH 097/159] fix(firm): supervisor changes led to inconsistent DB --- src/Handler/Firm.hs | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 11ff2e4fa..f86048434 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -1102,10 +1102,14 @@ postFirmSupersR fsh = do addMessageI Info $ MsgRemoveSupervisors nrRmSuper nrRmActual reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes (FirmSuperActSwitchSuperData{..}, Set.toList -> uids) -> do - let fltrSpr = guardMonoid (isNothing firmSuperActSwitchSuper) [UserCompanySupervisor ==. True] - changes = maybeEmpty firmSuperActSwitchSuper (pure . (UserCompanySupervisor =.)) - <> guardMonoid (firmSuperActSwitchSuper /= Just False || firmSuperActSwitchReroute == Just False) ( - maybeEmpty firmSuperActSwitchReroute (pure . (UserCompanySupervisorReroute =.))) + let (fltrSpr, changes) = case (firmSuperActSwitchSuper, firmSuperActSwitchReroute) of + (Just True, Nothing) -> ([UserCompanySupervisor ==. False], [UserCompanySupervisor =. True ]) + (Just True, Just rer) -> ([UserCompanySupervisor ==. False] ||. [UserCompanySupervisorReroute !=. rer] + , [UserCompanySupervisor =. True , UserCompanySupervisorReroute =. rer ]) + (Just False, _) -> ([UserCompanySupervisor ==. True ], [UserCompanySupervisor =. False, UserCompanySupervisorReroute =. False]) + (Nothing, Just True) -> ([UserCompanySupervisor ==. True, UserCompanySupervisorReroute ==. False], [UserCompanySupervisorReroute =. True ]) + (Nothing, Just False) -> ([ UserCompanySupervisorReroute ==. True ], [UserCompanySupervisorReroute =. False]) + (Nothing, Nothing ) -> ([],[]) nrSuperChanges <- runDB $ updateWhereCount (fltrSpr <> [UserCompanyUser <-. uids, UserCompanyCompany ==. cid]) changes addMessageI Info $ MsgFirmActAddSupersSet nrSuperChanges Nothing reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes From df6a7ee1e2ed47e76f60477322ca433edbd84445 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 1 Dec 2023 17:04:42 +0100 Subject: [PATCH 098/159] chore(lms): deactivate lms synch by default --- config/settings.yml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/config/settings.yml b/config/settings.yml index b3c228991..602c9c0e2 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -91,8 +91,8 @@ study-features-recache-relevance-within: 172800 study-features-recache-relevance-interval: 293 # Enqueue at specified hour, a few minutes later -job-lms-qualifications-enqueue-hour: 15 -job-lms-qualifications-dequeue-hour: 3 +# job-lms-qualifications-enqueue-hour: 15 +# job-lms-qualifications-dequeue-hour: 3 log-settings: detailed: "_env:DETAILED_LOGGING:false" From fcc802753a75f0829238e3cbdce46dfc0d7ca4e7 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 1 Dec 2023 18:11:02 +0100 Subject: [PATCH 099/159] chore(lms): remove obsolete lms handlers v1 --- .../categories/qualification/de-de-formal.msg | 6 - .../categories/qualification/en-eu.msg | 6 - .../utils/navigation/menu/de-de-formal.msg | 2 - .../uniworx/utils/navigation/menu/en-eu.msg | 2 - models/lms.model | 37 +-- routes | 9 - src/Foundation/Navigation.hs | 30 +- src/Handler/LMS.hs | 12 +- src/Handler/LMS/Result.hs | 293 ------------------ src/Handler/LMS/Userlist.hs | 288 ----------------- src/Handler/Utils/LMS.hs | 10 - src/Jobs/Handler/LMS.hs | 127 +------- src/Jobs/Types.hs | 6 +- src/Utils/Lens.hs | 2 - test/Database/Fill.hs | 6 - 15 files changed, 11 insertions(+), 825 deletions(-) delete mode 100644 src/Handler/LMS/Result.hs delete mode 100644 src/Handler/LMS/Userlist.hs diff --git a/messages/uniworx/categories/qualification/de-de-formal.msg b/messages/uniworx/categories/qualification/de-de-formal.msg index 1571d7ac1..e0fee7cb8 100644 --- a/messages/uniworx/categories/qualification/de-de-formal.msg +++ b/messages/uniworx/categories/qualification/de-de-formal.msg @@ -84,14 +84,8 @@ CsvColumnLmsDate: Datum des E‑Learning Ereignisses CsvColumnLmsResetTries: Anzahl der bisher verbrauchten E‑Learning Prüfungsversuche zurücksetzen CsvColumnLmsLock: E‑Learning Login gesperrt CsvColumnLmsResult !ident-ok: LMS Status -LmsUserlistInsert: Neuer LMS User -LmsUserlistUpdate: LMS User Aktualisierung -LmsResultInsert: Neues LMS Ergebnis -LmsResultUpdate: LMS Ergebnis Aktualisierung LmsReportInsert: Neues LMS Ereignis LmsReportUpdate: LMS Ereignis Aktualisierung -LmsResultCsvExceptionDuplicatedKey: CSV-Import LmsResult fand uneindeutigen Schlüssel -LmsUserlistCsvExceptionDuplicatedKey: CSV-Import LmsUserlist fand uneindeutigen Schlüssel LmsReportCsvExceptionDuplicatedKey: CSV-Import LmsReport fand uneindeutigen Schlüssel LmsDirectUpload: Direkter Upload für automatisierte Systeme LmsErrorNoRefreshElearning: Fehler: E‑Learning wird nicht automatisch gestartet, da die Zeitspanne für den Erneurerungszeitraum nicht festgelegt wurde. diff --git a/messages/uniworx/categories/qualification/en-eu.msg b/messages/uniworx/categories/qualification/en-eu.msg index 5d466355b..c886cb843 100644 --- a/messages/uniworx/categories/qualification/en-eu.msg +++ b/messages/uniworx/categories/qualification/en-eu.msg @@ -84,14 +84,8 @@ CsvColumnLmsResetTries: Reset number of used up e‑learning exam attempts CsvColumnLmsDate: Date of e‑learning event CsvColumnLmsResult: LMS Status CsvColumnLmsLock: E‑learning login is not permitted -LmsUserlistInsert: New LMS user -LmsUserlistUpdate: Update of LMS user -LmsResultInsert: New LMS result -LmsResultUpdate: Update of LMS result LmsReportInsert: New LMS event LmsReportUpdate: Update of LMS event -LmsResultCsvExceptionDuplicatedKey: CSV import LmsResult with ambiguous key -LmsUserlistCsvExceptionDuplicatedKey: CSV import LmsUserlist with ambiguous key LmsReportCsvExceptionDuplicatedKey: CSV Import LmsReport with ambiguous key LmsDirectUpload: Direct upload for automated systems LmsErrorNoRefreshElearning: Error: E‑learning will not be started automatically due to refresh-within time period not being set. diff --git a/messages/uniworx/utils/navigation/menu/de-de-formal.msg b/messages/uniworx/utils/navigation/menu/de-de-formal.msg index b306bfdfc..d7d246ed3 100644 --- a/messages/uniworx/utils/navigation/menu/de-de-formal.msg +++ b/messages/uniworx/utils/navigation/menu/de-de-formal.msg @@ -124,8 +124,6 @@ MenuLmsUser: Benutzerqualifikationen MenuLmsUserSchool: Bereichs Benutzerqualifikationen MenuLmsUserAll: Alle Benutzerqualifikationen MenuLmsUsers: Veralteter Export E‑Learning Benutzer -MenuLmsUserlist: Veraltetes Melden E‑Learning Benutzer -MenuLmsResult: Veralteter Melden Ergebnisse E‑Learning MenuLmsUpload: Hochladen MenuLmsDirectUpload: Direkter Upload MenuLmsDirectDownload: Direkter Download diff --git a/messages/uniworx/utils/navigation/menu/en-eu.msg b/messages/uniworx/utils/navigation/menu/en-eu.msg index c8c18365f..02e25ca1e 100644 --- a/messages/uniworx/utils/navigation/menu/en-eu.msg +++ b/messages/uniworx/utils/navigation/menu/en-eu.msg @@ -125,8 +125,6 @@ MenuLmsUser: User Qualifications MenuLmsUserSchool: Institute User Qualifications MenuLmsUserAll: All User Qualifications MenuLmsUsers: Legacy download e‑learning users -MenuLmsUserlist: Legacy upload e‑learning users -MenuLmsResult: Legacy upload r‑learning results MenuLmsUpload: Upload MenuLmsDirectUpload: Direct Upload MenuLmsDirectDownload: Direct Download diff --git a/models/lms.model b/models/lms.model index 4ba0f3927..d9f4c1b7e 100644 --- a/models/lms.model +++ b/models/lms.model @@ -95,25 +95,20 @@ QualificationUserBlock -- - delete-flag: isJust LmsUserStatus -- Note: REST means that LmsUserResetPin and LmsUserDelete remain unchanged by this GET request! -- - -- 3. REST POST Userlist.csv: just save as is to LmsUserlist + -- 3. REST POST Report.csv: just save as is to LmsReport for later processing -- - -- 4. REST POST Ergebnisse.csv: just save as is to LmsResult - -- - -- 5. When received: Job LmsUserlist: -- Note: containment needs at-once processing + -- 4. When received: Job LmsReport: -- Note: containment needs at-once processing -- - For all LmsUser: -- + if contained: -- set LmsUserReceived to Just now() - -- if LmsUserlistFailed: set LmsUserStatus to Just LmsBlocked now + -- if Failed: set LmsUserStatus to Just LmsBlocked now + -- if Success: set LmsUserStatus to Just LmsSuccess now + -- and renew QualificationValidTo -- + not contained, by LmsUserReceived is set: set LmsUserEnded to Just now() -- - move row to LmsAudit -- - -- 6. When received: Daily Job LmsResult: - -- - set LmsUserReceived to Just now() -- always - -- - set LmsUserStatus to Just LmsSuccess now -- conditional - -- - and renew QualificationValidTo - -- - move row to LmsAudit - -- - -- 7. Daily Job: dequeue LMS Users + -- 5. Daily Job: dequeue LMS Users + -- - fail and mark expired LmsUser -- - remove from LmsUser after audit Period has passed LmsUser @@ -144,24 +139,6 @@ LmsUser -- UniqueLmsUserStatus lmsUser -- enforcing uniqueness prohibits history -- deriving Generic --- DEPRECATED V1 LmsUserlist stores LMS upload for later processing only -LmsUserlist - qualification QualificationId OnDeleteCascade OnUpdateCascade - ident LmsIdent - failed Bool - timestamp UTCTime default=now() - UniqueLmsUserlist qualification ident - deriving Generic Show - --- DEPRECATED V1 LmsResult stores LMS upload for later processing only -LmsResult - qualification QualificationId OnDeleteCascade OnUpdateCascade - ident LmsIdent - success Day -- BEWARE: timezone is local as submitted by LMS - timestamp UTCTime default=now() - UniqueLmsResult qualification ident -- required by DBTable - deriving Generic - -- V2 Stores LMS upload for processing in Background Job LmsReport qualification QualificationId OnDeleteCascade OnUpdateCascade diff --git a/routes b/routes index 0ea40300c..34891b367 100644 --- a/routes +++ b/routes @@ -279,15 +279,6 @@ /lms/#SchoolId LmsSchoolR GET /lms/#SchoolId/#QualificationShorthand LmsR GET POST /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/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 -/lms/#SchoolId/#QualificationShorthand/result LmsResultR GET POST -/lms/#SchoolId/#QualificationShorthand/result/upload LmsResultUploadR GET POST !development -/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 diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index 1d0258e31..59e430487 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -185,14 +185,6 @@ breadcrumb (LmsR ssh qsh) = useRunDB . maybeT (i18nCrumb MsgBrea guardM . lift . existsBy $ SchoolQualificationShort ssh qsh return (CI.original qsh, Just $ LmsSchoolR ssh) breadcrumb (LmsEditR ssh qsh) = i18nCrumb MsgMenuLmsEdit $ Just $ LmsR ssh qsh -breadcrumb (LmsUsersR ssh qsh) = i18nCrumb MsgMenuLmsUsers $ Just $ LmsR ssh qsh -breadcrumb (LmsUsersDirectR ssh qsh) = i18nCrumb MsgMenuLmsUsers $ Just $ LmsUsersR ssh qsh -- never displayed, TypedContent -breadcrumb (LmsUserlistR ssh qsh) = i18nCrumb MsgMenuLmsUserlist $ Just $ LmsR ssh qsh -breadcrumb (LmsUserlistUploadR ssh qsh) = i18nCrumb MsgMenuLmsUpload $ Just $ LmsUserlistR ssh qsh -breadcrumb (LmsUserlistDirectR ssh qsh) = i18nCrumb MsgMenuLmsUpload $ Just $ LmsUserlistR ssh qsh -- never displayed -breadcrumb (LmsResultR ssh qsh) = i18nCrumb MsgMenuLmsResult $ Just $ LmsR ssh qsh -breadcrumb (LmsResultUploadR ssh qsh) = i18nCrumb MsgMenuLmsUpload $ Just $ LmsResultR ssh qsh -breadcrumb (LmsResultDirectR ssh qsh) = i18nCrumb MsgMenuLmsUpload $ Just $ LmsResultR ssh qsh -- never displayed -- v2 breadcrumb (LmsLearnersR ssh qsh) = i18nCrumb MsgMenuLmsLearners $ Just $ LmsR ssh qsh breadcrumb (LmsLearnersDirectR ssh qsh) = i18nCrumb MsgMenuLmsLearners $ Just $ LmsLearnersR ssh qsh -- never displayed, TypedContent @@ -2375,27 +2367,7 @@ pageActions (LmsR sid qsh) = return [ defNavLink MsgMenuLmsUpload $ LmsReportUploadR sid qsh , defNavLink MsgMenuLmsDirectUpload $ LmsReportDirectR sid qsh ] - } - , NavPageActionSecondary - { navLink = defNavLink MsgMenuLmsUsers $ LmsUsersR sid qsh - -- , navChildren = - -- [ defNavLink MsgMenuLmsDirectDownload $ LmsUsersDirectR sid qsh - -- ] - } - , NavPageActionSecondary - { navLink = defNavLink MsgMenuLmsUserlist $ LmsUserlistR sid qsh - -- , navChildren = - -- [ defNavLink MsgMenuLmsUpload $ LmsUserlistUploadR sid qsh - -- , defNavLink MsgMenuLmsDirectUpload $ LmsUserlistDirectR sid qsh - -- ] - } - , NavPageActionSecondary - { navLink = defNavLink MsgMenuLmsResult $ LmsResultR sid qsh - -- , navChildren = - -- [ defNavLink MsgMenuLmsUpload $ LmsResultUploadR sid qsh - -- , defNavLink MsgMenuLmsDirectUpload $ LmsResultDirectR sid qsh - -- ] - } + } , NavPageActionSecondary { navLink = defNavLink MsgMenuLmsEdit $ LmsEditR sid qsh } diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index 5bf9beb94..abc8d8bd6 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -11,13 +11,7 @@ module Handler.LMS , getLmsR , postLmsR , getLmsIdentR , getLmsEditR , postLmsEditR - -- V1 - , getLmsUsersR , getLmsUsersDirectR - , getLmsUserlistR , postLmsUserlistR - , getLmsUserlistUploadR , postLmsUserlistUploadR, postLmsUserlistDirectR - , getLmsResultR , postLmsResultR - , getLmsResultUploadR , postLmsResultUploadR , postLmsResultDirectR - -- V1 + -- V2 , getLmsLearnersR , getLmsLearnersDirectR , getLmsReportR , postLmsReportR , getLmsReportUploadR , postLmsReportUploadR , postLmsReportDirectR @@ -50,10 +44,6 @@ import qualified Database.Esqueleto.PostgreSQL as E import qualified Database.Esqueleto.Utils as E import Database.Esqueleto.Utils.TH import Database.Persist.Sql (deleteWhereCount, updateWhereCount) --- V1 -import Handler.LMS.Users as Handler.LMS -import Handler.LMS.Userlist as Handler.LMS -import Handler.LMS.Result as Handler.LMS -- V2 import Handler.LMS.Learners as Handler.LMS import Handler.LMS.Report as Handler.LMS diff --git a/src/Handler/LMS/Result.hs b/src/Handler/LMS/Result.hs deleted file mode 100644 index aca551ab6..000000000 --- a/src/Handler/LMS/Result.hs +++ /dev/null @@ -1,293 +0,0 @@ --- SPDX-FileCopyrightText: 2022 Steffen Jost ,Steffen Jost --- --- SPDX-License-Identifier: AGPL-3.0-or-later - -{-# OPTIONS_GHC -fno-warn-orphans #-} -- needed for HasEntity instances - -module Handler.LMS.Result - ( getLmsResultR, postLmsResultR - , getLmsResultUploadR, postLmsResultUploadR - , postLmsResultDirectR - ) - where - -import Import - -import Handler.Utils -import Handler.Utils.Csv -import Handler.Utils.LMS - -import qualified Data.Map as Map -import qualified Data.Csv as Csv -import qualified Data.Conduit.List as C -import qualified Database.Esqueleto.Legacy as E -import qualified Database.Esqueleto.Utils as E - -import Jobs.Queue - - -data LmsResultTableCsv = LmsResultTableCsv - { csvLRTident :: LmsIdent - , csvLRTsuccess :: LmsDay - } - deriving Generic -makeLenses_ ''LmsResultTableCsv - --- csv without headers -instance Csv.ToRecord LmsResultTableCsv -- default suffices -instance Csv.FromRecord LmsResultTableCsv -- default suffices - --- csv with headers -lmsResultTableCsvHeader :: Csv.Header -lmsResultTableCsvHeader = Csv.header [ csvLmsIdent, csvLmsSuccess ] - -instance ToNamedRecord LmsResultTableCsv where - toNamedRecord LmsResultTableCsv{..} = Csv.namedRecord - [ csvLmsIdent Csv..= csvLRTident - , csvLmsSuccess Csv..= csvLRTsuccess - ] - -instance FromNamedRecord LmsResultTableCsv where - parseNamedRecord (lsfHeaderTranslate -> csv) - = LmsResultTableCsv - <$> csv Csv..: csvLmsIdent - <*> csv Csv..: csvLmsSuccess - -instance CsvColumnsExplained LmsResultTableCsv where - csvColumnsExplanations _ = mconcat - [ single csvLmsIdent MsgCsvColumnLmsIdent - , single csvLmsSuccess MsgCsvColumnLmsSuccess - ] - where - single :: RenderMessage UniWorX msg => Csv.Name -> msg -> Map Csv.Name Widget - single k v = singletonMap k [whamlet|_{v}|] - -data LmsResultCsvActionClass = LmsResultInsert | LmsResultUpdate - deriving (Eq, Ord, Read, Show, Generic, Enum, Bounded) -embedRenderMessage ''UniWorX ''LmsResultCsvActionClass id - --- By coincidence the action type is identical to LmsResultTableCsv -data LmsResultCsvAction = LmsResultInsertData { lmsResultInsertIdent :: LmsIdent, lmsResultInsertSuccess :: Day } - | LmsResultUpdateData { lmsResultInsertIdent :: LmsIdent, lmsResultInsertSuccess :: Day } - deriving (Eq, Ord, Read, Show, Generic) - -deriveJSON defaultOptions - { constructorTagModifier = camelToPathPiece'' 2 1 -- LmsResultInsertData -> insert - , fieldLabelModifier = camelToPathPiece' 2 -- lmsResultInsertIdent -> insert-ident | lmsResultInsertSuccess -> insert-success - , sumEncoding = TaggedObject "action" "data" - } ''LmsResultCsvAction - -data LmsResultCsvException - = LmsResultCsvExceptionDuplicatedKey -- TODO: this is not used anywhere?! - deriving (Show, Generic) - -instance Exception LmsResultCsvException -embedRenderMessage ''UniWorX ''LmsResultCsvException id - -mkResultTable :: SchoolId -> QualificationShorthand -> QualificationId -> DB (Any, Widget) -mkResultTable sid qsh qid = do - now_day <- utctDay <$> liftIO getCurrentTime - dbtCsvName <- csvFilenameLmsResult qsh - let dbtCsvSheetName = dbtCsvName - let - resultDBTable = DBTable{..} - where - dbtSQLQuery lmsresult = do - E.where_ $ lmsresult E.^. LmsResultQualification E.==. E.val qid - return lmsresult - dbtRowKey = (E.^. LmsResultId) - dbtProj = dbtProjId - dbtColonnade = dbColonnade $ mconcat - [ sortable (Just csvLmsIdent) (i18nCell MsgTableLmsIdent) $ \(view $ _dbrOutput . _entityVal . _lmsResultIdent . _getLmsIdent -> ident) -> textCell ident - , sortable (Just csvLmsSuccess) (i18nCell MsgTableLmsSuccess) $ \(view $ _dbrOutput . _entityVal . _lmsResultSuccess -> success) -> dayCell success - , sortable (Just csvLmsTimestamp) (i18nCell MsgTableLmsReceived) $ \(view $ _dbrOutput . _entityVal . _lmsResultTimestamp -> timestamp) -> dateTimeCell timestamp - ] - dbtSorting = Map.fromList - [ (csvLmsIdent , SortColumn (E.^. LmsResultIdent)) - , (csvLmsSuccess , SortColumn (E.^. LmsResultSuccess)) - , (csvLmsTimestamp, SortColumn (E.^. LmsResultTimestamp)) - ] - dbtFilter = Map.fromList - [ (csvLmsIdent , FilterColumn $ E.mkContainsFilterWith LmsIdent (E.^. LmsResultIdent)) - , (csvLmsSuccess, FilterColumn $ E.mkExactFilter (E.^. LmsResultSuccess)) - ] - dbtFilterUI = \mPrev -> mconcat - [ prismAForm (singletonFilter csvLmsIdent . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent) - , prismAForm (singletonFilter csvLmsSuccess . maybePrism _PathPiece) mPrev $ aopt (hoistField lift dayField) (fslI MsgTableLmsSuccess) - ] - dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } - dbtParams = def - dbtIdent :: Text - dbtIdent = "lms-result" - dbtCsvEncode = Just DBTCsvEncode - { dbtCsvExportForm = pure () - , dbtCsvDoEncode = \() -> C.map (doEncode' . view _2) - , dbtCsvName - , dbtCsvSheetName - , dbtCsvNoExportData = Just id - , dbtCsvHeader = const $ return lmsResultTableCsvHeader - , dbtCsvExampleData = Just - [ LmsResultTableCsv{csvLRTident = LmsIdent lid, csvLRTsuccess = LmsDay $ addDays (-dos) now_day } - | (lid,dos) <- zip ["abcdefgh", "12345678", "ident8ch"] [1..] - ] - } - where - doEncode' = LmsResultTableCsv - <$> view (_dbrOutput . _entityVal . _lmsResultIdent) - <*> view (_dbrOutput . _entityVal . _lmsResultSuccess . _lmsDay) - dbtCsvDecode = Just DBTCsvDecode -- Just save to DB; Job will process data later - { dbtCsvRowKey = \LmsResultTableCsv{..} -> - fmap E.Value . MaybeT . getKeyBy $ UniqueLmsResult qid csvLRTident - , dbtCsvComputeActions = \case -- purpose is to show a diff to the user first - DBCsvDiffNew{dbCsvNewKey = Nothing, dbCsvNew} -> do - yield $ LmsResultInsertData - { lmsResultInsertIdent = csvLRTident dbCsvNew - , lmsResultInsertSuccess = csvLRTsuccess dbCsvNew & lms2day - } - DBCsvDiffNew{dbCsvNewKey = Just _, dbCsvNew = _} -> error "UniqueLmsResult was found, but the key no longer exists." -- TODO: how can this ever happen? Check Pagination-Code - DBCsvDiffExisting{dbCsvNew = LmsResultTableCsv{..}, dbCsvOld} -> do - let successDay = lms2day csvLRTsuccess - when (successDay /= dbCsvOld ^. _dbrOutput . _entityVal . _lmsResultSuccess) $ - yield $ LmsResultUpdateData - { lmsResultInsertIdent = csvLRTident - , lmsResultInsertSuccess = successDay - } - DBCsvDiffMissing{} -> return () -- no deletion - , dbtCsvClassifyAction = \case - LmsResultInsertData{} -> LmsResultInsert - LmsResultUpdateData{} -> LmsResultUpdate - , dbtCsvCoarsenActionClass = \case - LmsResultInsert -> DBCsvActionNew - LmsResultUpdate -> DBCsvActionExisting - , dbtCsvValidateActions = return () -- no validation, since this is an automatic upload, i.e. no user to review error - , dbtCsvExecuteActions = do - C.mapM_ $ \actionData -> do - now <- liftIO getCurrentTime - void $ upsert - LmsResult - { lmsResultQualification = qid - , lmsResultIdent = lmsResultInsertIdent actionData - , lmsResultSuccess = lmsResultInsertSuccess actionData - , lmsResultTimestamp = now -- lmsResultInsertTimestamp -- does it matter which one to choose? - } - [ LmsResultSuccess =. lmsResultInsertSuccess actionData - , LmsResultTimestamp =. now - ] - -- audit $ Transaction.. (add to Audit.Types) - lift . queueDBJob $ JobLmsResults qid - return $ LmsResultR sid qsh - , dbtCsvRenderKey = const $ \case - LmsResultInsertData{..} -> do -- TODO: i18n - [whamlet| - $newline never - Insert: Ident #{getLmsIdent lmsResultInsertIdent} # - had success on ^{formatTimeW SelFormatDate lmsResultInsertSuccess} - |] - LmsResultUpdateData{..} -> do -- TODO: i18n - [whamlet| - $newline never - Update: Ident #{getLmsIdent lmsResultInsertIdent} # - had success on ^{formatTimeW SelFormatDate lmsResultInsertSuccess} - |] - , dbtCsvRenderActionClass = toWidget <=< ap getMessageRender . pure - , dbtCsvRenderException = ap getMessageRender . pure :: LmsResultCsvException -> DB Text - } - dbtExtraReps = [] - - resultDBTableValidator = def - & defaultSorting [SortAscBy csvLmsIdent] - dbTable resultDBTableValidator resultDBTable - -getLmsResultR, postLmsResultR :: SchoolId -> QualificationShorthand -> Handler Html -getLmsResultR = postLmsResultR -postLmsResultR sid qsh = do - let directUploadLink = LmsResultUploadR sid qsh - lmsTable <- runDB $ do - qid <- getKeyBy404 $ SchoolQualificationShort sid qsh - view _2 <$> mkResultTable sid qsh qid - siteLayoutMsg MsgMenuLmsResult $ do - setTitleI MsgMenuLmsResult - $(widgetFile "lms-result") - - --- Direct File Upload/Download - -saveResultCsv :: QualificationId -> Int -> LmsResultTableCsv -> DB Int -saveResultCsv qid i LmsResultTableCsv{..} = do - now <- liftIO getCurrentTime - void $ upsert - LmsResult - { lmsResultQualification = qid - , lmsResultIdent = csvLRTident - , lmsResultSuccess = csvLRTsuccess & lms2day - , lmsResultTimestamp = now - } - [ LmsResultSuccess =. (csvLRTsuccess & lms2day) - , LmsResultTimestamp =. now - ] - return $ succ i - -makeResultUploadForm :: Form FileInfo -makeResultUploadForm = renderAForm FormStandard $ fileAFormReq "Result CSV" - -getLmsResultUploadR, postLmsResultUploadR :: SchoolId -> QualificationShorthand -> Handler Html -getLmsResultUploadR = postLmsResultUploadR -postLmsResultUploadR sid qsh = do - ((result,widget), enctype) <- runFormPost makeResultUploadForm - case result of - FormSuccess file -> do - -- content <- fileSourceByteString file - -- return $ Just (fileName file, content) - nr <- runDB $ do - qid <- getKeyBy404 $ SchoolQualificationShort sid qsh - nr <- runConduit $ fileSource file - .| decodeCsv - .| foldMC (saveResultCsv qid) 0 - queueJob' $ JobLmsResults qid - return nr - addMessage Success $ toHtml $ pack "Erfolgreicher Upload der Datei " <> fileName file <> pack (" mit " <> show nr <> " Zeilen") - redirect $ LmsResultR sid qsh - FormFailure errs -> do - forM_ errs $ addMessage Error . toHtml - redirect $ LmsResultUploadR sid qsh - FormMissing -> - siteLayoutMsg MsgMenuLmsResult $ do - setTitleI MsgMenuLmsUpload - [whamlet|$newline never -
                                                - ^{widget} -

                                                - - |] - - -postLmsResultDirectR :: SchoolId -> QualificationShorthand -> Handler Html -postLmsResultDirectR sid qsh = do - (_params, files) <- runRequestBody - (status, msg) <- case files of - [(fhead,file)] -> do - lmsDecoder <- getLmsCsvDecoder - runDB $ do - qid <- getKeyBy404 $ SchoolQualificationShort sid qsh - enr <- try $ runConduit $ fileSource file - .| lmsDecoder - .| foldMC (saveResultCsv qid) 0 - case enr of - Left (e :: SomeException) -> do -- catch all to avoid ok220 in case of any error - $logWarnS "LMS" $ "Result upload failed parsing: " <> tshow e - return (badRequest400, "Exception: " <> tshow e) - Right nr -> do - let msg = "Success. LMS Result upload file " <> fileName file <> " containing " <> tshow nr <> " rows for " <> fhead <> ". " - $logInfoS "LMS" msg - when (nr > 0) $ queueJob' $ JobLmsResults qid - return (ok200, msg) - [] -> do - let msg = "Result upload file missing." - $logWarnS "LMS" msg - return (badRequest400, msg) - _other -> do - let msg = "Result upload received multiple files; all ignored." - $logWarnS "LMS" msg - return (badRequest400, msg) - sendResponseStatus status msg - diff --git a/src/Handler/LMS/Userlist.hs b/src/Handler/LMS/Userlist.hs deleted file mode 100644 index 6304c5be7..000000000 --- a/src/Handler/LMS/Userlist.hs +++ /dev/null @@ -1,288 +0,0 @@ --- SPDX-FileCopyrightText: 2022 Steffen Jost --- --- SPDX-License-Identifier: AGPL-3.0-or-later - -{-# OPTIONS_GHC -fno-warn-orphans #-} -- needed for HasEntity instances - -module Handler.LMS.Userlist - ( getLmsUserlistR, postLmsUserlistR - , getLmsUserlistUploadR, postLmsUserlistUploadR - , postLmsUserlistDirectR - ) - where - -import Import - -import Handler.Utils -import Handler.Utils.Csv -import Handler.Utils.LMS - -import qualified Data.Map as Map -import qualified Data.Csv as Csv -import qualified Data.Conduit.List as C -import qualified Database.Esqueleto.Legacy as E -import qualified Database.Esqueleto.Utils as E - -import Jobs.Queue - -data LmsUserlistTableCsv = LmsUserlistTableCsv - { csvLULident :: LmsIdent - , csvLULfailed :: LmsBool - } - deriving Generic -makeLenses_ ''LmsUserlistTableCsv - --- csv without headers -instance Csv.ToRecord LmsUserlistTableCsv -instance Csv.FromRecord LmsUserlistTableCsv - --- csv with headers -instance DefaultOrdered LmsUserlistTableCsv where - headerOrder = const $ Csv.header [ csvLmsIdent, csvLmsBlocked ] - -instance ToNamedRecord LmsUserlistTableCsv where - toNamedRecord LmsUserlistTableCsv{..} = Csv.namedRecord - [ csvLmsIdent Csv..= csvLULident - , csvLmsBlocked Csv..= csvLULfailed - ] -instance FromNamedRecord LmsUserlistTableCsv where - parseNamedRecord (lsfHeaderTranslate -> csv) - = LmsUserlistTableCsv - <$> csv Csv..: csvLmsIdent - <*> csv Csv..: csvLmsBlocked - -instance CsvColumnsExplained LmsUserlistTableCsv where - csvColumnsExplanations _ = mconcat - [ single csvLmsIdent MsgCsvColumnLmsIdent - , single csvLmsBlocked MsgCsvColumnLmsLock - ] - where - single :: RenderMessage UniWorX msg => Csv.Name -> msg -> Map Csv.Name Widget - single k v = singletonMap k [whamlet|_{v}|] - - -data LmsUserlistCsvActionClass = LmsUserlistInsert | LmsUserlistUpdate - deriving (Eq, Ord, Read, Show, Generic, Enum, Bounded) -embedRenderMessage ''UniWorX ''LmsUserlistCsvActionClass id - -data LmsUserlistCsvAction = LmsUserlistInsertData { lmsUserlistInsertIdent :: LmsIdent, lmsUserlistInsertFailed :: Bool } - | LmsUserlistUpdateData { lmsUserlistInsertIdent :: LmsIdent, lmsUserlistInsertFailed :: Bool } - deriving (Eq, Ord, Read, Show, Generic) - -deriveJSON defaultOptions - { constructorTagModifier = camelToPathPiece'' 2 1 -- LmsUserlistInsertData -> insert - , fieldLabelModifier = camelToPathPiece' 2 -- lmsUserlistInsertIdent -> insert-ident | lmsUserlistInsertFailed -> insert-failed - , sumEncoding = TaggedObject "action" "data" - } ''LmsUserlistCsvAction - - -data LmsUserlistCsvException - = LmsUserlistCsvExceptionDuplicatedKey -- TODO: this is not used anywhere?! - deriving (Show, Generic) - -instance Exception LmsUserlistCsvException -embedRenderMessage ''UniWorX ''LmsUserlistCsvException id - -mkUserlistTable :: SchoolId -> QualificationShorthand -> QualificationId -> DB (Any, Widget) -mkUserlistTable sid qsh qid = do - dbtCsvName <- csvFilenameLmsUserlist qsh - let dbtCsvSheetName = dbtCsvName - let - userlistTable = DBTable{..} - where - dbtSQLQuery lmslist = do - E.where_ $ lmslist E.^. LmsUserlistQualification E.==. E.val qid - return lmslist - dbtRowKey = (E.^. LmsUserlistId) - dbtProj = dbtProjId - dbtColonnade = dbColonnade $ mconcat - [ sortable (Just csvLmsIdent) (i18nCell MsgTableLmsIdent) $ \DBRow{ dbrOutput = Entity _ LmsUserlist{..} } -> textCell $ lmsUserlistIdent & getLmsIdent - , sortable (Just csvLmsBlocked) (i18nCell MsgTableLmsLock) $ \DBRow{ dbrOutput = Entity _ LmsUserlist{..} } -> ifIconCell lmsUserlistFailed IconBlocked - , sortable (Just csvLmsTimestamp) (i18nCell MsgTableLmsReceived) $ \DBRow{ dbrOutput = Entity _ LmsUserlist{..} } -> dateTimeCell lmsUserlistTimestamp - ] - dbtSorting = Map.fromList - [ (csvLmsIdent , SortColumn $ \lmslist -> lmslist E.^. LmsUserlistIdent) - , (csvLmsBlocked , SortColumn $ \lmslist -> lmslist E.^. LmsUserlistFailed) - , (csvLmsTimestamp, SortColumn $ \lmslist -> lmslist E.^. LmsUserlistTimestamp) - ] - dbtFilter = Map.fromList - [ (csvLmsIdent , FilterColumn $ E.mkContainsFilterWith LmsIdent (E.^. LmsUserlistIdent )) - , (csvLmsBlocked, FilterColumn $ E.mkExactFilter (E.^. LmsUserlistFailed)) - ] - dbtFilterUI = \mPrev -> mconcat - [ prismAForm (singletonFilter csvLmsIdent . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent) - , prismAForm (singletonFilter csvLmsBlocked . maybePrism _PathPiece) mPrev $ aopt (hoistField lift checkBoxField) (fslI MsgTableLmsLock) - ] - dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } - dbtParams = def - dbtIdent :: Text - dbtIdent = "lms-userlist" - dbtCsvEncode = simpleCsvEncode dbtCsvName dbtCsvSheetName doEncode' <&> addExample - where - addExample dce = dce{ dbtCsvExampleData = csvExample } - csvExample = Just - [ LmsUserlistTableCsv{csvLULident = LmsIdent lid, csvLULfailed = LmsBool ufl} - | (lid,ufl) <- zip ["abcdefgh", "12345678", "ident8ch"] [False,True,False] - ] - doEncode' = LmsUserlistTableCsv - <$> view (_dbrOutput . _entityVal . _lmsUserlistIdent) - <*> view (_dbrOutput . _entityVal . _lmsUserlistFailed . _lmsBool) - dbtCsvDecode = Just DBTCsvDecode {..} - where - dbtCsvRowKey = \LmsUserlistTableCsv{csvLULident} -> - fmap E.Value . MaybeT . getKeyBy $ UniqueLmsUserlist qid csvLULident - dbtCsvComputeActions = \case -- shows a diff first - DBCsvDiffNew{dbCsvNew} -> do - yield $ LmsUserlistInsertData - { lmsUserlistInsertIdent = csvLULident dbCsvNew - , lmsUserlistInsertFailed = lms2bool $ csvLULfailed dbCsvNew - } - DBCsvDiffExisting{dbCsvNew = LmsUserlistTableCsv{..}, dbCsvOld} -> do - let failedBool = lms2bool csvLULfailed - when (failedBool /= dbCsvOld ^. _dbrOutput . _entityVal . _lmsUserlistFailed) $ - yield $ LmsUserlistUpdateData - { lmsUserlistInsertIdent = csvLULident - , lmsUserlistInsertFailed = csvLULfailed & lms2bool - } - DBCsvDiffMissing{} -> return () -- no deletion - dbtCsvClassifyAction = \case - LmsUserlistInsertData{} -> LmsUserlistInsert - LmsUserlistUpdateData{} -> LmsUserlistUpdate - dbtCsvCoarsenActionClass = \case - LmsUserlistInsert -> DBCsvActionNew - LmsUserlistUpdate -> DBCsvActionExisting - dbtCsvValidateActions = return () -- no validation, since this is an automatic upload, i.e. no user to review error - dbtCsvExecuteActions = do - C.mapM_ $ \actionData -> do - now <- liftIO getCurrentTime - void $ upsert LmsUserlist - { - lmsUserlistQualification = qid - , lmsUserlistIdent = lmsUserlistInsertIdent actionData - , lmsUserlistFailed = lmsUserlistInsertFailed actionData - , lmsUserlistTimestamp = now - } - [ - LmsUserlistFailed =. lmsUserlistInsertFailed actionData -- TODO: should we allow a reset from failed: True to False? - , LmsUserlistTimestamp =. now - ] - -- audit - lift . queueDBJob $ JobLmsUserlist qid - return $ LmsUserlistR sid qsh - dbtCsvRenderKey = const $ \case - LmsUserlistInsertData{..} -> do -- TODO: i18n - [whamlet| - $newline never - Insert: Course for Ident #{getLmsIdent lmsUserlistInsertIdent} # - $if lmsUserlistInsertFailed - is closed due to failure. - $else - is open. - |] - LmsUserlistUpdateData{..} -> do -- TODO: i18n - [whamlet| - $newline never - Update: Course for Ident #{getLmsIdent lmsUserlistInsertIdent} # - $if lmsUserlistInsertFailed - is now closed due to failure. - $else - is still open. - |] - dbtCsvRenderActionClass = toWidget <=< ap getMessageRender . pure - dbtCsvRenderException = ap getMessageRender . pure :: LmsUserlistCsvException -> DB Text - dbtExtraReps = [] - - userlistDBTableValidator = def - & defaultSorting [SortAscBy csvLmsIdent] - - dbTable userlistDBTableValidator userlistTable - - -getLmsUserlistR, postLmsUserlistR :: SchoolId -> QualificationShorthand -> Handler Html -getLmsUserlistR = postLmsUserlistR -postLmsUserlistR sid qsh = do - lmsTable <- runDB $ do - qid <- getKeyBy404 $ SchoolQualificationShort sid qsh - view _2 <$> mkUserlistTable sid qsh qid - siteLayoutMsg MsgMenuLmsUserlist $ do - setTitleI MsgMenuLmsUserlist - lmsTable - - --- Direct File Upload/Download --- saveUserlistCsv :: (PersistUniqueWrite backend, MonadIO m, BaseBackend backend ~ SqlBackend, Enum b) => --- Key Qualification -> b -> LmsUserlistTableCsv -> ReaderT backend m b -saveUserlistCsv :: QualificationId -> Int -> LmsUserlistTableCsv -> DB Int -saveUserlistCsv qid i LmsUserlistTableCsv{..} = do - now <- liftIO getCurrentTime - void $ upsert - LmsUserlist - { lmsUserlistQualification = qid - , lmsUserlistIdent = csvLULident - , lmsUserlistFailed = csvLULfailed & lms2bool - , lmsUserlistTimestamp = now - } - [ LmsUserlistFailed =. (csvLULfailed & lms2bool) - , LmsUserlistTimestamp =. now - ] - return $ succ i - -makeUserlistUploadForm :: Form FileInfo -makeUserlistUploadForm = renderAForm FormStandard $ fileAFormReq "Userlist CSV" - -getLmsUserlistUploadR, postLmsUserlistUploadR :: SchoolId -> QualificationShorthand -> Handler Html -getLmsUserlistUploadR = postLmsUserlistUploadR -postLmsUserlistUploadR sid qsh = do - ((result,widget), enctype) <- runFormPost makeUserlistUploadForm - case result of - FormSuccess file -> do - nr <- runDB $ do - qid <- getKeyBy404 $ SchoolQualificationShort sid qsh - nr <- runConduit $ fileSource file .| decodeCsv .| foldMC (saveUserlistCsv qid) 0 - queueJob' $ JobLmsUserlist qid - return nr - addMessage Success $ toHtml $ pack "Erfolgreicher Upload der Datei " <> fileName file <> pack (" mit " <> show nr <> " Zeilen") - redirect $ LmsUserlistR sid qsh - FormFailure errs -> do - forM_ errs $ addMessage Error . toHtml - redirect $ LmsUserlistUploadR sid qsh - FormMissing -> - siteLayoutMsg MsgMenuLmsUserlist $ do - setTitleI MsgMenuLmsUpload - [whamlet|$newline never - - ^{widget} -

                                                - - |] - - -postLmsUserlistDirectR :: SchoolId -> QualificationShorthand -> Handler Html -postLmsUserlistDirectR sid qsh = do - (_params, files) <- runRequestBody - (status, msg) <- case files of - [(fhead,file)] -> do - lmsDecoder <- getLmsCsvDecoder - runDB $ do - qid <- getKeyBy404 $ SchoolQualificationShort sid qsh - enr <- try $ runConduit $ fileSource file - .| lmsDecoder - .| foldMC (saveUserlistCsv qid) 0 - case enr of - Left (e :: SomeException) -> do - $logWarnS "LMS" $ "Userlist upload failed parsing: " <> tshow e - return (badRequest400, "Exception: " <> tshow e) - Right nr -> do - let msg = "Success. LMS Userlist upload file " <> fileName file <> " containing " <> tshow nr <> " rows for " <> fhead <> ". " - $logInfoS "LMS" msg - when (nr > 0) $ queueJob' $ JobLmsUserlist qid - return (ok200, msg) - [] -> do - let msg = "Userlist upload file missing." - $logWarnS "LMS" msg - return (badRequest400, msg) - _other -> do - let msg = "Userlist upload received multiple files; all ignored." - $logWarnS "LMS" msg - return (badRequest400, msg) - sendResponseStatus status msg diff --git a/src/Handler/Utils/LMS.hs b/src/Handler/Utils/LMS.hs index eb619276b..e6f35e8e9 100644 --- a/src/Handler/Utils/LMS.hs +++ b/src/Handler/Utils/LMS.hs @@ -19,8 +19,6 @@ module Handler.Utils.LMS , csvLmsLock , csvLmsResult , csvFilenameLmsUser - , csvFilenameLmsUserlist - , csvFilenameLmsResult , csvFilenameLmsReport , lmsDeletionDate , lmsUserToDelete , _lmsUserToDelete , lmsUserToDeleteExpr @@ -109,14 +107,6 @@ csvLmsResult = fromString "result" -- LmsStatus: 0=Versuche aufgebraucht, 1=Offe csvFilenameLmsUser :: MonadHandler m => QualificationShorthand -> m Text csvFilenameLmsUser = makeLmsFilename "user" --- | Filename for Userlist transmission, contains current datestamp as agreed in LMS interface V2 -csvFilenameLmsUserlist :: MonadHandler m => QualificationShorthand -> m Text -csvFilenameLmsUserlist = makeLmsFilename "userliste" - --- | Filename for Result transmission, contains current datestamp as agreed in LMS interface V1 -csvFilenameLmsResult :: MonadHandler m => QualificationShorthand -> m Text -csvFilenameLmsResult = makeLmsFilename "ergebnisse" - -- | Filename for Report transmission, combining former Userlist and Result as agreed in new LMS interface V2 csvFilenameLmsReport :: MonadHandler m => QualificationShorthand -> m Text csvFilenameLmsReport = makeLmsFilename "report" diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index 1785924b4..5ab7745ae 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -10,8 +10,6 @@ module Jobs.Handler.LMS , dispatchJobLmsEnqueue, dispatchJobLmsEnqueueUser , dispatchJobLmsDequeue , dispatchJobLmsReports - , dispatchJobLmsResults - , dispatchJobLmsUserlist ) where import Import @@ -28,7 +26,7 @@ import qualified Database.Esqueleto.Utils as E import qualified Data.Set as Set -- import qualified Data.Map as Map -import qualified Data.Time.Zones as TZ +-- import qualified Data.Time.Zones as TZ import Handler.Utils.DateTime import Handler.Utils.LMS (randomLMSIdentBut, randomLMSpw, maxLmsUserIdentRetries) import Handler.Utils.Qualification @@ -134,10 +132,6 @@ dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act ( (E.^. LmsUserIdent) <$> E.from (E.table @LmsUser ) ) -- no filter by Qid, since LmsIdents must be unique across all `E.union_` ( (E.^. LmsReportIdent) <$> E.from (E.table @LmsReport ) ) -- V2 - `E.union_` - ( (E.^. LmsResultIdent) <$> E.from (E.table @LmsResult ) ) -- V1 DEPRECATED - `E.union_` - ( (E.^. LmsUserlistIdent) <$> E.from (E.table @LmsUserlist) ) -- V1 DEPRECATED E.orderBy [E.asc lui] pure lui now <- liftIO getCurrentTime @@ -261,8 +255,6 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act when (numdel > 0) $ do $logInfoS "LMS" $ "Deleting " <> tshow numdel <> " LmsIdents due to audit duration expiry for qualification " <> qshort deleteWhere [LmsUserQualification ==. qid, LmsUserIdent <-. delusers] - deleteWhere [LmsUserlistQualification ==. qid, LmsUserlistIdent <-. delusers] - deleteWhere [LmsResultQualification ==. qid, LmsResultIdent <-. delusers] -- deleteWhere [LmsAuditQualification ==. qid, LmsAuditIdent <-. delusers] deleteWhere [LmsReportLogQualification ==. qid, LmsReportLogTimestamp <. auditCutoff ] @@ -433,120 +425,3 @@ dispatchJobLmsReports qid = JobHandlerAtomic act E.<&> E.true) repProc <- deleteWhereCount [LmsReportQualification ==. qid] $logInfoS "LMS" [st|Processed #{tshow repProc} e-learning status reports for qualification #{tshow qid}.|] - - --- DEPRECATED processes received results and lengthen qualifications, if applicable -dispatchJobLmsResults :: QualificationId -> JobHandler UniWorX -dispatchJobLmsResults qid = JobHandlerAtomic act - where - -- act :: YesodJobDB UniWorX () - act = hoist lift $ do - results <- E.select $ do - (quser :& luser :& lresult) <- E.from $ - E.table @QualificationUser -- table not needed if renewal from lms completion day is used TODO: decide! - `E.innerJoin` E.table @LmsUser - `E.on` (\(quser :& luser) -> - luser E.^. LmsUserUser E.==. quser E.^. QualificationUserUser - E.&&. luser E.^. LmsUserQualification E.==. quser E.^. QualificationUserQualification) - `E.innerJoin` E.table @LmsResult - `E.on` (\(_ :& luser :& lresult) -> - luser E.^. LmsUserIdent E.==. lresult E.^. LmsResultIdent - E.&&. luser E.^. LmsUserQualification E.==. lresult E.^. LmsResultQualification) - E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid - E.&&. luser E.^. LmsUserQualification E.==. E.val qid - -- E.&&. E.isNothing (luser E.^. LmsUserStatus) -- do not process learners already having a result WORKAROUND LMS-Bug: LMS may send blocked & success simultanesouly or within a few hours; in this case, success is the correct meaning - E.&&. E.isNothing (luser E.^. LmsUserEnded) -- do not process closed learners - return (quser, luser, lresult) - now <- liftIO getCurrentTime - let locDay = localDay $ TZ.utcToLocalTimeTZ appTZ now - forM_ results $ \(Entity _quid QualificationUser{..}, Entity luid LmsUser{..}, Entity lrid LmsResult{..}) -> do - -- three separate DB operations per result is not so nice. All within one transaction though. - let lmsUserStartedDay = localDay $ TZ.utcToLocalTimeTZ appTZ lmsUserStarted - saneDate = lmsResultSuccess `inBetween` (lmsUserStartedDay, min qualificationUserValidUntil locDay) - -- && qualificationUserLastRefresh <= utctDay lmsUserStarted NOTE: not always true due to manual intervention; also renewValidQualificationUsers prevents double renewals anyway - -- newValidTo = addGregorianMonthsRollOver (toInteger renewalMonths) qualificationUserValidUntil -- renew from old validUntil onwards - note <- if saneDate && (lmsUserStatus /= Just LmsSuccess) - then do - -- WORKAROUND LMS-Bug [supposedly fixed now, but isnt]: sometimes we receive success and failure simultaneously; success is correct, hence we must unblock if the reason was e-learning - let reason_undo = Left $ "LMS Workaround undoing: " <> tshow (QualificationBlockFailedELearningBy lmsUserIdent) - ok_unblock <- qualificationUserUnblockByReason qid [qualificationUserUser] Nothing (Right $ QualificationBlockFailedELearningBy lmsUserIdent) reason_undo False -- affects audit log - when (ok_unblock > 0) ($logWarnS "LMS" [st|LMS Result: workaround triggered, unblocking #{tshow ok_unblock} e-learners for #{tshow qid}|]) - - _ok_renew <- renewValidQualificationUsers qid (Just $ Right $ QualificationRenewELearningBy lmsUserIdent) Nothing [qualificationUserUser] -- only unblocked are renewed - -- when (ok==1) $ update luid -- we end lms regardless of whether or not a regular renewal was successful, since BPol users may simultaneoysly have on-premise renewal courses and E-Learnings - - update luid - [ LmsUserStatus =. Just LmsSuccess - , LmsUserStatusDay =. Just (utctDayMidnight lmsResultSuccess) - , LmsUserReceived =. Just lmsResultTimestamp - ] - return Nothing - else do - let errmsg = [st|LMS Result: success with insane date #{tshow lmsResultSuccess} received for #{tshow lmsUserIdent} for #{tshow qid}|] - $logErrorS "LMS" errmsg - return $ Just errmsg - - audit TransactionLmsSuccess -- always log success, since this is only transmitted once - { transactionQualification = qid - , transactionLmsIdent = lmsUserIdent - , transactionLmsDay = utctDayMidnight lmsResultSuccess - , transactionLmsUser = lmsUserUser - , transactionNote = note - , transactionReceived = lmsResultTimestamp - } - delete lrid - $logInfoS "LMS" [st|Processed #{tshow (length results)} LMS results|] - - --- DEPRECATED processes received input and block qualifications, if applicable -dispatchJobLmsUserlist :: QualificationId -> JobHandler UniWorX -dispatchJobLmsUserlist qid = JobHandlerAtomic act - where - act :: YesodJobDB UniWorX () - act = whenM (exists [LmsUserlistQualification ==. qid]) $ do -- safeguard against multiple calls, which would close all learners due to first case below - now <- liftIO getCurrentTime - -- result :: [(Entity LmsUser, Entity LmsUserlist)] - results <- E.select $ do - (luser :& lulist) <- E.from $ - E.table @LmsUser `E.leftJoin` E.table @LmsUserlist - `E.on` (\(luser :& lulist) -> luser E.^. LmsUserIdent E.=?. lulist E.?. LmsUserlistIdent - E.&&. luser E.^. LmsUserQualification E.=?. lulist E.?. LmsUserlistQualification) - E.where_ $ luser E.^. LmsUserQualification E.==. E.val qid - E.&&. E.isNothing (luser E.^. LmsUserEnded) -- do not process closed learners - return (luser, lulist) - forM_ results $ \case - (Entity luid luser, Nothing) - | isJust $ lmsUserReceived luser -- mark all previuosly reported, but now unreported users as ended (LMS deleted them as expected) - , isNothing $ lmsUserEnded luser -> - update luid [LmsUserEnded =. Just now] - | otherwise -> return () -- users likely not yet started - - (Entity luid luser, Just (Entity _lulid lulist)) -> do - let lReceived = lmsUserlistTimestamp lulist - update luid [LmsUserReceived =. Just lReceived] -- LmsUserNotified is only updated upon sending notifications - - when (isNothing $ lmsUserNotified luser) $ do -- notify users that lms is available - queueDBJob JobUserNotification - { jRecipient = lmsUserUser luser - , jNotification = NotificationQualificationRenewal { nQualification = qid, nReminder = False } - } - - let isBlocked = lmsUserlistFailed lulist - oldStatus = lmsUserStatus luser - updateStatus = isBlocked && oldStatus /= Just LmsSuccess - when updateStatus $ do - update luid [LmsUserStatus =. Just LmsBlocked, LmsUserStatusDay =. Just lReceived] - ok <- qualificationUserBlocking qid [lmsUserUser luser] False Nothing (Right QualificationBlockFailedELearning) True - when (ok /= 1) $ do - uuid :: CryptoUUIDUser <- encrypt $ lmsUserUser luser - $logWarnS "LmsUserlist" [st|Blocking by failed E-learning failed for learner #{tshow uuid} and qualification #{tshow qid}] - audit TransactionLmsBlocked - { transactionQualification = qid - , transactionLmsIdent = lmsUserIdent luser - , transactionLmsDay = lReceived - , transactionLmsUser = lmsUserUser luser - , transactionNote = Just $ "Old status was " <> tshow oldStatus - , transactionReceived = lReceived - } - delete lulid - $logInfoS "LMS" [st|Processed LMS Userlist with #{tshow (length results)} entries|] diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs index 78b4fe50b..dc8e04120 100644 --- a/src/Jobs/Types.hs +++ b/src/Jobs/Types.hs @@ -135,8 +135,6 @@ data Job | JobLmsEnqueueUser { jQualification :: QualificationId, jUser :: UserId } | JobLmsQualificationsDequeue | JobLmsDequeue { jQualification :: QualificationId } - | JobLmsUserlist { jQualification :: QualificationId } -- Deprecated, remove together with routes - | JobLmsResults { jQualification :: QualificationId } -- Deprecated, remove together with routes | JobLmsReports { jQualification :: QualificationId } | JobPrintAck | JobPrintAckAgain @@ -368,9 +366,7 @@ jobNoQueueSame = \case JobLmsEnqueue {} -> Just JobNoQueueSame JobLmsEnqueueUser {} -> Just JobNoQueueSame JobLmsQualificationsDequeue -> Just JobNoQueueSame - JobLmsDequeue {} -> Just JobNoQueueSame - JobLmsUserlist {} -> Just JobNoQueueSame - JobLmsResults {} -> Just JobNoQueueSame + JobLmsDequeue {} -> Just JobNoQueueSame JobLmsReports {} -> Just JobNoQueueSame JobPrintAck {} -> Just JobNoQueueSame JobPrintAckAgain {} -> Just JobNoQueueSame diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index 861d98fd4..5c83e1e35 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -125,8 +125,6 @@ makeClassyFor_ ''QualificationUser makeClassyFor_ ''QualificationUserBlock makeClassyFor_ ''LmsUser -- makeClassyFor_ ''LmsUserStatus -makeClassyFor_ ''LmsUserlist -makeClassyFor_ ''LmsResult makeClassyFor_ ''LmsReport makeClassyFor_ ''UserAvs makeClassyFor_ ''UserAvsCard diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index 9e1b9cea6..19f424fc8 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -739,12 +739,6 @@ fillDb = do insertMany_ [QualificationUser uid qid_f (n_day (fromIntegral (length udn) - 12)) (n_day $ -42) (n_day $ -365) True (n_day' $ -11) | Entity uid User{userDisplayName=udn} <- take 200 $ drop 2 matUsers, uid `Set.notMember` qidfUsers] insertMany_ [LmsUser qid_f uid (LmsIdent udn) "123456" False now astatus astatusDay now (Just now) (Just now) Nothing False False | Entity uid User{userDisplayName=udn} <- take 200 $ drop 22 matUsers, uid `Set.notMember` qidfUsers , let selsome = odd $ length udn, let astatus = bool Nothing (Just LmsBlocked) selsome, let astatusDay = bool Nothing (Just now) selsome] - void . insert' $ LmsResult qid_f (LmsIdent "hijklm" ) (n_day (-1)) now - void . insert' $ LmsResult qid_f (LmsIdent "opqgrs" ) (n_day (-2)) now - void . insert' $ LmsResult qid_f (LmsIdent "pqgrst" ) (n_day (-3)) now - void . insert' $ LmsUserlist qid_f (LmsIdent "hijklm") False now - void . insert' $ LmsUserlist qid_f (LmsIdent "abcdef") True now - void . insert' $ LmsUserlist qid_f (LmsIdent "ijk" ) False now void . insert' $ LmsUser qid_f jost (LmsIdent "ijk" ) "123" False now Nothing Nothing now Nothing (Just $ n_day' (-7)) (Just $ n_day' (-5)) False False void . insert' $ LmsUser qid_f svaupel (LmsIdent "bcdefg") "abc" False now (Just LmsSuccess) (Just $ n_day' 1) (n_day' (-1)) (Just now) (Just $ n_day' 0) Nothing True False void . insert' $ LmsUser qid_f gkleen (LmsIdent "hiklmn") "@#!" True now (Just LmsBlocked) (Just $ now) (n_day' (-2)) (Just now) (Just $ n_day' (-4)) Nothing False True From 50eda5f65f7394fe519546609fe748490cb4dd72 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 1 Dec 2023 18:36:21 +0100 Subject: [PATCH 100/159] fix(build): redundant parenthesis --- src/Handler/Firm.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index f86048434..370e30467 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -1040,7 +1040,7 @@ mkFirmSuperTable isAdmin cid = do [ guardMonoid isAdmin $ singletonMap FirmSuperActNotify $ pure FirmSuperActNotifyData , singletonMap FirmSuperActSwitchSuper $ FirmSuperActSwitchSuperData <$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgTableIsDefaultSupervisor) (Just $ Just True) - <*> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgTableIsDefaultReroute) (Nothing) + <*> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgTableIsDefaultReroute) Nothing <* aformMessage msgSupervisorUnchanged , singletonMap FirmSuperActRMSuperDef $ FirmSuperActRMSuperDefData <$> aopt checkBoxField (fslI MsgFirmSuperActRMSuperActive) (Just $ Just True) From 527a270cbf77ce6f45ab014e3f61d81249b98578 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 1 Dec 2023 21:26:09 +0000 Subject: [PATCH 101/159] chore(release): 27.4.52 --- CHANGELOG.md | 9 +++++++++ nix/docker/version.json | 2 +- package-lock.json | 2 +- package.json | 2 +- package.yaml | 2 +- 5 files changed, 13 insertions(+), 4 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 54de9bc9a..cce1e6cff 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,15 @@ All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines. +## [27.4.52](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.51...v27.4.52) (2023-12-01) + + +### Bug Fixes + +* **build:** redundant parenthesis ([50eda5f](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/50eda5f65f7394fe519546609fe748490cb4dd72)) +* **firm:** restrict firm access to company supervisors only ([0a06efd](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/0a06efd76c63180c996657c2c7d78efc5bddd83d)) +* **firm:** supervisor changes led to inconsistent DB ([1d3345c](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/1d3345cbba1cb65ee49c6f62e145750545439642)) + ## [27.4.51](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.50...v27.4.51) (2023-11-24) diff --git a/nix/docker/version.json b/nix/docker/version.json index ac2140316..07d466528 100644 --- a/nix/docker/version.json +++ b/nix/docker/version.json @@ -1,3 +1,3 @@ { - "version": "27.4.51" + "version": "27.4.52" } diff --git a/package-lock.json b/package-lock.json index 8c57be9a2..8aae86886 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.4.51", + "version": "27.4.52", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index 31aa2b12d..e7e8a6e47 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.4.51", + "version": "27.4.52", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index 5856789ac..c6e1a8bcb 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 27.4.51 +version: 27.4.52 dependencies: - base - yesod From a15862ea72bc374af870ef3a23f86ae32c2c67a9 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 4 Dec 2023 16:03:31 +0100 Subject: [PATCH 102/159] fix(print): keep print jobs on user merge and lms id deletion --- models/print.model | 4 ++-- src/Handler/Utils/Users.hs | 4 ++++ 2 files changed, 6 insertions(+), 2 deletions(-) diff --git a/models/print.model b/models/print.model index ee3f1ea7c..ee22cf922 100644 --- a/models/print.model +++ b/models/print.model @@ -9,11 +9,11 @@ PrintJob file ByteString -- stores plain pdf; otherwise use FileContentReference Maybe created UTCTime acknowledged UTCTime Maybe - recipient UserId Maybe OnDeleteCascade OnUpdateCascade -- optional as some letters may contain just an address + recipient UserId Maybe OnDeleteSetNull OnUpdateCascade -- optional as some letters may contain just an address sender UserId Maybe OnDeleteSetNull OnUpdateCascade -- senders and associations are optional course CourseId Maybe OnDeleteCascade OnUpdateCascade qualification QualificationId Maybe OnDeleteCascade OnUpdateCascade - lmsUser LmsIdent Maybe OnDeleteCascade OnUpdateCascade -- allows tracking if recipient has been notified; must be unique + lmsUser LmsIdent Maybe OnDeleteSetNull OnUpdateCascade -- allows tracking if recipient has been notified; must be unique -- UniquePrintJobLmsUser lmsUser -- Note that in fact multiple print jobs per LMS user are possible! -- UniquePrintJobApcIdent apcIdent -- TODO: not yet enforced, since LmsIdent is currently used deriving Generic diff --git a/src/Handler/Utils/Users.hs b/src/Handler/Utils/Users.hs index 1e4a28487..5c85c9c73 100644 --- a/src/Handler/Utils/Users.hs +++ b/src/Handler/Utils/Users.hs @@ -847,6 +847,10 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do delete oldQKey -- deleteWhere [ QualificationUserUser ==. oldUserId ] -- no longer needed + -- PrintJobs + updateWhere [ PrintJobRecipient ==. Just oldUserId ] [ PrintJobRecipient =. Just newUserId ] + updateWhere [ PrintJobSender ==. Just oldUserId ] [ PrintJobSender =. Just newUserId ] + -- Supervision is fully merged E.insertSelectWithConflict UniqueUserSupervisor From 3acb847915010d10358ea02000c231dbba7cba26 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 5 Dec 2023 11:52:13 +0100 Subject: [PATCH 103/159] fix(firm): supervisor filter --- src/Handler/Firm.hs | 22 +++++++++++++++++++++- 1 file changed, 21 insertions(+), 1 deletion(-) diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 370e30467..194eea1dc 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -507,7 +507,7 @@ mkFirmAllTable isAdmin uid = do dbtFilter = mconcat [ single $ fltrCompanyNameNr queryAllCompany , single ("company-number", FilterColumn $ E.mkExactFilterWithComma readMay (queryAllCompany >>> (E.^. CompanyAvsId))) - , single ("is-supervisor" , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do + , single ("is-associate" , 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) @@ -517,6 +517,25 @@ mkFirmAllTable isAdmin uid = do E.||. (usr E.^. UserSurname `E.hasInfix` E.val criterion) ) ) + , single ("is-supervisor" , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do + (usr :& usrCmp) <- E.from $ E.table @User + `E.leftJoin` E.table @UserCompany + `E.on` (\(usr :& usrCmp) -> usr E.^. UserId E.==. usrCmp E.^. UserCompanyUser) + E.where_ $ ((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) + ) E.&&. ((E.isTrue (usrCmp E.?. UserCompanySupervisor) E.&&. usrCmp E.? . UserCompanyCompany E.?=. queryAllCompany row E.^. CompanyId) + E.||. E.exists (do + usrSpr <- E.from $ E.table @UserSupervisor + E.where_ $ usrSpr E.^. UserSupervisorSupervisor E.==. usr E.^. UserId + E.&& E.exists (do + usrSub <- E.from $ E.table @UserCompany + E.where_ $ usrSub E.^. UserCompanyUser E.==. usrSpr E.^. UserSupervisorUser + E.&&. usrSub E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId + ) + ) + ) + ) , single ("foreign-supervisor", FilterColumn $ \row (getLast -> criterion) -> -- let checkSuper = do -- expensive -- usrSpr <- E.from $ E.table @UserSupervisor @@ -552,6 +571,7 @@ mkFirmAllTable isAdmin uid = do [ fltrCompanyNameUI mPrev , prismAForm (singletonFilter "company-number") mPrev $ aopt textField (fslI MsgTableCompanyNo) , prismAForm (singletonFilter "is-supervisor") mPrev $ aopt textField (fslI MsgTableSupervisor) + , prismAForm (singletonFilter "is-associate") mPrev $ aopt textField (fslI MsgTableCompanyUser) , 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 MsgFilterFirmExtern) ] From 9878956716b04c7ae88989cb9b059d3edcb923dc Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 5 Dec 2023 12:12:51 +0100 Subject: [PATCH 104/159] fix(firm): set supervisor field not all fields required --- src/Handler/Firm.hs | 22 +++++++++++----------- src/Utils.hs | 1 + 2 files changed, 12 insertions(+), 11 deletions(-) diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 194eea1dc..c6d77abc1 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -520,15 +520,15 @@ mkFirmAllTable isAdmin uid = do , single ("is-supervisor" , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do (usr :& usrCmp) <- E.from $ E.table @User `E.leftJoin` E.table @UserCompany - `E.on` (\(usr :& usrCmp) -> usr E.^. UserId E.==. usrCmp E.^. UserCompanyUser) + `E.on` (\(usr :& usrCmp) -> usr E.^. UserId E.=?. usrCmp E.?. UserCompanyUser) E.where_ $ ((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) - ) E.&&. ((E.isTrue (usrCmp E.?. UserCompanySupervisor) E.&&. usrCmp E.? . UserCompanyCompany E.?=. queryAllCompany row E.^. CompanyId) + ) E.&&. ((E.isTrue (usrCmp E.?. UserCompanySupervisor) E.&&. usrCmp E.?. UserCompanyCompany E.?=. queryAllCompany row E.^. CompanyId) E.||. E.exists (do usrSpr <- E.from $ E.table @UserSupervisor E.where_ $ usrSpr E.^. UserSupervisorSupervisor E.==. usr E.^. UserId - E.&& E.exists (do + E.&&. E.exists (do usrSub <- E.from $ E.table @UserCompany E.where_ $ usrSub E.^. UserCompanyUser E.==. usrSpr E.^. UserSupervisorUser E.&&. usrSub E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId @@ -638,8 +638,8 @@ data FirmUserActionData = FirmUserActNotifyData -- , firmUserActResetMutualSupervision :: Maybe Bool } | FirmUserActSetSupervisorData - { firmUserActSetSuperNames :: Set Text - , firmUserActSetSuperIds :: [UserId] + { firmUserActSetSuperNames :: Maybe (Set Text) + , firmUserActSetSuperIds :: Maybe [UserId] , firmUserActSetSuperReroute :: Bool , firmUserActSetSuperKeep :: Bool } @@ -798,10 +798,10 @@ mkFirmUserTable isAdmin cid = do <$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep) (Just $ Just False) -- <*> aopt checkBoxField (fslI MsgFirmActResetMutualSupervision) (Just $ Just True ) , singletonMap FirmUserActSetSupervisor $ FirmUserActSetSupervisorData - <$> apopt (textField & cfAnySeparatedSet) (fslI MsgFirmNewSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing - <*> apopt supervisorsField (fslI MsgFirmSetSupervisor) Nothing - <*> apopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip) (Just False) - <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep) (Just False) + <$> aopt (textField & cfAnySeparatedSet) (fslI MsgFirmNewSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing + <*> aopt supervisorsField (fslI MsgFirmSetSupervisor) Nothing + <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip) (Just False) + <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep) (Just False) , singletonMap FirmUserActMkSuper $ FirmUserActMkSuperData <$> aopt checkBoxField (fslI MsgTableIsDefaultReroute) (Just $ Just True) , singletonMap FirmUserActChangeContact $ FirmUserActChangeContactData @@ -887,10 +887,10 @@ postFirmUsersR fsh = do addMessageI Info $ MsgFirmResetSupervision delSupers newSupers reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes (FirmUserActSetSupervisorData{..}, set2NonEmpty (error "Unexpected empty user list in getFirmUserR action handler.") -> uids) -> do - avsUsers :: Map Text (Maybe UserId) <- sequenceA $ Map.fromSet guessAvsUser firmUserActSetSuperNames + avsUsers :: Map Text (Maybe UserId) <- sequenceA $ Map.fromSet guessAvsUser $ maybeMonoid firmUserActSetSuperNames let (usersFound', usersNotFound) = partition (is _Just . view _2) $ Map.toList avsUsers usersFound = mapMaybe snd usersFound' - newSupers = Set.toList $ Set.fromList firmUserActSetSuperIds <> Set.fromList usersFound + newSupers = Set.toList $ Set.fromList (maybeMonoid firmUserActSetSuperIds) <> Set.fromList usersFound nrSupers = fromIntegral $ length newSupers nrUsers = fromIntegral $ length uids unless (null usersNotFound) $ diff --git a/src/Utils.hs b/src/Utils.hs index a2b35c37a..2093da8b2 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -626,6 +626,7 @@ guardMonoid True x = x assertMonoid :: Monoid m => (m -> Bool) -> m -> m assertMonoid f x = guardMonoid (f x) x +-- fold would also do, but is more risky if the Folable isn't Maybe maybeMonoid :: Monoid m => Maybe m -> m -- ^ Identify `Nothing` with `mempty` maybeMonoid = fromMaybe mempty From fc0ca7b854a686cf395dadf81b7423e530fd26b8 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 5 Dec 2023 18:39:59 +0100 Subject: [PATCH 105/159] fix(firm): group multi select field supervisor However, grouped multi select does not work for some reason. --- .../uniworx/categories/firm/de-de-formal.msg | 3 ++ messages/uniworx/categories/firm/en-eu.msg | 3 ++ messages/uniworx/misc/de-de-formal.msg | 2 +- messages/uniworx/misc/en-eu.msg | 2 +- src/Handler/Firm.hs | 38 ++++++++++++------- 5 files changed, 33 insertions(+), 15 deletions(-) diff --git a/messages/uniworx/categories/firm/de-de-formal.msg b/messages/uniworx/categories/firm/de-de-formal.msg index f938dbaa9..c7a92efb3 100644 --- a/messages/uniworx/categories/firm/de-de-formal.msg +++ b/messages/uniworx/categories/firm/de-de-formal.msg @@ -2,6 +2,9 @@ # # SPDX-License-Identifier: AGPL-3.0-or-later +FirmSuperDefault: Standardansprechpartner +FirmSuperForeign: Firmenfremde Ansprechpartner +FirmSuperIrregular: Irreguläre Ansprechpartner FirmAssociates: Firmenangehörige FirmContact: Firmenkontakt FirmNoContact: Keine allgemeinen Kontaktinformationen bekannt. diff --git a/messages/uniworx/categories/firm/en-eu.msg b/messages/uniworx/categories/firm/en-eu.msg index 747900397..043312a20 100644 --- a/messages/uniworx/categories/firm/en-eu.msg +++ b/messages/uniworx/categories/firm/en-eu.msg @@ -2,6 +2,9 @@ # # SPDX-License-Identifier: AGPL-3.0-or-later +FirmSuperDefault: Default supervisor +FirmSuperForeign: External supervisor +FirmSuperIrregular: Irregular supervisor FirmAssociates: Company associated users FirmContact: Company Contact FirmNoContact: No general contact information known. diff --git a/messages/uniworx/misc/de-de-formal.msg b/messages/uniworx/misc/de-de-formal.msg index eaa02c0fa..3fcd6ffe6 100644 --- a/messages/uniworx/misc/de-de-formal.msg +++ b/messages/uniworx/misc/de-de-formal.msg @@ -10,7 +10,7 @@ BoolIrrelevant !ident-ok: — FieldPrimary: Hauptfach FieldSecondary: Nebenfach MultiEmailFieldTip: Es sind mehrere, Komma-separierte, E-Mail-Adressen möglich -MultiSelectTip: Mehrfachauswahl mit Strg-Klick +MultiSelectTip: Mehrfachauswahl und Abwählen mit Strg-Klick WeekDay: Wochentag LdapIdentificationOrEmail: Fraport AG-Kennung / E-Mail-Adresse Months num@Int64: #{num} #{pluralDE num "Monat" "Monate"} diff --git a/messages/uniworx/misc/en-eu.msg b/messages/uniworx/misc/en-eu.msg index 5b6b15f5b..ed8bda4db 100644 --- a/messages/uniworx/misc/en-eu.msg +++ b/messages/uniworx/misc/en-eu.msg @@ -10,7 +10,7 @@ BoolIrrelevant: — FieldPrimary: Major FieldSecondary: Minor MultiEmailFieldTip: Multiple emails addresses may be specified (comma-separated) -MultiSelectTip: Multiple selection via Ctrl-Click +MultiSelectTip: Multiple selection and desection via Ctrl-Click WeekDay: Day of the week LdapIdentificationOrEmail: Fraport AG-Kennung / email address Months num: #{num} #{pluralEN num "Month" "Months"} diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index c6d77abc1..fabb20538 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -380,14 +380,14 @@ firmCountForeignSupervisors cmpy = E.subSelectCountDistinct $ do -- 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.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.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 () @@ -682,20 +682,32 @@ instance HasUser UserCompanyTableData where mkFirmUserTable :: Bool -> CompanyId -> DB (FormResult (FirmUserActionData, Set UserId), Widget) mkFirmUserTable isAdmin cid = do + mr <- getMessageRender let - mkSprOption (E.Value uid, E.Value udn) = do + mkSprOption (E.Value uid, E.Value udn, E.Value mbSpr) = do uuid <- toPathPiece <$> encryptUser uid - return Option{ optionDisplay = udn, optionInternalValue = uid, optionExternalValue = uuid } - procOptions = fmap mkOptionList . traverse mkSprOption + return (Option{ optionDisplay = udn, optionInternalValue = uid, optionExternalValue = uuid }, mbSpr) + + procOptions rawSupers = do + procSupers <- traverse mkSprOption rawSupers + return $ mkOptionListGrouped $ filter (notNull . snd) + [ (mr MsgFirmSuperDefault , [opt | (opt, Just True ) <- procSupers]) + , (mr MsgFirmSuperIrregular, [opt | (opt, Just False) <- procSupers]) + , (mr MsgFirmSuperForeign , [opt | (opt, Nothing ) <- procSupers]) + ] 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) + (usr :& usrCmp) <- E.from $ E.table @User `E.leftJoin` E.table @UserCompany + `E.on` (\(usr :& usrCmp) -> usr E.^. UserId E.=?. usrCmp E.?. UserCompanyUser E.&&. usrCmp E.?. UserCompanyCompany E.==. E.justVal cid) + E.where_ $ E.isTrue (usrCmp E.?. UserCompanySupervisor) + E.||. E.exists (firmQuerySupervisedBy cid Nothing usr) + return (usr E.^. UserId, usr E.^. UserDisplayName, usrCmp E.?. UserCompanySupervisor) let -- supervisorField :: Field Handler UserId - -- supervisorField = selectField $ procOptions rawSupers - supervisorsField = multiSelectField $ procOptions rawSupers + supervisorField = selectField $ procOptions rawSupers + -- TODO: Markieren Alien/Standard/Irregulär + -- supervisorsField = multiSelectField $ procOptions rawSupers + -- supervisorsField = convertField pure head supervisorField fsh = unCompanyKey cid resultDBTable = DBTable{..} @@ -784,8 +796,8 @@ mkFirmUserTable isAdmin cid = do -- superField = selectField $ ???? dbtFilterUI mPrev = mconcat [ fltrUserNameEmailHdrUI MsgTableCompanyUser mPrev - -- , prismAForm (singletonFilter "supervisor-is" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift supervisorField) (fslI MsgFilterSupervisor) - , prismAForm (multiFilter "supervisors-are" . maybePrism monoPathPieces) mPrev $ aopt (hoistField lift supervisorsField) (fslI MsgFilterSupervisor & setTooltip MsgMultiSelectTip ) + , prismAForm (singletonFilter "supervisor-is" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift supervisorField) (fslI MsgFilterSupervisor) + -- , prismAForm (multiFilter "supervisors-are" . maybePrism monoPathPieces) mPrev $ aopt (hoistField lift supervisorsField) (fslI MsgFilterSupervisor & setTooltip MsgMultiSelectTip ) , 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) @@ -799,7 +811,7 @@ mkFirmUserTable isAdmin cid = do -- <*> aopt checkBoxField (fslI MsgFirmActResetMutualSupervision) (Just $ Just True ) , singletonMap FirmUserActSetSupervisor $ FirmUserActSetSupervisorData <$> aopt (textField & cfAnySeparatedSet) (fslI MsgFirmNewSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing - <*> aopt supervisorsField (fslI MsgFirmSetSupervisor) Nothing + <*> fmap (fmap pure) (aopt supervisorField (fslI MsgFirmSetSupervisor) Nothing) <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip) (Just False) <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep) (Just False) , singletonMap FirmUserActMkSuper $ FirmUserActMkSuperData From 3aa89019a8b4393da0eca715871a3793c1e3abb2 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 6 Dec 2023 11:50:08 +0100 Subject: [PATCH 106/159] fix(form): multiSelectField working with grouped options --- messages/uniworx/utils/utils/de-de-formal.msg | 1 + messages/uniworx/utils/utils/en-eu.msg | 1 + src/Handler/Firm.hs | 21 ++++---- src/Utils/Form.hs | 48 +++++++++++++++++++ 4 files changed, 60 insertions(+), 11 deletions(-) diff --git a/messages/uniworx/utils/utils/de-de-formal.msg b/messages/uniworx/utils/utils/de-de-formal.msg index 067b7ba11..5ff122fb1 100644 --- a/messages/uniworx/utils/utils/de-de-formal.msg +++ b/messages/uniworx/utils/utils/de-de-formal.msg @@ -98,6 +98,7 @@ RoomReferenceLinkInstructions: Anweisungen RoomReferenceLinkInstructionsPlaceholder: Anweisungen UtilEmptyChoice: Auswahl war leer UtilEmptyNoChangeTip: Eine leere Eingabe belässt den vorherigen Wert unverändert. +MultiNoSelection: Keine Auswahl #invitation.hs InvitationAction: Aktion diff --git a/messages/uniworx/utils/utils/en-eu.msg b/messages/uniworx/utils/utils/en-eu.msg index cafb5fac8..f65004cd1 100644 --- a/messages/uniworx/utils/utils/en-eu.msg +++ b/messages/uniworx/utils/utils/en-eu.msg @@ -98,6 +98,7 @@ RoomReferenceLinkInstructions: Instructions RoomReferenceLinkInstructionsPlaceholder: Instructions UtilEmptyChoice: Empty selection UtilEmptyNoChangeTip: Existing values remain unchanged if this field is left empty. +MultiNoSelection: No selection #invitation.hs InvitationAction: Action diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index fabb20538..53914269e 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -94,7 +94,7 @@ firmActionMap mr isAdmin acts = mconcat (mkAct isAdmin <$> acts) <*> aopt checkBoxField (fslI MsgFirmActResetMutualSupervision) (Just $ Just True ) mkAct _ FirmActAddSupersvisors = singletonMap FirmActAddSupersvisors $ FirmActAddSupersvisorsData <$> areq (textField & cfAnySeparatedSet) (fslI MsgTableIsDefaultSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing - <*> areq checkBoxField (fslI MsgTableIsDefaultReroute ) (Just True) + <*> areq checkBoxField (fslI MsgTableIsDefaultReroute) (Just True) <*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip) Nothing mkAct _ FirmActChangeContactFirm = singletonMap FirmActChangeContactFirm $ FirmActChangeContactFirmData <$> aopt htmlField (fslI MsgPostAddress & setTooltip (SomeMessages [SomeMessage MsgPostAddressTip, SomeMessage MsgUtilEmptyNoChangeTip])) Nothing @@ -704,10 +704,9 @@ mkFirmUserTable isAdmin cid = do return (usr E.^. UserId, usr E.^. UserDisplayName, usrCmp E.?. UserCompanySupervisor) let -- supervisorField :: Field Handler UserId - supervisorField = selectField $ procOptions rawSupers - -- TODO: Markieren Alien/Standard/Irregulär - -- supervisorsField = multiSelectField $ procOptions rawSupers - -- supervisorsField = convertField pure head supervisorField + -- supervisorField = selectField' (Just $ SomeMessage MsgMultiNoSelection) $ procOptions rawSupers + supervisorsField = multiSelectField' (Just $ SomeMessage MsgMultiNoSelection) $ procOptions rawSupers + fsh = unCompanyKey cid resultDBTable = DBTable{..} @@ -796,8 +795,8 @@ mkFirmUserTable isAdmin cid = do -- superField = selectField $ ???? dbtFilterUI mPrev = mconcat [ fltrUserNameEmailHdrUI MsgTableCompanyUser mPrev - , prismAForm (singletonFilter "supervisor-is" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift supervisorField) (fslI MsgFilterSupervisor) - -- , prismAForm (multiFilter "supervisors-are" . maybePrism monoPathPieces) mPrev $ aopt (hoistField lift supervisorsField) (fslI MsgFilterSupervisor & setTooltip MsgMultiSelectTip ) + -- , prismAForm (singletonFilter "supervisor-is" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift supervisorField) (fslI MsgFilterSupervisor) + , prismAForm (multiFilter "supervisors-are" . maybePrism monoPathPieces) mPrev $ aopt (hoistField lift supervisorsField) (fslI MsgFilterSupervisor & setTooltip MsgMultiSelectTip) , 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) @@ -810,10 +809,10 @@ mkFirmUserTable isAdmin cid = do <$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep) (Just $ Just False) -- <*> aopt checkBoxField (fslI MsgFirmActResetMutualSupervision) (Just $ Just True ) , singletonMap FirmUserActSetSupervisor $ FirmUserActSetSupervisorData - <$> aopt (textField & cfAnySeparatedSet) (fslI MsgFirmNewSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing - <*> fmap (fmap pure) (aopt supervisorField (fslI MsgFirmSetSupervisor) Nothing) - <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip) (Just False) - <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep) (Just False) + <$> aopt (textField & cfAnySeparatedSet) (fslI MsgFirmNewSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing + <*> aopt supervisorsField (fslI MsgFirmSetSupervisor & setTooltip MsgMultiSelectTip) Nothing + <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip) (Just False) + <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep) (Just False) , singletonMap FirmUserActMkSuper $ FirmUserActMkSuperData <$> aopt checkBoxField (fslI MsgTableIsDefaultReroute) (Just $ Just True) , singletonMap FirmUserActChangeContact $ FirmUserActChangeContactData diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 39107331e..1a4bc3aa9 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -950,6 +950,54 @@ selectField' optMsg mkOpts = Field{..} #{optionDisplay opt} |] +multiSelectField' :: ( Eq a + , RenderMessage (HandlerSite m) FormMessage + , MonadHandler m + ) + => Maybe (SomeMessage (HandlerSite m)) -- ^ Caption used for @Nothing@-Option, if Field is optional and whether to show such an option + -> HandlerT (HandlerSite m) IO (OptionList a) + -> Field m [a] +-- ^ Like @multiSelectField@, but it can handle OptionListGrouped and also offers more control over the @Nothing@-Option, if Field is optional +multiSelectField' optMsg mkOpts = Field{..} + where + fieldEnctype = UrlEncoded + + fieldParse [] _ = return $ Right Nothing + fieldParse optlist _ = do + let optlist' = filter notNull optlist + readExternal <- view _olReadExternal <$> liftHandler mkOpts + return . maybe (Left . SomeMessage $ MsgInvalidEntry $ T.intercalate ", " optlist') (Right . Just) $ mapM readExternal optlist' + -- case mapM readExternal optlist' of + -- Nothing -> return $ Left $ SomeMessage $ MsgInvalidEntry $ T.intercalate ", " optlist' + -- res -> return $ Right res + + fieldView theId name attrs val isReq = do + opts <- liftHandler mkOpts + let + rendered = case val of + Left _ -> [] + Right xs -> [optionExternalValue o | o <- opts ^.. _olOptions, x <- xs, x == optionInternalValue o] + isSel Nothing = ClassyPrelude.Yesod.null rendered + isSel (Just opt) = optionExternalValue opt `elem` rendered + [whamlet| + $newline never + + |] + postPrintAckDirectR :: Handler Html postPrintAckDirectR = do now <- liftIO getCurrentTime (_params, files) <- runRequestBody (status, msg) <- case files of - [(_fhead,file)] -> do - runDBJobs $ do + [(_fhead,file)] -> do + runDBJobs $ do enr <- try $ runConduit $ fileSource file - -- .| decodeCsvPositional Csv.NoHeader -- decode by separator position + -- .| decodeCsvPositional Csv.NoHeader -- decode by separator position .| decodeUtf8C -- no CSV, just convert each line to a single text .| linesUnboundedC .| foldMC (saveApcident now) 0 @@ -462,7 +477,7 @@ postPrintAckDirectR = do let msg = "Success: received " <> tshow nr <> " APC identifiers to be processed later." $logInfoS "LMS" msg when (nr > 0) $ queueDBJob JobPrintAck - return (ok200, msg) + return (ok200, msg) [] -> do let msg = "Error: No file received. A file of lms identifiers must be supplied for print job acknowledging." $logWarnS "APC" msg @@ -476,7 +491,7 @@ postPrintAckDirectR = do getPrintLogR :: Handler Html getPrintLogR = do - let + let logDBTable = DBTable{..} where resultLog :: Lens' (DBRow (TransactionLog, Aeson.Result Transaction)) TransactionLog @@ -485,9 +500,9 @@ getPrintLogR = do resultTrans :: Lens' (DBRow (TransactionLog, Aeson.Result Transaction)) (Aeson.Result Transaction) resultTrans = _dbrOutput . _2 - tCell' err c dbr = case view resultTrans dbr of + tCell' err c dbr = case view resultTrans dbr of (Aeson.Error msg) -> err msg -- should not happen, due to query filter - (Aeson.Success t) -> c t + (Aeson.Success t) -> c t tCellErr = tCell' stringCell tCell = tCell' $ const mempty @@ -497,7 +512,7 @@ getPrintLogR = do -- E.&&. E.val "interface" E.==. l E.^. TransactionLogInfo E.->>. "transaction" -- not necessary return l dbtRowKey = (E.^. TransactionLogId) - dbtProj = dbtProjSimple $ \(Entity _ l) -> do + dbtProj = dbtProjSimple $ \(Entity _ l) -> do return (l, Aeson.fromJSON $ transactionLogInfo l) dbtColonnade = dbColonnade $ mconcat [ sortable (Just "time") (i18nCell MsgSystemMessageTimestamp) $ \(view $ resultLog . to transactionLogTime -> t) -> dateTimeCell t @@ -521,6 +536,6 @@ getPrintLogR = do dbtExtraReps = [] validator = def & defaultSorting [ SortDescBy "time" ] tbl <- runDB $ dbTableDB' validator logDBTable - siteLayoutMsg MsgMenuPrintLog $ do + siteLayoutMsg MsgMenuPrintLog $ do setTitleI MsgMenuPrintLog [whamlet|^{tbl}|] From bbb9f9fadb4136a92fa6727cb73ee02eb489f495 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 2 Feb 2024 17:16:19 +0100 Subject: [PATCH 140/159] chore(health): telling interface table compiles --- .../uniworx/categories/admin/de-de-formal.msg | 6 +- messages/uniworx/categories/admin/en-eu.msg | 6 +- src/Handler/Health/Interface.hs | 89 +++++++++++++++++-- src/Handler/LMS/Report.hs | 3 +- src/Handler/Utils/DateTime.hs | 4 +- 5 files changed, 95 insertions(+), 13 deletions(-) diff --git a/messages/uniworx/categories/admin/de-de-formal.msg b/messages/uniworx/categories/admin/de-de-formal.msg index f4c23696d..ad521c490 100644 --- a/messages/uniworx/categories/admin/de-de-formal.msg +++ b/messages/uniworx/categories/admin/de-de-formal.msg @@ -121,6 +121,10 @@ ProblemsAvsSynchHeading: Synchronisation AVS Fahrberechtigungen ProblemsAvsErrorHeading: Fehlermeldungen ProblemsInterfaceSince: Berücksichtigt werden nur Erfolge und Fehler seit +InterfaceStatus !ident-ok: Status +InterfaceName: Schnittstelle InterfaceLastSynch: Zuletzt InterfaceSubtype: Betreffend -InterfaceWrite: Schreibend \ No newline at end of file +InterfaceWrite: Schreibend +InterfaceSuccess: Rückmeldung +InterfaceInfo: Nachricht \ No newline at end of file diff --git a/messages/uniworx/categories/admin/en-eu.msg b/messages/uniworx/categories/admin/en-eu.msg index c035f54c0..c73fd8910 100644 --- a/messages/uniworx/categories/admin/en-eu.msg +++ b/messages/uniworx/categories/admin/en-eu.msg @@ -121,6 +121,10 @@ ProblemsAvsSynchHeading: Synchronisation AVS Driving Licences ProblemsAvsErrorHeading: Error Log ProblemsInterfaceSince: Only considering successes and errors since +InterfaceStatus: Status +InterfaceName: Interface InterfaceLastSynch: Last InterfaceSubtype: Affecting -InterfaceWrite: Write \ No newline at end of file +InterfaceWrite: Write +InterfaceSuccess: Returned +InterfaceInfo: Message \ No newline at end of file diff --git a/src/Handler/Health/Interface.hs b/src/Handler/Health/Interface.hs index 6592b6f56..e623901f1 100644 --- a/src/Handler/Health/Interface.hs +++ b/src/Handler/Health/Interface.hs @@ -2,6 +2,9 @@ -- -- SPDX-License-Identifier: AGPL-3.0-or-later +{-# OPTIONS_GHC -fno-warn-unused-top-binds #-} -- !!! TODO REMOVE ME + + module Handler.Health.Interface ( getHealthInterfaceR @@ -12,10 +15,12 @@ import Import -- import qualified Data.Set as Set import qualified Data.Text as Text +import Handler.Utils import Database.Esqueleto.Experimental ((:&)(..)) import qualified Database.Esqueleto.Experimental as E import qualified Database.Esqueleto.Utils as E +import qualified Database.Esqueleto.Legacy as EL (on) identifyInterfaces :: [Text] -> [Unique InterfaceHealth] @@ -34,35 +39,105 @@ wc2null o = Just o -- | sloppily parse a boolean, also see Model.Types.Avs.SloppyBool pbool :: Text -> Maybe Bool pbool (Text.toLower . Text.strip -> w) - | w `elem` ["1", "t", "true" ,"wahr", "w"] = Just True + | w `elem` ["1", "t", "true" ,"wahr", "w"] = Just True | w `elem` ["0", "f", "false","falsch"] = Just False | otherwise = Nothing +mkInterfaceLogTable :: [Unique InterfaceHealth] -> (Bool -> Widget) -> DB ([(Text,Bool)], Widget) +mkInterfaceLogTable interfs flagError = do + now <- liftIO getCurrentTime + dbTableDB ilvalidator DBTable{dbtColonnade=colonnade now, ..} + where + dbtIdent = "interface-log" :: Text + dbtProj = dbtProjId + dbtSQLQuery (ilog `E.LeftOuterJoin` ihealth) = do + EL.on ( ilog E.^. InterfaceLogInterface E.=?. ihealth E.?. InterfaceHealthInterface + E.&&. ilog E.^. InterfaceLogSubtype E.=~. E.joinV (ihealth E.?. InterfaceHealthSubtype) + E.&&. ilog E.^. InterfaceLogWrite E.=~. E.joinV (ihealth E.?. InterfaceHealthWrite ) + ) + unless (null interfs) $ + E.where_ $ E.or [ ilog E.^. InterfaceLogInterface E.==. E.val ifce + E.&&. ilog E.^. InterfaceLogSubtype E.=~. E.val subt + E.&&. ilog E.^. InterfaceLogWrite E.=~. E.val writ + | (UniqueInterfaceHealth ifce subt writ) <- interfs + ] + let ihour = E.coalesceDefault [ihealth E.?. InterfaceHealthHours] (E.val $ 3 * 24) -- if no default time is set, use 3 days instead + return (ilog, ihour, E.joinV $ ihealth E.?. InterfaceHealthMessage) + + queryILog :: (E.SqlExpr (Entity InterfaceLog) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity InterfaceHealth))) -> E.SqlExpr (Entity InterfaceLog) + queryILog = $(E.sqlLOJproj 2 1) + resultILog :: Lens' (DBRow (Entity InterfaceLog, E.Value Int, E.Value (Maybe Text))) InterfaceLog + resultILog = _dbrOutput . _1 . _entityVal + resultHours :: Lens' (DBRow (Entity InterfaceLog, E.Value Int, E.Value (Maybe Text))) Int + resultHours = _dbrOutput . _2 . E._unValue + -- resultErrMsg :: Traversal' (DBRow (Entity InterfaceLog, E.Value Int, E.Value (Maybe Text))) Text + -- resultErrMsg = _dbrOutput . _3 . E._unValue . _Just + + dbtRowKey = queryILog >>> (E.^.InterfaceLogId) + colonnade now = mconcat + [ sortable Nothing (i18nCell MsgInterfaceStatus) $ \row -> -- do + let hours = row ^. resultHours + -- defmsg = row ^? resultErrMsg + logtime = row ^. resultILog . _interfaceLogTime + success = row ^. resultILog . _interfaceLogSuccess + iface = row ^. resultILog . _interfaceLogInterface + status = success && now <= addHours hours logtime + in tellCell [(iface,status)] $ + wgtCell $ flagError status + , sortable (Just "interface") (i18nCell MsgInterfaceName ) $ \(view (resultILog . _interfaceLogInterface) -> n) -> textCell n + , sortable (Just "subtype") (i18nCell MsgInterfaceSubtype ) $ textCell . view (resultILog . _interfaceLogSubtype) + , sortable (Just "write") (i18nCell MsgInterfaceWrite ) $ (`ifIconCell` IconEdit) . view (resultILog . _interfaceLogWrite) + , sortable (Just "time") (i18nCell MsgInterfaceLastSynch ) $ dateTimeCell . view (resultILog . _interfaceLogTime) + , sortable (Just "rows") (i18nCell MsgTableRows ) $ cellMaybe numCell . view (resultILog . _interfaceLogRows) + , sortable (Just "success") (i18nCell MsgInterfaceSuccess ) $ \(view (resultILog . _interfaceLogSuccess) -> s) -> iconBoolCell s + , sortable Nothing (i18nCell MsgInterfaceInfo ) $ \(view resultILog -> ilt) -> case ilt of + InterfaceLog "AVS" "Synch" True _ _ i _ -> anchorCell ProblemAvsErrorR $ toWgt $ bool i "AVS-Log" $ null i + InterfaceLog "LPR" _ _ _ _ i _ -> anchorCell PrintLogR $ toWgt $ bool i "LPR-Log" $ null i + InterfaceLog _ _ _ _ _ i _ -> textCell i + ] + dbtSorting = mconcat + [ singletonMap "interface" $ SortColumn $ queryILog >>> (E.^. InterfaceLogInterface) + , singletonMap "subtype" $ SortColumn $ queryILog >>> (E.^. InterfaceLogSubtype) + , singletonMap "write" $ SortColumn $ queryILog >>> (E.^. InterfaceLogWrite) + , singletonMap "time" $ SortColumn $ queryILog >>> (E.^. InterfaceLogTime) + , singletonMap "rows" $ SortColumn $ queryILog >>> (E.^. InterfaceLogRows) + , singletonMap "success" $ SortColumn $ queryILog >>> (E.^. InterfaceLogSuccess) + ] + ilvalidator = def & defaultSorting [SortAscBy "interface", SortAscBy "subtype", SortAscBy "write"] + dbtFilter = mempty + dbtFilterUI = mempty + dbtStyle = def + dbtParams = def + dbtCsvEncode = noCsvEncode + dbtCsvDecode = Nothing + dbtExtraReps = [] + + getHealthInterfaceR :: [Text] -> Handler Html getHealthInterfaceR ris = do let interfs = identifyInterfaces ris res <- runDB $ E.select $ do - (ilog :& ihealth) <- E.from (E.table @InterfaceLog + (ilog :& ihealth) <- E.from (E.table @InterfaceLog `E.leftJoin` E.table @InterfaceHealth - `E.on` (\(ilog :& ihealth) -> + `E.on` (\(ilog :& ihealth) -> ilog E.^. InterfaceLogInterface E.=?. ihealth E.?. InterfaceHealthInterface E.&&. ilog E.^. InterfaceLogSubtype E.=~. E.joinV (ihealth E.?. InterfaceHealthSubtype) E.&&. ilog E.^. InterfaceLogWrite E.=~. E.joinV (ihealth E.?. InterfaceHealthWrite ) )) - unless (null interfs) $ + unless (null interfs) $ E.where_ $ E.or [ ilog E.^. InterfaceLogInterface E.==. E.val ifce E.&&. ilog E.^. InterfaceLogSubtype E.=~. E.val subt E.&&. ilog E.^. InterfaceLogWrite E.=~. E.val writ | (UniqueInterfaceHealth ifce subt writ) <- interfs - ] - let ihour = E.coalesceDefault [ihealth E.?. InterfaceHealthHours] (E.val 48) + ] + let ihour = E.coalesceDefault [ihealth E.?. InterfaceHealthHours] (E.val 48) return (ilog, ihour, E.joinV $ ihealth E.?. InterfaceHealthMessage) siteLayoutMsg MsgMenuHealthInterface $ do setTitleI MsgMenuHealthInterface [whamlet| TODO This page is not yet fully implemented - +

                                                  $forall i <- res
                                                • diff --git a/src/Handler/LMS/Report.hs b/src/Handler/LMS/Report.hs index a0a6fefb6..2e3ffb00b 100644 --- a/src/Handler/LMS/Report.hs +++ b/src/Handler/LMS/Report.hs @@ -294,8 +294,7 @@ postLmsReportUploadR sid qsh = do setTitleI MsgMenuLmsUpload [whamlet|$newline never - ^{widget} -

                                                  + ^{widget} |] diff --git a/src/Handler/Utils/DateTime.hs b/src/Handler/Utils/DateTime.hs index 49cc6a7ba..2b05f208f 100644 --- a/src/Handler/Utils/DateTime.hs +++ b/src/Handler/Utils/DateTime.hs @@ -93,8 +93,8 @@ toMorning = toTimeOfDay 6 0 0 toTimeOfDay :: Int -> Int -> Pico -> Day -> UTCTime toTimeOfDay todHour todMin todSec d = localTimeToUTCTZ appTZ $ LocalTime d TimeOfDay{..} -addHours :: Integer -> UTCTime -> UTCTime -addHours = addUTCTime . secondsToNominalDiffTime . fromInteger . (* 3600) +addHours :: Integral n => n -> UTCTime -> UTCTime +addHours = addUTCTime . secondsToNominalDiffTime . fromIntegral . (* 3600) instance HasLocalTime UTCTime where toLocalTime = utcToLocalTime From c71814d1ef1efc16c278136dfd6ebd86bd1d20db Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 2 Feb 2024 18:43:57 +0100 Subject: [PATCH 141/159] fix(health): fix #151 by offering route /health/interface/* --- .../uniworx/categories/admin/de-de-formal.msg | 5 +- messages/uniworx/categories/admin/en-eu.msg | 5 +- models/audit.model | 3 +- src/Handler/Admin.hs | 81 +----------- src/Handler/Health/Interface.hs | 118 ++++++++++++------ templates/admin-problems.hamlet | 7 +- 6 files changed, 100 insertions(+), 119 deletions(-) diff --git a/messages/uniworx/categories/admin/de-de-formal.msg b/messages/uniworx/categories/admin/de-de-formal.msg index ad521c490..6fb6a2836 100644 --- a/messages/uniworx/categories/admin/de-de-formal.msg +++ b/messages/uniworx/categories/admin/de-de-formal.msg @@ -121,10 +121,13 @@ ProblemsAvsSynchHeading: Synchronisation AVS Fahrberechtigungen ProblemsAvsErrorHeading: Fehlermeldungen ProblemsInterfaceSince: Berücksichtigt werden nur Erfolge und Fehler seit +InterfacesOk: Schnittstellen sind ok. +InterfacesFail n@Int: #{tshow n} Schnittstellenprobleme! InterfaceStatus !ident-ok: Status InterfaceName: Schnittstelle InterfaceLastSynch: Zuletzt InterfaceSubtype: Betreffend InterfaceWrite: Schreibend InterfaceSuccess: Rückmeldung -InterfaceInfo: Nachricht \ No newline at end of file +InterfaceInfo: Nachricht +InterfaceFreshness: Prüfungszeitraum (h) \ No newline at end of file diff --git a/messages/uniworx/categories/admin/en-eu.msg b/messages/uniworx/categories/admin/en-eu.msg index c73fd8910..74420ff19 100644 --- a/messages/uniworx/categories/admin/en-eu.msg +++ b/messages/uniworx/categories/admin/en-eu.msg @@ -121,10 +121,13 @@ ProblemsAvsSynchHeading: Synchronisation AVS Driving Licences ProblemsAvsErrorHeading: Error Log ProblemsInterfaceSince: Only considering successes and errors since +InterfacesOk: Interfaces are ok. +InterfacesFail n: #{tshow n} Interface problems! InterfaceStatus: Status InterfaceName: Interface InterfaceLastSynch: Last InterfaceSubtype: Affecting InterfaceWrite: Write InterfaceSuccess: Returned -InterfaceInfo: Message \ No newline at end of file +InterfaceInfo: Message +InterfaceFreshness: Check hours \ No newline at end of file diff --git a/models/audit.model b/models/audit.model index defb5c391..3cd567a13 100644 --- a/models/audit.model +++ b/models/audit.model @@ -26,7 +26,6 @@ InterfaceHealth interface Text subtype Text Maybe write Bool Maybe - hours Int - message Text Maybe + hours Int UniqueInterfaceHealth interface subtype write !force -- Note that nullable fields must be either empty or unique deriving Eq Read Show Generic diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index 92dcac020..fd001c768 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -24,6 +24,7 @@ import qualified Database.Esqueleto.Utils as E import Handler.Utils import Handler.Utils.Avs import Handler.Utils.Users +import Handler.Health.Interface import Handler.Admin.Test as Handler.Admin import Handler.Admin.ErrorMessage as Handler.Admin @@ -54,13 +55,15 @@ getAdminProblemsR = do flagNonZero n | n <= 0 = flagError True | otherwise = messageTooltip =<< handlerToWidget (messageI Error (MsgProblemsDriverSynch n)) - (usersAreReachable, driversHaveAvsIds, rDriversHaveFs, noStalePrintJobs, noBadAPCids, interfaceTable) <- runDB $ (,,,,,) + (usersAreReachable, driversHaveAvsIds, rDriversHaveFs, noStalePrintJobs, noBadAPCids, (interfaceOks, interfaceTable)) <- runDB $ (,,,,,) <$> areAllUsersReachable <*> allDriversHaveAvsId now <*> allRDriversHaveFs now <*> (not <$> exists [PrintJobAcknowledged ==. Nothing, PrintJobCreated <. cutOffOldTime]) <*> (not <$> exists [PrintAcknowledgeProcessed ==. False]) - <*> fmap (view _2) (mkInterfaceLogTable flagError cutOffOldTime) + <*> mkInterfaceLogTable flagError mempty + let interfacesBadNr = length $ filter (not . snd) interfaceOks + -- interfacesOk = all snd interfaceOks diffLics <- try retrieveDifferingLicences >>= \case -- (Left (UnsupportedContentType "text/html" resp)) -> Left $ text2widget "Html received" (Left e) -> return $ Left $ text2widget $ tshow (e :: SomeException) @@ -235,77 +238,3 @@ retrieveDriversRWithoutF now = do E.where_ $ E.exists (hasValidQual AvsLicenceRollfeld) E.&&. E.notExists (hasValidQual AvsLicenceVorfeld) return usr - - - - - -mkInterfaceLogTable :: (Bool -> Widget) -> UTCTime -> DB (Any, Widget) -mkInterfaceLogTable flagError cutOffOldTime = do - avsSynchStats <- E.select $ do - uavs <- E.from $ E.table @UserAvs - E.where_ $ uavs E.^. UserAvsLastSynch E.>. E.val cutOffOldTime - let isOk = E.isNothing (uavs E.^. UserAvsLastSynchError) - E.groupBy isOk - E.orderBy [E.descNullsLast isOk] - return (isOk, E.countRows, E.max_ $ uavs E.^. UserAvsLastSynch) - let - mkBadInfo badRows (fromMaybe cutOffOldTime -> badTime) | badRows > 0 = do - fmtCut <- formatTime SelFormatDate cutOffOldTime - fmtBad <- formatTime SelFormatDateTime badTime - return $ tshow badRows <> " Fehler seit " <> fmtCut <> ", zuletzt um " <> fmtBad - mkBadInfo _ _ = return mempty - writeAvsSynchStats okRows (fromMaybe cutOffOldTime -> okTime) badInfo = - void $ upsertBy (UniqueInterfaceSubtypeWrite "AVS" "Synch" True) - (InterfaceLog "AVS" "Synch" True okTime okRows badInfo (null badInfo)) - [InterfaceLogTime =. okTime, InterfaceLogRows =. okRows, InterfaceLogInfo =. badInfo, InterfaceLogSuccess =. null badInfo] - --case $(unValueN 3) <$> avsSynchStats of - case avsSynchStats of - ((E.Value True , E.Value okRows, E.Value okTime):(E.Value False, E.Value badRows, E.Value badTime):_) -> - writeAvsSynchStats (Just okRows) okTime =<< mkBadInfo badRows badTime - ((E.Value True , E.Value okRows, E.Value okTime):_) -> - writeAvsSynchStats (Just okRows) okTime mempty - ((E.Value False, E.Value badRows, E.Value badTime):_) -> do - lastOk <- userAvsLastSynch . entityVal <<$>> selectFirst [UserAvsLastSynchError ==. Nothing] [Desc UserAvsLastSynch] - writeAvsSynchStats Nothing lastOk =<< mkBadInfo badRows badTime - _ -> return () - - let - flagOld = flagError . (cutOffOldTime <) - resultDBTable = DBTable{..} - where - resultILog :: Lens' (DBRow (Entity InterfaceLog)) InterfaceLog - resultILog = _dbrOutput . _entityVal - dbtSQLQuery = return - dbtRowKey = (E.^. InterfaceLogId) - dbtProj = dbtProjId - dbtColonnade = dbColonnade $ mconcat - [ sortable Nothing (textCell "Status" ) $ wgtCell . flagOld . view (resultILog . _interfaceLogTime) - , sortable (Just "interface") (textCell "Interface" ) $ \(view (resultILog . _interfaceLogInterface) -> n) -> textCell n - , sortable (Just "subtype") (i18nCell MsgInterfaceSubtype ) $ textCell . view (resultILog . _interfaceLogSubtype) - , sortable (Just "write") (i18nCell MsgInterfaceWrite ) $ (`ifIconCell` IconEdit) . view (resultILog . _interfaceLogWrite) - , sortable (Just "time") (i18nCell MsgInterfaceLastSynch ) $ dateTimeCell . view (resultILog . _interfaceLogTime) - , sortable (Just "rows") (i18nCell MsgTableRows ) $ cellMaybe numCell . view (resultILog . _interfaceLogRows) - , sortable Nothing (textCell "Info" ) $ \(view resultILog -> ilt) -> case ilt of - InterfaceLog "AVS" "Synch" True _ _ i _ -> anchorCell ProblemAvsErrorR $ toWgt $ bool i "AVS-Log" $ null i - InterfaceLog "LPR" _ _ _ _ i _ -> anchorCell PrintLogR $ toWgt $ bool i "LPR-Log" $ null i - InterfaceLog _ _ _ _ _ i _ -> textCell i - ] - dbtSorting = mconcat - [ singletonMap "interface" $ SortColumn (E.^. InterfaceLogInterface) - , singletonMap "subtype" $ SortColumn (E.^. InterfaceLogSubtype) - , singletonMap "write" $ SortColumn (E.^. InterfaceLogWrite) - , singletonMap "time" $ SortColumn (E.^. InterfaceLogTime) - , singletonMap "rows" $ SortColumn (E.^. InterfaceLogRows) - ] - dbtFilter = mempty - dbtFilterUI = mempty - dbtStyle = def - dbtIdent = "interface-log" :: Text - dbtParams = def - dbtCsvEncode = noCsvEncode - dbtCsvDecode = Nothing - dbtExtraReps = [] - resultDBTableValidator = def - & defaultSorting [SortAscBy "interface", SortAscBy "subtype", SortAscBy "write"] - dbTable resultDBTableValidator resultDBTable \ No newline at end of file diff --git a/src/Handler/Health/Interface.hs b/src/Handler/Health/Interface.hs index e623901f1..d1b8a0af0 100644 --- a/src/Handler/Health/Interface.hs +++ b/src/Handler/Health/Interface.hs @@ -8,6 +8,8 @@ module Handler.Health.Interface ( getHealthInterfaceR + , mkInterfaceLogTable + , runInterfaceChecks ) where @@ -17,7 +19,7 @@ import Import import qualified Data.Text as Text import Handler.Utils -import Database.Esqueleto.Experimental ((:&)(..)) +-- import Database.Esqueleto.Experimental ((:&)(..)) import qualified Database.Esqueleto.Experimental as E import qualified Database.Esqueleto.Utils as E import qualified Database.Esqueleto.Legacy as EL (on) @@ -43,8 +45,39 @@ pbool (Text.toLower . Text.strip -> w) | w `elem` ["0", "f", "false","falsch"] = Just False | otherwise = Nothing -mkInterfaceLogTable :: [Unique InterfaceHealth] -> (Bool -> Widget) -> DB ([(Text,Bool)], Widget) -mkInterfaceLogTable interfs flagError = do + + +getHealthInterfaceR :: [Text] -> Handler Html +getHealthInterfaceR ris = do + let interfs = identifyInterfaces ris + (missing, allok, res, iltable) <- runInterfaceLogTable interfs + when missing notFound -- send 404 if an interface any interface was not found + unless allok $ sendResponseStatus internalServerError500 $ "Unhealthy interfaces: " <> Text.intercalate ", " [iface | (iface, False) <- res] + siteLayoutMsg MsgMenuHealthInterface $ do + setTitleI MsgMenuHealthInterface + [whamlet| + Interfaces healthy. + + ^{iltable} + |] + + +runInterfaceLogTable :: [Unique InterfaceHealth] -> Handler (Bool, Bool, [(Text,Bool)], Widget) +runInterfaceLogTable interfs = do + -- we abuse messageTooltip for colored icons here + msgSuccessTooltip <- messageI Success MsgMessageSuccess + -- msgWarningTooltip <- messageI Warning MsgMessageWarning + msgErrorTooltip <- messageI Error MsgMessageError + let flagError = messageTooltip . bool msgErrorTooltip msgSuccessTooltip + (res, twgt) <- runDB $ mkInterfaceLogTable flagError interfs + let missing = notNull [ifce | (UniqueInterfaceHealth ifce _subt _writ) <- interfs, ifce `notElem` (fst <$> res) ] + allok = all snd res + return (missing, allok, res, twgt) + + +mkInterfaceLogTable :: (Bool -> Widget) -> [Unique InterfaceHealth] -> DB ([(Text,Bool)], Widget) +mkInterfaceLogTable flagError interfs = do + runInterfaceChecks now <- liftIO getCurrentTime dbTableDB ilvalidator DBTable{dbtColonnade=colonnade now, ..} where @@ -62,16 +95,14 @@ mkInterfaceLogTable interfs flagError = do | (UniqueInterfaceHealth ifce subt writ) <- interfs ] let ihour = E.coalesceDefault [ihealth E.?. InterfaceHealthHours] (E.val $ 3 * 24) -- if no default time is set, use 3 days instead - return (ilog, ihour, E.joinV $ ihealth E.?. InterfaceHealthMessage) + return (ilog, ihour) queryILog :: (E.SqlExpr (Entity InterfaceLog) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity InterfaceHealth))) -> E.SqlExpr (Entity InterfaceLog) queryILog = $(E.sqlLOJproj 2 1) - resultILog :: Lens' (DBRow (Entity InterfaceLog, E.Value Int, E.Value (Maybe Text))) InterfaceLog + resultILog :: Lens' (DBRow (Entity InterfaceLog, E.Value Int)) InterfaceLog resultILog = _dbrOutput . _1 . _entityVal - resultHours :: Lens' (DBRow (Entity InterfaceLog, E.Value Int, E.Value (Maybe Text))) Int + resultHours :: Lens' (DBRow (Entity InterfaceLog, E.Value Int)) Int resultHours = _dbrOutput . _2 . E._unValue - -- resultErrMsg :: Traversal' (DBRow (Entity InterfaceLog, E.Value Int, E.Value (Maybe Text))) Text - -- resultErrMsg = _dbrOutput . _3 . E._unValue . _Just dbtRowKey = queryILog >>> (E.^.InterfaceLogId) colonnade now = mconcat @@ -88,6 +119,7 @@ mkInterfaceLogTable interfs flagError = do , sortable (Just "subtype") (i18nCell MsgInterfaceSubtype ) $ textCell . view (resultILog . _interfaceLogSubtype) , sortable (Just "write") (i18nCell MsgInterfaceWrite ) $ (`ifIconCell` IconEdit) . view (resultILog . _interfaceLogWrite) , sortable (Just "time") (i18nCell MsgInterfaceLastSynch ) $ dateTimeCell . view (resultILog . _interfaceLogTime) + , sortable Nothing (i18nCell MsgInterfaceFreshness ) $ numCell . view resultHours , sortable (Just "rows") (i18nCell MsgTableRows ) $ cellMaybe numCell . view (resultILog . _interfaceLogRows) , sortable (Just "success") (i18nCell MsgInterfaceSuccess ) $ \(view (resultILog . _interfaceLogSuccess) -> s) -> iconBoolCell s , sortable Nothing (i18nCell MsgInterfaceInfo ) $ \(view resultILog -> ilt) -> case ilt of @@ -95,6 +127,7 @@ mkInterfaceLogTable interfs flagError = do InterfaceLog "LPR" _ _ _ _ i _ -> anchorCell PrintLogR $ toWgt $ bool i "LPR-Log" $ null i InterfaceLog _ _ _ _ _ i _ -> textCell i ] + dbtSorting = mconcat [ singletonMap "interface" $ SortColumn $ queryILog >>> (E.^. InterfaceLogInterface) , singletonMap "subtype" $ SortColumn $ queryILog >>> (E.^. InterfaceLogSubtype) @@ -113,33 +146,44 @@ mkInterfaceLogTable interfs flagError = do dbtExtraReps = [] +-- | runs additional checks and logs results within InterfaceLogTable; assumed to executable within a handler call +runInterfaceChecks :: DB () +runInterfaceChecks = do + avsInterfaceCheck + lprAckCheck + +lprAckCheck :: DB () +lprAckCheck = return () -- !!! TODO !!! Stub + -- ensure that all received apc-idents were ok -getHealthInterfaceR :: [Text] -> Handler Html -getHealthInterfaceR ris = do - let interfs = identifyInterfaces ris - res <- runDB $ E.select $ do - (ilog :& ihealth) <- E.from (E.table @InterfaceLog - `E.leftJoin` E.table @InterfaceHealth - `E.on` (\(ilog :& ihealth) -> - ilog E.^. InterfaceLogInterface E.=?. ihealth E.?. InterfaceHealthInterface - E.&&. ilog E.^. InterfaceLogSubtype E.=~. E.joinV (ihealth E.?. InterfaceHealthSubtype) - E.&&. ilog E.^. InterfaceLogWrite E.=~. E.joinV (ihealth E.?. InterfaceHealthWrite ) - )) - unless (null interfs) $ - E.where_ $ E.or [ ilog E.^. InterfaceLogInterface E.==. E.val ifce - E.&&. ilog E.^. InterfaceLogSubtype E.=~. E.val subt - E.&&. ilog E.^. InterfaceLogWrite E.=~. E.val writ - | (UniqueInterfaceHealth ifce subt writ) <- interfs - ] - let ihour = E.coalesceDefault [ihealth E.?. InterfaceHealthHours] (E.val 48) - return (ilog, ihour, E.joinV $ ihealth E.?. InterfaceHealthMessage) - siteLayoutMsg MsgMenuHealthInterface $ do - setTitleI MsgMenuHealthInterface - [whamlet| - TODO This page is not yet fully implemented - -

                                                    - $forall i <- res -
                                                  • - #{show i} - |] +avsInterfaceCheck :: DB () +avsInterfaceCheck = flip (maybeM $ return ()) (getBy $ UniqueInterfaceHealth "AVS" (Just "Synch") (Just True)) $ \Entity{entityVal=InterfaceHealth{interfaceHealthHours}} -> do + now <- liftIO getCurrentTime + let cutOffOldTime = addHours (-interfaceHealthHours) now + avsSynchStats <- E.select $ do + uavs <- E.from $ E.table @UserAvs + E.where_ $ uavs E.^. UserAvsLastSynch E.>. E.val cutOffOldTime + let isOk = E.isNothing (uavs E.^. UserAvsLastSynchError) + E.groupBy isOk + E.orderBy [E.descNullsLast isOk] + return (isOk, E.countRows, E.max_ $ uavs E.^. UserAvsLastSynch) + let + mkBadInfo badRows (fromMaybe cutOffOldTime -> badTime) | badRows > 0 = do + fmtCut <- formatTime SelFormatDate cutOffOldTime + fmtBad <- formatTime SelFormatDateTime badTime + return $ tshow badRows <> " Fehler seit " <> fmtCut <> ", zuletzt um " <> fmtBad + mkBadInfo _ _ = return mempty + writeAvsSynchStats okRows (fromMaybe cutOffOldTime -> okTime) badInfo = + void $ upsertBy (UniqueInterfaceSubtypeWrite "AVS" "Synch" True) + (InterfaceLog "AVS" "Synch" True okTime okRows badInfo (null badInfo)) + [InterfaceLogTime =. okTime, InterfaceLogRows =. okRows, InterfaceLogInfo =. badInfo, InterfaceLogSuccess =. null badInfo] + --case $(unValueN 3) <$> avsSynchStats of + case avsSynchStats of + ((E.Value True , E.Value okRows, E.Value okTime):(E.Value False, E.Value badRows, E.Value badTime):_) -> + writeAvsSynchStats (Just okRows) okTime =<< mkBadInfo badRows badTime + ((E.Value True , E.Value okRows, E.Value okTime):_) -> + writeAvsSynchStats (Just okRows) okTime mempty + ((E.Value False, E.Value badRows, E.Value badTime):_) -> do + lastOk <- userAvsLastSynch . entityVal <<$>> selectFirst [UserAvsLastSynchError ==. Nothing] [Desc UserAvsLastSynch] + writeAvsSynchStats Nothing lastOk =<< mkBadInfo badRows badTime + _ -> return () diff --git a/templates/admin-problems.hamlet b/templates/admin-problems.hamlet index d07df69fd..b2a48143b 100644 --- a/templates/admin-problems.hamlet +++ b/templates/admin-problems.hamlet @@ -56,8 +56,11 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later

                                                    _{MsgMenuInterfaces}
                                                    -

                                                    - _{MsgProblemsInterfaceSince} ^{formatTimeW SelFormatDate cutOffOldTime} +

                                                    + $if interfacesBadNr > 0 + _{MsgInterfacesFail interfacesBadNr} + $else + _{MsgInterfacesOk} ^{interfaceTable} From ce3852e3d365e62b32d181d58b7cbcc749e49373 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 5 Feb 2024 18:54:50 +0100 Subject: [PATCH 142/159] fix(health): fix #153 and offer interface health route matching --- .../uniworx/categories/admin/de-de-formal.msg | 2 +- messages/uniworx/categories/admin/en-eu.msg | 2 +- src/Audit.hs | 38 +++- src/Handler/Health/Interface.hs | 165 ++++++++++++------ src/Model/Migration/Definitions.hs | 8 + src/Utils.hs | 11 +- src/Utils/Lens.hs | 1 + src/Utils/Print.hs | 4 +- 8 files changed, 167 insertions(+), 64 deletions(-) diff --git a/messages/uniworx/categories/admin/de-de-formal.msg b/messages/uniworx/categories/admin/de-de-formal.msg index 6fb6a2836..eb6cfe753 100644 --- a/messages/uniworx/categories/admin/de-de-formal.msg +++ b/messages/uniworx/categories/admin/de-de-formal.msg @@ -122,7 +122,7 @@ ProblemsAvsErrorHeading: Fehlermeldungen ProblemsInterfaceSince: Berücksichtigt werden nur Erfolge und Fehler seit InterfacesOk: Schnittstellen sind ok. -InterfacesFail n@Int: #{tshow n} Schnittstellenprobleme! +InterfacesFail n@Int: #{pluralDEeN n "Schnittstellenproblem"}! InterfaceStatus !ident-ok: Status InterfaceName: Schnittstelle InterfaceLastSynch: Zuletzt diff --git a/messages/uniworx/categories/admin/en-eu.msg b/messages/uniworx/categories/admin/en-eu.msg index 74420ff19..13f35ed9f 100644 --- a/messages/uniworx/categories/admin/en-eu.msg +++ b/messages/uniworx/categories/admin/en-eu.msg @@ -122,7 +122,7 @@ ProblemsAvsErrorHeading: Error Log ProblemsInterfaceSince: Only considering successes and errors since InterfacesOk: Interfaces are ok. -InterfacesFail n: #{tshow n} Interface problems! +InterfacesFail n: #{pluralENsN n "interface problem"}! InterfaceStatus: Status InterfaceName: Interface InterfaceLastSynch: Last diff --git a/src/Audit.hs b/src/Audit.hs index f26af2d80..40c4a4206 100644 --- a/src/Audit.hs +++ b/src/Audit.hs @@ -8,7 +8,7 @@ module Audit , audit , AuditRemoteException(..) , getRemote - , logInterface + , logInterface, logInterface' ) where @@ -128,11 +128,39 @@ logInterface :: ( AuthId (HandlerSite m) ~ Key User -> Text -- ^ Any additional information -> ReaderT (YesodPersistBackend (HandlerSite m)) m () -- ^ Log a transaction using information available from `HandlerT`, also calls `audit` -logInterface (Text.strip -> interfaceLogInterface) (Text.strip -> interfaceLogSubtype) interfaceLogSuccess interfaceLogRows (Text.strip -> interfaceLogInfo) = do - interfaceLogTime <- liftIO getCurrentTime +logInterface interfaceLogInterface interfaceLogSubtype interfaceLogSuccess interfaceLogRows interfaceLogInfo = do interfaceLogWrite <- (methodGet /=) . Wai.requestMethod . reqWaiRequest <$> getRequest - deleteBy $ UniqueInterfaceSubtypeWrite interfaceLogInterface interfaceLogSubtype interfaceLogWrite -- always replace, deleteBy & insert seems to be safest and fastest - insert_ InterfaceLog{..} + logInterface' interfaceLogInterface interfaceLogSubtype interfaceLogWrite interfaceLogSuccess interfaceLogRows interfaceLogInfo + +logInterface' :: ( AuthId (HandlerSite m) ~ Key User + , IsSqlBackend (YesodPersistBackend (HandlerSite m)) + , SqlBackendCanWrite (YesodPersistBackend (HandlerSite m)) + , HasInstanceID (HandlerSite m) InstanceId + , YesodAuthPersist (HandlerSite m) + , MonadHandler m + , MonadCatch m + , HasAppSettings (HandlerSite m) + , HasCallStack + ) + => Text -- ^ Interface that is used + -> Text -- ^ Subtype of the interface, if any + -> Bool -- ^ True indicates Write Access to FRADrive + -> Bool -- ^ Success=True, Failure=False + -> Maybe Int -- ^ Number of transmitted datasets + -> Text -- ^ Any additional information + -> ReaderT (YesodPersistBackend (HandlerSite m)) m () +-- ^ Log a transaction using information available from `HandlerT`, also calls `audit` +logInterface' (Text.strip -> interfaceLogInterface) (Text.strip -> interfaceLogSubtype) interfaceLogWrite interfaceLogSuccess interfaceLogRows (Text.strip -> interfaceLogInfo) = do + interfaceLogTime <- liftIO getCurrentTime + -- deleteBy $ UniqueInterfaceSubtypeWrite interfaceLogInterface interfaceLogSubtype interfaceLogWrite -- always replace: deleteBy & insert seems to be safest and fastest + -- insert_ InterfaceLog{..} + void $ upsertBy (UniqueInterfaceSubtypeWrite interfaceLogInterface interfaceLogSubtype interfaceLogWrite) + ( InterfaceLog{..} ) + [ InterfaceLogTime =. interfaceLogTime + , InterfaceLogRows =. interfaceLogRows + , InterfaceLogInfo =. interfaceLogInfo + , InterfaceLogSuccess =. interfaceLogSuccess + ] audit TransactionInterface { transactionInterfaceName = interfaceLogInterface , transactionInterfaceSubtype = interfaceLogSubtype diff --git a/src/Handler/Health/Interface.hs b/src/Handler/Health/Interface.hs index d1b8a0af0..c43ffaed8 100644 --- a/src/Handler/Health/Interface.hs +++ b/src/Handler/Health/Interface.hs @@ -18,24 +18,21 @@ import Import -- import qualified Data.Set as Set import qualified Data.Text as Text import Handler.Utils +import Handler.Utils.Concurrent -- import Database.Esqueleto.Experimental ((:&)(..)) import qualified Database.Esqueleto.Experimental as E import qualified Database.Esqueleto.Utils as E import qualified Database.Esqueleto.Legacy as EL (on) +import qualified Database.Persist.Sql as E (deleteWhereCount) -identifyInterfaces :: [Text] -> [Unique InterfaceHealth] -identifyInterfaces [] = [] -identifyInterfaces [i] = [UniqueInterfaceHealth i Nothing Nothing] -identifyInterfaces [i,s] = [UniqueInterfaceHealth i (wc2null s) Nothing] -identifyInterfaces (i:s:w:r) = UniqueInterfaceHealth i (wc2null s) (pbool w) : identifyInterfaces r - -- | identify a wildcard argument wc2null :: Text -> Maybe Text -wc2null "." = Nothing +-- wc2null "." = Nothing -- does not work, since dots are eliminated in URLs -- wc2null "-" = Nothing -- used as wildcard subtype in lpr interface wc2null "_" = Nothing +wc2null "*" = Nothing wc2null o = Just o -- | sloppily parse a boolean, also see Model.Types.Avs.SloppyBool @@ -45,55 +42,92 @@ pbool (Text.toLower . Text.strip -> w) | w `elem` ["0", "f", "false","falsch"] = Just False | otherwise = Nothing +-- | parse UniqueInterfaceHealth with subtype and write arguments being optional for the last interface. Wildcards '_' or '.' are also allowed in all places. +identifyInterfaces :: [Text] -> [Unique InterfaceHealth] +identifyInterfaces [] = [] +identifyInterfaces [i] = [UniqueInterfaceHealth i Nothing Nothing] +identifyInterfaces [i,s] = [UniqueInterfaceHealth i (wc2null s) Nothing] +identifyInterfaces (i:s:w:r) = UniqueInterfaceHealth i (wc2null s) (pbool w) : identifyInterfaces r + +type ReqBanInterfaceHealth = ([Unique InterfaceHealth],[Unique InterfaceHealth]) + +-- | Interface names prefixed with '-' are to be excluded from the query +splitInterfaces :: [Unique InterfaceHealth] -> ReqBanInterfaceHealth +splitInterfaces = foldl' aux mempty + where + aux (reqs,bans) uih@(UniqueInterfaceHealth i s w) + | Just ('-', b) <- Text.uncons i = (reqs, UniqueInterfaceHealth b s w : bans) + | otherwise = (uih : reqs, bans) + +-- | check whether the first argument is equal or more specialzed (i.e. more Just) than the second +matchesUniqueInterfaceHealth :: Unique InterfaceHealth -> Unique InterfaceHealth -> Bool +matchesUniqueInterfaceHealth (UniqueInterfaceHealth ai as aw) (UniqueInterfaceHealth bi bs bw) = ai == bi && eqOrNothing as bs && eqOrNothing aw bw + where + eqOrNothing _ Nothing = True + eqOrNothing a b = a == b getHealthInterfaceR :: [Text] -> Handler Html getHealthInterfaceR ris = do - let interfs = identifyInterfaces ris - (missing, allok, res, iltable) <- runInterfaceLogTable interfs - when missing notFound -- send 404 if an interface any interface was not found - unless allok $ sendResponseStatus internalServerError500 $ "Unhealthy interfaces: " <> Text.intercalate ", " [iface | (iface, False) <- res] - siteLayoutMsg MsgMenuHealthInterface $ do + let (forced, ris') = case ris of + ("force":ris0) -> (True , ris0) + _ -> (False, ris ) + interfs = splitInterfaces $ identifyInterfaces ris' + (missing, allok, res, iltable) <- runInterfaceLogTable interfs + let badMsg = "Unhealthy interfaces: " <> Text.intercalate ", " [iface | (iface, False) <- res] + when missing notFound -- send 404 if any requested interface was not found + unless (forced || allok) $ sendResponseStatus internalServerError500 badMsg + content <- siteLayoutMsg MsgMenuHealthInterface $ do setTitleI MsgMenuHealthInterface [whamlet| - Interfaces healthy. + $if allok + Interfaces are healthy. + $else + #{badMsg} ^{iltable} |] + sendResponseStatus (bool internalServerError500 status200 allok) content -runInterfaceLogTable :: [Unique InterfaceHealth] -> Handler (Bool, Bool, [(Text,Bool)], Widget) -runInterfaceLogTable interfs = do +runInterfaceLogTable :: ReqBanInterfaceHealth -> Handler (Bool, Bool, [(Text,Bool)], Widget) +runInterfaceLogTable interfs@(reqIfs,_) = do -- we abuse messageTooltip for colored icons here msgSuccessTooltip <- messageI Success MsgMessageSuccess -- msgWarningTooltip <- messageI Warning MsgMessageWarning msgErrorTooltip <- messageI Error MsgMessageError let flagError = messageTooltip . bool msgErrorTooltip msgSuccessTooltip (res, twgt) <- runDB $ mkInterfaceLogTable flagError interfs - let missing = notNull [ifce | (UniqueInterfaceHealth ifce _subt _writ) <- interfs, ifce `notElem` (fst <$> res) ] + let missing = notNull [ifce | (UniqueInterfaceHealth ifce _subt _writ) <- reqIfs, ifce `notElem` (fst <$> res) ] allok = all snd res return (missing, allok, res, twgt) +-- ihDebugShow :: Unique InterfaceHealth -> Text +-- ihDebugShow (UniqueInterfaceHealth i s w) = "(" <> tshow i <> tshow s <> tshow w <> ")" -mkInterfaceLogTable :: (Bool -> Widget) -> [Unique InterfaceHealth] -> DB ([(Text,Bool)], Widget) -mkInterfaceLogTable flagError interfs = do - runInterfaceChecks +mkInterfaceLogTable :: (Bool -> Widget) -> ReqBanInterfaceHealth -> DB ([(Text,Bool)], Widget) +mkInterfaceLogTable flagError interfs@(reqIfs, banIfs) = do + -- $logWarnS "DEBUG" $ tshow ([ihDebugShow x | x<- reqIfs], [ihDebugShow x | x<- banIfs]) + void $ liftHandler $ timeoutHandler 42000001 $ runDB $ runInterfaceChecks interfs now <- liftIO getCurrentTime dbTableDB ilvalidator DBTable{dbtColonnade=colonnade now, ..} where + sanitize = text2AlphaNumPlus ['+','-','_','Ä','Ö','Ü','ß','ä','ö','ü'] dbtIdent = "interface-log" :: Text dbtProj = dbtProjId dbtSQLQuery (ilog `E.LeftOuterJoin` ihealth) = do EL.on ( ilog E.^. InterfaceLogInterface E.=?. ihealth E.?. InterfaceHealthInterface - E.&&. ilog E.^. InterfaceLogSubtype E.=~. E.joinV (ihealth E.?. InterfaceHealthSubtype) - E.&&. ilog E.^. InterfaceLogWrite E.=~. E.joinV (ihealth E.?. InterfaceHealthWrite ) + E.&&. ilog E.^. InterfaceLogSubtype E.=~. E.joinV (ihealth E.?. InterfaceHealthSubtype) + E.&&. ilog E.^. InterfaceLogWrite E.=~. E.joinV (ihealth E.?. InterfaceHealthWrite ) ) - unless (null interfs) $ - E.where_ $ E.or [ ilog E.^. InterfaceLogInterface E.==. E.val ifce - E.&&. ilog E.^. InterfaceLogSubtype E.=~. E.val subt - E.&&. ilog E.^. InterfaceLogWrite E.=~. E.val writ - | (UniqueInterfaceHealth ifce subt writ) <- interfs - ] + let matchUIH crits = E.or + [ ilog E.^. InterfaceLogInterface E.==. E.val (sanitize ifce) + E.&&. ilog E.^. InterfaceLogSubtype E.=~. E.val (sanitize <$> subt) + E.&&. ilog E.^. InterfaceLogWrite E.=~. E.val writ + | (UniqueInterfaceHealth ifce subt writ) <- crits + ] + unless (null reqIfs) $ E.where_ $ matchUIH reqIfs + unless (null banIfs) $ E.where_ $ E.not_ $ matchUIH banIfs let ihour = E.coalesceDefault [ihealth E.?. InterfaceHealthHours] (E.val $ 3 * 24) -- if no default time is set, use 3 days instead return (ilog, ihour) @@ -147,19 +181,46 @@ mkInterfaceLogTable flagError interfs = do -- | runs additional checks and logs results within InterfaceLogTable; assumed to executable within a handler call -runInterfaceChecks :: DB () -runInterfaceChecks = do - avsInterfaceCheck - lprAckCheck - -lprAckCheck :: DB () -lprAckCheck = return () -- !!! TODO !!! Stub - -- ensure that all received apc-idents were ok +runInterfaceChecks :: ReqBanInterfaceHealth -> DB () +runInterfaceChecks interfs = do + avsInterfaceCheck interfs + lprAckCheck interfs -avsInterfaceCheck :: DB () -avsInterfaceCheck = flip (maybeM $ return ()) (getBy $ UniqueInterfaceHealth "AVS" (Just "Synch") (Just True)) $ \Entity{entityVal=InterfaceHealth{interfaceHealthHours}} -> do - now <- liftIO getCurrentTime - let cutOffOldTime = addHours (-interfaceHealthHours) now +maybeRunCheck :: ReqBanInterfaceHealth -> Unique InterfaceHealth -> (UTCTime -> DB ()) -> DB () +maybeRunCheck (reqIfs,banIfs) uih act + | null reqIfs || any (matchesUniqueInterfaceHealth uih) reqIfs + , null banIfs || not (any (matchesUniqueInterfaceHealth uih) banIfs) = do + mih <- getBy uih + whenIsJust mih $ \eih -> do + now <- liftIO getCurrentTime + act $ addHours (negate $ interfaceHealthHours $ entityVal eih) now + | otherwise = return () + +-- maybeRunCheck :: Unique InterfaceHealth -> (Int -> DB ()) -> DB () +-- maybeRunCheck uih act = maybeM (return ()) (act . interfaceHealthHours . entityVal) $ getBy uih + -- maybeRunCheck uih act = getBy uih >>= flip whenIsJust (act . interfaceHealthHours . entityVal) + -- where + -- ih2hours :: Entity InterfaceHealth -> Int + -- -- ih2hours Entity{entityVal=InterfaceHealth{interfaceHealthHours=h}} = h + -- ih2hours = interfaceHealthHours . entityVal + + +lprAckCheck :: ReqBanInterfaceHealth -> DB () +lprAckCheck interfs = maybeRunCheck interfs (UniqueInterfaceHealth "Printer" (Just "Acknowledge") (Just True)) $ \cutOffOldTime -> do + unproc <- selectList [PrintAcknowledgeTimestamp <. cutOffOldTime, PrintAcknowledgeProcessed ==. False] [] + if notNull unproc + then mkLog False (Just $ length unproc) "Long unprocessed APC-Idents exist" + else do + oks <- E.deleteWhereCount [PrintAcknowledgeTimestamp <. cutOffOldTime, PrintAcknowledgeProcessed ==. True] + if oks > 0 + then mkLog True (Just $ fromIntegral oks) "Long processed APC-Idents removed" + else mkLog True Nothing mempty + where + mkLog = logInterface' "Printer" "Acknowledge" True + + +avsInterfaceCheck :: ReqBanInterfaceHealth -> DB () +avsInterfaceCheck interfs = maybeRunCheck interfs (UniqueInterfaceHealth "AVS" (Just "Synch") (Just True)) $ \cutOffOldTime -> do avsSynchStats <- E.select $ do uavs <- E.from $ E.table @UserAvs E.where_ $ uavs E.^. UserAvsLastSynch E.>. E.val cutOffOldTime @@ -167,23 +228,21 @@ avsInterfaceCheck = flip (maybeM $ return ()) (getBy $ UniqueInterfaceHealth "AV E.groupBy isOk E.orderBy [E.descNullsLast isOk] return (isOk, E.countRows, E.max_ $ uavs E.^. UserAvsLastSynch) - let + let mkBadInfo badRows (fromMaybe cutOffOldTime -> badTime) | badRows > 0 = do fmtCut <- formatTime SelFormatDate cutOffOldTime fmtBad <- formatTime SelFormatDateTime badTime return $ tshow badRows <> " Fehler seit " <> fmtCut <> ", zuletzt um " <> fmtBad mkBadInfo _ _ = return mempty - writeAvsSynchStats okRows (fromMaybe cutOffOldTime -> okTime) badInfo = - void $ upsertBy (UniqueInterfaceSubtypeWrite "AVS" "Synch" True) - (InterfaceLog "AVS" "Synch" True okTime okRows badInfo (null badInfo)) - [InterfaceLogTime =. okTime, InterfaceLogRows =. okRows, InterfaceLogInfo =. badInfo, InterfaceLogSuccess =. null badInfo] - --case $(unValueN 3) <$> avsSynchStats of - case avsSynchStats of - ((E.Value True , E.Value okRows, E.Value okTime):(E.Value False, E.Value badRows, E.Value badTime):_) -> - writeAvsSynchStats (Just okRows) okTime =<< mkBadInfo badRows badTime - ((E.Value True , E.Value okRows, E.Value okTime):_) -> - writeAvsSynchStats (Just okRows) okTime mempty - ((E.Value False, E.Value badRows, E.Value badTime):_) -> do - lastOk <- userAvsLastSynch . entityVal <<$>> selectFirst [UserAvsLastSynchError ==. Nothing] [Desc UserAvsLastSynch] - writeAvsSynchStats Nothing lastOk =<< mkBadInfo badRows badTime + writeAvsSynchStats okRows badInfo = + logInterface' "AVS" "Synch" True (null badInfo) okRows badInfo + --case $(unValueN 3) <$> avsSynchStats of + case avsSynchStats of + ((E.Value True , E.Value okRows, E.Value _okTime):(E.Value False, E.Value badRows, E.Value badTime):_) -> + writeAvsSynchStats (Just okRows) =<< mkBadInfo badRows badTime + ((E.Value True , E.Value okRows, E.Value _okTime):_) -> + writeAvsSynchStats (Just okRows) mempty + ((E.Value False, E.Value badRows, E.Value badTime):_) -> + -- lastOk <- userAvsLastSynch . entityVal <<$>> selectFirst [UserAvsLastSynchError ==. Nothing] [Desc UserAvsLastSynch] + writeAvsSynchStats Nothing =<< mkBadInfo badRows badTime _ -> return () diff --git a/src/Model/Migration/Definitions.hs b/src/Model/Migration/Definitions.hs index 8e458ac47..a875b9648 100644 --- a/src/Model/Migration/Definitions.hs +++ b/src/Model/Migration/Definitions.hs @@ -123,6 +123,14 @@ migrateAlwaysSafe = do let itemDay = Map.findWithDefault today item changelogItemDays return [st|('#{toPathPiece item}', '#{iso8601Show itemDay}')|] in sql + -- unless (tableExists "interface_health") $ do + -- [executeQQ| + -- INSERT INTO "interface_health" (interface, subtype, write, hours) + -- VALUES + -- ('Printer', 'Acknowledge', True, 168) + -- , ('AVS' , 'Synch' , True , 96) + -- ON CONFLICT DO NOTHING; + -- |] {- Confusion about quotes, from the PostgreSQL Manual: diff --git a/src/Utils.hs b/src/Utils.hs index 2093da8b2..c47f29992 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -23,7 +23,7 @@ import qualified Data.CaseInsensitive as CI import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as CBS -import qualified Data.Char as Char +-- import qualified Data.Char as Char import qualified Data.Text as Text import qualified Data.Text.Encoding as Text @@ -319,9 +319,16 @@ citext2string = Text.unpack . CI.original string2citext :: String -> CI Text string2citext = CI.mk . Text.pack +text2AlphaNumPlus :: [Char] -> Text -> Text +text2AlphaNumPlus = + let alphaNum = Set.fromAscList $ ['0'..'9'] <> ['A'..'Z'] <> ['a'..'z'] + in \oks -> + let aNumPlus = Set.fromList oks <> alphaNum + in Text.filter (`Set.member` aNumPlus) + -- | Convert or remove all non-ascii characters, e.g. for filenames text2asciiAlphaNum :: Text -> Text -text2asciiAlphaNum = Text.filter (\c -> Char.isAlphaNum c && Char.isAscii c) +text2asciiAlphaNum = text2AlphaNumPlus ['-','_'] . Text.replace "ä" "ae" . Text.replace "Ä" "Ae" . Text.replace "Æ" "ae" diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index 5e5f993c6..adcba7262 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -310,6 +310,7 @@ makeLenses_ ''AuthorshipStatementDefinition makeLenses_ ''PrintJob makeLenses_ ''InterfaceLog +-- makeLenses_ ''InterfaceLog -- not needed -------------------------- -- Fields for `UniWorX` -- diff --git a/src/Utils/Print.hs b/src/Utils/Print.hs index 8687158b8..d4dc3f882 100644 --- a/src/Utils/Print.hs +++ b/src/Utils/Print.hs @@ -270,7 +270,7 @@ printLetter' pji pdf = do printJobFile = LBS.toStrict pdf printJobAcknowledged = Nothing qshort <- ifMaybeM printJobQualification "-" $ fmap (maybe "_" $ CI.original . qualificationShorthand ) . get - let logInter = flip (logInterface "LPR" qshort) (Just 1) + let logInter = flip (logInterface "Printer" qshort) (Just 1) lprPDF printJobFilename pdf >>= \case Left err -> do logInter False err @@ -288,7 +288,7 @@ reprintPDF ignoreReroute pjid = maybeM (return $ Left "Print job id is unknown." reprint :: PrintJob -> DB (Either Text Text) reprint pj@PrintJob{..} = do qshort <- ifMaybeM printJobQualification "-" $ fmap (maybe "_" $ CI.original . qualificationShorthand ) . get - let logInter = flip (logInterface "LPR" qshort) (Just 1) + let logInter = flip (logInterface "Printer" qshort) (Just 1) result <- lprPDF' ignoreReroute printJobFilename $ LBS.fromStrict printJobFile case result of Left err -> From 1464a9a5822250f49d06391428bbd6b171cba461 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 6 Feb 2024 00:14:53 +0000 Subject: [PATCH 143/159] chore(release): 27.4.57 --- CHANGELOG.md | 9 +++++++++ nix/docker/version.json | 2 +- package-lock.json | 2 +- package.json | 2 +- package.yaml | 2 +- 5 files changed, 13 insertions(+), 4 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index d99bd198d..a09ca5698 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,15 @@ All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines. +## [27.4.57](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.56...v27.4.57) (2024-02-06) + + +### Bug Fixes + +* **course:** fix [#147](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/147) abort addd participant aborts now ([d332c0c](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/d332c0c11afd8b1dfe1343659f0b1626c968bbde)) +* **health:** fix [#151](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/151) by offering route /health/interface/* ([c71814d](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/c71814d1ef1efc16c278136dfd6ebd86bd1d20db)) +* **health:** fix [#153](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/153) and offer interface health route matching ([ce3852e](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/ce3852e3d365e62b32d181d58b7cbcc749e49373)) + ## [27.4.56](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.55...v27.4.56) (2023-12-20) diff --git a/nix/docker/version.json b/nix/docker/version.json index be8c9e7d6..2bc1d589a 100644 --- a/nix/docker/version.json +++ b/nix/docker/version.json @@ -1,3 +1,3 @@ { - "version": "27.4.56" + "version": "27.4.57" } diff --git a/package-lock.json b/package-lock.json index fb4545bc0..769a5b181 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.4.56", + "version": "27.4.57", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index 25437a405..d92518019 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.4.56", + "version": "27.4.57", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index 2ead3ea00..f22cd7d97 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 27.4.56 +version: 27.4.57 dependencies: - base - yesod From 42f1a802b52007ccca9595d732fc20f40cc66f6a Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 6 Feb 2024 10:32:00 +0000 Subject: [PATCH 144/159] chore(health): getHealthInterfaceR responds to mime content type header --- src/Handler/Health/Interface.hs | 39 ++++++++++++++++++--------------- 1 file changed, 21 insertions(+), 18 deletions(-) diff --git a/src/Handler/Health/Interface.hs b/src/Handler/Health/Interface.hs index c43ffaed8..1b6ee1dee 100644 --- a/src/Handler/Health/Interface.hs +++ b/src/Handler/Health/Interface.hs @@ -67,27 +67,30 @@ matchesUniqueInterfaceHealth (UniqueInterfaceHealth ai as aw) (UniqueInterfaceHe eqOrNothing a b = a == b -getHealthInterfaceR :: [Text] -> Handler Html -getHealthInterfaceR ris = do - let (forced, ris') = case ris of - ("force":ris0) -> (True , ris0) - _ -> (False, ris ) - interfs = splitInterfaces $ identifyInterfaces ris' +getHealthInterfaceR :: [Text] -> Handler TypedContent +getHealthInterfaceR (dropWhile (=="force") -> ris) = do -- for backwards compatibility we ignore leading "force" + let interfs = splitInterfaces $ identifyInterfaces ris (missing, allok, res, iltable) <- runInterfaceLogTable interfs - let badMsg = "Unhealthy interfaces: " <> Text.intercalate ", " [iface | (iface, False) <- res] when missing notFound -- send 404 if any requested interface was not found - unless (forced || allok) $ sendResponseStatus internalServerError500 badMsg - content <- siteLayoutMsg MsgMenuHealthInterface $ do - setTitleI MsgMenuHealthInterface - [whamlet| - $if allok - Interfaces are healthy. - $else - #{badMsg} + let respond = sendResponseStatus (bool internalServerError500 status200 allok) + plainMsg = if allok + then "Interfaces are healthy" + else "Unhealthy interfaces: " <> Text.intercalate ", " [iface | (iface, False) <- res] + selectRep $ do + provideRep $ do + content <- siteLayoutMsg MsgMenuHealthInterface $ do + setTitleI MsgMenuHealthInterface + [whamlet| +

                                                    + #{plainMsg} +
                                                    + ^{iltable} + |] + respond content + + provideRep $ do + respond $ RepPlain $ toContent plainMsg - ^{iltable} - |] - sendResponseStatus (bool internalServerError500 status200 allok) content runInterfaceLogTable :: ReqBanInterfaceHealth -> Handler (Bool, Bool, [(Text,Bool)], Widget) From 4a843fe30e35f346ffbe5c0337d69bf319cfeced Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 6 Feb 2024 10:48:54 +0000 Subject: [PATCH 145/159] refactor(health): simplfy code following HealthR handler --- src/Handler/Health/Interface.hs | 23 ++++++++++------------- 1 file changed, 10 insertions(+), 13 deletions(-) diff --git a/src/Handler/Health/Interface.hs b/src/Handler/Health/Interface.hs index 1b6ee1dee..87be63b89 100644 --- a/src/Handler/Health/Interface.hs +++ b/src/Handler/Health/Interface.hs @@ -68,28 +68,25 @@ matchesUniqueInterfaceHealth (UniqueInterfaceHealth ai as aw) (UniqueInterfaceHe getHealthInterfaceR :: [Text] -> Handler TypedContent -getHealthInterfaceR (dropWhile (=="force") -> ris) = do -- for backwards compatibility we ignore leading "force" +getHealthInterfaceR (dropWhile (=="force") -> ris) = do -- for backwards compatibility we ignore leading "force" let interfs = splitInterfaces $ identifyInterfaces ris (missing, allok, res, iltable) <- runInterfaceLogTable interfs - when missing notFound -- send 404 if any requested interface was not found - let respond = sendResponseStatus (bool internalServerError500 status200 allok) - plainMsg = if allok - then "Interfaces are healthy" - else "Unhealthy interfaces: " <> Text.intercalate ", " [iface | (iface, False) <- res] - selectRep $ do - provideRep $ do - content <- siteLayoutMsg MsgMenuHealthInterface $ do + when missing notFound -- send 404 if any requested interface was not found + let ihstatus = if allok then status200 + else internalServerError500 + plainMsg = if allok then "Interfaces are healthy." + else "Unhealthy interfaces: " <> Text.intercalate ", " [iface | (iface, False) <- res] + sendResponseStatus ihstatus <=< selectRep $ do + provideRep . siteLayoutMsg MsgMenuHealthInterface $ do setTitleI MsgMenuHealthInterface [whamlet|
                                                    #{plainMsg}
                                                    ^{iltable} - |] - respond content + |] - provideRep $ do - respond $ RepPlain $ toContent plainMsg + provideRep $ return $ RepPlain $ toContent plainMsg From 2a0bca1230b456eb413842b37f03342b25e49742 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 6 Feb 2024 15:37:00 +0000 Subject: [PATCH 146/159] refactor(health): interface-health - send text/plain by default - attempt to fix negative sub-filters for interface health --- src/Handler/Health/Interface.hs | 20 ++++++++++++-------- src/Model/Migration/Definitions.hs | 4 ++-- 2 files changed, 14 insertions(+), 10 deletions(-) diff --git a/src/Handler/Health/Interface.hs b/src/Handler/Health/Interface.hs index 87be63b89..4e551eb96 100644 --- a/src/Handler/Health/Interface.hs +++ b/src/Handler/Health/Interface.hs @@ -76,18 +76,16 @@ getHealthInterfaceR (dropWhile (=="force") -> ris) = do -- for bac else internalServerError500 plainMsg = if allok then "Interfaces are healthy." else "Unhealthy interfaces: " <> Text.intercalate ", " [iface | (iface, False) <- res] - sendResponseStatus ihstatus <=< selectRep $ do - provideRep . siteLayoutMsg MsgMenuHealthInterface $ do + sendResponseStatus ihstatus <=< selectRep $ do -- most browsers send accept:text/html, thus text/plain can be default here + provideRep . return . RepPlain $ toContent plainMsg -- /?_accept=text/plain + provideRep . siteLayoutMsg MsgMenuHealthInterface $ do -- /?_accept=text/html setTitleI MsgMenuHealthInterface [whamlet|
                                                    #{plainMsg}
                                                    ^{iltable} - |] - - provideRep $ return $ RepPlain $ toContent plainMsg - + |] runInterfaceLogTable :: ReqBanInterfaceHealth -> Handler (Bool, Bool, [(Text,Bool)], Widget) @@ -105,6 +103,12 @@ runInterfaceLogTable interfs@(reqIfs,_) = do -- ihDebugShow :: Unique InterfaceHealth -> Text -- ihDebugShow (UniqueInterfaceHealth i s w) = "(" <> tshow i <> tshow s <> tshow w <> ")" +-- | like (=~.) but avoids condition entirely if second argument is Nothing; Note that using =~. with E.val Nothing did not work somehow! +infixl 4 ~~. +(~~.) :: PersistField typ => E.SqlExpr (E.Value typ) -> Maybe typ -> E.SqlExpr (E.Value Bool) +(~~.) a Nothing = E.true +(~~.) a (Just b) = a E.==. E.val b + mkInterfaceLogTable :: (Bool -> Widget) -> ReqBanInterfaceHealth -> DB ([(Text,Bool)], Widget) mkInterfaceLogTable flagError interfs@(reqIfs, banIfs) = do -- $logWarnS "DEBUG" $ tshow ([ihDebugShow x | x<- reqIfs], [ihDebugShow x | x<- banIfs]) @@ -122,8 +126,8 @@ mkInterfaceLogTable flagError interfs@(reqIfs, banIfs) = do ) let matchUIH crits = E.or [ ilog E.^. InterfaceLogInterface E.==. E.val (sanitize ifce) - E.&&. ilog E.^. InterfaceLogSubtype E.=~. E.val (sanitize <$> subt) - E.&&. ilog E.^. InterfaceLogWrite E.=~. E.val writ + E.&&. ilog E.^. InterfaceLogSubtype ~~. (sanitize <$> subt) + E.&&. ilog E.^. InterfaceLogWrite ~~. writ | (UniqueInterfaceHealth ifce subt writ) <- crits ] unless (null reqIfs) $ E.where_ $ matchUIH reqIfs diff --git a/src/Model/Migration/Definitions.hs b/src/Model/Migration/Definitions.hs index a875b9648..e7d34e713 100644 --- a/src/Model/Migration/Definitions.hs +++ b/src/Model/Migration/Definitions.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022-23 Gregor Kleen ,Steffen Jost ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen ,Steffen Jost ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -125,7 +125,7 @@ migrateAlwaysSafe = do in sql -- unless (tableExists "interface_health") $ do -- [executeQQ| - -- INSERT INTO "interface_health" (interface, subtype, write, hours) + -- INSERT INTO "interface_health" ("interface", "subtype", "write", "hours") -- VALUES -- ('Printer', 'Acknowledge', True, 168) -- , ('AVS' , 'Synch' , True , 96) From 67552a666e2588c1f477eacd5036c09903b2d40e Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 6 Feb 2024 15:47:17 +0000 Subject: [PATCH 147/159] refactor(health): optimize sql query, needs tests --- src/Handler/Health/Interface.hs | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/src/Handler/Health/Interface.hs b/src/Handler/Health/Interface.hs index 4e551eb96..e1a523dea 100644 --- a/src/Handler/Health/Interface.hs +++ b/src/Handler/Health/Interface.hs @@ -130,6 +130,14 @@ mkInterfaceLogTable flagError interfs@(reqIfs, banIfs) = do E.&&. ilog E.^. InterfaceLogWrite ~~. writ | (UniqueInterfaceHealth ifce subt writ) <- crits ] + -- let matchUIH crits = E.or + -- [ E.and $ catMaybes + -- [ Just $ ilog E.^. InterfaceLogInterface E.==. E.val (sanitize ifce) + -- , foldMap ((ilog E.^. InterfaceLogSubtype E.==.) . E.val . sanitize) subt + -- , foldMap ((ilog E.^. InterfaceLogWrite E.==.) . E.val ) writ + -- ] + -- | (UniqueInterfaceHealth ifce subt writ) <- crits + -- ] unless (null reqIfs) $ E.where_ $ matchUIH reqIfs unless (null banIfs) $ E.where_ $ E.not_ $ matchUIH banIfs let ihour = E.coalesceDefault [ihealth E.?. InterfaceHealthHours] (E.val $ 3 * 24) -- if no default time is set, use 3 days instead From 618c78a69d7db77a745282c63356a936facff70d Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 7 Feb 2024 10:23:51 +0100 Subject: [PATCH 148/159] chore(health): examining cause of #155 --- src/Handler/Health/Interface.hs | 39 ++++++++++++++++++--------------- 1 file changed, 21 insertions(+), 18 deletions(-) diff --git a/src/Handler/Health/Interface.hs b/src/Handler/Health/Interface.hs index e1a523dea..42ec567fd 100644 --- a/src/Handler/Health/Interface.hs +++ b/src/Handler/Health/Interface.hs @@ -100,18 +100,19 @@ runInterfaceLogTable interfs@(reqIfs,_) = do allok = all snd res return (missing, allok, res, twgt) --- ihDebugShow :: Unique InterfaceHealth -> Text --- ihDebugShow (UniqueInterfaceHealth i s w) = "(" <> tshow i <> tshow s <> tshow w <> ")" +ihDebugShow :: Unique InterfaceHealth -> Text +ihDebugShow (UniqueInterfaceHealth i s w) = "(" <> tshow i <> "," <> tshow s <> "," <> tshow w <> ")" +-- NOTE: Using (~~.) instead of ()=~.) -- | like (=~.) but avoids condition entirely if second argument is Nothing; Note that using =~. with E.val Nothing did not work somehow! -infixl 4 ~~. -(~~.) :: PersistField typ => E.SqlExpr (E.Value typ) -> Maybe typ -> E.SqlExpr (E.Value Bool) -(~~.) a Nothing = E.true -(~~.) a (Just b) = a E.==. E.val b +-- infixl 4 ~~. +-- (~~.) :: PersistField typ => E.SqlExpr (E.Value typ) -> Maybe typ -> E.SqlExpr (E.Value Bool) +-- (~~.) _ Nothing = E.true +-- (~~.) a (Just b) = a E.==. E.val b mkInterfaceLogTable :: (Bool -> Widget) -> ReqBanInterfaceHealth -> DB ([(Text,Bool)], Widget) mkInterfaceLogTable flagError interfs@(reqIfs, banIfs) = do - -- $logWarnS "DEBUG" $ tshow ([ihDebugShow x | x<- reqIfs], [ihDebugShow x | x<- banIfs]) + $logWarnS "DEBUG" $ tshow ([ihDebugShow x | x<- reqIfs], [ihDebugShow x | x<- banIfs]) void $ liftHandler $ timeoutHandler 42000001 $ runDB $ runInterfaceChecks interfs now <- liftIO getCurrentTime dbTableDB ilvalidator DBTable{dbtColonnade=colonnade now, ..} @@ -124,22 +125,24 @@ mkInterfaceLogTable flagError interfs@(reqIfs, banIfs) = do E.&&. ilog E.^. InterfaceLogSubtype E.=~. E.joinV (ihealth E.?. InterfaceHealthSubtype) E.&&. ilog E.^. InterfaceLogWrite E.=~. E.joinV (ihealth E.?. InterfaceHealthWrite ) ) - let matchUIH crits = E.or - [ ilog E.^. InterfaceLogInterface E.==. E.val (sanitize ifce) - E.&&. ilog E.^. InterfaceLogSubtype ~~. (sanitize <$> subt) - E.&&. ilog E.^. InterfaceLogWrite ~~. writ - | (UniqueInterfaceHealth ifce subt writ) <- crits - ] + -- let matchUIH crits = E.or + -- [ ilog E.^. InterfaceLogInterface E.==. E.val (sanitize ifce) + -- E.&&. ilog E.^. InterfaceLogSubtype ~~. (sanitize <$> subt) + -- E.&&. ilog E.^. InterfaceLogWrite ~~. writ + -- | (UniqueInterfaceHealth ifce subt writ) <- crits + -- ] -- let matchUIH crits = E.or -- [ E.and $ catMaybes - -- [ Just $ ilog E.^. InterfaceLogInterface E.==. E.val (sanitize ifce) - -- , foldMap ((ilog E.^. InterfaceLogSubtype E.==.) . E.val . sanitize) subt - -- , foldMap ((ilog E.^. InterfaceLogWrite E.==.) . E.val ) writ + -- [ ilog E.^. InterfaceLogInterface E.==. E.val (sanitize ifce) & Just + -- , (ilog E.^. InterfaceLogSubtype E.==.) . E.val . sanitize <$> subt + -- , (ilog E.^. InterfaceLogWrite E.==.) . E.val <$> writ -- ] -- | (UniqueInterfaceHealth ifce subt writ) <- crits -- ] - unless (null reqIfs) $ E.where_ $ matchUIH reqIfs - unless (null banIfs) $ E.where_ $ E.not_ $ matchUIH banIfs + -- unless (null reqIfs) $ E.where_ $ matchUIH reqIfs + -- unless (null banIfs) $ E.where_ $ E.not_ $ matchUIH banIfs + E.where_ $ E.not_ (ilog E.^. InterfaceLogInterface E.==. E.val "LMS" E.&&. ilog E.^. InterfaceLogSubtype E.==. E.val (sanitize "F")) -- NOT OKAY ONLY Printer F SEE ISSUE #155 + -- E.where_ $ ilog E.^. InterfaceLogInterface E.!=. E.val "LMS" E.||. ilog E.^. InterfaceLogSubtype E.!=. E.val (sanitize "F") -- OKAY let ihour = E.coalesceDefault [ihealth E.?. InterfaceHealthHours] (E.val $ 3 * 24) -- if no default time is set, use 3 days instead return (ilog, ihour) From 3303c4eebf928e527d2f9c1eb6e2495c10b94b13 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 7 Feb 2024 10:39:21 +0100 Subject: [PATCH 149/159] fix(health): negative interface routes working as intended now --- src/Handler/Health/Interface.hs | 76 ++++++++++++++------------------- 1 file changed, 31 insertions(+), 45 deletions(-) diff --git a/src/Handler/Health/Interface.hs b/src/Handler/Health/Interface.hs index 42ec567fd..f64ef254f 100644 --- a/src/Handler/Health/Interface.hs +++ b/src/Handler/Health/Interface.hs @@ -2,8 +2,6 @@ -- -- SPDX-License-Identifier: AGPL-3.0-or-later -{-# OPTIONS_GHC -fno-warn-unused-top-binds #-} -- !!! TODO REMOVE ME - module Handler.Health.Interface ( @@ -62,7 +60,7 @@ splitInterfaces = foldl' aux mempty -- | check whether the first argument is equal or more specialzed (i.e. more Just) than the second matchesUniqueInterfaceHealth :: Unique InterfaceHealth -> Unique InterfaceHealth -> Bool matchesUniqueInterfaceHealth (UniqueInterfaceHealth ai as aw) (UniqueInterfaceHealth bi bs bw) = ai == bi && eqOrNothing as bs && eqOrNothing aw bw - where + where eqOrNothing _ Nothing = True eqOrNothing a b = a == b @@ -72,9 +70,9 @@ getHealthInterfaceR (dropWhile (=="force") -> ris) = do -- for bac let interfs = splitInterfaces $ identifyInterfaces ris (missing, allok, res, iltable) <- runInterfaceLogTable interfs when missing notFound -- send 404 if any requested interface was not found - let ihstatus = if allok then status200 + let ihstatus = if allok then status200 else internalServerError500 - plainMsg = if allok then "Interfaces are healthy." + plainMsg = if allok then "Interfaces are healthy." else "Unhealthy interfaces: " <> Text.intercalate ", " [iface | (iface, False) <- res] sendResponseStatus ihstatus <=< selectRep $ do -- most browsers send accept:text/html, thus text/plain can be default here provideRep . return . RepPlain $ toContent plainMsg -- /?_accept=text/plain @@ -100,19 +98,12 @@ runInterfaceLogTable interfs@(reqIfs,_) = do allok = all snd res return (missing, allok, res, twgt) -ihDebugShow :: Unique InterfaceHealth -> Text -ihDebugShow (UniqueInterfaceHealth i s w) = "(" <> tshow i <> "," <> tshow s <> "," <> tshow w <> ")" - --- NOTE: Using (~~.) instead of ()=~.) --- | like (=~.) but avoids condition entirely if second argument is Nothing; Note that using =~. with E.val Nothing did not work somehow! --- infixl 4 ~~. --- (~~.) :: PersistField typ => E.SqlExpr (E.Value typ) -> Maybe typ -> E.SqlExpr (E.Value Bool) --- (~~.) _ Nothing = E.true --- (~~.) a (Just b) = a E.==. E.val b +-- ihDebugShow :: Unique InterfaceHealth -> Text +-- ihDebugShow (UniqueInterfaceHealth i s w) = "(" <> tshow i <> "," <> tshow s <> "," <> tshow w <> ")" mkInterfaceLogTable :: (Bool -> Widget) -> ReqBanInterfaceHealth -> DB ([(Text,Bool)], Widget) mkInterfaceLogTable flagError interfs@(reqIfs, banIfs) = do - $logWarnS "DEBUG" $ tshow ([ihDebugShow x | x<- reqIfs], [ihDebugShow x | x<- banIfs]) + -- $logWarnS "DEBUG" $ tshow ([ihDebugShow x | x<- reqIfs], [ihDebugShow x | x<- banIfs]) void $ liftHandler $ timeoutHandler 42000001 $ runDB $ runInterfaceChecks interfs now <- liftIO getCurrentTime dbTableDB ilvalidator DBTable{dbtColonnade=colonnade now, ..} @@ -122,27 +113,30 @@ mkInterfaceLogTable flagError interfs@(reqIfs, banIfs) = do dbtProj = dbtProjId dbtSQLQuery (ilog `E.LeftOuterJoin` ihealth) = do EL.on ( ilog E.^. InterfaceLogInterface E.=?. ihealth E.?. InterfaceHealthInterface - E.&&. ilog E.^. InterfaceLogSubtype E.=~. E.joinV (ihealth E.?. InterfaceHealthSubtype) - E.&&. ilog E.^. InterfaceLogWrite E.=~. E.joinV (ihealth E.?. InterfaceHealthWrite ) + E.&&. ilog E.^. InterfaceLogSubtype E.=~. E.joinV (ihealth E.?. InterfaceHealthSubtype) + E.&&. ilog E.^. InterfaceLogWrite E.=~. E.joinV (ihealth E.?. InterfaceHealthWrite ) ) - -- let matchUIH crits = E.or - -- [ ilog E.^. InterfaceLogInterface E.==. E.val (sanitize ifce) - -- E.&&. ilog E.^. InterfaceLogSubtype ~~. (sanitize <$> subt) - -- E.&&. ilog E.^. InterfaceLogWrite ~~. writ - -- | (UniqueInterfaceHealth ifce subt writ) <- crits - -- ] - -- let matchUIH crits = E.or - -- [ E.and $ catMaybes - -- [ ilog E.^. InterfaceLogInterface E.==. E.val (sanitize ifce) & Just - -- , (ilog E.^. InterfaceLogSubtype E.==.) . E.val . sanitize <$> subt - -- , (ilog E.^. InterfaceLogWrite E.==.) . E.val <$> writ - -- ] - -- | (UniqueInterfaceHealth ifce subt writ) <- crits - -- ] - -- unless (null reqIfs) $ E.where_ $ matchUIH reqIfs - -- unless (null banIfs) $ E.where_ $ E.not_ $ matchUIH banIfs - E.where_ $ E.not_ (ilog E.^. InterfaceLogInterface E.==. E.val "LMS" E.&&. ilog E.^. InterfaceLogSubtype E.==. E.val (sanitize "F")) -- NOT OKAY ONLY Printer F SEE ISSUE #155 - -- E.where_ $ ilog E.^. InterfaceLogInterface E.!=. E.val "LMS" E.||. ilog E.^. InterfaceLogSubtype E.!=. E.val (sanitize "F") -- OKAY + let matchUIH crits = E.or + [ E.and $ catMaybes + [ ilog E.^. InterfaceLogInterface E.==. E.val (sanitize ifce) & Just + , (ilog E.^. InterfaceLogSubtype E.==.) . E.val . sanitize <$> subt + , (ilog E.^. InterfaceLogWrite E.==.) . E.val <$> writ + ] + | (UniqueInterfaceHealth ifce subt writ) <- crits + ] + matchUIHnot crits = E.and + [ E.or $ catMaybes + [ ilog E.^. InterfaceLogInterface E.!=. E.val (sanitize ifce) & Just + , (ilog E.^. InterfaceLogSubtype E.!=.) . E.val . sanitize <$> subt + , (ilog E.^. InterfaceLogWrite E.!=.) . E.val <$> writ + ] + | (UniqueInterfaceHealth ifce subt writ) <- crits + ] + unless (null reqIfs) $ E.where_ $ matchUIH reqIfs + unless (null banIfs) $ E.where_ $ matchUIHnot banIfs + -- unless (null banIfs) $ E.where_ $ E.not_ $ matchUIH banIfs -- !!! DOES NOT WORK !!! Yields strange results, see #155 + -- E.where_ $ E.not_ (ilog E.^. InterfaceLogInterface E.==. E.val "LMS" E.&&. ilog E.^. InterfaceLogSubtype E.==. E.val (sanitize "F")) -- BAD All missing, except for "Printer" "F" + -- E.where_ $ ilog E.^. InterfaceLogInterface E.!=. E.val "LMS" E.||. ilog E.^. InterfaceLogSubtype E.!=. E.val (sanitize "F") -- OKAY let ihour = E.coalesceDefault [ihealth E.?. InterfaceHealthHours] (E.val $ 3 * 24) -- if no default time is set, use 3 days instead return (ilog, ihour) @@ -211,14 +205,6 @@ maybeRunCheck (reqIfs,banIfs) uih act act $ addHours (negate $ interfaceHealthHours $ entityVal eih) now | otherwise = return () --- maybeRunCheck :: Unique InterfaceHealth -> (Int -> DB ()) -> DB () --- maybeRunCheck uih act = maybeM (return ()) (act . interfaceHealthHours . entityVal) $ getBy uih - -- maybeRunCheck uih act = getBy uih >>= flip whenIsJust (act . interfaceHealthHours . entityVal) - -- where - -- ih2hours :: Entity InterfaceHealth -> Int - -- -- ih2hours Entity{entityVal=InterfaceHealth{interfaceHealthHours=h}} = h - -- ih2hours = interfaceHealthHours . entityVal - lprAckCheck :: ReqBanInterfaceHealth -> DB () lprAckCheck interfs = maybeRunCheck interfs (UniqueInterfaceHealth "Printer" (Just "Acknowledge") (Just True)) $ \cutOffOldTime -> do @@ -227,10 +213,10 @@ lprAckCheck interfs = maybeRunCheck interfs (UniqueInterfaceHealth "Printer" (Ju then mkLog False (Just $ length unproc) "Long unprocessed APC-Idents exist" else do oks <- E.deleteWhereCount [PrintAcknowledgeTimestamp <. cutOffOldTime, PrintAcknowledgeProcessed ==. True] - if oks > 0 + if oks > 0 then mkLog True (Just $ fromIntegral oks) "Long processed APC-Idents removed" else mkLog True Nothing mempty - where + where mkLog = logInterface' "Printer" "Acknowledge" True From 263894b05899ce55635d790f5334729fbc655ecc Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 7 Feb 2024 12:43:39 +0100 Subject: [PATCH 150/159] fix(lms): previouly failed notifications will be sent again --- src/Jobs/Handler/LMS.hs | 5 +++-- src/Jobs/Types.hs | 4 +++- 2 files changed, 6 insertions(+), 3 deletions(-) diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index 12ab943f2..013f849b7 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022-23 Steffen Jost ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-24 Steffen Jost ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -313,7 +313,8 @@ dispatchJobLmsReports qid = JobHandlerAtomic act E.&&. lreport E.^. LmsReportLock E.==. E.true ) -- B) notify all newly reported users that lms is available - let luserFltrNew luser = E.isNothing $ luser E.^. LmsUserReceived -- not seen before, just starting + let luserFltrNew luser = E.isNothing (luser E.^. LmsUserReceived) -- not seen before, just starting + E.||. E.isNothing (luser E.^. LmsUserNotified) -- a previous notification has failed notifyNewLearner (E.Value uid) = queueDBJob JobUserNotification { jRecipient = uid, jNotification = NotificationQualificationRenewal { nQualification = qid, nReminder = False } } in luserQry luserFltrNew (const $ const E.true) >>= mapM_ notifyNewLearner -- C) block qualifications for failed learners by calling qualificationUserBlocking [uids] (includes audit), notified during expiry diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs index dc8e04120..69ad6b4d6 100644 --- a/src/Jobs/Types.hs +++ b/src/Jobs/Types.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022-23 Gregor Kleen ,Sarah Vaupel ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen ,Sarah Vaupel ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -375,6 +375,8 @@ jobNoQueueSame = \case notifyNoQueueSame :: Notification -> Maybe JobNoQueueSame notifyNoQueueSame = \case NotificationQualificationRenewal{} -> Just JobNoQueueSame -- send one at once; safe, since the job is rescheduled if sending was not acknowledged + NotificationQualificationExpiry{} -> Just JobNoQueueSame -- do not send multiple expiry messages to the same person at once + NotificationQualificationExpired{} -> Just JobNoQueueSame _ -> Nothing jobMovable :: JobCtl -> Bool From 57f5cac75af6a0d96f3216fcfbd0446d98f44345 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Thu, 8 Feb 2024 20:51:43 +0100 Subject: [PATCH 151/159] chore(release): 27.4.58 --- CHANGELOG.md | 8 ++++++++ nix/docker/version.json | 2 +- package-lock.json | 2 +- package.json | 2 +- package.yaml | 2 +- 5 files changed, 12 insertions(+), 4 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index a09ca5698..1ff23608e 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,14 @@ All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines. +## [27.4.58](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.57...v27.4.58) (2024-02-08) + + +### Bug Fixes + +* **health:** negative interface routes working as intended now ([3303c4e](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/3303c4eebf928e527d2f9c1eb6e2495c10b94b13)) +* **lms:** previouly failed notifications will be sent again ([263894b](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/263894b05899ce55635d790f5334729fbc655ecc)) + ## [27.4.57](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.56...v27.4.57) (2024-02-06) diff --git a/nix/docker/version.json b/nix/docker/version.json index 2bc1d589a..0f6ee116f 100644 --- a/nix/docker/version.json +++ b/nix/docker/version.json @@ -1,3 +1,3 @@ { - "version": "27.4.57" + "version": "27.4.58" } diff --git a/package-lock.json b/package-lock.json index 769a5b181..16f8bd6f6 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.4.57", + "version": "27.4.58", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index d92518019..2eac33199 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.4.57", + "version": "27.4.58", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index f22cd7d97..9e9579f42 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 27.4.57 +version: 27.4.58 dependencies: - base - yesod From e2be8bbd5c82fd8a68187ee6bea4ab49e2980797 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 12 Feb 2024 11:30:54 +0100 Subject: [PATCH 152/159] chore(sql): examine #155 --- src/Database/Esqueleto/Utils.hs | 3 ++- src/Handler/Health/Interface.hs | 4 +++- 2 files changed, 5 insertions(+), 2 deletions(-) diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index 8a0a02a17..c0b80448e 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022-23 Gregor Kleen ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen ,Steffen Jost ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -17,6 +17,7 @@ module Database.Esqueleto.Utils , (>~.), (<~.) , or, and , any, all + -- , parens , subSelectAnd, subSelectOr , mkExactFilter, mkExactFilterWith, mkExactFilterWithComma , mkExactFilterLast, mkExactFilterLastWith diff --git a/src/Handler/Health/Interface.hs b/src/Handler/Health/Interface.hs index f64ef254f..c530b43c5 100644 --- a/src/Handler/Health/Interface.hs +++ b/src/Handler/Health/Interface.hs @@ -135,8 +135,10 @@ mkInterfaceLogTable flagError interfs@(reqIfs, banIfs) = do unless (null reqIfs) $ E.where_ $ matchUIH reqIfs unless (null banIfs) $ E.where_ $ matchUIHnot banIfs -- unless (null banIfs) $ E.where_ $ E.not_ $ matchUIH banIfs -- !!! DOES NOT WORK !!! Yields strange results, see #155 + -- unless (null banIfs) $ E.where_ $ E.not_ $ E.parens $ matchUIH banIfs -- WORKS OKAY -- E.where_ $ E.not_ (ilog E.^. InterfaceLogInterface E.==. E.val "LMS" E.&&. ilog E.^. InterfaceLogSubtype E.==. E.val (sanitize "F")) -- BAD All missing, except for "Printer" "F" - -- E.where_ $ ilog E.^. InterfaceLogInterface E.!=. E.val "LMS" E.||. ilog E.^. InterfaceLogSubtype E.!=. E.val (sanitize "F") -- OKAY + -- E.where_ $ E.not_ $ E.parens (ilog E.^. InterfaceLogInterface E.==. E.val "LMS" E.&&. ilog E.^. InterfaceLogSubtype E.==. E.val (sanitize "F")) -- WORKS OKAY + -- E.where_ $ ilog E.^. InterfaceLogInterface E.!=. E.val "LMS" E.||. ilog E.^. InterfaceLogSubtype E.!=. E.val (sanitize "F") -- WORKS OKAY let ihour = E.coalesceDefault [ihealth E.?. InterfaceHealthHours] (E.val $ 3 * 24) -- if no default time is set, use 3 days instead return (ilog, ihour) From 42695cf5ef9f21691dc027f1ec97d57eec72f03e Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 12 Feb 2024 11:56:31 +0100 Subject: [PATCH 153/159] fix(sql): remove potential bug in relation to missing parenthesis after not_ --- src/Database/Esqueleto/Utils.hs | 5 ++++- src/Handler/Utils/Users.hs | 2 +- src/Jobs/Handler/LMS.hs | 4 ++-- 3 files changed, 7 insertions(+), 4 deletions(-) diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index c0b80448e..127e0ed88 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -17,7 +17,7 @@ module Database.Esqueleto.Utils , (>~.), (<~.) , or, and , any, all - -- , parens + , not__, parens , subSelectAnd, subSelectOr , mkExactFilter, mkExactFilterWith, mkExactFilterWithComma , mkExactFilterLast, mkExactFilterLastWith @@ -253,6 +253,9 @@ subSelectOr q = parens . E.subSelectUnsafe $ flip (E.unsafeSqlAggregateFunction parens :: E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value a) parens = E.unsafeSqlFunction "" +-- | Workaround for Esqueleto-Bug not placing parenthesis after NOT, see #155 +not__ :: E.SqlExpr (E.Value Bool) -> E.SqlExpr (E.Value Bool) +not__ = E.not_ . parens -- Allow usage of Tuples as DbtRowKey, i.e. SqlIn instances for tuples $(sqlInTuples [2..16]) diff --git a/src/Handler/Utils/Users.hs b/src/Handler/Utils/Users.hs index 5c85c9c73..e281c7fcf 100644 --- a/src/Handler/Utils/Users.hs +++ b/src/Handler/Utils/Users.hs @@ -189,7 +189,7 @@ guessUser (((Set.toList . toNullable) <$>) . Set.toList . dnfTerms -> criteria) containsAsSet x y = E.and . map (\y' -> x `E.hasInfix` E.val y') $ asWords y - toSql user pl = bool id E.not_ (is _PLNegated pl) $ case pl ^. _plVar of + toSql user pl = bool id E.not__ (is _PLNegated pl) $ case pl ^. _plVar of GuessUserMatrikelnummer userMatriculation' -> user E.^. UserMatrikelnummer E.==. E.val (Just userMatriculation') GuessUserEduPersonPrincipalName userEPPN' -> user E.^. UserLdapPrimaryKey E.==. E.val (Just userEPPN') GuessUserDisplayName userDisplayName' -> user E.^. UserDisplayName `containsAsSet` userDisplayName' diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index 013f849b7..136ea518e 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -202,7 +202,7 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act -- 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) + 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 ] @@ -223,7 +223,7 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act `E.on` (\(quser :& qblock) -> qblock E.?. QualificationUserBlockQualificationUser E.?=. quser E.^. QualificationUserId E.&&. qblock `isLatestBlockBefore` E.val now ) - E.where_ $ -- E.not_ (validQualification now quser) -- currently invalid + E.where_ $ -- E.not__ (validQualification now quser) -- currently invalid quser E.^. QualificationUserQualification E.==. E.val qid -- correct qualification E.&&. quserToNotify now quser qblock -- recently became invalid or blocked pure (quser E.^. QualificationUserUser) From 192c7337491fca7092499331efe3f88e8cf682c4 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 12 Feb 2024 18:30:07 +0100 Subject: [PATCH 154/159] chore(health): migration for health defaults --- src/Model/Migration/Definitions.hs | 28 ++++++++++++++++++++-------- 1 file changed, 20 insertions(+), 8 deletions(-) diff --git a/src/Model/Migration/Definitions.hs b/src/Model/Migration/Definitions.hs index e7d34e713..ab0147ff4 100644 --- a/src/Model/Migration/Definitions.hs +++ b/src/Model/Migration/Definitions.hs @@ -49,6 +49,7 @@ import qualified Data.Time.Zones as TZ data ManualMigration = Migration20230524QualificationUserBlock | Migration20230703LmsUserStatus + | Migration20240212InitInterfaceHealth -- create table interface_health and fill with default values deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic) deriving anyclass (Universe, Finite) @@ -123,14 +124,6 @@ migrateAlwaysSafe = do let itemDay = Map.findWithDefault today item changelogItemDays return [st|('#{toPathPiece item}', '#{iso8601Show itemDay}')|] in sql - -- unless (tableExists "interface_health") $ do - -- [executeQQ| - -- INSERT INTO "interface_health" ("interface", "subtype", "write", "hours") - -- VALUES - -- ('Printer', 'Acknowledge', True, 168) - -- , ('AVS' , 'Synch' , True , 96) - -- ON CONFLICT DO NOTHING; - -- |] {- Confusion about quotes, from the PostgreSQL Manual: @@ -185,6 +178,25 @@ customMigrations = mapF $ \case ; |] + Migration20240212InitInterfaceHealth -> + unlessM (tableExists "interface_health") $ do -- fill health table with some defaults + [executeQQ| + CREATE TABLE "interface_health" + ( id BIGSERIAL NOT NULL + , interface CHARACTER VARYING NOT NULL + , subtype CHARACTER VARYING + , write BOOLEAN + , hours BIGINT NOT NULL + , PRIMARY KEY(id) + , CONSTRAINT unique_interface_health UNIQUE(interface, subtype, write) + ); + INSERT INTO "interface_health" ("interface", "subtype", "write", "hours") + VALUES + ('Printer', 'Acknowledge', True, 168) + , ('AVS' , 'Synch' , True , 96) + ON CONFLICT DO NOTHING; + |] + tableExists :: MonadIO m => Text -> ReaderT SqlBackend m Bool tableExists table = do From ae9be9e2856ed84d938ff21a39cc5161a7963ac4 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 13 Feb 2024 21:15:49 +0000 Subject: [PATCH 155/159] chore(release): 27.4.59 --- CHANGELOG.md | 7 +++++++ nix/docker/version.json | 2 +- package-lock.json | 2 +- package.json | 2 +- package.yaml | 2 +- 5 files changed, 11 insertions(+), 4 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 1ff23608e..bb7fd8e96 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,13 @@ All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines. +## [27.4.59](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.58...v27.4.59) (2024-02-13) + + +### Bug Fixes + +* **sql:** remove potential bug in relation to missing parenthesis after not_ ([42695cf](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/42695cf5ef9f21691dc027f1ec97d57eec72f03e)) + ## [27.4.58](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.57...v27.4.58) (2024-02-08) diff --git a/nix/docker/version.json b/nix/docker/version.json index 0f6ee116f..450e150fd 100644 --- a/nix/docker/version.json +++ b/nix/docker/version.json @@ -1,3 +1,3 @@ { - "version": "27.4.58" + "version": "27.4.59" } diff --git a/package-lock.json b/package-lock.json index 16f8bd6f6..8baaeafcc 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.4.58", + "version": "27.4.59", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index 2eac33199..8c360c1e7 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.4.58", + "version": "27.4.59", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index 9e9579f42..2c242b3b3 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 27.4.58 +version: 27.4.59 dependencies: - base - yesod From d4f8a6c77b2a4a4540935f7f0beca0d0605508c8 Mon Sep 17 00:00:00 2001 From: Steffen Date: Wed, 21 Feb 2024 08:24:32 +0100 Subject: [PATCH 156/159] fix(doc): minor haddock problems --- src/Handler/Course/ParticipantInvite.hs | 2 +- src/Handler/Health/Interface.hs | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Handler/Course/ParticipantInvite.hs b/src/Handler/Course/ParticipantInvite.hs index 30daf6f19..53eff795d 100644 --- a/src/Handler/Course/ParticipantInvite.hs +++ b/src/Handler/Course/ParticipantInvite.hs @@ -193,7 +193,7 @@ handleAddUserR tid ssh csh tdesc ttyp = do currentRoute <- fromMaybe (error "postCAddUserR called from 404-handler") <$> getCurrentRoute (_ , registerConfirmResult) <- runButtonForm FIDCourseRegisterConfirm - -- $logDebugS "***AbortProblem***" $ tshow registerConfirmResult + -- $logDebugS "***AbortProblem***" $ tshow registerConfirmResult prefillUsers <- case registerConfirmResult of Nothing -> return mempty (Just BtnCourseRegisterAbort) -> do diff --git a/src/Handler/Health/Interface.hs b/src/Handler/Health/Interface.hs index c530b43c5..7dbc96932 100644 --- a/src/Handler/Health/Interface.hs +++ b/src/Handler/Health/Interface.hs @@ -103,7 +103,7 @@ runInterfaceLogTable interfs@(reqIfs,_) = do mkInterfaceLogTable :: (Bool -> Widget) -> ReqBanInterfaceHealth -> DB ([(Text,Bool)], Widget) mkInterfaceLogTable flagError interfs@(reqIfs, banIfs) = do - -- $logWarnS "DEBUG" $ tshow ([ihDebugShow x | x<- reqIfs], [ihDebugShow x | x<- banIfs]) + -- $logWarnS "DEBUG" $ tshow ([ihDebugShow x | x<- reqIfs], [ihDebugShow x | x<- banIfs]) void $ liftHandler $ timeoutHandler 42000001 $ runDB $ runInterfaceChecks interfs now <- liftIO getCurrentTime dbTableDB ilvalidator DBTable{dbtColonnade=colonnade now, ..} From 17a3541fe29db3e2101746745b36ecf1d5cd5c23 Mon Sep 17 00:00:00 2001 From: Steffen Date: Fri, 8 Mar 2024 13:26:34 +0100 Subject: [PATCH 157/159] chore(db): ass comments on upsertManyWhere usage --- test/Database/Fill.hs | 19 ++++++++++++++++--- 1 file changed, 16 insertions(+), 3 deletions(-) diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index c1c657912..af8961dba 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -696,9 +696,22 @@ fillDb = do ++ take 444 [ UserSupervisor fhamann uid True | Entity uid _ <- matUsers, uid /= jost] ++ take 123 [ UserSupervisor gkleen uid True | Entity uid _ <- drop 369 matUsers ] ++ take 11 [ UserSupervisor jost uid False | Entity uid _ <- drop 501 matUsers ] - upsertManyWhere supvs [] [] [] - -- upsertManyWhere supvs [] [] [] -- NOTE: multiple calls like this are ok - -- insertMany_ supvs -- NOTE: multiple calls like this throw an error! + upsertManyWhere supvs [] [] [] + -- insertMany_ supvs -- NOTE: multiple calls like this throw a runtime error! + -- upsertManyWhere supvs [] [] [] -- NOTE: multiple calls like this are ok + -- upsertManyWhere (supvs ++ take 5 (drop 12 [ UserSupervisor jost uid False | Entity uid _ <- drop 501 matUsers ])) -- no duplicates within first argument allowed! (runtime error: ON CONFLICT DO UPDATE command cannot affect row a second time) + -- [copyField UserSupervisorRerouteNotifications] [UserSupervisorRerouteNotifications =. True] [UserSupervisorSupervisor ==. jost, UserSupervisorUser <-. [uid | Entity uid _ <- take 3 $ drop 504 matUsers ]] -- does not work! + -- let changeSome usr@(UserSupervisor s u _) + -- | s == jost, u `elem` take 14 [ uid | Entity uid _ <- drop 501 matUsers ] = UserSupervisor s u True + -- | otherwise = usr + -- upsertManyWhere (changeSome <$> (supvs ++ take 5 (drop 12 [ UserSupervisor jost uid False | Entity uid _ <- drop 501 matUsers ]))) -- no duplicates within first argument allowed! (runtime error: ON CONFLICT DO UPDATE command cannot affect row a second time) + -- [copyField UserSupervisorRerouteNotifications] [] [UserSupervisorSupervisor ==. jost, UserSupervisorUser <-. [uid | Entity uid _ <- take 3 $ drop 504 matUsers ]] -- probably does the same as the above + -- OBSERVATIONS: + -- - use the 2. argument with `copyField` to overwrite an existing field with the new record value provided in the 1. argument in case of an update + -- - use the 3. argument to update a field indepently from the provided records or for computations involving previous values, eg. +=. + -- - use the 4. argument to filter both the application of the 2. and 3. argument + + ifi <- insert' $ School "Institut für Informatik" "IfI" (Just $ 14 * nominalDay) (Just $ 10 * nominalDay) True (ExamModeDNF predDNFFalse) (ExamCloseOnFinished True) SchoolAuthorshipStatementModeOptional (Just ifiAuthorshipStatement) True SchoolAuthorshipStatementModeRequired (Just ifiAuthorshipStatement) False mi <- insert' $ School "Institut für Mathematik" "MI" Nothing Nothing False (ExamModeDNF predDNFFalse) (ExamCloseOnFinished False) SchoolAuthorshipStatementModeNone Nothing True SchoolAuthorshipStatementModeOptional Nothing True From d625fbe8e3f33dfbd1508a70518878870467d65d Mon Sep 17 00:00:00 2001 From: Steffen Date: Fri, 15 Mar 2024 17:06:08 +0100 Subject: [PATCH 158/159] chore(faq): update to fit Fraport AG --- messages/faq/de-de-formal.msg | 8 ++-- messages/faq/en-eu.msg | 8 ++-- src/Handler/Info.hs | 41 +++++----------- .../faq/campus-cant-login.de-de-formal.hamlet | 39 +++++++-------- .../i18n/faq/campus-cant-login.en-eu.hamlet | 42 +++++++++-------- ...urse-correctors-tutors.de-de-formal.hamlet | 10 ---- .../faq/course-correctors-tutors.en-eu.hamlet | 9 ---- .../i18n/faq/exam-points.de-de-formal.hamlet | 14 ------ templates/i18n/faq/exam-points.en-eu.hamlet | 14 ------ .../forgotten-password.de-de-formal.hamlet | 25 +++------- .../i18n/faq/forgotten-password.en-eu.hamlet | 25 ++++------ ...ls-ad-account-disabled.de-de-formal.hamlet | 22 --------- ...edentials-ad-account-disabled.en-eu.hamlet | 19 -------- .../faq/login-expired.de-de-formal.hamlet | 47 +++++++++++++++++++ templates/i18n/faq/login-expired.en-eu.hamlet | 46 ++++++++++++++++++ 15 files changed, 168 insertions(+), 201 deletions(-) delete mode 100644 templates/i18n/faq/course-correctors-tutors.de-de-formal.hamlet delete mode 100644 templates/i18n/faq/course-correctors-tutors.en-eu.hamlet delete mode 100644 templates/i18n/faq/exam-points.de-de-formal.hamlet delete mode 100644 templates/i18n/faq/exam-points.en-eu.hamlet delete mode 100644 templates/i18n/faq/invalid-credentials-ad-account-disabled.de-de-formal.hamlet delete mode 100644 templates/i18n/faq/invalid-credentials-ad-account-disabled.en-eu.hamlet create mode 100644 templates/i18n/faq/login-expired.de-de-formal.hamlet create mode 100644 templates/i18n/faq/login-expired.en-eu.hamlet diff --git a/messages/faq/de-de-formal.msg b/messages/faq/de-de-formal.msg index 221b1f5b1..a568617e6 100644 --- a/messages/faq/de-de-formal.msg +++ b/messages/faq/de-de-formal.msg @@ -1,11 +1,9 @@ -# SPDX-FileCopyrightText: 2022 Gregor Kleen ,Steffen Jost +# SPDX-FileCopyrightText: 2022-24 Gregor Kleen ,Steffen Jost ,Steffen Jost # # SPDX-License-Identifier: AGPL-3.0-or-later +FAQLoginExpired: Mein Passwort ist abgelaufen und muss erneuert werden FAQNoCampusAccount: Ich habe keine Fraport AG Kennung (Büko-Login); kann ich trotzdem Zugang zum System erhalten? FAQForgottenPassword: Ich habe mein Passwort vergessen FAQCampusCantLogin: Ich kann mich mit meiner Fraport AG Kennung (Büko-Login) nicht anmelden -FAQCourseCorrectorsTutors: Wie kann ich Ausbilder oder Korrektoren für meine Kursart konfigurieren? -FAQNotLecturerHowToCreateCourses: Wie kann ich eine neue Kursart anlegen? -FAQExamPoints: Warum kann ich bei meiner Klausur keine Punkte eintragen? -FAQInvalidCredentialsAdAccountDisabled: Ich kann mich nicht anmelden und bekomme die Meldung „Benutzereintrag gesperrt“ \ No newline at end of file +FAQNotLecturerHowToCreateCourses: Wie kann ich eine neue Kursart anlegen? \ No newline at end of file diff --git a/messages/faq/en-eu.msg b/messages/faq/en-eu.msg index 0686713bb..5d1ed4913 100644 --- a/messages/faq/en-eu.msg +++ b/messages/faq/en-eu.msg @@ -1,11 +1,9 @@ -# SPDX-FileCopyrightText: 2022 Gregor Kleen ,Steffen Jost +# SPDX-FileCopyrightText: 2022-24 Gregor Kleen ,Steffen Jost ,Steffen Jost # # SPDX-License-Identifier: AGPL-3.0-or-later +FAQLoginExpired: My password expired FAQNoCampusAccount: I don't have Fraport AG credentials (Büko login); can I still get access? FAQForgottenPassword: I have forgotten my password FAQCampusCantLogin: I can't log in using my Fraport AG credentials (Büko login) -FAQCourseCorrectorsTutors: How can I add instructors or correctors to my course? -FAQNotLecturerHowToCreateCourses: How can I create new courses? -FAQExamPoints: Why can't I enter achievements for my exam as points? -FAQInvalidCredentialsAdAccountDisabled: I can't log in and am instead given the message “Account disabled” \ No newline at end of file +FAQNotLecturerHowToCreateCourses: How can I create new courses? \ No newline at end of file diff --git a/src/Handler/Info.hs b/src/Handler/Info.hs index 497fcb6c4..f927908d4 100644 --- a/src/Handler/Info.hs +++ b/src/Handler/Info.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022-2023 Felix Hamann , Gregor Kleen , Sarah Vaupel , Steffen Jost , Winnie Ros +-- SPDX-FileCopyrightText: 2022-2024 Felix Hamann , Gregor Kleen , Sarah Vaupel , Steffen Jost , Winnie Ros , Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -13,12 +13,12 @@ import Data.Map ((!)) import qualified Data.CaseInsensitive as CI import qualified Data.Set as Set -import qualified Database.Esqueleto.Legacy as E -import qualified Database.Esqueleto.Utils as E +-- import qualified Database.Esqueleto.Legacy as E +-- import qualified Database.Esqueleto.Utils as E import Development.GitRev -import Auth.LDAP (ADError(..), ADInvalidCredentials(..), CampusMessage(..)) +-- import Auth.LDAP (ADError(..), ADInvalidCredentials(..), CampusMessage(..)) import Yesod.Auth.Message(AuthMessage(..)) @@ -175,6 +175,7 @@ showFAQ :: ( MonadAP m , MonadThrow m ) => Route UniWorX -> FAQItem -> m Bool +showFAQ _ FAQLoginExpired = return True showFAQ _ FAQNoCampusAccount = is _Nothing <$> maybeAuthId showFAQ (AuthR _) FAQCampusCantLogin = return True showFAQ _ FAQCampusCantLogin = is _Nothing <$> maybeAuthId @@ -183,38 +184,20 @@ showFAQ _ FAQForgottenPassword = is _Nothing <$> maybeAuthId showFAQ _ FAQNotLecturerHowToCreateCourses = and2M (is _Just <$> maybeAuthId) (not <$> hasWriteAccessTo CourseNewR) -showFAQ (CourseR tid ssh csh _) FAQCourseCorrectorsTutors - = and2M (is _Just <$> maybeAuthId) - (or2M (hasWriteAccessTo $ CourseR tid ssh csh SheetNewR) - (hasWriteAccessTo $ CourseR tid ssh csh CTutorialNewR) - ) -showFAQ (CExamR tid ssh csh examn _) FAQExamPoints - = and2M (hasWriteAccessTo $ CExamR tid ssh csh examn EEditR) - noExamParts - where - noExamParts = liftHandler . runDB . E.selectNotExists . E.from $ \(examPart `E.InnerJoin` exam `E.InnerJoin` course) -> do - E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse - E.on $ exam E.^. ExamId E.==. examPart E.^. ExamPartExam - E.where_ $ course E.^. CourseTerm E.==. E.val tid - E.&&. course E.^. CourseSchool E.==. E.val ssh - E.&&. course E.^. CourseShorthand E.==. E.val csh - E.&&. exam E.^. ExamName E.==. E.val examn -showFAQ _ FAQInvalidCredentialsAdAccountDisabled = maybeT (return False) $ do - guardM $ is _Nothing <$> maybeAuthId - sessionError <- MaybeT $ lookupSessionJson SessionError - guard $ sessionError == PermissionDenied (toPathPiece $ ADInvalidCredentials ADAccountDisabled) - return True -showFAQ _ _ = return False +-- showFAQ (CourseR tid ssh csh _) FAQCourseCorrectorsTutors +-- = and2M (is _Just <$> maybeAuthId) +-- (or2M (hasWriteAccessTo $ CourseR tid ssh csh SheetNewR) +-- (hasWriteAccessTo $ CourseR tid ssh csh CTutorialNewR) +-- ) +-- showFAQ _ _ = return False prioFAQ :: Monad m => Route UniWorX -> FAQItem -> m Rational +prioFAQ _ FAQLoginExpired = return 2 prioFAQ _ FAQNoCampusAccount = return 1 prioFAQ _ FAQCampusCantLogin = return 1 prioFAQ _ FAQForgottenPassword = return 1 prioFAQ _ FAQNotLecturerHowToCreateCourses = return 1 -prioFAQ _ FAQCourseCorrectorsTutors = return 1 -prioFAQ _ FAQExamPoints = return 2 -prioFAQ _ FAQInvalidCredentialsAdAccountDisabled = return 3 getInfoLecturerR :: Handler Html diff --git a/templates/i18n/faq/campus-cant-login.de-de-formal.hamlet b/templates/i18n/faq/campus-cant-login.de-de-formal.hamlet index a516f2522..aff71f83a 100644 --- a/templates/i18n/faq/campus-cant-login.de-de-formal.hamlet +++ b/templates/i18n/faq/campus-cant-login.de-de-formal.hamlet @@ -8,19 +8,27 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later

                                                    Können sie sich mit exakt identischen (idealerweise # copy&paste) Daten # - im Campus-Portal # + im myapps.microsoft.com # anmelden? +
                                                    + Falls sie die Fehlermeldung „Passwort abgelaufen“ oder "password-expired" erhalten, # + dann befolgen Sie bitte # + + diese Anleitung zum erneuern Ihres Passworts. +
                                                    Falls nicht („_{InvalidLogin}“), ist davon auszugehen, dass Sie # Ihre Anmeldedaten falsch eingeben oder # -                                                     keine LMU-Benutzerkennung # - (ehem. Campus-Kennung) besitzen. + keine gültige Fraport AG # + Benutzerkennung besitzen. # + Rufen Sie in diesem Fall den allgemeinen Fraport IT-Helpdesk # + an unter +49-69-690127

                                                    - Beachten Sie dabei auch, dass Uni2work Leerzeichen sowohl im # - Passwort als auch bei der Kennung berücksichtigt. + Beachten Sie, dass Leerzeichen sowohl im # + Passwort als auch bei der Kennung berücksichtigt werden.
                                                    @@ -33,34 +41,27 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later aktiviertem JavaScript), dass Sie Ihr Passwort korrekt eingeben.

                                                    - Uni2work bietet zwei Login-Formulare. + Uni2work bietet mehrere Login-Formulare.
                                                    - Für die Anmeldung mit der LMU-Benutzerkennung (ehem. Campus-Kennung) # + Für die Anmeldung mit Ihren Fraport AG Konto # müssen Sie das Formular „_{MsgLDAPLoginTitle}“ verwenden.
                                                    - Geben Sie unter „_{MsgCampusIdent}“ ihre vollständige # - LMU-Benutzerkennung an. # - - Diese ist identisch mit ihrer @campus.lmu.de E-Mail # - Adresse. - +

                                                    - Falls Sie seit Ihrem letzten Login in Uni2work ihr Passwort geändert # + Falls Sie Ihr Passwort kürzlich geändert # haben, kann es sein, dass die Änderung des Passworts (noch) nicht # - korrekt propagiert wurde. + korrekt propagiert wurde. Warten Sie einfach ein paar Minuten oder # + versuchen Sie, Ihr altes Passwort zu verwenden. -
                                                    - - In diesem Fall können Sie versuchen Ihr Passwort erneut zu ändern.

                                                    Sobald Sie die obigen Hinweise befolgt haben, wenden Sie sich bitte # (erneut) über das Hilfe-Formular, oben rechts # - auf jeder Seite, an die Uni2work-Administration. + auf jeder Seite, an die FRADrive-Administration.
                                                    diff --git a/templates/i18n/faq/campus-cant-login.en-eu.hamlet b/templates/i18n/faq/campus-cant-login.en-eu.hamlet index 0159c44cc..99b621cdc 100644 --- a/templates/i18n/faq/campus-cant-login.en-eu.hamlet +++ b/templates/i18n/faq/campus-cant-login.en-eu.hamlet @@ -7,18 +7,29 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later

                                                    Can you log in to # - the Campus-Portal # + the myapps.microsoft.com # using the exact same (ideally copied & pasted) login data? +
                                                    + If you received the error message „Passwort abgelaufen“ or "password-expired" # + then please follow # + + these instructions for password renewal. +
                                                    If you cannot (“_{InvalidLogin}”), this means that you are # entering your login data wrong or that you # -                                                     do not have a LMU user ID # - (formerly Campus-ID). + + do not have a valid Fraport AG credentials. + +
                                                    + + In this case please call the general Fraport IT-Servicedesk + at                                                     +49-69-690127

                                                    - Please consider that for Uni2work both your user ID and password are # + Please consider that for FRADrive both your user ID and password are # sensitive to whitespace characters.
                                                    @@ -37,31 +48,22 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later password manager instead of typing it manually.

                                                    - Uni2work offers two login forms. + Furthermore, FRADrive offers several login forms.
                                                    - To log in using your LMU user ID (formerly Campus-ID) you need to # + To log in using your Fraport AG credentials you need to # use the form titled “_{MsgLDAPLoginTitle}”. -
                                                    - - Under “_{MsgCampusIdent}” please enter your entire LMU user ID, # - which is identical to your @campus.lmu.de email # - address. -

                                                    If you have changed your password since last you logged into # - Uni2work, it may be the case that your password change was not # - propagated properly. - -
                                                    - - If so, please try changing your password again. + FRADrive, it may be the case that your password change was not # + propagated properly. Please wait a few minutes and try again, + or try changing your password again.

                                                    Once you have followed the suggestions above, please contact a # - Uni2work-administrator using the Support form # + FRADrive-administrator using the Support form # (at the top right of every page).
                                                    @@ -73,4 +75,4 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later Never disclose your password to third parties! # - Not even to an Uni2work-administrator or the IT-Servicedesk! + Not even to a FRADrive-administrator or the IT-Servicedesk! diff --git a/templates/i18n/faq/course-correctors-tutors.de-de-formal.hamlet b/templates/i18n/faq/course-correctors-tutors.de-de-formal.hamlet deleted file mode 100644 index 0c68818a5..000000000 --- a/templates/i18n/faq/course-correctors-tutors.de-de-formal.hamlet +++ /dev/null @@ -1,10 +0,0 @@ -$newline never - -$# SPDX-FileCopyrightText: 2022 Gregor Kleen ,Winnie Ros -$# -$# SPDX-License-Identifier: AGPL-3.0-or-later - -

                                                    - Ausbilder:innen und Korrektor:innen werden beim Anlegen oder Editieren des # - jeweiligen Kurses bzw. Übungsblattes angegeben. - diff --git a/templates/i18n/faq/course-correctors-tutors.en-eu.hamlet b/templates/i18n/faq/course-correctors-tutors.en-eu.hamlet deleted file mode 100644 index f4fe7f813..000000000 --- a/templates/i18n/faq/course-correctors-tutors.en-eu.hamlet +++ /dev/null @@ -1,9 +0,0 @@ -$newline never - -$# SPDX-FileCopyrightText: 2022 Gregor Kleen -$# -$# SPDX-License-Identifier: AGPL-3.0-or-later - -

                                                    - Instructors and correctors are assigned when creating or editing the # - respective course or exercise sheet. diff --git a/templates/i18n/faq/exam-points.de-de-formal.hamlet b/templates/i18n/faq/exam-points.de-de-formal.hamlet deleted file mode 100644 index 20895c634..000000000 --- a/templates/i18n/faq/exam-points.de-de-formal.hamlet +++ /dev/null @@ -1,14 +0,0 @@ -$newline never - -$# SPDX-FileCopyrightText: 2022 Gregor Kleen -$# -$# SPDX-License-Identifier: AGPL-3.0-or-later - - -

                                                    - Klausurpunkte werden in Uni2work pro Teilaufgabe verwaltet. - -

                                                    - Um Klausurleistungen als Punkte anzugeben (und optional automatisch # - eine Note daraus zu berechnen), müssen Sie mindestens eine # - Teilprüfung/Aufgabe anlegen. diff --git a/templates/i18n/faq/exam-points.en-eu.hamlet b/templates/i18n/faq/exam-points.en-eu.hamlet deleted file mode 100644 index d7a6d7e65..000000000 --- a/templates/i18n/faq/exam-points.en-eu.hamlet +++ /dev/null @@ -1,14 +0,0 @@ -$newline never - -$# SPDX-FileCopyrightText: 2022 Gregor Kleen -$# -$# SPDX-License-Identifier: AGPL-3.0-or-later - - -

                                                    - Exam points are managed in Uni2work on a per-exam-part basis. - -

                                                    - To store exam achievements in the form of points (and optionally # - automatically compute grades), you need to create at least one # - exam part/question. diff --git a/templates/i18n/faq/forgotten-password.de-de-formal.hamlet b/templates/i18n/faq/forgotten-password.de-de-formal.hamlet index a3fa6e009..44f0c970a 100644 --- a/templates/i18n/faq/forgotten-password.de-de-formal.hamlet +++ b/templates/i18n/faq/forgotten-password.de-de-formal.hamlet @@ -1,27 +1,16 @@ $newline never -$# SPDX-FileCopyrightText: 2022 Gregor Kleen ,Winnie Ros +$# SPDX-FileCopyrightText: 2022-24 Gregor Kleen ,Winnie Ros ,Steffen Jost $# $# SPDX-License-Identifier: AGPL-3.0-or-later

                                                    - Wenn Sie sich gewöhnlicherweise mit Ihrer LMU-Benutzerkennug # - (ehem. Campus-Kennung) anmelden, wenden Sie sich bitte an # - den IT-Servicedesk # - um Ihr Passwort zurücksetzen zu lassen. + Wenn Sie Ihr Passwort vergessen haben, wenden Sie sich bitte an # + den allgemeinen Fraport IT-Helpdesk unter + + +49-69-690127 -

                                                    - Wenn Sie sich mit einer Uni2work-internen Kennung anmelden wenden # - Sie sich dafür bitte über das Hilfe-Formular # - (oben rechts auf jeder Seite) an die Uni2work-Administration.
                                                    - Tragen sie dabei unter „Antworten an“ die Adresse ein, an die # - Uni2work gewöhnlicherweise Mitteilungen verschickt. -
                                                    - Bitte geben Sie zusätzlich mind. eine nicht-öffentliche # - personenbezogene Information an, um den Administrator:innen zu helfen # - die Anfrage zu authorisieren. # - - Geeignet ist z.B. die Matrikelnummer oder der ungefähre Zeitpunkt # - des letzten Logins. + Die FRADrive Administratoren können bei Login Problemen leider # + nicht helfen, da diese keinen Zugriff auf Ihren Fraport AG Account haben. diff --git a/templates/i18n/faq/forgotten-password.en-eu.hamlet b/templates/i18n/faq/forgotten-password.en-eu.hamlet index a1814ad97..63fed8099 100644 --- a/templates/i18n/faq/forgotten-password.en-eu.hamlet +++ b/templates/i18n/faq/forgotten-password.en-eu.hamlet @@ -1,26 +1,17 @@ $newline never -$# SPDX-FileCopyrightText: 2022 Gregor Kleen +$# SPDX-FileCopyrightText: 2024 Gregor Kleen ,Steffen Jost $# $# SPDX-License-Identifier: AGPL-3.0-or-later

                                                    - If you usually log in using your LMU user ID (formerly Campus-ID) # - please contact # - the IT # - servicedesk (german) to reset your password. + If you have forgotten your password # + please contact the general Fraport IT-servicedesk at # + + +49-69-690127 + to reset your password. -

                                                    - If you log in using a Uni2work-internal account please use # - the Support form (at the top right of every # - page) to contact a Uni2work-administrator.
                                                    - Specify the email to which Uni2work usually sends notifications # - under “Send answers to”. -
                                                    - - Please also include at least one non-public piece of information to # - help authorise your request. # - We suggest your Matriculation number or the approximate time of your # - last successful login. + FRADrive administrators have no access to your Frapot AG account # + and thus cannot help you with this problem. diff --git a/templates/i18n/faq/invalid-credentials-ad-account-disabled.de-de-formal.hamlet b/templates/i18n/faq/invalid-credentials-ad-account-disabled.de-de-formal.hamlet deleted file mode 100644 index 404ce35ea..000000000 --- a/templates/i18n/faq/invalid-credentials-ad-account-disabled.de-de-formal.hamlet +++ /dev/null @@ -1,22 +0,0 @@ -$newline never - -$# SPDX-FileCopyrightText: 2022 Gregor Kleen -$# -$# SPDX-License-Identifier: AGPL-3.0-or-later - - -

                                                    - Gewöhnlicherweise wird Ihr Benutzereintrag gesperrt, wenn sie # - exmatrikuliert werden bzw. Ihr Beschäftigungsverhältnis endet. # - - Es kommt gelegentlich vor, dass Ihr Benutzereintrag nicht korrekt # - entsperrt wird, wenn Sie wieder immatrikuliert bzw. eingestellt # - werden. - -

                                                    - Falls Sie aktuell immatrikuliert bzw. eingestellt sind, oder Sie # - einen anderen triftigen Grund vorweisen können, warum Sie Zugang zu # - Uni2work brauchen, wenden Sie sich bitte über # - das Hilfe-Formular, oben rechts auf jeder # - Seite, an die Uni2work-Administration und schildern Sie Ihre # - Situation. diff --git a/templates/i18n/faq/invalid-credentials-ad-account-disabled.en-eu.hamlet b/templates/i18n/faq/invalid-credentials-ad-account-disabled.en-eu.hamlet deleted file mode 100644 index c14257f97..000000000 --- a/templates/i18n/faq/invalid-credentials-ad-account-disabled.en-eu.hamlet +++ /dev/null @@ -1,19 +0,0 @@ -$newline never - -$# SPDX-FileCopyrightText: 2022 Gregor Kleen -$# -$# SPDX-License-Identifier: AGPL-3.0-or-later - - -

                                                    - Usually your account is disabled once you are no longer matriculated # - (i.e. registered as a student) or employed. # - - Occasionally accounts are not correctly re-enabled once you are # - matriculated or employed, again. - -

                                                    - If you are currently matriculated, employed, or have another good # - reason why you should have access to Uni2work, please contact a # - Uni2work-Administrator using the Support form # - (at the top right of every page) and describe your situation. diff --git a/templates/i18n/faq/login-expired.de-de-formal.hamlet b/templates/i18n/faq/login-expired.de-de-formal.hamlet new file mode 100644 index 000000000..c1295a4b0 --- /dev/null +++ b/templates/i18n/faq/login-expired.de-de-formal.hamlet @@ -0,0 +1,47 @@ +$newline never + +$# SPDX-FileCopyrightText: 2024 Steffen Jost +$# +$# SPDX-License-Identifier: AGPL-3.0-or-later + + +

                                                    + Der Zugang zu FRADrive erfolgt über Ihren Fraport AG Login. # + Das Passwort für Ihren Fraport AG Login muss alle 90 Tage geändert werden. # + Tun Sie dies nicht, so können Sie sich nicht mehr einloggen. # + Dies besagen die Richtlininen der Fraport AG IT Abteilung. + +

                                                    + Bevor oder auch nachdem Ihr Passwort abgelaufen ist, # + können Sie das Passwort ganze leicht selbst mit einer # + der folgenden Methoden ändern: # + +

                                                      +
                                                    1. + Über # + + das Azure Portal + . +
                                                    2. + Über Ihre # + + Microsoft Kontoseite + . Verwenden Sie dort die Funktion "Kennwort ändern". +
                                                    3. + Über Ihre Profil-Einstellungen "Konto-Anzeigen" auf # + + Ihre Microsoft My-Apps Seite + . + +

                                                      + + Hinweis: # + + Wenden Sie sich bei Problemen mit dem Passwortwechsel # + bitte direkt an den allgemeinen Fraport IT-Helpdesk unter # + + +49-69-690127 + +
                                                      + Die FRADrive Administratoren können bei diesem Login Problem leider # + nicht helfen, da diese keinen Zugriff auf Ihren Fraport AG Account haben. diff --git a/templates/i18n/faq/login-expired.en-eu.hamlet b/templates/i18n/faq/login-expired.en-eu.hamlet new file mode 100644 index 000000000..9fa4d7786 --- /dev/null +++ b/templates/i18n/faq/login-expired.en-eu.hamlet @@ -0,0 +1,46 @@ +$newline never + +$# SPDX-FileCopyrightText: 2024 Steffen Jost +$# +$# SPDX-License-Identifier: AGPL-3.0-or-later + + +

                                                      + Using FRADrive required a Fraport AG account. # + The password for your Fraport AG account must be changed every 90 days. # + Following the general IT safety guidelines of Fraport AG, # + your login will be temporarily disabled otherwise. + +

                                                      + Regardless of whether your password has already expired or not, # + you may easily change your password with any one of the following methods: # + +

                                                        +
                                                      1. + Via # + + the azure portal + . +
                                                      2. + Using you # + + Microsoft account page + , then using the function "change password" there. +
                                                      3. + By accessing your profile settings on # + + your Microsoft My-Apps page + . + +

                                                        + + Please note: # + + If you have any problem changing your password # + please call the general Fraport IT-servicedesk at # + + +49-69-690127 + +
                                                        + FRADrive administrators have no access to your Frapot AG account # + and thus cannot help you with this problem. From caf8fec5acb94df16293bf9aa0cdab766f8829e8 Mon Sep 17 00:00:00 2001 From: Stephan Barth Date: Mon, 6 May 2024 15:09:42 +0200 Subject: [PATCH 159/159] feature(util script): Util script for renaming of files added. --- utils/renamer.pl | 58 ++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 58 insertions(+) create mode 100755 utils/renamer.pl diff --git a/utils/renamer.pl b/utils/renamer.pl new file mode 100755 index 000000000..9845e36c4 --- /dev/null +++ b/utils/renamer.pl @@ -0,0 +1,58 @@ +#!/usr/bin/env perl + +use strict; +use warnings; + +my ($fromdir, $renamefile, $todir) = @ARGV; + +sub usage { + die "usage: $0 [fromdir] [renamefile] [todir]\n + takes files from [fromdir], renames according to the json-map in + [renamefile] and writes the files to [todir]. + old filenames are used as keys; new filenames as value\n"; +} + +usage() unless $fromdir and $renamefile and $todir; +usage() unless -d $fromdir; +usage() unless -f $renamefile; + +mkdir $todir; + +my %did = (); + +my @errNex = (); + +my $fh = undef; +open($fh, '<', $renamefile) or die "Cannot read '$renamefile', because: $!"; +my $cont = join '', <$fh>; +close $fh; +if($cont!~m#^\s*\{(.*)\}\s*$#s) { die "'$renamefile' not in an expected format; it should be an json-object" } +my $core = $1; + +while($core=~s#^\s*,?\s*"([^"/]+)"\s*:\s*"([^"/]+)"##) { + my ($from, $to) = ($1, $2); + my $pfrom = "$fromdir/$from"; + my $pto = "$todir/$to"; + if(-e $pfrom) { + print "Renaming '$pfrom' to '$pto'\n"; + system("cp", $pfrom, $pto); + $did{$from} = 1; + } else { + push @errNex, $from + } +} + +for(@errNex) { + warn "Could not rename non-existent file: $_\n"; +} + +die "Syntax error in [renamefile], could not process everything!" if $core!~m#^[\s*,]*$#; + +my $dh = undef; +opendir($dh, $fromdir) or die "Could not read dir '$fromdir', because: $!"; +while(my $filename = readdir($dh)) { + next if $filename=~m#^\.\.?$#; + warn "Did not touch not mentioned file '$filename'\n" unless $did{$filename}; +} + +