> module Main (main) where

Important: If we really start using tunnels between a dhd and its local clients, it should probably be much more efficient using Unix-domain sockets instead of TCP/IP. As they create 'Handle's,too, this shouldn´t add too much overhead. Alas, there´s this idea about implementation-independant communication-modules (UDP/TCP/UNIX-Domain)

XXX Most output should probably go to stderr instead of stdout

> import DHSCore
> import ObjIO

#ifdef __HUGS__

> import NetFIFO as Network hiding (startup, myGetVar, Hostname)
> import qualified NetFIFO as Network

#else

> import NetTCP as Network hiding (startup,Hostname)
> import qualified NetTCP as Network
> import System.Posix

#endif

> import Tunnel hiding (startup)
> import qualified Tunnel

#ifdef CONCDEBUG

> import ConcurrentDebug as Concurrent

#else

> import ConcurrentDebugLess as Concurrent

#endif

> import System.Console.GetOpt
> import System
> import IO
> -- import Network.BSD
> import Network.BSD as BSD
> import Monad
> import Maybe

> type DicChan = Chan DictMsgs
> type Dict = [(Nodename,PNode)]
> type DictPtr = (DicChan,Chan DictAnsMsgs)

> data DictMsgs = Lookup Nodename (MVar DictAnsMsgs) | Delete Nodename | Add (Nodename,PNode) | Flush | Dump
> data DictAnsMsgs = DictReply (Maybe PNode)

GetOpts-stuff:

> data Opts = Interface String | Port String | Daemon deriving (Eq)

> options :: [OptDescr Opts]
> options =
>   [Option ['i']	["interface"]	(ReqArg Interface "")	"interface to listen on",
>    Option ['p']	["port"]	(ReqArg Port "PORT")	("port to listen on (default: " ++ (show distHaskellPortNr)),
>    Option ['d']	["detach"]	(NoArg Daemon)		"detach"]

The dhd loops and accepts connections on the less-known distHaskellPort
(see Distributed.lhs). Incoming requests are remoteSends, lookUps and
registration-requests.

> main = do

Read options:

>   args <- catch (do System.getArgs)
>		  (\_ -> return [])
>   let opts = case getOpt Permute options args of
>                (o,n,[]  ) -> o
>                (_,_,errs) -> [] -- XXX
>   let iface = foldl (\n x -> case x of
>                                Interface i -> (Just i)
>				 _	     -> n) Nothing opts
>   when (Daemon `elem` opts) (do
>      -- close all open file descriptors
>      -- change cwd
>      -- umask

#ifndef __HUGS__

>      _ <- installHandler sigTTOU Ignore Nothing
>      -- sigTTIN, sigTSTP ?

>      self <- getProcessID
>      setProcessGroupID 0 self

#endif
      
>    )
>      
>   ci <- newChan -- to dict
>   labelChan ci "dhd.dictIn"
>   co <- newChan -- from dict
>   labelChan co "dhd.dictOut"
>   forkIOLabel "dhd.dict" (runDict ci [])
>   net <- Network.startup "dhd"
>   tun <- Tunnel.startup net distHaskellPortNr 30
>   socket <- (net#listen) iface (Just distHaskellPortNr)

#ifndef __HUGS__

>   _ <- installHandler sigHUP (Catch (do
>     putStrLn "dhd: Thinking of Maud you forget everything else."
>     writeChan ci Flush
>    )) Nothing

The following function *could* be implemented to be invoked via network, but you probably don´t want people prying around here.

>   _ <- installHandler sigUSR1 (Catch (do
>     putStrLn "dhd: Dumping all entries."
>     writeChan ci Dump
>    )) Nothing

#endif

>   putStrLn "dhd started."
>   outerloop net socket (ci,co) tun
>  where
>    outerloop :: Net -> Socket -> DictPtr -> Tunnel -> IO ()
>    outerloop net socket dict tun = do
>      c <- catch (do
>        h <- socket#accept
>	 return (Just h)
>	)
>	( \e -> do
>	  putStrLn ("dhd: accept failed, reason:\n"++(show e))
>	  return Nothing)
>      case c of
>        Nothing -> return ()
>        Just h@(handle,host,port) -> do
>	   --print $ "accept: " ++ (show host)
>	   forkIOLabel (show (host,port)) (loop dict (handle,Hostname host,port) >> handle#closeH)
>	   return ()
>      outerloop net socket dict tun
>     where

We need a loop reading from a file-handle for handling tunnels.

>     loop :: DictPtr -> (Handle,Hostname,Int) -> IO ()
>     loop dict@(ci,co) h@(handle,Hostname host,port) = do
>      m <- catch (do
>        line <- handle#readH
>	 return (Just line)
>	)
>	( \e -> do 
>	  unless (isEOFError e) 
>	    (putStrLn ("dhd: hGetLine failed, reason:\n"++(show e)))
>	  return Nothing
>	 )
>      case m of
>        Nothing -> return ()
>	 Just msg -> do
>         stop <- evaluateMsg handle msg host port
>	  unless stop (loop dict h)

Please take care not to accidentially close the handle.

>      where
>       baseEvalWrap h m ho p = do
>	  res <- baseEval h m ho p
>	  case res of
>	    Left bool -> return bool
>	    Right m -> return False

>	baseEval :: IOObj a => a -> String -> Network.Hostname -> Port -> IO (Either Bool String)
>       baseEval handle msg host port =
>        case msg of

'*': A remote host requests forwarding to a local node.

>	   '*':msg' -> do
>	     let (node,mesg) = (\(n,m) -> (Nodename n,m)) (span (/='#') msg')
>	     res <- lookup dict node
>	     case res of
>	       Nothing   -> do
>	         putStrLn ("*: Attempted forwarding to unregistered node " ++ ((\(Nodename x) -> x) node))
>	       Just (nhost,port) -> do
>		 -- print (nhost,port)
>		 --catch ((tun#bang) (Hostname nhost,port) ('#':mesg))
>		 catch ((tun#bang) (Hostname nhost,port) (mesg))
>		   (\ e -> print $ "forwarding failed: " ++ (show e))
>	     return (Left False)

'%': Register -- A new node is born.

>	   '%':msg' -> do
>	     let (ip,('%':msg'')) = span (/='%') msg'
>	     let (node,('%':portStr)) = (\(x,y) -> (Nodename x,y)) (span (/='%') msg'')
>	     res <- lookup dict node
>	     case res of
>	       Nothing -> do
>		 (handle#writeH) "ok" -- *requires* ACK
>		 -- putStrLn ("%: Registered " ++ node)
>		 -- he <- BSD.getHostByName host
>		 -- let hostip = addressToIP (BSD.hostAddress he)
>		 insert dict (node, (ip,(read portStr):: Int))
>	       Just _  -> do
>		 putStrLn ("%: " ++ ((\(Nodename x) -> x) node) ++ " already registered.")
>		 (handle#writeH) "die!"
>	     return (Left False)

'$': Lookup

>	   '$':msg' -> do
>	     let (node,_) = (\(x,y) -> (Nodename x,y)) (span (/='\r') msg')
>	     -- putStr $ "$: Looking up " ++ node ++ "..."
>	     res <- lookup dict node
>	     (handle#writeH) (show (case res of
>	       (Just (_,port)) -> (Just port)
>	       Nothing	       -> Nothing))
>	     return (Left False)

'/': Unregister

>	   '/':msg' -> do
>	      let (node,_) = (\(x,y) -> (Nodename x,y)) (span (/='\r') msg')
>	      -- putStr $ "/: Unregistering " ++ node
>	      res <- lookup dict node
>	      when (isJust res)
>		(del dict node)
>	      return (Left False)
>	   _ -> return (Right msg)

>       evaluateMsg :: Handle -> String -> Network.Hostname -> Port -> IO Bool
>       evaluateMsg handle msg host port = do
>	 -- putStrLn msg
>	 ev <- baseEval handle msg host port
>        case ev of
>	   Left res -> return res
>	   Right msg -> do
>	     case msg of

´=´: TCP-Tunnel

>	       '=':msg' -> do
>	         -- putStrLn "tun"
>                he <- BSD.getHostByName host
>		 _ <- Tunnel.tunOpF (tun#thisMV) (\ _ -> return ()) (addressToIP (BSD.hostAddress he)) port handle baseEvalWrap msg'
>		 -- _ <- (tun#Tunnel.tunOp) (\ _ -> return ()) (addressToIP (BSD.hostAddress he)) port handle baseEvalWrap msg'
>	         return False

'@': Tunnel-Close

>	       '@':msg' -> do
>	         return True

>	       x -> do
>	          -- putStrLn $ "dhd: Junk received *" ++ x ++ "*"
>	          return False
>  
>    lookup :: DictPtr -> Nodename -> IO (Maybe PNode)
>    lookup (ci,co) name = do
>      mv <- newEmptyMVar
>      writeChan ci (Lookup name mv)
>      (DictReply ans) <- readMVar mv
>      return ans

>    del :: DictPtr -> Nodename -> IO ()
>    del (ci,co) name = do
>      writeChan ci (Delete name)

>    insert :: DictPtr -> (Nodename,PNode) -> IO ()
>    insert (ci,co) (name,port) = do
>      writeChan ci (Add (name,port))

> runDict :: DicChan -> Dict -> IO ()
> runDict ci dict = do 
>   msg <- readChan ci
>   case msg of
>     Lookup name mv -> do
>       putMVar mv (DictReply (Prelude.lookup name dict))
>	runDict ci dict
>     Delete name -> do
>	runDict ci (del name dict [])
>     Add np -> do
>       runDict ci (np:dict)
>     Flush -> do
>       runDict ci []
>     Dump -> do
>       mapM print dict
>	runDict ci dict	

>  where  
>    -- del :: Nodename -> [(Nodename,Port)] -> [(Nodename,Port)] -> [(Nodename,Port)]
>    del node (np@(n,p):nps) acc
>      | node == n = acc ++ nps
>      | otherwise = del node nps (np:acc)