fix(workflows): ui improvements
BREAKING CHANGE: digests now json encode via base64 Also improve efficiency of marking workflow files as referenced
This commit is contained in:
Gregor Kleen
parent
99f3fca6d0
commit
c7f4fa0e41
@ -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)
|
||||
|
||||
@ -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}
|
||||
|
||||
@ -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}
|
||||
|
||||
@ -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))||]
|
||||
|
||||
@ -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
|
||||
<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
|
||||
)
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user