117 lines
5.0 KiB
Haskell
117 lines
5.0 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 Database.Esqueleto as E
|
|
import qualified Database.Esqueleto.Utils as E
|
|
|
|
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 :: FileId -> StateT (Bimap FileIdent FileId) DB FileIdent
|
|
recordFile fId = do
|
|
prev <- State.gets $ Bimap.lookupR fId
|
|
case prev of
|
|
Just fIdent -> return fIdent
|
|
Nothing -> do
|
|
mTitle <- lift . E.selectMaybe . E.from $ \file -> do
|
|
E.where_ $ file E.^. FileId E.==. E.val fId
|
|
return $ file E.^. FileTitle
|
|
cMap <- State.get
|
|
let candidateIdents = map (review _Wrapped . CI.mk) $ case mTitle of
|
|
Just (E.Value fTitle)
|
|
-> map pack $ fTitle : [ base <.> show n <.> ext | n <- [1..] :: [Natural], let (base, ext) = splitExtension fTitle ]
|
|
Nothing
|
|
-> [ [st|file_#{n}|] | 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 fId
|
|
return fIdent
|
|
|
|
(wdfGraph, Bimap.toMap -> wdfFiles) <- (runStateT ?? Bimap.empty) . ($ workflowDefinitionGraph)
|
|
$ (typesCustom @WorkflowChildren :: Traversal (WorkflowGraph SqlBackendKey SqlBackendKey) (WorkflowGraph FileIdent SqlBackendKey) SqlBackendKey FileIdent) (recordFile . review _SqlKey)
|
|
>=> (typesCustom @WorkflowChildren :: Traversal (WorkflowGraph FileIdent SqlBackendKey) (WorkflowGraph FileIdent CryptoUUIDUser) 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 :: 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)
|
|
|
|
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
|