> module NetTCP (startup, getHostName, Socket, Handle, Hostname, Listen, Accept, Connect, Close, Put, Get, Net) where

A FIFO networking module which needs a "mux-server". Only supports hGetLine/hPutStrLn.

> import MuxCore
> import Concurrent
> import Random
> import System

> import IO hiding (Handle,hPutStrLn)
> import qualified IO

> type Socket = Int -- MVar
> type Handle = (IO.Handle, IO.Handle)

> type Listen  = Maybe String -> Maybe Port -> IO (Port, Socket)
> type Accept  = Socket -> IO (Handle, Hostname, Port)
> type Connect = Hostname -> Port -> IO Handle
> type Close   = Handle -> IO ()
> type Put     = Handle -> String -> IO ()
> type Get     = Handle -> IO String

> type Net = (Listen, Accept, Connect, Close, Put, Get)

> type MV = MVar Int -- counting

#ifdef __HUGS__

> hPutStrLn h s = do
>   IO.hPutStrLn h s
>   IO.hFlush h

> startup :: String -> IO (Net)
> startup name = do

Create a new FIFO. MUX will know where to look for it so there´s no need to induce even more overhead by registering first.
We use /tmp/dhs/<port> & mux. We ignore PortNumbers, but connect to the mux so we can create unique Pid.

>   g <- newMVar 1
>   mux <- openFile "/tmp/dhs/mux" WriteMode
>   rnd <- ((getStdRandom (randomR (1,1000))) :: IO Int) -- for nodes w/o a name
>   let fifo= ("/tmp/dhs/" ++ name ++"." ++ (show rnd))
>   mkFifo fifo
>   dummy <- openFile fifo WriteMode
>   me <- openFile fifo ReadMode
>   return (listen fifo mux me g, accept name mux g, connect name mux me g, fclose g, fwrite g, fread g)

> getHostName :: IO String
> getHostName = do
>   env <- myGetVar "HOSTNAME"
>   case env of
>     Just name -> return name
>     Nothing	-> ioError (userError "$HOSTNAME not set!")

> listen :: String -> IO.Handle -> IO.Handle -> MV -> Listen
> listen fifo mux me g iface port = do
>   v <- takeMVar g -- muxWrites are atomic
>   hPutStrLn mux (show (Listen fifo iface port))
>   ans <- hGetLine me
>   putMVar g v
>   let (Listening p sem) = read ans
>   return (p, sem)

> accept :: String -> IO.Handle -> MV -> Accept
> accept name mux g s = do
>   putStrLn "accept"
>   v <- takeMVar g
>   let fIn = "/tmp/dhs/" ++ name ++ "I" ++ (show s) ++ "." ++ (show v)
>   let fOut = "/tmp/dhs/" ++ name ++ "O" ++ (show s) ++ "." ++ (show v)
>   mkFifo fIn
>   mkFifo fOut
>   dummy <- openFile fIn WriteMode
>   hIn <- openFile fIn ReadMode
>   hOut <- openFile fOut WriteMode
>   let msg = show (Accept s fOut fIn)
>   l <- catch (do hPutStrLn mux $ msg
>		   -- yield -- enable for funny behaviour
>		   acc <- hIsReadable hIn
>		   putStrLn $ "readable: " ++ (show acc)
>	           c <- hGetLine hIn
>		   return (Just c))
>	          (\e -> do putStrLn $ (ioeGetErrorString e)
>		            putStrLn $ (show (ioeGetFileName e))
>		            return Nothing)
>   putMVar g (v+1)
>   putStrLn "accepted"
>   case l of
>     Just msg -> do
>       putStrLn msg
>       let (Accepted host port) = read msg
>       return ((hIn,hOut),host, port)
>     Nothing -> do
>       putStrLn "arg"
>       ioError(userError "arg")

> connect :: String -> IO.Handle -> IO.Handle -> MV -> Connect
> connect name mux me g host port = do
>   v <- takeMVar g
>   putStrLn "#connect"

Hugs can open files containing "<" & ">"?!

>   let fIn = "/tmp/dhs/" ++ name ++ "I" ++ host ++ ":" ++ (show port) ++ "." ++ (show v)
>   let fOut = "/tmp/dhs/" ++ name ++ "O" ++ host ++ ":" ++ (show port) ++ "." ++ (show v)
>   mkFifo fIn
>   mkFifo fOut
>   dummy <- openFile fIn WriteMode
>   hOut <- openFile fOut WriteMode
>   hIn <- openFile fIn ReadMode
>   hPutStrLn mux (show (Connect host port  fOut fIn))
>   putMVar g (v+1)
>   -- hClose dummy -- This will crash the next getLine!
>   f <- catch (do c <- hGetLine hIn
>		   return (Just c))
>	       (\e -> return Nothing)
>   case f of
>     Nothing -> do
>       putStrLn "x"
>     Just l -> do
>       putStrLn ("#"++l++"#")
>	case l of
>         "Nothing" -> do ioError (userError "no connection")
>         "ok"	-> do return ()
>   return (hIn,hOut)

> fclose :: MV -> Close
> fclose g (hIn,hOut) = do
>   putStrLn "#close"
>   hClose hIn
>   hClose hOut

> fread :: MV -> Get
> fread g (hIn,_) = do
>   putStrLn "#read"
>   hGetLine hIn

> fwrite :: MV -> Put
> fwrite g (_,hOut) str = do
>   putStrLn "#write"
>   hPutStrLn hOut str

> myGetVar :: String -> IO (Maybe String)
> myGetVar var = do
>   catch (getEnv var >>= (\x -> return (Just x))) -- can only be NoSuchThing
>	       (\_ -> return Nothing)

#endif