From c7f4fa0e412d2b920a3819ffed5b79b8aeea2842 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Mon, 28 Sep 2020 10:51:51 +0200 Subject: [PATCH] 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 | 6 ++- messages/uniworx/de-de-formal.msg | 3 +- messages/uniworx/en-eu.msg | 3 +- src/Crypto/Hash/Instances.hs | 18 +++++---- src/Handler/Utils/Form.hs | 53 ++++++++++++++++++++----- src/Handler/Workflow/Definition/Form.hs | 4 +- src/Handler/Workflow/Definition/List.hs | 4 +- src/Jobs/Handler/Files.hs | 13 ++++-- 8 files changed, 76 insertions(+), 28 deletions(-) diff --git a/frontend/src/app.sass b/frontend/src/app.sass index af6dd77a6..6e079a6ec 100644 --- a/frontend/src/app.sass +++ b/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) diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index 34b721661..48bd13592 100644 --- a/messages/uniworx/de-de-formal.msg +++ b/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} diff --git a/messages/uniworx/en-eu.msg b/messages/uniworx/en-eu.msg index 840b1dabf..a45cc8ace 100644 --- a/messages/uniworx/en-eu.msg +++ b/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} diff --git a/src/Crypto/Hash/Instances.hs b/src/Crypto/Hash/Instances.hs index 349464132..c552b0500 100644 --- a/src/Crypto/Hash/Instances.hs +++ b/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 - fromPathPiece = readFromPathPiece + toPathPiece = decodeUtf8 . Base64.encodeUnpadded . convert + 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 - hashWithSalt s = (hashWithSalt s :: ByteString -> Int) . convert +instance Typeable hash => Hashable (Digest hash) where + 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))||] diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index d8a4a5295..37f42a4f3 100644 --- a/src/Handler/Utils/Form.hs +++ b/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 - { fieldIdent = Nothing - , fieldUnpackZips = FileFieldUserOption True False - , fieldMultiple = False - , fieldRestrictExtensions = Nothing - , fieldAdditionalFiles = Map.empty - , fieldMaxFileSize = Nothing - } +fileField = singleFileField $ return () + +singleFileField :: (MonadHandler m, HandlerSite m ~ UniWorX) => FileUploads -> Field m FileUploads +singleFileField prev = genericFileField $ do + permitted <- runConduit $ prev .| C.foldMap Set.singleton + return FileField + { 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 -