chore: merge uni2work/master

CHANGELOG.md

@@ -156,6 +156,7 @@ All notable changes to this project will be documented in this file. See [standa
 
 
 ### Bug Fixes
+
 * **system-message:** add volatile cluster setting model default ([6655582](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/6655582ace098808bfcea90ca85fce2fe0024d2b))
 
 ## [25.29.2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v25.29.1...v25.29.2) (2022-04-21)

routes

@@ -282,4 +282,4 @@
 /swagger       SwaggerR              GET      !free
 /swagger.json  SwaggerJsonR          GET      !free
 
-!/*WellKnownFileName WellKnownR GET !free
+!/*WellKnownFileName WellKnownR GET !free

src/Application.hs

@@ -156,7 +156,6 @@ import Handler.ApiDocs
 import Handler.Swagger
 
 import ServantApi () -- YesodSubDispatch instances
-
 import Servant.API
 import Servant.Client
 import Network.HTTP.Client.TLS (mkManagerSettings)

src/Foundation/I18n.hs

@@ -142,6 +142,11 @@ ordinalEN (toMessage -> numStr) = case lastChar of
   where
     lastChar = last <$> fromNullable numStr
 
+notDE :: Bool -> Text
+notDE = bool "nicht" ""
+
+notEN :: Bool -> Text
+notEN = bool "not" ""
 
 {-  -- TODO: use this is message eventually
 -- Commonly used plurals 

src/Foundation/Navigation.hs

@@ -111,7 +111,7 @@ breadcrumb PrintSendR         = i18nCrumb MsgMenuPrintSend        $ Just PrintCe
 breadcrumb (PrintDownloadR _) = i18nCrumb MsgMenuPrintDownload    $ Just PrintCenterR           
 
 breadcrumb SchoolListR      = i18nCrumb MsgMenuSchoolList       $ Just AdminR
-breadcrumb (SchoolR ssh sRoute) = case sRoute of
+breadcrumb currentRoute@(SchoolR ssh sRoute) = case sRoute of
   SchoolEditR -> useRunDB . maybeT (i18nCrumb MsgBreadcrumbSchool $ Just SchoolListR) $ do
     School{..} <- MaybeT $ get ssh
     isAdmin <- lift $ hasReadAccessTo SchoolListR
@@ -2511,6 +2511,51 @@ pageActions PrintCenterR = return
     , navChildren = []
     }
   ]
+pageActions ApiDocsR = return
+  [ NavPageActionPrimary
+    { navLink = NavLink
+      { navLabel       = MsgMenuSwagger
+      , navRoute       = SwaggerR
+      , navAccess'     = NavAccessTrue
+      , navType        = NavTypeLink { navModal = False }
+      , navQuick'      = mempty
+      , navForceActive = False
+      }
+    , navChildren = []
+    }
+  ]
+pageActions (TopWorkflowWorkflowListR lState) = 
+  let lState' | lState == WorkflowWorkflowListActive = WorkflowWorkflowListArchive
+              | otherwise                            = WorkflowWorkflowListActive
+   in return
+      [ NavPageActionPrimary
+        { navLink = NavLink
+          { navLabel       = MsgMenuTopWorkflowWorkflowList lState'
+          , navRoute       = TopWorkflowWorkflowListR lState'
+          , navAccess'     = NavAccessTrue
+          , navType        = NavTypeLink { navModal = False }
+          , navQuick'      = mempty
+          , navForceActive = False
+          }
+        , navChildren = []
+        }
+      ]
+pageActions (SchoolR ssh (SchoolWorkflowInstanceR swiName (SWIWorkflowsR lState))) = 
+  let lState' | lState == WorkflowWorkflowListActive = WorkflowWorkflowListArchive
+              | otherwise                            = WorkflowWorkflowListActive
+   in return
+      [ NavPageActionPrimary
+        { navLink = NavLink
+          { navLabel       = MsgMenuWorkflowWorkflowList lState'
+          , navRoute       = SchoolR ssh . SchoolWorkflowInstanceR swiName $ SWIWorkflowsR lState'
+          , navAccess'     = NavAccessTrue
+          , navType        = NavTypeLink { navModal = False }
+          , navQuick'      = mempty
+          , navForceActive = False
+          }
+        , navChildren = []
+        }
+      ]
 pageActions _ = return []
 
 submissionList :: ( MonadIO m

src/Handler/Info.hs

@@ -42,6 +42,7 @@ getLegalR =
 -- | Allgemeine Informationen
 getInfoR :: Handler Html
 getInfoR = do
+  AppSettings{..} <- getsYesod appSettings'
   changelogEntries' <- runDB $ selectList [ ChangelogItemFirstSeenItem <-. universeF ] []
   let changelogEntries = Map.fromListWith Set.union
         [ (Down changelogItemFirstSeenFirstSeen, Set.singleton changelogItemFirstSeenItem)

src/Handler/SystemMessage.hs

@@ -19,6 +19,7 @@ import qualified Data.Text as Text (intercalate)
 
 import qualified Database.Esqueleto.Legacy as E
 
+
 invalidateVisibleSystemMessages :: (MonadHandler m, HandlerSite m ~ UniWorX) => m ()
 invalidateVisibleSystemMessages = memcachedByInvalidate AuthCacheVisibleSystemMessages $ Proxy @(Map SystemMessageId (Maybe UTCTime, Maybe UTCTime))
 
@@ -49,7 +50,6 @@ systemMessageVolatileClusterSettingsForm (fmap Set.toList -> mPrev) = wFormToAFo
     miLayout lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/massinput/systemMessage/volatileClusterSettings/layout")
   fmap Set.fromList <$> massInputAccumEditW miAdd miEdit miButtonAction miLayout ("system-message-volatile-cluster-settings" :: Text) (fslI MsgSystemMessageOnVolatileClusterSettings) False mPrev
 
-
 getMessageR, postMessageR :: CryptoUUIDSystemMessage -> Handler Html
 getMessageR = postMessageR
 postMessageR cID = do

src/Jobs/Handler/Files.hs

@@ -106,7 +106,6 @@ dispatchJobDetectMissingFiles = JobHandlerAtomicDeferrableWithFinalizer act fin
 
         let useRefSource refKind refSource = transPipe (lift . withReaderT projectBackend) (refSource .| C.filterM (\ref -> not <$> exists [FileContentEntryHash ==. ref])) .| C.mapM_ (insertRef refKind)
         useRefSource (nameToPathPiece ''Job) jobFileReferences
-          
       let allMissingDb :: Set Minio.Object
           allMissingDb = setOf (folded . folded . re minioFileReference) missingDb
           filterMissingDb :: forall m. Monad m

src/Model/Migration/Definitions.hs

@@ -101,9 +101,7 @@ data ManualMigration
   | Migration20210208StudyFeaturesRelevanceCachedUUIDs
   | Migration20210318CrontabSubmissionRatedNotification
   | Migration20210608SeparateTermActive
-    -- TODO: migration regarding authorship statements
-    --         - apply desired non-default modes for IfI
-    --         - set authorship statement texts for IfI
+  | Migration20220521WorkflowArchivation
   deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
   deriving anyclass (Universe, Finite)
 
@@ -1018,6 +1016,20 @@ customMigrations = mapF $ \case
         ALTER TABLE "term" DROP COLUMN "active";
       |]
 
+  Migration20220521WorkflowArchivation -> whenM (and2M (tableExists "workflow_workflow") $ not <$> columnExists "workflow_workflow" "archived") $ do
+    now <- liftIO getCurrentTime
+    -- mArchiveAfter <- lift $ view _appWorkflowWorkflowArchiveAfter
+    let mArchiveAfter = Just (5270400 :: NominalDiffTime)
+    [executeQQ| ALTER TABLE "workflow_workflow" ADD "archived" timestamp with time zone; |]
+    let getWorkflows = [queryQQ| SELECT "workflow_workflow"."id", "workflow_workflow"."state"->-1->'time', "workflow_workflow"."state"->-1->'to', "shared_workflow_graph"."graph" FROM "workflow_workflow" INNER JOIN "shared_workflow_graph" ON "workflow_workflow"."graph" = "shared_workflow_graph"."hash"; |]
+        migrateArchived [ fromPersistValue -> Right (wwId :: WorkflowWorkflowId), fmap Aeson.fromJSON . fromPersistValue -> Right (Aeson.Success wpTime), fmap Aeson.fromJSON . fromPersistValue -> Right (Aeson.Success wpTo), fromPersistValue -> Right (wGraph :: DBWorkflowGraph) ] = maybeT_ $ do
+          archiveAfter <- hoistMaybe mArchiveAfter
+          WGN{wgnFinal} <- hoistMaybe . Map.lookup wpTo $ wgNodes wGraph
+          let wwArchived = max now (archiveAfter `addUTCTime` wpTime) <$ wgnFinal
+          lift [executeQQ| UPDATE "workflow_workflow" SET "archived" = #{wwArchived} WHERE "id" = #{wwId}; |]
+        migrateArchived _ = return ()
+     in runConduit $ getWorkflows .| C.mapM_ migrateArchived
+
 
 tableExists :: MonadIO m => Text -> ReaderT SqlBackend m Bool
 tableExists table = do

src/Model/Types/Common.hs

@@ -62,4 +62,4 @@ type TermCandidateIncidence = UUID
 type SessionFileReference = Digest SHA3_256
 
 type QualificationName       = CI Text
-type QualificationShorthand  = CI Text
+type QualificationShorthand  = CI Text

src/Utils/Form.hs

@@ -76,6 +76,7 @@ import qualified Data.Binary as Binary
 import qualified Data.ByteString.Base64.URL as Base64 (encodeUnpadded)
 import qualified Data.ByteString as BS
 
+
 ------------
 -- Fields --
 ------------

templates/i18n/changelog/workflows-archivation.de-de-formal.hamlet

@@ -0,0 +1,11 @@
+$newline never
+
+$maybe archived <- appWorkflowWorkflowArchiveAfter
+  Workflows werden nun automatisch archiviert, sobald sie #
+  $if archived /= 0
+    seit #{tshow (nominalDiffTimeToSeconds archived / 86400)} Tagen #
+  abgeschlossen sind.
+$nothing
+  Workflows können nun archiviert werden.
+<br>
+Archivierte Workflows werden nicht mehr in der Liste laufender Workflows angezeigt, sondern sind über ein separates Archiv verfügbar.

templates/i18n/changelog/workflows-archivation.en-eu.hamlet

@@ -0,0 +1,13 @@
+$newline never
+
+$maybe archived <- appWorkflowWorkflowArchiveAfter
+  Workflows are now being archived automatically #
+  $if archived == 0
+    immediately #
+  $else
+    #{tshow (nominalDiffTimeToSeconds archived / 86400)} days #
+  after finalization.
+$nothing
+  Workflow may now be archived.
+<br>
+Archived workflows are not shown among the list of running workflows, but can instead be accessed via a separate archive list.

test/Database/Fill.hs

@@ -880,6 +880,21 @@ fillDb = do
     , systemMessageLastChanged = now
     , systemMessageLastUnhide = now
     }  
+  void $ insert SystemMessage
+    { systemMessageNewsOnly = False
+    , systemMessageFrom = Just now
+    , systemMessageTo = Nothing
+    , systemMessageOnVolatileClusterSettings = Set.singleton (ClusterVolatileWorkflowsEnabled, toJSON False)
+    , systemMessageAuthenticatedOnly = False
+    , systemMessageSeverity = Warning
+    , systemMessageManualPriority = Nothing
+    , systemMessageDefaultLanguage = "de"
+    , systemMessageContent = "Workflow-System zur Zeit deaktiviert (systemMessageOnVolatileClusterSettings-Test)"
+    , systemMessageSummary = Nothing
+    , systemMessageCreated = now
+    , systemMessageLastChanged = now
+    , systemMessageLastUnhide = now
+    }
   void $ insert SystemMessage
     { systemMessageNewsOnly = True
     , systemMessageFrom = Just now