feat(workflows): create new workflow definitions

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

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
+    inputType = case fieldKind of
-      | hide      = "hidden"
+      JsonFieldHidden -> "hidden"
-      | otherwise = "text"
+      _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
-      <input id=#{theId} name=#{name} *{attrs} type=#{inputType} :isReq:required value=#{either fromStrict encodeToLazyText val}>
+       JsonFieldLarge -> liftWidget
-    |]
+         [whamlet|
+           $newline never
+           <textarea id=#{theId} name=#{name} *{attrs} :isReq:required>
+             #{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}>
+         |]
     fieldEnctype = UrlEncoded
 
 boolField :: ( MonadHandler m

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")
+  piPreviousPost <- lift . runInputPost $ iopt (jsonField JsonFieldHidden) (wIdent "pagination")
-  piPreviousGet  <- lift . runInputGet  $ iopt (jsonField True) (wIdent "pagination")
+  piPreviousGet  <- lift . runInputGet  $ iopt (jsonField JsonFieldHidden) (wIdent "pagination")
   let
     piPreviousRes = maybe FormMissing FormSuccess $ piPreviousPost <|> piPreviousGet
   $logDebugS "dbTable" [st|#{wIdent "pagination"}: #{tshow piPreviousRes}|]

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)
+makeLenses_ ''WorkflowDefinitionForm
-workflowDefinitionForm = validateForm validateWorkflowDefinitionForm . renderAForm FormStandard $
-  error "not implemented"
 
+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)
+      

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

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

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)
+    [ "tag"    JSON..= WFPText'
-    , "text"   JSON..= t
+    , toPathPiece WFPText' JSON..= t
     ]
   toJSON (WorkflowFieldPayloadW (WFPNumber n)) = JSON.object
-    [ "tag"    JSON..= ("number" :: Text)
+    [ "tag"    JSON..= WFPNumber'
-    , "number" JSON..= n
+    , toPathPiece WFPNumber' JSON..= n
     ]
   toJSON (WorkflowFieldPayloadW (WFPBool   b)) = JSON.object
-    [ "tag"    JSON..= ("bool"   :: Text)
+    [ "tag"    JSON..= WFPBool' 
-    , "bool"   JSON..= b
+    , toPathPiece WFPBool' JSON..= b
     ]
   toJSON (WorkflowFieldPayloadW (WFPFile fid)) = JSON.object
-    [ "tag"    JSON..= ("file"   :: Text)
+    [ "tag"    JSON..= WFPFile'
-    , "file"   JSON..= fid
+    , toPathPiece WFPFile' JSON..= fid
     ]
   toJSON (WorkflowFieldPayloadW (WFPUser uid)) = JSON.object
-    [ "tag"    JSON..= ("user"   :: Text)
+    [ "tag"    JSON..= WFPUser'
-    , "user"   JSON..= uid
+    , 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
+      WFPText'   -> do
-        t <- o JSON..: "text"
+        t <- o JSON..: toPathPiece WFPText'
         return $ WorkflowFieldPayloadW $ WFPText t
-      "number" -> do
+      WFPNumber' -> do
-        n <- o JSON..: "number"
+        n <- o JSON..: toPathPiece WFPNumber'
         return $ WorkflowFieldPayloadW $ WFPNumber n
-      "bool"   -> do
+      WFPBool'   -> do
-        b <- o JSON..: "bool"
+        b <- o JSON..: toPathPiece WFPBool'
         return $ WorkflowFieldPayloadW $ WFPBool b
-      "file"   -> do
+      WFPFile'   -> do
-        fid <- o JSON..: "file"
+        fid <- o JSON..: toPathPiece WFPFile'
         return $ WorkflowFieldPayloadW $ WFPFile fid
-      "user"   -> do
+      WFPUser'   -> do
-        uid <- o JSON..: "user"
+        uid <- o JSON..: toPathPiece WFPUser'
         return $ WorkflowFieldPayloadW $ WFPUser uid
-      _        -> terror $ "WorkflowFieldPayloadW parseJSON error: expected field tag (text|number|bool|file|user), but got " <> fieldTag
 
 
 

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

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

templates/widgets/massinput/workflowDefinitionDescriptions/add.hamlet

@@ -0,0 +1,4 @@
+$newline never
+^{formView}
+<td>
+  ^{fvWidget submitView}

templates/widgets/massinput/workflowDefinitionDescriptions/form.hamlet

@@ -0,0 +1,8 @@
+$newline never
+<td>
+  #{csrf}
+  ^{fvWidget langView}
+<td>
+  ^{fvWidget titleView}
+<td>
+  ^{fvWidget descrView}

templates/widgets/massinput/workflowDefinitionDescriptions/layout.hamlet

@@ -0,0 +1,22 @@
+$newline never
+<table>
+  <thead>
+    <tr>
+      <th>
+        _{MsgWorkflowDefinitionDescriptionLanguage} #
+        <span .form-group__required-marker>
+      <th>
+        _{MsgWorkflowDefinitionDescriptionTitle} #
+        <span .form-group__required-marker>
+      <th>
+        _{MsgWorkflowDefinitionDescription}
+      <td>
+  <tbody>
+    $forall coord <- review liveCoords lLength
+      <tr .massinput__cell>
+        ^{cellWdgts ! coord}
+        <td>
+          ^{fvWidget (delButtons ! coord)}
+  <tfoot>
+    <tr .massinput__cell.massinput__cell--add>
+      ^{addWdgts ! (0, 0)}

templates/widgets/massinput/workflowDefinitionFiles/add.hamlet

@@ -0,0 +1,4 @@
+$newline never
+^{formView}
+<td>
+  ^{fvWidget submitView}

templates/widgets/massinput/workflowDefinitionFiles/form.hamlet

@@ -0,0 +1,6 @@
+$newline never
+<td>
+  #{csrf}
+  ^{fvWidget fileIdentView}
+<td>
+  ^{fvWidget fileView}

templates/widgets/massinput/workflowDefinitionFiles/layout.hamlet

@@ -0,0 +1,20 @@
+$newline never
+<table>
+  <thead>
+    <tr>
+      <th>
+        _{MsgWorkflowDefinitionFileIdent} #
+        <span .form-group__required-marker>
+      <th>
+        _{MsgWorkflowDefinitionFile} #
+        <span .form-group__required-marker>
+      <td>
+  <tbody>
+    $forall coord <- review liveCoords lLength
+      <tr .massinput__cell>
+        ^{cellWdgts ! coord}
+        <td>
+          ^{fvWidget (delButtons ! coord)}
+  <tfoot>
+    <tr .massinput__cell.massinput__cell--add>
+      ^{addWdgts ! (0, 0)}