> module Main (main) where

WARNING! Although this is the long-waited for, hyper-interactive, show-off demo
for Distributed Haskell we were all waiting for, this module turned out rather ugly
because of worldly issues like Gtk, concurrency & Distributed.proc.

However, this is an example of Distributed.runDist interacting with IO when needed.
We clone a new process from the immutable parts of the environment and get something
like 'spawn :: ... -> DIO a b -> IO ()'.
The bad news is the the Accept-constructor gets spilled into the datatype we use for
external communication, too.

Linking does not work properly due to GTK!

> import Distributed
> import BSD
> import IO
> import Gtk hiding (main)
> import qualified Gtk
> import Monad
> import Maybe
> import Concurrent

> data Msgs = RTo String Pid String | Accept |
>	         Connect Pid | Deny | Line String | Close |
>		 Down Pid
>                deriving (Show,Read)
> instance Serialize Msgs

> main :: IO ()
> main = do
>  hSetBuffering stdout NoBuffering -- Otherwise we'd never see the prompt
>  _ <- Gtk.init Nothing
>  timeoutAdd 10 (TimeoutHandler $ yield >> return True) -- reschedule every 10ms

Require $USER for unique node name:

>  nodeName <- myGetVar "USER"
>  case nodeName of
>    Nothing -> putStrLn "No user-name!? Please set $USER!"
>    Just n  -> Distributed.start (talk ("Talk_" ++ n)) ("Talk_" ++ n)

> talk :: String -> DIO Msgs ()
> talk myNodeName = do

First set up main window and spawn the notifier who will keep us informed about
incoming requests.

>   me <- self 
>   (window,box) <- proc (createRootWindow myNodeName)
>   spawn (notify (window,box) me)
>   proc $ forkIO Gtk.main
>   loop

The loop handles user-input. The result of actOn is True when the user decides to quit.

>  where
>   loop :: DIO Msgs ()
>   loop = do  
>     proc $ putStrLn "Press 't' to talk or 'q' to quit."
>     line <- proc $ getLine
>     quit <- actOn line
>     if quit then do proc $ mainQuit
>		      halt
>             else loop
>     where
>      actOn :: String -> DIO Msgs Bool
>      actOn ('q':_) = return True

Initiate a talk-request:
Get all necessary data and send RTo message to remote node. The remote end
should reply with Connect or Deny.

XXX Should be Gtkified.

>      actOn ('t':_) = do
>       proc $ putStr "Please type the hostname of the remote host: "
>       rhost <- proc $ getLine
>       proc $ putStr "Please type the user's name: "
>       rname <- proc $ getLine
>       let rnode = "Talk_" ++ rname
>       proc $ putStrLn "# Sending invitation..."

Free tty by spawning new thread

>       spawn (do

Get local userīs name

>        uName <- proc $ myGetVar "USER"
>        let myUserName = case uName of
>                           Nothing -> "??" 
>	                    Just n  -> n
>        me <- self
>        remoteSend (Hostname rhost) (Nodename rnode) "Talkserver"
>	            (RTo rname me myUserName)-- XXX
>        proc $ putStrLn "# Waiting for reply..."
>        receive (\v -> case v of
>          Connect rPid -> 
>	     acceptTalk rPid rname
>	   Deny ->
>	     proc $ putStrLn "Denied."
>         ))
>       return False
>      actOn _ = return False -- Swallow illegible input 

> acceptTalk p@(Pid (host,_) _) user = do
>    me <- self

"raceMVar" is used to solve the race between the local user closing the
window and a remote message arriving.

"closeAcct" & "senderAcct" are the DHS-actions to be executed on the GUI-events.
Although this is clearly much more legible than the previous version using dhsReceptor,
it is much more heavy-weight because of the repeated calls to runDist.

>    raceMVar  <- proc $ newEmptyMVar
>    st <- get
>    let closeAcct  = runDist st (do p <!> Close >> return ())
>    let senderAcct = \msg -> runDist st (do p <!> Line msg >> return ())
>    (win,hisLabel,entry,ch) <- proc ( setupWindows user host (senderAcct, closeAcct, raceMVar))
>    proc $ putMVar raceMVar (Just win)
>    -- spawn (dhsReceptor ch p)
>    linkMeWith p
>    receiveRemoteData win hisLabel entry raceMVar
>  where
>    receiveRemoteData :: Gtk.Window -> Label -> Entry -> MVar (Maybe Gtk.Window) -> DIO Msgs ()
>    receiveRemoteData win label entry race = do
>      receive (\v -> case v of
>        Line str -> do
>	   proc (gtkRace race (do
>	     text <- labelGet label
>	     labelSetText label (text ++ str++"\n")))
>	   receiveRemoteData win label entry race -- ch
>        Close -> proc (do
>	   gtkRace race (entrySetEditable entry False)
>	   -- writeChan ch Nothing -- Tell spawned dhsReceptor to quit
>         )
>	 Down _ -> proc (do
>	   gtkRace race (entrySetEditable entry False)
>	   -- writeChan ch Nothing -- Tell spawned dhsReceptor to quit
>	  )
>       )
>     where
>	gtkRace :: MVar (Maybe Gtk.Window) -> IO () -> IO ()
>	gtkRace race f = do
>	  raceCheck <- takeMVar race
>	  when (isJust raceCheck) f
>	  putMVar race raceCheck
    
submitHandler & DHS-counterpart. The submitHandler adds the line to *both* labels.

>    submitHandler ch lbl e = do
>      text <- entryGetText e
>      ch text
>      -- writeChan ch (Just text) -- Could be replaced by a low-level send like Distributed.sendToLocal
>      entrySetText e "" -- Erase input
>      text2 <- labelGet lbl
>      labelSetText lbl (text2 ++ text ++"\n")

The dhsReceptor which forwards messages entered into the GUI to the remote host could be
improved to a DHS-only version:

>    dhsReceptor ch p = do
>      msg <- proc $ readChan ch
>      case msg of
>        Nothing  -> return ()
>	 Just str -> do
>	   p <!> Line str
>	   dhsReceptor ch p

>    setupWindows user host (ch, closeAcct, raceMVar) = do
>      window <- windowNew WindowToplevel
>      windowSetTitle window $ "DHS-Talk to " ++ user ++ "@" ++ host 
>      signalConnect window (WidgetDeleteEventHandler
>        (\_ _ -> do
>	   closeAcct     -- tell remote we quit
>	   takeMVar raceMVar   -- lock Gtk
>	   putMVar raceMVar Nothing -- ignore remaining messages
>	   return False))	       -- close window
>      box <- vBoxNew True 0

Frame for your text on top:

>      (myFrame,myLabel) <- createFrame "you:"
>      containerAdd box myFrame

Remote text below:

>      (hisFrame,hisLabel) <- createFrame (user++":")
>      containerAdd box hisFrame

The entryfield for the text you want to send

>      entry <- entryNew
>      -- ch <- newChan
>      signalConnect entry (EditableActivateHandler (submitHandler ch myLabel))
>      containerAdd box entry
>      containerAdd window box
>      widgetShow entry

>      widgetShow box
>      widgetShow window
>      return (window, hisLabel, entry, ch)
>     where
>       createFrame :: String -> IO ((Frame,Label))
>       createFrame text = do
>         frame <- frameNew $ text
>         widgetShow frame
>         lbl <- labelNew ""
>         labelSetJustify lbl JustifyLeft
>         widgetShow lbl
>         containerAdd frame lbl
>         return (frame,lbl)

The Notifiction-thread.

> notify (window,box) parent = do
>   register "Talkserver"
>   loop 0
>  where
>   loop c = do
>     receive (\v -> case v of
>       RTo name pid@(Pid (no,de) _) rUserName -> do

Spawn a process. Ugly.

>	  accept <- spawn ( do
>	    receive ( \v -> case v of
>	      Accept -> do
>	        me <- self
>               pid <!> Connect me
>	        acceptTalk pid rUserName
>	        return ()
>	     )
>          )
>	  st <- get
>         proc (do
>	    putStrLn ("["++(show c)++"] Invitation for " ++ name)
>	    button <- buttonNewWithLabel $ "[" ++ (show c) ++ "] " ++ rUserName ++ "@" ++ no
>	    containerAdd window button
>	    signalConnect button (ButtonClickedHandler (\_ -> do containerRemove box button >> Distributed.runDist st (do accept <!> Accept >> return ()) >> return ()))
>	    boxPackStart box button True True 0
>	    widgetShow button
>	   )

>         loop (c+1)
>      ) -- receive

> createRootWindow myNodeName = do
>   window <- windowNew WindowToplevel
>   windowSetTitle window $ "DHS Talk@" ++ myNodeName
>   signalConnect window (WidgetDeleteEventHandler (\_ _ -> do mainQuit; return False))
>   box <- vBoxNew True 0
>   containerAdd window box
>   widgetShow box
>   widgetShow window
>   return (window,box)