{-# 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
                   syncCache