108 lines
4.3 KiB
Haskell
108 lines
4.3 KiB
Haskell
{-# LANGUAGE BangPatterns #-}
|
|
|
|
module Handler.Workflow.Definition.Edit
|
|
( getAWDEditR, postAWDEditR
|
|
) where
|
|
|
|
import Import
|
|
import Handler.Utils
|
|
import Handler.Workflow.Definition.Form
|
|
|
|
import qualified Data.Map as Map
|
|
import Data.Map.Strict ((!))
|
|
|
|
import Data.Bimap (Bimap)
|
|
import qualified Data.Bimap as Bimap
|
|
|
|
import qualified Control.Monad.State.Class as State
|
|
|
|
import qualified Data.CaseInsensitive as CI
|
|
|
|
|
|
getAWDEditR, postAWDEditR :: WorkflowInstanceScope' -> WorkflowDefinitionName -> Handler Html
|
|
getAWDEditR = postAWDEditR
|
|
postAWDEditR wds' wdn = do
|
|
(((_, editForm), editEncoding), act) <- runDB $ do
|
|
Entity wdId WorkflowDefinition{..} <- getBy404 $ UniqueWorkflowDefinition wdn wds'
|
|
template <- do
|
|
descs <- selectList [WorkflowDefinitionDescriptionDefinition ==. wdId] []
|
|
let wdfDescriptions = Map.fromList
|
|
[ (workflowDefinitionDescriptionLanguage, (workflowDefinitionDescriptionTitle, workflowDefinitionDescriptionDescription))
|
|
| Entity _ WorkflowDefinitionDescription{..} <- descs
|
|
]
|
|
|
|
let 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) $
|
|
map pack $ fileReferenceTitle : [ base <.> show n <.> ext | n <- [1..] :: [Natural], let (base, ext) = splitExtension fileReferenceTitle ]
|
|
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
|
|
|
|
(wdfGraph, Bimap.toMap -> wdfFiles) <- (runStateT ?? Bimap.empty) . ($ workflowDefinitionGraph)
|
|
$ traverseOf (typesCustom @WorkflowChildren) recordFile
|
|
>=> traverseOf (typesCustom @WorkflowChildren @(WorkflowGraph FileIdent SqlBackendKey) @_ @_ @CryptoUUIDUser) (encrypt . review (_SqlKey @User))
|
|
|
|
return WorkflowDefinitionForm
|
|
{ wdfScope = workflowDefinitionScope
|
|
, wdfName = workflowDefinitionName
|
|
, wdfDescriptions
|
|
, wdfGraph
|
|
, wdfFiles
|
|
}
|
|
|
|
form@((editRes, _), _) <- runFormPost . workflowDefinitionForm $ Just template
|
|
|
|
act <- formResultMaybe editRes $ \WorkflowDefinitionForm{..} -> do
|
|
wdfGraph' <- wdfGraph
|
|
& over (typesCustom @WorkflowChildren) (wdfFiles !)
|
|
& traverseOf (typesCustom @WorkflowChildren @(WorkflowGraph FileReference CryptoUUIDUser) @_ @CryptoUUIDUser) (fmap (view $ _SqlKey @User) . decrypt)
|
|
|
|
insConflict <- replaceUnique wdId WorkflowDefinition
|
|
{ workflowDefinitionGraph = wdfGraph'
|
|
, workflowDefinitionScope = wdfScope
|
|
, workflowDefinitionName = wdfName
|
|
}
|
|
|
|
when (is _Nothing insConflict) . iforM_ wdfDescriptions $ \wddLang (wddTitle, wddDesc) -> do
|
|
deleteWhere [WorkflowDefinitionDescriptionDefinition ==. wdId]
|
|
insert WorkflowDefinitionDescription
|
|
{ workflowDefinitionDescriptionDefinition = wdId
|
|
, workflowDefinitionDescriptionLanguage = wddLang
|
|
, workflowDefinitionDescriptionTitle = wddTitle
|
|
, workflowDefinitionDescriptionDescription = wddDesc
|
|
}
|
|
|
|
case insConflict of
|
|
Just (UniqueWorkflowDefinition wdn' wds'') -> return . Just $
|
|
addMessage' =<< messageIHamlet Error
|
|
[ihamlet|
|
|
$newline never
|
|
<a href=@{AdminWorkflowDefinitionR wds'' wdn' AWDEditR}>
|
|
_{MsgWorkflowDefinitionCollision}
|
|
|]
|
|
Nothing -> return . Just $ do
|
|
addMessageI Success MsgWorkflowDefinitionEdited
|
|
redirect AdminWorkflowDefinitionListR
|
|
|
|
return (form, act)
|
|
|
|
forM_ act id
|
|
|
|
let editWidget = wrapForm editForm def
|
|
{ formAction = Just . SomeRoute $ AdminWorkflowDefinitionR wds' wdn AWDEditR
|
|
, formEncoding = editEncoding
|
|
}
|
|
|
|
siteLayoutMsg MsgWorkflowDefinitionEditTitle $ do
|
|
setTitleI MsgWorkflowDefinitionEditTitle
|
|
|
|
editWidget
|