feat(workflows): create new workflow definitions
This commit is contained in:
Gregor Kleen
parent
e3b5b93c71
commit
4d63d30634
@ -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
|
||||
@ -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|
|
||||
<input id=#{theId} name=#{name} *{attrs} type=#{inputType} :isReq:required value=#{either fromStrict encodeToLazyText val}>
|
||||
|]
|
||||
fieldView theId name attrs val isReq = case fieldKind of
|
||||
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
|
||||
|
||||
@ -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}|]
|
||||
|
||||
@ -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)
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -0,0 +1,4 @@
|
||||
$newline never
|
||||
^{formView}
|
||||
<td>
|
||||
^{fvWidget submitView}
|
||||
@ -0,0 +1,8 @@
|
||||
$newline never
|
||||
<td>
|
||||
#{csrf}
|
||||
^{fvWidget langView}
|
||||
<td>
|
||||
^{fvWidget titleView}
|
||||
<td>
|
||||
^{fvWidget descrView}
|
||||
@ -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)}
|
||||
@ -0,0 +1,4 @@
|
||||
$newline never
|
||||
^{formView}
|
||||
<td>
|
||||
^{fvWidget submitView}
|
||||
@ -0,0 +1,6 @@
|
||||
$newline never
|
||||
<td>
|
||||
#{csrf}
|
||||
^{fvWidget fileIdentView}
|
||||
<td>
|
||||
^{fvWidget fileView}
|
||||
@ -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)}
|
||||
Loading…
Reference in New Issue
Block a user