external-ip command.

1 files changed, 36 insertions, 4 deletions

diff --git a/examples/dhtd.hs b/examples/dhtd.hs
index 5c1bbb26..f98b05bd 100644
--- a/examples/dhtd.hs
+++ b/examples/dhtd.hs
@@ -4,6 +4,7 @@
 {-# LANGUAGE FlexibleInstances         #-}
 {-# LANGUAGE LambdaCase                #-}
 {-# LANGUAGE MultiParamTypeClasses     #-}
+{-# LANGUAGE NamedFieldPuns            #-}
 {-# LANGUAGE NondecreasingIndentation  #-}
 {-# LANGUAGE OverloadedStrings         #-}
 {-# LANGUAGE PartialTypeSignatures     #-}
@@ -59,9 +60,14 @@ showReport kvs = do
 marshalForClient :: String -> String
 marshalForClient s = show (length s) ++ ":" ++ s
 
+-- | Writes a message and signals ready for next command.
 hPutClient :: Handle -> String -> IO ()
 hPutClient h s = hPutStr h ('.' : marshalForClient s)
 
+-- | Writes message, but signals there is more to come.
+hPutClientChunk :: Handle -> String -> IO ()
+hPutClientChunk h s = hPutStr h (' ' : marshalForClient s)
+
 data DHT = forall ni. ( Show     ni
                       , Read     ni
                       , ToJSON   ni
@@ -117,13 +123,20 @@ reportTable bkts = map (show *** show . fst)
                  $ R.toList
                  $ bkts
 
-clientSession netname dhts signalQuit sock n h = do
+data Session = Session
+    { netname           :: String
+    , dhts              :: Map.Map String DHT
+    , externalAddresses :: IO [SockAddr]
+    , signalQuit        :: MVar ()
+    }
+
+clientSession s@Session{..} sock cnum h = do
     line <- map toLower . dropWhile isSpace <$> hGetLine h
     let (c,args) = second (dropWhile isSpace) $ break isSpace line
         cmd0 :: IO () -> IO ()
-        cmd0 action = action >> clientSession netname dhts signalQuit sock n h
+        cmd0 action = action >> clientSession s sock cnum h
         switchNetwork dest = do hPutClient h ("Network: "++dest)
-                                clientSession dest dhts signalQuit sock n h
+                                clientSession s{netname=dest} sock cnum h
     case (c,args) of
         ("stop", _) -> do hPutClient h "Terminating DHT Daemon."
                           hClose h
@@ -134,6 +147,9 @@ clientSession netname dhts signalQuit sock n h = do
         ("pid", _) -> cmd0 $ do
                     pid <- getProcessID
                     hPutClient h (show pid)
+        ("external-ip", _) -> cmd0 $ do
+                    unlines . map show <$> externalAddresses
+                        >>= hPutClient h
 #ifdef THREAD_DEBUG
         ("threads", _) -> cmd0 $ do
                     ts <- threadsInformation
@@ -205,6 +221,13 @@ clientSession netname dhts signalQuit sock n h = do
 
         _    -> cmd0 $ hPutClient h "error."
 
+
+readExternals :: [TVar (BucketList Mainline.NodeInfo)] -> IO [SockAddr]
+readExternals vars = do
+    as <- atomically $ mapM (fmap (Mainline.nodeAddr . selfNode) . readTVar) vars
+    -- TODO: Filter to only global addresses?
+    return as
+
 defaultPort = "6881"
 
 main = do
@@ -228,7 +251,16 @@ main = do
 
     waitForSignal <- do
         signalQuit <- newEmptyMVar
-        srv <- streamServer (withSession $ clientSession "bt4" dhts signalQuit) (SockAddrUnix "dht.sock")
+        let session = clientSession $ Session
+                { netname           = "bt4" -- initial default DHT
+                , dhts              = dhts  -- all DHTs
+                , signalQuit        = signalQuit
+                , externalAddresses = readExternals
+                                        [ Mainline.routing4 btR
+                                        , Mainline.routing6 btR
+                                        ]
+                }
+        srv <- streamServer (withSession session) (SockAddrUnix "dht.sock")
         return $ do
             () <- takeMVar signalQuit
             quitListening srv