209 lines
11 KiB
Haskell
209 lines
11 KiB
Haskell
module Handler.Utils.Workflow.Form
|
|
( FileIdent
|
|
, WorkflowGraphForm(..)
|
|
, workflowGraphForm
|
|
, toWorkflowGraphForm, fromWorkflowGraphForm
|
|
, WorkflowDescriptionsFormScope(..)
|
|
, workflowDescriptionsForm
|
|
) where
|
|
|
|
import Import
|
|
import Utils.Form
|
|
|
|
import Handler.Utils.Form
|
|
|
|
import qualified Data.Conduit.Combinators as C
|
|
|
|
import qualified Data.Map as Map
|
|
import Data.Map ((!))
|
|
import qualified Data.Set as Set
|
|
import qualified Data.CaseInsensitive as CI
|
|
|
|
import Data.Bimap (Bimap)
|
|
import qualified Data.Bimap as Bimap
|
|
|
|
import qualified Control.Monad.State.Class as State
|
|
|
|
import qualified Data.List.NonEmpty as NonEmpty
|
|
|
|
import qualified Data.Aeson as JSON
|
|
|
|
import Utils.Workflow.Lint
|
|
|
|
|
|
newtype FileIdent = FileIdent (CI Text)
|
|
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
|
deriving newtype (ToMessage, ToJSON, FromJSON)
|
|
|
|
makeWrapped ''FileIdent
|
|
|
|
newtype instance FileReferenceTitleMap FileIdent add = FileIdentFileReferenceTitleMap
|
|
{ unFileIdentFileReferenceTitleMap :: Map FilePath (FileIdentFileReferenceTitleMapElem add)
|
|
} deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
|
deriving newtype (Semigroup, Monoid)
|
|
data FileIdentFileReferenceTitleMapElem add = FileIdentFileReferenceTitleMapElem
|
|
{ fIdentTitleMapIdent :: FileIdent
|
|
, fIdentTitleMapAdditional :: add
|
|
} deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
|
makePrisms ''FileIdentFileReferenceTitleMapElem
|
|
|
|
instance FileReferenceTitleMapConvertible add FileIdent FileIdent where
|
|
_FileReferenceTitleMap = iso unFileIdentFileReferenceTitleMap FileIdentFileReferenceTitleMap . traverse . _FileIdentFileReferenceTitleMapElem
|
|
|
|
instance FileReferenceTitleMapConvertible add FileIdent FileReference where
|
|
_FileReferenceTitleMap = iso unFileIdentFileReferenceTitleMap FileReferenceFileReferenceTitleMap . iso Map.toList Map.fromList . traverse . iso (view $ _2 . _FileIdentFileReferenceTitleMapElem) (\(FileReference{..}, additional) -> (fileReferenceTitle, FileReferenceFileReferenceTitleMapElem fileReferenceContent fileReferenceModified additional))
|
|
|
|
instance FileReferenceTitleMapConvertible add FileReference FileIdent where
|
|
_FileReferenceTitleMap = iso unFileReferenceFileReferenceTitleMap FileIdentFileReferenceTitleMap . itraverse . (\f fileReferenceTitle FileReferenceFileReferenceTitleMapElem{ fRefTitleMapContent = fileReferenceContent, fRefTitleMapModified = fileReferenceModified, fRefTitleMapAdditional } -> review _FileIdentFileReferenceTitleMapElem <$> f (FileReference{..}, fRefTitleMapAdditional))
|
|
|
|
instance ToJSON (FileField FileIdent) where
|
|
toJSON FileField{..} = JSON.object $ catMaybes
|
|
[ ("ident" JSON..=) <$> fieldIdent
|
|
, pure $ "unpack-zips" JSON..= fieldUnpackZips
|
|
, pure $ "multiple" JSON..= fieldMultiple
|
|
, pure $ "restrict-extensions" JSON..= fieldRestrictExtensions
|
|
, pure $ "max-file-size" JSON..= fieldMaxFileSize
|
|
, pure $ "additional-files" JSON..= addFiles'
|
|
]
|
|
where addFiles' = unFileIdentFileReferenceTitleMap fieldAdditionalFiles <&> \FileIdentFileReferenceTitleMapElem{..} -> JSON.object
|
|
[ "ident" JSON..= fIdentTitleMapIdent
|
|
, "include" JSON..= fIdentTitleMapAdditional
|
|
]
|
|
instance FromJSON (FileField FileIdent) where
|
|
parseJSON = JSON.withObject "FileField" $ \o -> do
|
|
fieldIdent <- o JSON..:? "ident"
|
|
fieldUnpackZips <- o JSON..: "unpack-zips"
|
|
fieldMultiple <- o JSON..: "multiple"
|
|
fieldRestrictExtensions <- o JSON..:? "restrict-extensions"
|
|
fieldMaxFileSize <- o JSON..:? "max-file-size"
|
|
fieldAllEmptyOk <- o JSON..:? "all-empty-ok" JSON..!= True
|
|
addFiles' <- o JSON..:? "additional-files" JSON..!= mempty
|
|
fieldAdditionalFiles <- fmap FileIdentFileReferenceTitleMap . for addFiles' $ JSON.withObject "FileIdentFileReferenceTitleMapElem" $ \o' -> do
|
|
fIdentTitleMapIdent <- o' JSON..: "Ident"
|
|
fIdentTitleMapAdditional <- o' JSON..: "include"
|
|
return FileIdentFileReferenceTitleMapElem{..}
|
|
return FileField{..}
|
|
|
|
|
|
|
|
data WorkflowGraphForm = WorkflowGraphForm
|
|
{ wgfGraph :: WorkflowGraph FileIdent CryptoUUIDUser
|
|
, wgfFiles :: Map FileIdent FileReference
|
|
} deriving (Generic, Typeable)
|
|
|
|
makeLenses_ ''WorkflowGraphForm
|
|
|
|
|
|
workflowGraphForm :: Maybe WorkflowGraphForm -> AForm DB WorkflowGraphForm
|
|
workflowGraphForm template = validateAForm validateWorkflowGraphForm . hoistAForm lift $ WorkflowGraphForm
|
|
<$> areq yamlField (fslI MsgWorkflowDefinitionGraph) (wgfGraph <$> template)
|
|
<*> filesForm
|
|
where
|
|
filesForm = Map.fromList <$> massInputAccumEditA fileAdd fileEdit (const Nothing) fileLayout ("workflow-definition-files" :: Text) (fslI MsgWorkflowDefinitionFiles) False (Map.toList . wgfFiles <$> 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, 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 (singleFileField $ maybe (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
|
|
FormMissing -> return FormMissing
|
|
return ((,) <$> fileIdentRes <*> fileRes', $(widgetFile "widgets/massinput/workflowDefinitionFiles/form"))
|
|
fileLayout :: MassInputLayout ListLength (FileIdent, FileReference) (FileIdent, FileReference)
|
|
fileLayout lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/massinput/workflowDefinitionFiles/layout")
|
|
|
|
validateWorkflowGraphForm :: FormValidator WorkflowGraphForm DB ()
|
|
validateWorkflowGraphForm = do
|
|
fIdentsReferenced <- uses _wgfGraph . setOf $ typesCustom @WorkflowChildren
|
|
fIdentsAvailable <- uses _wgfFiles Map.keysSet
|
|
forM_ (fIdentsReferenced `Set.difference` fIdentsAvailable) $ tellValidationError . MsgWorkflowFileIdentDoesNotExist . views _Wrapped CI.original
|
|
|
|
graph <- use _wgfGraph
|
|
for_ (lintWorkflowGraph graph) $ \lintIssues -> do
|
|
addMessageModal Warning (i18n MsgWorkflowDefinitionWarningLinterIssuesMessage) $ Right
|
|
[whamlet|
|
|
$newline never
|
|
_{MsgWorkflowDefinitionWarningLinterIssues}
|
|
<ul>
|
|
$forall issue <- otoList lintIssues
|
|
<li>
|
|
#{displayException issue}
|
|
|]
|
|
|
|
toWorkflowGraphForm :: ( MonadHandler m, HandlerSite m ~ UniWorX
|
|
)
|
|
=> WorkflowGraph FileReference SqlBackendKey
|
|
-> m WorkflowGraphForm
|
|
toWorkflowGraphForm g = liftHandler . fmap (uncurry WorkflowGraphForm . over _2 Bimap.toMap) . (runStateT ?? Bimap.empty) . ($ g)
|
|
$ traverseOf (typesCustom @WorkflowChildren) recordFile
|
|
>=> traverseOf (typesCustom @WorkflowChildren @(WorkflowGraph FileIdent SqlBackendKey) @_ @_ @CryptoUUIDUser) (encrypt . review (_SqlKey @User))
|
|
where
|
|
recordFile :: forall m. Monad m => FileReference -> StateT (Bimap FileIdent FileReference) m FileIdent
|
|
recordFile fRef@FileReference{..} = do
|
|
prev <- State.gets $ Bimap.lookupR fRef
|
|
case prev of
|
|
Just fIdent -> return fIdent
|
|
Nothing -> do
|
|
cMap <- State.get
|
|
let candidateIdents = map (review _Wrapped . CI.mk . pack) $
|
|
fileReferenceTitle : [ base <.> show n <.> ext | let (base, ext) = splitExtension fileReferenceTitle, n <- [1..] :: [Natural] ]
|
|
fIdent = case filter (`Bimap.notMember` cMap) candidateIdents of
|
|
fIdent' : _ -> fIdent'
|
|
[] -> error "candidateIdents should be infinite; cMap should be finite"
|
|
State.modify $ Bimap.insert fIdent fRef
|
|
return fIdent
|
|
|
|
fromWorkflowGraphForm :: (MonadHandler m, HandlerSite m ~ UniWorX)
|
|
=> WorkflowGraphForm
|
|
-> m (WorkflowGraph FileReference SqlBackendKey)
|
|
fromWorkflowGraphForm WorkflowGraphForm{..}
|
|
= liftHandler $ wgfGraph
|
|
& over (typesCustom @WorkflowChildren) (wgfFiles !)
|
|
& traverseOf (typesCustom @WorkflowChildren @(WorkflowGraph FileReference CryptoUUIDUser) @_ @CryptoUUIDUser) (fmap (view $ _SqlKey @User) . decrypt)
|
|
|
|
|
|
data WorkflowDescriptionsFormScope
|
|
= WorkflowDescriptionsFormDefinition
|
|
| WorkflowDescriptionsFormInstance
|
|
deriving (Eq, Ord, Bounded, Enum, Read, Show, Generic, Typeable)
|
|
deriving (Universe, Finite)
|
|
|
|
workflowDescriptionsForm :: WorkflowDescriptionsFormScope -> Maybe (Map Lang (Text, Maybe StoredMarkup)) -> AForm Handler (Map Lang (Text, Maybe StoredMarkup))
|
|
workflowDescriptionsForm scope template = Map.fromList <$> massInputAccumEditA descrAdd descrEdit (const Nothing) descrLayout ("workflow-descriptions" :: Text) (fslI msgWorkflowDescriptions) False (Map.toList <$> 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 msgWorkflowDescriptionsLanguageExists]
|
|
| otherwise
|
|
-> FormSuccess $ pure newDescr
|
|
return (res', $(widgetFile "widgets/massinput/workflowDescriptions/add"))
|
|
descrEdit nudge = descrForm nudge . Just
|
|
descrForm :: (Text -> Text) -> Maybe (Lang, (Text, Maybe StoredMarkup)) -> Form (Lang, (Text, Maybe StoredMarkup))
|
|
descrForm nudge descrTemplate csrf = do
|
|
(langRes, langView) <- mpreq (langField False) (fslI MsgWorkflowDescriptionLanguage & addName (nudge "lang")) (fmap (view _1) descrTemplate <|> Just (NonEmpty.head appLanguages))
|
|
(titleRes, titleView) <- mpreq textField (fslI MsgWorkflowDescriptionTitle & addName (nudge "title")) (view (_2 . _1) <$> descrTemplate)
|
|
(descrRes, descrView) <- mopt htmlField (fslI MsgWorkflowDescription & addName (nudge "descr")) (view (_2 . _2) <$> descrTemplate)
|
|
return ((,) <$> langRes <*> ((,) <$> titleRes <*> descrRes), $(widgetFile "widgets/massinput/workflowDescriptions/form"))
|
|
descrLayout :: MassInputLayout ListLength (Lang, (Text, Maybe StoredMarkup)) (Lang, (Text, Maybe StoredMarkup))
|
|
descrLayout lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/massinput/workflowDescriptions/layout")
|
|
|
|
msgWorkflowDescriptions = case scope of
|
|
WorkflowDescriptionsFormDefinition -> MsgWorkflowDefinitionDescriptions
|
|
WorkflowDescriptionsFormInstance -> MsgWorkflowInstanceDescriptions
|
|
msgWorkflowDescriptionsLanguageExists = case scope of
|
|
WorkflowDescriptionsFormDefinition -> MsgWorkflowDefinitionDescriptionsLanguageExists
|
|
WorkflowDescriptionsFormInstance -> MsgWorkflowInstanceDescriptionsLanguageExists
|