Mainline DHT rewrite: newClient

1 files changed, 32 insertions, 6 deletions

diff --git a/Mainline.hs b/Mainline.hs
index e2ab2d7f..d24b3376 100644
--- a/Mainline.hs
+++ b/Mainline.hs
@@ -7,6 +7,8 @@
 module Mainline where
 
 import Control.Arrow
+import Control.Concurrent.STM
+import Crypto.Random
 import Data.BEncode             as BE
 import Data.BEncode.BDict       as BE
 import Data.Bool
@@ -16,6 +18,7 @@ import Data.ByteString          as B
 import Data.ByteString.Lazy     (toStrict)
 import Data.Data
 import Data.IP
+import Data.Maybe
 import Data.Monoid
 import qualified Data.Serialize as S
 import Data.Typeable
@@ -84,7 +87,7 @@ data Error = Error
     , errorMessage :: !ByteString -- ^ Human-readable text message.
     } deriving ( Show, Eq, Ord, Typeable, Data, Read )
 
-newtype TransactionId = TransactionId Word16
+newtype TransactionId = TransactionId ByteString
  deriving (Eq, Ord, Show, BEncode)
 
 newtype Method = Method ByteString
@@ -145,26 +148,49 @@ encodePacket :: Message BValue -> NodeInfo -> (ByteString, SockAddr)
 encodePacket msg ni = ( toStrict $ BE.encode msg
                       , nodeAddr ni )
 
+newClient ::
+      SockAddr -> IO (Client String Method TransactionId NodeInfo (Message BValue))
 newClient addr = do
     udp <- udpTransport addr
+    nid <- error "todo: tentative node id"
+    self <- atomically $ newTVar
+             $ NodeInfo nid (fromMaybe (toEnum 0) $ fromSockAddr addr)
+                            (fromMaybe 0 $ sockAddrPort addr)
+    -- drg <- getSystemDRG
     let net = layerTransport parsePacket encodePacket udp
-    return net
+        dispatch tbl = DispatchMethods
+            { classifyInbound = classify
+            , lookupHandler = handlers
+            , tableMethods = tbl
+            }
+        mapT = transactionMethods mapMethods gen
+        gen :: Word16 -> (TransactionId, Word16)
+        gen cnt = (TransactionId $ S.encode cnt, cnt+1)
+    map_var <- atomically $ newTVar (0, mempty)
+    return Client
+            { clientNet           = net
+            , clientDispatcher    = dispatch mapT
+            , clientErrorReporter = ignoreErrors -- TODO
+            , clientPending       = map_var
+            , clientAddress       = atomically (readTVar self)
+            , clientResponseId    = return
+            }
 
 classify :: Message BValue -> MessageClass String Method TransactionId
 classify (Q { msgID = tid, qryMethod = meth }) = IsQuery meth tid
 classify (R { msgID = tid                   }) = IsResponse tid
 
-encodePayload () tid self dest b = R (nodeId self) tid (Right $ BE.toBEncode b) (Just $ nodeAddr dest)
+encodePayload tid self dest b = R (nodeId self) tid (Right $ BE.toBEncode b) (Just $ nodeAddr dest)
 
-errorPayload () tid self dest e = R (nodeId self) tid (Left e) (Just $ nodeAddr dest)
+errorPayload tid self dest e = R (nodeId self) tid (Left e) (Just $ nodeAddr dest)
 
 decodePayload :: BEncode a => Message BValue -> Either String a
 decodePayload msg = BE.fromBEncode $ qryPayload msg
 
 handler f = Just $ MethodHandler decodePayload encodePayload f
 
-handlers :: Method -> Maybe (MethodHandler String TransactionId NodeInfo (Message BValue) ())
-handlers (Method "ping"     ) = handler pingH
+handlers :: Method -> Maybe (MethodHandler String TransactionId NodeInfo (Message BValue))
+handlers (Method "ping"     ) = error "handler pingH"
 handlers (Method "find_node") = error "find_node"
 handlers (Method "get_peers") = error "get_peers"
 handlers (Method meth       ) = Just $ MethodHandler decodePayload errorPayload (defaultH meth)