Separated module DHTTransport from ToxTransport.

4 files changed, 209 insertions, 98 deletions

diff --git a/DHTTransport.hs b/DHTTransport.hs
new file mode 100644
index 00000000..6b3af2fc
--- /dev/null
+++ b/DHTTransport.hs
@@ -0,0 +1,177 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE KindSignatures             #-}
+module DHTTransport
+    ( parseDHTAddr
+    , encodeDHTAddr
+    , module ToxAddress
+    , DHTMessage(..)
+    , Ping
+    , Pong
+    , GetNodes
+    , SendNodes
+    , CookieRequest
+    , Cookie
+    , DHTRequest
+    ) where
+
+import ToxAddress
+import ToxCrypto
+
+import Control.Arrow
+import qualified Data.ByteString as B
+         ;import Data.ByteString (ByteString)
+import Data.Serialize            as S (Get, Serialize, get, put, runGet)
+import Data.Word
+import Network.Socket
+
+
+
+data DHTMessage (f :: * -> *)
+    = DHTPing (Assym (f Ping))
+    | DHTPong (Assym (f Pong))
+    | DHTGetNodes (Assym (f GetNodes))
+    | DHTSendNodes (Assym (f SendNodes))
+    | DHTCookieRequest (Assym (f CookieRequest))
+    | DHTCookie Nonce24 (f Cookie)
+    | DHTDHTRequest PublicKey (Assym (f DHTRequest))
+
+instance Sized GetNodes where
+    size = ConstSize 32 -- TODO This right?
+
+instance Sized SendNodes where
+    size = VarSize $ \(SendNodes ns) -> _nodeFormatSize * length ns
+
+instance Sized Ping where size = ConstSize 1
+instance Sized Pong where size = ConstSize 1
+
+parseDHTAddr :: (ByteString, SockAddr) -> Either (DHTMessage Encrypted8,NodeInfo) (ByteString,SockAddr)
+parseDHTAddr (msg,saddr)
+    | Just (typ,bs) <- B.uncons msg
+    , let right = Right (msg,saddr)
+          left  = either (const right) Left
+    = case typ of
+    0x00 -> left $ direct bs saddr DHTPing
+    0x01 -> left $ direct bs saddr DHTPong
+    0x02 -> left $ direct bs saddr DHTGetNodes
+    0x04 -> left $ direct bs saddr DHTSendNodes
+    0x18 -> left $ direct bs saddr DHTCookieRequest
+    0x19 -> left $ fanGet bs getCookie (uncurry DHTCookie) (const $ noReplyAddr saddr)
+    0x20 -> left $ fanGet bs getDHTReqest (uncurry DHTDHTRequest) (asymNodeInfo saddr . snd)
+    _ -> right
+
+encodeDHTAddr :: (DHTMessage Encrypted8,NodeInfo) -> (ByteString, SockAddr)
+encodeDHTAddr = _todo
+
+getCookie :: Get (Nonce24, Encrypted8 Cookie)
+getCookie = get
+
+getDHTReqest :: Get (PublicKey, Assym (Encrypted8 DHTRequest))
+getDHTReqest = _todo
+
+getDHT :: Sized a => Get (Assym (Encrypted8 a))
+getDHT = _todo
+
+
+-- Throws an error if called with a non-internet socket.
+direct :: Sized a => ByteString
+                  -> SockAddr
+                  -> (Assym (Encrypted8 a)
+                  -> DHTMessage Encrypted8)
+                  -> Either String (DHTMessage Encrypted8, NodeInfo)
+direct bs saddr f = fanGet bs getDHT f (asymNodeInfo saddr)
+
+-- Throws an error if called with a non-internet socket.
+asymNodeInfo saddr asym = either (error . mappend "asymNodeInfo: ") id $ nodeInfo (NodeId $ senderKey asym) saddr
+
+
+fanGet :: ByteString -> Get x -> (x -> a) -> (x -> b) -> Either String (a,b)
+fanGet bs getIt f nid = fmap (f &&& nid) $ runGet getIt bs
+
+-- Throws an error if called with a non-internet socket.
+noReplyAddr saddr = either (error . mappend "noReplyAddr: ") id $ nodeInfo zeroID saddr
+
+
+-- ## DHT Request packets
+--
+-- | Length | Contents                  |
+-- |:-------|:--------------------------|
+-- | `1`    | `uint8_t` (0x20)          |
+-- | `32`   | receiver's DHT public key |
+--   ...      ...
+
+data DHTRequestPacket = DHTRequestPacket
+    { requestTarget :: PublicKey
+    , request       :: Assym (Encrypted DHTRequest)
+    }
+
+instance Serialize DHTRequestPacket where
+    get = _todo
+    put = _todo
+
+
+data DHTRequest
+    = NATPing Nonce8
+    | NATPong Nonce8
+    | DHTPK DHTPublicKey
+
+-- | Length      | Contents                            |
+-- |:------------|:------------------------------------|
+-- | `1`         | `uint8_t` (0x9c)                    |
+-- | `8`         | `uint64_t` `no_replay`              |
+-- | `32`        | Our DHT public key                  |
+-- | `[39, 204]` | Maximum of 4 nodes in packed format |
+data DHTPublicKey = DHTPublicKey
+    { dhtpkNonce :: Nonce8
+    , dhtpk :: PublicKey
+    , dhtpkNodes :: SendNodes
+    }
+
+newtype GetNodes = GetNodes NodeId
+    deriving (Eq,Ord,Show,Read,S.Serialize)
+
+newtype SendNodes = SendNodes [NodeInfo]
+    deriving (Eq,Ord,Show,Read)
+
+instance S.Serialize SendNodes where
+    get = do
+        cnt <- S.get :: S.Get Word8
+        ns <- sequence $ replicate (fromIntegral cnt) S.get
+        return $ SendNodes ns
+
+    put (SendNodes ns) = do
+        let ns' = take 4 ns
+        S.put (fromIntegral (length ns') :: Word8)
+        mapM_ S.put ns'
+
+data Ping = Ping deriving Show
+data Pong = Pong deriving Show
+
+instance S.Serialize Ping where
+    get = do w8 <- S.get
+             if (w8 :: Word8) /= 0
+                then fail "Malformed ping."
+                else return Ping
+    put Ping = S.put (0 :: Word8)
+
+instance S.Serialize Pong where
+    get = do w8 <- S.get
+             if (w8 :: Word8) /= 1
+                then fail "Malformed pong."
+                else return Pong
+    put Pong = S.put (1 :: Word8)
+
+newtype CookieRequest = CookieRequest PublicKey
+newtype CookieResponse = CookieResponse Cookie
+
+data Cookie = Cookie Nonce24 (Encrypted CookieData)
+
+instance Sized Cookie where size = ConstSize 112 -- 24 byte nonce + 88 byte cookie data
+
+data CookieData = CookieData   --   16 (mac)
+    { cookieTime  :: Word64    --    8
+    , longTermKey :: PublicKey --   32
+    , dhtKey      :: PublicKey -- + 32
+    }                          -- = 88 bytes when encrypted.
+
+instance Sized CookieRequest where
+    size = ConstSize 64 -- 32 byte key + 32 byte padding
diff --git a/ToxAddress.hs b/ToxAddress.hs
index a0d5345d..9aa7a575 100644
--- a/ToxAddress.hs
+++ b/ToxAddress.hs
@@ -13,16 +13,18 @@
 {-# LANGUAGE ScopedTypeVariables        #-}
 {-# LANGUAGE TupleSections              #-}
 {-# LANGUAGE TypeApplications           #-}
-module ToxAddress where
+module ToxAddress (NodeInfo(..),NodeId(..),nodeInfo) where
 
 import Control.Applicative
 import Control.Monad
+import Crypto.Error.Types                     (CryptoFailable (..),
+                                               throwCryptoError)
+import Crypto.PubKey.Curve25519
 import qualified Data.Aeson                   as JSON
          ;import Data.Aeson                   (FromJSON, ToJSON, (.=))
-import Data.Bits
 import Data.Bits.ByteString                   ()
-import Data.ByteArray                         as BA (ByteArrayAccess, Bytes)
-import qualified Data.ByteArray as BA
+import qualified Data.ByteArray               as BA
+         ;import Data.ByteArray               as BA (ByteArrayAccess)
 import qualified Data.ByteString              as B
          ;import Data.ByteString              (ByteString)
 import qualified Data.ByteString.Base16       as Base16
@@ -33,18 +35,12 @@ import Data.Hashable
 import Data.IP
 import Data.Serialize                         as S
 import Data.Word
+import Foreign.Storable
+import GHC.TypeLits
 import Network.Address                        hiding (nodePort)
-import Network.Socket
+import System.IO.Unsafe                       (unsafeDupablePerformIO)
 import qualified Text.ParserCombinators.ReadP as RP
 import Text.Read
-import GHC.TypeLits
-import Crypto.PubKey.Curve25519
-import Crypto.Error.Types (CryptoFailable(..))
-
-data Address
- = DHTNode        NodeInfo                 -- A direct DHT exchange.
- | OnionFromOwner NodeInfo (ForwardPath 3) -- Your own created onion path.
- | OnionToOwner   NodeInfo (ReturnPath 3)  -- An onion path end point.
 
 -- | perform io for hashes that do allocation and ffi.
 -- unsafeDupablePerformIO is used when possible as the
@@ -363,14 +359,6 @@ zeroID = PubKey $ B.replicate 32 0
 
 -}
 
-newtype ReturnPath (n::Nat) = ReturnPath ByteString
- deriving (Eq, Ord,Data)
-
-instance KnownNat n => Serialize (ReturnPath n) where
-    -- Size: 59 = 1(family) + 16(ip) + 2(port) +16(mac) + 24(nonce)
-    get = ReturnPath <$> getBytes ( 59 * (fromIntegral $ natVal $ Proxy @n) )
-    put (ReturnPath bs) = putByteString bs
-
 newtype ForwardPath (n::Nat) = ForwardPath ByteString
  deriving (Eq, Ord,Data)
 
diff --git a/ToxCrypto.hs b/ToxCrypto.hs
index cae7e251..6f0fcf1a 100644
--- a/ToxCrypto.hs
+++ b/ToxCrypto.hs
@@ -7,6 +7,8 @@ module ToxCrypto
     , publicKey
     , SecretKey
     , Encrypted
+    , Encrypted8
+    , Assym(..)
     , Plain
     , computeSharedSecret
     , encrypt
@@ -47,6 +49,10 @@ import qualified Data.ByteString.Internal
 newtype Encrypted a = Encrypted ByteString
  deriving (Eq,Ord,Data)
 
+newtype Encrypted8 a = E8 (Encrypted (a,Nonce8))
+ deriving Serialize
+
+
 newtype Auth = Auth Poly1305.Auth deriving (Eq, ByteArrayAccess)
 instance Ord Auth where
     compare (Auth a) (Auth b) = comparing (BA.convert :: Poly1305.Auth -> Bytes) a b
@@ -210,3 +216,13 @@ zeros32 = Nonce32 $ BA.replicate 32 0
 
 zeros24 :: ByteString
 zeros24 = BA.take 24 zs where Nonce32 zs = zeros32
+
+-- | `32`   | sender's DHT public key   |
+-- | `24`   | nonce                     |
+-- | `?`    | encrypted message         |
+data Assym a = Assym
+    { senderKey :: PublicKey
+    , assymNonce :: Nonce24
+    , assymData :: a
+    }
+
diff --git a/ToxTransport.hs b/ToxTransport.hs
index 694d9d79..3e442d49 100644
--- a/ToxTransport.hs
+++ b/ToxTransport.hs
@@ -15,16 +15,6 @@ module ToxTransport
 
     , UDPTransport
 
-    -- DHTTransport
-    , DHTMessage(..)
-    , Ping
-    , Pong
-    , GetNodes
-    , SendNodes
-    , CookieRequest
-    , Cookie
-    , DHTRequest
-
     -- OnionTransport
     , OnionToOwner(..)
     , OnionMessage(..)
@@ -48,9 +38,8 @@ module ToxTransport
     ) where
 
 import Network.QueryResponse
-import ToxAddress            as Tox hiding (OnionToOwner, ReturnPath)
 import ToxCrypto
-import ToxPacket
+import DHTTransport
 
 import Control.Applicative
 import Control.Arrow
@@ -98,76 +87,11 @@ toxTransport crypto closeLookup udp = do
 type HandleHi a = Maybe (Either String (DHTMessage Encrypted8, NodeInfo)) -> IO a
 type HandleLo a = Maybe (Either String (ByteString, SockAddr)) -> IO a
 
-data DHTMessage (f :: * -> *)
-    = DHTPing (Assym (f Ping))
-    | DHTPong (Assym (f Pong))
-    | DHTGetNodes (Assym (f GetNodes))
-    | DHTSendNodes (Assym (f SendNodes))
-    | DHTCookieRequest (Assym (f CookieRequest))
-    | DHTCookie Nonce24 (f Cookie)
-    | DHTDHTRequest PublicKey (Assym (f DHTRequest))
-
-instance Sized GetNodes where
-    size = ConstSize 32 -- TODO This right?
-
-instance Sized SendNodes where
-    size = VarSize $ \(SendNodes ns) -> _nodeFormatSize * length ns
-
-instance Sized Ping where size = ConstSize 1
-instance Sized Pong where size = ConstSize 1
-
-newtype Encrypted8 a = E8 (Encrypted (a,Nonce8))
- deriving Serialize
-
 -- instance (Sized a, Sized b) => Sized (a,b) where size = _todo
 
-getDHT :: Sized a => Get (Assym (Encrypted8 a))
-getDHT = _todo
-
 getOnionAssym :: Get (Assym (Encrypted DataToRoute))
 getOnionAssym = _todo
 
-getCookie :: Get (Nonce24, Encrypted8 Cookie)
-getCookie = get
-
-getDHTReqest :: Get (PublicKey, Assym (Encrypted8 DHTRequest))
-getDHTReqest = _todo
-
-fanGet :: ByteString -> Get x -> (x -> a) -> (x -> b) -> Either String (a,b)
-fanGet bs getIt f nid = fmap (f &&& nid) $ runGet getIt bs
-
--- Throws an error if called with a non-internet socket.
-direct :: Sized a => ByteString
-                  -> SockAddr
-                  -> (Assym (Encrypted8 a)
-                  -> DHTMessage Encrypted8)
-                  -> Either String (DHTMessage Encrypted8, NodeInfo)
-direct bs saddr f = fanGet bs getDHT f (asymNodeInfo saddr)
-
--- Throws an error if called with a non-internet socket.
-asymNodeInfo saddr asym = either (error . mappend "asymNodeInfo: ") id $ nodeInfo (NodeId $ senderKey asym) saddr
-
--- Throws an error if called with a non-internet socket.
-noReplyAddr saddr = either (error . mappend "noReplyAddr: ") id $ nodeInfo zeroID saddr
-
-parseDHTAddr :: (ByteString, SockAddr) -> Either (DHTMessage Encrypted8,NodeInfo) (ByteString,SockAddr)
-parseDHTAddr (msg,saddr)
-    | Just (typ,bs) <- B.uncons msg
-    , let right = Right (msg,saddr)
-          left  = either (const right) Left
-    = case typ of
-    0x00 -> left $ direct bs saddr DHTPing
-    0x01 -> left $ direct bs saddr DHTPong
-    0x02 -> left $ direct bs saddr DHTGetNodes
-    0x04 -> left $ direct bs saddr DHTSendNodes
-    0x18 -> left $ direct bs saddr DHTCookieRequest
-    0x19 -> left $ fanGet bs getCookie (uncurry DHTCookie) (const $ noReplyAddr saddr)
-    0x20 -> left $ fanGet bs getDHTReqest (uncurry DHTDHTRequest) (asymNodeInfo saddr . snd)
-    _ -> right
-
-encodeDHTAddr :: (DHTMessage Encrypted8,NodeInfo) -> (ByteString, SockAddr)
-encodeDHTAddr = _todo
-
 
 data OnionMessage (f :: * -> *)
     = OnionAnnounce (Assym (f (AnnounceRequest,Nonce8)))
@@ -396,6 +320,12 @@ data ReturnPath (n :: Nat) where
     NoReturnPath :: ReturnPath 0
     ReturnPath :: Nonce24 -> Encrypted (Addressed (ReturnPath n)) -> ReturnPath (n + 1)
 
+-- instance KnownNat n => Serialize (ReturnPath n) where
+--     -- Size: 59 = 1(family) + 16(ip) + 2(port) +16(mac) + 24(nonce)
+--     get = ReturnPath <$> getBytes ( 59 * (fromIntegral $ natVal $ Proxy @n) )
+--     put (ReturnPath bs) = putByteString bs
+
+
 data Forwarding (n :: Nat) msg where
     NotForwarded :: msg -> Forwarding 0 msg
     Forwarding :: Assym (Encrypted (Addressed (Forwarding n msg))) -> Forwarding (n + 1) msg