diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index 1ee0b58ec..b21e7400c 100644 --- a/messages/uniworx/de-de-formal.msg +++ b/messages/uniworx/de-de-formal.msg @@ -2779,3 +2779,20 @@ WorkflowInstanceScopeKindTerm: Pro Semester WorkflowInstanceScopeKindSchool: Pro Institut WorkflowInstanceScopeKindTermSchool: Pro Institut & Semester WorkflowInstanceScopeKindCourse: Pro Veranstaltung +WorkflowDefinitionScope: Bereich +WorkflowDefinitionName: Name +WorkflowDefinitionDescriptions: Beschreibung +WorkflowDefinitionDescriptionsLanguageExists: Eine Beschreibung in dieser Sprache existiert bereits +WorkflowDefinitionDescriptionLanguage: Sprach-Code (RFC1766) +WorkflowDefinitionDescriptionTitle: Titel +WorkflowDefinitionDescription: Beschreibung +WorkflowDefinitionGraph: Spezifikation +WorkflowDefinitionKeyDoesNotExist renderedCryptoID@Text: Referenziert ID existiert nicht: #{renderedCryptoID} +WorkflowDefinitionFiles: Dateien +WorkflowDefinitionFileIdentDoesNotExist fileIdent@Text: Referenzierte Datei existiert nicht: #{fileIdent} +WorkflowDefinitionFileIdentExists: Eine Datei mit dieser ID existiert bereits +WorkflowDefinitionFileIdent: Dateireferenz +WorkflowDefinitionFile: Datei +WorkflowDefinitionCreated: Workflow-Definition angelegt +WorkflowDefinitionCollision: Es existiert bereits eine Workflow-Definition mit diesem Namen +WorkflowDefinitionNewTitle: Workflow-Definition anlegen \ No newline at end of file diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 4be16133b..a91210f10 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -60,6 +60,11 @@ import Handler.Utils.Form.MassInput import qualified Data.Binary as Binary import qualified Data.ByteString.Base64.URL as Base64 +import Data.Time.Clock.System (systemEpochDay) + +import Data.Aeson.Encode.Pretty (encodePrettyToTextBuilder) +import qualified Data.Text.Lazy.Builder as Builder + {-# ANN module ("HLint: ignore Use const" :: String) #-} @@ -1279,31 +1284,47 @@ utcTimeField = checkMMap (return . localTimeToUTC') utcToLocalTime localTimeFiel langField :: Bool -- ^ Only allow values from `appLanguages` -> Field Handler Lang -langField False = checkBool langCheck MsgInvalidLangFormat $ textField & addDatalist appLanguagesOpts +langField False = checkBool langCheck MsgInvalidLangFormat $ textField & addDatalist appLanguagesOpts & cfStrip where langCheck (T.splitOn "-" -> lParts) = all ((&&) <$> not . null <*> T.all Char.isAlpha) lParts && not (null lParts) langField True = selectField appLanguagesOpts +data JsonFieldKind + = JsonFieldNormal + | JsonFieldLarge + | JsonFieldHidden + deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) + deriving anyclass (Universe, Finite) + jsonField :: ( ToJSON a, FromJSON a , MonadHandler m , RenderMessage (HandlerSite m) UniWorXMessage , RenderMessage (HandlerSite m) FormMessage ) - => Bool {-^ Hidden? -} + => JsonFieldKind -> Field m a -jsonField hide = Field{..} +jsonField fieldKind = Field{..} where inputType :: Text - inputType - | hide = "hidden" - | otherwise = "text" + inputType = case fieldKind of + JsonFieldHidden -> "hidden" + _other -> "text" fieldParse [encodeUtf8 -> v] [] = return . bimap (SomeMessage . MsgJSONFieldDecodeFailure) Just $ eitherDecodeStrict' v <|> eitherDecodeStrict' (urlDecode True v) fieldParse [] [] = return $ Right Nothing fieldParse _ _ = return . Left $ SomeMessage MsgValueRequired - fieldView theId name attrs val isReq = liftWidget [whamlet| - - |] + fieldView theId name attrs val isReq = case fieldKind of + JsonFieldLarge -> liftWidget + [whamlet| + $newline never + + #{either fromStrict (Builder.toLazyText . encodePrettyToTextBuilder) val} + |] + _other -> liftWidget + [whamlet| + $newline never + + |] fieldEnctype = UrlEncoded boolField :: ( MonadHandler m diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index 0bba1059d..1e3f9fc36 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -889,8 +889,8 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db , fieldEnctype = UrlEncoded } - piPreviousPost <- lift . runInputPost $ iopt (jsonField True) (wIdent "pagination") - piPreviousGet <- lift . runInputGet $ iopt (jsonField True) (wIdent "pagination") + piPreviousPost <- lift . runInputPost $ iopt (jsonField JsonFieldHidden) (wIdent "pagination") + piPreviousGet <- lift . runInputGet $ iopt (jsonField JsonFieldHidden) (wIdent "pagination") let piPreviousRes = maybe FormMissing FormSuccess $ piPreviousPost <|> piPreviousGet $logDebugS "dbTable" [st|#{wIdent "pagination"}: #{tshow piPreviousRes}|] diff --git a/src/Handler/Workflow/Definition/Form.hs b/src/Handler/Workflow/Definition/Form.hs index f6176967c..8a3b7ce8e 100644 --- a/src/Handler/Workflow/Definition/Form.hs +++ b/src/Handler/Workflow/Definition/Form.hs @@ -1,22 +1,104 @@ module Handler.Workflow.Definition.Form - ( workflowDefinitionForm + ( WorkflowDefinitionForm(..), FileIdent + , workflowDefinitionForm ) where import Import import Handler.Utils +import qualified Data.List.NonEmpty as NonEmpty + +import qualified Data.Set as Set +import qualified Data.Map as Map +import Data.Map ((!)) + +import qualified Data.CryptoID as C + +import qualified Data.CaseInsensitive as CI + +import qualified Data.Conduit.Combinators as C + + +newtype FileIdent = FileIdent (CI Text) + deriving (Eq, Ord, Read, Show, Generic, Typeable) + deriving newtype (ToMessage, ToJSON, FromJSON) + +makeWrapped ''FileIdent + data WorkflowDefinitionForm = WorkflowDefinitionForm { wdfScope :: WorkflowInstanceScope' , wdfName :: CI Text , wdfDescriptions :: Map Lang (Text, Maybe Html) - , wdfGraph :: WorkflowGraph CryptoUUIDFile CryptoUUIDUser + , wdfGraph :: WorkflowGraph FileIdent CryptoUUIDUser + , wdfFiles :: Map FileIdent FileId } deriving (Generic, Typeable) -workflowDefinitionForm :: Html -> MForm DB (FormResult WorkflowDefinitionForm, Widget) -workflowDefinitionForm = validateForm validateWorkflowDefinitionForm . renderAForm FormStandard $ - error "not implemented" +makeLenses_ ''WorkflowDefinitionForm +workflowDefinitionForm :: Maybe WorkflowDefinitionForm -> Html -> MForm DB (FormResult WorkflowDefinitionForm, Widget) +workflowDefinitionForm template = validateForm validateWorkflowDefinitionForm . (hoist lift .) . renderAForm FormStandard $ WorkflowDefinitionForm + <$> apopt (selectField optionsFinite) (fslI MsgWorkflowDefinitionScope) (wdfScope <$> template) + <*> areq ciField (fslI MsgWorkflowDefinitionName) (wdfName <$> template) + <*> descriptionsForm + <*> areq (jsonField JsonFieldLarge) (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) + where descrAdd nudge submitView csrf = do + (formRes, formView) <- descrForm nudge Nothing csrf + MsgRenderer mr <- getMsgRenderer + let res' = formRes <&> \newDescr@(newLang, _) oldDescrs -> if + | any (\(oldLang, _) -> newLang == oldLang) oldDescrs + -> FormFailure [mr MsgWorkflowDefinitionDescriptionsLanguageExists] + | otherwise + -> FormSuccess $ pure newDescr + return (res', $(widgetFile "widgets/massinput/workflowDefinitionDescriptions/add")) + descrEdit nudge = descrForm nudge . Just + descrForm :: (Text -> Text) -> Maybe (Lang, (Text, Maybe Html)) -> Form (Lang, (Text, Maybe Html)) + descrForm nudge descrTemplate csrf = do + (langRes, langView) <- mpreq (langField False) (fslI MsgWorkflowDefinitionDescriptionLanguage & addName (nudge "lang")) (fmap (view _1) descrTemplate <|> Just (NonEmpty.head appLanguages)) + (titleRes, titleView) <- mpreq textField (fslI MsgWorkflowDefinitionDescriptionTitle & addName (nudge "title")) (view (_2 . _1) <$> descrTemplate) + (descrRes, descrView) <- mopt htmlField (fslI MsgWorkflowDefinitionDescription & addName (nudge "descr")) (view (_2 . _2) <$> descrTemplate) + return ((,) <$> langRes <*> ((,) <$> titleRes <*> descrRes), $(widgetFile "widgets/massinput/workflowDefinitionDescriptions/form")) + descrLayout :: MassInputLayout ListLength (Lang, (Text, Maybe Html)) (Lang, (Text, Maybe Html)) + descrLayout lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/massinput/workflowDefinitionDescriptions/layout") + + filesForm = Map.fromList <$> massInputAccumEditA fileAdd fileEdit (const Nothing) fileLayout ("workflow-definition-files" :: Text) (fslI MsgWorkflowDefinitionFiles) False (Map.toList . wdfFiles <$> template) + where fileAdd nudge submitView csrf = do + (formRes, formView) <- fileForm nudge Nothing csrf + MsgRenderer mr <- getMsgRenderer + let res' = formRes <&> \newFile@(newFileIdent, _) oldFiles -> if + | any (\(oldFileIdent, _) -> newFileIdent == oldFileIdent) oldFiles + -> FormFailure [mr MsgWorkflowDefinitionFileIdentExists] + | otherwise + -> FormSuccess $ pure newFile + return (res', $(widgetFile "widgets/massinput/workflowDefinitionFiles/add")) + fileEdit nudge = fileForm nudge . Just + fileForm :: (Text -> Text) -> Maybe (FileIdent, FileId) -> Form (FileIdent, FileId) + 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 . Left) <$> fileTemplate) + fileRes' <- liftHandler . runDB $ case fileRes of + FormSuccess uploads -> maybe FormMissing FormSuccess <$> runConduit (transPipe liftHandler uploads .| C.mapM (either return insert) .| C.head) + FormFailure errs -> return $ FormFailure errs + FormMissing -> return FormMissing + return ((,) <$> fileIdentRes <*> fileRes', $(widgetFile "widgets/massinput/workflowDefinitionFiles/form")) + fileLayout :: MassInputLayout ListLength (FileIdent, FileId) (FileIdent, FileId) + fileLayout lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/massinput/workflowDefinitionFiles/layout") + + validateWorkflowDefinitionForm :: FormValidator WorkflowDefinitionForm DB () -validateWorkflowDefinitionForm = error "not implemented" +validateWorkflowDefinitionForm = do + join . uses _wdfGraph . mapMOf_ (typesUsing @WorkflowChildren @CryptoUUIDUser) . ensureExists $ Proxy @User + fIdentsReferenced <- uses _wdfGraph . setOf $ typesUsing @WorkflowChildren @FileIdent + fIdentsAvailable <- uses _wdfFiles Map.keysSet + forM_ (fIdentsReferenced `Set.difference` fIdentsAvailable) $ tellValidationError . MsgWorkflowDefinitionFileIdentDoesNotExist . views _Wrapped CI.original + where + ensureExists :: forall record ns p r. _ => p record -> C.CryptoID ns UUID -> FormValidator r DB () + ensureExists _ cID = maybeT (tellValidationError . MsgWorkflowDefinitionFileIdentDoesNotExist $ toPathPiece cID) . catchMPlus (Proxy @CryptoIDError) $ do + $logDebugS "validateWorkflowDefinitionForm" $ "Checking key for existence: " <> toPathPiece cID + key <- decrypt cID + guardM . lift . lift $ existsKey (key :: Key record) + diff --git a/src/Handler/Workflow/Definition/New.hs b/src/Handler/Workflow/Definition/New.hs index e99501824..a035c88c6 100644 --- a/src/Handler/Workflow/Definition/New.hs +++ b/src/Handler/Workflow/Definition/New.hs @@ -3,7 +3,54 @@ module Handler.Workflow.Definition.New ) where import Import +import Handler.Utils +import Handler.Workflow.Definition.Form + +import Data.Map.Strict ((!)) + getAdminWorkflowDefinitionNewR, postAdminWorkflowDefinitionNewR :: Handler Html getAdminWorkflowDefinitionNewR = postAdminWorkflowDefinitionNewR -postAdminWorkflowDefinitionNewR = error "not implemented" +postAdminWorkflowDefinitionNewR = do + (((_, newForm), newEncoding), act) <- runDB $ do + form@((newRes, _), _) <- runFormPost $ workflowDefinitionForm Nothing + + act <- formResultMaybe newRes $ \WorkflowDefinitionForm{..} -> do + wdfGraph' <- wdfGraph + & over (typesCustom @WorkflowChildren :: Traversal (WorkflowGraph FileIdent CryptoUUIDUser) (WorkflowGraph SqlBackendKey CryptoUUIDUser) FileIdent SqlBackendKey) (view _SqlKey . (wdfFiles !)) + & (typesCustom @WorkflowChildren :: Traversal (WorkflowGraph SqlBackendKey CryptoUUIDUser) (WorkflowGraph SqlBackendKey SqlBackendKey) CryptoUUIDUser SqlBackendKey) (fmap (view _SqlKey :: UserId -> SqlBackendKey) . decrypt) + + insRes <- insertUnique WorkflowDefinition + { workflowDefinitionGraph = wdfGraph' + , workflowDefinitionScope = wdfScope + , workflowDefinitionName = wdfName + } + + for_ insRes $ \wdId -> iforM_ wdfDescriptions $ \wddLang (wddTitle, wddDesc) -> + insert WorkflowDefinitionDescription + { workflowDefinitionDescriptionDefinition = wdId + , workflowDefinitionDescriptionLanguage = wddLang + , workflowDefinitionDescriptionTitle = wddTitle + , workflowDefinitionDescriptionDescription = wddDesc + } + + case insRes of + Just _ -> return . Just $ do + addMessageI Success MsgWorkflowDefinitionCreated + redirect AdminWorkflowDefinitionListR + Nothing -> return . Just $ + addMessageI Error MsgWorkflowDefinitionCollision + + return (form, act) + + forM_ act id + + let newWidget = wrapForm newForm def + { formAction = Just $ SomeRoute AdminWorkflowDefinitionNewR + , formEncoding = newEncoding + } + + siteLayoutMsg MsgWorkflowDefinitionNewTitle $ do + setTitleI MsgWorkflowDefinitionNewTitle + + newWidget diff --git a/src/Model/Types/Security.hs b/src/Model/Types/Security.hs index 7f6c5b617..da48fbf8c 100644 --- a/src/Model/Types/Security.hs +++ b/src/Model/Types/Security.hs @@ -90,7 +90,7 @@ data AuthTag -- sortiert nach gewünschter Reihenfolge auf /authpreds, d.h. Prä | AuthDevelopment | AuthFree deriving (Eq, Ord, Enum, Bounded, Read, Show, Data, Generic, Typeable) - deriving anyclass (Universe, Finite, Hashable, Binary) + deriving anyclass (Universe, Finite, Hashable) nullaryPathPiece ''AuthTag $ camelToPathPiece' 1 pathPieceJSON ''AuthTag diff --git a/src/Model/Types/Workflow.hs b/src/Model/Types/Workflow.hs index f95d59d8d..51444b3d6 100644 --- a/src/Model/Types/Workflow.hs +++ b/src/Model/Types/Workflow.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE UndecidableInstances #-} + module Model.Types.Workflow ( WorkflowGraph(..) , WorkflowGraphNodeLabel @@ -5,6 +7,7 @@ module Model.Types.Workflow , WorkflowInstanceScope'(..) , WorkflowState , WorkflowAction(..) + , WorkflowChildren ) where import Import.NoModel @@ -22,8 +25,13 @@ import qualified Data.Aeson.Types as JSON import Data.Aeson.Lens (_Null) import Data.Aeson.Types (Parser) +import qualified Data.Set as Set +import qualified Data.CaseInsensitive as CI + import Type.Reflection (eqTypeRep, typeOf, (:~~:)(..)) +import Data.Generics.Product.Types + ----- WORKFLOW GRAPH ----- @@ -243,10 +251,72 @@ data WorkflowFieldPayload'' = WFPText' | WFPNumber' | WFPBool' | WFPFile' | WFPU ----- PathPiece instances ----- -nullaryPathPiece ''WorkflowInstanceScope' $ camelToPathPiece' 1 +nullaryPathPiece ''WorkflowInstanceScope' $ camelToPathPiece' 1 . fromJust . stripSuffix "'" nullaryPathPiece ''WorkflowFieldPayload'' $ camelToPathPiece' 1 . fromJust . stripSuffix "'" +----- Generic traversal ----- + +type family Concat as bs where + Concat '[] bs = bs + Concat as '[] = as + Concat (a ': as) bs = a ': Concat as bs + +data WorkflowChildren +type instance Children WorkflowChildren a = ChildrenWorkflowChildren a +type family ChildrenWorkflowChildren a where + ChildrenWorkflowChildren (Map k v) = '[v] + ChildrenWorkflowChildren (Set a) = '[a] + ChildrenWorkflowChildren (NonNull mono) = '[Element mono] + ChildrenWorkflowChildren (CI a) = '[a] + ChildrenWorkflowChildren UUID = '[] + ChildrenWorkflowChildren Html = '[] + ChildrenWorkflowChildren Scientific = '[] + ChildrenWorkflowChildren (BackendKey SqlBackend) = '[] + ChildrenWorkflowChildren (Key record) = '[] + ChildrenWorkflowChildren (WorkflowPayloadSpec fileid userid) + = ChildrenWorkflowChildren I18nText + `Concat` ChildrenWorkflowChildren (Maybe I18nText) + `Concat` ChildrenWorkflowChildren (Maybe I18nHtml) + `Concat` ChildrenWorkflowChildren (Maybe Text) + `Concat` ChildrenWorkflowChildren (Maybe Scientific) + `Concat` ChildrenWorkflowChildren (Maybe Bool) + `Concat` ChildrenWorkflowChildren (Maybe fileid) + `Concat` ChildrenWorkflowChildren (Maybe userid) + `Concat` ChildrenWorkflowChildren Bool + `Concat` ChildrenWorkflowChildren WorkflowPayloadLabel + ChildrenWorkflowChildren a = Children ChGeneric a + +instance HasTypesCustom WorkflowChildren v v' a a' => HasTypesCustom WorkflowChildren (Map k v) (Map k v') a a' where + typesCustom = traverse . typesCustom @WorkflowChildren + +instance (Ord b', HasTypesCustom WorkflowChildren a' b' a b) => HasTypesCustom WorkflowChildren (Set a') (Set b') a b where + typesCustom = iso Set.toList Set.fromList . traverse . typesCustom @WorkflowChildren + +instance (HasTypesCustom WorkflowChildren mono mono' a a', MonoFoldable mono') => HasTypesCustom WorkflowChildren (NonNull mono) (NonNull mono') a a' where + typesCustom = iso toNullable impureNonNull . typesCustom @WorkflowChildren + +instance (HasTypesCustom WorkflowChildren a' b' a b, FoldCase b') => HasTypesCustom WorkflowChildren (CI a') (CI b') a b where + typesCustom = iso CI.original CI.mk . typesCustom @WorkflowChildren + +instance (Typeable userid, Typeable fileid') => HasTypesCustom WorkflowChildren (WorkflowPayloadSpec fileid userid) (WorkflowPayloadSpec fileid' userid) fileid fileid' where + typesCustom f (WorkflowPayloadSpec WorkflowPayloadFieldFile{ wpffDefault = Just fid, .. }) = f fid <&> \fid' -> WorkflowPayloadSpec WorkflowPayloadFieldFile{ wpffDefault = Just fid', .. } + typesCustom _ (WorkflowPayloadSpec WorkflowPayloadFieldFile{ wpffDefault = Nothing, .. }) = pure $ WorkflowPayloadSpec WorkflowPayloadFieldFile{ wpffDefault = Nothing, ..} + typesCustom _ (WorkflowPayloadSpec WorkflowPayloadFieldText{..}) = pure $ WorkflowPayloadSpec WorkflowPayloadFieldText{..} + typesCustom _ (WorkflowPayloadSpec WorkflowPayloadFieldNumber{..}) = pure $ WorkflowPayloadSpec WorkflowPayloadFieldNumber{..} + typesCustom _ (WorkflowPayloadSpec WorkflowPayloadFieldBool{..}) = pure $ WorkflowPayloadSpec WorkflowPayloadFieldBool{..} + typesCustom _ (WorkflowPayloadSpec WorkflowPayloadFieldUser{..}) = pure $ WorkflowPayloadSpec WorkflowPayloadFieldUser{..} + typesCustom _ (WorkflowPayloadSpec WorkflowPayloadFieldReference{..}) = pure $ WorkflowPayloadSpec WorkflowPayloadFieldReference{..} + +instance (Typeable userid', Typeable fileid) => HasTypesCustom WorkflowChildren (WorkflowPayloadSpec fileid userid) (WorkflowPayloadSpec fileid userid') userid userid' where + typesCustom f (WorkflowPayloadSpec WorkflowPayloadFieldUser{ wpfuDefault = Just fid, .. }) = f fid <&> \fid' -> WorkflowPayloadSpec WorkflowPayloadFieldUser{ wpfuDefault = Just fid', .. } + typesCustom _ (WorkflowPayloadSpec WorkflowPayloadFieldUser{ wpfuDefault = Nothing, ..}) = pure $ WorkflowPayloadSpec WorkflowPayloadFieldUser{ wpfuDefault = Nothing, ..} + typesCustom _ (WorkflowPayloadSpec WorkflowPayloadFieldText{..}) = pure $ WorkflowPayloadSpec WorkflowPayloadFieldText{..} + typesCustom _ (WorkflowPayloadSpec WorkflowPayloadFieldNumber{..}) = pure $ WorkflowPayloadSpec WorkflowPayloadFieldNumber{..} + typesCustom _ (WorkflowPayloadSpec WorkflowPayloadFieldBool{..}) = pure $ WorkflowPayloadSpec WorkflowPayloadFieldBool{..} + typesCustom _ (WorkflowPayloadSpec WorkflowPayloadFieldFile{..}) = pure $ WorkflowPayloadSpec WorkflowPayloadFieldFile{..} + typesCustom _ (WorkflowPayloadSpec WorkflowPayloadFieldReference{..}) = pure $ WorkflowPayloadSpec WorkflowPayloadFieldReference{..} + ----- ToJSON / FromJSON instances ----- omitNothing :: [JSON.Pair] -> [JSON.Pair] @@ -258,6 +328,7 @@ deriveJSON defaultOptions } ''WorkflowRole deriveToJSON workflowPayloadViewAesonOptions ''WorkflowPayloadView +pathPieceJSON ''WorkflowFieldPayload'' instance (FromJSON userid, Ord userid) => FromJSON (WorkflowPayloadView userid) where parseJSON = genericParseJSON workflowPayloadViewAesonOptions @@ -395,45 +466,44 @@ instance ( FromJSON fileid, FromJSON userid instance (ToJSON fileid, ToJSON userid) => ToJSON (WorkflowFieldPayloadW fileid userid) where toJSON (WorkflowFieldPayloadW (WFPText t)) = JSON.object - [ "tag" JSON..= ("text" :: Text) - , "text" JSON..= t + [ "tag" JSON..= WFPText' + , toPathPiece WFPText' JSON..= t ] toJSON (WorkflowFieldPayloadW (WFPNumber n)) = JSON.object - [ "tag" JSON..= ("number" :: Text) - , "number" JSON..= n + [ "tag" JSON..= WFPNumber' + , toPathPiece WFPNumber' JSON..= n ] toJSON (WorkflowFieldPayloadW (WFPBool b)) = JSON.object - [ "tag" JSON..= ("bool" :: Text) - , "bool" JSON..= b + [ "tag" JSON..= WFPBool' + , toPathPiece WFPBool' JSON..= b ] toJSON (WorkflowFieldPayloadW (WFPFile fid)) = JSON.object - [ "tag" JSON..= ("file" :: Text) - , "file" JSON..= fid + [ "tag" JSON..= WFPFile' + , toPathPiece WFPFile' JSON..= fid ] toJSON (WorkflowFieldPayloadW (WFPUser uid)) = JSON.object - [ "tag" JSON..= ("user" :: Text) - , "user" JSON..= uid + [ "tag" JSON..= WFPUser' + , toPathPiece WFPUser' JSON..= uid ] instance (FromJSON fileid, FromJSON userid, Typeable fileid, Typeable userid) => FromJSON (WorkflowFieldPayloadW fileid userid) where parseJSON = JSON.withObject "WorkflowFieldPayloadW" $ \o -> do - fieldTag <- (o JSON..: "tag" :: Parser Text) + fieldTag <- o JSON..: "tag" case fieldTag of - "text" -> do - t <- o JSON..: "text" + WFPText' -> do + t <- o JSON..: toPathPiece WFPText' return $ WorkflowFieldPayloadW $ WFPText t - "number" -> do - n <- o JSON..: "number" + WFPNumber' -> do + n <- o JSON..: toPathPiece WFPNumber' return $ WorkflowFieldPayloadW $ WFPNumber n - "bool" -> do - b <- o JSON..: "bool" + WFPBool' -> do + b <- o JSON..: toPathPiece WFPBool' return $ WorkflowFieldPayloadW $ WFPBool b - "file" -> do - fid <- o JSON..: "file" + WFPFile' -> do + fid <- o JSON..: toPathPiece WFPFile' return $ WorkflowFieldPayloadW $ WFPFile fid - "user" -> do - uid <- o JSON..: "user" + WFPUser' -> do + uid <- o JSON..: toPathPiece WFPUser' return $ WorkflowFieldPayloadW $ WFPUser uid - _ -> terror $ "WorkflowFieldPayloadW parseJSON error: expected field tag (text|number|bool|file|user), but got " <> fieldTag diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 307bd6fad..069f3263d 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -33,6 +33,7 @@ import Control.Monad.Trans.Except (ExceptT, runExceptT) import Control.Monad.Fix (MonadFix) import Control.Monad.Morph (MFunctor(..)) import Control.Monad.Base +import Control.Monad.Catch (MonadCatch) import Data.List ((!!)) @@ -1072,6 +1073,7 @@ deriving newtype instance Monad m => MonadState r (FormValidator r m) deriving newtype instance MonadFix m => MonadFix (FormValidator r m) deriving newtype instance MonadResource m => MonadResource (FormValidator r m) deriving newtype instance MonadThrow m => MonadThrow (FormValidator r m) +deriving newtype instance MonadCatch m => MonadCatch (FormValidator r m) deriving newtype instance MonadIO m => MonadIO (FormValidator r m) deriving newtype instance MonadLogger m => MonadLogger (FormValidator r m) instance MonadBase b m => MonadBase b (FormValidator r m) where diff --git a/stack.yaml.lock b/stack.yaml.lock index 053ebc2d9..04c6067bc 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -96,17 +96,6 @@ packages: subdir: serversession-backend-acid-state git: git@gitlab2.rz.ifi.lmu.de:uni2work/serversession.git commit: 1c95b0100471279413485411032d639881012a5e -- completed: - name: xss-sanitize - version: 0.3.6 - git: git@gitlab2.rz.ifi.lmu.de:uni2work/xss-sanitize.git - pantry-tree: - size: 691 - sha256: 7cada516aa3cad4adc214f5eb90dd07c3a8ecabdc5551f761366fc270ae2e086 - commit: 074ed7c8810aca81f60f2c535f9e7bad67e9d95a - original: - git: git@gitlab2.rz.ifi.lmu.de:uni2work/xss-sanitize.git - commit: 074ed7c8810aca81f60f2c535f9e7bad67e9d95a - completed: subdir: colonnade name: colonnade @@ -131,71 +120,6 @@ packages: original: git: git@gitlab2.rz.ifi.lmu.de:uni2work/minio-hs.git commit: 42103ab247057c04c8ce7a83d9d4c160713a3df1 -- completed: - subdir: cryptoids-class - name: cryptoids-class - version: 0.0.0 - git: git@gitlab2.rz.ifi.lmu.de:uni2work/cryptoids.git - pantry-tree: - size: 350 - sha256: f014c9ff9666a4d4bab82dd2b3092fd2004b40ebf2bcd32cf7d90035e08ce75b - commit: 4d91394475b144ea5bf7ba111f93756cc0de8a3f - original: - subdir: cryptoids-class - git: git@gitlab2.rz.ifi.lmu.de:uni2work/cryptoids.git - commit: 4d91394475b144ea5bf7ba111f93756cc0de8a3f -- completed: - subdir: cryptoids-types - name: cryptoids-types - version: 1.0.0 - git: git@gitlab2.rz.ifi.lmu.de:uni2work/cryptoids.git - pantry-tree: - size: 258 - sha256: d1465d25a1a1807d5a88d9a09085fd4a2f49f2e57b8398496691ffad30e8f88c - commit: 4d91394475b144ea5bf7ba111f93756cc0de8a3f - original: - subdir: cryptoids-types - git: git@gitlab2.rz.ifi.lmu.de:uni2work/cryptoids.git - commit: 4d91394475b144ea5bf7ba111f93756cc0de8a3f -- completed: - subdir: cryptoids - name: cryptoids - version: 0.5.1.0 - git: git@gitlab2.rz.ifi.lmu.de:uni2work/cryptoids.git - pantry-tree: - size: 510 - sha256: 7c16ce6b5de6988ba628027a055fe7faa8b3a2e2bc77d7088e8dad23e9bac7a1 - commit: 4d91394475b144ea5bf7ba111f93756cc0de8a3f - original: - subdir: cryptoids - git: git@gitlab2.rz.ifi.lmu.de:uni2work/cryptoids.git - commit: 4d91394475b144ea5bf7ba111f93756cc0de8a3f -- completed: - subdir: filepath-crypto - name: filepath-crypto - version: 0.1.0.0 - git: git@gitlab2.rz.ifi.lmu.de:uni2work/cryptoids.git - pantry-tree: - size: 614 - sha256: 2f5d7053ba61d8727b2a0b4443017e9af013196d2d53064c98f21bbd196ccd52 - commit: 4d91394475b144ea5bf7ba111f93756cc0de8a3f - original: - subdir: filepath-crypto - git: git@gitlab2.rz.ifi.lmu.de:uni2work/cryptoids.git - commit: 4d91394475b144ea5bf7ba111f93756cc0de8a3f -- completed: - subdir: uuid-crypto - name: uuid-crypto - version: 1.4.0.0 - git: git@gitlab2.rz.ifi.lmu.de:uni2work/cryptoids.git - pantry-tree: - size: 359 - sha256: 1861593e0b304b8a09db3e7b435ae6763f57d2051a1c8770a051adc5aa0f0edd - commit: 4d91394475b144ea5bf7ba111f93756cc0de8a3f - original: - subdir: uuid-crypto - git: git@gitlab2.rz.ifi.lmu.de:uni2work/cryptoids.git - commit: 4d91394475b144ea5bf7ba111f93756cc0de8a3f - completed: subdir: gearhash name: gearhash diff --git a/templates/widgets/massinput/workflowDefinitionDescriptions/add.hamlet b/templates/widgets/massinput/workflowDefinitionDescriptions/add.hamlet new file mode 100644 index 000000000..d08b65e41 --- /dev/null +++ b/templates/widgets/massinput/workflowDefinitionDescriptions/add.hamlet @@ -0,0 +1,4 @@ +$newline never +^{formView} + + ^{fvWidget submitView} diff --git a/templates/widgets/massinput/workflowDefinitionDescriptions/form.hamlet b/templates/widgets/massinput/workflowDefinitionDescriptions/form.hamlet new file mode 100644 index 000000000..56cac181e --- /dev/null +++ b/templates/widgets/massinput/workflowDefinitionDescriptions/form.hamlet @@ -0,0 +1,8 @@ +$newline never + + #{csrf} + ^{fvWidget langView} + + ^{fvWidget titleView} + + ^{fvWidget descrView} diff --git a/templates/widgets/massinput/workflowDefinitionDescriptions/layout.hamlet b/templates/widgets/massinput/workflowDefinitionDescriptions/layout.hamlet new file mode 100644 index 000000000..23a31fe2c --- /dev/null +++ b/templates/widgets/massinput/workflowDefinitionDescriptions/layout.hamlet @@ -0,0 +1,22 @@ +$newline never + + + + + _{MsgWorkflowDefinitionDescriptionLanguage} # + + + _{MsgWorkflowDefinitionDescriptionTitle} # + + + _{MsgWorkflowDefinitionDescription} + + + $forall coord <- review liveCoords lLength + + ^{cellWdgts ! coord} + + ^{fvWidget (delButtons ! coord)} + + + ^{addWdgts ! (0, 0)} diff --git a/templates/widgets/massinput/workflowDefinitionFiles/add.hamlet b/templates/widgets/massinput/workflowDefinitionFiles/add.hamlet new file mode 100644 index 000000000..d08b65e41 --- /dev/null +++ b/templates/widgets/massinput/workflowDefinitionFiles/add.hamlet @@ -0,0 +1,4 @@ +$newline never +^{formView} + + ^{fvWidget submitView} diff --git a/templates/widgets/massinput/workflowDefinitionFiles/form.hamlet b/templates/widgets/massinput/workflowDefinitionFiles/form.hamlet new file mode 100644 index 000000000..1ec2772cb --- /dev/null +++ b/templates/widgets/massinput/workflowDefinitionFiles/form.hamlet @@ -0,0 +1,6 @@ +$newline never + + #{csrf} + ^{fvWidget fileIdentView} + + ^{fvWidget fileView} diff --git a/templates/widgets/massinput/workflowDefinitionFiles/layout.hamlet b/templates/widgets/massinput/workflowDefinitionFiles/layout.hamlet new file mode 100644 index 000000000..b12611eef --- /dev/null +++ b/templates/widgets/massinput/workflowDefinitionFiles/layout.hamlet @@ -0,0 +1,20 @@ +$newline never + + + + + _{MsgWorkflowDefinitionFileIdent} # + + + _{MsgWorkflowDefinitionFile} # + + + + $forall coord <- review liveCoords lLength + + ^{cellWdgts ! coord} + + ^{fvWidget (delButtons ! coord)} + + + ^{addWdgts ! (0, 0)}