It builds!

1 files changed, 187 insertions, 33 deletions

diff --git a/examples/dhtd.hs b/examples/dhtd.hs
index 8496dd5a..99ff7218 100644
--- a/examples/dhtd.hs
+++ b/examples/dhtd.hs
@@ -1,5 +1,7 @@
 {-# LANGUAGE NondecreasingIndentation #-}
 {-# LANGUAGE FlexibleContexts      #-}
+{-# LANGUAGE FlexibleInstances     #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE LambdaCase            #-}
 {-# LANGUAGE OverloadedStrings     #-}
 {-# LANGUAGE ScopedTypeVariables   #-}
@@ -7,6 +9,7 @@
 {-# LANGUAGE RecordWildCards       #-}
 {-# LANGUAGE PartialTypeSignatures #-}
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE RankNTypes #-}
 
 import Control.Arrow
 import Control.Monad
@@ -39,6 +42,7 @@ import Network.BitTorrent.DHT.Query
 import Network.DHT.Mainline (FindNode(..),NodeFound(..),GetPeers(..),GotPeers(..))
 import Network.DatagramServer (QueryFailure(..))
 import Network.DatagramServer.Mainline (ReflectedIP(..),KMessageOf)
+import qualified Network.DatagramServer.Tox as Tox
 import qualified Network.DHT.Routing as R
 import Network.BitTorrent.DHT.Session
 import Network.SocketLike
@@ -53,6 +57,14 @@ import Control.Concurrent
 #endif
 import Control.Concurrent.STM
 import System.Environment
+import Data.BEncode (BValue)
+import Network.DHT.Types
+import Network.DatagramServer.Types
+import Data.Bits
+import Data.Serialize
+import Network.KRPC.Method
+import Data.Typeable
+import GHC.Generics
 
 mkNodeAddr :: SockAddr -> NodeAddr IPv4
 mkNodeAddr addr = NodeAddr (fromJust $ fromSockAddr addr)
@@ -72,20 +84,27 @@ showReport kvs = do
     (k,v) <- kvs
     concat [ printf "  %-*s" (colwidth+1) k, v, "\n" ]
 
-showEnry :: Show a => (NodeInfo KMessageOf a (), t) -> [Char]
+showEnry ::
+    ( Show a
+    , Pretty (NodeId dht)
+    ) => (NodeInfo dht a u, t) -> [Char]
 showEnry (n,_) = intercalate " "
     [ show $ pPrint (nodeId n)
     , show $ nodeAddr n
     ]
 
-printTable :: DHT IPv4 ()
+printTable ::
+    ( Pretty (NodeId dht)
+    ) => DHT raw dht u IPv4 ()
 printTable = do
     t <- showTable
     liftIO $ do
         putStrLn t
         hFlush stdout
 
-showTable :: DHT IPv4 String
+showTable ::
+    ( Pretty (NodeId dht)
+    ) => DHT raw dht u IPv4 String
 showTable = do
     nodes <- R.toList <$> getTable
     return $ showReport
@@ -109,7 +128,7 @@ noLogging _ _ = False
 allNoise :: LogSource -> LogLevel ->  Bool
 allNoise _ _ = True
 
-resume :: DHT IPv4 (Maybe B.ByteString)
+resume :: DHT raw dht u IPv4 (Maybe B.ByteString)
 resume = do
     restore_attempt <- liftIO $ tryIOError $ B.readFile "dht-nodes.dat"
     saved_nodes <-
@@ -119,7 +138,30 @@ resume = do
             restore_attempt
     return saved_nodes
 
-godht :: String -> (NodeAddr IPv4 -> NodeId _ -> DHT IPv4 b) -> IO b
+godht ::
+    ( Eq (QueryMethod dht)
+    , Show (QueryMethod dht)
+    , Functor dht
+    , Ord (TransactionID dht)
+    , Serialize (TransactionID dht)
+    , Kademlia dht
+    , WireFormat raw dht
+    , DataHandlers raw dht
+    , SerializableTo raw (Query dht (FindNode dht IPv4))
+    , SerializableTo raw (Response dht (NodeFound dht IPv4))
+    , SerializableTo raw (Query dht (Ping dht))
+    , SerializableTo raw (Response dht (Ping dht))
+    , KRPC (Query dht (FindNode dht IPv4)) (Response dht (NodeFound dht IPv4))
+    , KRPC (Query dht (Ping dht)) (Response dht (Ping dht))
+    , Ord (NodeId dht)
+    , FiniteBits (NodeId dht)
+    , Serialize (NodeId dht)
+    , Show (NodeId dht)
+    , Pretty (NodeId dht)
+    , Pretty (NodeInfo dht IPv4 u)
+    , Default u
+    , Show u
+    ) => String -> (NodeAddr IPv4 -> NodeId dht -> DHT raw dht u IPv4 b) -> IO b
 godht p f = do
     a <- btBindAddr p False
     dht def { optTimeout = 5 } a noDebugPrints $ do
@@ -138,21 +180,118 @@ hPutClient h s = hPutStr h ('.' : marshalForClient s)
 hPutClientChunk :: Handle -> String -> IO ()
 hPutClientChunk h s = hPutStr h (' ' : marshalForClient s)
 
-clientSession :: Node IPv4 -> MVar () -> RestrictedSocket -> Int -> Handle -> IO ()
-clientSession st signalQuit sock n h = do
+data GenericDHT ip a
+    = GenericDHT
+        (forall raw dht u.
+            ( Eq (QueryMethod dht)
+            , Show (QueryMethod dht)
+            , Functor dht
+            , Ord (TransactionID dht)
+            , Serialize (TransactionID dht)
+            , Kademlia dht
+            , WireFormat raw dht
+            , DataHandlers raw dht
+            , SerializableTo raw (Query dht (FindNode dht ip))
+            , SerializableTo raw (Response dht (NodeFound dht ip))
+            , SerializableTo raw (Query dht (Ping dht))
+            , SerializableTo raw (Response dht (Ping dht))
+            , KRPC (Query dht (FindNode dht ip)) (Response dht (NodeFound dht ip))
+            , KRPC (Query dht (Ping dht)) (Response dht (Ping dht))
+            , Ord (NodeId dht)
+            , FiniteBits (NodeId dht)
+            , Serialize (NodeId dht)
+            , Show (NodeId dht)
+            , Pretty (NodeId dht)
+            , Pretty (NodeInfo dht ip ())
+            , Pretty (NodeInfo dht ip u)
+            , Default u
+            , Show u
+            , Read (NodeId dht)
+            ) => DHT raw dht u ip a)
+    | BtDHT (DHT BValue KMessageOf () ip a)
+
+dhtType :: DHT raw dht u ip (Proxy dht)
+dhtType = return Proxy
+
+nodeIdType :: NodeId dht -> DHT raw dht u ip ()
+nodeIdType _ = return ()
+
+nodeAddrType :: NodeAddr ip -> DHT raw dht u ip ()
+nodeAddrType _ = return ()
+
+ipType :: f dht ip -> DHT raw dht u ip ()
+ipType _ = return ()
+
+instance Kademlia Tox.Message where
+instance Pretty (NodeId Tox.Message) where
+instance Pretty (NodeInfo Tox.Message IPv4 ()) where
+instance Pretty (NodeInfo Tox.Message IPv4 Bool) where -- TODO
+instance Read (NodeId KMessageOf) where -- TODO
+instance Read (NodeId Tox.Message) where -- TODO
+instance Serialize (FindNode Tox.Message IPv4) where
+    get = error "TODO get"
+    put = error "TODO put"
+instance Serialize (NodeFound Tox.Message IPv4) where
+    get = error "TODO get"
+    put = error "TODO put"
+instance Serialize (Ping Tox.Message) where
+    get = error "TODO get"
+    put = error "TODO put"
+instance Serialize (Query Tox.Message (FindNode Tox.Message IPv4)) where
+    get = error "TODO get"
+    put = error "TODO put"
+instance Serialize (Query Tox.Message (Ping Tox.Message)) where -- TODO
+    get = error "TODO get"
+    put = error "TODO put"
+instance Serialize (Response Tox.Message (NodeFound Tox.Message IPv4)) where
+    get = error "TODO get"
+    put = error "TODO put"
+instance Serialize (Response Tox.Message (Ping Tox.Message)) where -- TODO
+    get = error "TODO get"
+    put = error "TODO put"
+instance KRPC (Query    Tox.Message (FindNode Tox.Message IPv4))
+              (Response Tox.Message (NodeFound Tox.Message IPv4)) where
+instance KRPC (Query    Tox.Message (Ping Tox.Message ))
+              (Response Tox.Message (Ping Tox.Message )) where
+instance DataHandlers ByteString Tox.Message where
+
+
+-- instance Generic (Response Tox.Message (NodeFound Tox.Message IPv4)) where -- TODO
+
+instance Default Bool where def = False
+
+clientSession :: Node BValue KMessageOf () IPv4 -> Node B.ByteString Tox.Message Bool IPv4 -> MVar () -> Bool ->  RestrictedSocket -> Int -> Handle -> IO ()
+clientSession bt tox signalQuit isBt sock n h = do
     line <- map toLower . dropWhile isSpace <$> hGetLine h
-    let cmd0 action = action >> clientSession st signalQuit sock n h
-        cmd  action = cmd0 $ join $ runDHT st action
+    let dht :: Either (Node BValue KMessageOf () IPv4)
+                      (Node B.ByteString Tox.Message Bool IPv4)
+        dht | isBt      = Left  bt
+            | otherwise = Right tox
+        cmd0 :: IO () -> IO ()
+        cmd0 action = action >> clientSession bt tox signalQuit isBt sock n h
+        cmd :: GenericDHT IPv4 (IO ()) -> IO ()
+        cmd  (GenericDHT action) = cmd0 $ join $ either (flip runDHT action) (flip runDHT action) dht
+        cmd  (BtDHT action)      = cmd0 $ join $ runDHT bt action
         (c,args) = second (dropWhile isSpace) $ break isSpace line
+        switchNetwork dest = clientSession bt tox signalQuit dest sock n h
     case (c,args) of
 
+        ("bt", _) -> switchNetwork True
+
+        ("tox", _) -> switchNetwork False
+
         ("quit", _) -> hPutClient h "" >> hClose h
 
         ("stop", _) -> do hPutClient h "Terminating DHT Daemon."
                           hClose h
                           putMVar signalQuit ()
 
-        ("ls", _) -> cmd $ do
+        ("pid", _) -> cmd0 $ do
+                    pid <- getProcessID
+                    hPutClient h (show pid)
+
+        -- DHT specific
+        ("ls", _) -> cmd $ GenericDHT $ do
                     tbl <- getTable
                     t <- showTable
                     me <- myNodeIdAccordingTo (read "8.8.8.8:6881")
@@ -163,14 +302,15 @@ clientSession st signalQuit sock n h = do
                         , showReport
                             [ ("node-id", show $ pPrint me)
                             , ("internet address", show ip)
-                            , ("buckets", show $ R.shape tbl)]
+                            , ("buckets", show $ R.shape tbl)
+                            , ("network", if isBt then "mainline" else "tox") ]
                         ]
-        ("external-ip", _) -> cmd $ do
+        ("external-ip", _) -> cmd $ BtDHT $ do
                     ip <- routableAddress
                     return $ do
                     hPutClient h $ maybe "" (takeWhile (/=':') . show) ip
 
-        ("swarms", s) -> cmd $ do
+        ("swarms", s) -> cmd $ BtDHT $ do
                     let fltr = case s of
                                     ('-':'v':cs) | all isSpace (take 1 cs)
                                       -> const True
@@ -181,23 +321,21 @@ clientSession st signalQuit sock n h = do
                     return $ do
                     hPutClient h $ showReport r
 
-        ("peers", s) -> cmd $ case readEither s of
+        -- bittorrent only
+        ("peers", s) -> cmd $ BtDHT $ case readEither s of
                         Right ih -> do
                             ps <- allPeers ih
                             seq ih $ return $ do
                             hPutClient h $ showReport $ map (((,) "") . show . pPrint) ps
                         Left er -> return $ hPutClient h er
 
-        ("pid", _) -> cmd $ return $ do
-                    pid <- getProcessID
-                    hPutClient h (show pid)
 #ifdef THREAD_DEBUG
-        ("threads", _) -> cmd $ return $ do
+        ("threads", _) -> cmd0 $ do
                     ts <- threadsInformation
                     tm <- getCurrentTime
                     let r = map (\PerThread{..} -> (show lbl,show (diffUTCTime tm startTime))) ts
                     hPutClient h $ showReport r
-        ("mem", s) -> cmd $ return $ do
+        ("mem", s) -> cmd0 $ do
                     case s of
                         "gc" -> do hPutClient h "Performing garbage collection..."
                                    performMajorGC
@@ -230,24 +368,27 @@ clientSession st signalQuit sock n h = do
                         _ -> hPutClient h "error."
 
 #endif
-        ("closest", s) -> cmd $ do
+        -- DHT specific
+        ("closest", s) -> cmd $ GenericDHT $ do
                         let (ns,hs) = second (dropWhile isSpace) $ break isSpace s
                             parse | null hs = do
                                        ih <- readEither ns
-                                       return (8 :: Int, ih :: InfoHash)
+                                       return (8 :: Int, ih)
                                   | otherwise = do
                                        n <- readEither ns
                                        ih <- readEither hs
-                                       return (n :: Int, ih :: InfoHash)
+                                       return (n :: Int, ih)
                         case parse of
                             Right (n,ih) -> do
+                                nodeIdType ih
                                 tbl <- getTable
                                 let nodes = R.kclosest n ih tbl
                                 return $ do
-                                hPutClient h $ unlines $ map (showEnry . (flip (,) 0)) nodes
+                                hPutClient h $ unlines $ map (showEnry . (flip (,) (error "showEnry"))) nodes
                             Left er -> return $ hPutClient h er
 
-        ("ping", s) -> cmd $ do
+        -- DHT specific
+        ("ping", s) -> cmd $ GenericDHT $ do
                     case readEither s of
                         Right addr -> do result <- try $ pingQ addr
                                          let rs = either (pure . showQueryFail) reportPong result
@@ -255,22 +396,30 @@ clientSession st signalQuit sock n h = do
                                          hPutClient h $ unlines rs
                         Left er -> return $ hPutClient h er
 
-        ("find-nodes", s) -> cmd $ do
+        -- DHT specific
+        ("find-nodes", s) -> cmd $ GenericDHT $ do
                     let (hs,as) = second (dropWhile isSpace) $ break isSpace s
                         parse = do ih <- readEither hs
                                    a <- readEither as
                                    -- XXX: using 'InfoHash' only because 'NodeId' currently
                                    -- has no 'Read' instance.
-                                   return (ih :: InfoHash, a :: NodeAddr IPv4)
+                                   return (ih, a :: NodeAddr IPv4)
                     case parse of
                         Right (ih,a) -> do
-                            result <- try $ queryNode' (a ::NodeAddr IPv4) $ FindNode (R.toNodeId ih)
+                            nodeIdType ih
+                            nodeAddrType a
+                            proxy <- dhtType
+                            let fn = findNodeMessage proxy ih
+                            ipType fn
+                            result <- try $ queryNode' a fn
+                            either (const $ return ()) (\(nid,nf,_) -> nodeIdType nid >> ipType nf) result
                             let rs = either (pure . showQueryFail) reportNodes result
                             return $ do
                             hPutClient h $ unlines rs
                         Left er -> return $ hPutClient h er
 
-        ("get-peers", s) -> cmd $ do
+        -- bittorrent only
+        ("get-peers", s) -> cmd $ BtDHT $ do
                     let (hs,as) = second (dropWhile isSpace) $ break isSpace s
                         parse = do ih <- readEither hs
                                    a <- readEither as
@@ -283,7 +432,8 @@ clientSession st signalQuit sock n h = do
                             hPutClient h $ showReport rs
                         Left er -> return $ hPutClient h er
 
-        ("search-peers", s) -> cmd $ do
+        -- bittorrent only
+        ("search-peers", s) -> cmd $ BtDHT $ do
                     case readEither s of
                         Right ih -> do
                             (tid, s) <- isearch ioGetPeers ih
@@ -315,10 +465,14 @@ consip' (ReflectedIP ip) xs = ("to", show ip) : xs
 
 reportPong (info,myip) = maybe id consip myip [show $ pPrint info]
 
-reportNodes :: (NodeId _, NodeFound IPv4, Maybe ReflectedIP) -> [String]
-reportNodes (nid,NodeFound ns,myip) = maybe id consip myip $ show (pPrint nid) : map (show . pPrint) ns
+reportNodes ::
+    ( Kademlia dht
+    , Pretty (NodeInfo dht ip ())
+    , Pretty (NodeId dht)
+    ) => (NodeId dht, NodeFound dht ip, Maybe ReflectedIP) -> [String]
+reportNodes (nid,ns,myip) = maybe id consip myip $ show (pPrint nid) : map (show . pPrint) (foundNodes ns)
 
-reportPeers :: (NodeId _, GotPeers IPv4, Maybe ReflectedIP) -> [(String,String)]
+reportPeers :: (NodeId KMessageOf, GotPeers IPv4, Maybe ReflectedIP) -> [(String,String)]
 reportPeers (nid,GotPeers r tok,myip)
     = maybe id consip' myip $ ("from", show (pPrint nid))
      : ("token", show tok)
@@ -368,7 +522,7 @@ main = do
     st <- ask
     waitForSignal <- liftIO $ do
         signalQuit <- newEmptyMVar
-        srv <- streamServer (withSession $ clientSession st signalQuit) (SockAddrUnix "dht.sock")
+        srv <- streamServer (withSession $ clientSession st (error "todo: tox state") signalQuit True) (SockAddrUnix "dht.sock")
         return $ liftIO $ do
             () <- takeMVar signalQuit
             quitListening srv