diff --git a/Control/Workflow.hs b/Control/Workflow.hs --- a/Control/Workflow.hs +++ b/Control/Workflow.hs @@ -189,8 +189,8 @@ import System.Mem.StableName import Control.Workflow.Stat ---import Debug.Trace ---a !> b= trace b a +import Debug.Trace +a !> b= trace b a type Workflow m = WF Stat m -- not so scary @@ -402,23 +402,30 @@ -- | executes a workflow, but does not mark it as finished even if -- the process ended. --- The workflow will return the las result. +-- It this case, the workflow just will return the last result. +-- If the workflow was gathering data from user questions for a configuration, then this +-- primitive will store them in the log the first time, and can be retrieve it the next time. exec1nc :: ( Monad m, MonadIO m, CMC.MonadCatchIO m) => String -> Workflow m a -> m a -exec1nc str f = - do - v <- getState str f () - case v of - Right (name, f, stat) -> do - r <- runWF1 name f stat False - return r - Left err -> CMC.throw err - `CMC.catch` - (\(e :: CE.SomeException) -> liftIO $ do - let name= keyWF str () - clearRunningFlag name --`debug` ("exception"++ show e) +exec1nc str f =do + v <- getState str f () + case v of + Left err -> CMC.throw err + Right (name, f, stat) -> do + r <- runWF1 name f stat False + return r - CMC.throw e ) + `CMC.catch` + (\(e :: CE.SomeException) -> liftIO $ do + let name= keyWF str () + clearRunningFlag name --`debug` ("exception"++ show e) + CMC.throw e ) + `CMC.finally` + (liftIO . atomically . + when(recover stat) $ do + let ref= self stat + s <- readDBRef ref `justifyM` error ("step: not found: "++ wfName stat) + writeDBRef ref s{recover= False,versions=L.reverse $ versions s}) mv :: MVar Int mv= unsafePerformIO $ newMVar 0 @@ -741,10 +748,10 @@ -- | Re-start the non finished workflows in the list, for all the initial values that they may have been invoked restartWorkflows :: (Serialize a, Typeable a) - => WorkflowList IO a b -- the list of workflows that implement the module + => M.Map String (a -> Workflow IO b) -- the list of workflows that implement the module -> IO () -- Only workflows in the IO monad can be restarted with restartWorkflows restartWorkflows map = do - mw <- liftIO $ getResource ((Running undefined ) ) -- :: IO (Maybe(Stat a)) + mw <- liftIO $ getResource ((Running undefined ) ) -- :: IO (Maybe(Stat a)) case mw of Nothing -> return () Just (Running all) -> mapM_ start . mapMaybe filter . toList $ all @@ -895,11 +902,8 @@ clearRunningFlag name= liftIO $ atomically $ do - mrun <- readDBRef tvRunningWfs - case mrun of - Nothing -> error $ "clearRunningFLag: non existing workflows" ++ name - Just(Running map) -> do - case M.lookup name map of + Running map <-readDBRef tvRunningWfs `onNothing` error ( "clearRunningFLag: non existing workflows" ++ name) + case M.lookup name map of Just(_, Nothing) -> return (map,Nothing) Just(v, Just th) -> do writeDBRef tvRunningWfs . Running $ M.insert name (v, Nothing) map @@ -939,10 +943,33 @@ liftIO $ atomically $ writeDBRef self s' r `seq` return (s',(ref,r)) ) -getWFRef :: Indexable a => Int -> String -> a -> WFRef b -getWFRef n s v= WFRef n $ getDBRef $ keyResource stat0{wfName= keyWF s v} +-- | return a reference to the nth elem of a workflow. The workflow is identified by +-- the workflow string and the parameter. If there is no parameter, use () +-- In case the type of the reference is not the expected, it return an error string.This is only known at runtime +-- +-- In case the workflow is not found it produces an error message +getWFRef ::(Typeable b, Serialize b, Indexable a) => Int -> String -> a -> STM(Either String (WFRef b)) +getWFRef n wfname v= wfref + where + wfref= do + let ref = getDBRef $ keyResource stat0{wfName= keyWF wfname v} + s@Stat{..} <- readDBRef ref `onNothing` error ("getWFRef: not found "++ wfname) + let n1= if recover then n else state - n + mr= (safeFromIDyn $ versions !! n1) `asTypeOf` typeOfRef wfref + case mr `seq` mr of + Left s -> return $ Left s + Right r -> do + let (n,flag)= if recover + then (state - (L.length versions ) -1 ,False) + else (state -1 ,True) + s'= s{references= (n,(toIDyn r,flag)):references } + writeDBRef self s' + return . Right $ WFRef n ref + typeOfRef :: STM(Either String (WFRef a)) -> Either String a + typeOfRef= undefined + --getNRefs wfname= do -- st <- getResource stat0{wfName= wfname} `onNothing` error ("Workflow not found: "++ wfname) -- return $ L.length $ references st @@ -965,15 +992,15 @@ => WFRef a -> STM (Maybe a) readWFRef (WFRef n ref)= do - mr <- readDBRef ref - case mr of + mst <- readDBRef ref + case mst of Nothing -> return Nothing - Just st -> + Just st -> do case L.lookup n $! references st of Just (r,_) -> return . Just $ fromIDyn r Nothing -> do let n1= if recover st then n else state st - n - return . Just . fromIDyn $ versions st !! n1 + return . Just . fromIDyn $ versions st !! n1 !> (show (L.length $ versions st) ++ " "++ show n1) -- flushDBRef ref !> "readWFRef" -- st <- readDBRef ref `justifyM` (error $ "readWFRef: reference has been deleted from storaga: "++ show ref) @@ -1224,7 +1251,8 @@ threadDelay $ delay if delta <= 0 then return () else wait $ delta - (fromIntegral delay ) --- | Return either the result of the STM conputation or Nothing in case of timeout +-- | Return either the result of the STM conputation or Nothing in case of timeout. +-- The computation can retry -- This timeout is persistent. This means that the counter is initialized in the first call to getTimeoutFlag -- no matter if the workflow is restarted. The time during which the worlkflow has been stopped count also. -- Thus, the wait time can exceed the time between failures. @@ -1232,7 +1260,7 @@ withTimeout :: ( MonadIO m, Typeable a, Serialize a)=> Integer -> STM a -> Workflow m (Maybe a) withTimeout time f = do flag <- getTimeoutFlag time - step . liftIO . atomically $ (f >>= return . Just ) + step . liftIO . atomically $ (f >>= return . Just ) `orElse` (waitUntilSTM flag >> return Nothing) diff --git a/Control/Workflow/Stat.hs b/Control/Workflow/Stat.hs --- a/Control/Workflow/Stat.hs +++ b/Control/Workflow/Stat.hs @@ -164,7 +164,7 @@ -- writeResource stat@Stat{..} - | recover = return () + | recover = return () -- !> "recover" | refs <- filter (\(n,(_,written))-> not written) references, not $ null refs= do diff --git a/Workflow.cabal b/Workflow.cabal --- a/Workflow.cabal +++ b/Workflow.cabal @@ -1,5 +1,5 @@ name: Workflow -version: 0.8.0.3 +version: 0.8.0.4 cabal-version: >= 1.6 build-type: Simple license: BSD3 @@ -22,7 +22,7 @@ See "Control.Workflow" for details . In this release: - * timeout miscalculated in time-related primitives fixed + * added getWFRef category: Control, Workflow