From dae2d16677a258a6429cbb11265c1b9f5f5e9335 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Mon, 30 Nov 2020 19:09:30 +0100 Subject: [PATCH] refactor(workflows): better modularize handlers --- src/Foundation/Authorization.hs | 16 ++++----- src/Foundation/I18n.hs | 4 ++- src/Foundation/Navigation.hs | 2 +- src/Handler/Utils/Workflow/CanonicalRoute.hs | 8 ++--- src/Handler/Utils/Workflow/Form.hs | 13 ++++--- src/Handler/Utils/Workflow/Workflow.hs | 14 ++++---- src/Handler/Workflow/Instance/Delete.hs | 8 ++--- src/Handler/Workflow/Instance/Edit.hs | 8 ++--- src/Handler/Workflow/Instance/Form.hs | 7 ++-- src/Handler/Workflow/Instance/Initiate.hs | 18 +++++----- src/Handler/Workflow/Instance/List.hs | 4 +-- src/Handler/Workflow/Instance/New.hs | 3 +- src/Handler/Workflow/Workflow/Delete.hs | 10 +++--- src/Handler/Workflow/Workflow/Edit.hs | 10 +++--- src/Handler/Workflow/Workflow/List.hs | 22 ++++++------ src/Handler/Workflow/Workflow/Workflow.hs | 38 ++++++++++---------- src/Utils/Workflow.hs | 34 +++++++++++++----- 17 files changed, 116 insertions(+), 103 deletions(-) diff --git a/src/Foundation/Authorization.hs b/src/Foundation/Authorization.hs index b07565323..ca773c059 100644 --- a/src/Foundation/Authorization.hs +++ b/src/Foundation/Authorization.hs @@ -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 diff --git a/src/Foundation/I18n.hs b/src/Foundation/I18n.hs index b1188a4c8..d6b2cfad6 100644 --- a/src/Foundation/I18n.hs +++ b/src/Foundation/I18n.hs @@ -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 diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index 2e1c25092..6ff58c1df 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -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 diff --git a/src/Handler/Utils/Workflow/CanonicalRoute.hs b/src/Handler/Utils/Workflow/CanonicalRoute.hs index 6e5082fd7..cb3117475 100644 --- a/src/Handler/Utils/Workflow/CanonicalRoute.hs +++ b/src/Handler/Utils/Workflow/CanonicalRoute.hs @@ -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 diff --git a/src/Handler/Utils/Workflow/Form.hs b/src/Handler/Utils/Workflow/Form.hs index d5da60e2c..f24c1627e 100644 --- a/src/Handler/Utils/Workflow/Form.hs +++ b/src/Handler/Utils/Workflow/Form.hs @@ -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 !) diff --git a/src/Handler/Utils/Workflow/Workflow.hs b/src/Handler/Utils/Workflow/Workflow.hs index 601dd206b..d54c5bab4 100644 --- a/src/Handler/Utils/Workflow/Workflow.hs +++ b/src/Handler/Utils/Workflow/Workflow.hs @@ -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' diff --git a/src/Handler/Workflow/Instance/Delete.hs b/src/Handler/Workflow/Instance/Delete.hs index cff14a90a..e674b0709 100644 --- a/src/Handler/Workflow/Instance/Delete.hs +++ b/src/Handler/Workflow/Instance/Delete.hs @@ -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" diff --git a/src/Handler/Workflow/Instance/Edit.hs b/src/Handler/Workflow/Instance/Edit.hs index 0626d81bb..a9855c501 100644 --- a/src/Handler/Workflow/Instance/Edit.hs +++ b/src/Handler/Workflow/Instance/Edit.hs @@ -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" diff --git a/src/Handler/Workflow/Instance/Form.hs b/src/Handler/Workflow/Instance/Form.hs index 17add03f3..549158565 100644 --- a/src/Handler/Workflow/Instance/Form.hs +++ b/src/Handler/Workflow/Instance/Form.hs @@ -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) diff --git a/src/Handler/Workflow/Instance/Initiate.hs b/src/Handler/Workflow/Instance/Initiate.hs index 4817ab9ff..f9f5677b2 100644 --- a/src/Handler/Workflow/Instance/Initiate.hs +++ b/src/Handler/Workflow/Instance/Initiate.hs @@ -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 diff --git a/src/Handler/Workflow/Instance/List.hs b/src/Handler/Workflow/Instance/List.hs index ecf191265..6c4ca426e 100644 --- a/src/Handler/Workflow/Instance/List.hs +++ b/src/Handler/Workflow/Instance/List.hs @@ -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 diff --git a/src/Handler/Workflow/Instance/New.hs b/src/Handler/Workflow/Instance/New.hs index e3ce88b6f..c02f6d2e8 100644 --- a/src/Handler/Workflow/Instance/New.hs +++ b/src/Handler/Workflow/Instance/New.hs @@ -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" diff --git a/src/Handler/Workflow/Workflow/Delete.hs b/src/Handler/Workflow/Workflow/Delete.hs index acb8e7282..315b7a2ef 100644 --- a/src/Handler/Workflow/Workflow/Delete.hs +++ b/src/Handler/Workflow/Workflow/Delete.hs @@ -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" diff --git a/src/Handler/Workflow/Workflow/Edit.hs b/src/Handler/Workflow/Workflow/Edit.hs index 673c49511..ea84d7f96 100644 --- a/src/Handler/Workflow/Workflow/Edit.hs +++ b/src/Handler/Workflow/Workflow/Edit.hs @@ -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" diff --git a/src/Handler/Workflow/Workflow/List.hs b/src/Handler/Workflow/Workflow/List.hs index 6b1fde4a6..4da5ddd3b 100644 --- a/src/Handler/Workflow/Workflow/List.hs +++ b/src/Handler/Workflow/Workflow/List.hs @@ -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) diff --git a/src/Handler/Workflow/Workflow/Workflow.hs b/src/Handler/Workflow/Workflow/Workflow.hs index 08f2f211b..3afe363ce 100644 --- a/src/Handler/Workflow/Workflow/Workflow.hs +++ b/src/Handler/Workflow/Workflow/Workflow.hs @@ -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 diff --git a/src/Utils/Workflow.hs b/src/Utils/Workflow.hs index ee7c1a32d..bf0830821 100644 --- a/src/Utils/Workflow.hs +++ b/src/Utils/Workflow.hs @@ -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)