{-# 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
-- 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 "¬ 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 "¬ 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 <number> to view the history or d <number> 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
_ → 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
syncCacheAdd a code snippet to your website: www.paste.org