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 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.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
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
, MonadThrow m'
)
=> Either WorkflowInstanceId WorkflowWorkflowId
-> Maybe WorkflowEdgeForm
-> SqlPersistT m' (Maybe (AForm m WorkflowEdgeForm))
workflowEdgeForm mwwId mPrev = runMaybeT $ do
MsgRenderer mr <- getMsgRenderer
ctx <- bitraverse (MaybeT . get) (MaybeT . get) mwwId
let (scope, graph) = case ctx of
Left WorkflowInstance{..} -> ( _DBWorkflowScope # workflowInstanceScope
, _DBWorkflowGraph # workflowInstanceGraph
)
Right WorkflowWorkflow{..} -> ( _DBWorkflowScope # workflowWorkflowScope
, _DBWorkflowGraph # workflowWorkflowGraph
)
wPayload = ctx ^? _Right . _workflowWorkflowState . re _DBWorkflowState . to workflowStateCurrentPayloads
wState = ctx ^? _Right . _workflowWorkflowState . to last . _wpTo
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)
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)
_other -> mzero
-- 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
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, (_, WorkflowGraphEdgeForm{..})) -> (edgeIdent, ) . fmap (WorkflowEdgeForm edgeIdent) . wFormToAForm . fmap sequenceA $ do
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 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) $ do
WorkflowPayloadView{..} <- hoistMaybe . Map.lookup payloadLabel $ wgPayloadView graph
wRoute <- case (mwwId, ctx) of
(Right wwId, Right _) -> do
cID <- encrypt wwId
return $ _WorkflowScopeRoute # (rScope, WorkflowWorkflowR cID WWWorkflowR)
(Left _, Left WorkflowInstance{..})
-> return $ _WorkflowScopeRoute # (rScope, WorkflowInstanceR workflowInstanceName WIInitiateR)
_other -> error "mwwId and ctx do not agree"
guardM . anyM (Set.toList $ toNullable wpvViewers) $ \role ->
lift . lift $ is _Authorized <$> hasWorkflowRole (mwwId ^? _Right) role wRoute False
(True, ) <$> selectLanguageI18n wpvDisplayLabel
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
, guardOnM 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 (WorkflowFieldPayloadW FileReference UserId)))], [FieldView UniWorX]))
fieldsMap = Map.fromList fields
resolveReferences :: forall i. Topograph.G WorkflowPayloadLabel i -> [(WorkflowPayloadLabel, ((Text, Bool), ([(Bool, FormResult (Maybe (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.singleton) 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}
#{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 FormStandard payloadFieldViews
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 (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 (WorkflowFieldPayloadW FileReference UserId)))
renderSpecField (WorkflowPayloadSpec (specField :: WorkflowPayloadField FileReference UserId payload)) = do
let f isOpt fld fs mx = lift . (<* tell (All isOpt)) . lift $ over (_2 . mapped . mapped) (review $ _WorkflowFieldPayloadW . _WorkflowFieldPayload) . bool (is (_FormSuccess . _Just) &&& id) (True, ) isOpt <$> wopt fld fs (Just <$> mx)
extractPrev :: forall payload' m.
( IsWorkflowFieldPayload FileReference UserId payload'
, State.MonadState [WorkflowFieldPayloadW FileReference UserId] m
)
=> m (Maybe payload')
extractPrev = State.state $ foldl' go (Nothing, []) . map (matching $ _WorkflowFieldPayloadW . _WorkflowFieldPayload)
where go (mPrev' , xs) (Left x ) = (mPrev', xs ++ [x])
go (Nothing, xs) (Right p ) = (Just p, xs)
go (Just p , xs) (Right p') = (Just p, xs ++ [_WorkflowFieldPayloadW . _WorkflowFieldPayload # p'])
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))
LanguageSelectI18n{..} <- getLanguageSelectI18n
mNudge <- ask
case specField of
WorkflowPayloadFieldText{..} -> do
prev <- extractPrev @Text
wSetTooltip' (fmap slI18n wpftTooltip) $
f wpftOptional
(textField & cfStrip)
( 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 (\wpfnMin' -> addAttr "min" . tshow $ formatScientific Scientific.Fixed Nothing wpfnMin') wpfnMin
& maybe id (\wpfnMax' -> addAttr "max" . tshow $ formatScientific Scientific.Fixed Nothing wpfnMax') wpfnMax
& maybe (addAttr "step" "any") (\wpfnStep' -> addAttr "step" . tshow $ formatScientific Scientific.Fixed Nothing wpfnStep') 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)
WorkflowPayloadFieldFile{..} -> do
fRefs <- extractPrev @(Set FileReference)
wSetTooltip' (fmap slI18n wpffTooltip) $
f 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 maybeAuthId
case mAuthId of
Just uid -> (True, FormSuccess $ _Just . _WorkflowFieldPayloadW . _WorkflowFieldPayload # uid) <$ tell (All True)
Nothing -> (False, FormMissing) <$ tell (All False)
WorkflowPayloadFieldReference{..} -> throwE wpfrTarget
WorkflowPayloadFieldMultiple{..} -> do
fRefs <- extractPrev @(NonEmpty (WorkflowFieldPayloadW FileReference UserId))
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 (WorkflowFieldPayloadW FileReference UserId)))
mPrev = Just . Map.fromList . zip [0..] . ensureLength . map (\x -> (Just x, Just x)) $ maybe [] otoList mPrev'
where
ensureLength :: forall a. [(Maybe a, Maybe a)] -> [(Maybe a, Maybe a)]
ensureLength = (\l -> (l ++) $ replicate (fromIntegral wpfmMin - length l) (Nothing, Nothing)) . maybe id (take . fromIntegral) ((+ wpfmMin) <$> wpfmRange)
mangleResult :: forall a.
FormResult (Map ListPosition (a, Maybe (WorkflowFieldPayloadW FileReference UserId)))
-> (Bool, FormResult (Maybe (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 . fmap (review $ _WorkflowFieldPayloadW . _WorkflowFieldPayload) . nonEmpty $ ress ^.. folded . _2 . _Just)
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 $ \csrf -> over (_1 . _FormSuccess) tweakRes <$> miForm nudge (Left submitView) csrf
where tweakRes :: Maybe (WorkflowFieldPayloadW FileReference UserId)
-> Map ListPosition (Maybe (WorkflowFieldPayloadW FileReference UserId))
-> FormResult (Map ListPosition (Maybe (WorkflowFieldPayloadW FileReference UserId)))
tweakRes newDat prevData = Map.fromList . zip [startKey..] <$> pure (pure newDat)
where startKey = maybe 0 succ $ fst <$> Map.lookupMax prevData
miCell :: ListPosition
-> Maybe (WorkflowFieldPayloadW FileReference UserId)
-> Maybe (Maybe (WorkflowFieldPayloadW FileReference UserId))
-> (Text -> Text)
-> (Html -> MForm (ExceptT WorkflowPayloadLabel Handler) (FormResult (Maybe (WorkflowFieldPayloadW FileReference UserId)), Widget))
miCell _pos dat mPrev'' nudge = miForm nudge . Right $ fromMaybe dat mPrev''
miForm :: (Text -> Text)
-> Either (FieldView UniWorX) (Maybe (WorkflowFieldPayloadW FileReference UserId))
-> (Html -> MForm (ExceptT WorkflowPayloadLabel Handler) (FormResult (Maybe (WorkflowFieldPayloadW FileReference UserId)), Widget))
miForm nudge mode csrf = do
let runSpecRender :: WriterT [FieldView UniWorX] Handler (Either WorkflowPayloadLabel (Bool, FormResult (Maybe (WorkflowFieldPayloadW FileReference UserId))), Ints, Enctype)
-> ExceptT WorkflowPayloadLabel Handler (((Bool, FormResult (Maybe (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)
MsgRenderer mr <- getMsgRenderer
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}
#{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 (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