fix(workflows): ui improvements

BREAKING CHANGE: digests now json encode via base64

Also improve efficiency of marking workflow files as referenced

frontend/src/app.sass

@@ -1384,5 +1384,9 @@ a.breadcrumbs__home
 .multi-user-invitation-field__wrapper
   max-width: 25rem
 
-.json
+.json, .yaml
   white-space: pre-wrap
+  font-family: var(--font-monospace)
+
+pre, tt, code
+  font-family: var(--font-monospace)

messages/uniworx/de-de-formal.msg

@@ -626,6 +626,7 @@ CorrAutoSetCorrector: Korrekturen verteilen
 CorrDelete: Abgaben löschen
 NatField name@Text: #{name} muss eine natürliche Zahl sein!
 JSONFieldDecodeFailure aesonFailure@String: Konnte JSON nicht parsen: #{aesonFailure}
+YAMLFieldDecodeFailure yamlFailure@String: Konnte YAML nicht parsen: #{yamlFailure}
 SecretJSONFieldDecryptFailure: Konnte versteckte vertrauliche Daten nicht entschlüsseln
 
 SubmissionsAlreadyAssigned num@Int64: #{num} #{pluralDE num "Abgabe" "Abgaben"} waren bereits einem Korrektor zugeteilt und wurden nicht verändert:
@@ -1448,7 +1449,7 @@ BreadcrumbCourseSheetPersonalisedFiles: Vorlage für personalisierte Übungsblat
 BreadcrumbAdminCrontab: Crontab
 BreadcrumbAdminWorkflowDefinitionList: Workflow-Definitionen
 BreadcrumbAdminWorkflowDefinitionNew: Neue Workflow-Definition
-BreadcrumbAdminWorkflowDefinitionEdit renderedWorkflowScope'@Text wfdn@WorkflowDefinitionName: #{wfdn} (#{renderedWorkflowScope'}
+BreadcrumbAdminWorkflowDefinitionEdit renderedWorkflowScope'@Text wfdn@WorkflowDefinitionName: #{wfdn} (#{renderedWorkflowScope'})
 BreadcrumbAdminWorkflowDefinitionDelete: Löschen
 
 ExternalExamEdit coursen@CourseName examn@ExamName: Bearbeiten: #{coursen}, #{examn}

messages/uniworx/en-eu.msg

@@ -624,6 +624,7 @@ CorrAutoSetCorrector: Distribute corrections
 CorrDelete: Delete submissions
 NatField name: #{name} must be a natural number!
 JSONFieldDecodeFailure aesonFailure: Could not parse JSON: #{aesonFailure}
+YAMLFieldDecodeFailure yamlFailure: Could not parse YAML: #{yamlFailure}
 SecretJSONFieldDecryptFailure: Could not decrypt hidden data
 
 SubmissionsAlreadyAssigned num: #{num} #{pluralEN num "correction" "corrections"} were already assigned to a corrector and were left unchanged:
@@ -1448,7 +1449,7 @@ BreadcrumbCourseSheetPersonalisedFiles: Download template for personalised sheet
 BreadcrumbAdminCrontab: Crontab
 BreadcrumbAdminWorkflowDefinitionList: Workflow definitions
 BreadcrumbAdminWorkflowDefinitionNew: New workflow definition
-BreadcrumbAdminWorkflowDefinitionEdit renderedWorkflowScope' wfdn: #{wfdn} (#{renderedWorkflowScope'}
+BreadcrumbAdminWorkflowDefinitionEdit renderedWorkflowScope' wfdn: #{wfdn} (#{renderedWorkflowScope'})
 BreadcrumbAdminWorkflowDefinitionDelete: Delete
 
 ExternalExamEdit coursen examn: Edit: #{coursen}, #{examn}

src/Crypto/Hash/Instances.hs

@@ -5,7 +5,7 @@ module Crypto.Hash.Instances
 
 import ClassyPrelude
 
-import Crypto.Hash
+import Crypto.Hash hiding (hash)
 
 import Database.Persist
 import Database.Persist.Sql
@@ -24,6 +24,10 @@ import Instances.TH.Lift ()
 import Data.Binary
 import qualified Data.Binary.Put as Binary
 import qualified Data.Binary.Get as Binary
+
+import qualified Data.ByteString.Base64.URL as Base64
+
+import Type.Reflection (typeRep)
   
 
 instance HashAlgorithm hash => PersistField (Digest hash) where
@@ -36,14 +40,14 @@ instance HashAlgorithm hash => PersistFieldSql (Digest hash) where
   sqlType _ = SqlBlob
 
 instance HashAlgorithm hash => PathPiece (Digest hash) where
-  toPathPiece = showToPathPiece
+  toPathPiece = decodeUtf8 . Base64.encodeUnpadded . convert
-  fromPathPiece = readFromPathPiece
+  fromPathPiece = digestFromByteString <=< either (const Nothing) Just . Base64.decodeUnpadded . encodeUtf8
 
 instance HashAlgorithm hash => ToHttpApiData (Digest hash) where
-  toUrlPiece = tshow
+  toUrlPiece = toPathPiece
 
 instance HashAlgorithm hash => FromHttpApiData (Digest hash) where
-  parseUrlPiece = maybe (Left "Could not read Digest") Right . readMay
+  parseUrlPiece = maybe (Left "Could not read Digest") Right . fromPathPiece
 
 instance HashAlgorithm hash => ToJSON (Digest hash) where
   toJSON = Aeson.String . toUrlPiece
@@ -51,8 +55,8 @@ instance HashAlgorithm hash => ToJSON (Digest hash) where
 instance HashAlgorithm hash => FromJSON (Digest hash) where
   parseJSON = withText "Digest" $ either (fail . unpack) return . parseUrlPiece
 
-instance Hashable (Digest hash) where
+instance Typeable hash => Hashable (Digest hash) where
-  hashWithSalt s = (hashWithSalt s :: ByteString -> Int) . convert
+  hashWithSalt s h = s `hashWithSalt` hash (typeRep @hash) `hashWithSalt` hash @ByteString (convert h)
 
 instance HashAlgorithm hash => Lift (Digest hash) where
   liftTyped dgst = [||fromMaybe (error "Lifted digest has wrong length") $ digestFromByteString $$(liftTyped (convert dgst :: ByteString))||]

src/Handler/Utils/Form.hs

@@ -62,6 +62,10 @@ import qualified Data.ByteString.Base64.URL as Base64
 
 import Data.Aeson.Encode.Pretty (encodePrettyToTextBuilder)
 import qualified Data.Text.Lazy.Builder as Builder
+
+import qualified Data.Yaml as Yaml
+
+import Control.Monad.Catch.Pure (runCatch)
   
 {-# ANN module ("HLint: ignore Use const" :: String) #-}
 
@@ -1062,15 +1066,24 @@ fileFieldMultiple = genericFileField $ return FileField
   , fieldMaxFileSize = Nothing
   }
 
+
 fileField :: (MonadHandler m, HandlerSite m ~ UniWorX) => Field m FileUploads
-fileField = genericFileField $ return FileField
+fileField = singleFileField $ return ()
-  { fieldIdent = Nothing
+
-  , fieldUnpackZips = FileFieldUserOption True False
+singleFileField :: (MonadHandler m, HandlerSite m ~ UniWorX) => FileUploads -> Field m FileUploads
-  , fieldMultiple = False
+singleFileField prev = genericFileField $ do
-  , fieldRestrictExtensions = Nothing
+  permitted <- runConduit $ prev .| C.foldMap Set.singleton
-  , fieldAdditionalFiles = Map.empty
+  return FileField
-  , fieldMaxFileSize = Nothing
+    { fieldIdent = Nothing
-  }
+    , fieldUnpackZips = FileFieldUserOption True False
+    , fieldMultiple = False
+    , fieldRestrictExtensions = Nothing
+    , fieldAdditionalFiles = Map.fromList
+      [ (fileReferenceTitle, (fileReferenceContent, fileReferenceModified, FileFieldUserOption False True))
+      | FileReference{..} <- Set.toList permitted
+      ]
+    , fieldMaxFileSize = Nothing
+    }
 
 specificFileField :: UploadSpecificFile -> Field Handler FileUploads
 specificFileField UploadSpecificFile{..} = convertField (.| fixupFileTitles) id . genericFileField $ return FileField
@@ -1315,16 +1328,36 @@ jsonField fieldKind = Field{..}
        JsonFieldLarge -> liftWidget
          [whamlet|
            $newline never
-           <textarea id=#{theId} name=#{name} *{attrs} :isReq:required>
+           <textarea id=#{theId} name=#{name} *{attrs} :isReq:required .json>
              #{either fromStrict (Builder.toLazyText . encodePrettyToTextBuilder) val}
          |]
        _other -> liftWidget
          [whamlet|
            $newline never
-             <input id=#{theId} name=#{name} *{attrs} type=#{inputType} :isReq:required value=#{either fromStrict encodeToLazyText val}>
+             <input id=#{theId} name=#{name} *{attrs} type=#{inputType} :isReq:required value=#{either fromStrict encodeToLazyText val} .json>
          |]
     fieldEnctype = UrlEncoded
 
+yamlField :: ( ToJSON a, FromJSON a
+             , MonadHandler m
+             , RenderMessage (HandlerSite m) UniWorXMessage
+             , RenderMessage (HandlerSite m) FormMessage
+             )
+          => Field m a
+yamlField = Field{..}
+  where
+    fieldParse [encodeUtf8 -> v] [] = return . bimap (SomeMessage . MsgYAMLFieldDecodeFailure . displayException) Just . runCatch $ Yaml.decodeThrow v <|> Yaml.decodeThrow (urlDecode True v)
+    fieldParse [] [] = return $ Right Nothing
+    fieldParse _ _ = return . Left $ SomeMessage MsgValueRequired
+    fieldView theId name attrs val isReq = liftWidget
+      [whamlet|
+        $newline never
+        <textarea id=#{theId} name=#{name} *{attrs} :isReq:required .yaml>
+          #{either id (decodeUtf8 . Yaml.encode) val}
+      |]
+    fieldEnctype = UrlEncoded
+   
+
 boolField :: ( MonadHandler m
              , HandlerSite m ~ UniWorX
              )

src/Handler/Workflow/Definition/Form.hs

@@ -41,7 +41,7 @@ workflowDefinitionForm template = validateForm validateWorkflowDefinitionForm .
   <$> apopt (selectField optionsFinite) (fslI MsgWorkflowDefinitionScope) (wdfScope <$> template)
   <*> areq ciField (fslI MsgWorkflowDefinitionName) (wdfName <$> template)
   <*> descriptionsForm
-  <*> areq (jsonField JsonFieldLarge) (fslI MsgWorkflowDefinitionGraph) (wdfGraph <$> template)
+  <*> areq yamlField (fslI MsgWorkflowDefinitionGraph) (wdfGraph <$> template)
   <*> filesForm
   where
     descriptionsForm = Map.fromList <$> massInputAccumEditA descrAdd descrEdit (const Nothing) descrLayout ("workflow-definition-descriptions" :: Text) (fslI MsgWorkflowDefinitionDescriptions) False (Map.toList . wdfDescriptions <$> template)
@@ -78,7 +78,7 @@ workflowDefinitionForm template = validateForm validateWorkflowDefinitionForm .
             fileForm :: (Text -> Text) -> Maybe (FileIdent, FileReference) -> Form (FileIdent, FileReference)
             fileForm nudge fileTemplate csrf = do
               (fileIdentRes, fileIdentView) <- mpreq (isoField _Unwrapped ciField) (fslI MsgWorkflowDefinitionFileIdent & addName (nudge "ident")) (view _1 <$> fileTemplate)
-              (fileRes, fileView) <- mpreq fileField (fslI MsgWorkflowDefinitionFile & addName (nudge "file")) (views _2 yield <$> fileTemplate)
+              (fileRes, fileView) <- mpreq (singleFileField . fromMaybe (return ()) $ views _2 yield <$> fileTemplate) (fslI MsgWorkflowDefinitionFile & addName (nudge "file")) (views _2 yield <$> fileTemplate)
               fileRes' <- liftHandler . runDB $ case fileRes of
                 FormSuccess uploads -> maybe FormMissing FormSuccess <$> runConduit (transPipe liftHandler uploads .| C.head)
                 FormFailure errs -> return $ FormFailure errs

src/Handler/Workflow/Definition/List.hs

@@ -11,7 +11,7 @@ import Handler.Utils
 import qualified Database.Esqueleto as E
 import qualified Database.Esqueleto.Utils as E
 
-import Data.Aeson.Encode.Pretty (encodePrettyToTextBuilder)
+import qualified Data.Yaml as Yaml
 
 import qualified Data.CaseInsensitive as CI
 
@@ -92,7 +92,7 @@ postAdminWorkflowDefinitionListR = do
                     <code .json>
                       #{graph'}
                   |]
-                where graph' = encodePrettyToTextBuilder graph
+                where graph' = decodeUtf8 $ Yaml.encode graph
           dbtSorting = mconcat
             [ singletonMap "name" . SortColumn $ views queryWorkflowDefinition (E.^. WorkflowDefinitionName)
             , singletonMap "scope" . SortColumn . views queryWorkflowDefinition $ E.orderByEnum . (E.^. WorkflowDefinitionScope)

src/Jobs/Handler/Files.hs

@@ -40,6 +40,7 @@ import Control.Monad.Logger (askLoggerIO, runLoggingT)
 import System.Clock
 
 import qualified Data.Set as Set
+import qualified Data.Sequence as Seq
 
 import Jobs.Queue (YesodJobDB)
 
@@ -214,15 +215,12 @@ dispatchJobPruneUnreferencedFiles numIterations epoch iteration = JobHandlerAtom
 
       $logDebugS "PruneUnreferencedFiles" . tshow $ (minBoundDgst, maxBoundDgst)
 
-      workflowFiles <- runConduit $ workflowFileReferences .| C.foldMap Set.singleton
-
       E.insertSelectWithConflict
         (UniqueFileContentChunkUnreferenced $ error "insertSelectWithConflict inspected constraint")
         (E.from $ \fileContentChunk -> do
             E.where_ . E.not_ . E.subSelectOr . E.from $ \fileContentEntry -> do
               E.where_ $ fileContentEntry E.^. FileContentEntryChunkHash E.==. fileContentChunk E.^. FileContentChunkId
               return $ E.any E.exists (fileReferences $ fileContentEntry E.^. FileContentEntryHash)
-                 E.||. fileContentEntry E.^. FileContentEntryHash `E.in_` E.valList (Set.toList workflowFiles)
             E.where_ . chunkIdFilter $ fileContentChunk E.^. FileContentChunkHash
             return $ FileContentChunkUnreferenced E.<# (fileContentChunk E.^. FileContentChunkId) E.<&> E.val now
         )
@@ -234,9 +232,16 @@ dispatchJobPruneUnreferencedFiles numIterations epoch iteration = JobHandlerAtom
         E.where_ . E.subSelectOr . E.from $ \fileContentEntry -> do
           E.where_ $ fileContentEntry E.^. FileContentEntryChunkHash E.==. fileContentChunkUnreferenced E.^. FileContentChunkUnreferencedHash
           return $ E.any E.exists (fileReferences $ fileContentEntry E.^. FileContentEntryHash)
-             E.||. fileContentEntry E.^. FileContentEntryHash `E.in_` E.valList (Set.toList workflowFiles)
         E.where_ . chunkIdFilter $ E.subSelectForeign fileContentChunkUnreferenced FileContentChunkUnreferencedHash (E.^. FileContentChunkHash)
 
+      let unmarkWorkflowFiles (otoList -> fRefs) = E.delete . E.from $ \fileContentChunkUnreferenced -> do
+            E.where_ . E.subSelectOr . E.from $ \fileContentEntry -> do
+              E.where_ $ fileContentEntry E.^. FileContentEntryChunkHash E.==. fileContentChunkUnreferenced E.^. FileContentChunkUnreferencedHash
+              return $ fileContentEntry E.^. FileContentEntryHash `E.in_` E.valList fRefs 
+            E.where_ . chunkIdFilter $ E.subSelectForeign fileContentChunkUnreferenced FileContentChunkUnreferencedHash (E.^. FileContentChunkHash)
+          chunkSize = 100
+       in runConduit $ workflowFileReferences .| C.map Seq.singleton .| C.chunksOfE chunkSize .| C.mapM_ unmarkWorkflowFiles
+  
       let
         getEntryCandidates = E.selectSource . E.from $ \fileContentEntry -> do
           let unreferencedSince = E.subSelectMaybe . E.from $ \(fileContentEntry' `E.InnerJoin` fileContentChunkUnreferenced) -> do