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

4
src/Foundation/I18n.hs
View File

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

2
src/Foundation/Navigation.hs
View File

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

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

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

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

@ -9,6 +9,7 @@ module Handler.Utils.Workflow.Form
import Import import Import
import Utils.Form import Utils.Form
import Utils.Workflow
import Handler.Utils.Form import Handler.Utils.Form
@ -92,8 +93,10 @@ instance FromJSON (FileField FileIdent) where
type FormWorkflowGraph = WorkflowGraph FileIdent CryptoUUIDUser
data WorkflowGraphForm = WorkflowGraphForm data WorkflowGraphForm = WorkflowGraphForm
{ wgfGraph :: WorkflowGraph FileIdent CryptoUUIDUser { wgfGraph :: FormWorkflowGraph
, wgfFiles :: Map FileIdent FileReference , wgfFiles :: Map FileIdent FileReference
} deriving (Generic, Typeable) } deriving (Generic, Typeable)
@ -115,7 +118,7 @@ workflowGraphForm template = validateAForm validateWorkflowGraphForm . hoistAFor
WGFTextInput -> apreq yamlField (fslI MsgWorkflowDefinitionGraph) (wgfGraph <$> template) WGFTextInput -> apreq yamlField (fslI MsgWorkflowDefinitionGraph) (wgfGraph <$> template)
WGFFileUpload -> apreq (checkMMap toGraph fromGraph . singleFileField . foldMap fromGraph $ wgfGraph <$> template) (fslI MsgWorkflowDefinitionGraph) (wgfGraph <$> template) WGFFileUpload -> apreq (checkMMap toGraph fromGraph . singleFileField . foldMap fromGraph $ wgfGraph <$> template) (fslI MsgWorkflowDefinitionGraph) (wgfGraph <$> template)
where where
toGraph :: FileUploads -> Handler (Either (SomeMessage UniWorX) (WorkflowGraph FileIdent CryptoUUIDUser)) toGraph :: FileUploads -> Handler (Either (SomeMessage UniWorX) FormWorkflowGraph)
toGraph uploads = runExceptT $ do toGraph uploads = runExceptT $ do
fRefs <- lift . runConduit $ uploads .| C.take 2 .| C.foldMap pure fRefs <- lift . runConduit $ uploads .| C.take 2 .| C.foldMap pure
fRef <- case fRefs of 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 mContent <- for (fileContent $ sourceFile fRef) $ \fContent -> lift . runDB . runConduit $ fContent .| C.fold
content <- maybe (throwE $ SomeMessage MsgWorkflowGraphFormUploadIsDirectory) return mContent content <- maybe (throwE $ SomeMessage MsgWorkflowGraphFormUploadIsDirectory) return mContent
either (throwE . SomeMessage . MsgYAMLFieldDecodeFailure . displayException) return . runCatch $ Yaml.decodeThrow content either (throwE . SomeMessage . MsgYAMLFieldDecodeFailure . displayException) return . runCatch $ Yaml.decodeThrow content
fromGraph :: WorkflowGraph FileIdent CryptoUUIDUser -> FileUploads fromGraph :: FormWorkflowGraph -> FileUploads
fromGraph g = yieldM . runDB $ do fromGraph g = yieldM . runDB $ do
fileModified <- liftIO getCurrentTime fileModified <- liftIO getCurrentTime
fRef <- sinkFile $ File fRef <- sinkFile $ File
@ -181,7 +184,7 @@ validateWorkflowGraphForm = do
toWorkflowGraphForm :: ( MonadHandler m, HandlerSite m ~ UniWorX toWorkflowGraphForm :: ( MonadHandler m, HandlerSite m ~ UniWorX
) )
=> WorkflowGraph FileReference SqlBackendKey => DBWorkflowGraph
-> m WorkflowGraphForm -> m WorkflowGraphForm
toWorkflowGraphForm g = liftHandler . fmap (uncurry WorkflowGraphForm . over _2 Bimap.toMap) . (runStateT ?? Bimap.empty) . ($ g) toWorkflowGraphForm g = liftHandler . fmap (uncurry WorkflowGraphForm . over _2 Bimap.toMap) . (runStateT ?? Bimap.empty) . ($ g)
$ traverseOf (typesCustom @WorkflowChildren) recordFile $ traverseOf (typesCustom @WorkflowChildren) recordFile
@ -204,7 +207,7 @@ toWorkflowGraphForm g = liftHandler . fmap (uncurry WorkflowGraphForm . over _2
fromWorkflowGraphForm :: (MonadHandler m, HandlerSite m ~ UniWorX) fromWorkflowGraphForm :: (MonadHandler m, HandlerSite m ~ UniWorX)
=> WorkflowGraphForm => WorkflowGraphForm
-> m (WorkflowGraph FileReference SqlBackendKey) -> m DBWorkflowGraph
fromWorkflowGraphForm WorkflowGraphForm{..} fromWorkflowGraphForm WorkflowGraphForm{..}
= liftHandler $ wgfGraph = liftHandler $ wgfGraph
& over (typesCustom @WorkflowChildren) (wgfFiles !) & 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 Import
import Utils.Workflow
import Handler.Utils.Workflow.EdgeForm import Handler.Utils.Workflow.EdgeForm
import qualified Data.Set as Set import qualified Data.Set as Set
import qualified Data.Map as Map 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 ensureScope wiScope cID = do
wId <- catchMaybeT (Proxy @CryptoIDError) $ decrypt cID wId <- catchMaybeT (Proxy @CryptoIDError) $ decrypt cID
WorkflowWorkflow{..} <- MaybeT $ get wId WorkflowWorkflow{..} <- MaybeT $ get wId
@ -28,7 +29,7 @@ followEdge :: ( MonadHandler m
, HandlerSite m ~ UniWorX , HandlerSite m ~ UniWorX
, MonadThrow m , 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 followEdge graph edgeRes cState = do
act <- workflowEdgeFormToAction edgeRes act <- workflowEdgeFormToAction edgeRes
followAutomaticEdges graph $ maybe id (<>) cState (act `ncons` mempty) followAutomaticEdges graph $ maybe id (<>) cState (act `ncons` mempty)
@ -43,13 +44,12 @@ followAutomaticEdges :: forall m.
( MonadIO m ( MonadIO m
, MonadThrow m , MonadThrow m
) )
=> WorkflowGraph FileReference UserId => IdWorkflowGraph -> IdWorkflowState -> m IdWorkflowState
-> WorkflowState FileReference UserId -> m (WorkflowState FileReference UserId)
followAutomaticEdges WorkflowGraph{..} = go [] followAutomaticEdges WorkflowGraph{..} = go []
where where
go :: [((WorkflowGraphNodeLabel, Set WorkflowPayloadLabel), (WorkflowGraphEdgeLabel, WorkflowGraphNodeLabel))] -- ^ Should encode all state from which automatic edges decide whether they can be followed go :: [((WorkflowGraphNodeLabel, Set WorkflowPayloadLabel), (WorkflowGraphEdgeLabel, WorkflowGraphNodeLabel))] -- ^ Should encode all state from which automatic edges decide whether they can be followed
-> WorkflowState FileReference UserId -> IdWorkflowState
-> m (WorkflowState FileReference UserId) -> m IdWorkflowState
go automaticEdgesTaken history go automaticEdgesTaken history
| null automaticEdgeOptions = return history | null automaticEdgeOptions = return history
| [(edgeLbl, nodeLbl)] <- automaticEdgeOptions = if | [(edgeLbl, nodeLbl)] <- automaticEdgeOptions = if
@ -74,7 +74,7 @@ followAutomaticEdges WorkflowGraph{..} = go []
filledPayloads = Map.keysSet . Map.filter (not . Set.null) $ workflowStateCurrentPayloads history filledPayloads = Map.keysSet . Map.filter (not . Set.null) $ workflowStateCurrentPayloads history
edgeDecisionInput = (cState, filledPayloads) edgeDecisionInput = (cState, filledPayloads)
checkWorkflowRestriction :: WorkflowState FileReference UserId checkWorkflowRestriction :: IdWorkflowState
-> PredDNF WorkflowGraphRestriction -> PredDNF WorkflowGraphRestriction
-> Bool -> Bool
checkWorkflowRestriction history dnf = maybe False (ofoldr1 (||)) . fromNullable $ map evalConj dnf' 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 :: WorkflowInstanceName -> Handler Html
getGWIDeleteR = postGWIDeleteR getGWIDeleteR = postGWIDeleteR
postGWIDeleteR win postGWIDeleteR = workflowInstanceDeleteR WSGlobal
= workflowInstanceDeleteR <=< runDB . getKeyBy404 $ UniqueWorkflowInstance win WSGlobal
getSWIDeleteR, postSWIDeleteR :: SchoolId -> WorkflowInstanceName -> Handler Html getSWIDeleteR, postSWIDeleteR :: SchoolId -> WorkflowInstanceName -> Handler Html
getSWIDeleteR = postSWIDeleteR getSWIDeleteR = postSWIDeleteR
postSWIDeleteR ssh win postSWIDeleteR ssh = workflowInstanceDeleteR $ WSSchool ssh
= workflowInstanceDeleteR <=< runDB . getKeyBy404 . UniqueWorkflowInstance win . view _DBWorkflowScope $ WSSchool ssh
workflowInstanceDeleteR :: WorkflowInstanceId -> Handler Html workflowInstanceDeleteR :: RouteWorkflowScope -> WorkflowInstanceName -> Handler Html
workflowInstanceDeleteR = error "not implemented" 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 :: WorkflowInstanceName -> Handler Html
getGWIEditR = postGWIEditR getGWIEditR = postGWIEditR
postGWIEditR win postGWIEditR = workflowInstanceEditR WSGlobal
= workflowInstanceEditR <=< runDB . getKeyBy404 $ UniqueWorkflowInstance win WSGlobal
getSWIEditR, postSWIEditR :: SchoolId -> WorkflowInstanceName -> Handler Html getSWIEditR, postSWIEditR :: SchoolId -> WorkflowInstanceName -> Handler Html
getSWIEditR = postSWIEditR getSWIEditR = postSWIEditR
postSWIEditR ssh win postSWIEditR ssh = workflowInstanceEditR $ WSSchool ssh
= workflowInstanceEditR <=< runDB . getKeyBy404 . UniqueWorkflowInstance win . view _DBWorkflowScope $ WSSchool ssh
workflowInstanceEditR :: WorkflowInstanceId -> Handler Html workflowInstanceEditR :: RouteWorkflowScope -> WorkflowInstanceName -> Handler Html
workflowInstanceEditR = error "not implemented" 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
import Handler.Utils.Workflow.Form import Handler.Utils.Workflow.Form
import Utils.Workflow
import qualified Data.Map as Map import qualified Data.Map as Map
import qualified Data.Set as Set import qualified Data.Set as Set
@ -15,8 +16,8 @@ import qualified Data.Set as Set
workflowInstanceScopeForm :: Maybe WorkflowScope' workflowInstanceScopeForm :: Maybe WorkflowScope'
-> FieldSettings UniWorX -> FieldSettings UniWorX
-> Maybe (WorkflowScope TermId SchoolId CourseId) -> Maybe IdWorkflowScope
-> AForm Handler (WorkflowScope TermId SchoolId CourseId) -> AForm Handler IdWorkflowScope
workflowInstanceScopeForm scopeRestr fs mPrev = multiActionA scopeOptions' fs $ classifyWorkflowScope <$> mPrev workflowInstanceScopeForm scopeRestr fs mPrev = multiActionA scopeOptions' fs $ classifyWorkflowScope <$> mPrev
where where
scopeOptions' = maybe id (flip Map.restrictKeys . Set.singleton) scopeRestr scopeOptions scopeOptions' = maybe id (flip Map.restrictKeys . Set.singleton) scopeRestr scopeOptions
@ -42,7 +43,7 @@ workflowInstanceScopeForm scopeRestr fs mPrev = multiActionA scopeOptions' fs $
data WorkflowInstanceForm = WorkflowInstanceForm data WorkflowInstanceForm = WorkflowInstanceForm
{ wifScope :: WorkflowScope TermId SchoolId CourseId { wifScope :: IdWorkflowScope
, wifName :: WorkflowInstanceName , wifName :: WorkflowInstanceName
, wifCategory :: Maybe WorkflowInstanceCategory , wifCategory :: Maybe WorkflowInstanceCategory
, wifDescriptions :: Map Lang (Text, Maybe StoredMarkup) , 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 :: WorkflowInstanceName -> Handler Html
getGWIInitiateR = postGWIInitiateR getGWIInitiateR = postGWIInitiateR
postGWIInitiateR win postGWIInitiateR = workflowInstanceInitiateR WSGlobal
= workflowInstanceInitiateR <=< runDB . getKeyBy404 $ UniqueWorkflowInstance win WSGlobal
getSWIInitiateR, postSWIInitiateR :: SchoolId -> WorkflowInstanceName -> Handler Html getSWIInitiateR, postSWIInitiateR :: SchoolId -> WorkflowInstanceName -> Handler Html
getSWIInitiateR = postSWIInitiateR getSWIInitiateR = postSWIInitiateR
postSWIInitiateR ssh win postSWIInitiateR ssh = workflowInstanceInitiateR $ WSSchool ssh
= workflowInstanceInitiateR <=< runDB . getKeyBy404 . UniqueWorkflowInstance win . view _DBWorkflowScope $ WSSchool ssh
workflowInstanceInitiateR :: WorkflowInstanceId -> Handler Html workflowInstanceInitiateR :: RouteWorkflowScope -> WorkflowInstanceName -> Handler Html
workflowInstanceInitiateR wiId = do workflowInstanceInitiateR rScope win = do
(WorkflowInstance{..}, ((edgeAct, edgeView'), edgeEnc), rScope, mDesc) <- runDB $ do (WorkflowInstance{..}, ((edgeAct, edgeView'), edgeEnc), mDesc) <- runDB $ do
wi@WorkflowInstance{..} <- get404 wiId scope <- maybeT notFound $ fromRouteWorkflowScope rScope
Entity wiId wi@WorkflowInstance{..} <- getBy404 . UniqueWorkflowInstance win $ scope ^. _DBWorkflowScope
edgeForm <- maybeT notFound . MaybeT $ workflowEdgeForm (Left wiId) Nothing edgeForm <- maybeT notFound . MaybeT $ workflowEdgeForm (Left wiId) Nothing
rScope <- maybeT notFound . toRouteWorkflowScope $ _DBWorkflowScope # workflowInstanceScope
descs <- selectList [ WorkflowInstanceDescriptionInstance ==. wiId ] [] descs <- selectList [ WorkflowInstanceDescriptionInstance ==. wiId ] []
mDesc <- runMaybeT $ do mDesc <- runMaybeT $ do
@ -66,7 +64,7 @@ workflowInstanceInitiateR wiId = do
, _WorkflowScopeRoute # ( rScope, WorkflowInstanceListR ) , _WorkflowScopeRoute # ( rScope, WorkflowInstanceListR )
] ]
return (wi, ((edgeAct, edgeView), edgeEnc), rScope, mDesc) return (wi, ((edgeAct, edgeView), edgeEnc), mDesc)
sequence_ edgeAct 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 -> scopes <- fmap (map $ review _DBWorkflowScope . E.unValue) . E.select . E.from $ \workflowInstance ->
return $ workflowInstance E.^. WorkflowInstanceScope return $ workflowInstance E.^. WorkflowInstanceScope
fmap mkOptionList . for scopes $ \scope -> do 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 wScope <- maybeT notFound $ toRouteWorkflowScope scope
MsgRenderer mr <- getMsgRenderer MsgRenderer mr <- getMsgRenderer
return Option return Option
@ -133,7 +133,7 @@ getSchoolWorkflowInstanceListR :: SchoolId -> Handler Html
getSchoolWorkflowInstanceListR = workflowInstanceListR . WSSchool getSchoolWorkflowInstanceListR = workflowInstanceListR . WSSchool
workflowInstanceListR :: WorkflowScope TermId SchoolId (TermId, SchoolId, CourseShorthand) -> Handler Html workflowInstanceListR :: RouteWorkflowScope -> Handler Html
workflowInstanceListR rScope = do workflowInstanceListR rScope = do
instances <- runDB $ do instances <- runDB $ do
dbScope <- maybeT notFound $ view _DBWorkflowScope <$> fromRouteWorkflowScope rScope 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 Import
import Handler.Utils import Handler.Utils
import Handler.Utils.Workflow.Form import Handler.Utils.Workflow.Form
import Utils.Workflow
import Handler.Workflow.Instance.Form import Handler.Workflow.Instance.Form
@ -77,5 +78,5 @@ getSchoolWorkflowInstanceNewR, postSchoolWorkflowInstanceNewR :: SchoolId -> Han
getSchoolWorkflowInstanceNewR = postSchoolWorkflowInstanceNewR getSchoolWorkflowInstanceNewR = postSchoolWorkflowInstanceNewR
postSchoolWorkflowInstanceNewR = workflowInstanceNewR . WSSchool postSchoolWorkflowInstanceNewR = workflowInstanceNewR . WSSchool
workflowInstanceNewR :: WorkflowScope TermId SchoolId CourseId -> Handler Html workflowInstanceNewR :: RouteWorkflowScope -> Handler Html
workflowInstanceNewR = error "not implemented" 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 Import
import Handler.Utils.Workflow.Workflow import Utils.Workflow
getGWWDeleteR, postGWWDeleteR :: CryptoFileNameWorkflowWorkflow -> Handler Html getGWWDeleteR, postGWWDeleteR :: CryptoFileNameWorkflowWorkflow -> Handler Html
getGWWDeleteR = postGWWDeleteR getGWWDeleteR = postGWWDeleteR
postGWWDeleteR cID postGWWDeleteR = workflowDeleteR WSGlobal
= workflowDeleteR <=< runDB . maybeT notFound $ ensureScope WSGlobal cID
getSWWDeleteR, postSWWDeleteR :: SchoolId -> CryptoFileNameWorkflowWorkflow -> Handler Html getSWWDeleteR, postSWWDeleteR :: SchoolId -> CryptoFileNameWorkflowWorkflow -> Handler Html
getSWWDeleteR = postSWWDeleteR getSWWDeleteR = postSWWDeleteR
postSWWDeleteR ssh cID postSWWDeleteR ssh = workflowDeleteR $ WSSchool ssh
= workflowDeleteR <=< runDB . maybeT notFound $ ensureScope (WSSchool ssh) cID
workflowDeleteR :: WorkflowWorkflowId -> Handler Html workflowDeleteR :: RouteWorkflowScope -> CryptoFileNameWorkflowWorkflow -> Handler Html
workflowDeleteR = error "not implemented" 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 Import
import Handler.Utils.Workflow.Workflow import Utils.Workflow
getGWWEditR, postGWWEditR :: CryptoFileNameWorkflowWorkflow -> Handler Html getGWWEditR, postGWWEditR :: CryptoFileNameWorkflowWorkflow -> Handler Html
getGWWEditR = postGWWEditR getGWWEditR = postGWWEditR
postGWWEditR cID postGWWEditR = workflowEditR WSGlobal
= workflowEditR <=< runDB . maybeT notFound $ ensureScope WSGlobal cID
getSWWEditR, postSWWEditR :: SchoolId -> CryptoFileNameWorkflowWorkflow -> Handler Html getSWWEditR, postSWWEditR :: SchoolId -> CryptoFileNameWorkflowWorkflow -> Handler Html
getSWWEditR = postSWWEditR getSWWEditR = postSWWEditR
postSWWEditR ssh cID postSWWEditR ssh = workflowEditR $ WSSchool ssh
= workflowEditR <=< runDB . maybeT notFound $ ensureScope (WSSchool ssh) cID
workflowEditR :: WorkflowWorkflowId -> Handler Html workflowEditR :: RouteWorkflowScope -> CryptoFileNameWorkflowWorkflow -> Handler Html
workflowEditR = error "not implemented" 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 :: SchoolId -> Handler Html
getSchoolWorkflowWorkflowListR = workflowWorkflowListR . WSSchool getSchoolWorkflowWorkflowListR = workflowWorkflowListR . WSSchool
workflowWorkflowListR :: WorkflowScope TermId SchoolId CourseId -> Handler Html workflowWorkflowListR :: RouteWorkflowScope -> Handler Html
workflowWorkflowListR scope = do -- not implemented; TODO: FIXME workflowWorkflowListR rScope = do -- not implemented; TODO: FIXME
wfRoutes <- runDB $ do wfRoutes <- runDB $ do
rScope <- maybeT notFound $ toRouteWorkflowScope scope scope <- maybeT notFound $ fromRouteWorkflowScope rScope
wfs <- selectKeysList [ WorkflowWorkflowScope ==. view _DBWorkflowScope scope ] [] wfs <- selectKeysList [ WorkflowWorkflowScope ==. view _DBWorkflowScope scope ] []
flip mapMaybeM wfs $ \wfId -> do flip mapMaybeM wfs $ \wfId -> do
cID <- encrypt wfId cID <- encrypt wfId
@ -44,21 +44,21 @@ workflowWorkflowListR scope = do -- not implemented; TODO: FIXME
getGWIWorkflowsR :: WorkflowInstanceName -> Handler Html getGWIWorkflowsR :: WorkflowInstanceName -> Handler Html
getGWIWorkflowsR win getGWIWorkflowsR = workflowInstanceWorkflowsR WSGlobal
= workflowInstanceWorkflowsR <=< runDB . getKeyBy404 $ UniqueWorkflowInstance win WSGlobal
getSWIWorkflowsR :: SchoolId -> WorkflowInstanceName -> Handler Html getSWIWorkflowsR :: SchoolId -> WorkflowInstanceName -> Handler Html
getSWIWorkflowsR ssh win getSWIWorkflowsR ssh = workflowInstanceWorkflowsR $ WSSchool ssh
= workflowInstanceWorkflowsR <=< runDB . getKeyBy404 . UniqueWorkflowInstance win . view _DBWorkflowScope $ WSSchool ssh
workflowInstanceWorkflowsR :: WorkflowInstanceId -> Handler Html workflowInstanceWorkflowsR :: RouteWorkflowScope -> WorkflowInstanceName -> Handler Html
workflowInstanceWorkflowsR wiId = do -- not implemented; TODO: FIXME workflowInstanceWorkflowsR rScope win = do -- not implemented; TODO: FIXME
wfRoutes <- runDB $ do wfRoutes <- runDB $ do
scope <- maybeT notFound $ fromRouteWorkflowScope rScope
wiId <- getKeyBy404 . UniqueWorkflowInstance win $ scope ^. _DBWorkflowScope
wfs <- selectList [ WorkflowWorkflowInstance ==. Just wiId ] [] wfs <- selectList [ WorkflowWorkflowInstance ==. Just wiId ] []
flip mapMaybeM wfs $ \(Entity wfId WorkflowWorkflow{..}) -> do flip mapMaybeM wfs $ \(Entity wfId WorkflowWorkflow{..}) -> do
rScope <- toRouteWorkflowScope $ _DBWorkflowScope # workflowWorkflowScope rScope' <- toRouteWorkflowScope $ _DBWorkflowScope # workflowWorkflowScope
cID <- encrypt wfId cID <- encrypt wfId
let route = _WorkflowScopeRoute # (rScope, WorkflowWorkflowR cID WWWorkflowR) let route = _WorkflowScopeRoute # (rScope', WorkflowWorkflowR cID WWWorkflowR)
guardM $ hasReadAccessTo route guardM $ hasReadAccessTo route
return (cID, route) return (cID, route)

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

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

34
src/Utils/Workflow.hs
View File

@ -1,7 +1,10 @@
module Utils.Workflow module Utils.Workflow
( _DBWorkflowScope ( RouteWorkflowScope, DBWorkflowScope, IdWorkflowScope, CryptoIDWorkflowScope
, _DBWorkflowScope
, fromRouteWorkflowScope, toRouteWorkflowScope , fromRouteWorkflowScope, toRouteWorkflowScope
, DBWorkflowGraph, IdWorkflowGraph
, _DBWorkflowGraph , _DBWorkflowGraph
, DBWorkflowState, IdWorkflowState
, _DBWorkflowState , _DBWorkflowState
, decryptWorkflowStateIndex, encryptWorkflowStateIndex , decryptWorkflowStateIndex, encryptWorkflowStateIndex
, isTopWorkflowScope , isTopWorkflowScope
@ -17,7 +20,13 @@ import Crypto.Hash.Algorithms (SHAKE256)
import Language.Haskell.TH (nameBase) 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 _DBWorkflowScope = iso toScope' toScope
where where
toScope' scope = scope toScope' scope = scope
@ -32,25 +41,34 @@ _DBWorkflowScope = iso toScope' toScope
fromRouteWorkflowScope :: ( MonadIO m fromRouteWorkflowScope :: ( MonadIO m
, BackendCompatible SqlReadBackend backend , BackendCompatible SqlReadBackend backend
) )
=> WorkflowScope TermId SchoolId (TermId, SchoolId, CourseShorthand) => RouteWorkflowScope
-> MaybeT (ReaderT backend m) (WorkflowScope TermId SchoolId CourseId) -> 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 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 toRouteWorkflowScope :: ( MonadIO m
, BackendCompatible SqlReadBackend backend , BackendCompatible SqlReadBackend backend
) )
=> WorkflowScope TermId SchoolId CourseId => IdWorkflowScope
-> MaybeT (ReaderT backend m) (WorkflowScope TermId SchoolId (TermId, SchoolId, CourseShorthand)) -> 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) 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 _DBWorkflowGraph = iso toDB fromDB
where where
toDB = over (typesCustom @WorkflowChildren @(WorkflowGraph FileReference UserId) @(WorkflowGraph FileReference SqlBackendKey) @UserId @SqlBackendKey) (view _SqlKey) 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) 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 _DBWorkflowState = iso toDB fromDB
where where
toDB = over (typesCustom @WorkflowChildren @(WorkflowState FileReference UserId) @(WorkflowState FileReference SqlBackendKey) @UserId @SqlBackendKey) (view _SqlKey) toDB = over (typesCustom @WorkflowChildren @(WorkflowState FileReference UserId) @(WorkflowState FileReference SqlBackendKey) @UserId @SqlBackendKey) (view _SqlKey)