WIP: Adapting DHT to Tox network.

3 files changed, 209 insertions, 29 deletions

diff --git a/src/Network/KRPC/Manager.hs b/src/Network/KRPC/Manager.hs
index 66de6548..e7f0563b 100644
--- a/src/Network/KRPC/Manager.hs
+++ b/src/Network/KRPC/Manager.hs
@@ -55,9 +55,13 @@ import Control.Monad
 import Control.Monad.Logger
 import Control.Monad.Reader
 import Control.Monad.Trans.Control
+#ifdef VERSION_bencoding
 import Data.BEncode as BE
 import Data.BEncode.Internal as BE
 import Data.BEncode.Pretty (showBEncode)
+#else
+import qualified Data.Tox as Tox
+#endif
 import qualified Data.ByteString.Base16 as Base16
 import Data.ByteString as BS
 import Data.ByteString.Char8 as BC
@@ -67,6 +71,7 @@ import Data.IORef
 import Data.List as L
 import Data.Map as M
 import Data.Monoid
+import Data.Serialize as S
 import Data.Text as T
 import Data.Text.Encoding as T
 import Data.Tuple
@@ -128,10 +133,10 @@ type KResult = Either KError KResponse
 
 type TransactionCounter = IORef Int
 type CallId             = (TransactionId, SockAddr)
-type CallRes            = MVar (BValue, KResult)
+type CallRes            = MVar (KQueryArgs, KResult) -- (raw response, decoded response)
 type PendingCalls       = IORef (Map CallId CallRes)
 
-type HandlerBody h = SockAddr -> BValue -> h (BE.Result BValue)
+type HandlerBody h = SockAddr -> KQueryArgs -> h (Either String KQueryArgs)
 
 -- | Handler is a function which will be invoked then some /remote/
 -- node querying /this/ node.
@@ -223,8 +228,13 @@ withManager opts addr hs = bracket (newManager opts addr hs) closeManager
 -- TODO prettify log messages
 querySignature :: MethodName -> TransactionId -> SockAddr -> Text
 querySignature name transaction addr = T.concat
+#ifdef VERSION_bencoding
   [  "&", T.decodeUtf8 name
   , " #", T.decodeUtf8 (Base16.encode transaction) -- T.decodeUtf8 transaction
+#else
+  [  "&", T.pack (show name)
+  , " #", T.decodeUtf8 (Base16.encode $ S.encode transaction)
+#endif
   , " @", T.pack (show addr)
   ]
 
@@ -243,14 +253,24 @@ data QueryFailure
 
 instance Exception QueryFailure
 
+#ifdef VERSION_bencoding
 sendMessage :: MonadIO m => BEncode a => Socket -> SockAddr -> a -> m ()
 sendMessage sock addr a = do
   liftIO $ sendManyTo sock (BL.toChunks (BE.encode a)) addr
+#else
+sendMessage :: MonadIO m => Socket -> SockAddr -> BC.ByteString -> m ()
+sendMessage sock addr a = do
+  liftIO $ sendManyTo sock [a] addr
+#endif
 
 genTransactionId :: TransactionCounter -> IO TransactionId
 genTransactionId ref = do
   cur <- atomicModifyIORef' ref $ \ cur -> (succ cur, cur)
+#ifdef VERSION_bencoding
   return $ BC.pack (show cur)
+#else
+  return $ either (error "failed to create TransactionId") id $ S.decode $ BC.pack (L.take 24 $ show cur ++ L.repeat ' ')
+#endif
 
 -- | How many times 'query' call have been performed.
 getQueryCount :: MonadKRPC h m => m Int
@@ -274,8 +294,13 @@ unregisterQuery cid ref = do
 
 
 -- (sendmsg EINVAL)
+#ifdef VERSION_bencoding
 sendQuery :: BEncode a => Socket -> SockAddr -> a -> IO ()
 sendQuery sock addr q = handle sockError $ sendMessage sock addr q
+#else
+sendQuery :: Serialize a => Socket -> SockAddr -> a -> IO ()
+sendQuery sock addr q = handle sockError $ sendMessage sock addr (S.encode q)
+#endif
   where
     sockError :: IOError -> IO ()
     sockError _ = throwIO SendFailed
@@ -295,11 +320,11 @@ query' addr params = queryK addr params (const (,))
 -- | Enqueue a query, but give us the complete BEncoded content sent by the
 -- remote Node.  This is useful for handling extensions that this library does
 -- not otherwise support.
-queryRaw :: forall h m a b. (MonadKRPC h m, KRPC a b) => SockAddr -> a -> m (b, BValue)
+queryRaw :: forall h m a b. (MonadKRPC h m, KRPC a b) => SockAddr -> a -> m (b, KQueryArgs)
 queryRaw addr params = queryK addr params (\raw x _ -> (x,raw))
 
 queryK :: forall h m a b x. (MonadKRPC h m, KRPC a b) =>
-    SockAddr -> a -> (BValue -> b -> Maybe ReflectedIP -> x) -> m x
+    SockAddr -> a -> (KQueryArgs -> b -> Maybe ReflectedIP -> x) -> m x
 queryK addr params kont = do
   Manager {..} <- getManager
   tid <- liftIO $ genTransactionId transactionCounter
@@ -310,17 +335,29 @@ queryK addr params kont = do
   mres <- liftIO $ do
     ares <- registerQuery (tid, addr) pendingCalls
 
+#ifdef VERSION_bencoding
     let q = KQuery (toBEncode params) (methodName queryMethod) tid
+#else
+    let q = Tox.Message (methodName queryMethod) cli tid params
+        cli = error "TODO TOX client node id"
+#endif
     sendQuery sock addr q
       `onException` unregisterQuery (tid, addr) pendingCalls
 
     timeout (optQueryTimeout options * 10 ^ (6 :: Int)) $ do
-      (raw,res) <- readMVar ares
+      (raw,res) <- readMVar ares -- MVar (KQueryArgs, KResult)
       case res of
+#ifdef VERSION_bencoding
         Left  (KError   c m _) -> throwIO $ QueryFailed c (T.decodeUtf8 m)
         Right (KResponse {..}) ->
           case fromBEncode respVals of
             Right r -> pure $ kont raw r respIP
+#else
+        Left  _                  -> throwIO $ QueryFailed GenericError "TODO: TOX ERROR"
+        Right (Tox.Message {..}) ->
+          case S.decode msgPayload of
+            Right r -> pure $ kont raw r Nothing
+#endif
             Left  e -> throwIO $ QueryFailed ProtocolError (T.pack e)
 
   case mres of
@@ -377,51 +414,87 @@ handler body = (name, wrapper)
   where
     Method name = method :: Method a b
     wrapper addr args =
+#ifdef VERSION_bencoding
       case fromBEncode args of
+#else
+      case S.decode args of
+#endif
         Left  e -> return $ Left e
         Right a -> do
           r <- body addr a
+#ifdef VERSION_bencoding
           return $ Right $ toBEncode r
+#else
+          return $ Right $ S.encode r
+#endif
 
 runHandler :: MonadKRPC h m
            => HandlerBody h -> SockAddr -> KQuery -> m KResult
-runHandler h addr KQuery {..} = Lifted.catches wrapper failbacks
+runHandler h addr m = Lifted.catches wrapper failbacks
   where
-    signature = querySignature queryMethod queryId addr
+    signature = querySignature (queryMethod m) (queryId m) addr
 
     wrapper = do
       $(logDebugS) "handler.quered" signature
-      result <- liftHandler (h addr queryArgs)
+      result <- liftHandler (h addr (queryArgs m))
 
       case result of
         Left msg -> do
           $(logDebugS) "handler.bad_query" $ signature <> " !" <> T.pack msg
-          return $ Left $ KError ProtocolError (BC.pack msg) queryId
+#ifdef VERSION_bencoding
+          return $ Left $ KError ProtocolError (BC.pack msg) (queryId m)
+#else
+          return $ Left $ decodeError "TODO TOX ProtocolError" (queryId m)
+#endif
 
-        Right a -> do
+        Right a -> do -- KQueryArgs
           $(logDebugS) "handler.success" signature
-          return $ Right $ KResponse a queryId (Just $ ReflectedIP addr)
+#ifdef VERSION_bencoding
+          return $ Right $ KResponse a (queryId m) (Just $ ReflectedIP addr)
+#else
+          let cli = error "TODO TOX client node id"
+              messageid = error "TODO TOX message response id"
+              -- TODO: ReflectedIP addr ??
+          return $ Right $ Tox.Message messageid cli (queryId m) a
+#endif
 
     failbacks =
       [ E.Handler $ \ (e :: HandlerFailure) -> do
           $(logDebugS) "handler.failed" signature
-          return $ Left $ KError ProtocolError (prettyHF e) queryId
+#ifdef VERSION_bencoding
+          return $ Left $ KError ProtocolError (prettyHF e) (queryId m)
+#else
+          return $ Left $ decodeError "TODO TOX ProtocolError 2" (queryId m)
+#endif
+
 
         -- may happen if handler makes query and fail
       , E.Handler $ \ (e :: QueryFailure) -> do
-          return $ Left $ KError ServerError (prettyQF e) queryId
+#ifdef VERSION_bencoding
+          return $ Left $ KError ServerError (prettyQF e) (queryId m)
+#else
+          return $ Left $ decodeError "TODO TOX ServerError" (queryId m)
+#endif
 
         -- since handler thread exit after sendMessage we can safely
         -- suppress async exception here
       , E.Handler $ \ (e :: SomeException) -> do
-          return $ Left $ KError GenericError (BC.pack (show e)) queryId
+#ifdef VERSION_bencoding
+          return $ Left $ KError GenericError (BC.pack (show e)) (queryId m)
+#else
+          return $ Left $ decodeError "TODO TOX GenericError" (queryId m)
+#endif
       ]
 
 dispatchHandler :: MonadKRPC h m => KQuery -> SockAddr -> m KResult
-dispatchHandler q @ KQuery {..} addr = do
+dispatchHandler q addr = do
   Manager {..} <- getManager
-  case L.lookup queryMethod handlers of
-    Nothing -> return $ Left $ KError MethodUnknown queryMethod queryId
+  case L.lookup (queryMethod q) handlers of
+#ifdef VERSION_bencoding
+    Nothing -> return $ Left $ KError MethodUnknown (queryMethod q) (queryId q)
+#else
+    Nothing -> return $ Left $ decodeError "TODO TOX Error MethodUnknown" (queryId q)
+#endif
     Just h  -> runHandler h addr q
 
 {-----------------------------------------------------------------------
@@ -435,11 +508,12 @@ dispatchHandler q @ KQuery {..} addr = do
 -- peer B fork too many threads
 -- ... space leak
 --
-handleQuery :: MonadKRPC h m => BValue -> KQuery -> SockAddr -> m ()
+handleQuery :: MonadKRPC h m => KQueryArgs -> KQuery -> SockAddr -> m ()
 handleQuery raw q addr = void $ fork $ do
   myThreadId >>= liftIO . flip labelThread "KRPC.handleQuery"
   Manager {..} <- getManager
   res <- dispatchHandler q addr
+#ifdef VERSION_bencoding
   let resbe = either toBEncode toBEncode res
   $(logOther "q") $ T.unlines
     [ either (const "<unicode-fail>") id $ T.decodeUtf8' (BL.toStrict $ showBEncode raw)
@@ -447,21 +521,36 @@ handleQuery raw q addr = void $ fork $ do
     , either (const "<unicode-fail>") id $ T.decodeUtf8' (BL.toStrict $ showBEncode resbe)
     ]
   sendMessage sock addr resbe
+#else
+  -- Errors not sent for Tox.
+  either (const $ return ()) (sendMessage sock addr . S.encode) res
+#endif
 
-handleResponse :: MonadKRPC h m => BValue -> KResult -> SockAddr -> m ()
+handleResponse :: MonadKRPC h m => KQueryArgs -> KResult -> SockAddr -> m ()
 handleResponse raw result addr = do
   Manager {..} <- getManager
   liftIO $ do
+#ifdef VERSION_bencoding
     let resultId = either errorId respId  result
+#else
+    let resultId = either Tox.msgNonce Tox.msgNonce result
+#endif
     mcall <- unregisterQuery (resultId, addr) pendingCalls
     case mcall of
       Nothing   -> return ()
       Just ares -> putMVar ares (raw,result)
 
-handleMessage :: MonadKRPC h m => BValue -> KMessage -> SockAddr -> m ()
+#ifdef VERSION_bencoding
+handleMessage :: MonadKRPC h m => KQueryArgs -> KMessage -> SockAddr -> m ()
 handleMessage raw (Q q) = handleQuery    raw q
 handleMessage raw (R r) = handleResponse raw (Right r)
 handleMessage raw (E e) = handleResponse raw (Left  e)
+#else
+handleMessage :: MonadKRPC h m => KQueryArgs -> Tox.Message BC.ByteString -> SockAddr -> m ()
+handleMessage raw q | Tox.isQuery q    = handleQuery    raw q
+handleMessage raw r | Tox.isResponse r = handleResponse raw (Right r)
+handleMessage raw e | Tox.isError e    = handleResponse raw (Left  e)
+#endif
 
 listener :: MonadKRPC h m => m ()
 listener = do
@@ -469,9 +558,17 @@ listener = do
   fix $ \again -> do
     (bs, addr) <- liftIO $ do
       handle exceptions $ BS.recvFrom sock (optMaxMsgSize options)
+#ifdef VERSION_bencoding
     case BE.parse bs >>= \r -> (,) r <$> BE.decode bs of
+#else
+    case return bs >>= \r -> (,) r <$> decode bs of
+#endif
       -- TODO ignore unknown messages at all?
+#ifdef VERSION_bencoding
       Left  e       -> liftIO $ sendMessage sock addr $ unknownMessage e
+#else
+      Left  _       -> return () -- TODO TOX send unknownMessage error
+#endif
       Right (raw,m) -> handleMessage raw m addr
     again
   where
diff --git a/src/Network/KRPC/Message.hs b/src/Network/KRPC/Message.hs
index 6f4ae620..d48fa8ac 100644
--- a/src/Network/KRPC/Message.hs
+++ b/src/Network/KRPC/Message.hs
@@ -12,8 +12,10 @@
 --
 --   See <http://www.bittorrent.org/beps/bep_0005.html#krpc-protocol>
 --
+{-# LANGUAGE CPP                    #-}
 {-# LANGUAGE OverloadedStrings      #-}
 {-# LANGUAGE FlexibleContexts       #-}
+{-# LANGUAGE FlexibleInstances      #-}
 {-# LANGUAGE TypeSynonymInstances   #-}
 {-# LANGUAGE MultiParamTypeClasses  #-}
 {-# LANGUAGE FunctionalDependencies #-}
@@ -31,6 +33,11 @@ module Network.KRPC.Message
 
          -- * Query
        , KQuery(..)
+#ifndef VERSION_bencoding
+       , queryArgs
+       , queryMethod
+       , queryId
+#endif
        , MethodName
 
          -- * Response
@@ -39,12 +46,18 @@ module Network.KRPC.Message
 
          -- * Message
        , KMessage (..)
+       , KQueryArgs
+
        ) where
 
 import Control.Applicative
 import Control.Arrow
 import Control.Exception.Lifted as Lifted
+#ifdef VERSION_bencoding
 import Data.BEncode as BE
+#else
+import qualified Data.Tox as Tox
+#endif
 import Data.ByteString as B
 import Data.ByteString.Char8 as BC
 import qualified Data.Serialize as S
@@ -53,15 +66,23 @@ import Data.Typeable
 import Network.Socket (SockAddr (..),PortNumber,HostAddress)
 
 
+#ifdef VERSION_bencoding
 -- | This transaction ID is generated by the querying node and is
 -- echoed in the response, so responses may be correlated with
 -- multiple queries to the same node. The transaction ID should be
 -- encoded as a short string of binary numbers, typically 2 characters
 -- are enough as they cover 2^16 outstanding queries.
 type TransactionId = ByteString
+#else
+type TransactionId = Tox.Nonce24 -- msgNonce
+#endif
 
 unknownTransaction :: TransactionId
+#ifdef VERSION_bencoding
 unknownTransaction = ""
+#else
+unknownTransaction = 0
+#endif
 
 {-----------------------------------------------------------------------
 -- Error messages
@@ -98,13 +119,16 @@ instance Enum ErrorCode where
   toEnum _   = GenericError
   {-# INLINE toEnum #-}
 
+#ifdef VERSION_bencoding
 instance BEncode ErrorCode where
   toBEncode = toBEncode . fromEnum
   {-# INLINE toBEncode #-}
 
   fromBEncode b = toEnum <$> fromBEncode b
   {-# INLINE fromBEncode #-}
+#endif
 
+#ifdef VERSION_bencoding
 -- | Errors are sent when a query cannot be fulfilled. Error message
 --   can be send only from server to client but not in the opposite
 --   direction.
@@ -113,7 +137,10 @@ data KError = KError
   { errorCode    :: !ErrorCode     -- ^ the type of error;
   , errorMessage :: !ByteString    -- ^ human-readable text message;
   , errorId      :: !TransactionId -- ^ match to the corresponding 'queryId'.
-  } deriving (Show, Read, Eq, Ord, Typeable)
+  } deriving ( Show, Eq, Ord, Typeable, Read )
+#else
+type KError = Tox.Message ByteString -- TODO TOX unused
+#endif
 
 -- | Errors, or KRPC message dictionaries with a \"y\" value of \"e\",
 --   contain one additional key \"e\". The value of \"e\" is a
@@ -129,6 +156,7 @@ data KError = KError
 --
 --   > d1:eli201e23:A Generic Error Ocurrede1:t2:aa1:y1:ee
 --
+#ifdef VERSION_bencoding
 instance BEncode KError where
   toBEncode KError {..} = toDict $
        "e" .=! (errorCode, errorMessage)
@@ -142,33 +170,49 @@ instance BEncode KError where
     (code, msg) <- field (req "e")
     KError code msg <$>! "t"
   {-# INLINE fromBEncode #-}
+#endif
 
 instance Exception KError
 
 -- | Received 'queryArgs' or 'respVals' can not be decoded.
 decodeError :: String -> TransactionId -> KError
+#ifdef VERSION_bencoding
 decodeError msg = KError ProtocolError (BC.pack msg)
+#else
+decodeError msg = error "TODO TOX Error packet"
+#endif
 
 -- | A remote node has send some 'KMessage' this node is unable to
 -- decode.
 unknownMessage :: String -> KError
+#ifdef VERSION_bencoding
 unknownMessage msg = KError ProtocolError (BC.pack msg) unknownTransaction
+#else
+unknownMessage msg = error "TODO TOX Protocol error"
+#endif
 
 {-----------------------------------------------------------------------
 -- Query messages
 -----------------------------------------------------------------------}
 
+#ifdef VERSION_bencoding
 type MethodName = ByteString
+type KQueryArgs = BValue
+#else
+type MethodName = Tox.MessageType -- msgType
+type KQueryArgs = ByteString      -- msgPayload
+#endif
 
+#ifdef VERSION_bencoding
 -- | Query used to signal that caller want to make procedure call to
 -- callee and pass arguments in. Therefore query may be only sent from
 -- client to server but not in the opposite direction.
 --
 data KQuery = KQuery
-  { queryArgs   :: !BValue         -- ^ values to be passed to method;
+  { queryArgs   :: !KQueryArgs     -- ^ values to be passed to method;
   , queryMethod :: !MethodName     -- ^ method to call;
   , queryId     :: !TransactionId  -- ^ one-time query token.
-  } deriving (Show, Read, Eq, Ord, Typeable)
+  } deriving ( Show, Eq, Ord, Typeable, Read )
 
 -- | Queries, or KRPC message dictionaries with a \"y\" value of
 -- \"q\", contain two additional keys; \"q\" and \"a\". Key \"q\" has
@@ -193,13 +237,19 @@ instance BEncode KQuery where
     KQuery <$>! "a" <*>! "q" <*>! "t"
   {-# INLINE fromBEncode #-}
 
-newtype ReflectedIP = ReflectedIP SockAddr
-  deriving (Eq, Ord, Show)
-
 instance BEncode ReflectedIP where
   toBEncode (ReflectedIP addr) = BString (encodeAddr addr)
   fromBEncode (BString bs) = ReflectedIP <$> decodeAddr bs
   fromBEncode _            = Left "ReflectedIP should be a bencoded string"
+#else
+type KQuery = Tox.Message KQueryArgs
+queryArgs   = Tox.msgPayload
+queryMethod = Tox.msgType
+queryId     = Tox.msgNonce
+#endif
+
+newtype ReflectedIP = ReflectedIP SockAddr
+  deriving (Eq, Ord, Show)
 
 port16 :: Word16 -> PortNumber
 port16 = fromIntegral
@@ -237,8 +287,9 @@ encodeAddr _ = B.empty
 --
 --   * KResponse can be only sent from server to client.
 --
+#ifdef VERSION_bencoding
 data KResponse = KResponse
-  { respVals :: BValue         -- ^ 'BDict' containing return values;
+  { respVals :: KQueryArgs     -- ^ 'BDict' containing return values;
   , respId   :: TransactionId  -- ^ match to the corresponding 'queryId'.
   , respIP   :: Maybe ReflectedIP
   } deriving (Show, Eq, Ord, Typeable)
@@ -265,11 +316,18 @@ instance BEncode KResponse where
     addr <- optional (field (req "ip"))
     (\r t -> KResponse r t addr) <$>! "r" <*>! "t"
   {-# INLINE fromBEncode #-}
+#else
+type KResponse = Tox.Message KQueryArgs
+respVals       = Tox.msgPayload
+respId         = Tox.msgNonce
+respIP         = Nothing :: Maybe ReflectedIP
+#endif
 
 {-----------------------------------------------------------------------
 -- Summed messages
 -----------------------------------------------------------------------}
 
+#ifdef VERSION_bencoding
 -- | Generic KRPC message.
 data KMessage
   = Q KQuery
@@ -287,3 +345,6 @@ instance BEncode KMessage where
     <|> R <$> fromBEncode b
     <|> E <$> fromBEncode b
     <|> decodingError "KMessage: unknown message or message tag"
+#else
+type KMessage = Tox.Message
+#endif
diff --git a/src/Network/KRPC/Method.hs b/src/Network/KRPC/Method.hs
index 916b38a8..2a791924 100644
--- a/src/Network/KRPC/Method.hs
+++ b/src/Network/KRPC/Method.hs
@@ -7,6 +7,7 @@
 --
 --   Normally, you don't need to import this module.
 --
+{-# LANGUAGE CPP                        #-}
 {-# LANGUAGE RankNTypes                 #-}
 {-# LANGUAGE MultiParamTypeClasses      #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
@@ -17,7 +18,11 @@ module Network.KRPC.Method
        , KRPC (..)
        ) where
 
+#ifdef VERSION_bencoding
 import Data.BEncode (BEncode)
+#else
+import Data.Serialize
+#endif
 import Data.ByteString.Char8 as BC
 import Data.Char
 import Data.Monoid
@@ -38,7 +43,12 @@ import Network.KRPC.Message
 --     * result: Type of return value of the method.
 --
 newtype Method param result = Method { methodName :: MethodName }
-  deriving (Eq, Ord, IsString, BEncode)
+  deriving ( Eq, Ord
+#ifdef VERSION_bencoding
+           , IsString
+           , BEncode
+#endif
+           )
 
 -- | Example:
 --
@@ -49,7 +59,11 @@ instance (Typeable a, Typeable b) => Show (Method a b) where
 
 showsMethod :: forall a b. ( Typeable a , Typeable b ) => Method a b -> ShowS
 showsMethod (Method name) =
+#ifdef VERSION_bencoding
     showString (BC.unpack name) <>
+#else
+    shows (show name) <>
+#endif
     showString " :: " <>
     shows paramsTy <>
     showString " -> " <>
@@ -72,7 +86,13 @@ showsMethod (Method name) =
 --     method = \"ping\"
 --   @
 --
-class (Typeable req, BEncode req, Typeable resp, BEncode resp)
+class ( Typeable req, Typeable resp
+#ifdef VERSION_bencoding
+      , BEncode req, BEncode resp
+#else
+      , Serialize req, Serialize resp
+#endif
+      )
     => KRPC req resp where
 
   -- | Method name. Default implementation uses lowercased @req@
@@ -80,8 +100,10 @@ class (Typeable req, BEncode req, Typeable resp, BEncode resp)
   --
   method :: Method req resp
 
+#ifdef VERSION_bencoding
   -- TODO add underscores
   default method :: Typeable req => Method req resp
   method = Method $ fromString $ L.map toLower $ show $ typeOf hole
     where
       hole = error "krpc.method: impossible" :: req
+#endif