{-# OPTIONS -XDeriveDataTypeable #-} {- This program is an example of simple workflow management. Once a document is created by the user, a workflow controls two levels of approbal (boss and superboss) trough messages to the presentation layer of the three different users. 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. This program can handle as many document workflows as you like simultaneously. this is a version with more transaction-aware communications between the workflow and the user interfaces. Most of te Workflow and communication primitives are used. The second level of approbal now has a timeout . The seralization of the document is trough the Serialize class of the RefSerialize package. There is also a rudimentary account of document modifications When te document title is modified, the workflow launches a new workflow with the new document and stops. -} import Control.Workflow import Data.TCache.IDynamic import Data.Typeable import System.Exit import Data.List (find,(\\)) import Data.Maybe(fromJust) import Control.Monad (when) import Control.Concurrent ( forkIO,threadDelay) import GHC.Conc( atomically, unsafeIOToSTM, STM, orElse) import Data.RefSerialize import Data.TCache.Dynamic import Debug.Trace debug a b= trace b a data Document=Document{title :: String , text :: [String]} deriving (Read, Show,Eq,Typeable) instance IResource Document where keyResource (Document t _)= t tshowp (Document title text)= do title1 <- showp title stext <- rshowp text return $ "Document " ++ title1 ++ stext treadp= do symbol "Document" title <- readp text <- rreadp return $ Document title text docWorkflows=[("docApprobal",docApprobal)] main= do -- register all the data types to be returned in the workflow steps registerType :: IO Document registerType :: IO () registerType :: IO Bool {- let x= toIDyn $ Document "title" ["sdfsdf", "sdfsdf"] let str= runW $ showp [x,x] let y = runR readp str :: [IDynamic] putStrLn str putStrLn "" putStrLn "" putStrLn "" print y -} -- restart the interrupted workflows restartWorkflows docWorkflows 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" 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." putStrLn "\n please login as:\n 1- user\n 2- boss\n 3- super boss\n\n Enter the number" n <- getLine case n of "1" -> userMenu "2" -> aprobal boss "3" -> aprobal superboss -- The workflow. -- Think on it as a persistent thread docApprobal :: Document -> Workflow IO () docApprobal doc= do logWF "send a message to the boss requesting approbal" step $ writeQueue boss doc -- wait for any respoinse from the boss let docQueue= receiver approbal doc ap <- step $ readQueue docQueue case ap of False -> logWF "not approbed, sent to the user for correction" >> correctWF doc True -> do logWF " approbed, send a message to the superboss requesting approbal" step $ writeQueue superboss doc -- wait for any respoinse from the superboss -- if no response from the superboss in 5 minutes, it is validated flag <- getTimeoutFlag $ 5 * 60 ap <- step . atomically $ readQueueSTM docQueue `orElse` waitUntilSTM flag >> return True case ap of False -> logWF "not approbed, sent to the user for correction" >> correctWF doc True -> do logWF " approbed, sent to the list of approbed documents" step $ writeQueue approbed doc correctWF :: Document -> Workflow IO () correctWF doc= do step $ writeQueue user doc -- send a message to the user to correct the document -- wait for the document approbal doc' <- step $ readQueue (title doc) if title doc /= title doc' -- if doc and new doc hace different document title, then start a new workflow for this new document -- since a workflow is identified by the workflow name and the key of the starting data, this is a convenient thing. then step $ startWF "docApprobal" doc' docWorkflows -- else continue the current workflow else docApprobal doc' create = do separator doc <- readDoc putStrLn "The document has been sent to the boss.\nPlease wait for the approbal" forkIO $ startWF "docApprobal" doc docWorkflows userMenu {- finaldoc <- startWF "docApprobal" doc docWorkflows Just sequenceAprobal <- getWFHistory "docApprobal" doc printHistory sequenceAprobal -} user= "user" boss = "boss" superboss= "superboss" approbed = "approbed" approbal= "approbal" userMenu= do separator putStrLn"\n\n1- Create document\n2- Documents to modify\n3- Approbed documents\n4- manage workflows\n5- exit" n <- getLine case n of "1" -> create "2" -> modify "3" -> view "4" -> history "5" -> exitSuccess userMenu handle = flip catch history= do separator putStr "MANAGE WORKFLOWS\n" ks <- getWFKeys "docApprobal" mapM (\(n,d) -> putStr (show n) >> putStr "- " >> putStrLn d) $ zip [1..] ks putStr $ show $ length ks + 1 putStrLn "- back" putStrLn "" putStrLn " select v to view the history or d to delete it" l <- getLine let n= read $ drop 2 l let docproto= Document{title= ks !! (n-1), text=undefined} case head l of 'v' -> do getWFHistory "docApprobal" docproto >>= printHistory . fromJust history 'd' -> do delWFHistory "docApprobal" docproto history separator= putStrLn "------------------------------------------------" modify :: IO () modify= do separator empty <- isEmptyQueue user :: IO Bool if empty then putStrLn "thanks, enter as Boss for the approbal"else do doc <- atomically $ do doc <- readQueueSTM user unreadQueueSTM user doc return doc putStrLn "Please correct this doc" print doc doc1 <- readDoc return $ diff doc1 doc atomically $ do readQueueSTM user :: STM Document writeQueueSTM (title doc) doc1 modify diff (Document t xs) (Document _ ys)= Document t $ map (search ys) xs where search xs x= case find (==x) xs of Just x' -> x' Nothing -> x readDoc :: IO Document readDoc = do putStrLn "please enter the title of the document" title1 <- getLine h <- getWFHistory "docApprobal" $ Document title1 undefined case h of Just _ -> putStrLn "sorry document title already existent, try other" >> readDoc Nothing -> do putStrLn "please enter the text. " putStrLn "the edition will end wth a empty line " text <- readDoc1 [title1] return $ Document title1 text where readDoc1 text= do line <- getLine if line == "" then return text else readDoc1 $ text ++ [line] receiver name doc= name++keyResource doc view= do separator putStrLn "LIST OF APPROBED DOCUMENTS:" view1 where view1= do empty <- isEmptyQueue approbed if empty then return () else do doc <- readQueue approbed :: IO [Document] print doc view1 aprobal who= do separator aprobalList putStrLn $ "thanks , press any key to exit, "++ who getLine return () where aprobalList= do empty <- isEmptyQueue who if empty then do putStrLn "No more document to validate. Bye" return () else do doc <- atomically $do doc <- readQueueSTM who unreadQueueSTM who doc return doc syncCache approbal1 doc aprobalList approbal1 :: Document -> IO () approbal1 doc= do putStrLn $ "hi " ++ who ++", a new request for aprobal has arrived:" print doc putStrLn $ "Would you approbe this document? s/n" l <- getLine let b= head l let res= if b == 's' then True else False -- send the message to the workflow atomically $ do empty <- isEmptyQueueSTM who readQueueSTM who :: STM Document writeQueueSTM (receiver approbal doc) res syncCache