> module Main (main) where

WARNING! You will run into system limits on filehandles etc.!

> import MuxCore
> import TCP (myAccept)

> import IO
> import Socket
> import Posix (handleToFd)
> import PosixUtil (fdToInt)
> import System
> import Concurrent
> import qualified SocketPrim

> data SMsg = New Int SChan | Start (Int,String,String) 
> type SChan = Chan SMsg

> main :: IO ()
> main = do
>   let nameIn = "/tmp/dhs/mux"
>   try (mkFifo nameIn)
>   hIn <- openFile nameIn ReadMode
>   hSetBuffering hIn LineBuffering
>   hDummy <- openFile nameIn WriteMode -- We need this for FIFOs, check your local copy of Stevens "Unix Network Programming"
>   sem <- newChan
>   forkIO (dict sem [])
>   loop sem 0 hIn
>  where
>    dict sem d = do
>      m <- readChan sem
>      case m of
>        New i ch -> do
>	   dict sem ((i,ch):d)
>	 v@(Start (i,_,_)) -> do
>          let x = lookup i d
>          case x of
>            Nothing -> return ()
>	     Just ch -> do
>	       writeChan ch v
>	   dict sem d
>    loop :: SChan -> Int -> Handle -> IO ()
>    loop sem c h = do
>      -- putStr "looping..."
>      msg <- hGetLine h
>      putStrLn $ "read " ++ msg
>      let msg' = ((read msg) :: MuxMsg)
>      res <- evalMsg c msg'
>      loop sem res h
>     where
>       evalMsg :: Int -> MuxMsg -> IO (Int)
>	evalMsg m (Connect host port r w) = do
>	  -- connect to remote host
>	  res <- catch (do h <- connectTo host (PortNumber (mkPortNumber port))
>		           return (Just h))
>		        (\e -> return Nothing)
>	  wh <- openFile w WriteMode
>	  hSetBuffering wh LineBuffering
>	  rh <- openFile r ReadMode
>         case res of
>	    Nothing -> do
>	      putStrLn "1"
>	      hPutStrLn wh "Nothing"
>	      hClose wh
>	      hClose rh
>	    Just h -> do
>	      hPutStrLn wh "ok"
>	      putStrLn "hier"
>	      -- spawn a reader which reads from r and writes to remote
>	      _ <- forkIO (reader rh h)
>	      -- spawn a reader which reads from remote and writes to w
>	      _ <- forkIO (reader h wh)
>	      return ()
>	      -- yes, you´re right, currently they´re never removed.
>	  return m
>	  where
>	    reader i o = do
>	      m <- hGetLine i -- XXX catch
>	      --fd <- handleToFd i
>	      --putStrLn $ "data on " ++ (show (fdToInt fd))
>	      hPutStrLn o m
>	      reader i o
>	evalMsg m (Accept i r w) = do
>	  writeChan sem (Start (i,r,w))
>	  return m
>	evalMsg m (Listen fifo port) = do

A local node wishes to listen. Allocate a new port & fork.

>         sin <- listenOn (PortNumber (case port of
>				  Nothing -> SocketPrim.aNY_PORT
>				  Just p  -> mkPortNumber p))
>         (PortNumber myPort) <- socketPort sin
>	  let portInt = (read (show myPort)) :: Port -- sigh
>	  h <- openFile fifo WriteMode
>	  hSetBuffering h LineBuffering
>	  forkIO (acceptor sem c sin)
>	  hPutStrLn h (show (Listening portInt m))
>	  return (m+1)
>	 where
>	   acceptor :: SChan -> Int -> Socket -> IO ()
>	   acceptor sem c s = do
>	     new <- newChan
>	     writeChan sem (New c new)
>	     v <- readChan new
>	     case v of
>	       Start (current,fRead,fWrite) | current == c -> do
>	         -- dummy <- openFile fRead WriteMode -- Client already has a write lock!
>	         fIn <- openFile fRead ReadMode
>		 hSetBuffering fIn LineBuffering
>	         fOut<- openFile fWrite WriteMode
>		 hSetBuffering fOut LineBuffering
>	         putStrLn $ "accepting@" ++ (show c)
>	         (h,host,port) <- myAccept s
>	         putStrLn $ "accepted@" ++ (show c)
>		 hPutStrLn fOut (show (Accepted host port))
>	         forkIO (recv h fIn fOut)
>		 return ()
>	       _ -> do
>	         putStrLn "Was soll das?!"
>	    where
>	     recv :: IO.Handle -> IO.Handle -> IO.Handle -> IO ()
>	     recv h fIn fOut = do
>	       ch <- newChan
>	       hPid <- forkIO(do
>	         fd <- handleToFd h
>	         threadWaitRead (fdToInt fd)
>	         putStrLn "hier1"
>		 writeChan ch h)
>	       fInPid <- forkIO(do
>	         fd <- handleToFd fIn
>	         threadWaitRead (fdToInt fd)
>	         putStrLn "hier2"
>		 writeChan ch fIn)
>	       inH <- readChan ch
>	       putStrLn "hier"
>	       outH <- if (inH == h) then do
>			     killThread fInPid
>			     return fOut
>			    else do
>				 killThread hPid
>				 return h
>	       msg <- catch (do line <- hGetLine inH
>				return (Just line))
>			    (\e -> return Nothing)
>	       case msg of
>	         Nothing -> do -- disconnect
>		   hClose inH
>		   hClose fIn
>		   hClose fOut
>		 Just str -> do
>		   hPutStrLn outH str
>		   recv h fIn fOut