From 0beb0e4011745ea51906e018c53548bb2f6d978e Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 7 Jul 2023 11:32:59 +0000 Subject: [PATCH 01/19] fix(avs): avs background synchs and lms userlist result no longer block handler --- src/Handler/Admin.hs | 5 ++--- src/Handler/LMS.hs | 8 ++++---- src/Handler/LMS/Result.hs | 10 +++++----- src/Handler/LMS/Userlist.hs | 10 +++++----- src/Handler/Users.hs | 4 ++-- src/Jobs/Handler/SynchroniseAvs.hs | 22 +++++++++++----------- src/Jobs/Queue.hs | 4 ++-- 7 files changed, 31 insertions(+), 32 deletions(-) diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index 40f51677e..943748605 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -54,9 +54,8 @@ getAdminProblemsR = do -- (Left (UnsupportedContentType "text/html" resp)) -> Left $ text2widget "Html received" (Left e) -> return $ Left $ text2widget $ tshow (e :: SomeException) (Right AvsLicenceDifferences{..}) -> do - let problemIds = avsLicenceDiffRevokeAll <> avsLicenceDiffGrantVorfeld <> avsLicenceDiffRevokeRollfeld <> avsLicenceDiffGrantRollfeld - -- mapM_ (queueJob' . flip JobSynchroniseAvsId cutOffAvsSynch) problemIds - runDBJobs . forM_ problemIds $ queueDBJob . flip JobSynchroniseAvsId (Just nowaday) + let problemIds = avsLicenceDiffRevokeAll <> avsLicenceDiffGrantVorfeld <> avsLicenceDiffRevokeRollfeld <> avsLicenceDiffGrantRollfeld + forM_ (take 42 $ Set.toList problemIds) $ queueJob' . flip JobSynchroniseAvsId (Just nowaday) return $ Right ( Set.size avsLicenceDiffRevokeAll , Set.size avsLicenceDiffGrantVorfeld diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index 80eae5b68..34d20300e 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -671,15 +671,15 @@ postLmsR sid qsh = do fromIntegral <$> deleteWhereCount [LmsUserQualification ==. qid, LmsUserUser <-. usersList] - runDBJobs $ forM_ selectedUsers $ \uid -> - queueDBJob $ JobLmsEnqueueUser { jQualification = qid, jUser = uid } + forM_ selectedUsers $ \uid -> + queueJob' $ JobLmsEnqueueUser { jQualification = qid, jUser = uid } let numUsers = length selectedUsers mStatus = bool Success Warning $ delUsers < numUsers addMessageI mStatus $ MsgLmsActRestartFeedback delUsers numUsers reloadKeepGetParams $ LmsR sid qsh (action, selectedUsers) | isRenewPinAct action || isNotifyAct action -> do - numExaminees <- runDBJobs $ do + numExaminees <- runDB $ do okUsers <- selectList [ LmsUserQualification ==. qid -- matching qualification , LmsUserEnded ==. Nothing -- not yet deleted , LmsUserStatus ==. Nothing -- not yet decided @@ -690,7 +690,7 @@ postLmsR sid qsh = do newPin <- liftIO randomLMSpw update lid [LmsUserPin =. newPin, LmsUserDatePin =. now, LmsUserResetPin =. True] when (isNotifyAct action) $ - queueDBJob $ JobUserNotification { jRecipient = uid, jNotification = NotificationQualificationRenewal qid' False } + queueJob' $ JobUserNotification { jRecipient = uid, jNotification = NotificationQualificationRenewal qid' False } return $ length okUsers let numSelected = length selectedUsers diffSelected = numSelected - numExaminees diff --git a/src/Handler/LMS/Result.hs b/src/Handler/LMS/Result.hs index 6662d7574..aca551ab6 100644 --- a/src/Handler/LMS/Result.hs +++ b/src/Handler/LMS/Result.hs @@ -212,7 +212,7 @@ postLmsResultR sid qsh = do -- Direct File Upload/Download -saveResultCsv :: QualificationId -> Int -> LmsResultTableCsv -> JobDB Int +saveResultCsv :: QualificationId -> Int -> LmsResultTableCsv -> DB Int saveResultCsv qid i LmsResultTableCsv{..} = do now <- liftIO getCurrentTime void $ upsert @@ -238,12 +238,12 @@ postLmsResultUploadR sid qsh = do FormSuccess file -> do -- content <- fileSourceByteString file -- return $ Just (fileName file, content) - nr <- runDBJobs $ do + nr <- runDB $ do qid <- getKeyBy404 $ SchoolQualificationShort sid qsh nr <- runConduit $ fileSource file .| decodeCsv .| foldMC (saveResultCsv qid) 0 - queueDBJob $ JobLmsResults qid + queueJob' $ JobLmsResults qid return nr addMessage Success $ toHtml $ pack "Erfolgreicher Upload der Datei " <> fileName file <> pack (" mit " <> show nr <> " Zeilen") redirect $ LmsResultR sid qsh @@ -267,7 +267,7 @@ postLmsResultDirectR sid qsh = do (status, msg) <- case files of [(fhead,file)] -> do lmsDecoder <- getLmsCsvDecoder - runDBJobs $ do + runDB $ do qid <- getKeyBy404 $ SchoolQualificationShort sid qsh enr <- try $ runConduit $ fileSource file .| lmsDecoder @@ -279,7 +279,7 @@ postLmsResultDirectR sid qsh = do Right nr -> do let msg = "Success. LMS Result upload file " <> fileName file <> " containing " <> tshow nr <> " rows for " <> fhead <> ". " $logInfoS "LMS" msg - when (nr > 0) $ queueDBJob $ JobLmsResults qid + when (nr > 0) $ queueJob' $ JobLmsResults qid return (ok200, msg) [] -> do let msg = "Result upload file missing." diff --git a/src/Handler/LMS/Userlist.hs b/src/Handler/LMS/Userlist.hs index 407c7436e..cb8618b6d 100644 --- a/src/Handler/LMS/Userlist.hs +++ b/src/Handler/LMS/Userlist.hs @@ -212,7 +212,7 @@ postLmsUserlistR sid qsh = do -- 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 -> JobDB Int +saveUserlistCsv :: QualificationId -> Int -> LmsUserlistTableCsv -> DB Int saveUserlistCsv qid i LmsUserlistTableCsv{..} = do now <- liftIO getCurrentTime void $ upsert @@ -236,10 +236,10 @@ postLmsUserlistUploadR sid qsh = do ((result,widget), enctype) <- runFormPost makeUserlistUploadForm case result of FormSuccess file -> do - nr <- runDBJobs $ do + nr <- runDB $ do qid <- getKeyBy404 $ SchoolQualificationShort sid qsh nr <- runConduit $ fileSource file .| decodeCsv .| foldMC (saveUserlistCsv qid) 0 - queueDBJob $ JobLmsUserlist qid + queueJob' $ JobLmsUserlist qid return nr addMessage Success $ toHtml $ pack "Erfolgreicher Upload der Datei " <> fileName file <> pack (" mit " <> show nr <> " Zeilen") redirect $ LmsUserlistR sid qsh @@ -263,7 +263,7 @@ postLmsUserlistDirectR sid qsh = do (status, msg) <- case files of [(fhead,file)] -> do lmsDecoder <- getLmsCsvDecoder - runDBJobs $ do + runDB $ do qid <- getKeyBy404 $ SchoolQualificationShort sid qsh enr <- try $ runConduit $ fileSource file .| lmsDecoder @@ -275,7 +275,7 @@ postLmsUserlistDirectR sid qsh = do Right nr -> do let msg = "Success. LMS Userlist upload file " <> fileName file <> " containing " <> tshow nr <> " rows for " <> fhead <> ". " $logInfoS "LMS" msg - when (nr > 0) $ queueDBJob $ JobLmsUserlist qid + when (nr > 0) $ queueJob' $ JobLmsUserlist qid return (ok200, msg) [] -> do let msg = "Userlist upload file missing." diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index ad3ab6ee1..92f9c4803 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -359,11 +359,11 @@ postUsersR = do | Set.null usersSet && isNotSetSupervisor act -> addMessageI Info MsgActionNoUsersSelected (UserLdapSyncData, userSet) -> do - runDBJobs . forM_ userSet $ \uid -> queueDBJob $ JobSynchroniseLdapUser uid + forM_ userSet $ \uid -> queueJob' $ JobSynchroniseLdapUser uid addMessageI Success . MsgSynchroniseLdapUserQueued $ Set.size userSet redirectKeepGetParams UsersR (UserAvsSyncData, userSet) -> do - runDBJobs . forM_ userSet $ \uid -> queueDBJob $ JobSynchroniseAvsUser uid Nothing + forM_ userSet $ \uid -> queueJob' $ JobSynchroniseAvsUser uid Nothing addMessageI Success . MsgSynchroniseAvsUserQueued $ Set.size userSet redirectKeepGetParams UsersR (UserHijack, Set.minView -> Just (uid, _)) -> diff --git a/src/Jobs/Handler/SynchroniseAvs.hs b/src/Jobs/Handler/SynchroniseAvs.hs index 96ae456df..bdc2a3aab 100644 --- a/src/Jobs/Handler/SynchroniseAvs.hs +++ b/src/Jobs/Handler/SynchroniseAvs.hs @@ -22,24 +22,24 @@ import Jobs.Queue import Handler.Utils.Avs dispatchJobSynchroniseAvs :: Natural -> Natural -> Natural -> Maybe Day -> JobHandler UniWorX -dispatchJobSynchroniseAvs numIterations epoch iteration pause - -- TODO: refactor so that the AvsIdLookup becomes obsolete - = JobHandlerAtomic . runConduit $ - readUsers .| filterIteration .| sinkDBJobs +dispatchJobSynchroniseAvs numIterations epoch iteration pause + = JobHandlerException . runDB $ do + now <- liftIO getCurrentTime + todos <- runConduit $ readUsers .| filterIteration now .| sinkList + putMany todos where - readUsers :: ConduitT () UserId (YesodJobDB UniWorX) () + readUsers :: ConduitT () UserId _ () readUsers = selectKeys [] [] - filterIteration :: ConduitT UserId Job (YesodJobDB UniWorX) () - filterIteration = C.mapMaybeM $ \userId -> runMaybeT $ do + filterIteration :: UTCTime -> ConduitT UserId AvsSync _ () + filterIteration now = C.mapMaybeM $ \userId -> runMaybeT $ do let userIteration, currentIteration :: Integer userIteration = toInteger (hash epoch `hashWithSalt` userId) `mod` toInteger numIterations currentIteration = toInteger iteration `mod` toInteger numIterations -- $logDebugS "SynchronisAvs" [st|User ##{tshow (fromSqlKey userId)}: sync on #{tshow userIteration}/#{tshow numIterations}, now #{tshow currentIteration}|] - guard $ userIteration == currentIteration - - return $ JobSynchroniseAvsUser userId pause + guard $ userIteration == currentIteration + return $ AvsSync userId now pause -- dispatchJobSynchroniseAvs' :: Natural -> Natural -> Natural -> Maybe Day -> JobHandler UniWorX -- dispatchJobSynchroniseAvs' numIterations epoch iteration pause = JobHandlerAtomic $ do @@ -97,7 +97,7 @@ dispatchJobSynchroniseAvsQueue = JobHandlerException $ do AvsInterfaceUnavailable -> return () -- ignore and retry later AvsUserUnknownByAvs _ -> return () -- ignore for users no longer listed in AVS otherExc -> throwM otherExc - ) + ) -- needed, since JobSynchroniseAvsQueue cannot requeue itself due to JobNoQueueSame (and having no parameters) dispatchJobSynchroniseAvsNext :: JobHandler UniWorX diff --git a/src/Jobs/Queue.hs b/src/Jobs/Queue.hs index d9b3e31f0..25df1337f 100644 --- a/src/Jobs/Queue.hs +++ b/src/Jobs/Queue.hs @@ -152,7 +152,7 @@ sinkDBJobs :: ConduitT Job Void (YesodJobDB UniWorX) () sinkDBJobs = C.mapM_ queueDBJob runDBJobs :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => YesodJobDB UniWorX a -> m a --- | Replacement for/Wrapper around `runDB` when jobs need to be queued as part of a database transaction +-- | Blocking! Replacement for/Wrapper around `runDB` when jobs need to be queued as part of a database transaction -- -- Jobs get immediately executed if the transaction succeeds runDBJobs act = do @@ -161,7 +161,7 @@ runDBJobs act = do forM_ jIds $ flip runReaderT app . writeJobCtl . JobCtlPerform return ret - +-- | Blocking! runDBJobs' :: YesodJobDB UniWorX a -> DB a runDBJobs' act = do (ret, jIds) <- mapReaderT runWriterT act From ee4e67fbda38ec1be4f9f9039b513eb09293ccb8 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Sat, 8 Jul 2023 19:30:08 +0000 Subject: [PATCH 02/19] chore(release): 27.4.12 --- CHANGELOG.md | 10 ++++++++++ nix/docker/demo-version.json | 2 +- nix/docker/version.json | 2 +- package-lock.json | 2 +- package.json | 2 +- package.yaml | 2 +- 6 files changed, 15 insertions(+), 5 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 2668fd3ca..7456eff4f 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,16 @@ 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.12](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.11...v27.4.12) (2023-07-08) + + +### Bug Fixes + +* **avs:** attempt to fix avs background jobs ([bbaa42e](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/bbaa42eefaaae88982b091973adb295cdc0e80ff)) +* **avs:** avs background synchs and lms userlist result no longer block handler ([0beb0e4](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/0beb0e4011745ea51906e018c53548bb2f6d978e)) +* **avs:** fix [#7](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/7) by sequencing avs background jobs one after another ([6dc3d8d](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/6dc3d8d059e132d19c119c5f1de906342fdf6d2c)) +* **notifications:** direct notifications now respect user triggers ([3e5f271](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/3e5f271cacfcc5dbd95aa68a342f56db566f8dee)) + ## [27.4.11](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.10...v27.4.11) (2023-06-20) diff --git a/nix/docker/demo-version.json b/nix/docker/demo-version.json index afe4fccef..ecc9308f3 100644 --- a/nix/docker/demo-version.json +++ b/nix/docker/demo-version.json @@ -1,3 +1,3 @@ { - "version": "27.4.11" + "version": "27.4.12" } diff --git a/nix/docker/version.json b/nix/docker/version.json index afe4fccef..ecc9308f3 100644 --- a/nix/docker/version.json +++ b/nix/docker/version.json @@ -1,3 +1,3 @@ { - "version": "27.4.11" + "version": "27.4.12" } diff --git a/package-lock.json b/package-lock.json index c2dc210aa..5662fa9dd 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.4.11", + "version": "27.4.12", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index 6eccdb0b4..7cb2e2d29 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.4.11", + "version": "27.4.12", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index 1791191ce..0abe5190d 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 27.4.11 +version: 27.4.12 dependencies: - base - yesod From 9b93c00301417904e859c4dd255f1072a6bb2132 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 10 Jul 2023 15:28:20 +0000 Subject: [PATCH 03/19] refactor(health): show all health checks that may lead to failure (WIP) --- .../categories/health/de-de-formal.msg | 13 +++-- messages/uniworx/categories/health/en-eu.msg | 13 +++-- src/Foundation/I18n.hs | 1 + src/Handler/Health.hs | 57 ++++++++++++------- src/Model/Types/Health.hs | 2 + 5 files changed, 52 insertions(+), 34 deletions(-) diff --git a/messages/uniworx/categories/health/de-de-formal.msg b/messages/uniworx/categories/health/de-de-formal.msg index 34566d000..429a37e47 100644 --- a/messages/uniworx/categories/health/de-de-formal.msg +++ b/messages/uniworx/categories/health/de-de-formal.msg @@ -3,12 +3,13 @@ # SPDX-License-Identifier: AGPL-3.0-or-later HealthReport: Instanz-Zustand -HealthMatchingClusterConfig: Cluster-geteilte Konfiguration ist aktuell -HealthHTTPReachable: Cluster kann an der erwarteten URL über HTTP erreicht werden -HealthLDAPAdmins: Anteil der Administrator:innen mit LDAP Authentifizierung, welche tatsächlich im LDAP-Verzeichnis gefunden werden können -HealthSMTPConnect: SMTP-Server kann erreicht werden -HealthWidgetMemcached: Memcached-Server liefert Widgets korrekt aus -HealthActiveJobExecutors: Anteil der job-workers, die neue Befehle annehmen +HealthCheckMatchingClusterConfig: Cluster-geteilte Konfiguration ist aktuell +HealthCheckHTTPReachable: Cluster kann an der erwarteten URL über HTTP erreicht werden +HealthCheckLDAPAdmins: Anteil der Administrator:innen mit LDAP Authentifizierung, welche tatsächlich im LDAP-Verzeichnis gefunden werden können +HealthCheckSMTPConnect: SMTP-Server kann erreicht werden +HealthCheckWidgetMemcached: Memcached-Server liefert Widgets korrekt aus +HealthCheckActiveJobExecutors: Anteil der job-workers, die neue Befehle annehmen +HealthCheckDoesFlush: Zustandspüfung läuft durch InstanceIdentification: Instanz-Identifikation InstanceId: Instanz-Nummer ClusterId: Cluster-Nummer \ No newline at end of file diff --git a/messages/uniworx/categories/health/en-eu.msg b/messages/uniworx/categories/health/en-eu.msg index 1bf279300..948a7c4cc 100644 --- a/messages/uniworx/categories/health/en-eu.msg +++ b/messages/uniworx/categories/health/en-eu.msg @@ -3,12 +3,13 @@ # SPDX-License-Identifier: AGPL-3.0-or-later HealthReport: Health report -HealthMatchingClusterConfig: Cluster config matches -HealthHTTPReachable: Cluster can be reached under the expected URL via HTTP -HealthLDAPAdmins: Proportion of administrators with LDAP authentication that were actually found in the LDAP directory -HealthSMTPConnect: SMTP server is reachable -HealthWidgetMemcached: Memcached server is serving widgets correctly -HealthActiveJobExecutors: Proportion of job workers accepting new jobs +HealthCheckMatchingClusterConfig: Cluster config matches +HealthCheckHTTPReachable: Cluster can be reached under the expected URL via HTTP +HealthCheckLDAPAdmins: Proportion of administrators with LDAP authentication that were actually found in the LDAP directory +HealthCheckSMTPConnect: SMTP server is reachable +HealthCheckWidgetMemcached: Memcached server is serving widgets correctly +HealthCheckActiveJobExecutors: Proportion of job workers accepting new jobs +HealthCheckDoesFlush: Health reports flushes InstanceIdentification: Instance identification InstanceId: Instance id ClusterId: Cluster id diff --git a/src/Foundation/I18n.hs b/src/Foundation/I18n.hs index c82adf9d4..9f093d135 100644 --- a/src/Foundation/I18n.hs +++ b/src/Foundation/I18n.hs @@ -247,6 +247,7 @@ mkMessageVariant ''UniWorX ''PWHashMessage "messages/auth/pw-hash" "de" mkMessageVariant ''UniWorX ''ButtonMessage "messages/button" "de" mkMessageVariant ''UniWorX ''FrontendMessage "messages/frontend" "de-de-formal" +embedRenderMessage ''UniWorX ''HealthCheck id -- not possible here embedRenderMessage ''UniWorX ''AvsLicence id -- required by UniWorXAvsMessages mkMessageAddition ''UniWorX "Qualification" "messages/uniworx/categories/qualification" "de-de-formal" mkMessageAddition ''UniWorX "Avs" "messages/uniworx/categories/avs" "de-de-formal" diff --git a/src/Handler/Health.hs b/src/Handler/Health.hs index aad83d566..3fd4a1c99 100644 --- a/src/Handler/Health.hs +++ b/src/Handler/Health.hs @@ -34,7 +34,7 @@ getHealthR = do waitResult <- atomically $ maybe (pure $ Left False) (fmap (const $ Left True) . waitDelay) delay <|> (fmap Right . assertM (not. Set.null) $ readTVar reportStore) case waitResult of Left False -> sendResponseStatus noContent204 () - Left True -> sendResponseStatus internalServerError500 ("System is not generating HealthReports" :: Text) + Left True -> sendResponseStatus internalServerError500 ("System is not generating HealthReports" :: Text) -- can this ever happen after it was non-null? Right _ -> redirect HealthR Just healthReports -> do let (Max lastUpdated, Min status) = ofoldMap1 (Max *** Min . healthReportStatus) healthReports @@ -57,28 +57,41 @@ getHealthR = do setTitleI MsgHealthReport [whamlet| $newline never +

+ $case status + $of HealthSuccess + _{MsgMessageSuccess} + $of _ + _{MsgMessageError} +
$forall (_, report) <- healthReports' - $case report - $of HealthMatchingClusterConfig passed -
_{MsgHealthMatchingClusterConfig} -
#{boolSymbol passed} - $of HealthHTTPReachable (Just passed) -
_{MsgHealthHTTPReachable} -
#{boolSymbol passed} - $of HealthLDAPAdmins (Just found) -
_{MsgHealthLDAPAdmins} -
#{textPercent found 1} - $of HealthSMTPConnect (Just passed) -
_{MsgHealthSMTPConnect} -
#{boolSymbol passed} - $of HealthWidgetMemcached (Just passed) -
_{MsgHealthWidgetMemcached} -
#{boolSymbol passed} - $of HealthActiveJobExecutors (Just active) -
_{MsgHealthActiveJobExecutors} -
#{textPercent active 1} - $of _ + $with hcclass = classifyHealthReport report + $with hcstatus = HealthSuccess == healthReportStatus report + $case report + $of HealthMatchingClusterConfig passed +
_{MsgHealthCheckMatchingClusterConfig} +
#{boolSymbol passed} + $of HealthHTTPReachable (Just passed) +
_{MsgHealthCheckHTTPReachable} +
#{boolSymbol passed} + $of HealthLDAPAdmins (Just found) +
_{MsgHealthCheckLDAPAdmins} +
#{textPercent found 1} + $of HealthSMTPConnect (Just passed) +
_{MsgHealthCheckSMTPConnect} +
#{boolSymbol passed} + $of HealthWidgetMemcached (Just passed) +
_{MsgHealthCheckWidgetMemcached} +
#{boolSymbol passed} + $of HealthActiveJobExecutors (Just active) +
_{MsgHealthCheckActiveJobExecutors} +
#{textPercent active 1} + $of HealthDoesFlush mProp +
_{hcclass} +
#{boolSymbol hcstatus} + $of _ + |] provideJson healthReports provideRep . return . Builder.toLazyText $ Aeson.encodePrettyToTextBuilder healthReports @@ -105,7 +118,7 @@ getInstanceR = do provideRep . return $ tshow instanceInfo --- Most simple page for simple liveness checks +-- Most simple page for simple liveness checks, but it always delivers 200 getStatusR :: Handler Html getStatusR = do starttime <- getsYesod appStartTime diff --git a/src/Model/Types/Health.hs b/src/Model/Types/Health.hs index a1f49fad2..6528232bc 100644 --- a/src/Model/Types/Health.hs +++ b/src/Model/Types/Health.hs @@ -27,6 +27,8 @@ instance Finite HealthCheck instance Hashable HealthCheck instance NFData HealthCheck +-- embedRenderMessage ''UniWorX ''HealthCheck id -- not possible here + deriveJSON defaultOptions { constructorTagModifier = camelToPathPiece' 2 } ''HealthCheck From c596491e494eaf09c917b7af57294530a8ceb219 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 12 Jul 2023 08:21:31 +0000 Subject: [PATCH 04/19] chore(health): add more info to health --- src/Foundation/I18n.hs | 2 +- src/Handler/Health.hs | 27 ++++++++------------------- 2 files changed, 9 insertions(+), 20 deletions(-) diff --git a/src/Foundation/I18n.hs b/src/Foundation/I18n.hs index 9f093d135..4651944ad 100644 --- a/src/Foundation/I18n.hs +++ b/src/Foundation/I18n.hs @@ -247,7 +247,6 @@ mkMessageVariant ''UniWorX ''PWHashMessage "messages/auth/pw-hash" "de" mkMessageVariant ''UniWorX ''ButtonMessage "messages/button" "de" mkMessageVariant ''UniWorX ''FrontendMessage "messages/frontend" "de-de-formal" -embedRenderMessage ''UniWorX ''HealthCheck id -- not possible here embedRenderMessage ''UniWorX ''AvsLicence id -- required by UniWorXAvsMessages mkMessageAddition ''UniWorX "Qualification" "messages/uniworx/categories/qualification" "de-de-formal" mkMessageAddition ''UniWorX "Avs" "messages/uniworx/categories/avs" "de-de-formal" @@ -317,6 +316,7 @@ appLanguagesOpts = do langOptions = map mkOption $ toList appLanguages return $ mkOptionList langOptions +embedRenderMessage ''UniWorX ''HealthCheck id embedRenderMessage ''UniWorX ''MessageStatus ("Message" <>) embedRenderMessage ''UniWorX ''NotificationTrigger $ ("NotificationTrigger" <>) . concat . drop 1 . splitCamel embedRenderMessage ''UniWorX ''StudyFieldType id diff --git a/src/Handler/Health.hs b/src/Handler/Health.hs index 3fd4a1c99..b19e90a7e 100644 --- a/src/Handler/Health.hs +++ b/src/Handler/Health.hs @@ -6,7 +6,7 @@ module Handler.Health where import Import --- import Handler.Utils +import Handler.Utils.DateTime (formatTimeW) import qualified Data.Aeson.Encode.Pretty as Aeson import qualified Data.Text.Lazy.Builder as Builder @@ -65,33 +65,22 @@ getHealthR = do _{MsgMessageError}
- $forall (_, report) <- healthReports' - $with hcclass = classifyHealthReport report - $with hcstatus = HealthSuccess == healthReportStatus report + $forall (lUp, report) <- healthReports' + $with hcclass <- classifyHealthReport report + $with hcstatus <- HealthSuccess == healthReportStatus report $case report - $of HealthMatchingClusterConfig passed -
_{MsgHealthCheckMatchingClusterConfig} -
#{boolSymbol passed} - $of HealthHTTPReachable (Just passed) -
_{MsgHealthCheckHTTPReachable} -
#{boolSymbol passed} $of HealthLDAPAdmins (Just found)
_{MsgHealthCheckLDAPAdmins}
#{textPercent found 1} - $of HealthSMTPConnect (Just passed) -
_{MsgHealthCheckSMTPConnect} -
#{boolSymbol passed} - $of HealthWidgetMemcached (Just passed) -
_{MsgHealthCheckWidgetMemcached} -
#{boolSymbol passed} + \ ^{formatTimeW SelFormatDateTime lUp} $of HealthActiveJobExecutors (Just active)
_{MsgHealthCheckActiveJobExecutors}
#{textPercent active 1} - $of HealthDoesFlush mProp + \ ^{formatTimeW SelFormatDateTime lUp} + $of _
_{hcclass}
#{boolSymbol hcstatus} - $of _ - + \ ^{formatTimeW SelFormatDateTime lUp} |] provideJson healthReports provideRep . return . Builder.toLazyText $ Aeson.encodePrettyToTextBuilder healthReports From 1b224630ebdc48c59961199f1c0c2459230587b5 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 12 Jul 2023 10:47:15 +0000 Subject: [PATCH 05/19] chore(health): add HealthStatus HealthInactive --- .../categories/health/de-de-formal.msg | 2 +- src/Application.hs | 2 +- src/Handler/Health.hs | 38 ++++++++++--------- src/Model/Types/Health.hs | 30 ++++++++++----- 4 files changed, 43 insertions(+), 29 deletions(-) diff --git a/messages/uniworx/categories/health/de-de-formal.msg b/messages/uniworx/categories/health/de-de-formal.msg index 429a37e47..75aa473dd 100644 --- a/messages/uniworx/categories/health/de-de-formal.msg +++ b/messages/uniworx/categories/health/de-de-formal.msg @@ -9,7 +9,7 @@ HealthCheckLDAPAdmins: Anteil der Administrator:innen mit LDAP Authentifizierung HealthCheckSMTPConnect: SMTP-Server kann erreicht werden HealthCheckWidgetMemcached: Memcached-Server liefert Widgets korrekt aus HealthCheckActiveJobExecutors: Anteil der job-workers, die neue Befehle annehmen -HealthCheckDoesFlush: Zustandspüfung läuft durch +HealthCheckDoesFlush: Zustandsprüfung läuft durch InstanceIdentification: Instanz-Identifikation InstanceId: Instanz-Nummer ClusterId: Cluster-Nummer \ No newline at end of file diff --git a/src/Application.hs b/src/Application.hs index 6592a8342..0181d2cf0 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -551,7 +551,7 @@ warpSettings foundation = defaultSettings atomically $ do results <- readTVar $ foundation ^. _appHealthReport guard $ activeChecks == Set.map (classifyHealthReport . snd) results - guard . (== Min HealthSuccess) $ foldMap (Min . healthReportStatus . snd) results + guard . (/= Min HealthFailure) $ foldMap (Min . healthReportStatus . snd) results notifyReady | otherwise -> notifyReady diff --git a/src/Handler/Health.hs b/src/Handler/Health.hs index b19e90a7e..e06f688ae 100644 --- a/src/Handler/Health.hs +++ b/src/Handler/Health.hs @@ -48,10 +48,10 @@ getHealthR = do setLastModified lastUpdated let status' - | HealthSuccess <- status - = ok200 - | otherwise + | HealthFailure <- status = internalServerError500 + | otherwise + = ok200 sendResponseStatus status' <=< selectRep $ do provideRep . siteLayoutMsg MsgHealthReport $ do setTitleI MsgHealthReport @@ -61,26 +61,28 @@ getHealthR = do $case status $of HealthSuccess _{MsgMessageSuccess} + $of HealthInactive + _{MsgMessageWarning} $of _ _{MsgMessageError}
$forall (lUp, report) <- healthReports' - $with hcclass <- classifyHealthReport report - $with hcstatus <- HealthSuccess == healthReportStatus report - $case report - $of HealthLDAPAdmins (Just found) -
_{MsgHealthCheckLDAPAdmins} -
#{textPercent found 1} - \ ^{formatTimeW SelFormatDateTime lUp} - $of HealthActiveJobExecutors (Just active) -
_{MsgHealthCheckActiveJobExecutors} -
#{textPercent active 1} - \ ^{formatTimeW SelFormatDateTime lUp} - $of _ -
_{hcclass} -
#{boolSymbol hcstatus} - \ ^{formatTimeW SelFormatDateTime lUp} + $case healthReportStatus report + $of HealthInactive + $of hcstatus +
+ _{classifyHealthReport report} +
+ #{boolSymbol (healthOk hcstatus)} # + $case report + $of HealthLDAPAdmins (Just found) + #{textPercent found 1} + $of HealthActiveJobExecutors (Just active) + #{textPercent active 1} + $of _ +
+ ^{formatTimeW SelFormatDateTime lUp} |] provideJson healthReports provideRep . return . Builder.toLazyText $ Aeson.encodePrettyToTextBuilder healthReports diff --git a/src/Model/Types/Health.hs b/src/Model/Types/Health.hs index 6528232bc..36f4be750 100644 --- a/src/Model/Types/Health.hs +++ b/src/Model/Types/Health.hs @@ -78,7 +78,7 @@ classifyHealthReport HealthDoesFlush{} = HealthCheckDoesFlush -- -- Currently all consumers of this type check for @(== HealthSuccess)@; this -- needs to be adjusted on a case-by-case basis if new constructors are added -data HealthStatus = HealthFailure | HealthSuccess +data HealthStatus = HealthFailure | HealthInactive | HealthSuccess deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic) instance Universe HealthStatus @@ -89,17 +89,29 @@ deriveJSON defaultOptions } ''HealthStatus nullaryPathPiece ''HealthStatus $ camelToPathPiece' 1 +healthOk :: HealthStatus -> Bool +healthOk HealthFailure = False +healthOk HealthInactive = True +healthOk HealthSuccess = True + healthReportStatus :: HealthReport -> HealthStatus -- ^ Classify `HealthReport` by badness -healthReportStatus = \case - HealthMatchingClusterConfig False -> HealthFailure - HealthHTTPReachable (Just False) -> HealthFailure +healthReportStatus = \case + HealthMatchingClusterConfig True -> HealthSuccess + HealthHTTPReachable (Just True ) -> HealthSuccess + HealthHTTPReachable Nothing -> HealthInactive HealthLDAPAdmins (Just prop ) - | prop <= 0 -> HealthFailure - HealthSMTPConnect (Just False) -> HealthFailure + | prop > 0 -> HealthSuccess + HealthLDAPAdmins Nothing -> HealthInactive + HealthSMTPConnect (Just True ) -> HealthSuccess + HealthSMTPConnect Nothing -> HealthInactive HealthWidgetMemcached (Just False) -> HealthFailure -- TODO: investigate this failure mode; do we just handle it gracefully? + HealthWidgetMemcached (Just True ) -> HealthSuccess + HealthWidgetMemcached Nothing -> HealthInactive + HealthActiveJobExecutors Nothing -> HealthInactive HealthActiveJobExecutors (Just prop ) - | prop <= 0 -> HealthFailure + | prop > 0 -> HealthSuccess HealthDoesFlush mProp - | maybe True (>= 2) mProp -> HealthFailure - _other -> maxBound -- Minimum badness + | maybe True (>= 2) mProp -> HealthFailure -- Looks buggy to me? + | otherwise -> HealthSuccess + _other -> HealthFailure From a8df40d9f8943f2e0c4e219074486dbbf0eaf0fe Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 12 Jul 2023 11:16:22 +0000 Subject: [PATCH 06/19] fix(lms): add safeguard to LmsUserlist dispatch running twice, thus ending LMS prematurely --- src/Jobs/Handler/LMS.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index 933cfa867..04eb37018 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -304,7 +304,7 @@ dispatchJobLmsUserlist :: QualificationId -> JobHandler UniWorX dispatchJobLmsUserlist qid = JobHandlerAtomic act where act :: YesodJobDB UniWorX () - act = do + 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 From 2e59d3c2ea4d5017be9b4e578b7da12c4da0e2fa Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 12 Jul 2023 11:19:21 +0000 Subject: [PATCH 07/19] fix(avs): background avs synch yielding undefined due to wrong monad --- src/Jobs/Handler/SynchroniseAvs.hs | 13 +++++-------- 1 file changed, 5 insertions(+), 8 deletions(-) diff --git a/src/Jobs/Handler/SynchroniseAvs.hs b/src/Jobs/Handler/SynchroniseAvs.hs index bdc2a3aab..0a3281f07 100644 --- a/src/Jobs/Handler/SynchroniseAvs.hs +++ b/src/Jobs/Handler/SynchroniseAvs.hs @@ -47,23 +47,20 @@ dispatchJobSynchroniseAvs numIterations epoch iteration pause dispatchJobSynchroniseAvsId :: AvsPersonId -> Maybe Day -> JobHandler UniWorX dispatchJobSynchroniseAvsId apid pause = JobHandlerException $ do - ok <- runDBJobs $ + ok <- runDB $ getBy (UniqueUserAvsId apid) >>= \case (Just Entity{entityVal=UserAvs{userAvsUser=uid}}) -> do -- known user workJobSychronizeAvs uid pause return True - Nothing -> -- unknown avsPersonId, attempt to create user + _ -> -- unknown avsPersonId, attempt to create user return False - -- flip (maybeM $ return False) (getBy $ UniqueUserAvsId apid) $ \Entity{entityVal=UserAvs{userAvsUser=uid}} -> do -- known user - -- workJobSychronizeAvs uid pause - -- return True unless ok $ void $ maybeCatchAll $ upsertAvsUserById apid dispatchJobSynchroniseAvsUser :: UserId -> Maybe Day -> JobHandler UniWorX -dispatchJobSynchroniseAvsUser uid pause = JobHandlerException $ runDBJobs $ workJobSychronizeAvs uid pause +dispatchJobSynchroniseAvsUser uid pause = JobHandlerException $ runDB $ workJobSychronizeAvs uid pause -workJobSychronizeAvs :: UserId -> Maybe Day -> JobDB () +workJobSychronizeAvs :: UserId -> Maybe Day -> DB () workJobSychronizeAvs uid pause = do now <- liftIO getCurrentTime void $ E.upsert @@ -72,7 +69,7 @@ workJobSychronizeAvs uid pause = do , avsSyncPause = pause } [ \oldSync -> (AvsSyncPause E.=. E.greatest (E.val pause) (oldSync E.^. AvsSyncPause)) oldSync ] - queueDBJob JobSynchroniseAvsQueue + queueJob' JobSynchroniseAvsQueue dispatchJobSynchroniseAvsQueue :: JobHandler UniWorX dispatchJobSynchroniseAvsQueue = JobHandlerException $ do From 57842a53e73b96da986e3f4cdba6be8fa55be2a1 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 12 Jul 2023 12:51:34 +0000 Subject: [PATCH 08/19] chore(health): minor change treating HealthInactive --- src/Application.hs | 2 +- src/Jobs/Handler/SynchroniseAvs.hs | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Application.hs b/src/Application.hs index 0181d2cf0..6592a8342 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -551,7 +551,7 @@ warpSettings foundation = defaultSettings atomically $ do results <- readTVar $ foundation ^. _appHealthReport guard $ activeChecks == Set.map (classifyHealthReport . snd) results - guard . (/= Min HealthFailure) $ foldMap (Min . healthReportStatus . snd) results + guard . (== Min HealthSuccess) $ foldMap (Min . healthReportStatus . snd) results notifyReady | otherwise -> notifyReady diff --git a/src/Jobs/Handler/SynchroniseAvs.hs b/src/Jobs/Handler/SynchroniseAvs.hs index 0a3281f07..2693da5cc 100644 --- a/src/Jobs/Handler/SynchroniseAvs.hs +++ b/src/Jobs/Handler/SynchroniseAvs.hs @@ -47,8 +47,8 @@ dispatchJobSynchroniseAvs numIterations epoch iteration pause dispatchJobSynchroniseAvsId :: AvsPersonId -> Maybe Day -> JobHandler UniWorX dispatchJobSynchroniseAvsId apid pause = JobHandlerException $ do - ok <- runDB $ - getBy (UniqueUserAvsId apid) >>= \case + ok <- runDB $ getBy (UniqueUserAvsId apid) >>= + \case (Just Entity{entityVal=UserAvs{userAvsUser=uid}}) -> do -- known user workJobSychronizeAvs uid pause return True From 80c632df1ca4871c10cdac1141d87f92a7646cf7 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 12 Jul 2023 13:58:44 +0000 Subject: [PATCH 09/19] fix(lpr): fix #96 by various minor improvements to PrintCenter --- .../uniworx/categories/print/de-de-formal.msg | 1 + messages/uniworx/categories/print/en-eu.msg | 1 + src/Handler/PrintCenter.hs | 23 +++++++--- src/Utils/Print.hs | 45 ++++++++++--------- templates/print-center.hamlet | 5 ++- 5 files changed, 46 insertions(+), 29 deletions(-) diff --git a/messages/uniworx/categories/print/de-de-formal.msg b/messages/uniworx/categories/print/de-de-formal.msg index 1eb9eb034..32fe30556 100644 --- a/messages/uniworx/categories/print/de-de-formal.msg +++ b/messages/uniworx/categories/print/de-de-formal.msg @@ -4,6 +4,7 @@ PJActAcknowledge: Druck und Versand bestätigen PJActReprint: Erneut drucken über APC +PJActReprintIgnoreReroute: Drucken auch bei aktiver Mail-Umleitung erzwingen PrintJobName: Bezeichnung PrintJobFilename: Dateiname PrintJobId !ident-ok: Id diff --git a/messages/uniworx/categories/print/en-eu.msg b/messages/uniworx/categories/print/en-eu.msg index a1090de43..053fd1a7e 100644 --- a/messages/uniworx/categories/print/en-eu.msg +++ b/messages/uniworx/categories/print/en-eu.msg @@ -4,6 +4,7 @@ PJActAcknowledge: Acknowledge printing and mailing PJActReprint: Print again via APC +PJActReprintIgnoreReroute: Force printing to APC, even if mail-reroute-to option is active PrintJobName: Description PrintJobFilename: Filename PrintJobId: Id diff --git a/src/Handler/PrintCenter.hs b/src/Handler/PrintCenter.hs index 90889c63d..0d2455400 100644 --- a/src/Handler/PrintCenter.hs +++ b/src/Handler/PrintCenter.hs @@ -127,7 +127,7 @@ nullaryPathPiece ''PJTableAction $ camelToPathPiece' 2 embedRenderMessage ''UniWorX ''PJTableAction id -- Not yet needed, since there is no additional data for now: -data PJTableActionData = PJActAcknowledgeData | PJActReprintData +data PJTableActionData = PJActAcknowledgeData | PJActReprintData { ignoreReroute :: Maybe Bool } deriving (Eq, Ord, Read, Show, Generic) type PJTableExpr = ( E.SqlExpr (Entity PrintJob) @@ -192,7 +192,7 @@ mkPJTable = do dbtRowKey = queryPrintJob >>> (E.^. PrintJobId) dbtProj = dbtProjId dbtColonnade = mconcat - [ dbSelectIf (applying _2) id (return . view (resultPrintJob . _entityKey)) (\r -> isNothing $ r ^. resultPrintJob . _entityVal . _printJobAcknowledged) + [ dbSelect (applying _2) id (return . view (resultPrintJob . _entityKey)) -- condition for dbSelectIf: (\r -> isNothing $ r ^. resultPrintJob . _entityVal . _printJobAcknowledged) , sortable (Just "created") (i18nCell MsgPrintJobCreated) $ \( view $ resultPrintJob . _entityVal . _printJobCreated -> t) -> dateTimeCell t , sortable (Just "acknowledged") (i18nCell MsgPrintJobAcknowledged) $ \( view $ resultPrintJob . _entityVal . _printJobAcknowledged -> t) -> maybeDateTimeCell t , sortable (Just "filename") (i18nCell MsgPrintPDF) $ \r -> let k = r ^. resultPrintJob . _entityKey @@ -262,7 +262,8 @@ mkPJTable = do = let acts :: Map PJTableAction (AForm Handler PJTableActionData) acts = mconcat [ singletonMap PJActAcknowledge $ pure PJActAcknowledgeData - , singletonMap PJActReprint $ pure PJActReprintData + , singletonMap PJActReprint $ PJActReprintData + <$> aopt checkBoxField (fslI MsgPJActReprintIgnoreReroute) Nothing ] in renderAForm FormStandard $ (, mempty) . First . Just @@ -292,15 +293,23 @@ postPrintCenterR = do num <- runDB $ updateWhereCount [PrintJobAcknowledged ==. Nothing, PrintJobId <-. pjIds] [PrintJobAcknowledged =. Just now] addMessageI Success $ MsgPrintJobAcknowledge num reloadKeepGetParams PrintCenterR - (PJActReprintData, Set.toList -> pjIds) -> do - let countOk = either (const $ Sum 0) (const $ Sum 1) - oks <- runDB $ forM pjIds $ fmap countOk . reprintPDF + (PJActReprintData{ignoreReroute}, Set.toList -> pjIds) -> do + let countOk = either (const $ Sum 0) (const $ Sum 1) + oks <- runDB $ forM pjIds $ fmap countOk . reprintPDF (fromMaybe False ignoreReroute) let nr_oks = getSum $ mconcat oks nr_tot = length pjIds mstat = bool Warning Success $ nr_oks == nr_tot addMessageI mstat $ MsgPrintJobReprint nr_oks nr_tot reloadKeepGetParams PrintCenterR - + siteConf <- getYesod + let lprConf = siteConf ^. _appLprConf + reroute = siteConf ^. _appMailRerouteTo + lprWgt = [whamlet| + LPR Konfiguration ist #{lprQueue lprConf}@#{lprHost lprConf}:#{lprPort lprConf} +
+ $maybe _ <- reroute + Mail-reroute-to ist gesetzt, somit werden alle lpr Kommandos unterdrückt! + |] siteLayoutMsg MsgMenuApc $ do setTitleI MsgMenuApc $(widgetFile "print-center") -- i18nWidgetFile? Currently no text contained; displays just the table only diff --git a/src/Utils/Print.hs b/src/Utils/Print.hs index 313ffb333..7735f1f09 100644 --- a/src/Utils/Print.hs +++ b/src/Utils/Print.hs @@ -278,12 +278,12 @@ printLetter' pji pdf = do insert_ PrintJob {..} return $ Right (ok, printJobFilename) -reprintPDF :: PrintJobId -> DB (Either Text Text) -reprintPDF pjid = maybeM (return $ Left "Print job id is unknown.") reprint $ get pjid +reprintPDF :: Bool -> PrintJobId -> DB (Either Text Text) +reprintPDF ignoreReroute pjid = maybeM (return $ Left "Print job id is unknown.") reprint $ get pjid where reprint :: PrintJob -> DB (Either Text Text) reprint pj@PrintJob{..} = do - result <- lprPDF printJobFilename $ LBS.fromStrict printJobFile + result <- lprPDF' ignoreReroute printJobFilename $ LBS.fromStrict printJobFile whenIsRight result $ const $ do now <- liftIO getCurrentTime insert_ pj{ printJobAcknowledged = Nothing @@ -460,26 +460,29 @@ encryptPDF pw bs = over _Left (decodeUtf8 . LBS.toStrict) . exit2either <$> read -- | Internal only, use `printLetter` instead lprPDF :: (MonadHandler m, HasAppSettings (HandlerSite m)) => FilePath -> LBS.ByteString -> m (Either Text Text) -lprPDF (sanitizeCmdArg' -> jb) bs = do - mbLprServerArg <- getLprServerArg - case mbLprServerArg of - Nothing -> return $ Right "Print command ignored due to setting 'mail-reroute-to' being set." - Just lprServerArg -> do - let pc = setStdin (byteStringInput bs) $ - proc "lpr" $ - jobname ++ -- -J jobname -- a name for job identification at printing site - [ lprServerArg -- -P queue@hostname:port - , "-" -- read from stdin - ] - jobname | null jb = [] - | otherwise = ["-J " <> jb] - exit2either <$> readProcess' pc - where +lprPDF = lprPDF' False + +lprPDF' :: (MonadHandler m, HasAppSettings (HandlerSite m)) => Bool -> FilePath -> LBS.ByteString -> m (Either Text Text) +lprPDF' ignoreReroute (sanitizeCmdArg' -> jb) bs = maybeM hdlFail hdlLpr getLprServerArg + where + hdlFail = return $ Right "Print command ignored due to setting 'mail-reroute-to' being set." + + hdlLpr lprServerArg = do + let pc = setStdin (byteStringInput bs) $ + proc "lpr" $ + jobname ++ -- -J jobname -- a name for job identification at printing site + [ lprServerArg -- -P queue@hostname:port + , "-" -- read from stdin + ] + jobname | null jb = [] + | otherwise = ["-J " <> jb] + exit2either <$> readProcess' pc + getLprServerArg = do rerouteMail <- getsYesod $ view _appMailRerouteTo - case rerouteMail of - Just _ -> return Nothing - Nothing -> do + case (ignoreReroute, rerouteMail) of + (False, Just _) -> return Nothing + _ -> do LprConf{..} <- getsYesod $ view _appLprConf return . Just $ "-P " <> lprQueue <> "@" <> lprHost <> ":" <> show lprPort diff --git a/templates/print-center.hamlet b/templates/print-center.hamlet index 6f6008a5c..1cac8e15e 100644 --- a/templates/print-center.hamlet +++ b/templates/print-center.hamlet @@ -6,4 +6,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later

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

+ ^{modal "APC Konfiguration" (Right lprWgt)} \ No newline at end of file From 1ce8f75c2d192051929b1a74b17f4e6494961901 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 12 Jul 2023 14:32:49 +0000 Subject: [PATCH 10/19] fix(tutorial): fix #94 tutorial renaming (de) and template naming --- .../categories/courses/courses/de-de-formal.msg | 12 ++++++------ src/Handler/Course/ParticipantInvite.hs | 2 +- templates/i18n/info-lecturer/de-de-formal.hamlet | 10 +++++----- 3 files changed, 12 insertions(+), 12 deletions(-) diff --git a/messages/uniworx/categories/courses/courses/de-de-formal.msg b/messages/uniworx/categories/courses/courses/de-de-formal.msg index f0df8c433..a0bf4391e 100644 --- a/messages/uniworx/categories/courses/courses/de-de-formal.msg +++ b/messages/uniworx/categories/courses/courses/de-de-formal.msg @@ -81,21 +81,21 @@ CourseSubmissionGroup: Feste Abgabegruppe SubmissionGroupEmptyIsUnsetTip: Leer lassen um Benutzer:innen aus den jeweiligen Abgabegruppen ersatzlos zu entfernen CourseParticipantsRegisterHeading: Kursartteilnehmer:innen hinzufügen CourseParticipantsRegisterActionAddParticipants: Personen zur Kursart anmelden -CourseParticipantsRegisterActionAddTutorialMembers: Personen zur Kursart und Kursgruppe anmelden +CourseParticipantsRegisterActionAddTutorialMembers: Personen zur Kursart und Kurs anmelden CourseParticipantsRegisterUsersField: Zur Kursart anzumeldende Personen CourseParticipantsRegisterUsersFieldTip: Bitte Ausweiskartennummer inklusive Punkt, Fraport Personalnummer oder Email angeben. Mehrere Personen bitte mit Komma oder Leerzeichen trennen. -CourseParticipantsRegisterTutorialOption: Kursartteilnehmer:innen zu Kursgruppe anmelden? -CourseParticipantsRegisterTutorialField: Kursgruppe -CourseParticipantsRegisterTutorialFieldTip: Ist aktuell keine Kursgruppe mit diesem Namen vorhanden, wird eine neue erstellt. Ist bereits eine Kursgruppe mit diesem Namen vorhanden, werden die Kursartteilnehmenden dieser hinzugefügt. +CourseParticipantsRegisterTutorialOption: Kursartteilnehmer:innen zu Kurs anmelden? +CourseParticipantsRegisterTutorialField: Kurs +CourseParticipantsRegisterTutorialFieldTip: Ist aktuell keine Kurs mit diesem Namen vorhanden, wird eine neue erstellt. Ist bereits eine Kurs mit diesem Namen vorhanden, werden die Kursartteilnehmenden dieser hinzugefügt. CourseParticipantsRegisterNoneGiven: Es wurden keine anzumeldenden Personen angegeben! CourseParticipantsRegisterNotFoundInAvs n@Int: Zu #{n} #{pluralDE n "Angabe konnte keine übereinstimmende Person" "Angaben konnten keine übereinstimmenden Personen"} im AVS gefunden werden CourseParticipantsRegisterTutorialFirstDayTip: Wenn ein neuer Kurs gemäß einer Vorlage erstellt wird, werden die Zeiten gemäß dem Starttag angepasst CourseParticipantsInvited n@Int: #{n} #{pluralDE n "Einladung" "Einladungen"} per E-Mail verschickt CourseParticipantsAlreadyRegistered n@Int: #{n} #{pluralDE n "Teinehmer:in" "Teilnehmer:innen"} #{pluralDE n "ist" "sind"} bereits zur Kursart angemeldet -CourseParticipantsAlreadyTutorialMember n@Int: #{n} #{pluralDE n "Teinehmer:in" "Teilnehmer:innen"} #{pluralDE n "ist" "sind"} bereits in dieser Kursgruppe angemeldet +CourseParticipantsAlreadyTutorialMember n@Int: #{n} #{pluralDE n "Teinehmer:in" "Teilnehmer:innen"} #{pluralDE n "ist" "sind"} bereits in dieser Kurs angemeldet CourseParticipantsRegistered n@Int: #{n} #{pluralDE n "Teinehmer:in" "Teilnehmer:innen"} erfolgreich zur Kursart angemeldet -CourseParticipantsRegisteredTutorial n@Int: #{n} #{pluralDE n "Teinehmer:in" "Teilnehmer:innen"} erfolgreich zur Kursgruppe angemeldet +CourseParticipantsRegisteredTutorial n@Int: #{n} #{pluralDE n "Teinehmer:in" "Teilnehmer:innen"} erfolgreich zur Kurs angemeldet CourseParticipantsRegisterConfirmationHeading: Teilnehmer:innen hinzufügen CourseParticipantsRegisterUnnecessary: Alle angeforderten Anmeldungen sind bereits vorhanden. Es wurden keine Änderungen vorgenommen. CourseParticipantsRegisterConfirmInvalid: Ungültiges Bestätigungsformular! diff --git a/src/Handler/Course/ParticipantInvite.hs b/src/Handler/Course/ParticipantInvite.hs index 4b79d8c86..d31cd0d41 100644 --- a/src/Handler/Course/ParticipantInvite.hs +++ b/src/Handler/Course/ParticipantInvite.hs @@ -52,7 +52,7 @@ tutorialDefaultName :: Maybe TutorialType -> Day -> TutorialName tutorialDefaultName Nothing = CI.mk . tshow -- Don't use user date display setting, so that tutorial default names conform to all users tutorialDefaultName (Just ttyp) = let prefix = CI.mk $ snd $ Text.breakOnEnd (CI.original tutorialTypeSeparator) $ CI.original ttyp - in ((prefix <> tutorialTypeSeparator) <>) . tutorialDefaultName Nothing + in (<> (tutorialTypeSeparator <> prefix)) . tutorialDefaultName Nothing data ButtonCourseRegisterMode = BtnCourseRegisterConfirm | BtnCourseRegisterAbort deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) diff --git a/templates/i18n/info-lecturer/de-de-formal.hamlet b/templates/i18n/info-lecturer/de-de-formal.hamlet index e10eb28a5..b683e141a 100644 --- a/templates/i18n/info-lecturer/de-de-formal.hamlet +++ b/templates/i18n/info-lecturer/de-de-formal.hamlet @@ -285,9 +285,9 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
Ausbilder:innen

- Ausbilder:innen werden ad hoc pro Kursgruppe festgelegt. + Ausbilder:innen werden ad hoc pro Kurs festgelegt.
- Eine Kursgruppe kann beliebig viele Ausbilder:innen haben und ein Ausbilder kann beliebig viele Kursegruppen betreuen. + Eine Kurs kann beliebig viele Ausbilder:innen haben und ein Ausbilder kann beliebig viele Kursegruppen betreuen.

Ausbilder:innen haben Zugriff auf die Namen und Studiendaten ihrer Kursteilnehmer:innen, können Mitteilungen an sie verschicken (analog zu Kursartmitteilungen) und Teilnehmer:innen aus ihrem Kurs entfernen. @@ -307,16 +307,16 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
Eine vorherige Anmeldung zur Kursart ist Voraussetzung.

- Die Anmeldung kann pro Kursgruppe zeitlich beschränkt werden. + Die Anmeldung kann pro Kurs zeitlich beschränkt werden.

- Kursgruppen können mit einer Registrierungs-Gruppe versehen werden. + Kurse können mit einer Registrierungs-Gruppe versehen werden. Es handelt sich hierbei um einen beliebig wählbaren Text, der ansonsten keine Bedeutung hat.
Lernenden wird die Anmeldung nur in einem Kurs pro Registrierungs-Gruppe erlaubt. Leere Registrierungs-Gruppen (d.h. es wurde keine Registrierungs-Gruppe angegeben) zählen hierbei als verschieden.

- Um die Anmeldung in beliebig viele Kursgruppen zuzulassen können alle Registrierungs-Gruppen leer gelassen werden. + Um die Anmeldung in beliebig viele Kurse zuzulassen können alle Registrierungs-Gruppen leer gelassen werden.

^{newFeat 2019 10 10} Nachmeldung
From 7ed891a120065e1badd9ecafc8c272adc4a73193 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 12 Jul 2023 16:08:57 +0000 Subject: [PATCH 11/19] chore(jobs): stub for queued job interface towards #95 --- .../navigation/breadcrumbs/de-de-formal.msg | 1 + .../utils/navigation/breadcrumbs/en-eu.msg | 1 + .../utils/navigation/menu/de-de-formal.msg | 1 + .../uniworx/utils/navigation/menu/en-eu.msg | 1 + .../utils/table_column/de-de-formal.msg | 2 + messages/uniworx/utils/table_column/en-eu.msg | 2 + routes | 1 + src/Foundation/Navigation.hs | 8 +++ src/Handler/Admin/Crontab.hs | 50 ++++++++++++++++++- 9 files changed, 66 insertions(+), 1 deletion(-) diff --git a/messages/uniworx/utils/navigation/breadcrumbs/de-de-formal.msg b/messages/uniworx/utils/navigation/breadcrumbs/de-de-formal.msg index 3d083e6e7..9087f1ca0 100644 --- a/messages/uniworx/utils/navigation/breadcrumbs/de-de-formal.msg +++ b/messages/uniworx/utils/navigation/breadcrumbs/de-de-formal.msg @@ -66,6 +66,7 @@ BreadcrumbFaq !ident-ok: FAQ BreadcrumbSheetPersonalisedFiles: Personalisierte Dateien herunterladen BreadcrumbCourseSheetPersonalisedFiles: Vorlage für personalisierte Übungsblatt-Dateien herunterladen BreadcrumbAdminCrontab !ident-ok: Crontab +BreadcrumbAdminJobs !ident-ok: Jobs BreadcrumbError: Fehler BreadcrumbUpload !ident-ok: Upload BreadcrumbUserAdd: Benutzer:in anlegen diff --git a/messages/uniworx/utils/navigation/breadcrumbs/en-eu.msg b/messages/uniworx/utils/navigation/breadcrumbs/en-eu.msg index deadd76e7..5763051d1 100644 --- a/messages/uniworx/utils/navigation/breadcrumbs/en-eu.msg +++ b/messages/uniworx/utils/navigation/breadcrumbs/en-eu.msg @@ -66,6 +66,7 @@ BreadcrumbFaq: FAQ BreadcrumbSheetPersonalisedFiles: Download personalised sheet files BreadcrumbCourseSheetPersonalisedFiles: Download template for personalised sheet files BreadcrumbAdminCrontab: Crontab +BreadcrumbAdminJobs !ident-ok: Jobs BreadcrumbError: Error BreadcrumbUpload: Upload BreadcrumbUserAdd: Add user diff --git a/messages/uniworx/utils/navigation/menu/de-de-formal.msg b/messages/uniworx/utils/navigation/menu/de-de-formal.msg index abc748e02..ff8043db6 100644 --- a/messages/uniworx/utils/navigation/menu/de-de-formal.msg +++ b/messages/uniworx/utils/navigation/menu/de-de-formal.msg @@ -107,6 +107,7 @@ MenuFaq !ident-ok: FAQ MenuSheetPersonalisedFiles: Personalisierte Dateien herunterladen MenuCourseSheetPersonalisedFiles: Vorlage für personalisierte Übungsblatt-Dateien herunterladen MenuAdminCrontab !ident-ok: Crontab +MenuAdminJobs: Job Warteschlange MenuGlossary: Begriffsverzeichnis MenuVersion: Versionsgeschichte MenuCourseNewsNew: Neue Kursartnachricht diff --git a/messages/uniworx/utils/navigation/menu/en-eu.msg b/messages/uniworx/utils/navigation/menu/en-eu.msg index 81ca762a8..7dc653c6a 100644 --- a/messages/uniworx/utils/navigation/menu/en-eu.msg +++ b/messages/uniworx/utils/navigation/menu/en-eu.msg @@ -108,6 +108,7 @@ MenuFaq: FAQ MenuSheetPersonalisedFiles: Download personalised sheet files MenuCourseSheetPersonalisedFiles: Download template for personalised sheet files MenuAdminCrontab: Crontab +MenuAdminJobs: Job queue MenuGlossary: Glossary MenuVersion: Version history MenuCourseNewsNew: Add course type news diff --git a/messages/uniworx/utils/table_column/de-de-formal.msg b/messages/uniworx/utils/table_column/de-de-formal.msg index b9e575dda..18757a352 100644 --- a/messages/uniworx/utils/table_column/de-de-formal.msg +++ b/messages/uniworx/utils/table_column/de-de-formal.msg @@ -78,3 +78,5 @@ TableCompany: Firma TableCompanies: Firmen TableCompanyNos: Firmennummern TableSupervisor: Ansprechpartner +TableCreationTime: Erstellungszeit +TableJobContent !ident-ok: Job diff --git a/messages/uniworx/utils/table_column/en-eu.msg b/messages/uniworx/utils/table_column/en-eu.msg index 5187d80dc..1bfa7cdb7 100644 --- a/messages/uniworx/utils/table_column/en-eu.msg +++ b/messages/uniworx/utils/table_column/en-eu.msg @@ -78,3 +78,5 @@ TableCompany: Company TableCompanies: Companies TableCompanyNos: Company numbers TableSupervisor: Supervisor +TableCreationTime: Creation +TableJobContent: Job \ No newline at end of file diff --git a/routes b/routes index 32721396e..7a80c2012 100644 --- a/routes +++ b/routes @@ -66,6 +66,7 @@ /admin/errMsg AdminErrMsgR GET POST /admin/tokens AdminTokensR GET POST /admin/crontab AdminCrontabR GET +/admin/crontab/jobs AdminJobsR GET POST /admin/avs AdminAvsR GET POST /admin/avs/#CryptoUUIDUser AdminAvsUserR GET /admin/ldap AdminLdapR GET POST diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index 5f91b778b..8a4dcbddd 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -112,6 +112,7 @@ breadcrumb AdminTestPdfR = i18nCrumb MsgMenuAdminTest $ Just breadcrumb AdminErrMsgR = i18nCrumb MsgMenuAdminErrMsg $ Just AdminR breadcrumb AdminTokensR = i18nCrumb MsgMenuAdminTokens $ Just AdminR breadcrumb AdminCrontabR = i18nCrumb MsgBreadcrumbAdminCrontab $ Just AdminR +breadcrumb AdminJobsR = i18nCrumb MsgBreadcrumbAdminJobs $ Just AdminCrontabR breadcrumb AdminAvsR = i18nCrumb MsgMenuAvs $ Just AdminR breadcrumb AdminAvsUserR{} = i18nCrumb MsgAvsPersonInfo $ Just AdminAvsR breadcrumb AdminLdapR = i18nCrumb MsgMenuLdap $ Just AdminR @@ -2396,6 +2397,13 @@ pageActions PrintCenterR = do dayLinks <- mapM toDayAck $ Map.toAscList dayMap return $ manualSend : take 9 dayLinks +pageActions AdminCrontabR = return + [ NavPageActionPrimary + { navLink = defNavLink MsgMenuAdminJobs AdminJobsR + , navChildren = [] + } + ] + pageActions _ = return [] submissionList :: ( MonadIO m diff --git a/src/Handler/Admin/Crontab.hs b/src/Handler/Admin/Crontab.hs index 12f4349de..e0232c3fe 100644 --- a/src/Handler/Admin/Crontab.hs +++ b/src/Handler/Admin/Crontab.hs @@ -6,23 +6,31 @@ module Handler.Admin.Crontab ( getAdminCrontabR + , getAdminJobsR + , postAdminJobsR ) where import Import import Jobs -import Handler.Utils.DateTime +import Handler.Utils import qualified Data.Aeson.Encode.Pretty as Pretty import Data.Aeson.Encode.Pretty (encodePrettyToTextBuilder') +-- import qualified Data.CaseInsensitive as CI import qualified Data.Text as Text import qualified Data.Text.Lazy.Builder as Text.Builder +import qualified Data.Map as Map import qualified Data.HashSet as HashSet import qualified Data.HashMap.Strict as HashMap import qualified Data.UUID as UUID +import qualified Database.Esqueleto.Legacy as E +-- import qualified Database.Esqueleto.Utils as E +-- import Database.Esqueleto.Utils.TH + deriveJSON defaultOptions { constructorTagModifier = camelToPathPiece' 1 @@ -96,3 +104,43 @@ getAdminCrontabR = do , Text.splitOn "-" t ) } + + +getAdminJobsR, postAdminJobsR :: Handler Html +getAdminJobsR = postAdminJobsR +postAdminJobsR = do + let + jobsDBTable = DBTable{..} + where + resultJob :: Lens' (DBRow (Entity QueuedJob)) (Entity QueuedJob) + resultJob = _dbrOutput + + dbtSQLQuery = return + dbtRowKey = (E.^. QueuedJobId) + dbtProj = dbtProjId + dbtColonnade = dbColonnade $ mconcat -- remove call to dbColonnade if table actions are added + [ sortable (Just "creation-time") (i18nCell MsgTableCreationTime) $ \(view $ resultJob . _entityVal -> QueuedJob{..}) -> dateTimeCell queuedJobCreationTime + , sortable (Just "content") (i18nCell MsgTableCreationTime) $ \(view $ resultJob . _entityVal -> QueuedJob{..}) -> stringCell $ show queuedJobContent + ] + dbtSorting = Map.fromList + [ ("creation-time", SortColumnNullsInv (E.^. QueuedJobCreationTime)) + , ("content" , SortColumn (E.^. QueuedJobContent)) + ] + dbtFilter = Map.empty + dbtFilterUI = const mempty + dbtStyle = def + dbtParams = def + dbtIdent :: Text + dbtIdent = "queued-jobs" + dbtCsvEncode = noCsvEncode + dbtCsvDecode = Nothing + dbtExtraReps = [] + jobsDBTableValidator = def + & defaultSorting [SortDescBy "creation-time"] + ((), jobsTable) <- runDB $ dbTable jobsDBTableValidator jobsDBTable + + siteLayoutMsg MsgMenuAdminJobs $ do + setTitleI MsgMenuAdminJobs + [whamlet| + ^{jobsTable} + |] \ No newline at end of file From 256740e15e5e07f3e4a6a176d7ae01cce930c8e8 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 12 Jul 2023 20:08:59 +0000 Subject: [PATCH 12/19] chore(release): 27.4.13 --- CHANGELOG.md | 10 ++++++++++ nix/docker/demo-version.json | 2 +- nix/docker/version.json | 2 +- package-lock.json | 2 +- package.json | 2 +- package.yaml | 2 +- 6 files changed, 15 insertions(+), 5 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 7456eff4f..5b5eebd6c 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,16 @@ 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.13](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.12...v27.4.13) (2023-07-12) + + +### Bug Fixes + +* **avs:** background avs synch yielding undefined due to wrong monad ([2e59d3c](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/2e59d3c2ea4d5017be9b4e578b7da12c4da0e2fa)) +* **lms:** add safeguard to LmsUserlist dispatch running twice, thus ending LMS prematurely ([a8df40d](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/a8df40d9f8943f2e0c4e219074486dbbf0eaf0fe)) +* **lpr:** fix [#96](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/96) by various minor improvements to PrintCenter ([80c632d](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/80c632df1ca4871c10cdac1141d87f92a7646cf7)) +* **tutorial:** fix [#94](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/94) tutorial renaming (de) and template naming ([1ce8f75](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/1ce8f75c2d192051929b1a74b17f4e6494961901)) + ## [27.4.12](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.11...v27.4.12) (2023-07-08) diff --git a/nix/docker/demo-version.json b/nix/docker/demo-version.json index ecc9308f3..fe44f31d2 100644 --- a/nix/docker/demo-version.json +++ b/nix/docker/demo-version.json @@ -1,3 +1,3 @@ { - "version": "27.4.12" + "version": "27.4.13" } diff --git a/nix/docker/version.json b/nix/docker/version.json index ecc9308f3..fe44f31d2 100644 --- a/nix/docker/version.json +++ b/nix/docker/version.json @@ -1,3 +1,3 @@ { - "version": "27.4.12" + "version": "27.4.13" } diff --git a/package-lock.json b/package-lock.json index 5662fa9dd..1573d51d9 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.4.12", + "version": "27.4.13", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index 7cb2e2d29..9905d5fcd 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.4.12", + "version": "27.4.13", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index 0abe5190d..4ce8a77e3 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 27.4.12 +version: 27.4.13 dependencies: - base - yesod From 240c6f81f81d1872317da01411fa67ec97e3b16d Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 13 Jul 2023 16:08:57 +0000 Subject: [PATCH 13/19] fix(avs): eliminate call to undefined in Esqueleto.Internals --- src/Jobs/Handler/SynchroniseAvs.hs | 23 ++++++++++++++--------- 1 file changed, 14 insertions(+), 9 deletions(-) diff --git a/src/Jobs/Handler/SynchroniseAvs.hs b/src/Jobs/Handler/SynchroniseAvs.hs index 2693da5cc..408758885 100644 --- a/src/Jobs/Handler/SynchroniseAvs.hs +++ b/src/Jobs/Handler/SynchroniseAvs.hs @@ -12,9 +12,9 @@ module Jobs.Handler.SynchroniseAvs import Import -import qualified Database.Esqueleto.Legacy as E hiding (upsert) -import qualified Database.Esqueleto.PostgreSQL as E -import qualified Database.Esqueleto.Utils as E +-- import qualified Database.Esqueleto.Legacy as E hiding (upsert) +-- import qualified Database.Esqueleto.PostgreSQL as E +-- import qualified Database.Esqueleto.Utils as E import qualified Data.Conduit.List as C import Jobs.Queue @@ -63,12 +63,17 @@ dispatchJobSynchroniseAvsUser uid pause = JobHandlerException $ runDB $ workJobS workJobSychronizeAvs :: UserId -> Maybe Day -> DB () workJobSychronizeAvs uid pause = do now <- liftIO getCurrentTime - void $ E.upsert - AvsSync { avsSyncUser = uid - , avsSyncCreationTime = now - , avsSyncPause = pause - } - [ \oldSync -> (AvsSyncPause E.=. E.greatest (E.val pause) (oldSync E.^. AvsSyncPause)) oldSync ] + -- void $ E.upsert + -- AvsSync { avsSyncUser = uid + -- , avsSyncCreationTime = now + -- , avsSyncPause = pause + -- } + -- [ \oldSync -> (AvsSyncPause E.=. E.greatest (E.val pause) (oldSync E.^. AvsSyncPause)) oldSync ] -- causes Esqueleto to call undefined at Database.Esqueleto.Internal.Internal.renderUpdates:1308 + maybeM + (insert_ AvsSync{avsSyncUser=uid, avsSyncCreationTime=now, avsSyncPause=pause}) + (\Entity{entityKey=asid, entityVal=AvsSync{avsSyncPause=oldPause}} -> + update asid [AvsSyncPause =. max pause oldPause, AvsSyncCreationTime =. now]) + (getBy $ UniqueAvsSyncUser uid) queueJob' JobSynchroniseAvsQueue dispatchJobSynchroniseAvsQueue :: JobHandler UniWorX From a407094253a7fe48be6184ac90c415ec52f88302 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 13 Jul 2023 16:09:12 +0000 Subject: [PATCH 14/19] chore(job): add filtering to job queue view --- .../utils/table_column/de-de-formal.msg | 3 +- messages/uniworx/utils/table_column/en-eu.msg | 3 +- src/Handler/Admin/Crontab.hs | 45 ++++++++++++++----- src/Utils/PathPiece.hs | 6 +++ 4 files changed, 44 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 18757a352..e95b4757e 100644 --- a/messages/uniworx/utils/table_column/de-de-formal.msg +++ b/messages/uniworx/utils/table_column/de-de-formal.msg @@ -79,4 +79,5 @@ TableCompanies: Firmen TableCompanyNos: Firmennummern TableSupervisor: Ansprechpartner TableCreationTime: Erstellungszeit -TableJobContent !ident-ok: Job +TableJob !ident-ok: Job +TableJobContent !ident-ok: Parameter diff --git a/messages/uniworx/utils/table_column/en-eu.msg b/messages/uniworx/utils/table_column/en-eu.msg index 1bfa7cdb7..682c66966 100644 --- a/messages/uniworx/utils/table_column/en-eu.msg +++ b/messages/uniworx/utils/table_column/en-eu.msg @@ -79,4 +79,5 @@ TableCompanies: Companies TableCompanyNos: Company numbers TableSupervisor: Supervisor TableCreationTime: Creation -TableJobContent: Job \ No newline at end of file +TableJob !ident-ok: Job +TableJobContent !ident-ok: Parameters \ No newline at end of file diff --git a/src/Handler/Admin/Crontab.hs b/src/Handler/Admin/Crontab.hs index e0232c3fe..18b14fbe6 100644 --- a/src/Handler/Admin/Crontab.hs +++ b/src/Handler/Admin/Crontab.hs @@ -14,8 +14,10 @@ import Import import Jobs import Handler.Utils -import qualified Data.Aeson.Encode.Pretty as Pretty -import Data.Aeson.Encode.Pretty (encodePrettyToTextBuilder') +-- import Data.Aeson (fromJSON) +-- import qualified Data.Aeson as Aeson +-- import qualified Data.Aeson.Types as Aeson +import qualified Data.Aeson.Encode.Pretty as Pretty -- import qualified Data.CaseInsensitive as CI import qualified Data.Text as Text @@ -28,7 +30,7 @@ import qualified Data.HashMap.Strict as HashMap import qualified Data.UUID as UUID import qualified Database.Esqueleto.Legacy as E --- import qualified Database.Esqueleto.Utils as E +import qualified Database.Esqueleto.Utils as E -- import Database.Esqueleto.Utils.TH @@ -97,8 +99,8 @@ getAdminCrontabR = do provideJson mCrontab' provideRep . return . Text.Builder.toLazyText $ doEnc mCrontab' where - doEnc :: _ => a -> _ - doEnc = encodePrettyToTextBuilder' Pretty.defConfig + doEnc :: ToJSON a => a -> _ + doEnc = Pretty.encodePrettyToTextBuilder' Pretty.defConfig { Pretty.confIndent = Pretty.Spaces 2 , Pretty.confCompare = comparing $ \t -> ( t `elem` ["instruction", "job", "notification"] , Text.splitOn "-" t @@ -119,16 +121,24 @@ postAdminJobsR = do dbtRowKey = (E.^. QueuedJobId) dbtProj = dbtProjId dbtColonnade = dbColonnade $ mconcat -- remove call to dbColonnade if table actions are added - [ sortable (Just "creation-time") (i18nCell MsgTableCreationTime) $ \(view $ resultJob . _entityVal -> QueuedJob{..}) -> dateTimeCell queuedJobCreationTime - , sortable (Just "content") (i18nCell MsgTableCreationTime) $ \(view $ resultJob . _entityVal -> QueuedJob{..}) -> stringCell $ show queuedJobContent + [ sortable (Just "job") (i18nCell MsgTableJob) $ \(view $ resultJob . _entityVal -> QueuedJob{..}) -> cellMaybe textCell $ getJobName queuedJobContent + , sortable (Just "creation-time") (i18nCell MsgTableCreationTime) $ \(view $ resultJob . _entityVal -> QueuedJob{..}) -> dateTimeCell queuedJobCreationTime + , sortable (Just "content") (i18nCell MsgTableJobContent) $ \(view $ resultJob . _entityVal -> QueuedJob{..}) -> cell [whamlet|#{doEnc queuedJobContent}|] & addCellClass ("json"::Text) ] dbtSorting = Map.fromList [ ("creation-time", SortColumnNullsInv (E.^. QueuedJobCreationTime)) + , ("job" , SortColumn (\v -> v E.^. QueuedJobContent E.->>. "job")) , ("content" , SortColumn (E.^. QueuedJobContent)) ] - dbtFilter = Map.empty - dbtFilterUI = const mempty - dbtStyle = def + dbtFilter = Map.fromList + [ + ("job", FilterColumn $ E.mkContainsFilter (\v -> v E.^. QueuedJobContent E.->>. "job")) + ] + dbtFilterUI = \mPrev -> mconcat + [ + prismAForm (singletonFilter "job" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableJob) + ] + dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } dbtParams = def dbtIdent :: Text dbtIdent = "queued-jobs" @@ -143,4 +153,17 @@ postAdminJobsR = do setTitleI MsgMenuAdminJobs [whamlet| ^{jobsTable} - |] \ No newline at end of file + |] + where + doEnc :: ToJSON a => a -> _ + doEnc = Pretty.encodePrettyToTextBuilder' Pretty.defConfig + { Pretty.confIndent = Pretty.Spaces 2 + , Pretty.confCompare = comparing $ \t -> ( t `elem` ["job", "notification"] + , Text.splitOn "-" t + ) + } + + getJobName :: Value -> Maybe Text + getJobName (Object o) + | Just (String s) <- HashMap.lookup "job" o = Just s -- $ kebabToCamel s + getJobName _ = Nothing \ No newline at end of file diff --git a/src/Utils/PathPiece.hs b/src/Utils/PathPiece.hs index 05f7f558a..45b5643e5 100644 --- a/src/Utils/PathPiece.hs +++ b/src/Utils/PathPiece.hs @@ -9,6 +9,7 @@ module Utils.PathPiece , splitCamel, dropCamel , camelToPathPiece, camelToPathPiece', camelToPathPiece'' , nameToPathPiece, nameToPathPiece' + , kebabToCamel , tuplePathPiece , pathPieceJSON, pathPieceJSONKey , pathPieceBinary @@ -237,6 +238,11 @@ nameToPathPiece' dropN = camelToPathPiece' dropN . repack . nameBase nameToPathPiece :: Textual t => Name -> t nameToPathPiece = nameToPathPiece' 0 +-- | convert kebab-case to CamelCase +kebabToCamel :: Text -> Text +-- kebabToCamel = Text.filter (not . Char.isSpace) . Text.toTitle . Text.replace "-" " " -- eliminates all space +kebabToCamel = mconcat . fmap Text.toTitle . Text.split ('-'==) -- preserves existing spaces + tuplePathPiece :: Int -> DecQ tuplePathPiece tupleDim = do From 681f16be93ebbea69a67cfadd2d94af89fa2233d Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 14 Jul 2023 11:15:59 +0000 Subject: [PATCH 15/19] chore(health): adjust health evalutation --- messages/uniworx/categories/health/de-de-formal.msg | 2 +- messages/uniworx/categories/health/en-eu.msg | 2 +- src/Application.hs | 6 +++--- src/Jobs.hs | 2 +- src/Model/Types/Health.hs | 13 +++++++------ 5 files changed, 13 insertions(+), 12 deletions(-) diff --git a/messages/uniworx/categories/health/de-de-formal.msg b/messages/uniworx/categories/health/de-de-formal.msg index 75aa473dd..2c8355493 100644 --- a/messages/uniworx/categories/health/de-de-formal.msg +++ b/messages/uniworx/categories/health/de-de-formal.msg @@ -9,7 +9,7 @@ HealthCheckLDAPAdmins: Anteil der Administrator:innen mit LDAP Authentifizierung HealthCheckSMTPConnect: SMTP-Server kann erreicht werden HealthCheckWidgetMemcached: Memcached-Server liefert Widgets korrekt aus HealthCheckActiveJobExecutors: Anteil der job-workers, die neue Befehle annehmen -HealthCheckDoesFlush: Zustandsprüfung läuft durch +HealthCheckDoesFlush: Abgearbeitete Jobs werden aufgeräumt InstanceIdentification: Instanz-Identifikation InstanceId: Instanz-Nummer ClusterId: Cluster-Nummer \ No newline at end of file diff --git a/messages/uniworx/categories/health/en-eu.msg b/messages/uniworx/categories/health/en-eu.msg index 948a7c4cc..4e24bd8bb 100644 --- a/messages/uniworx/categories/health/en-eu.msg +++ b/messages/uniworx/categories/health/en-eu.msg @@ -9,7 +9,7 @@ HealthCheckLDAPAdmins: Proportion of administrators with LDAP authentication tha HealthCheckSMTPConnect: SMTP server is reachable HealthCheckWidgetMemcached: Memcached server is serving widgets correctly HealthCheckActiveJobExecutors: Proportion of job workers accepting new jobs -HealthCheckDoesFlush: Health reports flushes +HealthCheckDoesFlush: Executed jobs are removed InstanceIdentification: Instance identification InstanceId: Instance id ClusterId: Cluster id diff --git a/src/Application.hs b/src/Application.hs index 6592a8342..90d344bfd 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -550,8 +550,8 @@ warpSettings foundation = defaultSettings & Set.filter (is _Just . (foundation ^. _appHealthCheckInterval)) atomically $ do results <- readTVar $ foundation ^. _appHealthReport - guard $ activeChecks == Set.map (classifyHealthReport . snd) results - guard . (== Min HealthSuccess) $ foldMap (Min . healthReportStatus . snd) results + guard $ activeChecks `Set.isSubsetOf` Set.map (classifyHealthReport . snd) results + guard . (/= Min HealthFailure) $ foldMap (Min . healthReportStatus . snd) results notifyReady | otherwise -> notifyReady @@ -679,7 +679,7 @@ appMain = runResourceT $ do interval <- mInterval let lastSuccess = maybeMonoid mResults & Set.filter (\(_, rep) -> classifyHealthReport rep == hc) - & Set.filter (\(_, rep) -> healthReportStatus rep >= HealthSuccess) + & Set.filter (\(_, rep) -> healthReportStatus rep > HealthFailure) & Set.mapMonotonic (view _1) & Set.lookupMax diff --git a/src/Jobs.hs b/src/Jobs.hs index c658668dc..0d5993ce7 100644 --- a/src/Jobs.hs +++ b/src/Jobs.hs @@ -593,7 +593,7 @@ handleJobs' wNum = C.mapM_ $ \jctl -> hoist delimitInternalState . withJobWorker newReport@(healthReportStatus -> newStatus) <- lift $ generateHealthReport kind $logInfoS logIdent [st|#{tshow kind}: #{toPathPiece newStatus}|] - unless (newStatus == HealthSuccess) $ do + unless (newStatus > HealthFailure) $ do $logErrorS logIdent [st|#{tshow kind}: #{tshow newReport}|] liftIO $ do diff --git a/src/Model/Types/Health.hs b/src/Model/Types/Health.hs index 36f4be750..64ad49b3a 100644 --- a/src/Model/Types/Health.hs +++ b/src/Model/Types/Health.hs @@ -67,10 +67,10 @@ classifyHealthReport :: HealthReport -> HealthCheck classifyHealthReport HealthMatchingClusterConfig{} = HealthCheckMatchingClusterConfig classifyHealthReport HealthLDAPAdmins{} = HealthCheckLDAPAdmins classifyHealthReport HealthHTTPReachable{} = HealthCheckHTTPReachable -classifyHealthReport HealthSMTPConnect{} = HealthCheckSMTPConnect -classifyHealthReport HealthWidgetMemcached{} = HealthCheckWidgetMemcached -classifyHealthReport HealthActiveJobExecutors{} = HealthCheckActiveJobExecutors -classifyHealthReport HealthDoesFlush{} = HealthCheckDoesFlush +classifyHealthReport HealthSMTPConnect{} = HealthCheckSMTPConnect +classifyHealthReport HealthWidgetMemcached{} = HealthCheckWidgetMemcached -- kein Neustart notwendig +classifyHealthReport HealthActiveJobExecutors{} = HealthCheckActiveJobExecutors +classifyHealthReport HealthDoesFlush{} = HealthCheckDoesFlush -- evtl. kein Neustart notwendig -- | `HealthReport` classified (`classifyHealthReport`) by badness -- @@ -111,7 +111,8 @@ healthReportStatus = \case HealthActiveJobExecutors Nothing -> HealthInactive HealthActiveJobExecutors (Just prop ) | prop > 0 -> HealthSuccess - HealthDoesFlush mProp - | maybe True (>= 2) mProp -> HealthFailure -- Looks buggy to me? + HealthDoesFlush Nothing -> HealthInactive + HealthDoesFlush (Just prop ) + | prop >= 2 -> HealthFailure | otherwise -> HealthSuccess _other -> HealthFailure From 2fc7ac610bd386b1e23dc2ee1ff590fa28812331 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 14 Jul 2023 12:32:26 +0000 Subject: [PATCH 16/19] chore(job): add more columns to queued job view --- .../utils/table_column/de-de-formal.msg | 3 +++ messages/uniworx/utils/table_column/en-eu.msg | 5 ++++- src/Handler/Admin/Crontab.hs | 18 ++++++++++++------ 3 files changed, 19 insertions(+), 7 deletions(-) diff --git a/messages/uniworx/utils/table_column/de-de-formal.msg b/messages/uniworx/utils/table_column/de-de-formal.msg index e95b4757e..5b03468c8 100644 --- a/messages/uniworx/utils/table_column/de-de-formal.msg +++ b/messages/uniworx/utils/table_column/de-de-formal.msg @@ -81,3 +81,6 @@ TableSupervisor: Ansprechpartner TableCreationTime: Erstellungszeit TableJob !ident-ok: Job TableJobContent !ident-ok: Parameter +TableJobLockTime: Bearbeitung seit +TableJobLockInstance: Bearbeiter +TableJobCreationInstance: Ersteller \ 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 682c66966..e27dfebdf 100644 --- a/messages/uniworx/utils/table_column/en-eu.msg +++ b/messages/uniworx/utils/table_column/en-eu.msg @@ -80,4 +80,7 @@ TableCompanyNos: Company numbers TableSupervisor: Supervisor TableCreationTime: Creation TableJob !ident-ok: Job -TableJobContent !ident-ok: Parameters \ No newline at end of file +TableJobContent !ident-ok: Parameters +TableJobLockTime: Lock time +TableJobLockInstance: Worker +TableJobCreationInstance: Creator \ No newline at end of file diff --git a/src/Handler/Admin/Crontab.hs b/src/Handler/Admin/Crontab.hs index 18b14fbe6..f309ab73f 100644 --- a/src/Handler/Admin/Crontab.hs +++ b/src/Handler/Admin/Crontab.hs @@ -121,14 +121,20 @@ postAdminJobsR = do dbtRowKey = (E.^. QueuedJobId) dbtProj = dbtProjId dbtColonnade = dbColonnade $ mconcat -- remove call to dbColonnade if table actions are added - [ sortable (Just "job") (i18nCell MsgTableJob) $ \(view $ resultJob . _entityVal -> QueuedJob{..}) -> cellMaybe textCell $ getJobName queuedJobContent - , sortable (Just "creation-time") (i18nCell MsgTableCreationTime) $ \(view $ resultJob . _entityVal -> QueuedJob{..}) -> dateTimeCell queuedJobCreationTime - , sortable (Just "content") (i18nCell MsgTableJobContent) $ \(view $ resultJob . _entityVal -> QueuedJob{..}) -> cell [whamlet|#{doEnc queuedJobContent}|] & addCellClass ("json"::Text) + [ sortable (Just "job") (i18nCell MsgTableJob) $ \(view $ resultJob . _entityVal -> QueuedJob{..}) -> cellMaybe textCell $ getJobName queuedJobContent + , sortable (Just "creation-time") (i18nCell MsgTableCreationTime) $ \(view $ resultJob . _entityVal -> QueuedJob{..}) -> dateTimeCell queuedJobCreationTime + , sortable (Just "content") (i18nCell MsgTableJobContent) $ \(view $ resultJob . _entityVal -> QueuedJob{..}) -> cell [whamlet|#{doEnc queuedJobContent}|] & addCellClass ("json"::Text) + , sortable (Just "lock-time") (i18nCell MsgTableJobLockTime) $ \(view $ resultJob . _entityVal -> QueuedJob{..}) -> cellMaybe dateTimeCell queuedJobLockTime + , sortable (Just "lock-instance") (i18nCell MsgTableJobLockInstance) $ \(view $ resultJob . _entityVal -> QueuedJob{..}) -> cellMaybe (stringCell . show) queuedJobLockInstance + , sortable (Just "creation-instance") (i18nCell MsgTableJobCreationInstance) $ \(view $ resultJob . _entityVal -> QueuedJob{..}) -> stringCell $ show queuedJobCreationInstance ] dbtSorting = Map.fromList - [ ("creation-time", SortColumnNullsInv (E.^. QueuedJobCreationTime)) - , ("job" , SortColumn (\v -> v E.^. QueuedJobContent E.->>. "job")) - , ("content" , SortColumn (E.^. QueuedJobContent)) + [ ("creation-time" , SortColumnNullsInv (E.^. QueuedJobCreationTime)) + , ("job" , SortColumn (\v -> v E.^. QueuedJobContent E.->>. "job")) + , ("content" , SortColumn (E.^. QueuedJobContent)) + , ("lock-time" , SortColumnNullsInv (E.^. QueuedJobLockTime)) + , ("lock-instance" , SortColumn (E.^. QueuedJobLockInstance)) + , ("creation-instance", SortColumn (E.^. QueuedJobCreationInstance)) ] dbtFilter = Map.fromList [ From 5b9a5545457dbe506d20f7362fb6e0d6bae4f7f4 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 14 Jul 2023 15:48:18 +0000 Subject: [PATCH 17/19] fix(job): fix #95 by implementing queued job deletion for admins --- .../utils/table_column/de-de-formal.msg | 4 +- messages/uniworx/utils/table_column/en-eu.msg | 4 +- src/Handler/Admin/Crontab.hs | 61 +++++++++++++++++-- src/Handler/LMS.hs | 1 - 4 files changed, 61 insertions(+), 9 deletions(-) diff --git a/messages/uniworx/utils/table_column/de-de-formal.msg b/messages/uniworx/utils/table_column/de-de-formal.msg index 5b03468c8..16d43de61 100644 --- a/messages/uniworx/utils/table_column/de-de-formal.msg +++ b/messages/uniworx/utils/table_column/de-de-formal.msg @@ -83,4 +83,6 @@ TableJob !ident-ok: Job TableJobContent !ident-ok: Parameter TableJobLockTime: Bearbeitung seit TableJobLockInstance: Bearbeiter -TableJobCreationInstance: Ersteller \ No newline at end of file +TableJobCreationInstance: Ersteller +ActJobDelete: Job entfernen +TableJobActDeleteFeedback n@Int m@Int: #{n}/#{m} Jobs entfernt \ 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 e27dfebdf..17fbfe79a 100644 --- a/messages/uniworx/utils/table_column/en-eu.msg +++ b/messages/uniworx/utils/table_column/en-eu.msg @@ -83,4 +83,6 @@ TableJob !ident-ok: Job TableJobContent !ident-ok: Parameters TableJobLockTime: Lock time TableJobLockInstance: Worker -TableJobCreationInstance: Creator \ No newline at end of file +TableJobCreationInstance: Creator +ActJobDelete: Delete job +TableJobActDeleteFeedback n@Int m@Int: #{n}/#{m} queued jobs deleted \ No newline at end of file diff --git a/src/Handler/Admin/Crontab.hs b/src/Handler/Admin/Crontab.hs index f309ab73f..42844d91d 100644 --- a/src/Handler/Admin/Crontab.hs +++ b/src/Handler/Admin/Crontab.hs @@ -23,12 +23,14 @@ import qualified Data.Aeson.Encode.Pretty as Pretty import qualified Data.Text as Text import qualified Data.Text.Lazy.Builder as Text.Builder +import qualified Data.Set as Set import qualified Data.Map as Map import qualified Data.HashSet as HashSet import qualified Data.HashMap.Strict as HashMap import qualified Data.UUID as UUID +import Database.Persist.Sql (deleteWhereCount) import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E -- import Database.Esqueleto.Utils.TH @@ -108,6 +110,19 @@ getAdminCrontabR = do } +data JobTableAction = ActJobDelete + deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) + +instance Universe JobTableAction +instance Finite JobTableAction +nullaryPathPiece ''JobTableAction $ camelToPathPiece' 1 +embedRenderMessage ''UniWorX ''JobTableAction id + +-- Not yet needed, since there is no additional data for now (also, postprocess did not type somehow) +-- data JobTableActionData = ActJobDeleteData +-- deriving (Eq, Ord, Read, Show, Generic) + + getAdminJobsR, postAdminJobsR :: Handler Html getAdminJobsR = postAdminJobsR postAdminJobsR = do @@ -117,11 +132,15 @@ postAdminJobsR = do resultJob :: Lens' (DBRow (Entity QueuedJob)) (Entity QueuedJob) resultJob = _dbrOutput + dbtIdent :: Text + dbtIdent = "queued-jobs" + dbtSQLQuery = return dbtRowKey = (E.^. QueuedJobId) dbtProj = dbtProjId - dbtColonnade = dbColonnade $ mconcat -- remove call to dbColonnade if table actions are added - [ sortable (Just "job") (i18nCell MsgTableJob) $ \(view $ resultJob . _entityVal -> QueuedJob{..}) -> cellMaybe textCell $ getJobName queuedJobContent + dbtColonnade = mconcat + [ dbSelect (applying _2) id (return . view (resultJob . _entityKey)) + , sortable (Just "job") (i18nCell MsgTableJob) $ \(view $ resultJob . _entityVal -> QueuedJob{..}) -> cellMaybe textCell $ getJobName queuedJobContent , sortable (Just "creation-time") (i18nCell MsgTableCreationTime) $ \(view $ resultJob . _entityVal -> QueuedJob{..}) -> dateTimeCell queuedJobCreationTime , sortable (Just "content") (i18nCell MsgTableJobContent) $ \(view $ resultJob . _entityVal -> QueuedJob{..}) -> cell [whamlet|#{doEnc queuedJobContent}|] & addCellClass ("json"::Text) , sortable (Just "lock-time") (i18nCell MsgTableJobLockTime) $ \(view $ resultJob . _entityVal -> QueuedJob{..}) -> cellMaybe dateTimeCell queuedJobLockTime @@ -145,15 +164,45 @@ postAdminJobsR = do prismAForm (singletonFilter "job" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableJob) ] dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } - dbtParams = def - dbtIdent :: Text - dbtIdent = "queued-jobs" + acts :: Map JobTableAction (AForm Handler JobTableAction) + acts = Map.singleton ActJobDelete $ pure ActJobDelete + dbtParams = DBParamsForm + { dbParamsFormAdditional = + renderAForm FormStandard + $ (, mempty) . First . Just + <$> multiActionA acts (fslI MsgTableAction) Nothing + , dbParamsFormMethod = POST + , dbParamsFormAction = Nothing -- Just $ SomeRoute currentRoute + , dbParamsFormAttrs = [] + , dbParamsFormSubmit = FormSubmit + , dbParamsFormEvaluate = liftHandler . runFormPost + , dbParamsFormResult = id + , dbParamsFormIdent = def + } dbtCsvEncode = noCsvEncode dbtCsvDecode = Nothing dbtExtraReps = [] + -- jobsDBTableValidator :: PSValidator (MForm Handler) (FormResult (First JobTableAction, DBFormResult QueuedJobId Bool (DBRow (Entity QueuedJob)))) jobsDBTableValidator = def & defaultSorting [SortDescBy "creation-time"] - ((), jobsTable) <- runDB $ dbTable jobsDBTableValidator jobsDBTable + -- postprocess :: FormResult (First JobTableAction, DBFormResult QueuedJobId Bool (DBRow (Entity QueuedJob))) + -- -> FormResult (JobTableAction, Set QueuedJobId) + postprocess inp = do + (First (Just act), jobMap) <- inp + let jobSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) jobMap + return (act, jobSet) + (jobActRes, jobsTable) <- runDB (over _1 postprocess <$> dbTable jobsDBTableValidator jobsDBTable) + + formResult jobActRes $ \case + (ActJobDelete, jobIds) -> do + let jobReq = length jobIds + rmvd <- fromIntegral <$> runDB (deleteWhereCount + [ QueuedJobLockTime ==. Nothing + , QueuedJobLockInstance ==. Nothing + , QueuedJobId <-. Set.toList jobIds + ]) + addMessageI (bool Success Warning $ rmvd < jobReq) (MsgTableJobActDeleteFeedback rmvd jobReq) + reloadKeepGetParams AdminJobsR siteLayoutMsg MsgMenuAdminJobs $ do setTitleI MsgMenuAdminJobs diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index 34d20300e..2c886be11 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -326,7 +326,6 @@ instance Finite LmsTableAction nullaryPathPiece ''LmsTableAction $ camelToPathPiece' 2 embedRenderMessage ''UniWorX ''LmsTableAction id --- Not yet needed, since there is no additional data for now: data LmsTableActionData = LmsActNotifyData | LmsActRenewNotifyData | LmsActRenewPinData -- no longer used From 9b77bfcdc0e685625126ce09d20481599b7d5af5 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 14 Jul 2023 19:35:01 +0000 Subject: [PATCH 18/19] chore(release): 27.4.14 --- CHANGELOG.md | 8 ++++++++ nix/docker/demo-version.json | 2 +- nix/docker/version.json | 2 +- package-lock.json | 2 +- package.json | 2 +- package.yaml | 2 +- 6 files changed, 13 insertions(+), 5 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 5b5eebd6c..6c994dfbb 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.14](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.13...v27.4.14) (2023-07-14) + + +### Bug Fixes + +* **avs:** eliminate call to undefined in Esqueleto.Internals ([240c6f8](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/240c6f81f81d1872317da01411fa67ec97e3b16d)) +* **job:** fix [#95](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/95) by implementing queued job deletion for admins ([5b9a554](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/5b9a5545457dbe506d20f7362fb6e0d6bae4f7f4)) + ## [27.4.13](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.12...v27.4.13) (2023-07-12) diff --git a/nix/docker/demo-version.json b/nix/docker/demo-version.json index fe44f31d2..82f0bdba7 100644 --- a/nix/docker/demo-version.json +++ b/nix/docker/demo-version.json @@ -1,3 +1,3 @@ { - "version": "27.4.13" + "version": "27.4.14" } diff --git a/nix/docker/version.json b/nix/docker/version.json index fe44f31d2..82f0bdba7 100644 --- a/nix/docker/version.json +++ b/nix/docker/version.json @@ -1,3 +1,3 @@ { - "version": "27.4.13" + "version": "27.4.14" } diff --git a/package-lock.json b/package-lock.json index 1573d51d9..e9fdffe9a 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.4.13", + "version": "27.4.14", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index 9905d5fcd..9f2805cf4 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.4.13", + "version": "27.4.14", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index 4ce8a77e3..cfe01b928 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 27.4.13 +version: 27.4.14 dependencies: - base - yesod From eb6d868a11f7bc7d159ad02c27768e752c4da8b9 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 17 Jul 2023 11:16:17 +0000 Subject: [PATCH 19/19] bumb version --- src/Handler/Admin/Crontab.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Handler/Admin/Crontab.hs b/src/Handler/Admin/Crontab.hs index 42844d91d..5cb000074 100644 --- a/src/Handler/Admin/Crontab.hs +++ b/src/Handler/Admin/Crontab.hs @@ -204,6 +204,7 @@ postAdminJobsR = do addMessageI (bool Success Warning $ rmvd < jobReq) (MsgTableJobActDeleteFeedback rmvd jobReq) reloadKeepGetParams AdminJobsR + siteLayoutMsg MsgMenuAdminJobs $ do setTitleI MsgMenuAdminJobs [whamlet|