543 lines
32 KiB
Haskell
543 lines
32 KiB
Haskell
module Handler.Utils.Workflow.EdgeForm
|
|
( WorkflowEdgeForm(..)
|
|
, workflowEdgeForm, WorkflowEdgeFormException(..)
|
|
, workflowEdgeFormToAction
|
|
) where
|
|
|
|
import Import hiding (StateT)
|
|
|
|
import Utils.Form
|
|
import Utils.Workflow
|
|
import Handler.Utils.Form
|
|
import Handler.Utils.Workflow.CanonicalRoute
|
|
import Handler.Utils.Widgets
|
|
import Handler.Utils.Workflow.Restriction
|
|
|
|
import qualified ListT
|
|
|
|
import Data.RFC5051 (compareUnicode)
|
|
import qualified Data.Text as Text
|
|
import Text.Unidecode (unidecode)
|
|
|
|
import qualified Data.Map as Map
|
|
import Data.Map ((!), (!?))
|
|
import qualified Data.Set as Set
|
|
import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
|
|
|
|
import qualified Crypto.MAC.KMAC as Crypto
|
|
import qualified Crypto.Saltine.Class as Saltine
|
|
import qualified Data.Binary as Binary
|
|
import qualified Data.ByteArray as BA
|
|
import Crypto.Hash.Algorithms (SHAKE256)
|
|
|
|
import qualified Control.Monad.State.Class as State
|
|
import Control.Monad.Trans.RWS.Lazy (runRWST, mapRWST)
|
|
import Control.Monad.Trans.State.Strict (execState, evalStateT)
|
|
import Control.Monad.Trans.RWS.Strict (RWST, evalRWST)
|
|
|
|
import Data.Bitraversable
|
|
|
|
import Data.List (findIndex)
|
|
import qualified Data.List as List (delete)
|
|
|
|
import qualified Data.Aeson as Aeson
|
|
import qualified Data.Scientific as Scientific
|
|
|
|
import Numeric.Lens (subtracting)
|
|
|
|
import qualified Data.Conduit.Combinators as C
|
|
|
|
import qualified Database.Esqueleto as E
|
|
|
|
import qualified Topograph
|
|
|
|
import qualified Text.Blaze as Blaze
|
|
import qualified Text.Blaze.Renderer.Text as Blaze
|
|
|
|
|
|
{-# ANN module ("HLint: ignore Use newtype instead of data"::String) #-}
|
|
|
|
|
|
data WorkflowEdgeForm = WorkflowEdgeForm
|
|
{ wefEdge :: (WorkflowGraphNodeLabel, WorkflowGraphEdgeLabel)
|
|
, wefPayload :: Map WorkflowPayloadLabel (Set (WorkflowFieldPayloadW FileReference UserId))
|
|
}
|
|
|
|
data WorkflowEdgeFormException
|
|
= WorkflowEdgeFormPayloadFieldReferenceCycle [WorkflowPayloadLabel]
|
|
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
|
deriving anyclass (Exception)
|
|
|
|
workflowEdgeForm :: ( MonadHandler m
|
|
, HandlerSite m ~ UniWorX
|
|
, MonadHandler m'
|
|
, HandlerSite m' ~ UniWorX
|
|
, MonadCatch m'
|
|
)
|
|
=> Either WorkflowInstanceId WorkflowWorkflowId
|
|
-> Maybe WorkflowEdgeForm
|
|
-> SqlPersistT m' (Maybe (AForm m WorkflowEdgeForm))
|
|
workflowEdgeForm mwwId mPrev = runMaybeT $ do
|
|
MsgRenderer mr <- getMsgRenderer
|
|
|
|
ctx' <- bitraverse (MaybeT . getEntity) (MaybeT . getEntity) mwwId
|
|
let (scope, graph) = case ctx of
|
|
Left WorkflowInstance{..} -> ( _DBWorkflowScope # workflowInstanceScope
|
|
, _DBWorkflowGraph # workflowInstanceGraph
|
|
)
|
|
Right WorkflowWorkflow{..} -> ( _DBWorkflowScope # workflowWorkflowScope
|
|
, _DBWorkflowGraph # workflowWorkflowGraph
|
|
)
|
|
wState = ctx ^? _Right . _workflowWorkflowState . to last . _wpTo
|
|
wPayload' = ctx ^? _Right . _workflowWorkflowState . re _DBWorkflowState
|
|
ctx = bimap entityVal entityVal ctx'
|
|
mAuthId <- maybeAuthId
|
|
wPayload <- case mwwId of
|
|
Right wwId -> workflowStateCurrentPayloads <$> filterM (lift . hoist liftHandler . mayViewWorkflowAction mAuthId wwId) (maybe [] otoList wPayload')
|
|
Left _ -> return Map.empty
|
|
|
|
rScope <- toRouteWorkflowScope scope
|
|
|
|
-- edges :: [((WorkflowGraphNodeLabel, WorkflowGraphEdgeLabel), (I18nText, Map WorkflowPayloadLabel (NonNull (Set (WorkflowPayloadSpec FileReference UserId)))))]
|
|
edges <- ListT.toList $ do
|
|
(nodeLabel, WGN{..}) <- ListT.fromFoldable . Map.toList $ wgNodes graph
|
|
(edgeLabel, edge) <- ListT.fromFoldable $ Map.toList wgnEdges
|
|
((nodeLabel, edgeLabel), ) <$> case edge of
|
|
WorkflowGraphEdgeManual{..} -> do
|
|
guard $ Just wgeSource == wState
|
|
wwId <- hoistMaybe $ mwwId ^? _Right
|
|
cID <- lift $ encrypt wwId
|
|
guardM . anyM (Set.toList wgeActors) $ \role ->
|
|
lift . lift $ is _Authorized <$> hasWorkflowRole (Just wwId) role (_WorkflowScopeRoute # (rScope, WorkflowWorkflowR cID WWWorkflowR)) True
|
|
return (wgeDisplayLabel, (wgeForm, wgeMessages))
|
|
WorkflowGraphEdgeInitial{..} -> do
|
|
guard $ is _Nothing wState
|
|
win <- hoistMaybe $ ctx ^? _Left . _workflowInstanceName
|
|
guardM . anyM (Set.toList wgeActors) $ \role ->
|
|
lift . lift $ is _Authorized <$> hasWorkflowRole Nothing role (_WorkflowScopeRoute # (rScope, WorkflowInstanceR win WIInitiateR)) True
|
|
return (wgeDisplayLabel, (wgeForm, wgeMessages))
|
|
_other -> mzero
|
|
|
|
guard . not $ null edges
|
|
|
|
-- edgesOptList :: OptionList (WorkflowGraphNodeLabel, WorkflowGraphEdgeLabel)
|
|
edgesOptList <- do
|
|
sBoxKey <- secretBoxKey
|
|
|
|
let olReadExternal ciphertext = do
|
|
edgeIdent <- fromMaybeT . exceptTMaybe $ encodedSecretBoxOpen' sBoxKey ciphertext
|
|
guard $ any (\(edgeIdent', _) -> edgeIdent == edgeIdent') edges
|
|
return edgeIdent
|
|
olOptions' <- ListT.toList $ do
|
|
(edgeIdent, (edgeLabel, _)) <- ListT.fromFoldable edges
|
|
optionDisplay <- lift $ selectLanguageI18n edgeLabel
|
|
let optionInternalValue = edgeIdent
|
|
optionExternalValue <- encodedSecretBox' sBoxKey SecretBoxShort edgeIdent
|
|
return Option{..}
|
|
let olOptions = concat $ do
|
|
let optSort = (compareUnicode `on` (Text.toLower . optionDisplay))
|
|
<> comparing (fallbackSortKey . optionInternalValue)
|
|
where fallbackSortKey = toDigest . kmaclazy ("workflow-edge-sorting" :: ByteString) (Saltine.encode sBoxKey) . Binary.encode . (mwwId, )
|
|
where toDigest :: Crypto.KMAC (SHAKE256 256) -> ByteString
|
|
toDigest = BA.convert
|
|
opts <- sortBy optSort olOptions'
|
|
& map (\opt@Option{..} -> (Text.concatMap (pack . unidecode) optionDisplay, opt))
|
|
& foldr (\(k, v) -> InsOrdHashMap.insertWith (<>) k [v]) InsOrdHashMap.empty
|
|
& InsOrdHashMap.elems
|
|
|
|
if
|
|
| [_] <- opts
|
|
-> return opts
|
|
| otherwise -> do
|
|
return $ zipWith (\Option{..} i -> Option{ optionDisplay = mr $ MsgWorkflowEdgeNumberedVariant optionDisplay i, ..}) opts [1..]
|
|
return OptionList{..}
|
|
|
|
let edges' = flip sortOn edges $ \(edgeIdent, _) -> flip findIndex (olOptions edgesOptList) $ (== edgeIdent) . optionInternalValue
|
|
|
|
let edgeForms :: Map (WorkflowGraphNodeLabel, WorkflowGraphEdgeLabel) (AForm Handler WorkflowEdgeForm)
|
|
edgeForms = Map.fromList . flip map edges' $ \(edgeIdent@(tState, _), (_, (WorkflowGraphEdgeForm{..}, edgeMessages))) -> (edgeIdent, ) . fmap (WorkflowEdgeForm edgeIdent) . wFormToAForm . fmap sequenceA $ do
|
|
forM_ edgeMessages $ \WorkflowEdgeMessage{..} -> void . runMaybeT $ do
|
|
let hasWorkflowRole' role = liftHandler . runDB $ case ctx' of
|
|
Right (Entity wwId _) -> do
|
|
cID <- encrypt wwId
|
|
is _Authorized <$> hasWorkflowRole (Just wwId) role (_WorkflowScopeRoute # (rScope, WorkflowWorkflowR cID WWWorkflowR)) True
|
|
Left (Entity _ WorkflowInstance{..})
|
|
-> is _Authorized <$> hasWorkflowRole Nothing role (_WorkflowScopeRoute # (rScope, WorkflowInstanceR workflowInstanceName WIInitiateR)) True
|
|
guardM $ anyM (otoList wemViewers) hasWorkflowRole'
|
|
whenIsJust wemRestriction $ guard . checkWorkflowRestriction wPayload'
|
|
let messageStatus = wemStatus
|
|
messageIcon = Nothing
|
|
messageContent <- selectLanguageI18n wemContent
|
|
lift $ wformMessage Message{..}
|
|
|
|
let fieldSort :: [(WorkflowPayloadLabel, [[(Either WorkflowGraphEdgeFormOrder ByteString, WorkflowPayloadSpec FileReference UserId)]])]
|
|
-> _
|
|
fieldSort
|
|
= sortOn ((,) <$> foldOf (_2 . folded . folded . _1 . _Left) <*> foldMapOf (_2 . folded . folded . _1 . _Right) (Just . Min))
|
|
. over (traverse . _2) (sortOn $ (,) <$> foldOf (folded . _1 . _Left) <*> foldMapOf (folded . _1 . _Right) (Just . Min))
|
|
. over (traverse . _2 . traverse) (sortOn $ (,) <$> preview (_1 . _Left) <*> preview (_1 . _Right))
|
|
orderedFields <- lift . lift . fmap fieldSort . for (Map.toList wgefFields) $ \(payloadLabel, Set.toList . toNullable -> payloadSpecs) -> fmap (payloadLabel, ) . for payloadSpecs $ \(Map.toList . toNullable -> payloadSpecs') -> for payloadSpecs' $ \(payloadOrder, payloadSpec) -> if
|
|
| payloadOrder /= mempty -> return (Left payloadOrder, payloadSpec)
|
|
| otherwise -> do
|
|
sBoxKey <- secretBoxKey
|
|
payloadSpec' <- traverseOf (typesCustom @WorkflowChildren @(WorkflowPayloadSpec FileReference UserId) @(WorkflowPayloadSpec FileReference CryptoUUIDUser) @UserId @CryptoUUIDUser) encrypt payloadSpec
|
|
let toDigest :: Crypto.KMAC (SHAKE256 256) -> ByteString
|
|
toDigest = BA.convert
|
|
fallbackSortKey = toDigest . kmaclazy ("workflow-edge-form-payload-field-sorting" :: ByteString) (Saltine.encode sBoxKey) $ Aeson.encode (mwwId, payloadSpec')
|
|
return (Right fallbackSortKey, payloadSpec)
|
|
|
|
orderedFields' <- flip evalStateT 1 . for orderedFields $ \x@(payloadLabel, _) -> do
|
|
let generateDisplayLabel = State.state $ \n -> (mr $ MsgWorkflowEdgeFormHiddenPayload n, succ n)
|
|
(mayView, payloadDisplayLabel) <- hoist (lift . lift . runDB) . maybeT ((False, ) <$> generateDisplayLabel) $
|
|
let
|
|
displayNameFromState s = do
|
|
WorkflowPayloadView{..} <- hoistMaybe . Map.lookup payloadLabel $ Map.findWithDefault Map.empty s (wgnPayloadView <$> wgNodes graph)
|
|
wRoute <- case ctx' of
|
|
Right (Entity wwId _) -> do
|
|
cID <- encrypt wwId
|
|
return $ _WorkflowScopeRoute # (rScope, WorkflowWorkflowR cID WWWorkflowR)
|
|
Left (Entity _ WorkflowInstance{..})
|
|
-> return $ _WorkflowScopeRoute # (rScope, WorkflowInstanceR workflowInstanceName WIInitiateR)
|
|
guardM . anyM (Set.toList $ toNullable wpvViewers) $ \role ->
|
|
lift . lift $ is _Authorized <$> hasWorkflowRole (mwwId ^? _Right) role wRoute False
|
|
(True, ) <$> selectLanguageI18n wpvDisplayLabel
|
|
in displayNameFromState tState <|> maybe mzero displayNameFromState wState
|
|
return ((mayView, payloadDisplayLabel), x)
|
|
|
|
fields <- for orderedFields' $ \((mayView, payloadDisplayLabel), (payloadLabel, payloadSpecs)) -> (payloadLabel, ) <$> do
|
|
let payloadSpecs' = payloadSpecs ^.. folded . folded . _2
|
|
payloadFields = workflowEdgePayloadFields payloadSpecs' $ fmap otoList . Map.lookup payloadLabel =<< prevSrc
|
|
where prevSrc = asum
|
|
[ wefPayload <$> assertM ((== edgeIdent) . wefEdge) mPrev
|
|
, guardOn mayView wPayload
|
|
]
|
|
((payloadRes, isOptional), payloadFieldViews) <- wFormFields payloadFields
|
|
return ((payloadDisplayLabel, getAll isOptional), (payloadRes, payloadFieldViews))
|
|
|
|
fields' <-
|
|
let payloadReferenceAdjacency = fieldsMap <&> setOf (_2 . _1 . folded . _Left)
|
|
fieldsMap :: Map WorkflowPayloadLabel ((Text, Bool), ([Either WorkflowPayloadLabel (Bool, FormResult (Maybe (NonEmpty (WorkflowFieldPayloadW FileReference UserId))))], [FieldView UniWorX]))
|
|
fieldsMap = Map.fromList fields
|
|
resolveReferences :: forall i. Topograph.G WorkflowPayloadLabel i -> [(WorkflowPayloadLabel, ((Text, Bool), ([(Bool, FormResult (Maybe (NonEmpty (WorkflowFieldPayloadW FileReference UserId))))], [FieldView UniWorX])))]
|
|
resolveReferences Topograph.G{gVertices, gFromVertex} = resort . Map.toList . flip execState Map.empty . for topoOrder $ \payloadLabel -> whenIsJust (Map.lookup payloadLabel fieldsMap) $ \(payloadDisplay, (payloadRes, payloadFieldViews)) -> State.modify' $ \oldState ->
|
|
let payloadRes' = flip concatMap payloadRes $ \case
|
|
Right res -> pure res
|
|
Left ref -> Map.lookup ref oldState ^. _Just . _2 . _1
|
|
in Map.insert payloadLabel (payloadDisplay, (payloadRes', payloadFieldViews)) oldState
|
|
where
|
|
topoOrder = map gFromVertex gVertices
|
|
resort = sortOn $ \(payloadLabel, _) -> findIndex (views _1 (== payloadLabel)) fields
|
|
in either (throwM . WorkflowEdgeFormPayloadFieldReferenceCycle) return $ Topograph.runG payloadReferenceAdjacency resolveReferences
|
|
|
|
fmap Map.fromList . for fields' $ \(payloadLabel, ((payloadDisplayLabel, isOptional), (payloadRes, payloadFieldViews))) -> (payloadLabel, ) <$> do
|
|
$logWarnS "WorkflowEdgeForm" $ toPathPiece payloadLabel <> ": " <> tshow payloadRes
|
|
let payloadRes' = let res = foldMap (views _2 . fmap $ maybe Set.empty (Set.fromList . otoList)) payloadRes
|
|
in if | doErrMsg -> FormFailure $ view _FormFailure res ++ pure (mr $ MsgWorkflowEdgeFormPayloadOneFieldRequiredFor payloadDisplayLabel)
|
|
| otherwise -> res
|
|
doErrMsg = flip none payloadRes $ \res -> view _1 res || hasn't (_2 . _FormSuccess) res
|
|
addErrMsg pErrs = Just
|
|
[shamlet|
|
|
$newline never
|
|
$maybe errs <- pErrs
|
|
#{errs}
|
|
<br />
|
|
#{mr MsgWorkflowEdgeFormPayloadOneFieldRequired}
|
|
|]
|
|
case payloadFieldViews of
|
|
[] -> return ()
|
|
[fv] -> lift . tell . pure $ fv
|
|
& _fvRequired .~ not isOptional
|
|
& _fvErrors %~ bool id addErrMsg doErrMsg
|
|
_other -> do
|
|
fvId <- newIdent
|
|
let fvLabel = toHtml payloadDisplayLabel
|
|
fvTooltip = Nothing
|
|
fvInput = renderFieldViews FormWorkflowDataset $ payloadFieldViews
|
|
& traverse . _fvRequired .~ not isOptional
|
|
fvErrors = bool id addErrMsg doErrMsg Nothing
|
|
fvRequired = not isOptional
|
|
in lift . tell $ pure FieldView{..}
|
|
return payloadRes'
|
|
|
|
return . hoistAForm liftHandler . multiActionAOpts edgeForms (return edgesOptList) actFS $ wefEdge <$> mPrev
|
|
where
|
|
actFS = fslI MsgWorkflowEdgeFormEdge
|
|
|
|
workflowEdgePayloadFields :: [WorkflowPayloadSpec FileReference UserId]
|
|
-> Maybe [WorkflowFieldPayloadW FileReference UserId]
|
|
-> WForm Handler ([Either WorkflowPayloadLabel (Bool, FormResult (Maybe (NonEmpty (WorkflowFieldPayloadW FileReference UserId))))], All) -- ^ @isFilled@, @foldMap ala All . map isOptional@
|
|
workflowEdgePayloadFields specs = evalRWST (forM specs $ runExceptT . renderSpecField) Nothing . fromMaybe []
|
|
where
|
|
renderSpecField :: WorkflowPayloadSpec FileReference UserId
|
|
-> ExceptT WorkflowPayloadLabel (RWST (Maybe (Text -> Text)) All [WorkflowFieldPayloadW FileReference UserId] (MForm (WriterT [FieldView UniWorX] Handler))) (Bool, FormResult (Maybe (NonEmpty (WorkflowFieldPayloadW FileReference UserId))))
|
|
renderSpecField (WorkflowPayloadSpec (specField :: WorkflowPayloadField FileReference UserId payload)) = do
|
|
let f' :: forall payload' payload''.
|
|
_
|
|
=> (payload' -> Maybe (NonEmpty payload''))
|
|
-> Bool -- ^ @isOpt@
|
|
-> Field Handler payload'
|
|
-> FieldSettings UniWorX
|
|
-> Maybe payload'
|
|
-> _ (Bool, FormResult (Maybe (NonEmpty (WorkflowFieldPayloadW FileReference UserId))))
|
|
f' toNonEmpty' isOpt fld fs mx = lift . (<* tell (All isOpt)) . lift $ over (_2 . mapped) (fmap (fmap . review $ _WorkflowFieldPayloadW . _WorkflowFieldPayload) . toNonEmpty' =<<) . bool (is (_FormSuccess . _Just) &&& id) (True, ) isOpt <$> wopt fld fs (Just <$> mx)
|
|
f :: forall payload'.
|
|
_
|
|
=> Bool -- ^ @isOpt@
|
|
-> Field Handler payload'
|
|
-> FieldSettings UniWorX
|
|
-> Maybe payload'
|
|
-> _ (Bool, FormResult (Maybe (NonEmpty (WorkflowFieldPayloadW FileReference UserId))))
|
|
f = f' (nonEmpty . pure)
|
|
extractPrevs :: forall payload' m xs.
|
|
( IsWorkflowFieldPayload' FileReference UserId payload'
|
|
, State.MonadState [WorkflowFieldPayloadW FileReference UserId] m
|
|
)
|
|
=> (payload' -> Maybe xs -> Maybe xs)
|
|
-> m (Maybe xs)
|
|
extractPrevs accum = State.state $ foldl' go (Nothing, []) . map (matching $ _WorkflowFieldPayloadW @payload' @FileReference @UserId . _WorkflowFieldPayload)
|
|
where go (mPrev', xs) (Left x) = (mPrev', xs ++ [x])
|
|
go (acc, xs) (Right p) = case accum p acc of
|
|
acc'@(Just _) -> (acc', xs)
|
|
Nothing -> (acc, xs ++ [_WorkflowFieldPayloadW @payload' @FileReference @UserId . _WorkflowFieldPayload # p])
|
|
extractPrev :: forall payload' m.
|
|
( IsWorkflowFieldPayload' FileReference UserId payload'
|
|
, State.MonadState [WorkflowFieldPayloadW FileReference UserId] m
|
|
)
|
|
=> m (Maybe payload')
|
|
extractPrev = extractPrevs $ \p -> \case
|
|
Nothing -> Just p
|
|
Just _ -> Nothing
|
|
wSetTooltip' :: _ => Maybe Html -> t' (t (MForm (WriterT [FieldView UniWorX] Handler))) a -> t' (t (MForm (WriterT [FieldView UniWorX] Handler))) a
|
|
wSetTooltip' tip = hoist (hoist (wSetTooltip tip))
|
|
|
|
MsgRenderer mr <- getMsgRenderer
|
|
LanguageSelectI18n{..} <- getLanguageSelectI18n
|
|
mNudge <- ask
|
|
|
|
case specField of
|
|
WorkflowPayloadFieldText{..} -> do
|
|
prev <- extractPrev @Text
|
|
wSetTooltip' (fmap slI18n wpftTooltip) $
|
|
f wpftOptional
|
|
(bool (textField & cfStrip) (textareaField & isoField _Wrapped & cfStrip) wpftLarge)
|
|
( fsl (slI18n wpftLabel)
|
|
& maybe id (addPlaceholder . slI18n) wpftPlaceholder
|
|
& maybe id (addName . ($ "text")) mNudge
|
|
)
|
|
(prev <|> wpftDefault)
|
|
WorkflowPayloadFieldNumber{..} -> do
|
|
prev <- extractPrev @Scientific
|
|
wSetTooltip' (fmap slI18n wpfnTooltip) $
|
|
f wpfnOptional
|
|
( fractionalField
|
|
& maybe id (\wpfnMin' -> checkBool (>= wpfnMin') $ MsgWorkflowEdgeFormFieldNumberTooSmall wpfnMin') wpfnMin
|
|
& maybe id (\wpfnMax' -> checkBool (>= wpfnMax') $ MsgWorkflowEdgeFormFieldNumberTooSmall wpfnMax') wpfnMax
|
|
& maybe id (\wpfnStep' -> flip convertField id . over (maybe id subtracting wpfnMin) $ \n -> fromInteger (round $ n / wpfnStep') * wpfnStep') wpfnStep
|
|
)
|
|
( fsl (slI18n wpfnLabel)
|
|
& maybe id (addPlaceholder . slI18n) wpfnPlaceholder
|
|
& maybe id (addAttr "min" . tshow . formatScientific Scientific.Fixed Nothing) wpfnMin
|
|
& maybe id (addAttr "max" . tshow . formatScientific Scientific.Fixed Nothing) wpfnMax
|
|
& maybe (addAttr "step" "any") (addAttr "step" . tshow . formatScientific Scientific.Fixed Nothing) wpfnStep
|
|
& maybe id (addName . ($ "number")) mNudge
|
|
)
|
|
(prev <|> wpfnDefault)
|
|
WorkflowPayloadFieldBool{..} -> do
|
|
prev <- extractPrev @Bool
|
|
wSetTooltip' (fmap slI18n wpfbTooltip) $
|
|
f (is _Just wpfbOptional)
|
|
(maybe checkBoxField (boolField . Just . SomeMessage . slI18n) wpfbOptional)
|
|
( fsl (slI18n wpfbLabel)
|
|
& maybe id (addName . ($ "bool")) mNudge
|
|
)
|
|
(prev <|> wpfbDefault)
|
|
WorkflowPayloadFieldDay{..} -> do
|
|
prev <- extractPrev @Day
|
|
wSetTooltip' (fmap slI18n wpfdTooltip) $
|
|
f wpfdOptional
|
|
dayField
|
|
( fsl (slI18n wpfdLabel)
|
|
& maybe id (addName . ($ "day")) mNudge
|
|
)
|
|
(prev <|> wpfdDefault)
|
|
WorkflowPayloadFieldFile{..} -> do
|
|
fRefs <- extractPrevs @FileReference $ \p -> if
|
|
| fieldMultiple wpffConfig -> Just . maybe (Set.singleton p) (Set.insert p)
|
|
| otherwise -> \case
|
|
Nothing -> Just $ Set.singleton p
|
|
Just _ -> Nothing
|
|
let wpffConfig' = wpffConfig & _fieldAdditionalFiles %~ (fRefs' <>)
|
|
where fRefs' = review _FileReferenceFileReferenceTitleMap . Map.fromList $ do
|
|
FileReference{..} <- Set.toList =<< hoistMaybe fRefs
|
|
return (fileReferenceTitle, (fileReferenceContent, fileReferenceModified, FileFieldUserOption False True))
|
|
wSetTooltip' (fmap slI18n wpffTooltip) $
|
|
f' (nonEmpty . Set.toList) wpffOptional
|
|
(convertFieldM (\p -> runConduit $ transPipe liftHandler p .| C.foldMap Set.singleton) yieldMany . genericFileField $ return wpffConfig')
|
|
( fsl (slI18n wpffLabel)
|
|
& maybe id (addName . ($ "file")) mNudge
|
|
)
|
|
fRefs
|
|
WorkflowPayloadFieldUser{..} -> do
|
|
fRefs <- extractPrev @UserId
|
|
let suggestions uid = E.from $ \user -> do
|
|
E.where_ $ user E.^. UserId E.==. E.val uid
|
|
return user
|
|
wSetTooltip' (fmap slI18n wpfuTooltip) $
|
|
f wpfuOptional
|
|
(checkMap (first $ const MsgWorkflowEdgeFormFieldUserNotFound) Right . userField False $ suggestions <$> fRefs)
|
|
( fslI (slI18n wpfuLabel)
|
|
& maybe id (addName . ($ "user")) mNudge
|
|
)
|
|
(fRefs <|> wpfuDefault)
|
|
WorkflowPayloadFieldCaptureUser -> do
|
|
mAuthId <- liftHandler maybeAuth
|
|
case mAuthId of
|
|
Just (Entity uid User{userDisplayName, userSurname}) -> do
|
|
fvId <- newIdent
|
|
State.modify . List.delete $ _WorkflowFieldPayloadW . _WorkflowFieldPayload # uid
|
|
lift . lift . lift . tell $ pure FieldView
|
|
{ fvLabel = [shamlet|#{mr MsgWorkflowEdgeFormFieldCaptureUserLabel}|]
|
|
, fvTooltip = Nothing
|
|
, fvId
|
|
, fvInput = [whamlet|
|
|
$newline never
|
|
<span ##{fvId}>
|
|
^{nameWidget userDisplayName userSurname}
|
|
|]
|
|
, fvErrors = Nothing
|
|
, fvRequired = False
|
|
}
|
|
(True, FormSuccess . Just . (:| []) $ _WorkflowFieldPayloadW . _WorkflowFieldPayload # uid) <$ tell (All True)
|
|
Nothing -> (False, FormMissing) <$ tell (All False)
|
|
WorkflowPayloadFieldReference{..} -> throwE wpfrTarget
|
|
WorkflowPayloadFieldMultiple{..} -> do
|
|
fRefs <- nonEmpty <$> State.state (maybe (, []) (splitAt . fromIntegral) $ (+ wpfmMin) <$> wpfmRange)
|
|
miIdent <- newIdent
|
|
wSetTooltip' (fmap slI18n wpfmTooltip) $
|
|
let mPrev' :: Maybe (NonEmpty (WorkflowFieldPayloadW FileReference UserId))
|
|
mPrev' = fRefs <|> wpfmDefault
|
|
mPrev :: Maybe (Map ListPosition (Maybe (WorkflowFieldPayloadW FileReference UserId), Maybe (NonEmpty (WorkflowFieldPayloadW FileReference UserId))))
|
|
mPrev = Just . Map.fromList . zip [0..] . ensureLength . map (\x -> (Just x, Just $ x :| [])) $ mPrev' ^.. _Just . folded
|
|
where
|
|
ensureLength :: forall a b. [(Maybe a, Maybe b)] -> [(Maybe a, Maybe b)]
|
|
ensureLength = (\l -> (l ++) $ replicate (fromIntegral wpfmMin - length l) (Nothing, Nothing)) . maybe id (take . fromIntegral) ((+ wpfmMin) <$> wpfmRange)
|
|
mangleResult :: forall a.
|
|
FormResult (Map ListPosition (a, Maybe (NonEmpty (WorkflowFieldPayloadW FileReference UserId))))
|
|
-> (Bool, FormResult (Maybe (NonEmpty (WorkflowFieldPayloadW FileReference UserId))))
|
|
-- FieldMultiple are always filled since `massInput` ensures cardinality constraints (iff @mPrev'@ correctly initializes `massInput` with a list of fields of the appropriate length)
|
|
mangleResult res = case matching _FormSuccess res of
|
|
Right ress
|
|
-> (True, FormSuccess . nonEmpty $ ress ^.. folded . _2 . _Just . folded)
|
|
Left res'
|
|
-> (False, res')
|
|
runMI :: forall a.
|
|
WForm (ExceptT WorkflowPayloadLabel Handler) a
|
|
-> ExceptT WorkflowPayloadLabel (RWST (Maybe (Text -> Text)) All [WorkflowFieldPayloadW FileReference UserId] (MForm (WriterT [FieldView UniWorX] Handler))) a
|
|
runMI mx = do
|
|
r <- lift $ lift ask
|
|
s <- lift $ lift State.get
|
|
((a, s', w), w') <- ExceptT . lift . lift . lift . runExceptT . runWriterT $ runRWST mx r s
|
|
lift . lift $ do
|
|
State.put s'
|
|
tell w
|
|
lift $ tell w'
|
|
lift . tell . All $ wpfmMin <= 0
|
|
return a
|
|
|
|
miAdd :: ListPosition
|
|
-> Natural
|
|
-> (Text -> Text)
|
|
-> FieldView UniWorX
|
|
-> Maybe (Html -> MForm (ExceptT WorkflowPayloadLabel Handler) (FormResult (Map ListPosition (Maybe (WorkflowFieldPayloadW FileReference UserId)) -> FormResult (Map ListPosition (Maybe (WorkflowFieldPayloadW FileReference UserId)))), Widget))
|
|
miAdd _pos _dim nudge submitView = Just $ over (mapped . _1 . _FormSuccess) tweakRes . miForm nudge (Left submitView)
|
|
where tweakRes :: Maybe (NonEmpty (WorkflowFieldPayloadW FileReference UserId))
|
|
-> Map ListPosition (Maybe (WorkflowFieldPayloadW FileReference UserId))
|
|
-> FormResult (Map ListPosition (Maybe (WorkflowFieldPayloadW FileReference UserId)))
|
|
tweakRes newDat prevData = pure . Map.fromList . zip [startKey..] . map Just $ newDat ^.. _Just . folded
|
|
where startKey = maybe 0 succ $ fst <$> Map.lookupMax prevData
|
|
|
|
miCell :: ListPosition
|
|
-> Maybe (WorkflowFieldPayloadW FileReference UserId)
|
|
-> Maybe (Maybe (NonEmpty (WorkflowFieldPayloadW FileReference UserId)))
|
|
-> (Text -> Text)
|
|
-> (Html -> MForm (ExceptT WorkflowPayloadLabel Handler) (FormResult (Maybe (NonEmpty (WorkflowFieldPayloadW FileReference UserId))), Widget))
|
|
miCell _pos dat mPrev'' nudge = miForm nudge . Right $ fromMaybe (fmap (:| []) dat) mPrev''
|
|
|
|
miForm :: (Text -> Text)
|
|
-> Either (FieldView UniWorX) (Maybe (NonEmpty (WorkflowFieldPayloadW FileReference UserId)))
|
|
-> (Html -> MForm (ExceptT WorkflowPayloadLabel Handler) (FormResult (Maybe (NonEmpty (WorkflowFieldPayloadW FileReference UserId))), Widget))
|
|
miForm nudge mode csrf = do
|
|
let runSpecRender :: WriterT [FieldView UniWorX] Handler (Either WorkflowPayloadLabel (Bool, FormResult (Maybe (NonEmpty (WorkflowFieldPayloadW FileReference UserId)))), Ints, Enctype)
|
|
-> ExceptT WorkflowPayloadLabel Handler (((Bool, FormResult (Maybe (NonEmpty (WorkflowFieldPayloadW FileReference UserId)))), [FieldView UniWorX]), Ints, Enctype)
|
|
runSpecRender mSR = do
|
|
((eRes, s, w), fvs) <- lift $ runWriterT mSR
|
|
ExceptT . return $ (, s, w) . (, fvs) <$> eRes
|
|
((fFilled, fmRes), fvs') <- mapRWST runSpecRender . fmap (view _1) $ evalRWST (runExceptT $ renderSpecField wpfmSub) (Just $ fromMaybe id mNudge . nudge) (mode ^.. _Right . _Just . folded)
|
|
|
|
let fFilled' = fFilled || isn't _FormSuccess fmRes
|
|
fmRes' | not fFilled' = FormFailure . pure . maybe (mr MsgValueRequired) (mr . valueRequired) $ fvs ^? _head . to fvLabel'
|
|
| otherwise = fmRes
|
|
fvLabel' = toStrict . Blaze.renderMarkup . Blaze.contents . fvLabel -- Dirty, but probably good enough; if not: `censor` writer with actual `Text` in `renderSpecField` and discard that information in `workflowEdgePayloadFields`
|
|
fvs | not fFilled' = fvs' <&> \fv -> fv { fvErrors = Just
|
|
[shamlet|
|
|
$newline never
|
|
$maybe errs <- fvErrors fv
|
|
#{errs}
|
|
<br />
|
|
#{mr (valueRequired (fvLabel' fv))}
|
|
|]
|
|
}
|
|
| otherwise = fvs'
|
|
valueRequired :: forall msg. _ => msg -> ValueRequired UniWorX
|
|
valueRequired = ValueRequired
|
|
|
|
return ( fmRes'
|
|
, case mode of
|
|
Left btn -> $(widgetFile "widgets/massinput/workflow-payload-field-multiple/add")
|
|
Right _ -> $(widgetFile "widgets/massinput/workflow-payload-field-multiple/cell")
|
|
)
|
|
|
|
miDelete :: forall m.
|
|
Monad m
|
|
=> Map ListPosition (Maybe (WorkflowFieldPayloadW FileReference UserId))
|
|
-> ListPosition
|
|
-> MaybeT m (Map ListPosition ListPosition)
|
|
miDelete dat pos = do
|
|
ListLength l <- hoistMaybe . preview liveCoords $ Map.keysSet dat
|
|
guard $ l > wpfmMin
|
|
miDeleteList dat pos
|
|
|
|
miAllowAdd :: ListPosition
|
|
-> Natural
|
|
-> ListLength
|
|
-> Bool
|
|
miAllowAdd _ _ (ListLength l) = maybe True (l <) $ (+ wpfmMin) <$> wpfmRange
|
|
|
|
miAddEmpty :: ListPosition
|
|
-> Natural
|
|
-> ListLength
|
|
-> Set ListPosition
|
|
miAddEmpty _ _ _ = Set.empty
|
|
|
|
miButtonAction :: forall p.
|
|
p -> Maybe (SomeRoute UniWorX)
|
|
miButtonAction _ = Nothing
|
|
|
|
miLayout :: MassInputLayout ListLength (Maybe (WorkflowFieldPayloadW FileReference UserId)) (Maybe (NonEmpty (WorkflowFieldPayloadW FileReference UserId)))
|
|
miLayout lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/massinput/workflow-payload-field-multiple/layout")
|
|
in runMI . fmap mangleResult $ massInputW MassInput{..} (fslI $ slI18n wpfmLabel) False mPrev
|
|
|
|
|
|
workflowEdgeFormToAction :: ( MonadHandler m
|
|
, HandlerSite m ~ UniWorX
|
|
)
|
|
=> WorkflowEdgeForm
|
|
-> m (WorkflowAction FileReference UserId)
|
|
workflowEdgeFormToAction WorkflowEdgeForm{..} = do
|
|
wpUser <- Just <$> maybeAuthId
|
|
wpTime <- liftIO getCurrentTime
|
|
return WorkflowAction{..}
|
|
where
|
|
(wpTo, wpVia) = wefEdge
|
|
wpPayload = wefPayload
|