Switched to the 3-transports (DHT,Onion,Crypto) Tox design.

1 files changed, 205 insertions, 106 deletions

diff --git a/examples/dhtd.hs b/examples/dhtd.hs
index 232abd6e..f651ba1b 100644
--- a/examples/dhtd.hs
+++ b/examples/dhtd.hs
@@ -14,6 +14,7 @@
 {-# LANGUAGE ScopedTypeVariables       #-}
 {-# LANGUAGE TupleSections             #-}
 {-# LANGUAGE TypeFamilies              #-}
+{-# LANGUAGE TypeOperators             #-}
 
 import Control.Arrow
 import Control.Concurrent.STM
@@ -64,6 +65,10 @@ import Data.Wrapper.PSQ as PSQ (pattern (:->))
 import qualified Data.Wrapper.PSQ as PSQ
 import Data.Ord
 import Data.Time.Clock.POSIX
+import qualified DHTTransport as Tox
+import qualified DHTHandlers as Tox
+import qualified OnionHandlers as Tox
+import Data.Typeable
 
 showReport :: [(String,String)] -> String
 showReport kvs = showColumns $ map (\(x,y)->[x,y]) kvs
@@ -88,7 +93,10 @@ hPutClient h s = hPutStr h ('.' : marshalForClient s)
 hPutClientChunk :: Handle -> String -> IO ()
 hPutClientChunk h s = hPutStr h (' ' : marshalForClient s)
 
-data DHTQuery nid ni = forall addr r tok. Ord addr => DHTQuery
+data DHTQuery nid ni = forall addr r tok.
+                        ( Ord addr
+                        , Typeable r
+                        )=> DHTQuery
     { qsearch  :: Search nid addr tok ni r
     , qhandler :: ni -> nid -> IO ([ni], [r], tok)
     , qshowR   :: r -> String
@@ -111,13 +119,16 @@ data DHT = forall nid ni. ( Show     ni
                           , Show     nid
                           , Ord      nid
                           , Hashable nid
+                          , Typeable ni
+                          , S.Serialize nid
                           ) =>
     DHT
-    { dhtBuckets  :: TVar (BucketList ni)
-    , dhtPing     :: ni -> IO Bool
-    , dhtQuery    :: Map.Map String (DHTQuery nid ni)
-    , dhtParseId  :: String -> Either String nid
-    , dhtSearches :: TVar (Map.Map (String,nid) (DHTSearch nid ni))
+    { dhtBuckets       :: TVar (BucketList ni)
+    , dhtPing          :: ni -> IO Bool
+    , dhtQuery         :: Map.Map String (DHTQuery nid ni)
+    , dhtParseId       :: String -> Either String nid
+    , dhtSearches      :: TVar (Map.Map (String,nid) (DHTSearch nid ni))
+    , dhtFallbackNodes :: IO [ni]
     }
 
 nodesFileName :: String -> String
@@ -459,140 +470,228 @@ clientSession s@Session{..} sock cnum 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
+readExternals :: (ni -> SockAddr) -> [TVar (BucketList ni)] -> IO [SockAddr]
+readExternals nodeAddr vars = do
+    as <- atomically $ mapM (fmap (nodeAddr . selfNode) . readTVar) vars
     let unspecified (SockAddrInet _ 0)              = True
         unspecified (SockAddrInet6 _ _ (0,0,0,0) _) = True
         unspecified _                               = False
     -- TODO: Filter to only global addresses?
     return $ filter (not . unspecified) as
 
-defaultPort :: String
-defaultPort = "6881"
+data Options = Options
+    { portbt  :: String
+    , porttox :: String
+    , ip6bt   :: Bool
+    , ip6tox  :: Bool
+    }
+ deriving (Eq,Show)
+
+sensibleDefaults :: Options
+sensibleDefaults = Options
+    { portbt  = "6881"
+    , porttox = "33445"
+    , ip6bt   = True
+    , ip6tox  = True
+    }
+
+-- bt=<port>,tox=<port>
+-- -4
+parseArgs :: [String] -> Options -> Options
+parseArgs []          opts = opts
+parseArgs ("-4":args) opts = parseArgs args opts
+    { ip6bt  = False
+    , ip6tox = False }
+parseArgs (arg:args) opts        = parseArgs args opts
+    { portbt  = fromMaybe (portbt opts)  $ Prelude.lookup "bt"  ports
+    , porttox = fromMaybe (porttox opts) $ Prelude.lookup "tox" ports }
+ where
+    ports = map ( (dropWhile (==',') *** dropWhile (=='='))
+                . break (=='=') )
+                $ groupBy (const (/= ',')) arg
+
 
 main :: IO ()
 main = do
     args <- getArgs
-    p <- case take 2 (dropWhile (/="-p") args) of
-                ["-p",port] | not ("-" `isPrefixOf` port) -> return port
-                ("-p":_)      -> error "Port not specified! (-p PORT)"
-                _             -> return defaultPort
-    addr <- getBindAddress p True{- ipv6 -}
-
-    (bt,btR,swarms) <- Mainline.newClient addr
+    let opts = parseArgs args sensibleDefaults
+    print opts
 
+    swarms <- Mainline.newSwarmsDatabase
     -- Restore peer database before forking the listener thread.
     peerdb <- left show <$> tryIOError (L.readFile "bt-peers.dat")
     either (hPutStrLn stderr . ("bt-peers.dat: "++))
            (atomically . writeTVar (Mainline.contactInfo swarms))
            (peerdb >>= S.decodeLazy)
 
-    quitBt <- forkListener (clientNet bt)
-
-    let toxport = succ $ fromMaybe 33445 (fromIntegral <$> sockAddrPort addr)
-    addrTox <- getBindAddress (show toxport) True
-    (tox,toxR,toxkeys) <- Tox.newClient addrTox
-
-    quitTox <- forkListener (clientNet tox)
-
-    mainlineSearches <- atomically $ newTVar Map.empty
-    toxSearches <- atomically $ newTVar Map.empty
-
-    let mainlineDHT bkts = DHT
-            { dhtBuckets = bkts btR
-            , dhtPing    = Mainline.ping bt
-            , dhtQuery   = Map.fromList
-                            [ ("node", DHTQuery (Mainline.nodeSearch bt)
-                                                (\ni -> fmap Mainline.unwrapNodes
-                                                        . Mainline.findNodeH btR ni
-                                                        . flip Mainline.FindNode (Just Want_Both))
-                                                show
-                                                (const Nothing))
-                            , ("peer", DHTQuery (Mainline.peerSearch bt)
-                                                (\ni -> fmap Mainline.unwrapPeers
-                                                        . Mainline.getPeersH btR swarms ni
-                                                        . flip Mainline.GetPeers (Just Want_Both)
-                                                        . (read . show)) -- TODO: InfoHash -> NodeId
-                                                (show . pPrint)
-                                                (Just . show))
-                            ]
-            , dhtParseId  = readEither :: String -> Either String Mainline.NodeId
-            , dhtSearches = mainlineSearches
-            }
-        toxDHT bkts = DHT
-            { dhtBuckets = bkts toxR
-            , dhtPing    = Tox.ping tox
-            , dhtQuery   = Map.fromList
-                            [ ("node", DHTQuery (Tox.nodeSearch tox)
-                                                (\ni -> fmap Tox.unwrapNodes
-                                                        . Tox.getNodesH toxR ni
-                                                        . Tox.GetNodes)
-                                                show
-                                                (const Nothing))
-                            ]
-            , dhtParseId  = readEither :: String -> Either String Tox.NodeId
-            , dhtSearches = toxSearches
-            }
-        dhts = Map.fromList
-                [ ("bt4", mainlineDHT Mainline.routing4)
-                , ("bt6", mainlineDHT Mainline.routing6)
-                , ("tox4", toxDHT Tox.routing4)
-                , ("tox6", toxDHT Tox.routing6)
-                ]
+    (quitBt,btdhts,btips) <- case portbt opts of
+        "" -> return (return (), Map.empty,return [])
+        p  -> do
+            addr <- getBindAddress p (ip6bt opts)
+            (bt,btR) <- Mainline.newClient swarms addr
+            quitBt <- forkListener "bt" (clientNet bt)
+            mainlineSearches <- atomically $ newTVar Map.empty
+            let mainlineDHT bkts wantip = DHT
+                    { dhtBuckets = bkts btR
+                    , dhtPing    = Mainline.ping bt
+                    , dhtQuery   = Map.fromList
+                                    [ ("node", DHTQuery (Mainline.nodeSearch bt)
+                                                        (\ni -> fmap Mainline.unwrapNodes
+                                                                . Mainline.findNodeH btR ni
+                                                                . flip Mainline.FindNode (Just Want_Both))
+                                                        show
+                                                        (const Nothing))
+                                    , ("peer", DHTQuery (Mainline.peerSearch bt)
+                                                        (\ni -> fmap Mainline.unwrapPeers
+                                                                . Mainline.getPeersH btR swarms ni
+                                                                . flip Mainline.GetPeers (Just Want_Both)
+                                                                . (read . show)) -- TODO: InfoHash -> NodeId
+                                                        (show . pPrint)
+                                                        (Just . show))
+                                    ]
+                    , dhtParseId  = readEither :: String -> Either String Mainline.NodeId
+                    , dhtSearches = mainlineSearches
+                    , dhtFallbackNodes = Mainline.bootstrapNodes wantip
+                    }
+                dhts = Map.fromList $
+                        ("bt4", mainlineDHT Mainline.routing4 Want_IP4)
+                        : if ip6bt opts
+                            then [ ("bt6", mainlineDHT Mainline.routing6 Want_IP6) ]
+                            else []
+                ips :: IO [SockAddr]
+                ips = readExternals Mainline.nodeAddr
+                                        [ Mainline.routing4 btR
+                                        , Mainline.routing6 btR
+                                        ]
+            return (quitBt,dhts,ips)
+
+    keysdb <- Tox.newKeysDatabase
+
+    (quitTox,toxdhts,toxips) <- case porttox opts of
+        "" -> return (return (), Map.empty, return [])
+        toxport -> do
+            addrTox <- getBindAddress toxport (ip6tox opts)
+            tox <- Tox.newTox keysdb addrTox
+            quitTox <- Tox.forkTox tox
+
+            toxSearches <- atomically $ newTVar Map.empty
+
+            let toxDHT bkts = DHT
+                    { dhtBuckets = bkts (Tox.toxRouting tox)
+                    , dhtPing    = Tox.ping (Tox.toxDHT tox)
+                    , dhtQuery   = Map.fromList
+                                    [ ("node", DHTQuery (Tox.nodeSearch $ Tox.toxDHT tox)
+                                                        (\ni -> fmap Tox.unwrapNodes
+                                                                . Tox.getNodesH (Tox.toxRouting tox) ni
+                                                                . Tox.GetNodes)
+                                                        show
+                                                        (const Nothing))
+                                    ]
+                    , dhtParseId  = readEither :: String -> Either String Tox.NodeId
+                    , dhtSearches = toxSearches
+                    , dhtFallbackNodes = return []
+                    }
+                dhts = Map.fromList $
+                        ("tox4", toxDHT Tox.routing4)
+                        : if ip6tox opts
+                            then [ ("tox6", toxDHT Tox.routing6) ]
+                            else []
+                ips :: IO [SockAddr]
+                ips = readExternals Tox.nodeAddr [ Tox.routing4 $ Tox.toxRouting tox
+                                                 , Tox.routing6 $ Tox.toxRouting tox ]
+            return (quitTox, dhts, ips)
+
+    let dhts = Map.union btdhts toxdhts
 
     waitForSignal <- do
         signalQuit <- newEmptyMVar
         let session = clientSession $ Session
-                { netname           = "bt4" -- initial default DHT
+                { netname           = concat $ take 1 $ Map.keys dhts -- initial default DHT
                 , dhts              = dhts  -- all DHTs
                 , signalQuit        = signalQuit
                 , swarms            = swarms
-                , toxkeys           = toxkeys
-                , externalAddresses = readExternals
-                                        [ Mainline.routing4 btR
-                                        , Mainline.routing6 btR
-                                        ]
+                , toxkeys           = keysdb
+                , externalAddresses = liftM2 (++) btips toxips
                 }
         srv <- streamServer (withSession session) (SockAddrUnix "dht.sock")
         return $ do
             () <- takeMVar signalQuit
             quitListening srv
 
+
+    forM_ (Map.toList dhts)
+          $ \(netname, dht@DHT { dhtBuckets = bkts
+                             , dhtQuery = qrys
+                             , dhtPing = ping
+                             , dhtFallbackNodes = getBootstrapNodes }) -> do
+        btSaved <- loadNodes netname --  :: IO [Mainline.NodeInfo]
+        putStrLn $ "Loaded "++show (length btSaved)++" nodes for "++netname++"."
+        fallbackNodes <- getBootstrapNodes
+        let isNodesSearch :: ni :~: r -> Search nid addr tok ni r -> Search nid addr tok ni ni
+            isNodesSearch Refl sch = sch
+        fork $ do
+            myThreadId >>= flip labelThread ("bootstrap."++netname)
+            case Map.lookup "node" qrys of
+                Just DHTQuery { qsearch = srch } -> do
+                    case eqT of
+                        Just witness -> bootstrap (isNodesSearch witness srch) bkts ping btSaved fallbackNodes
+                        _            -> error $ "Missing node-search for "++netname++"."
+                    saveNodes netname dht
+                Nothing -> return ()
+        return ()
+
+    {-
     let bkts4 = Mainline.routing4 btR
-    btSaved4 <- loadNodes "bt4" :: IO [Mainline.NodeInfo]
-    putStrLn $ "Loaded "++show (length btSaved4)++" nodes for bt4."
-    fallbackNodes4 <- Mainline.bootstrapNodes Want_IP4
-    fork $ do
-        myThreadId >>= flip labelThread "bootstrap.Mainline4"
-        bootstrap (Mainline.nodeSearch bt) bkts4 (Mainline.ping bt) btSaved4 fallbackNodes4
-        saveNodes "bt4" (dhts Map.! "bt4")
-
-    btSaved6 <- loadNodes "bt6"
-    putStrLn $ "Loaded "++show (length btSaved6)++" nodes for bt6."
-    let bkts6 = Mainline.routing6 btR
-    fallbackNodes6 <- Mainline.bootstrapNodes Want_IP6
-    fork $ do
-        myThreadId >>= flip labelThread "bootstrap.Mainline6"
-        bootstrap (Mainline.nodeSearch bt) bkts6 (Mainline.ping bt) btSaved6 fallbackNodes6
-        saveNodes "bt6" (dhts Map.! "bt6")
-
-    toxSaved4 <- loadNodes "tox4"
-    putStrLn $ "Loaded "++show (length toxSaved4)++" nodes for tox4"
-    fork $ do
-        myThreadId >>= flip labelThread "bootstrap.Tox4"
-        bootstrap (Tox.nodeSearch tox) (Tox.routing4 toxR) (Tox.ping tox) toxSaved4 []
-        saveNodes "tox4" (dhts Map.! "tox4")
-
-    toxSaved6 <- loadNodes "tox6"
-    putStrLn $ "Loaded "++show (length toxSaved6)++" nodes for tox6"
-    fork $ do
-        myThreadId >>= flip labelThread "bootstrap.Tox6"
-        bootstrap (Tox.nodeSearch tox) (Tox.routing6 toxR) (Tox.ping tox) toxSaved6 []
-        saveNodes "tox6" (dhts Map.! "tox6")
+    (fallbackNodes4,fallbackNodes6) <- case portbt opts of
+        [] -> return ([],[])
+        _  -> do
+            btSaved4 <- loadNodes "bt4" :: IO [Mainline.NodeInfo]
+            putStrLn $ "Loaded "++show (length btSaved4)++" nodes for bt4."
+            fallbackNodes4 <- Mainline.bootstrapNodes Want_IP4
+            fork $ do
+                myThreadId >>= flip labelThread "bootstrap.Mainline4"
+                bootstrap (Mainline.nodeSearch bt) bkts4 (Mainline.ping bt) btSaved4 fallbackNodes4
+                saveNodes "bt4" (dhts Map.! "bt4")
+
+            fallbackNodes6 <- case ip6bt opts of
+                True -> do
+                    btSaved6 <- loadNodes "bt6"
+                    putStrLn $ "Loaded "++show (length btSaved6)++" nodes for bt6."
+                    let bkts6 = Mainline.routing6 btR
+                    fallbackNodes6 <- Mainline.bootstrapNodes Want_IP6
+                    fork $ do
+                        myThreadId >>= flip labelThread "bootstrap.Mainline6"
+                        bootstrap (Mainline.nodeSearch bt) bkts6 (Mainline.ping bt) btSaved6 fallbackNodes6
+                        saveNodes "bt6" (dhts Map.! "bt6")
+                    return fallbackNodes6
+                False -> return []
+            return (fallbackNodes4,fallbackNodes6)
+
+    (toxSaved4, toxSaved6) <- case porttox opts of
+        [] -> return ([],[])
+        _  -> do
+            toxSaved4 <- loadNodes "tox4"
+            putStrLn $ "Loaded "++show (length toxSaved4)++" nodes for tox4"
+            fork $ do
+                myThreadId >>= flip labelThread "bootstrap.Tox4"
+                bootstrap (Tox.nodeSearch $ Tox.toxDHT tox) (Tox.routing4 (Tox.toxRouting tox)) (Tox.ping $ Tox.toxDHT tox) toxSaved4 []
+                saveNodes "tox4" (dhts Map.! "tox4")
+
+            toxSaved6 <- case ip6tox opts of
+                True ->  do
+                    toxSaved6 <- loadNodes "tox6"
+                    putStrLn $ "Loaded "++show (length toxSaved6)++" nodes for tox6"
+                    fork $ do
+                        myThreadId >>= flip labelThread "bootstrap.Tox6"
+                        bootstrap (Tox.nodeSearch $ Tox.toxDHT tox) (Tox.routing6 (Tox.toxRouting tox)) (Tox.ping $ Tox.toxDHT tox) toxSaved6 []
+                        saveNodes "tox6" (dhts Map.! "tox6")
+                    return toxSaved6
+                False -> return []
+            return (toxSaved4,toxSaved6)
 
     hPutStr stderr $ showReport $ map (("bootstrap (IPv4)",) . show) fallbackNodes4
                                   ++ map (("bootstrap (IPv6)",) . show) fallbackNodes6
+    -}
 
     waitForSignal