fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

refactor(workflows): better modularize handlers

Browse Source
This commit is contained in:
Gregor Kleen 2020-11-30 19:09:30 +01:00
parent 282d56a5c2
commit dae2d16677
17 changed files with 116 additions and 103 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
src/Foundation/Authorization.hs
View File

@ -1367,8 +1367,8 @@ tagAccessPredicate AuthWorkflow = APDB $ \_ mAuthId route isWrite -> do
scope <- MaybeT . $cachedHereBinary rScope . runMaybeT $ fromRouteWorkflowScope rScope
Entity _ WorkflowInstance{..} <- $cachedHereBinary (win, scope) . MaybeT . getBy . UniqueWorkflowInstance win $ scope ^. _DBWorkflowScope
let
wiGraph :: WorkflowGraph FileReference UserId
wiGraph = workflowInstanceGraph & over (typesCustom @WorkflowChildren) (review _SqlKey :: SqlBackendKey -> UserId)
wiGraph :: IdWorkflowGraph
wiGraph = _DBWorkflowGraph # workflowInstanceGraph
edges = do
WGN{..} <- wiGraph ^.. _wgNodes . folded
WorkflowGraphEdgeInitial{..} <- wgnEdges ^.. folded
@ -1385,8 +1385,8 @@ tagAccessPredicate AuthWorkflow = APDB $ \_ mAuthId route isWrite -> do
WorkflowWorkflow{..} <- MaybeT . $cachedHereBinary wwId $ get wwId
let
wwGraph :: WorkflowGraph FileReference UserId
wwGraph = workflowWorkflowGraph & over (typesCustom @WorkflowChildren) (review _SqlKey :: SqlBackendKey -> UserId)
wwGraph :: IdWorkflowGraph
wwGraph = _DBWorkflowGraph # workflowWorkflowGraph
wwNode = wpTo $ last workflowWorkflowState
@ -1405,8 +1405,8 @@ tagAccessPredicate AuthWorkflow = APDB $ \_ mAuthId route isWrite -> do
WorkflowWorkflow{..} <- MaybeT . $cachedHereBinary wwId $ get wwId
let
wwGraph :: WorkflowGraph FileReference UserId
wwGraph = workflowWorkflowGraph & over (typesCustom @WorkflowChildren) (review _SqlKey :: SqlBackendKey -> UserId)
wwGraph :: IdWorkflowGraph
wwGraph = _DBWorkflowGraph # workflowWorkflowGraph
nodeViewers = do
WorkflowAction{..} <- otoList workflowWorkflowState
@ -1429,8 +1429,8 @@ tagAccessPredicate AuthWorkflow = APDB $ \_ mAuthId route isWrite -> do
WorkflowWorkflow{..} <- MaybeT . $cachedHereBinary wwId $ get wwId
stIx <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decryptWorkflowStateIndex wwId stCID
let
wwGraph :: WorkflowGraph FileReference UserId
wwGraph = workflowWorkflowGraph & over (typesCustom @WorkflowChildren) (review _SqlKey :: SqlBackendKey -> UserId)
wwGraph :: IdWorkflowGraph
wwGraph = _DBWorkflowGraph # workflowWorkflowGraph
act <- workflowStateIndex stIx $ _DBWorkflowState # workflowWorkflowState
let
cState = wpTo act

4
src/Foundation/I18n.hs
View File

@ -51,6 +51,8 @@ import Data.List ((!!))
import qualified Data.Scientific as Scientific
import Utils.Workflow (RouteWorkflowScope)
pluralDE :: (Eq a, Num a)
=> a -- ^ Count
@ -423,7 +425,7 @@ instance RenderMessage UniWorX ShortWeekDay where
embedRenderMessage ''UniWorX ''ButtonSubmit id
instance RenderMessage UniWorX (WorkflowScope TermId SchoolId (TermId, SchoolId, CourseShorthand)) where
instance RenderMessage UniWorX RouteWorkflowScope where
renderMessage foundation ls = \case
WSGlobal -> mr MsgWorkflowScopeGlobal
WSTerm{..} -> mr . ShortTermIdentifier $ unTermKey wisTerm

2
src/Foundation/Navigation.hs
View File

@ -2571,7 +2571,7 @@ _haveWorkflowInstances, haveWorkflowWorkflows
, BackendCompatible SqlReadBackend backend
, BearerAuthSite UniWorX
)
=> WorkflowScope TermId SchoolId (TermId, SchoolId, CourseShorthand)
=> RouteWorkflowScope
-> ReaderT backend m Bool
_haveWorkflowInstances rScope = hoist liftHandler . withReaderT (projectBackend @SqlReadBackend) . maybeT (return False) $ do
scope <- fromRouteWorkflowScope rScope

8
src/Handler/Utils/Workflow/CanonicalRoute.hs
View File

@ -4,6 +4,8 @@ import Import.NoFoundation
import Foundation.Type
import Foundation.Routes
import Utils.Workflow (RouteWorkflowScope)
data WorkflowScopeRoute
= WorkflowInstanceListR
@ -22,11 +24,7 @@ data WorkflowWorkflowR
deriving (Eq, Ord, Read, Show, Generic, Typeable)
_WorkflowScopeRoute :: Prism'
( Route UniWorX )
( WorkflowScope TermId SchoolId (TermId, SchoolId, CourseShorthand)
, WorkflowScopeRoute
)
_WorkflowScopeRoute :: Prism' (Route UniWorX) (RouteWorkflowScope, WorkflowScopeRoute)
_WorkflowScopeRoute = prism' (uncurry toRoute) toWorkflowScopeRoute
where
toRoute = \case

13
src/Handler/Utils/Workflow/Form.hs
View File

@ -9,6 +9,7 @@ module Handler.Utils.Workflow.Form
import Import
import Utils.Form
import Utils.Workflow
import Handler.Utils.Form
@ -92,8 +93,10 @@ instance FromJSON (FileField FileIdent) where
type FormWorkflowGraph = WorkflowGraph FileIdent CryptoUUIDUser
data WorkflowGraphForm = WorkflowGraphForm
{ wgfGraph :: WorkflowGraph FileIdent CryptoUUIDUser
{ wgfGraph :: FormWorkflowGraph
, wgfFiles :: Map FileIdent FileReference
} deriving (Generic, Typeable)
@ -115,7 +118,7 @@ workflowGraphForm template = validateAForm validateWorkflowGraphForm . hoistAFor
WGFTextInput -> apreq yamlField (fslI MsgWorkflowDefinitionGraph) (wgfGraph <$> template)
WGFFileUpload -> apreq (checkMMap toGraph fromGraph . singleFileField . foldMap fromGraph $ wgfGraph <$> template) (fslI MsgWorkflowDefinitionGraph) (wgfGraph <$> template)
where
toGraph :: FileUploads -> Handler (Either (SomeMessage UniWorX) (WorkflowGraph FileIdent CryptoUUIDUser))
toGraph :: FileUploads -> Handler (Either (SomeMessage UniWorX) FormWorkflowGraph)
toGraph uploads = runExceptT $ do
fRefs <- lift . runConduit $ uploads .| C.take 2 .| C.foldMap pure
fRef <- case fRefs of
@ -124,7 +127,7 @@ workflowGraphForm template = validateAForm validateWorkflowGraphForm . hoistAFor
mContent <- for (fileContent $ sourceFile fRef) $ \fContent -> lift . runDB . runConduit $ fContent .| C.fold
content <- maybe (throwE $ SomeMessage MsgWorkflowGraphFormUploadIsDirectory) return mContent
either (throwE . SomeMessage . MsgYAMLFieldDecodeFailure . displayException) return . runCatch $ Yaml.decodeThrow content
fromGraph :: WorkflowGraph FileIdent CryptoUUIDUser -> FileUploads
fromGraph :: FormWorkflowGraph -> FileUploads
fromGraph g = yieldM . runDB $ do
fileModified <- liftIO getCurrentTime
fRef <- sinkFile $ File
@ -181,7 +184,7 @@ validateWorkflowGraphForm = do
toWorkflowGraphForm :: ( MonadHandler m, HandlerSite m ~ UniWorX
)
=> WorkflowGraph FileReference SqlBackendKey
=> DBWorkflowGraph
-> m WorkflowGraphForm
toWorkflowGraphForm g = liftHandler . fmap (uncurry WorkflowGraphForm . over _2 Bimap.toMap) . (runStateT ?? Bimap.empty) . ($ g)
$ traverseOf (typesCustom @WorkflowChildren) recordFile
@ -204,7 +207,7 @@ toWorkflowGraphForm g = liftHandler . fmap (uncurry WorkflowGraphForm . over _2
fromWorkflowGraphForm :: (MonadHandler m, HandlerSite m ~ UniWorX)
=> WorkflowGraphForm
-> m (WorkflowGraph FileReference SqlBackendKey)
-> m DBWorkflowGraph
fromWorkflowGraphForm WorkflowGraphForm{..}
= liftHandler $ wgfGraph
& over (typesCustom @WorkflowChildren) (wgfFiles !)

14
src/Handler/Utils/Workflow/Workflow.hs
View File

@ -7,13 +7,14 @@ module Handler.Utils.Workflow.Workflow
import Import
import Utils.Workflow
import Handler.Utils.Workflow.EdgeForm
import qualified Data.Set as Set
import qualified Data.Map as Map
ensureScope :: WorkflowScope TermId SchoolId CourseId -> CryptoFileNameWorkflowWorkflow -> MaybeT DB WorkflowWorkflowId
ensureScope :: IdWorkflowScope -> CryptoFileNameWorkflowWorkflow -> MaybeT DB WorkflowWorkflowId
ensureScope wiScope cID = do
wId <- catchMaybeT (Proxy @CryptoIDError) $ decrypt cID
WorkflowWorkflow{..} <- MaybeT $ get wId
@ -28,7 +29,7 @@ followEdge :: ( MonadHandler m
, HandlerSite m ~ UniWorX
, MonadThrow m
)
=> WorkflowGraph FileReference UserId -> WorkflowEdgeForm -> Maybe (WorkflowState FileReference UserId) -> m (WorkflowState FileReference UserId)
=> IdWorkflowGraph -> WorkflowEdgeForm -> Maybe IdWorkflowState -> m IdWorkflowState
followEdge graph edgeRes cState = do
act <- workflowEdgeFormToAction edgeRes
followAutomaticEdges graph $ maybe id (<>) cState (act `ncons` mempty)
@ -43,13 +44,12 @@ followAutomaticEdges :: forall m.
( MonadIO m
, MonadThrow m
)
=> WorkflowGraph FileReference UserId
-> WorkflowState FileReference UserId -> m (WorkflowState FileReference UserId)
=> IdWorkflowGraph -> IdWorkflowState -> m IdWorkflowState
followAutomaticEdges WorkflowGraph{..} = go []
where
go :: [((WorkflowGraphNodeLabel, Set WorkflowPayloadLabel), (WorkflowGraphEdgeLabel, WorkflowGraphNodeLabel))] -- ^ Should encode all state from which automatic edges decide whether they can be followed
-> WorkflowState FileReference UserId
-> m (WorkflowState FileReference UserId)
-> IdWorkflowState
-> m IdWorkflowState
go automaticEdgesTaken history
| null automaticEdgeOptions = return history
| [(edgeLbl, nodeLbl)] <- automaticEdgeOptions = if
@ -74,7 +74,7 @@ followAutomaticEdges WorkflowGraph{..} = go []
filledPayloads = Map.keysSet . Map.filter (not . Set.null) $ workflowStateCurrentPayloads history
edgeDecisionInput = (cState, filledPayloads)
checkWorkflowRestriction :: WorkflowState FileReference UserId
checkWorkflowRestriction :: IdWorkflowState
-> PredDNF WorkflowGraphRestriction
-> Bool
checkWorkflowRestriction history dnf = maybe False (ofoldr1 (||)) . fromNullable $ map evalConj dnf'

8
src/Handler/Workflow/Instance/Delete.hs
View File

@ -11,13 +11,11 @@ import Utils.Workflow
getGWIDeleteR, postGWIDeleteR :: WorkflowInstanceName -> Handler Html
getGWIDeleteR = postGWIDeleteR
postGWIDeleteR win
= workflowInstanceDeleteR <=< runDB . getKeyBy404 $ UniqueWorkflowInstance win WSGlobal
postGWIDeleteR = workflowInstanceDeleteR WSGlobal
getSWIDeleteR, postSWIDeleteR :: SchoolId -> WorkflowInstanceName -> Handler Html
getSWIDeleteR = postSWIDeleteR
postSWIDeleteR ssh win
= workflowInstanceDeleteR <=< runDB . getKeyBy404 . UniqueWorkflowInstance win . view _DBWorkflowScope $ WSSchool ssh
postSWIDeleteR ssh = workflowInstanceDeleteR $ WSSchool ssh
workflowInstanceDeleteR :: WorkflowInstanceId -> Handler Html
workflowInstanceDeleteR :: RouteWorkflowScope -> WorkflowInstanceName -> Handler Html
workflowInstanceDeleteR = error "not implemented"

8
src/Handler/Workflow/Instance/Edit.hs
View File

@ -11,13 +11,11 @@ import Utils.Workflow
getGWIEditR, postGWIEditR :: WorkflowInstanceName -> Handler Html
getGWIEditR = postGWIEditR
postGWIEditR win
= workflowInstanceEditR <=< runDB . getKeyBy404 $ UniqueWorkflowInstance win WSGlobal
postGWIEditR = workflowInstanceEditR WSGlobal
getSWIEditR, postSWIEditR :: SchoolId -> WorkflowInstanceName -> Handler Html
getSWIEditR = postSWIEditR
postSWIEditR ssh win
= workflowInstanceEditR <=< runDB . getKeyBy404 . UniqueWorkflowInstance win . view _DBWorkflowScope $ WSSchool ssh
postSWIEditR ssh = workflowInstanceEditR $ WSSchool ssh
workflowInstanceEditR :: WorkflowInstanceId -> Handler Html
workflowInstanceEditR :: RouteWorkflowScope -> WorkflowInstanceName -> Handler Html
workflowInstanceEditR = error "not implemented"

7
src/Handler/Workflow/Instance/Form.hs
View File

@ -8,6 +8,7 @@ import Import
import Handler.Utils
import Handler.Utils.Workflow.Form
import Utils.Workflow
import qualified Data.Map as Map
import qualified Data.Set as Set
@ -15,8 +16,8 @@ import qualified Data.Set as Set
workflowInstanceScopeForm :: Maybe WorkflowScope'
-> FieldSettings UniWorX
-> Maybe (WorkflowScope TermId SchoolId CourseId)
-> AForm Handler (WorkflowScope TermId SchoolId CourseId)
-> Maybe IdWorkflowScope
-> AForm Handler IdWorkflowScope
workflowInstanceScopeForm scopeRestr fs mPrev = multiActionA scopeOptions' fs $ classifyWorkflowScope <$> mPrev
where
scopeOptions' = maybe id (flip Map.restrictKeys . Set.singleton) scopeRestr scopeOptions
@ -42,7 +43,7 @@ workflowInstanceScopeForm scopeRestr fs mPrev = multiActionA scopeOptions' fs $
data WorkflowInstanceForm = WorkflowInstanceForm
{ wifScope :: WorkflowScope TermId SchoolId CourseId
{ wifScope :: IdWorkflowScope
, wifName :: WorkflowInstanceName
, wifCategory :: Maybe WorkflowInstanceCategory
, wifDescriptions :: Map Lang (Text, Maybe StoredMarkup)

18
src/Handler/Workflow/Instance/Initiate.hs
View File

@ -20,20 +20,18 @@ import qualified Data.List.NonEmpty as NonEmpty
getGWIInitiateR, postGWIInitiateR :: WorkflowInstanceName -> Handler Html
getGWIInitiateR = postGWIInitiateR
postGWIInitiateR win
= workflowInstanceInitiateR <=< runDB . getKeyBy404 $ UniqueWorkflowInstance win WSGlobal
postGWIInitiateR = workflowInstanceInitiateR WSGlobal
getSWIInitiateR, postSWIInitiateR :: SchoolId -> WorkflowInstanceName -> Handler Html
getSWIInitiateR = postSWIInitiateR
postSWIInitiateR ssh win
= workflowInstanceInitiateR <=< runDB . getKeyBy404 . UniqueWorkflowInstance win . view _DBWorkflowScope $ WSSchool ssh
postSWIInitiateR ssh = workflowInstanceInitiateR $ WSSchool ssh
workflowInstanceInitiateR :: WorkflowInstanceId -> Handler Html
workflowInstanceInitiateR wiId = do
(WorkflowInstance{..}, ((edgeAct, edgeView'), edgeEnc), rScope, mDesc) <- runDB $ do
wi@WorkflowInstance{..} <- get404 wiId
workflowInstanceInitiateR :: RouteWorkflowScope -> WorkflowInstanceName -> Handler Html
workflowInstanceInitiateR rScope win = do
(WorkflowInstance{..}, ((edgeAct, edgeView'), edgeEnc), mDesc) <- runDB $ do
scope <- maybeT notFound $ fromRouteWorkflowScope rScope
Entity wiId wi@WorkflowInstance{..} <- getBy404 . UniqueWorkflowInstance win $ scope ^. _DBWorkflowScope
edgeForm <- maybeT notFound . MaybeT $ workflowEdgeForm (Left wiId) Nothing
rScope <- maybeT notFound . toRouteWorkflowScope $ _DBWorkflowScope # workflowInstanceScope
descs <- selectList [ WorkflowInstanceDescriptionInstance ==. wiId ] []
mDesc <- runMaybeT $ do
@ -66,7 +64,7 @@ workflowInstanceInitiateR wiId = do
, _WorkflowScopeRoute # ( rScope, WorkflowInstanceListR )
]
return (wi, ((edgeAct, edgeView), edgeEnc), rScope, mDesc)
return (wi, ((edgeAct, edgeView), edgeEnc), mDesc)
sequence_ edgeAct

4
src/Handler/Workflow/Instance/List.hs
View File

@ -58,7 +58,7 @@ getAdminWorkflowInstanceListR = do
scopes <- fmap (map $ review _DBWorkflowScope . E.unValue) . E.select . E.from $ \workflowInstance ->
return $ workflowInstance E.^. WorkflowInstanceScope
fmap mkOptionList . for scopes $ \scope -> do
eScope <- traverseOf _wisCourse encrypt scope :: DB (WorkflowScope TermId SchoolId CryptoUUIDCourse)
eScope <- traverseOf _wisCourse encrypt scope :: DB CryptoIDWorkflowScope
wScope <- maybeT notFound $ toRouteWorkflowScope scope
MsgRenderer mr <- getMsgRenderer
return Option
@ -133,7 +133,7 @@ getSchoolWorkflowInstanceListR :: SchoolId -> Handler Html
getSchoolWorkflowInstanceListR = workflowInstanceListR . WSSchool
workflowInstanceListR :: WorkflowScope TermId SchoolId (TermId, SchoolId, CourseShorthand) -> Handler Html
workflowInstanceListR :: RouteWorkflowScope -> Handler Html
workflowInstanceListR rScope = do
instances <- runDB $ do
dbScope <- maybeT notFound $ view _DBWorkflowScope <$> fromRouteWorkflowScope rScope

3
src/Handler/Workflow/Instance/New.hs
View File

@ -9,6 +9,7 @@ module Handler.Workflow.Instance.New
import Import
import Handler.Utils
import Handler.Utils.Workflow.Form
import Utils.Workflow
import Handler.Workflow.Instance.Form
@ -77,5 +78,5 @@ getSchoolWorkflowInstanceNewR, postSchoolWorkflowInstanceNewR :: SchoolId -> Han
getSchoolWorkflowInstanceNewR = postSchoolWorkflowInstanceNewR
postSchoolWorkflowInstanceNewR = workflowInstanceNewR . WSSchool
workflowInstanceNewR :: WorkflowScope TermId SchoolId CourseId -> Handler Html
workflowInstanceNewR :: RouteWorkflowScope -> Handler Html
workflowInstanceNewR = error "not implemented"

10
src/Handler/Workflow/Workflow/Delete.hs
View File

@ -6,18 +6,16 @@ module Handler.Workflow.Workflow.Delete
import Import
import Handler.Utils.Workflow.Workflow
import Utils.Workflow
getGWWDeleteR, postGWWDeleteR :: CryptoFileNameWorkflowWorkflow -> Handler Html
getGWWDeleteR = postGWWDeleteR
postGWWDeleteR cID
= workflowDeleteR <=< runDB . maybeT notFound $ ensureScope WSGlobal cID
postGWWDeleteR = workflowDeleteR WSGlobal
getSWWDeleteR, postSWWDeleteR :: SchoolId -> CryptoFileNameWorkflowWorkflow -> Handler Html
getSWWDeleteR = postSWWDeleteR
postSWWDeleteR ssh cID
= workflowDeleteR <=< runDB . maybeT notFound $ ensureScope (WSSchool ssh) cID
postSWWDeleteR ssh = workflowDeleteR $ WSSchool ssh
workflowDeleteR :: WorkflowWorkflowId -> Handler Html
workflowDeleteR :: RouteWorkflowScope -> CryptoFileNameWorkflowWorkflow -> Handler Html
workflowDeleteR = error "not implemented"

10
src/Handler/Workflow/Workflow/Edit.hs
View File

@ -6,18 +6,16 @@ module Handler.Workflow.Workflow.Edit
import Import
import Handler.Utils.Workflow.Workflow
import Utils.Workflow
getGWWEditR, postGWWEditR :: CryptoFileNameWorkflowWorkflow -> Handler Html
getGWWEditR = postGWWEditR
postGWWEditR cID
= workflowEditR <=< runDB . maybeT notFound $ ensureScope WSGlobal cID
postGWWEditR = workflowEditR WSGlobal
getSWWEditR, postSWWEditR :: SchoolId -> CryptoFileNameWorkflowWorkflow -> Handler Html
getSWWEditR = postSWWEditR
postSWWEditR ssh cID
= workflowEditR <=< runDB . maybeT notFound $ ensureScope (WSSchool ssh) cID
postSWWEditR ssh = workflowEditR $ WSSchool ssh
workflowEditR :: WorkflowWorkflowId -> Handler Html
workflowEditR :: RouteWorkflowScope -> CryptoFileNameWorkflowWorkflow -> Handler Html
workflowEditR = error "not implemented"

22
src/Handler/Workflow/Workflow/List.hs
View File

@ -21,10 +21,10 @@ getGlobalWorkflowWorkflowListR = workflowWorkflowListR WSGlobal
getSchoolWorkflowWorkflowListR :: SchoolId -> Handler Html
getSchoolWorkflowWorkflowListR = workflowWorkflowListR . WSSchool
workflowWorkflowListR :: WorkflowScope TermId SchoolId CourseId -> Handler Html
workflowWorkflowListR scope = do -- not implemented; TODO: FIXME
workflowWorkflowListR :: RouteWorkflowScope -> Handler Html
workflowWorkflowListR rScope = do -- not implemented; TODO: FIXME
wfRoutes <- runDB $ do
rScope <- maybeT notFound $ toRouteWorkflowScope scope
scope <- maybeT notFound $ fromRouteWorkflowScope rScope
wfs <- selectKeysList [ WorkflowWorkflowScope ==. view _DBWorkflowScope scope ] []
flip mapMaybeM wfs $ \wfId -> do
cID <- encrypt wfId
@ -44,21 +44,21 @@ workflowWorkflowListR scope = do -- not implemented; TODO: FIXME
getGWIWorkflowsR :: WorkflowInstanceName -> Handler Html
getGWIWorkflowsR win
= workflowInstanceWorkflowsR <=< runDB . getKeyBy404 $ UniqueWorkflowInstance win WSGlobal
getGWIWorkflowsR = workflowInstanceWorkflowsR WSGlobal
getSWIWorkflowsR :: SchoolId -> WorkflowInstanceName -> Handler Html
getSWIWorkflowsR ssh win
= workflowInstanceWorkflowsR <=< runDB . getKeyBy404 . UniqueWorkflowInstance win . view _DBWorkflowScope $ WSSchool ssh
getSWIWorkflowsR ssh = workflowInstanceWorkflowsR $ WSSchool ssh
workflowInstanceWorkflowsR :: WorkflowInstanceId -> Handler Html
workflowInstanceWorkflowsR wiId = do -- not implemented; TODO: FIXME
workflowInstanceWorkflowsR :: RouteWorkflowScope -> WorkflowInstanceName -> Handler Html
workflowInstanceWorkflowsR rScope win = do -- not implemented; TODO: FIXME
wfRoutes <- runDB $ do
scope <- maybeT notFound $ fromRouteWorkflowScope rScope
wiId <- getKeyBy404 . UniqueWorkflowInstance win $ scope ^. _DBWorkflowScope
wfs <- selectList [ WorkflowWorkflowInstance ==. Just wiId ] []
flip mapMaybeM wfs $ \(Entity wfId WorkflowWorkflow{..}) -> do
rScope <- toRouteWorkflowScope $ _DBWorkflowScope # workflowWorkflowScope
rScope' <- toRouteWorkflowScope $ _DBWorkflowScope # workflowWorkflowScope
cID <- encrypt wfId
let route = _WorkflowScopeRoute # (rScope, WorkflowWorkflowR cID WWWorkflowR)
let route = _WorkflowScopeRoute # (rScope', WorkflowWorkflowR cID WWWorkflowR)
guardM $ hasReadAccessTo route
return (cID, route)

38
src/Handler/Workflow/Workflow/Workflow.hs
View File

@ -61,29 +61,25 @@ makePrisms ''WorkflowHistoryItemActor
getGWWWorkflowR, postGWWWorkflowR :: CryptoFileNameWorkflowWorkflow -> Handler Html
getGWWWorkflowR = postGWWWorkflowR
postGWWWorkflowR cID = workflowR <=< runDB . maybeT notFound $ ensureScope WSGlobal cID
postGWWWorkflowR = workflowR WSGlobal
getGWWFilesR :: CryptoFileNameWorkflowWorkflow -> WorkflowPayloadLabel -> CryptoUUIDWorkflowStateIndex -> Handler TypedContent
getGWWFilesR wwCID wpl stCID = do
wId <- runDB . maybeT notFound $ ensureScope WSGlobal wwCID
getWorkflowFilesR wId wpl stCID
getGWWFilesR = getWorkflowFilesR WSGlobal
getSWWWorkflowR, postSWWWorkflowR :: SchoolId -> CryptoFileNameWorkflowWorkflow -> Handler Html
getSWWWorkflowR = postSWWWorkflowR
postSWWWorkflowR ssh cID = workflowR <=< runDB . maybeT notFound $ ensureScope (WSSchool ssh) cID
postSWWWorkflowR ssh = workflowR $ WSSchool ssh
getSWWFilesR :: SchoolId -> CryptoFileNameWorkflowWorkflow -> WorkflowPayloadLabel -> CryptoUUIDWorkflowStateIndex -> Handler TypedContent
getSWWFilesR ssh wwCID wpl stCID = do
wId <- runDB . maybeT notFound $ ensureScope (WSSchool ssh) wwCID
getWorkflowFilesR wId wpl stCID
getSWWFilesR ssh = getWorkflowFilesR $ WSSchool ssh
workflowR :: WorkflowWorkflowId -> Handler Html
workflowR wwId = do
cID <- encrypt wwId
(mEdge, rScope, (workflowState, workflowHistory)) <- runDB $ do
workflowR :: RouteWorkflowScope -> CryptoFileNameWorkflowWorkflow -> Handler Html
workflowR rScope cID = do
(mEdge, (workflowState, workflowHistory)) <- runDB $ do
wwId <- decrypt cID
WorkflowWorkflow{..} <- get404 wwId
rScope <- maybeT notFound . toRouteWorkflowScope $ _DBWorkflowScope # workflowWorkflowScope
maybeT notFound . void . assertM (== review _DBWorkflowScope workflowWorkflowScope) $ fromRouteWorkflowScope rScope
mEdgeForm <- workflowEdgeForm (Right wwId) Nothing
let canonRoute = _WorkflowScopeRoute # (rScope, WorkflowWorkflowR cID WWWorkflowR)
wGraph = _DBWorkflowGraph # workflowWorkflowGraph
@ -220,7 +216,7 @@ workflowR wwId = do
| stIx <- [minBound..]
| payload <- tailEx $ inits wState
]
return (mEdge, rScope, (workflowState, workflowHistory))
return (mEdge, (workflowState, workflowHistory))
sequenceOf_ (_Just . _1 . _1 . _Just) mEdge
@ -257,11 +253,16 @@ workflowR wwId = do
WorkflowFieldPayloadW (WFPFile v ) -> absurd v
$(widgetFile "workflows/workflow")
getWorkflowFilesR :: WorkflowWorkflowId -> WorkflowPayloadLabel -> CryptoUUIDWorkflowStateIndex -> Handler TypedContent
getWorkflowFilesR wwId wpl stCID = do
getWorkflowFilesR :: RouteWorkflowScope
-> CryptoFileNameWorkflowWorkflow
-> WorkflowPayloadLabel
-> CryptoUUIDWorkflowStateIndex
-> Handler TypedContent
getWorkflowFilesR rScope wwCID wpl stCID = do
fRefs <- runDB $ do
wwId <- decrypt wwCID
WorkflowWorkflow{..} <- get404 wwId
maybeT notFound . void . assertM (== review _DBWorkflowScope workflowWorkflowScope) $ fromRouteWorkflowScope rScope
stIx <- decryptWorkflowStateIndex wwId stCID
payloads <- maybeT notFound . workflowStateSection stIx $ _DBWorkflowState # workflowWorkflowState
mAuthId <- maybeAuthId
@ -272,7 +273,6 @@ getWorkflowFilesR wwId wpl stCID = do
when (null payloads'') notFound
return payloads''
wwCID <- encrypt wwId
archiveName <- fmap (flip addExtension (unpack extensionZip) . unpack) . ap getMessageRender . pure $ MsgWorkflowWorkflowFilesArchiveName wwCID wpl stCID
serveSomeFiles archiveName $ yieldMany fRefs

34
src/Utils/Workflow.hs
View File

@ -1,7 +1,10 @@
module Utils.Workflow
( _DBWorkflowScope
( RouteWorkflowScope, DBWorkflowScope, IdWorkflowScope, CryptoIDWorkflowScope
, _DBWorkflowScope
, fromRouteWorkflowScope, toRouteWorkflowScope
, DBWorkflowGraph, IdWorkflowGraph
, _DBWorkflowGraph
, DBWorkflowState, IdWorkflowState
, _DBWorkflowState
, decryptWorkflowStateIndex, encryptWorkflowStateIndex
, isTopWorkflowScope
@ -17,7 +20,13 @@ import Crypto.Hash.Algorithms (SHAKE256)
import Language.Haskell.TH (nameBase)
_DBWorkflowScope :: Iso' (WorkflowScope TermId SchoolId CourseId) (WorkflowScope TermIdentifier SchoolShorthand SqlBackendKey)
type RouteWorkflowScope = WorkflowScope TermId SchoolId (TermId, SchoolId, CourseShorthand)
type DBWorkflowScope = WorkflowScope TermIdentifier SchoolShorthand SqlBackendKey
type IdWorkflowScope = WorkflowScope TermId SchoolId CourseId
type CryptoIDWorkflowScope = WorkflowScope TermId SchoolId CryptoUUIDCourse
_DBWorkflowScope :: Iso' IdWorkflowScope DBWorkflowScope
_DBWorkflowScope = iso toScope' toScope
where
toScope' scope = scope
@ -32,25 +41,34 @@ _DBWorkflowScope = iso toScope' toScope
fromRouteWorkflowScope :: ( MonadIO m
, BackendCompatible SqlReadBackend backend
)
=> WorkflowScope TermId SchoolId (TermId, SchoolId, CourseShorthand)
-> MaybeT (ReaderT backend m) (WorkflowScope TermId SchoolId CourseId)
=> RouteWorkflowScope
-> MaybeT (ReaderT backend m) IdWorkflowScope
fromRouteWorkflowScope rScope = hoist (withReaderT $ projectBackend @SqlReadBackend) . forOf (typesCustom @WorkflowChildren @(WorkflowScope TermId SchoolId (TermId, SchoolId, CourseShorthand)) @(WorkflowScope TermId SchoolId CourseId) @(TermId, SchoolId, CourseShorthand) @CourseId) rScope $ \(tid, ssh, csh) -> MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
toRouteWorkflowScope :: ( MonadIO m
, BackendCompatible SqlReadBackend backend
)
=> WorkflowScope TermId SchoolId CourseId
-> MaybeT (ReaderT backend m) (WorkflowScope TermId SchoolId (TermId, SchoolId, CourseShorthand))
=> IdWorkflowScope
-> MaybeT (ReaderT backend m) RouteWorkflowScope
toRouteWorkflowScope scope = hoist (withReaderT $ projectBackend @SqlReadBackend) . forOf (typesCustom @WorkflowChildren @(WorkflowScope TermId SchoolId CourseId) @(WorkflowScope TermId SchoolId (TermId, SchoolId, CourseShorthand)) @CourseId @(TermId, SchoolId, CourseShorthand)) scope $ \cId -> MaybeT (get cId) <&> \Course{..} -> (courseTerm, courseSchool, courseShorthand)
_DBWorkflowGraph :: Iso' (WorkflowGraph FileReference UserId) (WorkflowGraph FileReference SqlBackendKey)
type IdWorkflowGraph = WorkflowGraph FileReference UserId
type DBWorkflowGraph = WorkflowGraph FileReference SqlBackendKey
_DBWorkflowGraph :: Iso' IdWorkflowGraph DBWorkflowGraph
_DBWorkflowGraph = iso toDB fromDB
where
toDB = over (typesCustom @WorkflowChildren @(WorkflowGraph FileReference UserId) @(WorkflowGraph FileReference SqlBackendKey) @UserId @SqlBackendKey) (view _SqlKey)
fromDB = over (typesCustom @WorkflowChildren @(WorkflowGraph FileReference SqlBackendKey) @(WorkflowGraph FileReference UserId) @SqlBackendKey @UserId) (review _SqlKey)
_DBWorkflowState :: Iso' (WorkflowState FileReference UserId) (WorkflowState FileReference SqlBackendKey)
type IdWorkflowState = WorkflowState FileReference UserId
type DBWorkflowState = WorkflowState FileReference SqlBackendKey
_DBWorkflowState :: Iso' IdWorkflowState DBWorkflowState
_DBWorkflowState = iso toDB fromDB
where
toDB = over (typesCustom @WorkflowChildren @(WorkflowState FileReference UserId) @(WorkflowState FileReference SqlBackendKey) @UserId @SqlBackendKey) (view _SqlKey)