├── Control ├── Workflow.hs ├── Workflow.old.hs └── Workflow │ ├── Configuration.hs │ ├── Patterns.hs │ ├── Stat.hs │ ├── Stat.many.hs │ └── Stat.old.hs ├── Demos ├── .tcachedata │ └── workflow │ │ ├── Running │ │ └── Stat │ │ └── count │ │ └── void ├── WFReference.hs ├── buyreserve ├── buyreserve.hs ├── docAprobal.hs ├── fact.hs ├── hello.hs ├── inspect.hs └── sequence.hs ├── IDE.session ├── LICENSE ├── README ├── Setup.lhs ├── Workflow.cabal └── notes.lhs /Control/Workflow.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverlappingInstances 2 | , UndecidableInstances 3 | , ExistentialQuantification 4 | , ScopedTypeVariables 5 | , MultiParamTypeClasses 6 | , FlexibleInstances 7 | , FlexibleContexts 8 | , TypeSynonymInstances 9 | , DeriveDataTypeable 10 | , RecordWildCards 11 | , BangPatterns 12 | , CPP 13 | #-} 14 | {-# OPTIONS -IControl/Workflow #-} 15 | 16 | 17 | {- | A workflow can be seen as a persistent thread. 18 | The workflow monad writes a log that permit to restore the thread 19 | at the interrupted point. `step` is the (partial) monad transformer for 20 | the Workflow monad. A workflow is defined by its name and, optionally 21 | by the key of the single parameter passed. There primitives for starting workflows 22 | also restart the interrupted workflow when it has been in execution previously. 23 | 24 | 25 | A small example that print the sequence of integers in te console 26 | if you interrupt the progam, when restarted again, it will 27 | start from the last printed number 28 | 29 | @ 30 | module Main where 31 | import Control.Workflow 32 | import Control.Concurrent(threadDelay) 33 | import System.IO (hFlush,stdout) 34 | 35 | mcount n= do `step` $ do 36 | putStr (show n ++ \" \") 37 | hFlush stdout 38 | threadDelay 1000000 39 | mcount (n+1) 40 | return () -- to disambiguate the return type 41 | 42 | main= `exec1` \"count\" $ mcount (0 :: Int) 43 | @ 44 | 45 | >>>runghc demos\sequence.hs 46 | >0 1 2 3 47 | >CTRL-C Pressed 48 | >>>runghc demos\sequence.hs 49 | >3 4 5 6 7 50 | >CTRL-C Pressed 51 | >>>runghc demos\sequence.hs 52 | >7 8 9 10 11 53 | ... 54 | 55 | The program restart at the last saved step. 56 | 57 | As you can see, some side effect can be re-executed after recovery if 58 | the log is not complete. This may happen after an unexpected shutdown (in this case) 59 | or due to an asynchronous log writing policy. (see `syncWrite`) 60 | 61 | When the step results are big and complex, use the "Data.RefSerialize" package to define the (de)serialization instances 62 | The log size will be reduced. showHistory` method will print the structure changes 63 | in each step. 64 | 65 | If instead of `RefSerialize`, you use read and show instances, there will 66 | be no reduction. but still it will work, and the log will be readable for debugging purposes. 67 | The RefSerialize istance is automatically derived from Read, Show instances. 68 | 69 | Data.Binary instances are also fine for serialization. To use Binary, just define a binary instance 70 | of your data by using `showpBinary` and `readpBinary`. 71 | 72 | Within the RefSerialize instance of a structure, you can freely mix 73 | Show,Read RefSerialize and Data Binary instances. 74 | 75 | 76 | 77 | "Control.Workflow.Patterns" contains higher level workflow patterns for handling multiple workflows 78 | 79 | "Control.Workflow.Configuration" permits the use of workflows for configuration purposes 80 | 81 | -} 82 | 83 | module Control.Workflow 84 | 85 | ( 86 | Stat 87 | , Workflow -- a useful type name 88 | , WorkflowList 89 | , PMonadTrans (..) 90 | , MonadCatchIO (..) 91 | , HasFork(..) 92 | , throw 93 | , Indexable(..) 94 | , keyWF 95 | -- * Start/restart workflows 96 | , start 97 | , exec 98 | , exec1d 99 | , exec1 100 | , exec1nc 101 | , wfExec 102 | , startWF 103 | , restartWorkflows 104 | , WFErrors(..) 105 | -- * Lifting to the Workflow monad 106 | , step 107 | , getWFStat 108 | , stepExec 109 | --, while 110 | --, label 111 | --, stepControl 112 | --, stepDebug 113 | , unsafeIOtoWF 114 | -- * References to intermediate values in the workflow log 115 | , WFRef 116 | , newWFRef 117 | , stepWFRef 118 | , readWFRef 119 | -- * State manipulation 120 | , writeWFRef 121 | , moveState 122 | -- * Workflow inspection 123 | , waitWFActive 124 | , getAll 125 | --, getStep 126 | , safeFromIDyn 127 | , getWFKeys 128 | , getWFHistory 129 | , waitFor 130 | , waitForSTM 131 | -- * Persistent timeouts 132 | , waitUntilSTM 133 | , getTimeoutFlag 134 | , withTimeout 135 | , withKillTimeout 136 | -- * Trace logging 137 | , logWF 138 | -- * Termination of workflows 139 | , clearRunningFlag 140 | , killThreadWF 141 | , killWF 142 | , delWF 143 | , killThreadWF1 144 | , delWFHistory 145 | , delWFHistory1 146 | -- * Log writing policy 147 | , syncWrite 148 | , SyncMode(..) 149 | -- * Print log history 150 | , showHistory 151 | , isInRecover 152 | -- * Low leve, internal use 153 | , runWF1 154 | , getState 155 | 156 | ) 157 | 158 | where 159 | 160 | import Prelude hiding (catch) 161 | import System.IO.Unsafe 162 | import Control.Monad(when,liftM) 163 | import Control.Applicative 164 | #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 707 165 | import qualified Control.Exception as CE (Exception,AsyncException(ThreadKilled), SomeException, ErrorCall, throwIO, handle,finally,catch) 166 | #else 167 | import qualified Control.Exception as CE (Exception,AsyncException(ThreadKilled), SomeException, ErrorCall, throwIO, handle,finally,catch,block,unblock) 168 | #endif 169 | import Control.Concurrent -- (forkIO,threadDelay, ThreadId, myThreadId, killThread) 170 | import Control.Concurrent.STM 171 | import GHC.Conc(unsafeIOToSTM) 172 | import GHC.Base (maxInt) 173 | 174 | 175 | import Data.ByteString.Lazy.Char8 as B hiding (index) 176 | import Data.ByteString.Lazy as BL(putStrLn) 177 | import Data.List as L 178 | import Data.Typeable 179 | import System.Time 180 | import Control.Monad.Trans 181 | --import Control.Concurrent.MonadIO(HasFork(..),MVar,newMVar,takeMVar,putMVar,readMVar) 182 | 183 | 184 | import System.IO(hPutStrLn, stderr) 185 | import Data.List(elemIndex) 186 | import Data.Maybe 187 | import Data.IORef 188 | import System.IO.Unsafe(unsafePerformIO) 189 | import Data.Map as M(Map,fromList,elems, insert, delete, lookup,toList, fromList,keys) 190 | import qualified Control.Monad.Catch as CMC 191 | import qualified Control.Exception.Extensible as E 192 | 193 | import Data.TCache 194 | import Data.TCache.Defs 195 | import Data.RefSerialize 196 | import Data.Persistent.IDynamic 197 | import Unsafe.Coerce 198 | import System.Mem.StableName 199 | import Control.Workflow.Stat 200 | 201 | --import Debug.Trace 202 | --(!>)= flip trace 203 | 204 | type Workflow m = WF Stat m -- not so scary 205 | 206 | type WorkflowList m a b= M.Map String (a -> Workflow m b) 207 | 208 | instance Monad m => Monad (WF s m) where 209 | return x = WF (\s -> return (s, x)) 210 | WF g >>= f = WF (\s -> do 211 | (s1, x) <- g s 212 | let WF fun= f x 213 | fun s1) 214 | 215 | 216 | 217 | instance (Monad m,Functor m) => Functor (WF s m ) where 218 | fmap f (WF g)= WF (\s -> do 219 | (s1, x) <- g s 220 | return (s1, f x)) 221 | 222 | tvRunningWfs = getDBRef $ keyRunning :: DBRef Stat 223 | 224 | 225 | 226 | -- | Executes a computation inside of the workflow monad whatever the monad encapsulated in the workflow. 227 | -- Warning: this computation is executed whenever 228 | -- the workflow restarts, no matter if it has been already executed previously. This is useful for intializations or debugging. 229 | -- To avoid re-execution when restarting use: @'step' $ unsafeIOtoWF...@ 230 | -- 231 | -- To perform IO actions in a workflow that encapsulates an IO monad, use step over the IO action directly: 232 | -- 233 | -- @ 'step' $ action @ 234 | -- 235 | -- instead of 236 | -- 237 | -- @ 'step' $ unsafeIOtoWF $ action @ 238 | unsafeIOtoWF :: (Monad m) => IO a -> Workflow m a 239 | unsafeIOtoWF x= let y= unsafePerformIO ( x >>= return) in y `seq` return y 240 | 241 | 242 | {- | @PMonadTrans@ permits |to define a partial monad transformer. They are not defined for all kinds of data 243 | but the ones that have instances of certain classes.That is because in the lift instance code there are some 244 | hidden use of these classes. This also may permit an accurate control of effects. 245 | An instance of MonadTrans is an instance of PMonadTrans 246 | -} 247 | class PMonadTrans t m a where 248 | plift :: Monad m => m a -> t m a 249 | 250 | 251 | 252 | -- | @plift= step@ 253 | instance (Monad m 254 | , MonadIO m 255 | , Serialize a 256 | , Typeable a) 257 | => PMonadTrans (WF Stat) m a 258 | where 259 | plift = step 260 | 261 | instance (Monad m, Functor m) => Applicative (WF s m) where 262 | pure x= return x 263 | WF f <*> WF g= WF $ \s -> do 264 | (s1, k) <- f s 265 | (s2, x) <- g s1 266 | return (s2,k x) 267 | 268 | 269 | 270 | -- | An instance of MonadTrans is an instance of PMonadTrans 271 | instance (MonadTrans t, Monad m) => PMonadTrans t m a where 272 | plift= Control.Monad.Trans.lift 273 | 274 | --- | Handle with care: this instance will force 275 | -- the execution at recovery of every liftted IO procedure 276 | -- better use 'step . liftIO' instead of 'liftIO' 277 | 278 | 279 | instance MonadIO m => MonadIO (WF Stat m) where 280 | liftIO= unsafeIOtoWF 281 | 282 | 283 | {- | Adapted from the @MonadCatchIO-mtl@ package. However, in this case it is needed to express serializable constraints about the returned values, 284 | so the usual class definitions for lifting IO functions are not suitable. 285 | -} 286 | 287 | class MonadCatchIO m a where 288 | -- | Generalized version of 'E.catch' 289 | catch :: E.Exception e => m a -> (e -> m a) -> m a 290 | 291 | -- | Generalized version of 'E.block' 292 | block :: m a -> m a 293 | 294 | -- | Generalized version of 'E.unblock' 295 | unblock :: m a -> m a 296 | 297 | 298 | 299 | -- | Generalized version of 'E.throwIO' 300 | throw :: (MonadIO m, E.Exception e) => e -> m a 301 | throw = liftIO . E.throwIO 302 | 303 | 304 | 305 | 306 | 307 | --instance (Serialize a 308 | -- , Typeable a,MonadIO m, CMC.MonadCatch m) 309 | -- => MonadCatchIO (WF Stat m) a where 310 | -- catch exp exc = do 311 | -- expwf <- step $ getTempName 312 | -- excwf <- step $ getTempName 313 | -- step $ do 314 | -- ex <- CMC.catch (exec1d expwf exp >>= return . Right ) $ \e-> return $ Left e 315 | -- 316 | -- case ex of 317 | -- Right r -> return r -- All right 318 | -- Left e ->exec1d excwf (exc e) 319 | -- -- An exception occured in the main workflow 320 | -- -- the exception workflow is executed 321 | -- 322 | -- 323 | -- 324 | -- 325 | -- block exp=WF $ \s -> CMC.block (st exp $ s) 326 | ---- 327 | -- unblock exp= WF $ \s -> CMC.unblock (st exp $ s) 328 | 329 | data WFInfo= WFInfo{ name :: String 330 | , finished :: Bool 331 | , haserror :: Maybe WFErrors } 332 | deriving (Typeable,Read, Show) 333 | 334 | class MonadIO io => HasFork io where 335 | fork :: io () -> io ThreadId 336 | 337 | instance HasFork IO where 338 | fork= forkIO 339 | 340 | instance (HasFork io, MonadIO io 341 | , CMC.MonadCatch io) 342 | => HasFork (WF Stat io) where 343 | fork f = do 344 | (r,info@(WFInfo str finished status)) <- stepWFRef $ getTempName >>= \n -> return(WFInfo n False Nothing) 345 | 346 | WF $ \s -> do 347 | th <- if finished then fork $ return() 348 | else 349 | fork $ 350 | exec1 str f >> labelFinish r str Nothing 351 | `CMC.catch` \(E.ErrorCall str) -> do 352 | liftIO . atomicallySync $ writeWFRef r (WFInfo str True (Just $ WFException str)) -- !> ("ERROR *****"++show e) 353 | killWF1 $ keyWF str () 354 | `CMC.catch` \(e :: E.SomeException) -> do 355 | liftIO . atomicallySync $ writeWFRef r (WFInfo str True (Just . WFException $ show e)) -- !> ("ERROR *****"++show e) 356 | killWF1 $ keyWF str () 357 | 358 | 359 | return (s,th) 360 | where 361 | labelFinish r str err= liftIO . atomicallySync $ writeWFRef r (WFInfo str True err) -- !> "finished" 362 | 363 | 364 | -- | Start or restart an anonymous workflow inside another workflow. 365 | -- Its state is deleted when finished and the result is stored in 366 | -- the parent's WF state. 367 | wfExec 368 | :: (Serialize a, Typeable a 369 | , CMC.MonadCatch m, MonadIO m) 370 | => Workflow m a -> Workflow m a 371 | wfExec f= do 372 | str <- step $ getTempName 373 | step $ exec1 str f 374 | 375 | -- | A version of exec1 that deletes its state after complete execution or thread killed 376 | exec1d :: (MonadIO m, CMC.MonadCatch m) 377 | => String -> (Workflow m b) -> m b 378 | exec1d str f= do 379 | r <- exec1 str f 380 | delit 381 | return r 382 | `CMC.catch` (\e@CE.ThreadKilled -> delit >> throw e) 383 | 384 | where 385 | delit= do 386 | delWF str () 387 | 388 | 389 | 390 | 391 | -- | A version of exec with no seed parameter. 392 | exec1 :: ( Monad m, MonadIO m, CMC.MonadCatch m) 393 | => String -> Workflow m a -> m a 394 | 395 | exec1 str f= exec str (const f) () 396 | 397 | 398 | 399 | 400 | -- | Start or continue a workflow with exception handling 401 | -- the workflow flags are updated even in case of exception 402 | -- `WFerrors` are raised as exceptions 403 | exec :: ( Indexable a, Serialize a, Typeable a 404 | , Monad m, MonadIO m, CMC.MonadCatch m) 405 | => String -> (a -> Workflow m b) -> a -> m b 406 | exec str f x = 407 | (do 408 | v <- getState str f x 409 | case v of 410 | Right (name, f, stat) -> do 411 | r <- runWF name (f x) stat 412 | return r 413 | Left err -> CMC.throwM err) 414 | `CMC.catch` 415 | (\(e :: CE.SomeException) -> liftIO $ do 416 | let name= keyWF str x 417 | clearRunningFlag name --`debug` ("exception"++ show e) 418 | 419 | CMC.throwM e ) 420 | 421 | -- | executes a workflow, but does not mark it as finished even if 422 | -- the process ended. 423 | -- It this case, the workflow just will return the last result. 424 | -- If the workflow was gathering data from user questions for a configuration, then this 425 | -- primitive will store them in the log the first time, and can be retrieve it the next time. 426 | exec1nc :: ( Monad m, MonadIO m, CMC.MonadMask m) 427 | => String -> Workflow m a -> m a 428 | exec1nc str f =do 429 | v <- getState str f () 430 | case v of 431 | Left err -> CMC.throwM err 432 | Right (name, f, stat) -> do 433 | runWF1 name f stat False 434 | 435 | `CMC.catch` 436 | (\(e :: CE.SomeException) -> liftIO $ do 437 | let name= keyWF str () 438 | clearRunningFlag name --`debug` ("exception"++ show e) 439 | CMC.throwM e ) 440 | `CMC.finally` 441 | (liftIO . atomically . 442 | when(recover stat) $ do 443 | let ref= self stat 444 | s <- readDBRef ref `justifyM` error ("step: not found: "++ wfName stat) 445 | writeDBRef ref s{recover= False,versions=L.reverse $ versions s}) 446 | 447 | mv :: MVar Int 448 | mv= unsafePerformIO $ newMVar 0 449 | 450 | getTempName :: MonadIO m => m String 451 | getTempName= liftIO $ do 452 | seq <- takeMVar mv 453 | putMVar mv (seq + 1) 454 | TOD t _ <- getClockTime 455 | return $ "anon"++ show t ++ show seq 456 | 457 | 458 | 459 | 460 | -- Permits the modification of the workflow state by the procedure being lifted 461 | -- if the boolean value is True. This is used internally for control purposes 462 | --stepControl :: ( Monad m 463 | -- , MonadIO m 464 | -- , Serialize a 465 | -- , Typeable a) 466 | -- => m a 467 | -- -> Workflow m a 468 | --stepControl= stepControl1 True 469 | 470 | 471 | -- | Lifts a monadic computation to the WF monad, and provides transparent state loging and resuming the computation 472 | -- Note: Side effect can be repeated at recovery time if the log was not complete before shut down 473 | -- see the integer sequence example, above. 474 | step :: ( MonadIO m 475 | , Serialize a 476 | , Typeable a) 477 | => m a 478 | -> Workflow m a 479 | 480 | step mx= WF(\s -> do 481 | let 482 | recovers= recover s 483 | versionss= versions s 484 | -- !> "vvvvvvvvvvvvvvvvvvv" 485 | -- !> (unpack $ runW $ showp $ versions s) 486 | -- !> (show $ references s) 487 | -- !> (show $ "recover="++ show( recover s)) 488 | -- !> "^^^^^^^^^^^^^^^^^^^" 489 | if recovers && not (L.null versionss) 490 | then 491 | return (s{versions=L.tail versionss }, fromIDyn $ L.head versionss ) 492 | else do 493 | let ref= self s 494 | when (recovers && L.null versionss) $ do 495 | liftIO $ atomically $ do 496 | s' <- readDBRef ref `justifyM` error ("step: not found: "++ wfName s) 497 | writeDBRef ref s'{recover= False,references= references s} 498 | stepExec1 ref mx) 499 | 500 | getWFStat :: Monad m => Workflow m (DBRef Stat) 501 | getWFStat= WF $ \s -> return (s,self s) 502 | 503 | stepExec 504 | :: (Typeable t, Serialize t, MonadIO m) => 505 | DBRef Stat -> m t -> m (DBRef Stat, t) 506 | stepExec ref mx= do 507 | (s,x) <- stepExec1 ref mx 508 | return (self s, x) 509 | 510 | stepExec1 sref mx= do 511 | x' <- mx 512 | liftIO . atomicallySync $ do 513 | s <- readDBRef sref >>= return . fromMaybe (error $ "step: readDBRef: not found:" ++ keyObjDBRef sref) 514 | let versionss= versions s 515 | dynx= toIDyn x' 516 | ver= dynx: versionss 517 | s'= s{ recover= False, versions = ver, state= state s+1} 518 | writeDBRef sref s' 519 | return (s', x') 520 | 521 | --undoStep :: Monad m => Workflow m () 522 | --undoStep= WF $ \s@Stat{..} -> return(s{state=state-1, versions= L.tail versions},()) 523 | 524 | -- | True if the workflow in recovery mode, reading the log to recover the process state 525 | isInRecover :: Monad m => Workflow m Bool 526 | isInRecover = WF(\s@Stat{..} -> 527 | if recover && not (L.null versions ) then return(s,True ) 528 | else if recover== True then return(s{recover=False}, False) 529 | else return (s,False)) 530 | 531 | -- | For debugging purposes. 532 | -- At recovery time, instead of returning the stored value from the log 533 | -- , stepDebug executes the computation 'f' as normally. 534 | -- . It permits the exact re-execution of a workflow process 535 | stepDebug :: ( Monad m 536 | , MonadIO m 537 | , Serialize a 538 | , Typeable a) 539 | => m a 540 | -> Workflow m a 541 | stepDebug f = r 542 | where 543 | r= do 544 | WF(\s -> 545 | let stat= state s 546 | 547 | 548 | in case recover s && not(L.null $ versions s) of 549 | True -> f >>= \x -> return (s{versions= L.tail $ versions s},x) 550 | False -> stepExec1 (self s) f) 551 | 552 | -- Executes a computation 'f' in a loop while the return value meets the condition 'cond' is met. 553 | -- At recovery time, the current state of the loop is restored. 554 | -- The loop restart at the last internal state that was (saved) before shutdown. 555 | -- 556 | -- The use of 'while' permits a faster recovery when the loop has many steps and the log is very long, as is the case in 557 | -- MFlow applications, 558 | --while 559 | -- :: MonadIO m => 560 | -- (b -> Bool) -> Workflow m b -> Workflow m b 561 | --while cond f= do 562 | -- n <- WF $ \s -> return (s,state s - L.length (versions s)) 563 | ---- do 564 | ---- let versionss= versions s 565 | ---- if recover s && not (L.null versionss) 566 | ---- then return (s{versions=L.tail versionss }, fromIDyn $ L.head versionss ) 567 | ---- 568 | ---- else return(s{recover= False, state=state s + 1 569 | ---- ,versions= (toIDyn $ state s):versionss} 570 | ---- ,state s) 571 | -- while1 n 572 | -- where 573 | -- while1 n =do 574 | -- label n 575 | -- x <- f 576 | -- if cond x 577 | -- then while1 n 578 | -- else return x 579 | -- 580 | --data Label= Label Int deriving (Eq,Typeable,Read,Show) 581 | --label n = do 582 | -- let !label= Label n 583 | -- r <- isInRecover 584 | -- if r 585 | -- then WF(\s@Stat{..} -> 586 | -- let !label@(Label n) = fromIDyn $ L.head versions 587 | -- !vers = filterMax (\d -> Just label /= safeFromIDyn d) versions -- !> (show label) 588 | -- in return (s{versions= L.tail vers}, fromIDyn . L.head $ vers )) 589 | -- else do 590 | -- step $ return label 591 | -- where 592 | -- filterMax f xs= 593 | -- case L.dropWhile f (L.tail xs) of 594 | -- [] -> xs 595 | -- [_] -> xs 596 | -- xs' -> filterMax f xs' 597 | -- 598 | 599 | 600 | 601 | -- | Start or continue a workflow . 602 | -- 'WFErrors' and exceptions are returned as @Left err@ (even if they were triggered as exceptions). 603 | -- Other exceptions are returned as @Left (Exception e)@ 604 | -- use `killWF` or `delWF` in case of error to clear the log. 605 | start 606 | :: ( CMC.MonadCatch m 607 | , MonadIO m 608 | , Indexable a 609 | , Serialize a 610 | , Typeable a) 611 | => String -- ^ name that identifies the workflow. 612 | -> (a -> Workflow m b) -- ^ workflow to execute 613 | -> a -- ^ initial value (ever use the initial value for restarting the workflow) 614 | -> m (Either WFErrors b) -- ^ result of the computation 615 | start namewf f1 v = do 616 | ei <- getState namewf f1 v 617 | case ei of 618 | Left error -> return $ Left error 619 | Right (name, f, stat) -> 620 | runWF name (f v) stat >>= return . Right 621 | `CMC.catch` 622 | (\(e :: WFErrors) -> do 623 | let name= keyWF namewf v 624 | clearRunningFlag name 625 | return $ Left e ) 626 | `CMC.catch` 627 | (\(E.ErrorCall msg) ->do 628 | let name= keyWF namewf v 629 | clearRunningFlag name 630 | return . Left $ WFException msg ) 631 | `CMC.catch` 632 | (\(e :: CE.SomeException) -> liftIO $ do 633 | let name= keyWF namewf v 634 | clearRunningFlag name 635 | return . Left $ WFException $ show e ) 636 | 637 | 638 | 639 | 640 | -- | Return conditions from the invocation of start/restart primitives 641 | data WFErrors = NotFound | AlreadyRunning | Timeout | WFException String deriving (Typeable, Read, Show) 642 | 643 | --instance Show WFErrors where 644 | -- show NotFound= "Not Found" 645 | -- show AlreadyRunning= "Already Running" 646 | -- show Timeout= "Timeout" 647 | -- show (Exception e)= "Exception: "++ show e 648 | 649 | --instance Serialize WFErrors where 650 | -- showp NotFound= insertString "NotFound" 651 | -- showp AlreadyRunning= insertString "AlreadyRunning" 652 | -- showp Timeout= insertString "Timeout" 653 | -- showp (Exception e)= insertString "Exception: ">> showp e 654 | -- 655 | -- readp= choice[notfound,already,timeout, exc] 656 | -- where 657 | -- notfound= symbol "NotFound" >> return NotFound 658 | -- already= symbol "AlreadyRunning" >> return AlreadyRunning 659 | -- timeout= symbol "Timeout" >> return Timeout 660 | -- exc= symbol "Exception" >> readp >>= \s -> return (Exception s) 661 | 662 | instance CE.Exception WFErrors 663 | 664 | 665 | 666 | {- 667 | lookup for any workflow for the entry value v 668 | if namewf is found and is running, return arlready running 669 | if is not runing, restart it 670 | else start anew. 671 | -} 672 | 673 | 674 | getState :: (Monad m, MonadIO m, Indexable a, Serialize a, Typeable a) 675 | => String -> x -> a 676 | -> m (Either WFErrors (String, x, Stat)) 677 | getState namewf f v= liftIO . atomically $ getStateSTM 678 | where 679 | getStateSTM = do 680 | mrunning <- readDBRef tvRunningWfs 681 | case mrunning of 682 | Nothing -> do 683 | writeDBRef tvRunningWfs (Running $ fromList []) 684 | getStateSTM 685 | Just(Running map) -> do 686 | let key= keyWF namewf v 687 | dynv= toIDyn v 688 | stat1= stat0{wfName= key,versions=[dynv],state=1, self= sref`seq`sref} 689 | sref= getDBRef $ keyResource stat1 690 | case M.lookup key map of 691 | Nothing -> do -- no workflow started for this object 692 | mythread <- unsafeIOToSTM $ myThreadId 693 | safeIOToSTM $ delResource stat1 >> writeResource stat1 694 | writeDBRef tvRunningWfs . Running $ M.insert key (namewf,Just mythread) map 695 | writeDBRef sref stat1 696 | return $ Right (key, f, stat1) -- !> "NEW WF" 697 | 698 | Just (wf, started) -> -- a workflow has been initiated for this object 699 | if isJust started 700 | then return $ Left AlreadyRunning -- !> "already running" 701 | else do 702 | mst <- readDBRef sref -- !> "has been running but not running now" 703 | stat' <- case mst of 704 | Nothing -> return stat1 -- error $ "getState: Workflow not found: "++ key 705 | Just s' -> do 706 | -- the thread may have been killed by an exception when running 707 | s <- case recover s' of 708 | True -> return s' 709 | False -> do 710 | s'' <- safeIOToSTM $ readResource s' `onNothing` return stat1 711 | let i= state s'' 712 | j= state s' 713 | return s'{versions= versions s'' ++ L.reverse ( L.take ( j - i) $ versions s')} 714 | if isJust (timeout s) 715 | then do 716 | tnow <- unsafeIOToSTM getTimeSeconds 717 | if lastActive s+ fromJust(timeout s) > tnow -- !>("lastActive="++show (lastActive s) ++ "tnow="++show tnow) 718 | then 719 | return s{recover= True,timeout=Nothing} 720 | else 721 | -- has been inactive for too much time, clean it 722 | return stat1 723 | 724 | else return s{recover= True} 725 | 726 | 727 | writeDBRef sref stat' 728 | mythread <- unsafeIOToSTM myThreadId 729 | writeDBRef tvRunningWfs . Running $ M.insert key (namewf,Just mythread) map 730 | 731 | return $ Right (key, f, stat') 732 | 733 | 734 | 735 | runWF :: ( Monad m, MonadIO m) 736 | => String -> Workflow m b -> Stat -> m b 737 | runWF n f s = runWF1 n f s True 738 | 739 | 740 | 741 | runWF1 n f s clear= do 742 | (s', v') <- st f s{versions= L.tail $ versions s} 743 | liftIO $ if clear then clearFromRunningList n 744 | else clearRunningFlag n >> return () 745 | return v' 746 | where 747 | 748 | -- eliminate the thread from the list of running workflows but leave the state 749 | clearFromRunningList n = atomicallySync $ do 750 | Just(Running map) <- readDBRef tvRunningWfs -- !> "clearFormRunning" 751 | writeDBRef tvRunningWfs . Running $ M.delete n map 752 | -- flushDBRef (getDBRef n :: DBRef Stat) 753 | 754 | -- | Start or continue a workflow from a list of workflows with exception handling. 755 | -- see 'start' for details about exception and error handling 756 | startWF 757 | :: ( CMC.MonadCatch m, MonadIO m 758 | , Serialize a, Serialize b 759 | , Typeable a 760 | , Indexable a) 761 | => String -- ^ Name of workflow in the workflow list 762 | -> a -- ^ Initial value (ever use the initial value even to restart the workflow) 763 | -> WorkflowList m a b -- ^ function to execute 764 | -> m (Either WFErrors b) -- ^ Result of the computation 765 | startWF namewf v wfs= 766 | case M.lookup namewf wfs of 767 | Nothing -> return $ Left NotFound 768 | Just f -> start namewf f v 769 | 770 | 771 | 772 | -- | Re-start the non finished workflows in the list, for all the initial values 773 | -- that they may have been invoked. The list contain he identifiers of the workflows and 774 | -- the procedures to be called. All the workflows initiated with exec* or start* will be 775 | -- restarted with all possible seed values. 776 | 777 | restartWorkflows 778 | :: (Serialize a, Typeable a) 779 | => M.Map String (a -> Workflow IO b) -- the list of workflows that implement the module 780 | -> IO () -- Only workflows in the IO monad can be restarted with restartWorkflows 781 | restartWorkflows map = do 782 | mw <- atomically $ readDBRef tvRunningWfs -- :: IO (Maybe(Stat a)) 783 | case mw of 784 | Nothing -> return () 785 | Just (Running all) -> mapM_ start . mapMaybe filter . toList $ all 786 | where 787 | filter (a, (b,Nothing)) = Just (b, a) 788 | filter _ = Nothing 789 | 790 | start (key, kv)= do 791 | let mf= M.lookup key map 792 | case mf of 793 | Nothing -> return () 794 | Just f -> do 795 | let st0 = stat0{wfName = kv} 796 | mst <- liftIO $ getResource st0 797 | case mst of 798 | Nothing -> error $ "restartWorkflows: workflow not found "++ keyResource st0 799 | Just st-> do 800 | liftIO . forkIO $ runWF key (f (fromIDyn . L.head $ versions st )) st{recover=True} >> return () 801 | return () 802 | -- ei <- getState namewf f1 v 803 | -- case ei of 804 | -- Left error -> return $ Left error 805 | -- Right (name, f, stat) -> 806 | 807 | 808 | -- | Return all the steps of the workflow log. The values are dynamic 809 | -- 810 | -- to get all the steps with result of type Int: 811 | -- @all <- `getAll` 812 | -- let lfacts = mapMaybe `safeFromIDyn` all :: [Int]@ 813 | getAll :: Monad m => Workflow m [IDynamic] 814 | getAll= WF(\s -> return (s, versions s)) 815 | 816 | --getStep 817 | -- :: (Serialize a, Typeable a, Monad m) 818 | -- => Int -- ^ the step number. If negative, count from the current state backwards 819 | -- -> Workflow m a -- ^ return the n-tn intermediate step result 820 | --getStep i= WF(\s -> do 821 | -- 822 | -- let stat= state s 823 | -- 824 | -- return (s, if i > 0 && i < stat then fromIDyn $ versions s !! (stat -i-1) 825 | -- else if i <= 0 && i > -stat then fromIDyn $ versions s !! (stat - ind +i-1) 826 | -- else error "getStep: wrong index") 827 | -- ) 828 | 829 | -- | Return the keys of the workflows that are running with a given prefix 830 | getWFKeys :: String -> IO [String] 831 | getWFKeys wfname= do 832 | mwfs <- atomically $ readDBRef tvRunningWfs 833 | case mwfs of 834 | Nothing -> return [] 835 | Just (Running wfs) -> return $ Prelude.filter (L.isPrefixOf wfname) $ M.keys wfs 836 | 837 | -- | Return the current state of the computation, in the IO monad 838 | getWFHistory :: (Indexable a, Serialize a) => String -> a -> IO (Maybe Stat) 839 | getWFHistory wfname x= getResource stat0{wfName= keyWF wfname x} 840 | 841 | -- | Delete the history of a workflow. 842 | -- Be sure that this WF has finished. 843 | 844 | --{-# DEPRECATED delWFHistory, delWFHistory1 "use delWF instead" #-} 845 | 846 | delWFHistory name1 x = do 847 | let name= keyWF name1 x 848 | delWFHistory1 name 849 | 850 | delWFHistory1 name = do 851 | let proto= stat0{wfName= name} 852 | -- when (isJust mdir) $ 853 | -- moveFile (defPath proto ++ key proto) (defPath proto ++ fromJust mdir) 854 | atomically . withSTMResources [] $ const resources{ toDelete= [proto] } 855 | 856 | -- | wait until the workflow is restarted 857 | waitWFActive wf= do 858 | r <- threadWF wf 859 | case r of -- wait for change in the wofkflow state 860 | Just (_, Nothing) -> retry 861 | _ -> return () 862 | where 863 | threadWF wf= do 864 | Just(Running map) <- readDBRef tvRunningWfs 865 | return $ M.lookup wf map 866 | 867 | 868 | -- | Kill the executing thread if not killed, but not its state. 869 | -- `exec` `start` or `restartWorkflows` will continue the workflow 870 | killThreadWF :: ( Indexable a 871 | , Serialize a 872 | 873 | , Typeable a 874 | , MonadIO m) 875 | => String -> a -> m() 876 | killThreadWF wfname x= do 877 | let name= keyWF wfname x 878 | killThreadWF1 name 879 | 880 | -- | A version of `KillThreadWF` for workflows started wit no parameter by `exec1` 881 | killThreadWF1 :: MonadIO m => String -> m() 882 | killThreadWF1 name= killThreadWFm name >> return () 883 | 884 | killThreadWFm name= do 885 | (map,f) <- clearRunningFlag name 886 | case f of 887 | Just th -> liftIO $ killThread th 888 | Nothing -> return() 889 | return map 890 | 891 | 892 | 893 | -- | Kill the process (if running) and drop it from the list of 894 | -- restart-able workflows. Its state history remains , so it can be inspected with 895 | -- `getWfHistory` `showHistory` and so on. 896 | -- 897 | -- When the workflow has been called with no parameter, use: () 898 | -- 899 | killWF :: (Indexable a,MonadIO m) => String -> a -> m () 900 | killWF name1 x= do 901 | let name= keyWF name1 x 902 | killWF1 name 903 | 904 | 905 | killWF1 :: MonadIO m => String -> m () 906 | killWF1 name = do 907 | map <- killThreadWFm name 908 | liftIO . atomically . writeDBRef tvRunningWfs . Running $ M.delete name map 909 | return () 910 | 911 | -- | Delete the WF from the running list and delete the workflow state from persistent storage. 912 | -- Use it to perform cleanup if the process has been killed. 913 | -- 914 | -- When the workflow has been called with no parameter, use: () 915 | delWF :: ( Indexable a 916 | , MonadIO m 917 | , Typeable a) 918 | => String -> a -> m() 919 | delWF name1 x= do 920 | let name= keyWF name1 x 921 | delWF1 name 922 | 923 | 924 | 925 | delWF1 :: MonadIO m => String -> m() 926 | delWF1 name= liftIO $ atomicallySync $ do 927 | mrun <- readDBRef tvRunningWfs 928 | case mrun of 929 | Nothing -> return() 930 | Just (Running map) -> do 931 | writeDBRef tvRunningWfs . Running $! M.delete name map 932 | delDBRef (getDBRef $ keyResource $ stat0{wfName= name} :: DBRef Stat) 933 | 934 | 935 | clearRunningFlag name= liftIO $ atomically $ do 936 | Running map <- readDBRef tvRunningWfs `onNothing` error ( "clearRunningFLag: no workflow list" ++ name) 937 | case M.lookup name map of 938 | Just(_, Nothing) -> return (map,Nothing) 939 | Just(v, Just th) -> do 940 | writeDBRef tvRunningWfs . Running $ M.insert name (v, Nothing) map 941 | -- flushDBRef (getDBRef $ keyResource stat0{wfName=name} :: DBRef Stat) 942 | return (map,Just th) 943 | Nothing -> 944 | return (map, Nothing) 945 | 946 | 947 | 948 | 949 | 950 | -- | Log a value in the workflow log and return a reference to it. 951 | -- 952 | -- @newWFRef x= `stepWFRef` (return x) >>= return . fst@ 953 | newWFRef :: ( Serialize a 954 | , Typeable a 955 | , MonadIO m 956 | , CMC.MonadCatch m) 957 | => a -> Workflow m (WFRef a) 958 | newWFRef x= stepWFRef (return x) >>= return . fst 959 | 960 | -- | Execute an step and return a reference to the result besides the result itself 961 | -- 962 | stepWFRef :: ( Serialize a 963 | , Typeable a 964 | , MonadIO m) 965 | => m a -> Workflow m (WFRef a,a) 966 | stepWFRef exp= do 967 | r <- step exp -- !> "stepWFRef" 968 | WF(\s@Stat{..} -> do 969 | let (n,flag)= if recover 970 | then (state - (L.length versions) -1 ,False) 971 | else (state -1 ,True) 972 | ref = WFRef n self 973 | s'= s{references= (n,(toIDyn r,flag)):references } 974 | liftIO $ atomically $ writeDBRef self s' 975 | r `seq` return (s',(ref,r)) ) 976 | 977 | 978 | 979 | -- | Read the content of a Workflow reference. Note that its result is not in the Workflow monad 980 | readWFRef :: ( Serialize a 981 | , Typeable a) 982 | => WFRef a 983 | -> STM (Maybe a) 984 | readWFRef (WFRef n ref)= do 985 | mst <- readDBRef ref 986 | case mst of 987 | Nothing -> return Nothing 988 | Just st -> do 989 | case L.lookup n $! references st of 990 | Just (r,_) -> return . Just $ fromIDyn r 991 | Nothing -> do 992 | let n1= if recover st then n else state st - n 993 | return . Just . fromIDyn $ versions st !! n1 -- !> (show (L.length $ versions st) ++ " "++ show n1) 994 | 995 | 996 | 997 | 998 | justifyM io y= io >>= return . fromMaybe y 999 | 1000 | -- | Writes a new value en in the workflow reference, that is, in the workflow log. 1001 | -- Why would you use this?. Don't do that!. modifiying the content of the workflow log would 1002 | -- change the excution flow when the workflow restarts. This metod is used internally in the package. 1003 | -- The best way to communicate with a workflow is trough a persistent queue, using "Data.Persistent.Collection": 1004 | -- 1005 | -- @worflow= exec1 "wf" do 1006 | -- r <- `stepWFRef` expr 1007 | -- `push` \"queue\" r 1008 | -- back <- `pop` \"queueback\" 1009 | -- ... 1010 | -- @ 1011 | 1012 | writeWFRef :: ( Serialize a 1013 | , Typeable a) 1014 | => WFRef a 1015 | -> a 1016 | -> STM () 1017 | writeWFRef r@(WFRef n ref) x= do 1018 | mr <- readDBRef ref 1019 | case mr of 1020 | Nothing -> error $ "writeWFRef: workflow does not exist: " ++ show ref 1021 | Just st@Stat{..} -> 1022 | writeDBRef ref st{references= add x references} -- !> ("writeWFREF"++ show r) 1023 | 1024 | where 1025 | add x xs= (n,(toIDyn x,False)) : L.filter (\(n',_) -> n/=n') xs 1026 | -- flushDBRef ref !> "writeWFRef" 1027 | -- s <- safeIOToSTM $ readResourceByKey (keyObjDBRef ref) `justifyM` (error $ "writeWFRef: reference has been deleted from storaga: "++ show ref) 1028 | -- let elems= versions s ++ (L.reverse $ L.take (state s' - state s) (versions s')) 1029 | -- 1030 | -- (h,t)= L.splitAt n elems 1031 | -- elems'= h ++ (toIDyn x:tail' t) 1032 | -- 1033 | -- tail' []= [] 1034 | -- tail' t = L.tail t 1035 | 1036 | 1037 | 1038 | -- elems `seq` writeDBRef ref s{ versions= elems'} 1039 | -- safeIOToSTM $ delResource s >> writeResource s{ versions= L.map tosave $ L.reverse elems'} 1040 | -- writeDBRef ref s' 1041 | 1042 | 1043 | -- | Moves the state of workflow with a seed value to become the state of other seed value 1044 | -- This may be of interest when the entry value 1045 | -- changes its key value but should not initiate a new workflow 1046 | -- but continues with the current one 1047 | 1048 | moveState :: (MonadIO m 1049 | , Indexable a 1050 | , Serialize a 1051 | , Typeable a) 1052 | =>String -> a -> a -> m () 1053 | moveState wf t t'= liftIO $ do 1054 | atomicallySync $ do 1055 | mrun <- readDBRef tvRunningWfs 1056 | case mrun of 1057 | Nothing -> return() 1058 | Just (Running map) -> do 1059 | let mr= M.lookup n map 1060 | let th= case mr of Nothing -> Nothing; Just(_,mt)-> mt 1061 | let map'= M.insert n' (wf,th) $ M.delete n map 1062 | writeDBRef tvRunningWfs $ Running map' 1063 | withSTMResources[stat0{wfName= n}] $ change n 1064 | 1065 | where 1066 | n = keyWF wf t 1067 | n'= keyWF wf t' 1068 | change n [Nothing]= error $ "moveState: Workflow not found: "++ show n 1069 | change n [Just s] = resources{toAdd= [s{wfName=n' 1070 | ,versions = toIDyn t': L.tail( versions s) }] 1071 | ,toDelete=[s]} 1072 | 1073 | 1074 | 1075 | 1076 | 1077 | -- | Log a message in the workflow history. I can be printed out with 'showHistory' 1078 | -- The message is printed in the standard output too 1079 | logWF :: MonadIO m => String -> Workflow m () 1080 | logWF str= do 1081 | str <- step . liftIO $ do 1082 | time <- getClockTime >>= toCalendarTime >>= return . calendarTimeToString 1083 | Prelude.putStrLn str 1084 | return $ time ++ ": "++ str 1085 | WF $ \s -> str `seq` return (s, ()) 1086 | 1087 | 1088 | 1089 | --------- event handling-------------- 1090 | 1091 | 1092 | -- | Wait until a TCache object (with a certaing key) meet a certain condition (useful to check external actions ) 1093 | -- NOTE if anoter process delete the object from te cache, then waitForData will no longer work 1094 | -- inside the wokflow, it can be used by lifting it : 1095 | -- do 1096 | -- x <- step $ .. 1097 | -- y <- step $ waitForData ... 1098 | -- .. 1099 | 1100 | waitForData :: (IResource a, Typeable a) 1101 | => (a -> Bool) -- ^ The condition that the retrieved object must meet 1102 | -> a -- ^ a partially defined object for which keyResource can be extracted 1103 | -> IO a -- ^ return the retrieved object that meet the condition and has the given key 1104 | waitForData f x = atomically $ waitForDataSTM f x 1105 | 1106 | waitForDataSTM :: (IResource a, Typeable a) 1107 | => (a -> Bool) -- ^ The condition that the retrieved object must meet 1108 | -> a -- ^ a partially defined object for which keyResource can be extracted 1109 | -> STM a -- ^ return the retrieved object that meet the condition and has the given key 1110 | waitForDataSTM filter x= do 1111 | tv <- newDBRef x 1112 | do 1113 | mx <- readDBRef tv >>= \v -> return $ cast v 1114 | case mx of 1115 | Nothing -> retry 1116 | Just x -> 1117 | case filter x of 1118 | False -> retry 1119 | True -> return x 1120 | 1121 | -- | Observe the workflow log until a condition is met. 1122 | waitFor 1123 | :: ( Indexable a, Serialize a, Serialize b, Typeable a 1124 | , Indexable b, Typeable b) 1125 | => (b -> Bool) -- ^ The condition that the retrieved object must meet 1126 | -> String -- ^ The workflow name 1127 | -> a -- ^ the INITIAL value used in the workflow to start it 1128 | -> IO b -- ^ The first event that meet the condition 1129 | waitFor filter wfname x= atomically $ waitForSTM filter wfname x 1130 | 1131 | waitForSTM 1132 | :: ( Indexable a, Serialize a, Serialize b, Typeable a 1133 | , Indexable b, Typeable b) 1134 | => (b -> Bool) -- ^ The condition that the retrieved object must meet 1135 | -> String -- ^ The workflow name 1136 | -> a -- ^ The INITIAL value used in the workflow 1137 | -> STM b -- ^ The first event that meet the condition 1138 | waitForSTM filter wfname x= do 1139 | let name= keyWF wfname x 1140 | let tv= getDBRef . keyResource $ stat0{wfName= name} -- `debug` "**waitFor***" 1141 | 1142 | mmx <- readDBRef tv 1143 | case mmx of 1144 | Nothing -> error ("waitForSTM: Workflow does not exist: "++ name) 1145 | Just mx -> do 1146 | let Stat{ versions= d:_}= mx 1147 | case safeFromIDyn d of 1148 | Left _ -> retry -- `debug` "waithFor retry Nothing" 1149 | Right x -> 1150 | case filter x of 1151 | False -> retry -- `debug` "waitFor false filter retry" 1152 | True -> return x -- `debug` "waitfor return" 1153 | 1154 | 1155 | 1156 | --{-# DEPRECATED waitUntilSTM, getTimeoutFlag "use withTimeout instead" #-} 1157 | 1158 | -- | Start the timeout and return the flag to be monitored by 'waitUntilSTM' 1159 | -- This timeout is persistent. This means that the counter is initialized in the first call to getTimeoutFlag 1160 | -- no matter if the workflow is restarted. The time during which the worlkflow has been stopped count also. 1161 | -- Thus, the wait time can exceed the time between failures. 1162 | -- when timeout is 0 means no timeout. 1163 | getTimeoutFlag 1164 | :: MonadIO m 1165 | => Integer -- ^ wait time in secods. This timing start from the first time that the timeout was started on. Sucessive restarts of the workflow will respect this timing 1166 | -> Workflow m (TVar Bool) -- ^ the returned flag in the workflow monad 1167 | getTimeoutFlag 0 = WF $ \s -> liftIO $ newTVarIO False >>= \tv -> return (s, tv) 1168 | getTimeoutFlag t = do 1169 | tnow <- step $ liftIO getTimeSeconds 1170 | flag tnow t 1171 | where 1172 | flag tnow delta = WF $ \s -> do 1173 | tv <- liftIO $ newTVarIO False 1174 | 1175 | liftIO $ do 1176 | let t = tnow + delta 1177 | atomically $ writeTVar tv False 1178 | forkIO $ do waitUntil t ; atomically $ writeTVar tv True 1179 | return (s, tv) 1180 | 1181 | 1182 | 1183 | 1184 | getTimeSeconds :: IO Integer 1185 | getTimeSeconds= do 1186 | TOD n _ <- getClockTime 1187 | return n 1188 | 1189 | {- | Wait until a certain clock time has passed by monitoring its flag, in the STM monad. 1190 | This permits to compose timeouts with locks waiting for data using `orElse` 1191 | 1192 | *example: wait for any respoinse from a Queue if no response is given in 5 minutes, it is returned True. 1193 | 1194 | @ 1195 | flag \<- 'getTimeoutFlag' $ 5 * 60 1196 | ap \<- `step` . atomically $ readSomewhere >>= return . Just `orElse` 'waitUntilSTM' flag >> return Nothing 1197 | case ap of 1198 | Nothing -> do 'logWF' "timeout" ... 1199 | Just x -> do 'logWF' $ "received" ++ show x ... 1200 | @ 1201 | -} 1202 | 1203 | --longWait :: Integer -> Workflow m a -> Workflow m a 1204 | --longWait time wf= 1205 | -- WF $ \s -> do 1206 | -- flag <- getTimeoutFlag time 1207 | -- forkIO $ do 1208 | -- atomically $ do 1209 | -- b <- readTVar flag 1210 | -- if b == False then retry else return () 1211 | -- start (wfName s) wf "" 1212 | -- myThreadId >>= killThread 1213 | 1214 | 1215 | waitUntilSTM :: TVar Bool -> STM() 1216 | waitUntilSTM tv = do 1217 | b <- readTVar tv 1218 | if b == False then retry else return () 1219 | 1220 | -- | Wait until a certain clock time has passed by monitoring its flag, in the IO monad. 1221 | -- See `waitUntilSTM` 1222 | 1223 | waitUntil:: Integer -> IO() 1224 | waitUntil t= getTimeSeconds >>= \tnow -> wait ((t-tnow)*1000000) 1225 | 1226 | 1227 | wait :: Integer -> IO() 1228 | wait delta= do 1229 | let delay | delta < 0= 0 1230 | | delta > (fromIntegral maxInt) = maxInt 1231 | | otherwise = fromIntegral $ delta 1232 | threadDelay $ delay 1233 | if delta <= 0 then return () else wait $ delta - (fromIntegral delay ) 1234 | 1235 | -- | Return either the result of the STM conputation or Nothing in case of timeout. 1236 | -- The computation can retry 1237 | -- This timeout is persistent. This means that the counter is initialized in the first call to getTimeoutFlag 1238 | -- no matter if the workflow is restarted. The time during which the worlkflow has been stopped count also. 1239 | -- Thus, the wait time can exceed the time between failures. 1240 | -- when timeout is 0 it means no timeout. 1241 | withTimeout :: ( MonadIO m, Typeable a, Serialize a)=> Integer -> STM a -> Workflow m (Maybe a) 1242 | withTimeout time f = do 1243 | flag <- getTimeoutFlag time 1244 | step . liftIO . atomically $ (f >>= return . Just ) 1245 | `orElse` 1246 | (waitUntilSTM flag >> return Nothing) 1247 | 1248 | 1249 | -- | Executes a computation understanding that it is inside the 1250 | -- workflow identified by 'id'. If 'f' finish after 'time' 1251 | -- it genetates a 'Timeout' exception which may result in the end of the workflow if the 1252 | -- programmer does not catch it. 1253 | -- If the workflow is restarted after 'time2' has elapsed, the workflow 1254 | -- will restart from the beginning. If not, it will restart after the last logged step. 1255 | -- 1256 | -- Usually @time2> time@ 1257 | -- 1258 | -- @time2=0@ means @time2@ is infinite 1259 | --withKillTimeout :: CMC.MonadCatchIO m => String -> Int -> Integer -> m a -> m a 1260 | --withKillTimeout id time time2 f = do 1261 | -- tid <- liftIO myThreadId 1262 | -- tstart <- liftIO getTimeSeconds 1263 | -- let final= liftIO $ do 1264 | -- tnow <- getTimeSeconds 1265 | -- let ref = getDBRef $ keyResource $ stat0{wfName=id} -- !> (keyResource $ stat0{wfName=id} ) 1266 | -- when (time2 /=0) . atomically $ do 1267 | -- s <- readDBRef ref `onNothing` error ( "withKillTimeout: Workflow not found: "++ id) 1268 | -- writeDBRef ref s{lastActive= tnow,timeout= Just (time2 - fromIntegral (tnow - tstart))} 1269 | -- clearRunningFlag id 1270 | -- let proc= do 1271 | -- twatchdog <- liftIO $ case time of 1272 | -- 0 -> return tid 1273 | -- _ -> forkIO $ threadDelay (time * 1000000) >> throwTo tid Timeout 1274 | -- r <- f 1275 | -- liftIO $ killThread twatchdog 1276 | -- return r 1277 | -- 1278 | -- proc `CMC.finally` final 1279 | 1280 | withKillTimeout :: (MonadIO m,CMC.MonadCatch m) => String -> Int -> Integer -> m a -> m a 1281 | withKillTimeout id time time2 f = do 1282 | tid <- liftIO myThreadId 1283 | twatchdog <- liftIO $ forkIO $ threadDelay (time * 1000000) >> throwTo tid Timeout 1284 | r <- f 1285 | liftIO $ killThread twatchdog 1286 | return r 1287 | `CMC.catch` \(e :: WFErrors) -> 1288 | case e of 1289 | Timeout -> liftIO $ do 1290 | 1291 | tnow <- getTimeSeconds 1292 | let ref = getDBRef $ keyResource $ stat0{wfName=id} -- !> (keyResource $ stat0{wfName=id} ) 1293 | when (time2 /=0) $ atomically $ do 1294 | s <- readDBRef ref `onNothing` error ( "withKillTimeout: Workflow not found: "++ id) 1295 | writeDBRef ref s{lastActive= tnow,timeout= Just (time2-fromIntegral time)} 1296 | syncCache 1297 | clearRunningFlag id 1298 | 1299 | throw Timeout -- !> "Timeout 2" 1300 | _ -> throw e 1301 | 1302 | 1303 | 1304 | transientTimeout 0= atomically $ newTVar False 1305 | transientTimeout t= do 1306 | flag <- atomically $ newTVar False 1307 | forkIO $ threadDelay (t * 1000000) >> atomically (writeTVar flag True) 1308 | return flag 1309 | -------------------------------------------------------------------------------- /Control/Workflow.old.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverlappingInstances 2 | , UndecidableInstances 3 | , ExistentialQuantification 4 | , ScopedTypeVariables 5 | , MultiParamTypeClasses 6 | , FlexibleInstances 7 | , FlexibleContexts 8 | , TypeSynonymInstances 9 | , DeriveDataTypeable 10 | #-} 11 | {-# OPTIONS -IControl/Workflow #-} 12 | 13 | 14 | {- | A workflow can be seen as a persistent thread. 15 | The workflow monad writes a log that permit to restore the thread 16 | at the interrupted point. `step` is the (partial) monad transformer for 17 | the Workflow monad. A workflow is defined by its name and, optionally 18 | by the key of the single parameter passed. The primitives for starting workflows 19 | also restart the interrupted workflow when it has been in execution previously. 20 | 21 | 22 | A small example that print the sequence of integers in te console 23 | if you interrupt the progam, when restarted again, it will 24 | start from the last printed number 25 | 26 | @module Main where 27 | import Control.Workflow 28 | import Control.Concurrent(threadDelay) 29 | import System.IO (hFlush,stdout) 30 | 31 | mcount n= do `step` $ do 32 | putStr (show n ++ \" \") 33 | hFlush stdout 34 | threadDelay 1000000 35 | mcount (n+1) 36 | return () -- to disambiguate the return type 37 | 38 | main= `exec1` \"count\" $ mcount (0 :: Int)@ 39 | 40 | >runghc demos\sequence.hs 41 | 0 1 2 3 42 | CTRL-C Pressed 43 | >runghc demos\sequence.hs 44 | 3 4 5 6 7 45 | CTRL-C Pressed 46 | C:\Users\agocorona\Documents\Dropbox\Haskell\devel\Workflow>runghc demos\sequenc 47 | e.hs 48 | 7 8 9 10 11 49 | ... 50 | 51 | The program continue restart by recovering the sequence. 52 | 53 | As you can see, some side effect can be re-executed after recovery if 54 | the log is not complete. This may happen after an unexpected shutdown (in this case) 55 | or due to an asynchronous log writing policy. (see `syncWrite`) 56 | 57 | When the step results are big and complex, use the "Data.RefSerialize" package to define the (de)serialization instances 58 | The log size will be reduced. printWFHistory` method will print the structure changes 59 | in each step. 60 | 61 | If instead of `RefSerialize`, you use read and show instances, there will 62 | be no reduction. but still it will work, and the log will be readable for debugging purposes. 63 | The RefSerialize istance is automatically derived from Read, Show instances. 64 | 65 | Data.Binary instances are also fine for serialization. To use Binary, just define a binary instance 66 | of your data by using `showpBinary` and `readpBinary`. 67 | 68 | Within the RefSerialize instance of a structure, you can freely mix 69 | Show,Read RefSerialize and Data Binary instances. 70 | 71 | 72 | -} 73 | 74 | module Control.Workflow 75 | 76 | ( 77 | Workflow -- a useful type name 78 | , WorkflowList 79 | , PMonadTrans (..) 80 | , MonadCatchIO (..) 81 | , throw 82 | , Indexable(..) 83 | -- * Start/restart workflows 84 | , start 85 | , exec 86 | , exec1d 87 | , exec1 88 | , wfExec 89 | , startWF 90 | , restartWorkflows 91 | , WFErrors(..) 92 | -- * Lifting to the Workflow monad 93 | , step 94 | , while 95 | , stepControl 96 | --, stepDebug 97 | , unsafeIOtoWF 98 | -- * References to intermediate values in the workflow log 99 | , WFRef 100 | , getWFRef 101 | , newWFRef 102 | , stepWFRef 103 | , readWFRef 104 | -- * state manipulation 105 | , writeWFRef 106 | , moveState 107 | -- * Workflow inspect 108 | , waitWFActive 109 | , getAll 110 | --, getStep 111 | , safeFromIDyn 112 | , getWFKeys 113 | , getWFHistory 114 | , waitFor 115 | , waitForSTM 116 | -- * Persistent timeouts 117 | , waitUntilSTM 118 | , getTimeoutFlag 119 | , withTimeout 120 | , withKillTimeout 121 | -- * Trace logging 122 | , logWF 123 | -- * Termination of workflows 124 | , clearRunningFlag 125 | , killThreadWF 126 | , killWF 127 | , delWF 128 | , killThreadWF1 129 | , killWF1 130 | , delWF1 131 | , delWFHistory 132 | , delWFHistory1 133 | -- * Log writing policy 134 | , syncWrite 135 | , SyncMode(..) 136 | -- * Print log history 137 | , showHistory 138 | , isInRecover 139 | ) 140 | 141 | where 142 | 143 | import Prelude hiding (catch) 144 | import System.IO.Unsafe 145 | import Control.Monad(when,liftM) 146 | import qualified Control.Exception as CE (Exception,AsyncException(ThreadKilled), SomeException, ErrorCall, throwIO, handle,finally,catch,block,unblock) 147 | import Control.Concurrent (forkIO,threadDelay, ThreadId, myThreadId, killThread) 148 | import Control.Concurrent.STM 149 | import GHC.Conc(unsafeIOToSTM) 150 | import GHC.Base (maxInt) 151 | 152 | 153 | import Data.ByteString.Lazy.Char8 as B hiding (index) 154 | import Data.ByteString.Lazy as BL(putStrLn) 155 | import Data.List as L 156 | import Data.Typeable 157 | import System.Time 158 | import Control.Monad.Trans 159 | import Control.Concurrent.MonadIO(HasFork(..),MVar,newMVar,takeMVar,putMVar) 160 | 161 | 162 | import System.IO(hPutStrLn, stderr) 163 | import Data.List(elemIndex) 164 | import Data.Maybe 165 | import Data.IORef 166 | import System.IO.Unsafe(unsafePerformIO) 167 | import Data.Map as M(Map,fromList,elems, insert, delete, lookup,toList, fromList,keys) 168 | import qualified Control.Monad.CatchIO as CMC 169 | import qualified Control.Exception.Extensible as E 170 | 171 | import Data.TCache 172 | import Data.TCache.DefaultPersistence 173 | import Data.RefSerialize 174 | import Control.Workflow.IDynamic 175 | import Unsafe.Coerce 176 | import Control.Workflow.Stat 177 | 178 | import Debug.Trace 179 | a !> b= trace b a 180 | 181 | 182 | type Workflow m = WF Stat m -- not so scary 183 | 184 | type WorkflowList m a b= [(String, a -> Workflow m b) ] 185 | 186 | 187 | instance Monad m => Monad (WF s m) where 188 | return x = WF (\s -> return (s, x)) 189 | WF g >>= f = WF (\s -> do 190 | (s1, x) <- g s 191 | let WF fun= f x 192 | fun s1) 193 | 194 | 195 | 196 | instance (Monad m,Functor m) => Functor (Workflow m ) where 197 | fmap f (WF g)= WF (\s -> do 198 | (s1, x) <- g s 199 | return (s1, f x)) 200 | 201 | tvRunningWfs = getDBRef $ keyRunning :: DBRef Stat 202 | 203 | 204 | 205 | -- | executes a computation inside of the workflow monad whatever the monad encapsulated in the workflow. 206 | -- Warning: this computation is executed whenever 207 | -- the workflow restarts, no matter if it has been already executed previously. This is useful for intializations or debugging. 208 | -- To avoid re-execution when restarting use: @'step' $ unsafeIOtoWF...@ 209 | -- 210 | -- To perform IO actions in a workflow that encapsulates an IO monad, use step over the IO action directly: 211 | -- 212 | -- @ 'step' $ action @ 213 | -- 214 | -- instead of 215 | -- 216 | -- @ 'step' $ unsafeIOtoWF $ action @ 217 | unsafeIOtoWF :: (Monad m) => IO a -> Workflow m a 218 | unsafeIOtoWF x= let y= unsafePerformIO ( x >>= return) in y `seq` return y 219 | 220 | 221 | {- | PMonadTrans permits |to define a partial monad transformer. They are not defined for all kinds of data 222 | but the ones that have instances of certain classes.That is because in the lift instance code there are some 223 | hidden use of these classes. This also may permit an accurate control of effects. 224 | An instance of MonadTrans is an instance of PMonadTrans 225 | -} 226 | class PMonadTrans t m a where 227 | plift :: Monad m => m a -> t m a 228 | 229 | 230 | 231 | -- | plift= step 232 | instance (Monad m 233 | , MonadIO m 234 | , Serialize a 235 | , Typeable a) 236 | => PMonadTrans (WF Stat) m a 237 | where 238 | plift = step 239 | 240 | -- | An instance of MonadTrans is an instance of PMonadTrans 241 | instance (MonadTrans t, Monad m) => PMonadTrans t m a where 242 | plift= Control.Monad.Trans.lift 243 | 244 | instance Monad m => MonadIO (WF Stat m) where 245 | liftIO=unsafeIOtoWF 246 | 247 | 248 | {- | adapted from MonadCatchIO-mtl. Workflow need to express serializable constraints about the returned values, 249 | so the usual class definitions for lifting IO functions are not suitable. 250 | -} 251 | 252 | class MonadCatchIO m a where 253 | -- | Generalized version of 'E.catch' 254 | catch :: E.Exception e => m a -> (e -> m a) -> m a 255 | 256 | -- | Generalized version of 'E.block' 257 | block :: m a -> m a 258 | 259 | -- | Generalized version of 'E.unblock' 260 | unblock :: m a -> m a 261 | 262 | 263 | 264 | -- | Generalized version of 'E.throwIO' 265 | throw :: (MonadIO m, E.Exception e) => e -> m a 266 | throw = liftIO . E.throwIO 267 | 268 | 269 | 270 | 271 | 272 | instance (Serialize a 273 | , Typeable a,MonadIO m, CMC.MonadCatchIO m) 274 | => MonadCatchIO (WF Stat m) a where 275 | catch exp exc = do 276 | expwf <- step $ getTempName 277 | excwf <- step $ getTempName 278 | step $ do 279 | ex <- CMC.catch (exec1d expwf exp >>= return . Right 280 | ) $ \e-> return $ Left e 281 | 282 | case ex of 283 | Right r -> return r -- All right 284 | Left e ->exec1d excwf (exc e) 285 | -- An exception occured in the main workflow 286 | -- the exception workflow is executed 287 | 288 | 289 | 290 | 291 | block exp=WF $ \s -> CMC.block (st exp $ s) 292 | 293 | unblock exp= WF $ \s -> CMC.unblock (st exp $ s) 294 | 295 | 296 | 297 | instance (HasFork io 298 | , CMC.MonadCatchIO io) 299 | => HasFork (WF Stat io) where 300 | fork f = do 301 | (str, finished) <- step $ getTempName >>= \n -> return(n, False) 302 | r <- getWFRef 303 | WF (\s -> 304 | do th <- if finished 305 | then fork $ return () 306 | else fork $ do 307 | exec1 str f 308 | liftIO $ atomicallySync $ writeWFRef r (str, True) 309 | 310 | return(s,th)) 311 | 312 | 313 | 314 | 315 | -- | start or restart an anonymous workflow inside another workflow. 316 | -- Its state is deleted when finished and the result is stored in 317 | -- the parent's WF state. 318 | wfExec 319 | :: (Indexable a, Serialize a, Typeable a 320 | , CMC.MonadCatchIO m, MonadIO m) 321 | => Workflow m a -> Workflow m a 322 | wfExec f= do 323 | str <- step $ getTempName 324 | step $ exec1 str f 325 | 326 | -- | a version of exec1 that deletes its state after complete execution or thread killed 327 | exec1d :: (Serialize b, Typeable b 328 | ,CMC.MonadCatchIO m) 329 | => String -> (Workflow m b) -> m b 330 | exec1d str f= do 331 | r <- exec1 str f 332 | delit 333 | return r 334 | `CMC.catch` (\e@CE.ThreadKilled -> delit >> throw e) 335 | 336 | where 337 | delit= do 338 | delWF str () 339 | 340 | 341 | 342 | 343 | -- | a version of exec with no seed parameter. 344 | exec1 :: ( Serialize a, Typeable a 345 | , Monad m, MonadIO m, CMC.MonadCatchIO m) 346 | => String -> Workflow m a -> m a 347 | 348 | exec1 str f= exec str (const f) () 349 | 350 | 351 | 352 | 353 | -- | start or continue a workflow with exception handling 354 | -- | the workflow flags are updated even in case of exception 355 | -- | `WFerrors` are raised as exceptions 356 | exec :: ( Indexable a, Serialize a, Serialize b, Typeable a 357 | , Typeable b 358 | , Monad m, MonadIO m, CMC.MonadCatchIO m) 359 | => String -> (a -> Workflow m b) -> a -> m b 360 | exec str f x = 361 | (do 362 | v <- getState str f x 363 | case v of 364 | Right (name, f, stat) -> do 365 | r <- runWF name (f x) stat 366 | return r 367 | Left err -> CMC.throw err) 368 | `CMC.catch` 369 | (\(e :: CE.SomeException) -> liftIO $ do 370 | let name= keyWF str x 371 | clearRunningFlag name --`debug` ("exception"++ show e) 372 | CMC.throw e ) 373 | 374 | 375 | 376 | 377 | mv :: MVar Int 378 | mv= unsafePerformIO $ newMVar 0 379 | 380 | getTempName :: MonadIO m => m String 381 | getTempName= liftIO $ do 382 | seq <- takeMVar mv 383 | putMVar mv (seq + 1) 384 | TOD t _ <- getClockTime 385 | return $ "anon"++ show t ++ show seq 386 | 387 | 388 | 389 | 390 | 391 | 392 | instance Indexable () where 393 | key= show 394 | 395 | -- | Lifts a monadic computation to the WF monad, and provides transparent state loging and resuming the computation 396 | -- Note: Side effect can be repeated at recovery time if the log was not complete before shut down 397 | -- see the integer sequence example, above. 398 | step :: ( Monad m 399 | , MonadIO m 400 | , Serialize a 401 | , Typeable a) 402 | => m a 403 | -> Workflow m a 404 | step= stepControl1 False 405 | 406 | -- | Permits the modification of the workflow state by the procedure being lifted 407 | -- if the boolean value is True. This is used internally for control purposes 408 | stepControl :: ( Monad m 409 | , MonadIO m 410 | , Serialize a 411 | , Typeable a) 412 | => m a 413 | -> Workflow m a 414 | stepControl= stepControl1 True 415 | 416 | stepControl1 :: ( Monad m 417 | , MonadIO m 418 | , Serialize a 419 | , Typeable a) 420 | => Bool -> m a 421 | -> Workflow m a 422 | stepControl1 isControl mx= WF(\s'' -> do 423 | let stat= state s'' 424 | let ind= index s'' 425 | if recover s'' && ind < stat 426 | then return (s''{index=ind +1 }, fromIDyn $ versions s'' !! (stat - ind-1) ) 427 | else stepExec isControl s'' mx) 428 | 429 | stepExec isControl s'' mx= do 430 | x' <- mx 431 | let sref = self s'' 432 | s'<- liftIO . atomicallySync $ do 433 | s <- if isControl 434 | then readDBRef sref >>= return . fromMaybe (error $ "step: readDBRef: not found:" ++ keyObjDBRef sref) 435 | else return s'' 436 | let versionss= versions s 437 | let dynx= toIDyn x' 438 | let ver= dynx: versionss 439 | let s'= s{ recover= False, versions = ver, state= state s+1} 440 | 441 | writeDBRef sref s' 442 | return s' 443 | return (s', x') 444 | 445 | isInRecover :: Monad m => Workflow m Bool 446 | isInRecover = WF(\s->return(s,recover s && index s < state s)) 447 | -- | For debugging purposes. 448 | -- At recovery time, instead of returning the stored value from the log 449 | -- , stepDebug executes the computation 'f' as normally. 450 | -- . It permits the exact re-execution of a workflow process 451 | stepDebug :: ( Monad m 452 | , MonadIO m 453 | , Serialize a 454 | , Typeable a) 455 | => m a 456 | -> Workflow m a 457 | stepDebug f = r 458 | where 459 | r= do 460 | WF(\s -> 461 | let stat= state s 462 | ind = index s 463 | 464 | in case recover s && ind < stat of 465 | True -> f >>= \x -> return (s{index=index s +1},x) 466 | False -> stepExec False s f) 467 | 468 | typ :: m a -> a 469 | typ = undefined 470 | 471 | -- | Executes a computation in a loop while condition is met. 472 | -- At recovery time, the current state of the loop is stored. 473 | -- the loop restart at the last internal state that it was before shutdown. 474 | -- . 475 | -- 476 | -- unlike a loop where `step´ may be used to checkpoint the internal lopp state, 477 | -- while does not make the logfile grow. Istead, it stores only the most recet step value 478 | -- 479 | 480 | while 481 | :: (Monad m,MonadIO m, Typeable a, Serialize a) 482 | => (a -> Bool) -- ^ condition to meet 483 | -> a -- ^ initial value 484 | -> (a -> m a) -- ^ iterated procedure 485 | -> WF Stat m a 486 | while cond x f = do 487 | WF(\s -> if not $ recover s 488 | then return (s{state= state s + 1,versions= toIDyn "" : versions s},()) 489 | else return (s,())) 490 | while1 cond x f 491 | where 492 | while1 cond x f= do 493 | x' <- override $ f x 494 | if cond x' then while1 cond x' f 495 | else return x' 496 | 497 | override mx= WF(\s -> do 498 | let stat= state s 499 | let ind= index s 500 | if recover s && ind < stat 501 | then return (s{index=ind +1 }, fromIDyn $ versions s !! (stat - ind-1) ) 502 | else do 503 | x' <- mx 504 | liftIO . atomicallySync $ do 505 | let dynx= toIDyn x' 506 | let ver= dynx: Prelude.tail (versions s) 507 | let s'= s{ recover= False, versions = ver} 508 | writeDBRef (self s) s' 509 | return (s', x')) 510 | 511 | 512 | 513 | 514 | 515 | 516 | 517 | 518 | 519 | -- | start or continue a workflow . 520 | -- using `killWF` or `delWF` in case of exception. 521 | -- 'WFErrors' and exceptions are returned as @Left err@ (even if they were triggered as exceptions). 522 | -- Other exceptions are returned as @Left (Exception e)@ 523 | 524 | start 525 | :: ( CMC.MonadCatchIO m 526 | , Indexable a 527 | , Serialize a, Serialize b 528 | , Typeable a 529 | , Typeable b) 530 | => String -- ^ name thar identifies the workflow. 531 | -> (a -> Workflow m b) -- ^ workflow to execute 532 | -> a -- ^ initial value (ever use the initial value for restarting the workflow) 533 | -> m (Either WFErrors b) -- ^ result of the computation 534 | start namewf f1 v = do 535 | ei <- getState namewf f1 v 536 | case ei of 537 | Left error -> return $ Left error 538 | Right (name, f, stat) -> 539 | runWF name (f v) stat >>= return . Right 540 | `CMC.catch` 541 | (\(e :: WFErrors) -> do 542 | let name= keyWF namewf v 543 | clearRunningFlag name 544 | return $ Left e) 545 | `CMC.catch` 546 | (\(e :: CE.SomeException) -> liftIO $ do 547 | let name= keyWF namewf v 548 | clearRunningFlag name 549 | return . Left $ Exception e ) 550 | 551 | 552 | -- | return conditions from the invocation of start/restart primitives 553 | data WFErrors = NotFound | AlreadyRunning | Timeout | forall e.CE.Exception e => Exception e deriving Typeable 554 | 555 | instance Show WFErrors where 556 | show NotFound= "Not Found" 557 | show AlreadyRunning= "Already Running" 558 | show Timeout= "Timeout" 559 | show (Exception e)= "Exception: "++ show e 560 | 561 | instance CE.Exception WFErrors 562 | 563 | --tvRunningWfs = unsafePerformIO . refDBRefIO $ Running (M.fromList [] :: Map String (String, (Maybe ThreadId))) 564 | 565 | {- 566 | lookup for any workflow for the entry value v 567 | if namewf is found and is running, return arlready running 568 | if is not runing, restart it 569 | else start anew. 570 | -} 571 | 572 | 573 | getState :: (Monad m, MonadIO m, Indexable a, Serialize a, Typeable a) 574 | => String -> x -> a 575 | -> m (Either WFErrors (String, x, Stat)) 576 | getState namewf f v= liftIO . atomically $ getStateSTM 577 | where 578 | getStateSTM = do 579 | mrunning <- readDBRef tvRunningWfs 580 | case mrunning of 581 | Nothing -> do 582 | writeDBRef tvRunningWfs (Running $ fromList []) 583 | getStateSTM 584 | Just(Running map) -> do 585 | let key= keyWF namewf v 586 | stat1= stat0{wfName= key,versions=[toIDyn v],self= sref} 587 | sref= getDBRef $ keyResource stat1 588 | case M.lookup key map of 589 | Nothing -> do -- no workflow started for this object 590 | mythread <- unsafeIOToSTM $ myThreadId 591 | writeDBRef tvRunningWfs . Running $ M.insert key (namewf,Just mythread) map 592 | writeDBRef sref stat1 593 | return $ Right (key, f, stat1) 594 | 595 | Just (wf, started) -> -- a workflow has been initiated for this object 596 | if isJust started 597 | then return $ Left AlreadyRunning -- `debug` "already running" 598 | else do -- has been running but not running now 599 | mst <- readDBRef sref 600 | stat' <- case mst of 601 | Nothing -> error $ "getState: Workflow not found: "++ key 602 | Just s -> do 603 | tnow <- unsafeIOToSTM getTimeSeconds 604 | if isJust (timeout s) 605 | then if lastActive s+ fromJust(timeout s) > tnow -- !>("lastActive="++show (lastActive s) ++ "tnow="++show tnow) 606 | then 607 | return s{index=0,recover= True,timeout=Nothing} 608 | else 609 | -- has been inactive for too much time, clean it 610 | return stat1 611 | else return s{index=0,recover= True} 612 | 613 | 614 | writeDBRef sref stat' 615 | mythread <- unsafeIOToSTM myThreadId 616 | writeDBRef tvRunningWfs . Running $ M.insert key (namewf,Just mythread) map 617 | 618 | return $ Right (key, f, stat') 619 | 620 | 621 | 622 | runWF :: (Monad m,MonadIO m 623 | , Serialize b, Typeable b) 624 | => String -> Workflow m b -> Stat -> m b 625 | runWF n f s= do 626 | (s', v') <- st f $ s -- !> (show $ versions s) 627 | liftIO $! clearFromRunningList n 628 | 629 | return v' 630 | where 631 | 632 | -- eliminate the thread from the list of running workflows but leave the state 633 | clearFromRunningList n = atomicallySync $ do 634 | Just(Running map) <- readDBRef tvRunningWfs 635 | writeDBRef tvRunningWfs . Running $ M.delete n map -- `debug` "clearFromRunningList" 636 | 637 | -- | Start or continue a workflow from a list of workflows with exception handling. 638 | -- see 'start' for details about exception and error handling 639 | startWF 640 | :: ( CMC.MonadCatchIO m 641 | , Serialize a, Serialize b 642 | , Typeable a 643 | , Indexable a 644 | , Typeable b) 645 | => String -- ^ Name of workflow in the workflow list 646 | -> a -- ^ Initial value (ever use the initial value even to restart the workflow) 647 | -> WorkflowList m a b -- ^ function to execute 648 | -> m (Either WFErrors b) -- ^ Result of the computation 649 | startWF namewf v wfs= 650 | case Prelude.lookup namewf wfs of 651 | Nothing -> return $ Left NotFound 652 | Just f -> start namewf f v 653 | 654 | 655 | 656 | -- | re-start the non finished workflows in the list, for all the initial values that they may have been invoked 657 | restartWorkflows 658 | :: (Serialize a, Serialize b, Typeable a 659 | , Indexable b, Typeable b) 660 | => WorkflowList IO a b -- the list of workflows that implement the module 661 | -> IO () -- Only workflows in the IO monad can be restarted with restartWorkflows 662 | restartWorkflows map = do 663 | mw <- liftIO $ getResource ((Running undefined ) ) -- :: IO (Maybe(Stat a)) 664 | case mw of 665 | Nothing -> return () 666 | Just (Running all) -> mapM_ start . mapMaybe filter . toList $ all 667 | where 668 | filter (a, (b,Nothing)) = Just (b, a) 669 | filter _ = Nothing 670 | 671 | start (key, kv)= do 672 | 673 | 674 | let mf= Prelude.lookup key map 675 | case mf of 676 | Nothing -> return () 677 | Just f -> do 678 | let st0= stat0{wfName = kv} 679 | mst <- liftIO $ getResource st0 680 | case mst of 681 | Nothing -> error $ "restartWorkflows: workflow not found "++ keyResource st0 682 | Just st-> do 683 | liftIO . forkIO $ runWF key (f (fromIDyn . Prelude.last $ versions st )) st{index=0,recover=True} >> return () 684 | return () 685 | 686 | 687 | 688 | -- | return all the steps of the workflow log. The values are dynamic 689 | -- 690 | -- to get all the steps with result of type Int: 691 | -- @all <- `getAll` 692 | -- let lfacts = mapMaybe `safeFromIDyn` all :: [Int]@ 693 | getAll :: Monad m => Workflow m [IDynamic] 694 | getAll= WF(\s -> return (s, versions s)) 695 | 696 | getStep 697 | :: (Serialize a, Typeable a, Monad m) 698 | => Int -- ^ the step number. If negative, count from the current state backwards 699 | -> Workflow m a -- ^ return the n-tn intermediate step result 700 | getStep i= WF(\s -> do 701 | let ind= index s 702 | stat= state s 703 | 704 | return (s, if i > 0 && i < stat then fromIDyn $ versions s !! (stat -i-1) 705 | else if i <= 0 && i > -stat then fromIDyn $ versions s !! (stat - ind +i-1) 706 | else error "getStep: wrong index") 707 | ) 708 | 709 | -- | return the list of object keys that are running for a workflow 710 | getWFKeys :: String -> IO [String] 711 | getWFKeys wfname= do 712 | mwfs <- atomically $ readDBRef tvRunningWfs 713 | case mwfs of 714 | Nothing -> return [] 715 | Just (Running wfs) -> return $ Prelude.filter (L.isPrefixOf wfname) $ M.keys wfs 716 | 717 | -- | return the current state of the computation, in the IO monad 718 | getWFHistory :: (Indexable a, Serialize a) => String -> a -> IO (Maybe Stat) 719 | getWFHistory wfname x= getResource stat0{wfName= keyWF wfname x} 720 | 721 | -- | delete the history of a workflow. 722 | -- Be sure that this WF has finished. 723 | {-# DEPRECATED delWFHistory, delWFHistory1 "use delWF and delWF1 instead" #-} 724 | 725 | delWFHistory name1 x = do 726 | let name= keyWF name1 x 727 | delWFHistory1 name 728 | 729 | delWFHistory1 name = do 730 | let proto= stat0{wfName= name} 731 | -- when (isJust mdir) $ 732 | -- moveFile (defPath proto ++ key proto) (defPath proto ++ fromJust mdir) 733 | atomically . withSTMResources [] $ const resources{ toDelete= [proto] } 734 | 735 | 736 | waitWFActive wf= do 737 | r <- threadWF wf 738 | case r of -- wait for change in the wofkflow state 739 | Just (_, Nothing) -> retry 740 | _ -> return () 741 | where 742 | threadWF wf= do 743 | Just(Running map) <- readDBRef tvRunningWfs 744 | return $ M.lookup wf map 745 | 746 | 747 | -- | kill the executing thread if not killed, but not its state. 748 | -- `exec` `start` or `restartWorkflows` will continue the workflow 749 | killThreadWF :: ( Indexable a 750 | , Serialize a 751 | 752 | , Typeable a 753 | , MonadIO m) 754 | => String -> a -> m() 755 | killThreadWF wfname x= do 756 | let name= keyWF wfname x 757 | killThreadWF1 name 758 | 759 | -- | a version of `KillThreadWF` for workflows started wit no parameter by `exec1` 760 | killThreadWF1 :: MonadIO m => String -> m() 761 | killThreadWF1 name= killThreadWFm name >> return () 762 | 763 | killThreadWFm name= do 764 | (map,f) <- clearRunningFlag name 765 | case f of 766 | Just th -> liftIO $ killThread th 767 | Nothing -> return() 768 | return map 769 | 770 | 771 | 772 | -- | kill the process (if running) and drop it from the list of 773 | -- restart-able workflows. Its state history remains , so it can be inspected with 774 | -- `getWfHistory` `printWFHistory` and so on 775 | killWF :: (Indexable a,MonadIO m) => String -> a -> m () 776 | killWF name1 x= do 777 | let name= keyWF name1 x 778 | killWF1 name 779 | 780 | -- | a version of `KillWF` for workflows started wit no parameter by `exec1` 781 | killWF1 :: MonadIO m => String -> m () 782 | killWF1 name = do 783 | map <- killThreadWFm name 784 | liftIO . atomically . writeDBRef tvRunningWfs . Running $ M.delete name map 785 | return () 786 | 787 | -- | delete the WF from the running list and delete the workflow state from persistent storage. 788 | -- Use it to perform cleanup if the process has been killed. 789 | delWF :: ( Indexable a 790 | , MonadIO m 791 | , Typeable a) 792 | => String -> a -> m() 793 | delWF name1 x= do 794 | let name= keyWF name1 x 795 | delWF1 name 796 | 797 | 798 | -- | a version of `delWF` for workflows started wit no parameter by `exec1` 799 | delWF1 :: MonadIO m=> String -> m() 800 | delWF1 name= liftIO $ do 801 | mrun <- atomically $ readDBRef tvRunningWfs 802 | case mrun of 803 | Nothing -> return() 804 | Just (Running map) -> do 805 | atomicallySync . writeDBRef tvRunningWfs . Running $! M.delete name map 806 | delWFHistory1 name 807 | 808 | 809 | 810 | 811 | clearRunningFlag name= liftIO $ atomically $ do 812 | mrun <- readDBRef tvRunningWfs 813 | case mrun of 814 | Nothing -> error $ "clearRunningFLag: non existing workflows" ++ name 815 | Just(Running map) -> do 816 | case M.lookup name map of 817 | Just(_, Nothing) -> return (map,Nothing) 818 | Just(v, Just th) -> do 819 | writeDBRef tvRunningWfs . Running $ M.insert name (v, Nothing) map 820 | return (map,Just th) 821 | Nothing -> 822 | return (map, Nothing) 823 | 824 | 825 | -- | Return the reference to the last logged result , usually, the last result stored by `step`. 826 | -- wiorkflow references can be accessed outside of the workflow 827 | -- . They also can be (de)serialized. 828 | -- 829 | -- WARNING getWFRef can produce casting errors when the type demanded 830 | -- do not match the serialized data. Instead, `newDBRef` and `stepWFRef` are type safe at runtuime. 831 | getWFRef :: ( Monad m, 832 | MonadIO m, 833 | Serialize a 834 | , Typeable a) 835 | => Workflow m (WFRef a) 836 | getWFRef =ret 837 | where 838 | ret= WF (\s -> do 839 | let n= if recover s then index s else state s 840 | let ref = WFRef n (self s) 841 | -- to reify the object being accessed 842 | -- if not reified, the serializer will write a null object 843 | let r= fromIDyn (versions s !! (state s - n)) `asTypeOf` typeofRef ret 844 | r `seq` return (s,ref)) 845 | where 846 | typeofRef :: Workflow m (WFRef a) -> a 847 | typeofRef= undefined -- never will be executed 848 | -- | Execute an step but return a reference to the result instead of the result itself 849 | -- 850 | -- @stepWFRef exp= `step` exp >>= `getWFRef`@ 851 | stepWFRef :: ( Serialize a 852 | , Typeable a 853 | , MonadIO m) 854 | => m a -> Workflow m (WFRef a) 855 | stepWFRef exp= step exp >> getWFRef 856 | 857 | -- | Log a value and return a reference to it. 858 | -- 859 | -- @newWFRef x= `step` $ return x >>= `getWFRef`@ 860 | newWFRef :: ( Serialize a 861 | , Typeable a 862 | , MonadIO m) 863 | => a -> Workflow m (WFRef a) 864 | newWFRef x= step (return x) >> getWFRef 865 | 866 | -- | Read the content of a Workflow reference. Note that its result is not in the Workflow monad 867 | readWFRef :: ( Serialize a 868 | , Typeable a) 869 | => WFRef a 870 | -> STM (Maybe a) 871 | readWFRef (WFRef n ref)= do 872 | mr <- readDBRef ref 873 | case mr of 874 | Nothing -> return Nothing 875 | Just s -> do 876 | let elems= versions s 877 | l = state s -- L.length elems 878 | x = elems !! (l - n) 879 | return . Just $! fromIDyn x 880 | 881 | 882 | -- | Writes a new value en in the workflow reference, that is, in the workflow log. 883 | -- Why would you use this?. Don do that!. modifiying the content of the workflow log would 884 | -- change the excution flow when the workflow restarts. This metod is used internally in the package 885 | -- the best way to communicate with a workflow is trough a persistent queue: 886 | -- 887 | -- @worflow= exec1 "wf" do 888 | -- r <- `stepWFRef` expr 889 | -- `push` \"queue\" r 890 | -- back <- `pop` \"queueback\" 891 | -- ... 892 | -- @ 893 | 894 | writeWFRef :: ( Serialize a 895 | , Typeable a) 896 | => WFRef a 897 | -> a 898 | -> STM () 899 | writeWFRef r@(WFRef n ref) x= do 900 | mr <- readDBRef ref 901 | case mr of 902 | Nothing -> error $ "writeWFRef: workflow does not exist: " ++ keyObjDBRef ref 903 | Just s -> do 904 | let elems= versions s 905 | l = state s -- L.length elems 906 | p = l - n 907 | (h,t)= L.splitAt p elems 908 | elems'= h ++ (toIDyn x:tail' t) 909 | tail' []= [] 910 | tail' t= L.tail t 911 | 912 | writeDBRef ref s{ versions= elems'} 913 | 914 | -- | moves the state from a seed value to other. 915 | -- This may be of interest when the entry value 916 | -- changes its key value but should not initiate a new workflow 917 | -- but continues with the current one 918 | 919 | moveState :: (MonadIO m 920 | , Indexable a 921 | , Serialize a 922 | , Typeable a) 923 | =>String -> a -> a -> m () 924 | moveState wf t t'= liftIO $ do 925 | atomicallySync $ do 926 | withSTMResources[stat0{wfName= n}] $ doit n 927 | mrun <- readDBRef tvRunningWfs 928 | case mrun of 929 | Nothing -> return() 930 | Just (Running map) -> do 931 | let mr= M.lookup n map 932 | let th= case mr of Nothing -> Nothing; Just(_,mt)-> mt 933 | let map'= M.insert n' (wf,th) $ M.delete n map 934 | writeDBRef tvRunningWfs $ Running map' 935 | 936 | where 937 | n = keyWF wf t 938 | n'= keyWF wf t' 939 | 940 | doit n [Just s] = resources{toAdd= [ s{wfName=n',versions = toIDyn t': L.tail( versions s) }] 941 | ,toDelete=[s]} 942 | 943 | doit n [Nothing]= error $ "moveState: state not found for: " ++ n 944 | 945 | 946 | 947 | -- | Log a message in the workflow history. I can be printed out with 'printWFhistory' 948 | -- The message is printed in the standard output too 949 | logWF :: MonadIO m => String -> Workflow m () 950 | logWF str=do 951 | str <- step . liftIO $ do 952 | time <- getClockTime >>= toCalendarTime >>= return . calendarTimeToString 953 | Prelude.putStrLn str 954 | return $ time ++ ": "++ str 955 | WF $ \s -> str `seq` return (s, ()) 956 | 957 | 958 | 959 | --------- event handling-------------- 960 | 961 | 962 | -- | Wait until a TCache object (with a certaing key) meet a certain condition (useful to check external actions ) 963 | -- NOTE if anoter process delete the object from te cache, then waitForData will no longuer work 964 | -- inside the wokflow, it can be used by lifting it : 965 | -- do 966 | -- x <- step $ .. 967 | -- y <- step $ waitForData ... 968 | -- .. 969 | 970 | waitForData :: (IResource a, Typeable a) 971 | => (a -> Bool) -- ^ The condition that the retrieved object must meet 972 | -> a -- ^ a partially defined object for which keyResource can be extracted 973 | -> IO a -- ^ return the retrieved object that meet the condition and has the given kwaitForData filter x= atomically $ waitForDataSTM filter x 974 | waitForData f x = atomically $ waitForDataSTM f x 975 | 976 | waitForDataSTM :: (IResource a, Typeable a) 977 | => (a -> Bool) -- ^ The condition that the retrieved object must meet 978 | -> a -- ^ a partially defined object for which keyResource can be extracted 979 | -> STM a -- ^ return the retrieved object that meet the condition and has the given key 980 | waitForDataSTM filter x= do 981 | tv <- newDBRef x 982 | do 983 | mx <- readDBRef tv >>= \v -> return $ cast v 984 | case mx of 985 | Nothing -> retry 986 | Just x -> 987 | case filter x of 988 | False -> retry 989 | True -> return x 990 | 991 | -- | observe the workflow log untiil a condition is met. 992 | waitFor 993 | :: ( Indexable a, Serialize a, Serialize b, Typeable a 994 | , Indexable b, Typeable b) 995 | => (b -> Bool) -- ^ The condition that the retrieved object must meet 996 | -> String -- ^ The workflow name 997 | -> a -- ^ the INITIAL value used in the workflow to start it 998 | -> IO b -- ^ The first event that meet the condition 999 | waitFor filter wfname x= atomically $ waitForSTM filter wfname x 1000 | 1001 | waitForSTM 1002 | :: ( Indexable a, Serialize a, Serialize b, Typeable a 1003 | , Indexable b, Typeable b) 1004 | => (b -> Bool) -- ^ The condition that the retrieved object must meet 1005 | -> String -- ^ The workflow name 1006 | -> a -- ^ The INITIAL value used in the workflow to start it 1007 | -> STM b -- ^ The first event that meet the condition 1008 | waitForSTM filter wfname x= do 1009 | let name= keyWF wfname x 1010 | let tv= getDBRef . key $ stat0{wfName= name} -- `debug` "**waitFor***" 1011 | 1012 | mmx <- readDBRef tv 1013 | case mmx of 1014 | Nothing -> error ("waitForSTM: Workflow does not exist: "++ name) 1015 | Just mx -> do 1016 | let Stat{ versions= d:_}= mx 1017 | case safeFromIDyn d of 1018 | Nothing -> retry -- `debug` "waithFor retry Nothing" 1019 | Just x -> 1020 | case filter x of 1021 | False -> retry -- `debug` "waitFor false filter retry" 1022 | True -> return x -- `debug` "waitfor return" 1023 | 1024 | 1025 | 1026 | {-# DEPRECATED waitUntilSTM, getTimeoutFlag "use withTimeout instead" #-} 1027 | -- | Start the timeout and return the flag to be monitored by 'waitUntilSTM' 1028 | -- This timeout is persistent. This means that the time start to count from the first call to getTimeoutFlag on 1029 | -- no matter if the workflow is restarted. The time that the worlkflow has been stopped count also. 1030 | -- the wait time can exceed the time between failures. 1031 | -- when timeout is 0 means no timeout. 1032 | getTimeoutFlag 1033 | :: MonadIO m 1034 | => Integer -- ^ wait time in secods. This timing start from the first time that the timeout was started on. Sucessive restarts of the workflow will respect this timing 1035 | -> Workflow m (TVar Bool) -- ^ the returned flag in the workflow monad 1036 | getTimeoutFlag 0 = WF $ \s -> liftIO $ newTVarIO False >>= \tv -> return (s, tv) 1037 | getTimeoutFlag t = do 1038 | tnow <- step $ liftIO getTimeSeconds 1039 | flag tnow t 1040 | where 1041 | flag tnow delta = WF $ \s -> do 1042 | tv <- liftIO $ newTVarIO False 1043 | 1044 | liftIO $ do 1045 | let t = tnow + delta 1046 | atomically $ writeTVar tv False 1047 | forkIO $ do waitUntil t ; atomically $ writeTVar tv True 1048 | return (s, tv) 1049 | 1050 | getTimeSeconds :: IO Integer 1051 | getTimeSeconds= do 1052 | TOD n _ <- getClockTime 1053 | return n 1054 | 1055 | {- | Wait until a certain clock time has passed by monitoring its flag, in the STM monad. 1056 | This permits to compose timeouts with locks waiting for data using `orElse` 1057 | 1058 | *example: wait for any respoinse from a Queue if no response is given in 5 minutes, it is returned True. 1059 | 1060 | @ 1061 | flag <- 'getTimeoutFlag' $ 5 * 60 1062 | ap <- 'step' . atomically $ readSomewhere >>= return . Just `orElse` 'waitUntilSTM' flag >> return Nothing 1063 | case ap of 1064 | Nothing -> do 'logWF' "timeout" ... 1065 | Just x -> do 'logWF' $ "received" ++ show x ... 1066 | @ 1067 | -} 1068 | waitUntilSTM :: TVar Bool -> STM() 1069 | waitUntilSTM tv = do 1070 | b <- readTVar tv 1071 | if b == False then retry else return () 1072 | 1073 | -- | Wait until a certain clock time has passed by monitoring its flag, in the IO monad. 1074 | -- See `waitUntilSTM` 1075 | 1076 | waitUntil:: Integer -> IO() 1077 | waitUntil t= getTimeSeconds >>= \tnow -> wait (t-tnow) 1078 | 1079 | 1080 | wait :: Integer -> IO() 1081 | wait delta= do 1082 | let delay | delta < 0= 0 1083 | | delta > (fromIntegral maxInt) = maxInt 1084 | | otherwise = fromIntegral $ delta 1085 | threadDelay $ delay * 1000000 1086 | if delta <= 0 then return () else wait $ delta - (fromIntegral delay ) 1087 | 1088 | -- | return either the result of the STM conputation or Nothing in case of timeout 1089 | -- This timeout is persistent. This means that the time start to count from the first call to getTimeoutFlag on 1090 | -- no matter if the workflow is restarted. The time that the worlkflow has been stopped count also. 1091 | -- Thus, the wait time can exceed the time between failures. 1092 | -- when timeout is 0 means no timeout. 1093 | withTimeout :: ( MonadIO m, Typeable a, Serialize a)=> Integer -> STM a -> Workflow m (Maybe a) 1094 | withTimeout time f = do 1095 | flag <- getTimeoutFlag time 1096 | step . liftIO . atomically $ (f >>= return . Just ) 1097 | `orElse` 1098 | (waitUntilSTM flag >> return Nothing) 1099 | 1100 | 1101 | -- | executes a computation in the STM monad. If it is not finished after time `time 1102 | -- it kill the process. If the workflow is restarted after time2, the workflow 1103 | -- will restart from the beginning. If not, it will restart at the last checkpoint. 1104 | withKillTimeout :: MonadIO m => String -> Int -> Integer -> STM a -> m a 1105 | withKillTimeout id time time2 f = liftIO $ do 1106 | 1107 | flag <- transientTimeout time 1108 | r <- atomically $ (f >>= return . Just ) 1109 | `orElse` 1110 | (waitUntilSTM flag >> return Nothing) 1111 | case r of 1112 | Just r -> return r 1113 | Nothing -> do 1114 | clearRunningFlag id 1115 | if time2 == 0 1116 | then throw Timeout -- !> "Timeout" 1117 | else do 1118 | tnow <- getTimeSeconds 1119 | withResource stat0{wfName=id} $ \ms -> do 1120 | case ms of 1121 | Just s -> s{lastActive= tnow,timeout= Just (time2-fromIntegral time)} 1122 | Nothing -> error $ "withKillTimeout: Workflow not found: "++ id 1123 | throw Timeout !> "Timeout" 1124 | 1125 | 1126 | transientTimeout 0= atomically $ newTVar False 1127 | transientTimeout t= do 1128 | flag <- atomically $ newTVar False 1129 | forkIO $ threadDelay (t * 1000000) >> atomically (writeTVar flag True) 1130 | return flag 1131 | -------------------------------------------------------------------------------- /Control/Workflow/Configuration.hs: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | {-# OPTIONS 5 | -XScopedTypeVariables 6 | #-} 7 | 8 | {- | Helpers for application initialization -} 9 | 10 | module Control.Workflow.Configuration (once, ever, runConfiguration 11 | 12 | ) where 13 | 14 | import Control.Workflow 15 | import Data.Typeable 16 | import Data.RefSerialize 17 | import Control.Monad.Trans 18 | import Control.Exception 19 | import Control.Monad.Catch as CMC 20 | 21 | -------------- configuation 22 | -- | to execute a computation every time it is invoked. A synonimous of `unsafeIOtoWF` 23 | ever:: (Typeable a,Serialize a, MonadIO m) => IO a -> Workflow m a 24 | ever= unsafeIOtoWF 25 | 26 | -- | to execute one computation once . It executes at the first run only 27 | once :: (Typeable a,Serialize a, MonadIO m) => m a -> Workflow m a 28 | once= step 29 | 30 | -- | executes a computation with `once` and `ever` statements 31 | -- a synonym of `exec1nc` 32 | runConfiguration :: ( Monad m, MonadIO m, CMC.MonadMask m) 33 | => String -> Workflow m a -> m a 34 | runConfiguration = exec1nc 35 | 36 | -------------------------------------------------------------------------------- /Control/Workflow/Patterns.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable 2 | , ScopedTypeVariables 3 | , FlexibleInstances 4 | , FlexibleContexts 5 | #-} 6 | {-# OPTIONS -IControl/Workflow #-} 7 | 8 | {- | This module contains monadic combinators that express some workflow patterns. 9 | see the docAprobal.hs example included in the package 10 | 11 | 12 | EXAMPLE: 13 | 14 | This fragment below describes the approbal procedure of a document. 15 | First the document reference is sent to a list of bosses trough a queue. 16 | ithey return a boolean in a return queue ( askUser) 17 | the booleans are summed up according with a monoid instance (sumUp) 18 | 19 | if the resullt is false, the correctWF workflow is executed 20 | If the result is True, the pipeline continues to the next stage (`checkValidated`) 21 | 22 | the next stage is the same process with a new list of users (superbosses). 23 | There is a timeout of seven days. The result of the users that voted is summed 24 | up according with the same monoid instance 25 | 26 | if the result is true the document is added to the persistent list of approbed documents 27 | if the result is false, the document is added to the persistent list of rejectec documents (@checlkValidated1@) 28 | 29 | The program can be interrupted at any moment. The Workflow monad will restartWorkflows 30 | it at the point where it was interrupted. 31 | 32 | This example uses queues from "Data.Persistent.Queue" 33 | 34 | @docApprobal :: Document -> Workflow IO () 35 | docApprobal doc = `getWFRef` \>>= docApprobal1 36 | 37 | 38 | docApprobal1 rdoc= 39 | return True \>>= 40 | log \"requesting approbal from bosses\" \>>= 41 | `sumUp` 0 (map (askUser doc rdoc) bosses) \>>= 42 | checkValidated \>>= 43 | log \"requesting approbal from superbosses or timeout\" \>>= 44 | `sumUp` (7*60*60*24) (map(askUser doc rdoc) superbosses) \>>= 45 | checkValidated1 46 | 47 | 48 | askUser _ _ user False = return False 49 | askUser doc rdoc user True = do 50 | `step` $ `push` (quser user) rdoc 51 | `logWF` (\"wait for any response from the user: \" ++ user) 52 | `step` . `pop` $ qdocApprobal (title doc) 53 | 54 | log txt x = `logWF` txt >> return x 55 | 56 | checkValidated :: Bool -> `Workflow` IO Bool 57 | checkValidated val = 58 | case val of 59 | False -> correctWF (title doc) rdoc >> return False 60 | _ -> return True 61 | 62 | 63 | checkValidated1 :: Bool -> Workflow IO () 64 | checkValidated1 val = step $ do 65 | case val of 66 | False -> `push` qrejected doc 67 | _ -> `push` qapproved doc 68 | mapM (\u ->deleteFromQueue (quser u) rdoc) superbosses@ 69 | 70 | -} 71 | 72 | module Control.Workflow.Patterns( 73 | -- * Low level combinators 74 | split, merge, select, 75 | -- * High level conbinators 76 | vote, sumUp, Select(..) 77 | ) where 78 | import Control.Concurrent.STM 79 | import Data.Monoid 80 | 81 | import qualified Control.Monad.Catch as CMC 82 | 83 | import Control.Workflow.Stat 84 | import Control.Workflow 85 | import Data.Typeable 86 | import Prelude hiding (catch) 87 | import Control.Monad 88 | import Control.Monad.Trans 89 | import Control.Concurrent 90 | import Control.Exception.Extensible (Exception,SomeException) 91 | import Data.RefSerialize 92 | import Control.Workflow.Stat 93 | import qualified Data.Vector as V 94 | import Data.TCache 95 | import Debug.Trace 96 | import Data.Maybe 97 | 98 | data ActionWF a= ActionWF (WFRef(Maybe a)) ThreadId -- (WFRef (String, Bool)) 99 | 100 | -- | spawn a list of independent workflow 'actions' with a seed value 'a' 101 | -- The results are reduced by `merge` or `select` 102 | split :: ( Typeable b 103 | , Serialize b 104 | , HasFork io 105 | , CMC.MonadMask io) 106 | => [a -> Workflow io b] -> a -> Workflow io [ActionWF b] 107 | split actions a = mapM (\ac -> 108 | do 109 | mv <- newWFRef Nothing 110 | th<- fork (ac a >>= \v -> (step . liftIO . atomicallySync . writeWFRef mv . Just) v ) 111 | 112 | return $ ActionWF mv th ) 113 | 114 | actions 115 | 116 | 117 | 118 | -- | wait for the results and apply the cond to produce a single output in the Workflow monad 119 | merge :: ( MonadIO io 120 | , Typeable a 121 | , Typeable b 122 | , Serialize a, Serialize b) 123 | => ([a] -> io b) -> [ActionWF a] -> Workflow io b 124 | merge cond results= step $ mapM (\(ActionWF mv _ ) -> liftIO (atomically $ readWFRef1 mv) ) results >>= cond -- !> "cond" 125 | 126 | readWFRef1 :: ( Serialize a 127 | , Typeable a) 128 | => WFRef (Maybe a) -> STM a 129 | readWFRef1 r = do 130 | 131 | mv <- readWFRef r 132 | 133 | case mv of 134 | Just(Just v) -> return v -- !> "return v" 135 | Just Nothing -> retry -- !> "retry" 136 | Nothing -> error $ "readWFRef1: workflow not found "++ show r 137 | 138 | 139 | data Select 140 | = Select -- ^ select the source output 141 | | Discard -- ^ Discard the source output 142 | | Continue -- ^ Continue the source process 143 | | FinishDiscard -- ^ Discard this output, kill all and return the selected outputs 144 | | FinishSelect -- ^ Select this output, kill all and return the selected outputs 145 | deriving(Typeable, Read, Show) 146 | 147 | instance Exception Select 148 | 149 | -- | select the outputs of the workflows produced by `split` constrained within a timeout. 150 | -- The check filter, can select , discard or finish the entire computation before 151 | -- the timeout is reached. When the computation finalizes, it kill all 152 | -- the pending workflows and return the list of selected outputs 153 | -- the timeout is in seconds and it is is in the workflow monad, 154 | -- so it is possible to restart the process if interrupted, 155 | -- so it can proceed for years. 156 | -- 157 | -- This is necessary for the modelization of real-life institutional cycles such are political elections 158 | -- A timeout of 0 means no timeout. 159 | select :: 160 | ( Serialize a 161 | -- , Serialize [a] 162 | , Typeable a 163 | , HasFork io 164 | , CMC.MonadMask io) 165 | => Integer 166 | -> (a -> STM Select) 167 | -> [ActionWF a] 168 | -> Workflow io [a] 169 | select timeout check actions= do 170 | res <- liftIO $ newTVarIO $ V.generate(length actions) (const Nothing) 171 | flag <- getTimeoutFlag timeout 172 | parent <- liftIO myThreadId 173 | checThreads <- liftIO $ newEmptyMVar 174 | count <- liftIO $ newMVar 1 175 | let process = do 176 | let check' (ActionWF ac _) i = do 177 | liftIO . atomically $ do 178 | r <- readWFRef1 ac 179 | b <- check r 180 | case b of 181 | Discard -> return () 182 | Select -> addRes i r 183 | Continue -> addRes i r >> retry 184 | FinishDiscard -> do 185 | unsafeIOToSTM $ throwTo parent FinishDiscard 186 | FinishSelect -> do 187 | addRes i r 188 | unsafeIOToSTM $ throwTo parent FinishDiscard 189 | 190 | n <- liftIO $ do -- liftIO $ CMC.block $ do 191 | n <- takeMVar count 192 | putMVar count (n+1) 193 | return n -- !> ("SELECT" ++ show n) 194 | 195 | if ( n == length actions) 196 | then liftIO $ throwTo parent FinishDiscard 197 | else return () 198 | 199 | `CMC.catch` (\(e :: Select) -> liftIO $ throwTo parent e) 200 | 201 | 202 | ws <- mapM (\(ac,i) -> fork $ check' ac i) $ zip actions [0..] 203 | liftIO $ putMVar checThreads ws 204 | 205 | liftIO $ atomically $ do 206 | v <- readTVar flag -- wait fo timeout 207 | case v of 208 | False -> retry 209 | True -> return () 210 | throw FinishDiscard 211 | where 212 | 213 | addRes i r= do 214 | l <- readTVar res 215 | writeTVar res $ l V.// [(i, Just r)] 216 | 217 | let killall = liftIO $ do 218 | ws <- readMVar checThreads 219 | liftIO $ mapM_ killThread ws 220 | liftIO $ mapM_ (\(ActionWF _ th) -> killThread th)actions -- !> "KILLALL" 221 | 222 | step $ CMC.catch process -- (WF $ \s -> process >>= \ r -> return (s, r)) 223 | (\(e :: Select)-> do 224 | liftIO $ return . catMaybes . V.toList =<< atomically ( readTVar res) 225 | ) 226 | `CMC.finally` killall 227 | 228 | 229 | 230 | justify str Nothing = error str 231 | justify _ (Just x) = return x 232 | 233 | -- | spawn a list of workflows and reduces the results according with the 'comp' parameter within a given timeout 234 | -- 235 | -- @ 236 | -- vote timeout actions comp x= 237 | -- split actions x >>= select timeout (const $ return Select) >>= comp 238 | -- @ 239 | vote 240 | :: ( Serialize b 241 | -- , Serialize [b] 242 | , Typeable b 243 | , HasFork io 244 | , CMC.MonadMask io) 245 | => Integer 246 | -> [a -> Workflow io b] 247 | -> ([b] -> Workflow io c) 248 | -> a 249 | -> Workflow io c 250 | vote timeout actions comp x= 251 | split actions x >>= select timeout (const $ return Continue) >>= comp 252 | 253 | 254 | -- | sum the outputs of a list of workflows according with its monoid definition 255 | -- 256 | -- @ sumUp timeout actions = vote timeout actions (return . mconcat) @ 257 | sumUp 258 | :: ( Serialize b 259 | -- , Serialize [b] 260 | , Typeable b 261 | , Monoid b 262 | , HasFork io 263 | , CMC.MonadMask io) 264 | => Integer 265 | -> [a -> Workflow io b] 266 | -> a 267 | -> Workflow io b 268 | sumUp timeout actions = vote timeout actions (return . mconcat) 269 | 270 | 271 | 272 | 273 | main= do 274 | syncWrite SyncManual 275 | r <- exec1 "sumup" $ sumUp 0 [f 1, f 2] "0" 276 | print r 277 | 278 | `CMC.catch` \(e:: SomeException) -> syncCache -- !> "syncCache" 279 | 280 | 281 | f :: Int -> String -> Workflow IO String 282 | f n s= step ( threadDelay ( 5000000 * n)) >> return ( s ++"1") 283 | 284 | 285 | main2=do 286 | syncWrite SyncManual 287 | exec1 "split" $ split (take 10 $ repeat (step . print)) "hi" >>= merge (const $ return True) 288 | 289 | 290 | main3=do 291 | -- syncWrite SyncManual 292 | refs <- exec1 "WFRef" $ do 293 | 294 | refs <- replicateM 20 $ newWFRef Nothing --"bye initial valoe" 295 | mapM (\r -> fork $ unsafeIOtoWF $ atomically $ writeWFRef r $ Just "hi final value") refs 296 | 297 | 298 | return refs 299 | mapM (\r -> liftIO (atomically $ readWFRef1 r) >>= print) refs 300 | 301 | 302 | 303 | 304 | -------------------------------------------------------------------------------- /Control/Workflow/Stat.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -XUndecidableInstances 2 | -XDeriveDataTypeable 3 | -XTypeSynonymInstances 4 | -XExistentialQuantification 5 | -XMultiParamTypeClasses 6 | -XFlexibleInstances 7 | -XOverloadedStrings 8 | -XRecordWildCards 9 | -XScopedTypeVariables 10 | -XPatternGuards 11 | #-} 12 | module Control.Workflow.Stat where 13 | 14 | import Data.TCache 15 | import Data.TCache.Defs 16 | 17 | import System.IO 18 | import System.IO.Unsafe 19 | import Data.Typeable 20 | import qualified Data.Map as M 21 | import Control.Concurrent(ThreadId) 22 | import Control.Concurrent.STM(TVar, newTVarIO) 23 | import Data.IORef 24 | import Data.RefSerialize 25 | import Data.Persistent.IDynamic 26 | 27 | import Control.Monad(replicateM) 28 | 29 | import qualified Data.ByteString.Lazy.Char8 as B hiding (index) 30 | import Data.ByteString.Char8(findSubstring) 31 | import Data.Persistent.IDynamic 32 | import Control.Concurrent 33 | import Control.Exception(catch,bracket,SomeException) 34 | import System.IO.Error 35 | 36 | import System.Directory 37 | import Data.List 38 | import Control.Monad 39 | 40 | --import Debug.Trace 41 | --(!>) = flip trace 42 | 43 | data WF s m l = WF { st :: s -> m (s,l) } 44 | 45 | 46 | data Stat = Running (M.Map String (String, (Maybe ThreadId))) 47 | | Stat{ self :: DBRef Stat 48 | , wfName :: String 49 | , state :: Int 50 | , recover :: Bool 51 | , timeout :: Maybe Integer 52 | , lastActive:: Integer 53 | , context :: (Context, B.ByteString) 54 | , references:: [(Int,(IDynamic,Bool))] 55 | , versions :: [IDynamic] 56 | } 57 | deriving (Typeable) 58 | 59 | stat0 = Stat{ wfName="", state=0, recover=False, versions = [] 60 | , lastActive=0, timeout= Nothing 61 | , context = (unsafePerformIO newContext,"") 62 | , references= [] 63 | , self=getDBRef ""} 64 | 65 | statPrefix1= "Stat" 66 | statPrefix= statPrefix1 ++"/" 67 | 68 | header Stat{..}= do 69 | insertString "\r\n" 70 | insertString $ B.pack statPrefix1 71 | showpText wfName 72 | showpText state 73 | insertChar('(') 74 | showp timeout 75 | insertChar(')') 76 | showp lastActive 77 | -- showp $ markAsWritten references 78 | -- where 79 | -- markAsWritten = map (\(n,(r,_)) -> (n,(r,True))) 80 | 81 | getHeader= do 82 | symbol statPrefix1 83 | wfName <- readp 84 | state <- readp 85 | timeout <- parens readp 86 | lastActive <- readp 87 | -- references <- readp 88 | c <- getRContext 89 | return (wfName, state, timeout, lastActive,[],c) 90 | 91 | lenLen= 50 92 | 93 | 94 | instance Serialize Stat where 95 | showp (Running map)= do 96 | insertString $ B.pack "Running" 97 | showp $ Prelude.map (\(k,(w,_)) -> (k,w)) $ M.toList map 98 | 99 | 100 | showp stat@Stat{..} = do 101 | s <- showps $ Prelude.reverse versions 102 | let l= show (B.length s + 1 + lenLen) ++" "++ show state 103 | insertString . B.pack $ l ++ take (fromIntegral lenLen - length l - 2) (repeat ' ')++ "\r\n" 104 | insertString s 105 | header stat 106 | 107 | readp = choice [rStat, rWorkflows] "on reading Workflow State" where 108 | rStat= do 109 | integer 110 | integer 111 | versions <- readp -- !> "read versions" 112 | (wfName, state, timeout, lastActive,references,cont) <- getHeader -- !> "read header" 113 | 114 | 115 | let self= getDBRef $ keyResource stat0{wfName= wfName} 116 | return $ Stat self wfName state True timeout lastActive 117 | cont references versions 118 | 119 | 120 | rWorkflows= do 121 | symbol "Running" 122 | list <- readp 123 | return $ Running $ M.fromList $ Prelude.map(\(k,w)-> (k,(w,Nothing))) list 124 | 125 | 126 | 127 | 128 | -- | Return the unique name of a workflow with a parameter (executed with exec or start) 129 | keyWF :: Indexable a => String -> a -> String 130 | keyWF wn x= wn ++ "/" ++ key x 131 | 132 | data WFRef a= WFRef !Int !(DBRef Stat) deriving (Typeable, Show, Read) 133 | 134 | instance Indexable (WFRef a) where 135 | key (WFRef n ref)= keyObjDBRef ref++('-':show n) 136 | 137 | 138 | --instance Serialize a => Serializable a where 139 | -- serialize = runW . showp 140 | -- deserialize = runR readp 141 | 142 | pathWFlows= (defPath (1:: Int)) ++ "workflow/" 143 | stFName st = pathWFlows ++ keyResource st 144 | 145 | Persist fr fw fd = filePersist 146 | 147 | --nheader= "/header" 148 | --nlog= "/log" 149 | --ncontext= "/context" 150 | 151 | 152 | instance IResource Stat where 153 | 154 | keyResource s@Stat{wfName=name}= statPrefix ++ name 155 | keyResource (Running _)= keyRunning 156 | 157 | 158 | readResourceByKey k = fr (pathWFlows ++ k) 159 | >>= return . fmap ( runR readp) 160 | 161 | delResource st= fd (stFName st) -- removeFile (stFName st) `catch`\(e :: IOError) -> return () 162 | 163 | writeResource runn@(Running _)= fw{- B.writeFile -} (stFName runn) . runW $ showp runn 164 | 165 | -- 166 | writeResource stat@Stat{..} 167 | | recover = return () -- !> "recover" 168 | 169 | | refs <- filter (\(n,(_,written))-> not written) references, 170 | not $ null refs= do 171 | let n= stFName stat 172 | st <- readResource stat -- !> ("WRITING references " ++ wfName ) 173 | safe n $ \h -> do 174 | let elems= case st of 175 | Just s@Stat{state=states,versions= verss} -> verss ++ (reverse $ take (state - states) versions ) 176 | Nothing -> reverse versions 177 | 178 | let versions'= substs elems refs 179 | hSeek h AbsoluteSeek 0 180 | B.hPut h $ runWC context $ showp $ stat{versions=reverse versions'} 181 | 182 | writeContext h 183 | hTell h >>= hSetFileSize h 184 | 185 | | otherwise= do 186 | let n= stFName stat 187 | safe n $ \h -> do 188 | (seek,written) <- getWritten h 189 | writeLog seek written h 190 | 191 | 192 | where 193 | 194 | writeHeader h= B.hPut h $ runWC context $ header stat 195 | 196 | writeLog seek written h 197 | 198 | | written==0=do 199 | hSeek h AbsoluteSeek 0 -- !> ("WRITING complete " ++ wfName ) 200 | B.hPut h . runWC context . showp $ stat 201 | 202 | writeContext h 203 | hTell h >>= hSetFileSize h 204 | 205 | | otherwise= do 206 | hSeek h AbsoluteSeek 0 -- !> ("WRITING partial " ++ wfName ) 207 | let s = runWC context $ insertString "\r\n" >> showpe written ( reverse $ take (state - written) versions) 208 | let l= show (seek - 5 + B.length s) ++" "++ show state 209 | B.hPut h . B.pack $ l ++ take (fromIntegral lenLen - length l - 2) (repeat ' ') ++ "\r\n" 210 | hSeek h AbsoluteSeek (fromIntegral seek - 5) 211 | B.hPut h s 212 | writeHeader h 213 | writeContext h 214 | hTell h >>= hSetFileSize h 215 | 216 | subst elems (n,( x,_))= 217 | let 218 | tail' []= [] 219 | tail' t = tail t 220 | (h,t)= splitAt n elems 221 | in h ++ ( x:tail' t) 222 | 223 | substs elems xs= foldl subst elems xs 224 | 225 | writeContext h= B.hPut h $ showContext (fst context) True 226 | 227 | getWritten h= do 228 | size <- hFileSize h 229 | if size == 0 then return (0,0) 230 | else do 231 | s <- B.hGetNonBlocking h (fromIntegral lenLen) 232 | return $ runR ( return (,) `ap` readp `ap` readp) s 233 | -- seek <- readp 234 | -- written <- readp 235 | -- ) s 236 | 237 | 238 | 239 | 240 | showpe _ [] = insertChar ']' 241 | showpe 0 (x:xs) = do 242 | rshowp x 243 | showpe 1 xs 244 | showpe v (x:l) = insertString "," >> rshowp x >> showpe v l 245 | 246 | 247 | 248 | safe name f= bracket 249 | (openFile name ReadWriteMode) 250 | hClose 251 | f 252 | `Control.Exception.catch` (handler name (safe name f)) 253 | where 254 | handler name doagain e 255 | | isDoesNotExistError e=do 256 | createDirectoryIfMissing True $ Prelude.take (1+(Prelude.last $ Data.List.elemIndices '/' name)) name --maybe the path does not exist 257 | doagain 258 | 259 | 260 | | otherwise= if ("invalid" `isInfixOf` ioeGetErrorString e) 261 | then 262 | error $ "writeResource: " ++ show e ++ " defPath and/or keyResource are not suitable for a file path" 263 | else do 264 | hPutStrLn stderr $ "defaultWriteResource: " ++ show e ++ " in file: " ++ name ++ " retrying" 265 | doagain 266 | 267 | 268 | hReadFile h = do 269 | s <- hFileSize h 270 | if s == 0 then return "" 271 | else B.hGetNonBlocking h (fromIntegral s) 272 | 273 | 274 | readHeader scont h= do 275 | size <- hFileSize h 276 | if size==0 then return Nothing else do 277 | s <- B.hGetNonBlocking h (fromIntegral size) 278 | return . Just $ runR getHeader $ s `B.append` scont 279 | 280 | 281 | 282 | 283 | keyRunning= "Running" 284 | 285 | 286 | 287 | 288 | instance Serialize ThreadId where 289 | showp th= return () -- insertString . pack $ show th 290 | readp = {-(readp `asTypeOf` return ByteString) >>-} (return . unsafePerformIO . forkIO $ return ()) 291 | 292 | 293 | 294 | -- | show the state changes along the workflow, that is, all the intermediate results 295 | showHistory :: Stat -> B.ByteString 296 | showHistory Stat {..}= runW sp 297 | where 298 | sp = do 299 | insertString $ B.pack "Workflow name= " 300 | showp wfName 301 | insertString $ B.pack "\n" 302 | showElem $ zip [1..] versions 303 | c <- getWContext 304 | insertString $ showContext (fst c) True 305 | 306 | -- showElem :: [(Int,IDynamic)] -> STW () 307 | showElem [] = insertChar '\n' 308 | showElem ((n , dyn):es) = do 309 | insertString $ B.pack "Step " 310 | showp (n :: Int) 311 | insertString $ B.pack ": " 312 | showp1 dyn 313 | insertChar '\n' 314 | showElem es 315 | 316 | showp1 (IDyn r)= 317 | case unsafePerformIO $ readIORef r of 318 | DRight x -> showp x 319 | DLeft (s, _) -> insertString s 320 | 321 | 322 | 323 | wFRefStr = "WFRef" 324 | 325 | -- | default instances 326 | 327 | instance (Show a, Read a )=> Serialize a where 328 | showp= showpText 329 | readp= readpText 330 | 331 | 332 | instance Serialize (WFRef a) where 333 | showp (WFRef n ref)= do 334 | insertString $ B.pack wFRefStr 335 | showp n 336 | showp $ keyObjDBRef ref 337 | 338 | readp= do 339 | symbol wFRefStr 340 | n <- readp 341 | k <- readp 342 | return . WFRef n $ getDBRef k 343 | 344 | 345 | 346 | -------------------------------------------------------------------------------- /Control/Workflow/Stat.many.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -XUndecidableInstances 2 | -XDeriveDataTypeable 3 | -XTypeSynonymInstances 4 | -XExistentialQuantification 5 | -XMultiParamTypeClasses 6 | -XFlexibleInstances 7 | -XOverloadedStrings 8 | -XRecordWildCards 9 | -XScopedTypeVariables 10 | #-} 11 | module Control.Workflow.Stat where 12 | 13 | import Data.TCache 14 | import Data.TCache.Defs 15 | 16 | import System.IO 17 | import System.IO.Unsafe 18 | import Data.Typeable 19 | import qualified Data.Map as M 20 | import Control.Concurrent(ThreadId) 21 | import Control.Concurrent.STM(TVar, newTVarIO) 22 | import Data.IORef 23 | import Data.RefSerialize 24 | import Control.Workflow.IDynamic 25 | import Control.Monad(replicateM) 26 | 27 | import qualified Data.ByteString.Lazy.Char8 as B hiding (index) 28 | import Data.ByteString.Char8(findSubstring) 29 | import Control.Workflow.IDynamic 30 | import Control.Concurrent(forkIO) 31 | import Control.Exception(bracket,SomeException) 32 | import System.IO.Error 33 | import System.Directory 34 | import Data.List 35 | 36 | import Debug.Trace 37 | 38 | (!>)= flip trace 39 | 40 | data WF s m l = WF { st :: s -> m (s,l) } 41 | 42 | 43 | data Stat = Running (M.Map String (String, (Maybe ThreadId))) 44 | | Stat{ self :: DBRef Stat 45 | , wfName :: String 46 | , state:: Int 47 | , recover:: Bool 48 | , timeout :: Maybe Integer 49 | , lastActive :: Integer 50 | , context :: (Context, B.ByteString) 51 | , references :: [(Int,(IDynamic,Bool))] 52 | , versions :: [IDynamic] 53 | } 54 | deriving (Typeable) 55 | 56 | stat0 = Stat{ wfName="", state=0, recover=False, versions = [] 57 | , lastActive=0, timeout= Nothing 58 | , context = (unsafePerformIO newContext,"") 59 | , references= [] 60 | , self=getDBRef ""} 61 | 62 | statPrefix1= "Stat" 63 | statPrefix= statPrefix1 ++"/" 64 | 65 | header Stat{..}= do 66 | insertString $ B.pack statPrefix1 67 | showpText wfName 68 | showpText state 69 | insertChar('(') 70 | showp timeout 71 | insertChar(')') 72 | showp lastActive 73 | showp $ markAsWritten references 74 | where 75 | markAsWritten = map (\(n,(r,_)) -> (n,(r,True))) 76 | 77 | 78 | --instance Serialize Stat where 79 | -- showp (Running map)= do 80 | -- insertString $ B.pack "Running" 81 | -- showp $ Prelude.map (\(k,(w,_)) -> (k,w)) $ M.toList map 82 | -- 83 | -- 84 | -- showp stat@Stat{..} = do 85 | -- header stat 86 | -- insertChar '\n' 87 | -- showp$ Prelude.reverse versions 88 | -- 89 | -- 90 | -- 91 | -- readp = choice [rStat, rWorkflows] "on reading Workflow State" where 92 | -- rStat= do 93 | -- symbol statPrefix1 94 | -- wfname <- stringLiteral 95 | -- state <- integer >>= return . fromIntegral 96 | -- let recover = True 97 | -- tim <- parens readp 98 | -- act <- readp 99 | -- references <- readp 100 | -- versions <- readp 101 | -- cont <- getRContext 102 | -- 103 | -- let self= getDBRef $ keyResource stat0{wfName= wfname} 104 | -- return $ Stat self wfname state recover tim act 105 | -- cont versions 106 | -- 107 | -- 108 | -- rWorkflows= do 109 | -- symbol "Running" 110 | -- list <- readp 111 | -- return $ Running $ M.fromList $ Prelude.map(\(k,w)-> (k,(w,Nothing))) list 112 | 113 | 114 | 115 | 116 | -- return the unique name of a workflow with a parameter (executed with exec or start) 117 | keyWF :: Indexable a => String -> a -> String 118 | keyWF wn x= wn ++ "/" ++ key x 119 | 120 | 121 | data WFRef a= WFRef !Int !(DBRef Stat) deriving (Typeable, Show) 122 | 123 | instance Indexable (WFRef a) where 124 | key (WFRef n ref)= keyObjDBRef ref++('#':show n) 125 | 126 | 127 | 128 | 129 | --instance Serialize a => Serializable a where 130 | -- serialize = runW . showp 131 | -- deserialize = runR readp 132 | 133 | pathWFlows= (defPath (1:: Int)) ++ "Workflow/" 134 | stFName st = pathWFlows ++ keyResource st 135 | Persist fr fw fd = defaultPersist 136 | 137 | nheader= "/header" 138 | nlog= "/log" 139 | ncontext= "/context" 140 | 141 | 142 | instance IResource Stat where 143 | 144 | keyResource s@Stat{wfName=name}= statPrefix ++ name 145 | keyResource (Running _)= keyRunning 146 | 147 | 148 | readResourceByKey k 149 | | k== keyRunning = fr (pathWFlows ++ k) 150 | >>= return . fmap ( runR readRunning) 151 | | otherwise= do 152 | 153 | let n= pathWFlows ++ k 154 | scont<- safe (n++ncontext) hReadFile 155 | mh <- bracket (openFile (n++nheader) ReadWriteMode) 156 | hClose 157 | (readHeader scont) 158 | `catch`\(e :: IOError) -> return Nothing 159 | 160 | case mh of 161 | Nothing -> return Nothing 162 | Just (wfName, state, timeout, lastActive,references,cont) -> do 163 | 164 | log <- safe (n++nlog) hReadFile 165 | let versions = runRC cont readp log 166 | let self= getDBRef $ keyResource stat0{wfName= wfName} 167 | return . Just $ 168 | Stat self 169 | wfName state 170 | True timeout lastActive 171 | cont references versions 172 | where 173 | readRunning= do 174 | symbol "Running" 175 | list <- readp 176 | return $ Running $ M.fromList $ Prelude.map(\(k,w)-> (k,(w,Nothing))) list 177 | 178 | 179 | 180 | delResource st= removeDirectoryRecursive (stFName st) `catch`\(e :: IOError) -> return () 181 | 182 | writeResource runn@(Running list)= B.writeFile (stFName runn) . runW $ showpRunning 183 | where 184 | showpRunning = do 185 | insertString $ B.pack "Running" 186 | showp $ Prelude.map (\(k,(w,_)) -> (k,w)) $ M.toList list 187 | -- 188 | writeResource stat@Stat{..}= do 189 | let n= stFName stat 190 | written <- safe (n++nheader) getWritten :: IO Int 191 | safe (n++nheader) writeHeader 192 | safe (n++nlog) $ writeLog written 193 | safe (n++ncontext) writeContext 194 | 195 | 196 | 197 | where 198 | 199 | writeHeader h= B.hPut h $ runWC context $ header stat 200 | 201 | writeLog written h 202 | | refs <- filter (\(n,(_,written))-> not written) references, 203 | not $ null refs= 204 | let versions'= substs versions refs 205 | in B.hPut h $ runWC context $ showp $ reverse versions' 206 | 207 | | written==0= 208 | B.hPut h $ runWC context $ showp $ reverse versions 209 | 210 | 211 | | otherwise= do 212 | hSeek h SeekFromEnd (-2) 213 | B.hPut h . runWC context $ insertString "\r\n" >> showpe written ( reverse $ take (state - written) versions) 214 | 215 | subst elems (n,( x,_))= 216 | let 217 | tail' []= [] 218 | tail' t = tail t 219 | (h,t)= splitAt n elems 220 | in h ++ ( x:tail' t) 221 | 222 | substs elems xs= foldl subst elems xs 223 | 224 | writeContext h= B.hPut h $ showContext (fst context) True 225 | 226 | getWritten h= do 227 | size <- hFileSize h 228 | if size == 0 then return 0 229 | else do 230 | s <- B.hGetNonBlocking h (fromIntegral size) 231 | return $ runR ( do 232 | symbol statPrefix1 233 | readp :: STR String 234 | readp) s 235 | 236 | 237 | 238 | showpe _ [] = insertChar ']' 239 | showpe 0 (x:xs) = do 240 | rshowp x 241 | showpe 1 xs 242 | showpe v (x:l) = insertString "," >> rshowp x >> showpe v l 243 | 244 | 245 | 246 | 247 | 248 | safe name f= bracket 249 | (openFile name ReadWriteMode) 250 | hClose 251 | f 252 | `catch` (handler name (safe name f)) 253 | where 254 | handler name doagain e 255 | | isDoesNotExistError e=do 256 | createDirectoryIfMissing True $ Prelude.take (1+(Prelude.last $ Data.List.elemIndices '/' name)) name --maybe the path does not exist 257 | doagain 258 | 259 | 260 | | otherwise= if ("invalid" `isInfixOf` ioeGetErrorString e) 261 | then 262 | error $ "writeResource: " ++ show e ++ " defPath and/or keyResource are not suitable for a file path" 263 | else do 264 | hPutStrLn stderr $ "defaultWriteResource: " ++ show e ++ " in file: " ++ name ++ " retrying" 265 | doagain 266 | 267 | 268 | hReadFile h = do 269 | s <- hFileSize h 270 | if s == 0 then return "" 271 | else B.hGetNonBlocking h (fromIntegral s) 272 | 273 | 274 | readHeader scont h= do 275 | size <- hFileSize h 276 | if size==0 then return Nothing else do 277 | s <- B.hGetNonBlocking h (fromIntegral size) 278 | return . Just $ runR getHeader $ s `B.append` scont 279 | where 280 | getHeader= do 281 | symbol statPrefix1 282 | wfName <- readp 283 | state <- readp 284 | timeout <- parens readp 285 | lastActive <- readp 286 | references <- readp 287 | c <- getRContext 288 | return (wfName, state, timeout, lastActive,references,c) 289 | 290 | 291 | keyRunning= "Running" 292 | 293 | 294 | 295 | 296 | instance Serialize ThreadId where 297 | showp th= return () -- insertString . pack $ show th 298 | readp = {-(readp `asTypeOf` return ByteString) >>-} (return . unsafePerformIO . forkIO $ return ()) 299 | 300 | 301 | 302 | -- | show the state changes along the workflow, that is, all the intermediate results 303 | showHistory :: Stat -> B.ByteString 304 | showHistory Stat {..}= runW sp 305 | where 306 | sp = do 307 | insertString $ B.pack "Workflow name= " 308 | showp wfName 309 | insertString $ B.pack "\n" 310 | showElem $ zip [1..] $ Prelude.reverse versions 311 | 312 | -- showElem :: [(Int,IDynamic)] -> STW () 313 | showElem [] = insertChar '\n' 314 | showElem ((n , dyn):es) = do 315 | insertString $ B.pack "Step " 316 | showp (n :: Int) 317 | insertString $ B.pack ": " 318 | showp dyn 319 | insertChar '\n' 320 | showElem es 321 | 322 | 323 | instance Indexable String where 324 | key= id 325 | 326 | instance Indexable Int where 327 | key= show 328 | 329 | instance Indexable Integer where 330 | key= show 331 | 332 | 333 | instance Indexable () where 334 | key _= "noparam" 335 | 336 | wFRefStr = "WFRef" 337 | 338 | instance Serialize (WFRef a) where 339 | showp (WFRef n ref)= do 340 | insertString $ B.pack wFRefStr 341 | showp n 342 | showp $ keyObjDBRef ref 343 | 344 | readp= do 345 | symbol wFRefStr 346 | n <- readp 347 | k <- readp 348 | return . WFRef n $ getDBRef k 349 | 350 | 351 | 352 | -------------------------------------------------------------------------------- /Control/Workflow/Stat.old.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -XUndecidableInstances 2 | -XDeriveDataTypeable 3 | -XTypeSynonymInstances 4 | -XExistentialQuantification 5 | -XMultiParamTypeClasses 6 | -XFlexibleInstances 7 | -XOverloadedStrings 8 | 9 | #-} 10 | module Control.Workflow.Stat where 11 | 12 | import Data.TCache 13 | 14 | import Data.ByteString.Lazy.Char8(pack, unpack) 15 | import System.IO.Unsafe 16 | import Data.Typeable 17 | import qualified Data.Map as M 18 | import Control.Concurrent(ThreadId) 19 | import Control.Concurrent.STM(TVar, newTVarIO) 20 | import Data.IORef 21 | import Data.RefSerialize 22 | import Control.Workflow.IDynamic 23 | import Control.Monad(replicateM) 24 | import Data.TCache.DefaultPersistence 25 | import Data.ByteString.Lazy.Char8 hiding (index) 26 | import Control.Workflow.IDynamic 27 | import Control.Concurrent(forkIO) 28 | 29 | 30 | data WF s m l = WF { st :: s -> m (s,l) } 31 | 32 | 33 | data Stat = Running (M.Map String (String, (Maybe ThreadId))) 34 | | Stat{ wfName :: String 35 | , state:: Int 36 | , index :: Int 37 | , recover:: Bool 38 | , versions :: [IDynamic] 39 | , lastActive :: Integer 40 | , timeout :: Maybe Integer 41 | , self :: DBRef Stat 42 | } 43 | deriving (Typeable) 44 | 45 | stat0 = Stat{ wfName="", state=0, index=0, recover=False, versions = [] 46 | , lastActive=0, timeout= Nothing, self=getDBRef ""} 47 | 48 | 49 | statPrefix= "Stat/" 50 | instance Indexable Stat where 51 | key s@Stat{wfName=name}= statPrefix ++ name 52 | key (Running _)= keyRunning 53 | defPath _= (defPath (1:: Int)) ++ "Workflow/" 54 | 55 | 56 | instance Serialize Stat where 57 | showp (Running map)= do 58 | insertString $ pack "Running" 59 | showp $ Prelude.map (\(k,(w,_)) -> (k,w)) $ M.toList map 60 | 61 | 62 | showp stat@( Stat wfName state index recover versions act tim _)=do 63 | insertString $ pack "Stat" 64 | showpText wfName 65 | showpText state 66 | showpText index 67 | showpText recover 68 | showp versions 69 | showp act 70 | insertChar('(') 71 | showp tim 72 | insertChar(')') 73 | 74 | 75 | readp = choice [rStat, rWorkflows] where 76 | rStat= do 77 | symbol "Stat" 78 | wfName <- stringLiteral 79 | state <- integer >>= return . fromIntegral 80 | index <- integer >>= return . fromIntegral 81 | recover <- bool 82 | versions <- readp 83 | act <- readp 84 | tim <- parens readp 85 | let self= getDBRef $ key stat0{wfName= wfName} 86 | return $ Stat wfName state index recover versions act tim self 87 | "Stat" 88 | 89 | rWorkflows= do 90 | symbol "Running" 91 | list <- readp 92 | return $ Running $ M.fromList $ Prelude.map(\(k,w)-> (k,(w,Nothing))) list 93 | "RunningWoorkflows" 94 | 95 | 96 | -- return the unique name of a workflow with a parameter (executed with exec or start) 97 | keyWF :: Indexable a => String -> a -> String 98 | keyWF wn x= wn ++ "/" ++ key x 99 | 100 | 101 | data WFRef a= WFRef !Int !(DBRef Stat) deriving (Typeable, Show) 102 | 103 | instance Indexable (WFRef a) where 104 | key (WFRef n ref)= keyObjDBRef ref++('#':show n) 105 | 106 | 107 | 108 | 109 | 110 | 111 | instance Serialize a => Serializable a where 112 | serialize = runW . showp 113 | deserialize = runR readp 114 | 115 | 116 | 117 | 118 | keyRunning= "Running" 119 | 120 | 121 | 122 | 123 | instance Serialize ThreadId where 124 | showp th= return () -- insertString . pack $ show th 125 | readp = {-(readp `asTypeOf` return ByteString) >>-} (return . unsafePerformIO . forkIO $ return ()) 126 | 127 | 128 | 129 | -- | show the state changes along the workflow, that is, all the intermediate results 130 | showHistory :: Stat -> ByteString 131 | showHistory (Stat wfName state index recover versions _ _ _)= runW sp 132 | where 133 | sp = do 134 | insertString $ pack "Workflow name= " 135 | showp wfName 136 | insertString $ pack "\n" 137 | showElem $ Prelude.reverse $ (Prelude.zip ( Prelude.reverse [1..] ) versions ) 138 | 139 | 140 | -- showElem :: [(Int,IDynamic)] -> STW () 141 | showElem [] = insertChar '\n' 142 | showElem ((n , dyn):es) = do 143 | showp $ pack "Step " 144 | showp (n :: Int) 145 | showp $ pack ": " 146 | showp dyn 147 | insertChar '\n' 148 | showElem es 149 | 150 | 151 | instance Indexable String where 152 | key= id 153 | 154 | instance Indexable Int where 155 | key= show 156 | 157 | instance Indexable Integer where 158 | key= show 159 | 160 | 161 | wFRefStr = "WFRef" 162 | 163 | instance Serialize (WFRef a) where 164 | showp (WFRef n ref)= do 165 | insertString $ pack wFRefStr 166 | showp n 167 | showp $ keyObjDBRef ref 168 | 169 | readp= do 170 | symbol wFRefStr 171 | n <- readp 172 | k <- readp 173 | return . WFRef n $ getDBRef k 174 | 175 | 176 | 177 | -------------------------------------------------------------------------------- /Demos/.tcachedata/workflow/Running: -------------------------------------------------------------------------------- 1 | Running [ ( "count/void" , "count" ) ] -------------------------------------------------------------------------------- /Demos/.tcachedata/workflow/Stat/count/void: -------------------------------------------------------------------------------- 1 | 161 9 2 | [ "() " 3 | , "() " 4 | , "() " 5 | , "() " 6 | , "() " 7 | , "() " 8 | , "() " 9 | , "() " 10 | , "() " ] 11 | Stat "count/void" 9 ( Nothing ) 0 -------------------------------------------------------------------------------- /Demos/WFReference.hs: -------------------------------------------------------------------------------- 1 | 2 | module Main where 3 | import Control.Workflow 4 | import Data.TCache 5 | import Control.Concurrent(threadDelay) 6 | import System.IO (hFlush,stdout) 7 | import Control.Concurrent 8 | import qualified Data.ByteString.Lazy.Char8 as B 9 | import Control.Monad.Trans 10 | 11 | 12 | main= do 13 | syncWrite SyncManual 14 | (ref,ref2) <- exec1 "WFRef" $ do 15 | step $ return (1 :: Int) 16 | ref <- newWFRef "bye initial value1" 17 | 18 | step $ return (3 :: Int) 19 | liftIO $ do 20 | s <- atomically $ readWFRef ref 21 | print s 22 | 23 | ref2 <- newWFRef "bye initial value2" 24 | 25 | liftIO $ do 26 | s <- atomically $ readWFRef ref2 27 | print s 28 | return (ref,ref2) 29 | print ref 30 | print ref2 31 | atomically $ writeWFRef ref "hi final value1" 32 | s <- atomically $ readWFRef ref 33 | print s 34 | atomically $ writeWFRef ref2 "hi final value2" 35 | s <- atomically $ readWFRef ref2 36 | print s 37 | Just stat <- getWFHistory "WFRef" () 38 | B.putStrLn $ showHistory stat 39 | syncCache 40 | atomically flushAll 41 | 42 | stat<- getWFHistory "WFRef" () `onNothing` error "stat not found" 43 | B.putStrLn $ showHistory stat 44 | s <- atomically $ readWFRef ref 45 | print s 46 | s <- atomically $ readWFRef ref2 47 | print s 48 | 49 | 50 | 51 | -------------------------------------------------------------------------------- /Demos/buyreserve: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | 3 | import Control.Workflow as WF 4 | import Data.TCache 5 | import Data.TCache.DefaultPersistence 6 | import Control.Concurrent.STM 7 | import Data.ByteString.Lazy.Char8(pack,unpack) 8 | import Data.Typeable 9 | import Control.Concurrent(forkIO,threadDelay, killThread) 10 | import Control.Monad.IO.Class(liftIO) 11 | import Control.Workflow.Stat 12 | import Data.Maybe 13 | import Data.Map (fromList) 14 | 15 | import Debug.Trace 16 | (!>)= flip trace 17 | 18 | data Book= Book{btitle :: String, stock,reserved :: Int} 19 | deriving (Read,Show, Eq,Typeable) 20 | 21 | instance Indexable Book where key= btitle 22 | 23 | instance Serializable Book where 24 | serialize= pack. show 25 | deserialize= read . unpack 26 | 27 | -- show 28 | main= do 29 | 30 | putStrLn "\nFIRST CASE: the stock appears at 20 seconds. \n\ 31 | \The WF is killed and restarted at 30 simulating a shutdown and restart.\n\ 32 | \It is bought at 40. The reserve timeouts (at 50) is not reached.\n" 33 | test 20 40 50 30 34 | 35 | putStrLn "press any key to start the second case" 36 | getChar 37 | 38 | putStrLn "\nSECOND CASE: the stock appears at 20. \n\ 39 | \It is killed at 10 simulating a shutdowm and restart.\n\ 40 | \It is bought at 60, after the end of the reserve (20+25)\n" 41 | test 20 60 25 10 42 | 43 | putStrLn "press a letter to start the third case" 44 | getChar 45 | 46 | putStrLn "\nTHIRD CASE: the product enter in stock at 25, when the reservation\ 47 | \period was finished\n\ 48 | \At 30 but the buyer appears shortly after and buy the product.\n\ 49 | \At 15 the WF is killed to simulate a shutdown\n" 50 | test 25 30 20 15 51 | 52 | putStrLn "END" 53 | 54 | -- /show 55 | 56 | test stockdelay buydelay timereserve stopdelay = do 57 | let keyBook= "booktitle" 58 | rbook= getDBRef keyBook 59 | 60 | -- enterStock stockdelay rbook 61 | 62 | -- buy buydelay rbook 63 | 64 | 65 | th <- forkIO $ exec "buyreserve" (buyReserve timereserve) keyBook 66 | 67 | stopRestart stopdelay timereserve th 68 | 69 | threadDelay $ (buydelay- stopdelay+1) * 1000000 70 | putStrLn "FINISHED" 71 | atomically $ delDBRef rbook 72 | putStrLn "----------------WORKFLOW HISTORY:--------------" 73 | h <- getHistory "buyreserve" keyBook 74 | putStrLn $ unlines h 75 | putStrLn "---------------END WORKFLOW HISTORY------------" 76 | delWF "buyreserve" keyBook 77 | 78 | 79 | 80 | 81 | buyReserve timereserve keyBook= do 82 | let rbook = getDBRef keyBook 83 | logWF $ "Reserve workflow start for: "++ keyBook 84 | t <- getTimeoutFlag timereserve -- $ 5 * 24 * 60 * 60 85 | 86 | r <- WF.step . atomically $ (reserveIt rbook >> return True) 87 | `orElse` (waitUntilSTM t >> return False) 88 | if not r 89 | then do 90 | logWF "reservation period ended, no stock available" 91 | return () 92 | 93 | else do 94 | logWF "The book entered in stock, reserved " 95 | t <- getTimeoutFlag timereserve -- $ 5 * 24 *60 * 60 96 | r <- WF.step . atomically $ (waitUntilSTM t >> return False) 97 | `orElse` (testBought rbook >> return True) 98 | 99 | if r 100 | then do 101 | logWF "Book was bought at this time" 102 | else do 103 | logWF "Reserved for a time, but reserve period ended" 104 | WF.step . atomically $ unreserveIt rbook 105 | return () 106 | 107 | 108 | 109 | reserveIt rbook = do 110 | mr <- readDBRef rbook 111 | case mr of 112 | Nothing -> retry 113 | Just (Book t s r) -> writeDBRef rbook $ Book t (s-1) (r+1) 114 | 115 | 116 | unreserveIt rbook= do 117 | mr <- readDBRef rbook 118 | case mr of 119 | Nothing -> error "where is the book?" 120 | Just (Book t s r) -> writeDBRef rbook $ Book t (s+1) (r-1) 121 | 122 | enterStock delay rbook= forkIO $ do 123 | liftIO $ threadDelay $ delay * 1000000 124 | putStrLn "ENTER STOCK" 125 | atomically $ writeDBRef rbook $ Book "booktitle" 5 0 126 | 127 | buy delay rbook= forkIO $ do 128 | threadDelay $ delay * 1000000 129 | atomically $ do 130 | mr <- readDBRef rbook 131 | case mr of 132 | Nothing -> error "Not in stock" 133 | Just (Book t n n') -> 134 | if n' > 0 !> show mr then writeDBRef rbook $ Book t n (n'-1) 135 | !> "There is in Stock and reserved, BOUGHT" 136 | else if n > 0 then 137 | writeDBRef rbook $ Book t (n-1) 0 138 | !> "No reserved, but stock available, BOUGHT" 139 | else error "buy: neither stock nor reserve" 140 | 141 | testBought rbook= do 142 | mr <- readDBRef rbook 143 | case mr of 144 | Nothing -> retry !> ("testbought: the register does not exist: " ++ show rbook) 145 | Just (Book t stock reserve) -> 146 | case reserve of 147 | 0 -> return() 148 | n -> retry 149 | 150 | stopRestart delay timereserve th= do 151 | threadDelay $ delay * 1000000 152 | killThread th !> "workflow KILLED" 153 | syncCache 154 | atomically flushAll 155 | restartWorkflows ( fromList [("buyreserve", buyReserve timereserve)] ) !> "workflow RESTARTED" 156 | 157 | getHistory name x= liftIO $ do 158 | let wfname= keyWF name x 159 | let key= keyResource stat0{wfName=wfname} 160 | atomically $ flushKey key 161 | mh <- atomically . readDBRef . getDBRef $ key 162 | case mh of 163 | Nothing -> return ["No Log"] 164 | Just h -> return . catMaybes 165 | . map eitherToMaybe 166 | . map safeFromIDyn 167 | $ versions h :: IO [String] 168 | where 169 | eitherToMaybe (Right r)= Just r 170 | eitherToMaybe (Left _) = Nothing 171 | 172 | 173 | -------------------------------------------------------------------------------- /Demos/buyreserve.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | 3 | import Control.Workflow as WF 4 | import Data.TCache 5 | import Data.TCache.DefaultPersistence 6 | import Control.Concurrent.STM 7 | import Data.ByteString.Lazy.Char8(pack,unpack) 8 | import Data.Typeable 9 | import Control.Concurrent(forkIO,threadDelay, killThread) 10 | import Control.Monad.IO.Class(liftIO) 11 | import Control.Workflow.Stat 12 | import Data.Maybe 13 | import Data.Map (fromList) 14 | 15 | import Debug.Trace 16 | (!>)= flip trace 17 | 18 | data Book= Book{btitle :: String, stock,reserved :: Int} 19 | deriving (Read,Show, Eq,Typeable) 20 | 21 | instance Indexable Book where key= btitle 22 | 23 | instance Serializable Book where 24 | serialize= pack. show 25 | deserialize= read . unpack 26 | 27 | -- show 28 | main= do 29 | 30 | putStrLn "\nFIRST CASE: the stock appears at 20 seconds.\n\ 31 | \The WF is killed and restarted at 30 simulatingn\ 32 | \a shutdown and restart.\n\ 33 | \It is bought at 40.\n\ 34 | \The reserve timeouts (at 50) is not reached.\n" 35 | test 20 40 50 30 36 | 37 | putStrLn "press any key to start the second case" 38 | getChar 39 | 40 | putStrLn "\nSECOND CASE: the stock appears at 20. \n\ 41 | \It is killed at 10 simulating a shutdowm\ 42 | \and restart.\n\ 43 | \It is bought at 60, after the end of the \ 44 | \reserve (20+25)\n" 45 | test 20 60 25 10 46 | 47 | putStrLn "press a letter to start the third case" 48 | getChar 49 | 50 | putStrLn "\nTHIRD CASE: the product enter in stock at 25,\ 51 | \nwhen the reservation period was finished.\n\ 52 | \At 30 but the buyer appears shortly after and\ 53 | \buy the product.\n\ 54 | \At 15 the WF is killed to simulate a shutdown\n" 55 | test 25 30 20 15 56 | 57 | putStrLn "END" 58 | 59 | -- /show 60 | 61 | test stockdelay buydelay timereserve stopdelay = do 62 | let keyBook= "booktitle" 63 | rbook= getDBRef keyBook 64 | 65 | enterStock stockdelay rbook 66 | 67 | buy buydelay rbook 68 | 69 | 70 | th <- forkIO $ exec "buyreserve" (buyReserve timereserve) keyBook 71 | 72 | stopRestart stopdelay timereserve th 73 | 74 | threadDelay $ (buydelay- stopdelay+1) * 1000000 75 | putStrLn "FINISHED" 76 | atomically $ delDBRef rbook 77 | putStrLn "----------------WORKFLOW HISTORY:--------------" 78 | h <- getHistory "buyreserve" keyBook 79 | putStrLn $ unlines h 80 | putStrLn "---------------END WORKFLOW HISTORY------------" 81 | delWF "buyreserve" keyBook 82 | 83 | 84 | 85 | 86 | buyReserve timereserve keyBook= do 87 | let rbook = getDBRef keyBook 88 | logWF $ "Reserve workflow start for: "++ keyBook 89 | t <- getTimeoutFlag timereserve -- $ 5 * 24 * 60 * 60 90 | 91 | r <- WF.step . atomically $ (reserveIt rbook >> return True) 92 | `orElse` (waitUntilSTM t >> return False) 93 | if not r 94 | then do 95 | logWF "reservation period ended, no stock available" 96 | return () 97 | 98 | else do 99 | logWF "The book entered in stock, reserved " 100 | t <- getTimeoutFlag timereserve -- $ 5 * 24 *60 * 60 101 | r <- WF.step . atomically $ (waitUntilSTM t >> return False) 102 | `orElse` (testBought rbook >> return True) 103 | 104 | if r 105 | then do 106 | logWF "Book was bought at this time" 107 | else do 108 | logWF "Reserved for a time, but reserve period ended" 109 | WF.step . atomically $ unreserveIt rbook 110 | return () 111 | 112 | 113 | 114 | reserveIt rbook = do 115 | mr <- readDBRef rbook 116 | case mr of 117 | Nothing -> retry 118 | Just (Book t s r) -> writeDBRef rbook $ Book t (s-1) (r+1) 119 | 120 | 121 | unreserveIt rbook= do 122 | mr <- readDBRef rbook 123 | case mr of 124 | Nothing -> error "where is the book?" 125 | Just (Book t s r) -> writeDBRef rbook $ Book t (s+1) (r-1) 126 | 127 | enterStock delay rbook= forkIO $ do 128 | liftIO $ threadDelay $ delay * 1000000 129 | putStrLn "ENTER STOCK" 130 | atomically $ writeDBRef rbook $ Book "booktitle" 5 0 131 | 132 | buy delay rbook= forkIO $ do 133 | threadDelay $ delay * 1000000 134 | atomically $ do 135 | mr <- readDBRef rbook 136 | case mr of 137 | Nothing -> error "Not in stock" 138 | Just (Book t n n') -> 139 | if n' > 0 then writeDBRef rbook $ Book t n (n'-1) 140 | !> "There is in Stock and reserved, BOUGHT" 141 | else if n > 0 then 142 | writeDBRef rbook $ Book t (n-1) 0 143 | !> "No reserved, but stock available, BOUGHT" 144 | else error "buy: neither stock nor reserve" 145 | 146 | testBought rbook= do 147 | mr <- readDBRef rbook 148 | case mr of 149 | Nothing -> retry !> ("testbought: the register does not exist: " ++ show rbook) 150 | Just (Book t stock reserve) -> 151 | case reserve of 152 | 0 -> return() 153 | n -> retry 154 | 155 | stopRestart delay timereserve th= do 156 | threadDelay $ delay * 1000000 157 | killThread th !> "workflow KILLED" 158 | syncCache 159 | atomically flushAll 160 | restartWorkflows ( fromList [("buyreserve", buyReserve timereserve)] ) !> "workflow RESTARTED" 161 | 162 | getHistory name x= liftIO $ do 163 | let wfname= keyWF name x 164 | let key= keyResource stat0{wfName=wfname} 165 | atomically $ flushKey key 166 | mh <- atomically . readDBRef . getDBRef $ key 167 | case mh of 168 | Nothing -> return ["No Log"] 169 | Just h -> return . catMaybes 170 | . map eitherToMaybe 171 | . map safeFromIDyn 172 | $ versions h :: IO [String] 173 | where 174 | eitherToMaybe (Right r)= Just r 175 | eitherToMaybe (Left _) = Nothing 176 | 177 | 178 | -------------------------------------------------------------------------------- /Demos/docAprobal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables #-} 2 | {- 3 | This program is an example of simple workflow management. Once a document 4 | is created by the user, a workflow controls two levels of approbal (boss and superboss) trough 5 | messages to the presentation layer of the three different user roles. 6 | 7 | A document is created by the user "user", then is validated by two bosses and thwo super bosses. 8 | If any of the two dissapprobe, the document is sent to the user to modify it. 9 | 10 | This program can handle as many document workflows as you like simultaneously. 11 | 12 | Workflow patterns and queue communication primitives are used. 13 | 14 | The second level of approbal has a timeout . The seralization of the document is 15 | trough the Serialize class of the RefSerialize package. 16 | 17 | approbed and dissapprobed documents are stored in their respective queues 18 | 19 | When te document title is modified, the workflow launches a new workflow with the new 20 | document and stops. 21 | 22 | 23 | 24 | -} 25 | module Main where 26 | import Control.Workflow 27 | 28 | import Data.Persistent.Collection 29 | import Control.Workflow.Patterns 30 | 31 | import Data.Typeable 32 | import System.Exit 33 | import Data.List (find) 34 | import Data.Maybe(fromJust) 35 | import Control.Monad (when) 36 | import Control.Concurrent 37 | import GHC.Conc ( atomically) 38 | import Data.RefSerialize 39 | import Data.TCache(syncCache) 40 | import qualified Data.ByteString.Lazy.Char8 as B 41 | 42 | import Data.Monoid 43 | 44 | 45 | import Debug.Trace 46 | 47 | 48 | (!>) a b= trace b a 49 | 50 | data Document=Document{title :: String , text :: [String]} deriving (Read, Show,Eq,Typeable) 51 | 52 | instance Indexable Document where 53 | key (Document t _)= "Doc#"++ t 54 | 55 | instance Serialize Document where 56 | showp (Document title text)= do 57 | insertString $ B.pack "Document" 58 | showp title 59 | rshowp text 60 | 61 | 62 | readp= do 63 | symbol "Document" 64 | title <- readp 65 | text <- rreadp 66 | return $ Document title text 67 | 68 | --instance Binary Document where 69 | -- put (Document title text)= do 70 | -- put title 71 | -- put text 72 | -- get= do 73 | -- title <- get 74 | -- text <- get 75 | -- return $ Document title text 76 | 77 | 78 | 79 | user= "user" 80 | 81 | approved = "approved" 82 | rejected = "rejected" 83 | 84 | quser :: String -> RefQueue (WFRef Document) 85 | quser user= getQRef user 86 | 87 | qdoc :: String -> RefQueue Document 88 | qdoc doc = getQRef doc 89 | 90 | qdocApprobal :: String -> RefQueue Bool 91 | qdocApprobal doc = getQRef doc 92 | 93 | 94 | qapproved :: RefQueue Document 95 | qapproved = getQRef approved 96 | 97 | qrejected :: RefQueue Document 98 | qrejected = getQRef rejected 99 | 100 | 101 | 102 | loop= loop 103 | 104 | main = do 105 | -- restart the interrupted document approbal workflows (if necessary) 106 | syncWrite SyncManual 107 | 108 | restartWorkflows [("docApprobal",docApprobal)] 109 | 110 | putStrLn "\nThis program is an example of simple workflow management; once a document is created a workflow thread controls the flow o mail messages to three different users that approbe or disapprobe and modify the document" 111 | putStrLn "A document is created by the user, then is validated by the boss and the super boss. If any of the two dissapprobe, the document is sent to the user to modify it." 112 | putStrLn "\n please login as:\n 1- user\n 2- boss1\n 3- boos2\n 4- super boss1\n 5- super boss2\n\n Enter the number" 113 | 114 | n <- getLine 115 | case n of 116 | "1" -> userMenu 117 | "2" -> aprobal "boss1" 118 | "3" -> aprobal "boss2" 119 | "4" -> aprobal "superboss1" 120 | "5" -> aprobal "superboss2" 121 | _ -> exitWith ExitSuccess 122 | 123 | 124 | bosses= ["boss1", "boss2"] 125 | superbosses= ["superboss1", "superboss2"] 126 | 127 | -- used by sumUp to sum the boolean "votes" 128 | -- in this case OR is used 129 | instance Monoid Bool where 130 | mappend = (||) 131 | mempty= False 132 | 133 | {- 134 | the approbal procedure of a document below. 135 | First the document reference is sent to a list of bosses trough a queue. 136 | they return a boolean trough a return queue ( askUser) 137 | the booleans are summed up according with a monoid instance by sumUp 138 | 139 | in checkValidated, if the resullt is false, the correctWF workflow is executed 140 | If the result is True, the pipeline continues to the next stage 141 | 142 | the next stage is the same process with a new list of users (superbosses). 143 | This time, there is a timeout of one day That time counts even if the program is 144 | not running. the result of the users that voted is summedup according with the 145 | same monoid instance 146 | 147 | in chechValidated1, if the result is true the document is added to the persistent list of approbed documents 148 | if the result is false, the document is added to the persistent list of rejectec documents (checlkValidated1) 149 | 150 | -} 151 | 152 | docApprobal :: Document -> Workflow IO () 153 | docApprobal doc = newWFRef doc >>= docApprobal1 154 | where 155 | -- using a reference instead of the doc itself 156 | docApprobal1 rdoc= 157 | return True >>= 158 | log "requesting approbal from bosses" >>= 159 | sumUp 0 (map(askUser (title doc) rdoc) bosses ) >>= 160 | checkValidated >>= 161 | log "requesting approbal from superbosses or timeout" >>= 162 | sumUp (1*day) (map(askUser (title doc) rdoc) superbosses) >>= 163 | checkValidated1 164 | 165 | where 166 | sec= 1 167 | min= 60* sec 168 | hour= 60* min 169 | day= 24*hour 170 | askUser _ _ user False = return False 171 | askUser title rdoc user True = do 172 | step $ push (quser user) rdoc 173 | logWF ("wait for any response from the user: " ++ user) 174 | step . pop $ qdocApprobal title 175 | 176 | 177 | -- log txt x = logWF txt >> return x 178 | 179 | checkValidated :: Bool -> Workflow IO Bool 180 | checkValidated val = 181 | case val of 182 | False -> correctWF (title doc) rdoc >> return False 183 | !> "not validated. re-sent to the user for correction" 184 | _ -> return True 185 | 186 | 187 | checkValidated1 :: Bool -> Workflow IO () 188 | checkValidated1 val = step $ do 189 | case val of 190 | False -> push qrejected doc 191 | _ -> push qapproved doc 192 | 193 | -- because there may have been a timeout, 194 | -- the doc references may remain in the queue 195 | mapM_ (\u ->deleteElem (quser u) rdoc) superbosses 196 | 197 | 198 | 199 | 200 | {- old code of docAprobal with no sumUp pattern 201 | docApprobal :: Document -> Workflow IO () 202 | docApprobal doc= do 203 | logWF "message sent to the boss requesting approbal" 204 | step $ writeTQueue qboss doc 205 | 206 | -- wait for any response from the boss 207 | ap <- step $ readTQueue $ qdoc doc 208 | case ap of 209 | False -> do logWF "not approved, sent to the user for correction" 210 | correctWF doc 211 | True -> do 212 | logWF " approved, send a message to the superboss requesting approbal" 213 | step $ writeTQueue qsuperboss doc 214 | 215 | -- wait for any response from the superboss 216 | -- if no response from the superboss in 5 minutes, it is validated 217 | flag <- getTimeoutFlag $ 5 * 60 218 | ap <- step . atomically $ readTQueueSTM (qdoc doc) 219 | `orElse` 220 | waitUntilSTM flag >> return True 221 | case ap of 222 | False -> do logWF "not approved, sent to the user for correction" 223 | correctWF doc 224 | True -> do 225 | logWF " approved, sent to the list of approved documents" 226 | step $ writeTQueue qapproved doc 227 | 228 | -} 229 | 230 | correctWF :: String -> WFRef Document -> Workflow IO () 231 | correctWF title1 rdoc= do 232 | -- send a message to the user to correct the document 233 | step $ push (quser user) rdoc 234 | -- wait for document edition 235 | doc' <- step $ pop (qdoc title1) 236 | if title1 /= title doc' 237 | -- if doc and new doc edited hace different document title, then start a new workflow for this new document 238 | -- since a workflow is identified by the workflow name and the key of the starting data, this is a convenient thing. 239 | then step $ exec "docApprobal" docApprobal doc' 240 | -- else continue the current workflow by retryng the approbal process 241 | else docApprobal doc' 242 | 243 | 244 | create = do 245 | separator 246 | doc <- readDoc 247 | putStrLn "The document has been sent to the boss.\nPlease wait for the approbal" 248 | forkIO $ exec "docApprobal" docApprobal doc 249 | userMenu 250 | 251 | userMenu= do 252 | separator 253 | putStrLn"\n\n1- Create document\n2- Documents to modify\n3- Approbed documents\n4- manage workflows\nany other- exit" 254 | n <- getLine 255 | case n of 256 | "1" -> create 257 | "2" -> modify 258 | "3" -> view 259 | "4" -> history 260 | _ -> syncCache >> exitSuccess !> "syncCache" 261 | 262 | userMenu 263 | 264 | 265 | 266 | history= do 267 | separator 268 | putStr "MANAGE WORKFLOWS\n" 269 | ks <- getWFKeys "docApprobal" 270 | mapM (\(n,d) -> putStr (show n) >> putStr "- " >> putStrLn d) $ zip [1..] ks 271 | putStr $ show $ length ks + 1 272 | putStrLn "- back" 273 | putStrLn "" 274 | putStrLn " select v[space] to view the history or d[space] to delete it" 275 | l <- getLine 276 | if length l /= 3 || (head l /= 'v' && head l /= 'd') then history else do 277 | let n= read $ drop 2 l 278 | let docproto= Document{title= ks !! (n-1), text=undefined} 279 | case head l of 280 | 'v' -> do 281 | getWFHistory "docApprobal" docproto >>= B.putStrLn . showHistory . fromJust 282 | history 283 | 'd' -> do 284 | delWF "docApprobal" docproto 285 | history 286 | 287 | _ -> history 288 | 289 | separator= putStrLn "------------------------------------------------" 290 | 291 | 292 | modify :: IO () 293 | modify= do 294 | separator 295 | let quseruser= quser user 296 | empty <- isEmpty (quseruser) :: IO Bool 297 | if empty then putStrLn "no more documents to modify\nthanks, enter as Boss for the approbal" 298 | else do 299 | rdoc <- pick (quser user) 300 | putStrLn "Please correct this doc" 301 | Just doc <- atomically $ readWFRef rdoc 302 | print doc 303 | doc1 <- readDoc 304 | 305 | -- return $ diff doc1 doc 306 | atomically $ do 307 | popSTM (quseruser) 308 | pushSTM (qdoc $ title doc) doc1 309 | modify 310 | 311 | diff (Document t xs) (Document _ ys)= 312 | Document t $ map (search ys) xs 313 | where 314 | search xs x= case find (==x) xs of 315 | Just x' -> x' 316 | Nothing -> x 317 | 318 | 319 | readDoc :: IO Document 320 | readDoc = do 321 | putStrLn "please enter the title of the document" 322 | title1 <- getLine 323 | h <- getWFHistory "docApprobal" $ Document title1 undefined 324 | case h of 325 | Just _ -> putStrLn "sorry document title already existent, try other" >> readDoc 326 | Nothing -> do 327 | putStrLn "please enter the text. " 328 | putStrLn "the edition will end wth a empty line " 329 | text <- readDoc1 [title1] 330 | return $ Document title1 text 331 | where 332 | readDoc1 text= do 333 | line <- getLine 334 | if line == "" then return text else readDoc1 $ text ++ [line] 335 | 336 | 337 | 338 | 339 | view= do 340 | separator 341 | putStrLn "LIST OF APPROVED DOCUMENTS:" 342 | view1 343 | where 344 | view1= do 345 | empty <- isEmpty qapproved 346 | if empty then return () else do 347 | doc <- pop qapproved :: IO Document 348 | print doc 349 | view1 350 | 351 | 352 | 353 | aprobal who= do 354 | separator 355 | aprobalList 356 | putStrLn $ "thanks , press any key to exit, "++ who 357 | threadDelay 10000000 358 | syncCache 359 | threadDelay 1000000 360 | return () 361 | where 362 | quserwho= quser who 363 | aprobalList= do 364 | empty <- isEmpty (quserwho) 365 | if empty 366 | then do 367 | putStrLn "No more document to validate. Bye" 368 | 369 | return () 370 | else do 371 | rdoc <- pick (quserwho) 372 | 373 | approbal1 rdoc 374 | aprobalList 375 | approbal1 :: WFRef Document -> IO () 376 | approbal1 rdoc= do 377 | putStrLn $ "hi " ++ who ++", a new request for aprobal has arrived:" 378 | Just doc <- atomically $ readWFRef rdoc 379 | print doc 380 | putStrLn $ "Would you approbe this document? s/n" 381 | l <- getLine 382 | if l/= "s" && l /= "n" then approbal1 rdoc else do 383 | let b= head l 384 | let res= if b == 's' then True else False 385 | -- send the message to the workflow 386 | atomically $ do 387 | popSTM (quserwho) 388 | pushSTM (qdocApprobal $ title doc) res 389 | 390 | 391 | 392 | 393 | 394 | -------------------------------------------------------------------------------- /Demos/fact.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -XDeriveDataTypeable #-} 2 | -- this program imput numbers and calculate their factorials. The workflow control a record all the inputs and outputs 3 | -- so that when the program restart, all the previous results are shown. 4 | -- if the program abort by a runtime error or a power failure, the program will still work 5 | -- enter 0 for exit and finalize the workflow (all the intermediate data will be erased) 6 | -- enter any alphanumeric character for aborting and then re-start. 7 | 8 | module Main where 9 | import Control.Workflow 10 | import Data.Typeable 11 | import Data.Binary 12 | import Data.RefSerialize 13 | import Data.Maybe 14 | 15 | 16 | fact 0 =1 17 | fact n= n * fact (n-1) 18 | 19 | 20 | -- now the workflow versión 21 | data Fact= Fact Integer Integer deriving (Typeable, Read, Show) 22 | 23 | 24 | 25 | instance Binary Fact where 26 | put (Fact n v)= put n >> put v 27 | get= do 28 | n <- get 29 | v <- get 30 | return $ Fact n v 31 | 32 | instance Serialize Fact where 33 | showp= showpBinary 34 | readp= readpBinary 35 | 36 | factorials = do 37 | all <- getAll 38 | let lfacts = mapMaybe safeFromIDyn all :: [Fact] 39 | unsafeIOtoWF $ putStrLn "Factorials calculated so far:" 40 | unsafeIOtoWF $ mapM (\fct -> print fct) lfacts 41 | factLoop (Fact 0 1) 42 | where 43 | factLoop fct= do 44 | nf <- plift $ do -- plift == step 45 | putStrLn "give me a number if you enter a letter or 0, the program will abort. Then, please restart to see how the program continues" 46 | str<- getLine 47 | let n= read str :: Integer -- if you enter alphanumeric characters the program will abort. please restart 48 | let fct= fact n 49 | print fct 50 | return $ Fact n fct 51 | 52 | case nf of 53 | Fact 0 _ -> do 54 | unsafeIOtoWF $ print "bye" 55 | return (Fact 0 0) 56 | _ -> factLoop nf 57 | 58 | 59 | main = exec1 "factorials" factorials 60 | -------------------------------------------------------------------------------- /Demos/hello.hs: -------------------------------------------------------------------------------- 1 | 2 | module Main where 3 | import Control.Workflow 4 | import Data.TCache hiding (syncWrite,SyncManual) 5 | 6 | 7 | main = do 8 | syncWrite SyncManual 9 | getName >>= putStrLn 10 | getName >>= putStrLn 11 | syncCache 12 | 13 | 14 | getName= exec1nc "test" $ do 15 | name <- step $ do 16 | putStrLn "your name?" 17 | getLine 18 | surname <- step $ do 19 | putStrLn "your surname?" 20 | getLine 21 | 22 | return $ "hello " ++ name++ " "++ surname 23 | 24 | -------------------------------------------------------------------------------- /Demos/inspect.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | -- example of the Workflow package . 3 | -- This demo shows inter-workflow communications. 4 | -- two workflows that interact by inspecting its other's state. One ask the user for a numbers. 5 | -- When the total number of tries 6 | -- is exhausted, update Data with termination and ends. 7 | ---It can end when termination comes from the other workflow. The other wait for "5", print 8 | -- a message , update Data with termination to the other and finish. t 9 | -- you can break the code at any moment. The flow will re-start in the last interrupted point 10 | -- For bugs, questions, whatever, please email me: Alberto Gómez Corona agocorona@gmail.com 11 | 12 | module Main where 13 | import Control.Workflow 14 | --import Debug.Trace 15 | --import Data.Typeable 16 | import Control.Concurrent 17 | import Control.Exception 18 | import System.Exit 19 | import Control.Concurrent.STM 20 | 21 | 22 | --debug a b = trace b a 23 | 24 | 25 | 26 | -- start_ if the WF was in a intermediate state, restart it 27 | -- A workflow state is identified by: 28 | -- the name of the workflow 29 | -- the key of the object whose worflow was called 30 | 31 | main= do 32 | forkIO $ exec1 "wait" wait >> return () 33 | exec1 "hello-ask" hello 34 | threadDelay 1000000 35 | delWF1 "wait" 36 | delWF1 "hello-ask" 37 | 38 | 39 | 40 | -- ask for numbers or "end". Inspect the step values of the other workflow 41 | -- and exit if the value is "good" 42 | hello :: Workflow IO () 43 | hello = do 44 | unsafeIOtoWF $ do 45 | putStrLn "" 46 | putStrLn "At any step you can break and re-start the program" 47 | putStrLn "The program will restart at the interrupted step." 48 | putStrLn "" 49 | --syncWrite Synchronous -- this is the default 50 | name <- step $ do 51 | print "what is your name?" 52 | getLine 53 | step $ putStrLn $ "hello Mr "++ name 54 | loop 0 name 55 | where 56 | loop i name=do 57 | unsafeIOtoWF $ threadDelay 100000 58 | str <- step $ do 59 | putStrLn $ "Mr "++name++ " this is your try number "++show (i+1) ++". Guess my number, press \"end\" to finish" 60 | getLine 61 | flag <- getTimeoutFlag 1 62 | -- waith for any character in any step on the "wait" workflow within one second span 63 | let anyString :: String -> Bool 64 | anyString = const True 65 | s <- step . atomically $ (waitForSTM anyString "wait" () >>= return . Just) 66 | `orElse` 67 | (waitUntilSTM flag >> return Nothing ) 68 | case s of 69 | Just "good" -> return () 70 | _ -> loop (i+1) name 71 | 72 | 73 | -- wait for a "5" or "end" in any step of the "hello" workflow, put an "good" and exit 74 | wait :: Workflow IO () 75 | wait = do 76 | let 77 | filter "5" = True 78 | filter "end" = True 79 | filter _ = False 80 | step $ do 81 | r <- waitFor filter "hello-ask" () -- wait the other thread to store an object with the same key than Try 0 "" 82 | -- with the string "5" or termination 83 | case r of 84 | "5" -> print "done ! " >> return "good" -- put exit in the WF state 85 | "end" -> print "end received. Bye" >> return "good" -- put exit in the WF state 86 | 87 | -- wait for the inspection of the other workflow 88 | unsafeIOtoWF $ threadDelay 500000 89 | 90 | 91 | 92 | 93 | -------------------------------------------------------------------------------- /Demos/sequence.hs: -------------------------------------------------------------------------------- 1 | 2 | module Main where 3 | import Control.Workflow 4 | import Control.Concurrent(threadDelay) 5 | import System.IO (hFlush,stdout) 6 | 7 | printLine x= do 8 | putStr (show x ++ " ") 9 | hFlush stdout 10 | threadDelay 1000000 11 | 12 | 13 | mcount :: Int -> Workflow IO () 14 | mcount n= do step $ printLine n 15 | mcount (n+1) 16 | 17 | 18 | main= exec1 "count" $ mcount 0 19 | -------------------------------------------------------------------------------- /IDE.session: -------------------------------------------------------------------------------- 1 | Time of storage: 2 | "Thu Apr 15 08:53:47 Romance Daylight Time 2010" 3 | Layout: VerticalP (TerminalP {paneGroups = fromList [], paneTabs = Just TopP, currentPage = 4, detachedId = Nothing, detachedSize = Nothing}) (HorizontalP (TerminalP {paneGroups = fromList [("Debug",HorizontalP (HorizontalP (TerminalP {paneGroups = fromList [], paneTabs = Nothing, currentPage = 0, detachedId = Nothing, detachedSize = Nothing}) (TerminalP {paneGroups = fromList [], paneTabs = Just TopP, currentPage = -1, detachedId = Nothing, detachedSize = Nothing}) 174) (TerminalP {paneGroups = fromList [], paneTabs = Just TopP, currentPage = -1, detachedId = Nothing, detachedSize = Nothing}) 180)], paneTabs = Just TopP, currentPage = 1, detachedId = Nothing, detachedSize = Nothing}) (TerminalP {paneGroups = fromList [], paneTabs = Just TopP, currentPage = 0, detachedId = Nothing, detachedSize = Nothing}) 224) 640 4 | Population: [(Just (BreakpointsSt BreakpointsState),[SplitP RightP,SplitP TopP]),(Just (BufferSt (BufferState "C:\\Users\\magocoal\\Documents\\haskell\\devel\\Workflow-0.5.7\\DocumentApprobalHTML.hs" 7145)),[SplitP LeftP]),(Just (ErrorsSt ErrorsState),[SplitP LeftP]),(Just (BufferSt (BufferState "C:\\Users\\magocoal\\Documents\\haskell\\devel\\Workflow-0.5.7\\Control\\HackMessageFlow.hs" 5898)),[SplitP LeftP]),(Just (BufferSt (BufferState "C:\\Users\\magocoal\\Documents\\haskell\\devel\\TCache-0.6.6\\Data\\TCache\\IDynamic.hs" 6206)),[SplitP LeftP]),(Just (InfoSt (InfoState (Descr {descrName' = "showsPrec", typeInfo' = "Int -> a -> ShowS", descrModu' = PM {pack = PackageIdentifier {pkgName = PackageName "base", pkgVersion = Version {versionBranch = [4,1,0,0], versionTags = []}}, modu = ModuleName ["GHC","Show"]}, mbLocation' = Nothing, mbComment' = Nothing, details' = MethodDescr {classDescrM = Descr {descrName' = "Show", typeInfo' = "class Show a\n showsPrec :: Int -> a -> ShowS\n show :: a -> String\n showList :: [a] -> ShowS\n", descrModu' = PM {pack = PackageIdentifier {pkgName = PackageName "base", pkgVersion = Version {versionBranch = [4,1,0,0], versionTags = []}}, modu = ModuleName ["GHC","Show"]}, mbLocation' = Nothing, mbComment' = Nothing, details' = ClassDescr {super = [], methods = [("showsPrec","Int -> a -> ShowS"),("show","a -> String"),("showList","[a] -> ShowS")]}}}}))),[SplitP RightP,SplitP TopP]),(Just (LogSt LogState),[SplitP RightP,SplitP BottomP]),(Just (ModulesSt (ModulesState 143 (System,False) (Just (ModuleName ["GHC","Show"]),Nothing) (ExpanderState {localExp = ([],[]), localExpNoBlack = ([],[]), packageExp = ([],[]), packageExpNoBlack = ([],[]), systemExp = ([],[]), systemExpNoBlack = ([[281,12],[281,4],[281],[129],[89],[86,38],[86],[70]],[])}))),[SplitP RightP,SplitP TopP]),(Just (SearchSt (SearchState {searchString = "showsPrec", searchScope = System, searchMode = Regex {caseSense = False}})),[SplitP RightP,SplitP TopP]),(Just (TraceSt TraceState),[SplitP RightP,SplitP TopP]),(Just (BufferSt (BufferState "C:\\Users\\magocoal\\Documents\\haskell\\devel\\Workflow-0.5.7\\Control\\Workflow\\Users.hs" 3446)),[SplitP LeftP]),(Just (VariablesSt VariablesState),[SplitP RightP,SplitP TopP]),(Just (BufferSt (BufferState "C:\\Users\\magocoal\\Documents\\haskell\\devel\\Workflow-0.6.0\\Control\\Workflow.hs" 6854)),[SplitP LeftP]),(Just (BufferSt (BufferStateTrans "_Eval.hs" "\n:l DocumentApprobalHTML.hs\n\n\nserialize1 $ Key (typeOf (undefined :: Int)) \"hola\" \"Key (Int) hola\"\nserialize1 $ deserialize1 $ \"Key (Int) hola\"\n \"*** Exception: error reading Key in the expression: Key (Int) hola\n\n span (/= ')') $ tail $ drop 4 \n \"Key (\" `isPrefixOf` \"Key (Int) hola\" " 1)),[SplitP RightP,SplitP TopP,GroupP "Debug",SplitP TopP,SplitP TopP]),(Just (BufferSt (BufferState "C:\\Users\\magocoal\\Documents\\haskell\\devel\\Workflow-0.5.7\\test.hs" 415)),[SplitP LeftP])] 5 | Window size: (1024,538) 6 | Active package: 7 | Just "C:\\Users\\magocoal\\Documents\\haskell\\devel\\Workflow-0.5.7\\Workflow.cabal" 8 | Active pane: Just "Users.hs" 9 | Toolbar visible: 10 | True 11 | FindbarState: (True,FindState {entryStr = "list", entryHist = ["list","Key","asFragments","\\\\","RunningWorkflows","all","map","WorkflowS","workflowS","wfs","getState","tvRunningWfs"], replaceStr = "/", replaceHist = [], caseSensitive = True, entireWord = False, wrapAround = True, regex = False, lineNr = 1}) 12 | Recently opened files: 13 | ["C:\\Users\\magocoal\\Documents\\haskell\\devel\\Workflow-0.5.7\\Demos\\Test.hs","C:\\Users\\magocoal\\Documents\\haskell\\devel\\Workflow-0.5.7\\test.hs","C:\\Users\\magocoal\\Documents\\haskell\\devel\\ghci.hs","C:\\Users\\magocoal\\Documents\\haskell\\devel\\Workflow-0.5.7\\test1.hs","C:\\Users\\magocoal\\Documents\\haskell\\devel\\ghci","C:\\Users\\magocoal\\Documents\\haskell\\devel\\TCache-0.6.6\\Data\\TCache.hs","C:\\Users\\magocoal\\Documents\\haskell\\devel\\Workflow-0.5.7\\Demos\\DocumentApprobalHTML.hs","C:\\Users\\magocoal\\Documents\\haskell\\devel\\Workflow-0.5.7\\Demos\\Test1.hs","C:\\Users\\magocoal\\Documents\\haskell\\devel\\Workflow-0.5.7\\Demos\\DocumentApprobalRefSerial.hs","C:\\Users\\magocoal\\Documents\\haskell\\devel\\Workflow-0.5.7\\Control\\HackMessageFlow.hs","C:\\Users\\magocoal\\Documents\\haskell\\devel\\Workflow-0.5.7\\Control\\MessageFlow.hs","C:\\Users\\magocoal\\Documents\\haskell\\devel\\Workflow-0.5.7\\Control\\Workflow.hs"] 14 | Recently opened packages: 15 | ["C:\\Users\\magocoal\\Documents\\haskell\\devel\\TCache-0.6.6\\TCache.cabal","C:\\Users\\magocoal\\Documents\\haskell\\devel\\Workflow-0.5.7\\Workflow.cabal","C:\\Users\\magocoal\\Documents\\haskell\\devel\\Workflow-0.6.0\\Workflow.cabal","C:\\Users\\magocoal\\Documents\\haskell\\devel\\TraceT\\TraceT.cabal"] -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) Alberto Gómez Corona 2008 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions 7 | are met: 8 | 1. Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 2. Redistributions in binary form must reproduce the above copyright 11 | notice, this list of conditions and the following disclaimer in the 12 | documentation and/or other materials provided with the distribution. 13 | 3. Neither the name of the author nor the names of his contributors 14 | may be used to endorse or promote products derived from this software 15 | without specific prior written permission. 16 | 17 | THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND 18 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 19 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 20 | ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE 21 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 22 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 23 | OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 24 | HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 25 | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 26 | OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF 27 | SUCH DAMAGE. 28 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | A workflow can be seen as a persistent thread. The workflow monad writes a log that permits to restore the thread at the interrupted point. step is the (partial) monad transformer for the Workflow monad. A workflow is defined by its name and, optionally by the key of the single parameter passed. There primitives for starting workflows also restart the interrupted workflow when it has been in execution previously. 2 | 3 | A small example that prints the sequence of integers in the console if you interrupt the program. When restarted again, it will start from the last printed number: 4 | 5 | module Main where 6 | import Control.Workflow 7 | import Control.Concurrent(threadDelay) 8 | import System.IO (hFlush,stdout) 9 | 10 | mcount n= do step $ do 11 | putStr (show n ++ " ") 12 | hFlush stdout 13 | threadDelay 1000000 14 | mcount (n+1) 15 | return () -- to disambiguate the return type 16 | 17 | main= exec1 "count" $ mcount (0 :: Int) 18 | >>> runghc demos\sequence.hs 19 | >0 1 2 3 20 | >CTRL-C Pressed 21 | >>> runghc demos\sequence.hs 22 | >3 4 5 6 7 23 | >CTRL-C Pressed 24 | >>> runghc demos\sequence.hs 25 | >7 8 9 10 11 26 | ... 27 | 28 | The program restarts at the last saved step. 29 | 30 | As you can see, some side effect can be re-executed after recovery if the log is not complete. This may happen after an unexpected shutdown (in this case) or due to an asynchronous log writing policy (see syncWrite). 31 | 32 | When the step results are big and complex, use the Data.RefSerialize package to define the (de)serialization instances. Then the log size will be reduced. printWFHistory method will print the structure changes in each step. 33 | 34 | If instead of RefSerialize, you use read and show instances, there will be no reduction. But it will still work, and the log will be readable for debugging purposes. The RefSerialize instance is automatically derived from Read, Show instances. 35 | 36 | Data.Binary instances are also fine for serialization. To use Binary, just define a binary instance of your data by using showpBinary and readpBinary. 37 | 38 | Within the RefSerialize instance of a structure, you can freely mix Show, Read, RefSerialize and Data Binary instances. 39 | 40 | Control.Workflow.Patterns contains higher level workflow patters of multiuser workflows. 41 | 42 | Control.Workflow.Configuration permits the use of workflows for configuration purposes. 43 | -------------------------------------------------------------------------------- /Setup.lhs: -------------------------------------------------------------------------------- 1 | #! /usr/bin/runghc 2 | 3 | > import Distribution.Simple 4 | > 5 | > main = defaultMain 6 | -------------------------------------------------------------------------------- /Workflow.cabal: -------------------------------------------------------------------------------- 1 |  2 | name: Workflow 3 | version: 0.8.3 4 | cabal-version: >= 1.6 5 | build-type: Simple 6 | license: BSD3 7 | license-file: LICENSE 8 | maintainer: agocorona@gmail.com 9 | stability: experimental 10 | bug-reports: agocorona@gmail.com 11 | synopsis: Workflow patterns over a monad for thread state logging & recovery 12 | description: Transparent support for interruptible computations. A workflow can be seen as a persistent thread that executes a 13 | monadic computation. Therefore, it can be used in very time consuming computations such are CPU intensive calculations 14 | or procedures that are most of the time waiting for the action of a process or an user, that are prone to comunication 15 | failures, timeouts or shutdowns. It also can be used if you like to restart your 16 | program at the point where the user left it last time 17 | . . 18 | The computation can be restarted at the interrupted point thanks to its logged state in permanent storage. 19 | The thread state is located in files by default. It can be moved and continued in another computer. 20 | Besides that, the package also provides other higher level services associated to workflows: Workflow patterns, 21 | and a general configuarion utility, workflow observation events and references to the internal state. 22 | The state can be stored maintaining memory references (using the "RefSerialize" package), so that it is possible to track the modifications 23 | of a big structure (for example a document) along the workflow execution. 24 | . 25 | See "Control.Workflow" for details 26 | . 27 | In this release: 28 | * Adaptation for MonadMask instance introduced in the package exceptions-0.6 29 | 30 | category: Control, Workflow 31 | 32 | author: Alberto Gómez Corona 33 | 34 | data-dir: "" 35 | 36 | extra-source-files: Demos/Fact.hs Demos/Inspect.hs 37 | Demos/docAprobal.hs Demos/sequence.hs 38 | 39 | 40 | 41 | library 42 | build-depends: exceptions >= 0.6, RefSerialize , 43 | TCache , base >=4 && <5, binary , bytestring , 44 | containers , directory -any, extensible-exceptions , 45 | mtl , old-time , stm >2, vector 46 | 47 | exposed-modules: Control.Workflow 48 | Control.Workflow.Configuration 49 | Control.Workflow.Patterns 50 | Control.Workflow.Stat 51 | exposed: True 52 | buildable: True 53 | extensions: OverlappingInstances UndecidableInstances 54 | MultiParamTypeClasses ExistentialQuantification 55 | TypeSynonymInstances RecordWildCards DeriveDataTypeable 56 | hs-source-dirs: . 57 | other-modules: 58 | 59 | 60 | source-repository head 61 | type : git 62 | location: https://github.com/agocorona/Workflow 63 | -------------------------------------------------------------------------------- /notes.lhs: -------------------------------------------------------------------------------- 1 | instalar requirments 2 | meter setHeader como un requirement 3 | setHeader que incluya requirement 4 | 5 | data WebRequirement= CSSFile String 6 | | CSS String 7 | | JScriptFile String 8 | | JScript String 9 | | ServerProc (String, Token -> Workflow IO ()) 10 | | Header view 11 | | Body view 12 | 13 | if not null WebRequirement 14 | composerequirements 15 | else 16 | use mfHeader 17 | 18 | no es demasiado complicado? 19 | la opción anterior de introducir scripts via javascript. 20 | es mas potente (Puede usarse en runtime) 21 | hay que inyectar el codigo de inyeccion 22 | se puede hacer online?, hay que meter un tag 23 | 24 | 25 | como hacer backup: 26 | hacer que lea de un nuevo directorio 27 | rename TCacheData a ese directorio 28 | escribe en el nuevo 29 | copiar del viejo al nuevo todo 30 | 31 | paraar la escritura 32 | hacer una copia 33 | 34 | 35 | reversible monad: 36 | 37 | Instance Monad m,n => Reversible m n where 38 | reverse :: (a -> m b) -> (b -> n a) 39 | 40 | como establecer contratos: 41 | 42 | type verified= Bool 43 | 44 | data Prime = Prime Int isPrime Verified (Int -> Bool) 45 | 46 | data Ring 47 | class Class a where 48 | cf1 49 | cf2 50 | 51 | 52 | 53 | un workflow puede continuar a través de grupos y usuarios 54 | o puede ser un grupo activo con sus propios workflows 55 | como se arregla 56 | 57 | 58 | un grupo tiene que tener categorias de propuestas 59 | categorias tiene asociado workflow 60 | al crear una categoria, hay que crear un workflow o elegir entre los ya existentes 61 | cuando se crean las categorias? cuando se crea el grupo 62 | 63 | data WFData = WFData{ wfname :: WFName 64 | 65 | , wfprotos :: [Subject]} 66 | 67 | wfGroups= select $ pwrokflow .=. wfname 68 | 69 | donde los protos? aparte de todo 70 | WFData eliminado 71 | 72 | 73 | 74 | se puede generar una estructura por menu? no. 75 | 76 | primer mensaje que recibe un usuario: 77 | opción de crear un grupo 78 | lo recibe en su cola un proto de grupo. 79 | 80 | como se edita un wf creado con runConfiguration? 81 | alternando (many/once) 82 | 83 | editStep ui= do 84 | readIORef n 85 | if n== stat then many1 ui else once ui 86 | wher 87 | many1 ui= do 88 | r <- ui 89 | 90 | 91 | como configurar un workflow para un grupo: 92 | wfData wfName groups protos tipos 93 | 94 | cuando se activan? 95 | cuando se crea el subject 96 | pero el registro de un wf ocurre al registrar un proto 97 | se envia al grupo y se inicia el wf 98 | 99 | procedimiento mas automatico, porque otro WF puede enviar algo a un grupo no solo un usuario al crearlo 100 | se mira la cola detectando adiciones 101 | se mira el tipo de subject con atributo tipo 102 | se lanza el WF 103 | 104 | como se mira la cola? trigger 105 | sendToGroup 106 | addTrigger onmsgadded 107 | onmgsadded ref Just (Queue n q1 q2) 108 | | qname /= n -> return() 109 | | otherwise = 110 | 111 | 112 | data Status a = Active | Killed | Finished | Returned a deriving (Eq,Typeable) 113 | data SpawnWF a= Spawned{name :: String, status :: Status a} deriving (Eq,Typeable) 114 | 115 | type WFControl a= WFRef (SpawnWF a) 116 | spawneds= "Spawned" 117 | actives= "Active" 118 | killeds= "Killed" 119 | finisheds= "Finished" 120 | returneds= "Returned" 121 | 122 | instance (Serialize a) =>Serialize (SpawnWF a) where 123 | showp (Spawned name status) = do 124 | insertString $ pack spawneds 125 | insertChar '{' 126 | showp name 127 | insertChar ',' 128 | case status of 129 | Active -> insertString $ pack actives 130 | Killed -> insertString $ pack killeds 131 | Finished -> insertString $ pack finisheds 132 | Returned x -> do 133 | insertString (pack returneds) 134 | showp x 135 | 136 | insertChar '}' 137 | readp= do 138 | symbol spawneds 139 | symbol "{" 140 | name <- stringLiteral 141 | status <- choice [activep, killedp, finishedp, returnedp] 142 | symbol "{" 143 | return $ Spawned name status 144 | where 145 | activep= symbol actives >> return Active 146 | killedp= symbol killeds >> return Killed 147 | finishedp= symbol finisheds >> return Finished 148 | returnedp= do 149 | symbol returneds 150 | x <- readp 151 | return (Returned x) 152 | 153 | 154 | spawn 155 | :: (CMC.MonadCatchIO m, 156 | HasFork m, 157 | TwoSerializer w r a (), 158 | Typeable a, Eq a) => 159 | (WFControl a -> Workflow m a) 160 | -> WF Stat m (ThreadId, WFControl a) 161 | spawn f=do 162 | Spawned str status <- step $ getTempName >>= \n -> return ( Spawned n Active) 163 | r <- getWFRef 164 | WF (\s -> 165 | do th <- if status/= Active 166 | then fork $ return () 167 | else fork $ do 168 | exec1 str (f r) 169 | liftIO $ do 170 | atomically $ do 171 | Spawned _ status <- readWFRef r >>= justify "spawn" 172 | when (status== Active) $ 173 | writeWFRef r (Spawned str Finished) 174 | syncIt 175 | return(s,(th,r))) 176 | 177 | 178 | instance (HasFork io 179 | , CMC.MonadCatchIO io) 180 | => HasFork (WF Stat io) where 181 | fork f = spawn (const f) >>= \(th,_) -> return th 182 | 183 | - | spawn a list of independent workflows (the first argument) with a seed value (the second argument). 184 | -- Their results are reduced by `merge` or `select` 185 | split :: ( Typeable b 186 | , DynSerializer w r (Maybe b) 187 | , HasFork io 188 | , CMC.MonadCatchIO io) 189 | => [a -> Workflow io b] -> a -> Workflow io [WFRef (SpawnWF b)] 190 | split actions a = 191 | mapM (\ac -> 192 | 193 | (spawn (\mv -> ac a >>= 194 | step . liftIO . atomically . writeWFRef mv . Just)) 195 | 196 | actions 197 | 198 | fallos: 199 | 200 | no borra exec1d 201 | no serializa todas las colas 202 | 203 | por que es necesiario un flag finished? 204 | 205 | entra la segunda vez en recovery. step no puede iniciar, 206 | necesita añadir el spawned a la lista de restartWorkflows 207 | pero no se puede porque sus parametros no están calculados 208 | 209 | 210 | eb lugar de un var= hash 211 | 212 | var = lookup hash val 213 | 214 | 215 | return (1+) <$> return (2) <*> return 3 <*> return 4 216 | 217 | Control.Workflow.UserDefs.User <$> digest [] Nothing 218 | <*> digest [] Nothing 219 | <*> (return (Form [] [])) 220 | <*> digest [] Nothing 221 | 222 | askList:: (GetLine a, Digest a) => 223 | => Token -> Params -> [a] -> IO [a] 224 | 225 | askList xs= do 226 | send t form .comumn . map getLine xs 227 | receiveReq t 228 | 229 | 230 | Form view a = Form view a 231 | 232 | newtype FormT view a = FormT { runFormT :: m (From view a) } 233 | 234 | 235 | instance (Functor m, Monad m) => Applicative (FormT view) where 236 | pure a = FormT $ return (Form [] a) 237 | FormT f <*> FormT v = FormT $ f >>= Form form1 k -> 238 | v >>= Form form2 x-> return (Right (k x)) 239 | 240 | class Digest a view where 241 | digest :: Params -> IO (Form [view] a) 242 | 243 | instance (Digest a , Digest b ) => Digest (a,b) where 244 | digest prms= do 245 | Form f1 a <- digest prms 246 | Form f2 b <- digest prms 247 | return Form (mappend f1 f2) (a,b) 248 | 249 | ask t req page= do 250 | Form form x <- digest req 251 | case form of 252 | [] -> return x 253 | _ -> do 254 | 255 | send t $ mappend (column $ form) page 256 | req <- return . getParamms =<< receiveReq t 257 | ask t req page 258 | 259 | 260 | 261 | 262 | instance (Monad m) => Monad (MEitherT m) where 263 | fail _ = MEitherT (return Nothing) 264 | return = lift . return 265 | x >>= f = MEitherT $ do 266 | v <- runMEitherT x 267 | case v of 268 | Nothing -> return Nothing 269 | Just y -> runMEitherT (f y) 270 | 271 | 272 | 273 | instance Monoid e => Monad (Form e) where 274 | return x = Form [] x 275 | Form f1 x >> Form f2 y -> Form $ mappend errs1 errs 276 | (MLeft errs, MRight _) -> MLeft errs 277 | (MRight _, r) -> r 278 | 279 | 280 | x >>= f = case x of 281 | MRight r -> f r 282 | MLeft errs -> MLeft errs 283 | 284 | 285 | hay que decorar el form (con page?) 286 | ask t req page= do 287 | mx <- digest req 288 | case mx of 289 | MRight x -> return x 290 | MLeft msgs -> do 291 | send t $ mappend (column $ msgs) page 292 | r <- receiveReq t >>= digest . getParams 293 | 294 | case r of 295 | MRight x -> return x 296 | MLeft msgs -> ask t [] $ mappend (column $ map fromString msgs) page 297 | 298 | 299 | 300 | 301 | otros problemas como componer: 302 | 303 | data X a b= X a b 304 | 305 | instance Digest a view where 306 | digest env= 307 | x <- digest env 308 | y <- digest env 309 | return $ do 310 | x' <- x 311 | y' <- y 312 | return $ X x' y' 313 | 314 | 315 | result <- runMaybeT (MaybeT foo >>= MaybeT bar >>= MaybeT baz) 316 | 317 | newtype MEitherT m a = MaybeT { runMEitherT :: m (MEither a) } 318 | 319 | instance (Monad m) => Monad (MEitherT m) where 320 | fail _ = MEitherT (return Nothing) 321 | return = lift . return 322 | x >>= f = MEitherT $ do 323 | v <- runMEitherT x 324 | case v of 325 | Nothing -> return Nothing 326 | Just y -> runMEitherT (f y) 327 | 328 | 329 | Form a= MEither view a 330 | 331 | form :: Form a 332 | form= X <$> digest a <$> digest b 333 | 334 | 335 | usar un segunda key como clave. 336 | tiene asocuado un Map segCamp pKey 337 | 338 | join or reference: 339 | 340 | > data Person= Person{ name :: String, cars :: [DBRef Car]} 341 | > data Car{owner :: DBRef Person ,name:: String} 342 | 343 | > registerModifyTrigger (\car@(Car powner _ ) -> 344 | > withDBRef powner $ \m case m of 345 | > Just owner -> writeDBRef powner owner{cars= nub $ cars owner ++ car] 346 | 347 | 348 | > main= do 349 | > bruce <- newDBRef $ Person "Bruce" [] 350 | > withResources [] $ const [Car bruce "Bat Mobile", 351 | > ,Car bruce "Porsche"] 352 | > print $ cars bruce 353 | 354 | 355 | pathom types 356 | 357 | data Expr a = Expr PrimExpr 358 | 359 | constant :: Show a => a -> Expr a 360 | (.+.) :: Expr Int -> Expr Int -> Expr Int 361 | (.==.) :: Eq a=> Expr a-> Expr a-> Expr Bool 362 | (.&&.) :: Expr Bool -> Expr Bool-> Expr Bool 363 | 364 | data PrimExpr 365 | = BinExpr BinOp PrimExpr PrimExpr 366 | | UnExpr UnOp PrimExpr 367 | | ConstExpr String 368 | 369 | data BinOp 370 | = OpEq | OpAnd | OpPlus | ... 371 | 372 | ------------ 373 | selectors 374 | 375 | type Collection v = Collection Vector (DBRef v) 376 | 377 | data Selector v= LT v `In` Collection v | EQ v | And Sel v Sel v.... 378 | 379 | expand :: a (Selector v) -> [a v] 380 | 381 | 382 | 383 | 384 | readResource puede no depender de la key 385 | por tanto un prototipo con un valor incompleto puede servir 386 | para recuperar una colección 387 | readResources :: a -> [a] 388 | 389 | readResource :: a -> a 390 | 391 | readResourceByKey :: String -> a 392 | 393 | Para que puede servir readResources? 394 | para 395 | 396 | Select a= All | Only a | LEqual a | GThan a 397 | 398 | 399 | instance Functor Tree a => 400 | 401 | 402 | data Emp name company= Emp{name :: key , company :: company ....} 403 | 404 | data Emp (Select Nombre)(Select Company) 405 | 406 | instance Functor (Emp n c ) where 407 | fmap f emp= emp {name= f $ name emp, company= f $ company emp... 408 | 409 | 410 | -- elimina todos los All 411 | class CacheExpland a selector where 412 | expand :: a (selector s) -> IO [a s] 413 | 414 | class CacheExpland2 a selector selector' where 415 | expand :: a (selector s) (selector' t) -> IO [a s t] 416 | 417 | 418 | expand Emp{name = GT "B", company="jljljl"..}= 419 | 420 | instance Expansor (selector x) where 421 | expansor All = Index [key] 422 | expansor Only x= 423 | 424 | initSelector x= 425 | 426 | instance IResource (a s)=> IResource a (selector s) 427 | 428 | 429 | ------------------- 430 | DBRef RRef 431 | 432 | data DBList a= DBList a 433 | 434 | readDBList (DBList a)= getListResources a 435 | 436 | getListResources :: [a] -> [Maybe[a]] 437 | 438 | 439 | .............. 440 | 441 | strong deserialization sin necesidad de registerType 442 | 443 | 444 | array of types 445 | 446 | strongSerialize x= 447 | registerType x -- add to a serializrable vector 448 | hasString typeOf x ++ serialise x 449 | 450 | strongDeserialize str= 451 | let n= read 452 | deserial= vector ! n 453 | 454 | vector= Vector (typeRef,deserialize, readp) 455 | show vector= typeReps 456 | 457 | deserialize vector= 458 | 459 | 460 | mewtype DBRef a= DBRef TVar (Either Key (Elem a)) 461 | 462 | data Elem a= Elem{ key :: String, inDBRef :: Bool, value :: aNY_PORT 463 | , modifyTime, accessTime :: Integer} 464 | 465 | inDBRef sirve para saber si eliminar el TVar del cache o no 466 | si es parte de una DBRef instanciada con newDBRef, entonces se mantiene 467 | en el cache. 468 | 469 | como saber si una DBRef ya no se se utiliza? 470 | un DBRef con TVar Nothing, como se elimina del cache si no se usa? 471 | problema: si esta linkado en el cache no se ejecuta el onDelete 472 | si no esta en el cache, no se le puede recargar 473 | 474 | Definir data DBref1 a= DBRef1 (DBRef a)y solo meter en cache DBRef 475 | ---------------------- 476 | triggers 477 | 478 | 479 | 480 | data TriggerType= OnCreateModify | OnDelete 481 | 482 | data Trigger= forall a. (IResource a, Typeable a) => Trigger TriggerType TypeRep (a -> IO() 483 | 484 | triggers :: IORef [Trigger] 485 | 486 | 487 | registerTrigger :: (IResource a, Typeable a) => TriggerType -> (a -> IO()) -> IO() 488 | registerTrigger t= atomicModifyIORef (ts -> t:ts) 489 | 490 | applyTriggers:: (IResource a, Typeable a) => TriggerType -> a -> IO() 491 | applyTriggers applytype a = do 492 | ts <- readIORef triggers 493 | mapM_ (f a) ts 494 | where 495 | f a (Trigger ttype type t)= 496 | if applytype==ttype&& typOf a == type 497 | then t a 498 | else return() 499 | 500 | Web monad context 501 | Params 502 | lang 503 | userName 504 | 505 | 506 | mixer de monads: 507 | 508 | class SwitchMonads m n where 509 | switch :: m a -> (a -> n b) -> n b 510 | 511 | >>=> 512 | 513 | instance SwitchMonads (Either msg) Maybe where 514 | (Left _) `switch` f= Nothing 515 | (Right x) `switch` f= f x 516 | 517 | instance SwitchMonads (Either msg) (IO Maybe) where 518 | (Left _) `switch` f= return Nothing 519 | (Right x) `switch` f= f x 520 | 521 | una RefVar es o una referencia auna tupla o la clave para accederla 522 | data Ref x= TVar cacheElem | RKey x 523 | 524 | data Elem a= TVar (Elem a AccessTime ModifTime) | EKey String a 525 | 526 | type TPVar a= IORef (Elem a) deriving Typeable 527 | 528 | una estructura con References: 529 | 530 | data Struc X= Struc{ a: Ref A, b:: Ref B} 531 | 532 | x= Struct (newRef A a) (newRef B b) 533 | 534 | a'= takeRef (a x) 535 | 536 | 537 | como identificar el index de un usuario 538 | 539 | cada mensaje tiene que tener asociado un grupo 540 | para que? para que el usuario sepa de que grupo viene 541 | el grupo está asociado a unaq cola 542 | la cola depende de un rol 543 | rol = grupo = cola 544 | rol de usuario debe ser una lista 545 | 546 | como se indexan los usuarios? 547 | 548 | ccomo se asignan los verbos? 549 | 550 | actions= [(String, Params -> view)] 551 | 552 | como elegir los verbos 553 | view edit 554 | view vote delegate 555 | dejarlo como datos en la segunda estructura 556 | enm la segunda estructura, se pone 557 | 558 | data List a dat view= () 559 | IResource a, Typeable a, Digest a, Editable a view) 560 | => List a dat todo deriving Typeable 561 | 562 | actions=[("view/vote", mappend (view a) (vote dat)), ("delegate", delegate dat 563 | 564 | ---- 565 | diferencia entre ask y editElem? 566 | ask es sobre un objeto 567 | editElem es sobre una lista de objetos 568 | se necesitan varios 569 | 570 | hace falta una clase que 571 | permita editar 572 | permita votar 573 | datos a editar: 574 | (obj, data) 575 | 576 | verbos sobre obj: 577 | vew 578 | edit 579 | viewLine 580 | sobre data: 581 | user defined 582 | 583 | 584 | 585 | 586 | instance Editable a -> editable List a 587 | 588 | instance Digest a => Digest (List a) 589 | 590 | instance Editable obj, Editable data => Editable List(obj,data) 591 | showLine p (List (o,d))= row $ showLine p o hsep showLine p d 592 | render p (List (o,d)= column $ render p o hsep render p d 593 | getForm prms (List x)= do 594 | Verb v <- digest prms 595 | case v 596 | 597 | se puede usar siempre modify? 598 | process permite que editElem retorne siempre un valor 599 | Digest de la cola entera retorna la cola entera 600 | 601 | Digest de un elemento retorna un elemento 602 | necestiamos Digest de la cola y que retorne un elemento editado 603 | 604 | 605 | como se hace un flujo si no hay process? 606 | procesando una propuesta 607 | propuestas, colas con Keys de propuestas 608 | 609 | editEleme= do 610 | guardar objeto 611 | meter key en cola 612 | forkIO $ ask queue 613 | wait timeout 614 | leer objeto 615 | 616 | instance (Digest x , ShowLine x, Render x) => Digest Queue x 617 | digest params= editElem 618 | 619 | composición (objeto, load) 620 | 621 | instance Editable 622 | 623 | 624 | generador de forms. no actualiza la pagina de form. 625 | 626 | ask:: (Digest model view) => Token -> IO model 627 | ask t = r where r=do 628 | page <- gerForm r 629 | send t page 630 | r' <- receiveReq t >>= digest . getParams 631 | 632 | case r' of 633 | MRight x -> return x 634 | MLeft msgs -> ask t $ mappend (column $ map fromString msgs) page 635 | 636 | 637 | instance Monad (MEither e) where 638 | return = MRight 639 | x >> f = case x of 640 | MLeft errs -> case f of 641 | MLeft errs1 -> MLeft $ errs1 ++ errs 642 | _ -> MLeft errs 643 | MRight r -> f r 644 | 645 | --- 646 | x >> f= 647 | 648 | data Options = Approbal | ChooseOptions String Int [Option] deriving (Read,Show,Eq) 649 | data Option= Option String Status deriving (Read,Show,Eq) 650 | 651 | newtype Priority= Priority Int deriving (Eq, Ord) 652 | type PriorIVote = (Priority, IndexVote) 653 | 654 | type Percent= Float 655 | data Status = Draft | Processing | Approbed Percent | 656 | Rejected Why |Closed Status | Voted Status deriving (Read,Show,Eq) 657 | 658 | 659 | 660 | 661 | options :: Options -- options to vote 662 | votes :: DiffArray Int PriorIVote-- (representant priority, option voted) array 663 | sumVotes :: DiffUArray Int Int -- total votes per option 664 | 665 | 666 | 667 | 668 | create >>= sendGroup >>= vote_edit >>= applylaw >>= 669 | 670 | vote_edit que incluye? 671 | autenticacion= convert $ texto HTML 672 | userPasswordRequest :: req 673 | 674 | autenthicate :: Digest User req -> User 675 | autenthicate = ask userPasswordRequest 676 | 677 | grabar objeto 678 | manejo de Key 679 | manejo de listas 680 | lista usuario, grupos 681 | opciones por objeto , no por usuario 682 | lista de cosas a votar a editar 683 | manejo de opciones de acciones 684 | responder en cola de respuesta 685 | modificar en cola de recepcion 686 | modificar el objeto original 687 | 688 | editar objeto 689 | editar los votos 690 | 691 | pasar todo a Users.hs? 692 | class lookup String para obtener parametros 693 | class Digest 694 | 695 | instance convertTo String a 696 | 697 | Proposal Type object votes 698 | 699 | type es el tipo de propuesta para que aplique las representaciones y los 700 | criterios de evaluación de votos. 701 | 702 | 703 | type tiene que ser uno de los tipos editados en la propuesta de constitución 704 | 705 | grupo: nombre, constitución 706 | 707 | 708 | 709 | 710 | writeResource Key _ obj= writeResource obj?? 711 | 712 | 713 | data Key a= Key String a 714 | 715 | instance (Show a, Read a) => IResource (Key a) where 716 | keyResource (Key k _)= k 717 | serialize (Key _ x)= show x 718 | deserialize str= Key undefined . read 719 | readResource (Key k _) = readResource >>= return . Key k 720 | writeResource (Key _ x)= writeResource x 721 | 722 | instance IResource a => IResource Key a) 723 | keyResource (Key k _)= k 724 | serialize (Key _ x)= serilize x 725 | deserialize str= Key undefined . deserialize 726 | readResource str = readResource str >>= \x -> return $ Key (keyResource x) x 727 | writeResource (Key _ x)= writeResource x 728 | 729 | newType Hash= Hash Integer 730 | data Proto a= Proto (IORef Hash) a 731 | proto a = Proto (writeIORef..) 732 | 733 | hashString (Data hash _)= unsafeCoerce hash 734 | 735 | ..... 736 | mantener colas por usuario e ind, no por workflow 737 | meterlas en una estructura temporal. un tchan en runnongworkflows? 738 | ----- 739 | como usar tipos para evitar errores 740 | 741 | 742 | newType WFName= WFName String 743 | newType ObjKey= ObjKey String 744 | 745 | Token= Token{wfname,user, ind ::String, q, qr :: Queue} 746 | 747 | 748 | 749 | ------------------ 750 | que hacer con las colas en webScheduler? 751 | - crear un Map tokenName (TChan,TChan) 752 | -- meterlas en el Stat , convertir Token en Stat 753 | pasar ese stat en los transient workflows 754 | lo natural seria tener un send 755 | --- 756 | que pasa cuando un send envia a otro workflow y el receive se queda bloqueado en 757 | espera? 758 | 759 | getState no matar el thread cuando cambia de primitiva 760 | un token puede ejecutar mas de un workflow. eso para permitir workflows 761 | de larga vida, como cestas de la compra. 762 | inconvenientes: detectar 763 | Es un Map token workflow. hay que convertirlo en una map tokenworkflow thread 764 | 765 | 766 | admintir TCache para que permita indeººxar por mas de un campo 767 | usar otherKeysResource 768 | readresource que retorne el primero 769 | crear un elemento nuevo sin TVar que sirva solo para consulta y tenga una 770 | lista de claves principales de elementos que tienen la misma clave secundaria 771 | o bien utilizar el mismo TVar, y definiendo un objeto lista que agrupe los que tienen la misma 772 | clave secundaria. 773 | 774 | evitar usar registerType usando types en lugar de hexadecimal 775 | definir una tabla de equivalencias hexa-> string en la parte where de 776 | refSerialize: 777 | where Vab4567= "Control.Workflow.Queue" 778 | 779 | 780 | programar TPVars sobre TCache 781 | 782 | usuarios roles 783 | 784 | el usuario puede ver una lista o puede procesar elementos como en un workflow 785 | en el segundo caso, los elementos deben ser eliminados 786 | en el primero no. 787 | como se procesan enmiendas? 788 | parece mas logico presentarlo como ediciones de elementos comunes 789 | mas que procesos de colas. 790 | 791 | 792 | 793 | 794 | data User= User{name, password , role:: String, in, out :: Queue} | Workflow String 795 | 796 | como indexar un field con operaciones: 797 | 798 | 799 | 800 | --como indexar un field con operaciones: 801 | 802 | {------------------- 803 | class (IResource a) => ToIndex a where 804 | toIndex :: Ord b => a -> [(String, b)] 805 | 806 | 807 | 808 | data Index b = Index{nameIndex :: String, index ::M.Map b [String]} 809 | 810 | 811 | addtoIndex x= do 812 | let indexes= toIndex x 813 | map add indexes 814 | where 815 | add (index,v)= 816 | withResources [Index index undefined] $ 817 | \[midx] -> case midx of 818 | Just(Index index map) -> Index index $ M.insert v (keyResource x) map 819 | Nothing -> Index index M.singleton v (keyResource x) 820 | -} 821 | 822 | 823 | 824 | 825 | ------------------- 826 | class (IResource a) => toIndex a where 827 | toIndex :: Ord b => [ (a -> b)] 828 | 829 | 830 | 831 | data Index b = Index String [(Mapb [Key])] 832 | toIndex :: a -> (a-> b) -> String 833 | addtoIndex user role nameindex 834 | 835 | getElems nameIndex roleValue=...lookup 836 | getAllElems nameIndex = .... concat $ elems map 837 | 838 | and index value 839 | 840 | --------------------- 841 | 842 | autenticacion 843 | 844 | atenticate añadir a messageFlow 845 | 846 | register user password role 847 | 848 | autenticate user password 849 | ---------------- 850 | manipulaciones Objetos 851 | 852 | data Object a= Object a 853 | 854 | 855 | messageflow para aprobación 856 | 857 | el workflow utiliza varios usuarios que entran, no un solo usuario como en un workflow. 858 | cada usuario necesita un dialogo de una o varias pantallas, por tanto no se puede conectar a un messageflow tal como 859 | esta ahora. 860 | verbos: 861 | 862 | asociar a cada usuario autenticado dos colas in out 863 | 864 | waitFor user msg 865 | waitFor workflow msg 866 | user puede tener asociado siempre un workflow y en ese caso se puede obviar la primera forma? 867 | en teoria si 868 | puede ser un workflow parametrizado por un nombre de usuario o rol? por ejemplo 869 | 870 | waitFor aprobación boss documento= add this document to the workflow queue. 871 | luego el workflow no puede usar el documento como parametro porque en su cola puede haber mas de un documento 872 | no sirve startWF wf ... doc . hay que usar colas. 873 | 874 | ese workflow en el que entran documentos y entran usuarios puede conectar directamente con web? 875 | como abstraerlo del interface? 876 | 877 | el proceso tiene que tener dos colas, una para documentos (para hacer cosas con ellos, como aprobarlos etc) y otra para usuarios. como se modela? 878 | se trata de un proceso que presente la lista de objetos al usuario y el conjunto de verbos que puede ejecutar con cada uno 879 | para ello cada documento tiene que tener una lista de acciones asociado 880 | tiene que modelizarse como un mail. la presentacion depende del Interfaz, no de messageFlow. 881 | cada item tiene que tener una o varias actions. 882 | data Item a= Item a [Action] 883 | 884 | data Action= forall a.IAction a => Action Name a 885 | 886 | conjunto de acciones fijado (editar, aprobar..) o libre ambos dependen del interfaz. 887 | el usuario escoje una accion 888 | class IAction a b where 889 | exec :: a -> IO b 890 | 891 | pero edit no se puede codificar abstrayendose del interface 892 | 893 | data Approbal = Approbal 894 | 895 | iTask: editTask obj pide entrada de datos al usuario. 896 | 897 | patterns: sequence, recursion, exclusive choice, multiple choice, split/merge (parallel or, 898 | parallel and, discriminator), ... 899 | 900 | interfaces para web services 901 | 902 | 903 | --------------------------------------------------------------------------------