DoublingServer5.hs

-- Based on the TrivialServer-example from Marlow, Parallel and Concurrent
-- Programming in Haskell

{-# LANGUAGE StandaloneDeriving #-}

import System.IO
import Network
import Text.Printf
import Control.Monad
import Control.Concurrent
import Debug.Hoed(observe,Observable(..),runO,send,observe',Identifier(..))
import System.IO.Unsafe
import Data.List

twotimes :: Int -> Integer -> Integer
twotimes d j = (fst $ observe' "twotimes" (DependsJustOn d)
               ( \i -> {-# SCC "twotimes" #-} 
                  2 + i -- bug: should be 2 * i
               )) j

double :: String -> String
double s' = let (res,d) = observe' "double" UnknownId
                          (\s -> {-# SCC "double" #-} show (twotimes d (read s :: Integer)))
            in res s'

loop h = do
  line <- hGetLine h
  if line == "end"
     then do hPutStrLn h ("Thank you for using the Haskell doubling service.")
             putStrLn $ "server: Terminated client " ++ show h
     else do hPutStrLn h (double line)
             loop h

talk :: Handle -> IO ()
talk h = do 
  hSetBuffering h LineBuffering
  i <- myThreadId
  hPutStrLn h $ "Welcome on thread " ++ show i
  loop h

port :: Int
port = 44444

server :: Int -> Socket -> IO ()
server = observe "server" (\x sock -> {-# SCC "server" #-} server' x sock)
  where server' 0 _ = putStrLn "server: Shutting down."
        server' x sock = do
          (handle, host, port) <- accept sock
          printf "server: Accepted connection from %s: %s\n" host (show port)
          forkFinally (talk handle) (\_ -> hClose handle)
          server (x-1) sock

client :: Int -> IO ()
client x = do
  h <- connectTo "localhost" (PortNumber (fromIntegral port))
  hSetBuffering h LineBuffering
  let pr s = putStrLn $ "client-" ++ show x ++ ": " ++ s
  
  s <- hGetLine h; pr s -- Get and print the welcome message
  hPutStrLn h (show x)  -- Send x for doubling to the server
  s <- hGetLine h; pr s -- Get and print response from server
  hPutStrLn h "end"     -- Send goodbye message
  s <- hGetLine h; pr s -- Get and print response from server

main :: IO ()
main = runO $ withSocketsDo $ do
  sock <- listenOn (PortNumber (fromIntegral port))
  printf "server: Listening on port %d.\n" port
  forkIO (server 2 sock) -- Start server in own thread.
  client 2               -- Connect with two clients from this thread to the server.
  client 3
  threadDelay 1000       -- Give server-thread some time to terminate.

instance Observable Handle where observer h = send (show h) (return h)
instance Observable Socket where observer s = send "socket" (return s)