More progress on ToxTransport and related modules.

6 files changed, 283 insertions, 22 deletions

diff --git a/ToxAddress.hs b/ToxAddress.hs
index 08c9031b..a0d5345d 100644
--- a/ToxAddress.hs
+++ b/ToxAddress.hs
@@ -39,6 +39,7 @@ 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.
@@ -74,14 +75,12 @@ instance Ord NodeId where
 zeroID :: NodeId
 zeroID = NodeId $ throwCryptoError $ publicKey $ B.replicate 32 0
 
-{-
 instance Read NodeId where
     readsPrec _ str
         | (bs, xs) <- Base16.decode $ C8.pack str
-        , B.length bs == 32
-                    = [ (NodeId bs, drop 64 str) ]
+        , CryptoPassed pub <- publicKey bs -- B.length bs == 32
+                    = [ (NodeId pub, drop 64 str) ]
         | otherwise = []
--}
 
 instance Show NodeId where
     show (NodeId bs) = C8.unpack $ Base16.encode $ BA.convert bs
diff --git a/ToxCrypto.hs b/ToxCrypto.hs
index 98e02e91..cae7e251 100644
--- a/ToxCrypto.hs
+++ b/ToxCrypto.hs
@@ -17,6 +17,8 @@ module ToxCrypto
     , getRemainingEncrypted
     , putEncrypted
     , Auth
+    , Sized(..)
+    , Size(..)
     ) where
 
 import qualified Crypto.Cipher.Salsa    as Salsa
@@ -81,6 +83,13 @@ instance Sized a => Serialize (Encrypted a) where
             ConstSize n -> Encrypted <$> getBytes (16 + n) -- 16 extra for Poly1305 mac
     put = putEncrypted
 
+instance (Sized a, Sized b) => Sized (a,b) where
+    size = case (size :: Size a, size :: Size b) of
+        (ConstSize a , ConstSize b) -> ConstSize $ a + b
+        (VarSize f   , ConstSize b) -> VarSize $ \(a, _) -> f a + b
+        (ConstSize a , VarSize g)   -> VarSize $ \(_, b) -> a + g b
+        (VarSize f   , VarSize g)   -> VarSize $ \(a, b) -> f a + g b
+
 getRemainingEncrypted :: Get (Encrypted a)
 getRemainingEncrypted = Encrypted <$> (remaining >>= getBytes)
 
diff --git a/ToxPacket.hs b/ToxPacket.hs
index d10a7597..bc20f480 100644
--- a/ToxPacket.hs
+++ b/ToxPacket.hs
@@ -71,6 +71,52 @@ data Assym a = Assym
     , assymData :: a
     }
 
+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/ToxTransport.hs b/ToxTransport.hs
index 1b2bcbe4..a927e55a 100644
--- a/ToxTransport.hs
+++ b/ToxTransport.hs
@@ -2,11 +2,14 @@
 {-# LANGUAGE DataKinds,KindSignatures #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE TupleSections #-}
 module ToxTransport where
 
 import Network.QueryResponse
 import ToxCrypto
-import ToxAddress as Tox hiding (ReturnPath)
+import ToxAddress as Tox hiding (ReturnPath,OnionToOwner)
 import ToxPacket
 
 import Control.Concurrent.STM
@@ -14,9 +17,11 @@ import qualified Data.ByteString as B
          ;import Data.ByteString (ByteString)
 import Data.Word
 import Network.Socket
-import Data.Serialize as S (decode, Serialize, get, put, Get, Put)
+import Data.Serialize as S (decode, Serialize, get, put, Get, Put, runGet)
 import GHC.TypeLits
 import Data.Typeable
+import Control.Applicative
+import Control.Arrow
 
 newtype SymmetricKey = SymmetricKey ByteString
 
@@ -44,6 +49,9 @@ data Message = Todo | DHTReq DHTRequest | AnnounceReq AnnounceRequest
 
 -- awaitMessage :: forall a. (Maybe (Either err (x, addr)) -> IO a) -> IO a
 
+type UDPTransport = Transport String SockAddr ByteString
+
+{-
 toxTransport :: TransportCrypto -> Transport String SockAddr ByteString -> Transport String Tox.Address Message
 toxTransport crypto (Transport await send close) = Transport await' send' close
  where
@@ -51,18 +59,171 @@ toxTransport crypto (Transport await send close) = Transport await' send' close
     await' forMe = fix $ await . handleOnion crypto forMe
 
     send' = _todo
+-}
+toxTransport ::
+      TransportCrypto
+          -> UDPTransport
+          -> IO ( Transport String NodeInfo (DirectMessage Encrypted8)
+                , Transport String OnionToOwner (OnionMessage Encrypted)
+                , Transport String SockAddr ByteString )
+toxTransport crypto udp = do
+    (dht,udp1) <- partitionTransport parseDHTAddr encodeDHTAddr id $ handleOnion crypto udp
+    (onion,udp2) <- partitionTransport parseOnionAddr encodeOnionAddr id udp1
+    return (dht,onion,udp2)
+
 
 type HandleHi a = Maybe (Either String (Message, Tox.Address)) -> IO a
 type HandleLo a = Maybe (Either String (ByteString, SockAddr)) -> IO a
 
+data DirectMessage (f :: * -> *)
+    = DirectPing (Assym (f Ping))
+    | DirectPong (Assym (f Pong))
+    | DirectGetNodes (Assym (f GetNodes))
+    | DirectSendNodes (Assym (f SendNodes))
+    | DirectCookieRequest (Assym (f CookieRequest))
+    | DirectCookie Nonce24 (f Cookie)
+    | DirectDHTRequest 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
+
+getDirect :: Sized a => Get (Assym (Encrypted8 a))
+getDirect = _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)
+                  -> DirectMessage Encrypted8)
+                  -> Either String (DirectMessage Encrypted8, NodeInfo)
+direct bs saddr f = fanGet bs getDirect 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 (DirectMessage 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 DirectPing
+    0x01 -> left $ direct bs saddr DirectPong
+    0x02 -> left $ direct bs saddr DirectGetNodes
+    0x04 -> left $ direct bs saddr DirectSendNodes
+    0x18 -> left $ direct bs saddr DirectCookieRequest
+    0x19 -> left $ fanGet bs getCookie (uncurry DirectCookie) (const $ noReplyAddr saddr)
+    0x20 -> left $ fanGet bs getDHTReqest (uncurry DirectDHTRequest) (asymNodeInfo saddr . snd)
+    _ -> right
+
+encodeDHTAddr :: (DirectMessage Encrypted8,NodeInfo) -> (ByteString, SockAddr)
+encodeDHTAddr = _todo
+
+
+data OnionMessage (f :: * -> *)
+    = OnionAnnounce (Assym (f (AnnounceRequest,Nonce8)))
+    | OnionAnnounceResponse Nonce8 Nonce24 (f AnnounceResponse)
+    | OnionToRoute PublicKey (Assym (f DataToRoute)) -- destination key, aliased Assym
+    | OnionToRouteResponse (Assym (f DataToRoute))
+
+data OnionToOwner = OnionToOwner NodeInfo (ReturnPath 3)
+                  | OnionToMe SockAddr -- SockAddr is immediate peer in route
+
+onionToOwner assym ret3 saddr = do
+    ni <- nodeInfo (NodeId $ senderKey assym) saddr
+    return $ OnionToOwner ni ret3
+
+onion bs saddr getf = do (f,(assym,ret3)) <- runGet ((,) <$> getf <*> getOnionRequest) bs
+                         oaddr <- onionToOwner assym ret3 saddr
+                         return (f assym, oaddr)
+
+parseOnionAddr :: (ByteString, SockAddr) -> Either (OnionMessage Encrypted,OnionToOwner) (ByteString,SockAddr)
+parseOnionAddr (msg,saddr)
+    | Just (typ,bs) <- B.uncons msg
+    , let right = Right (msg,saddr)
+          query = either (const right) Left
+          response = either (const right) (Left . (, OnionToMe saddr))
+    = case typ of
+    0x83 -> query $ onion bs saddr (pure OnionAnnounce)                          -- Announce Request
+    0x85 -> query $ onion bs saddr (OnionToRoute <$> getPublicKey)               -- Onion Data Request
+    0x84 -> response $ runGet (OnionAnnounceResponse <$> get <*> get <*> get) bs -- Announce Response
+    0x86 -> response $ runGet (OnionToRouteResponse <$> getOnionAssym) bs        -- Onion Data Response
+    _ -> right
+
+encodeOnionAddr :: (OnionMessage Encrypted,OnionToOwner) -> (ByteString, SockAddr)
+encodeOnionAddr = _todo
+
+
+data CookieAddress = WithoutCookie NodeInfo
+                                   | CookieAddress Cookie SockAddr
+
+-- Handshake packet:
+--    [uint8_t 26] (0x1a)
+--    [Cookie]
+--    [nonce (24 bytes)]
+--    [Encrypted message containing:
+--        [24 bytes base nonce]
+--        [session public key of the peer (32 bytes)]
+--        [sha512 hash of the entire Cookie sitting outside the encrypted part]
+--        [Other Cookie (used by the other to respond to the handshake packet)]
+--    ]
+
+-- cookie response packet (161 bytes):
+--
+--     [uint8_t 25]
+--     [Random nonce (24 bytes)]
+--     [Encrypted message containing:
+--         [Cookie]
+--         [uint64_t echo id (that was sent in the request)]
+--     ]
+--
+--     Encrypted message is encrypted with the exact same symmetric key as the
+--     cookie request packet it responds to but with a different nonce.
+--     (Encrypted message is encrypted with reqesters's DHT private key,
+--     responders's DHT public key and the nonce.)
+--
+--     Since we don't receive the public key, we will need to lookup the key by
+--     the SockAddr... I don't understand why the CookieResponse message is
+--     special this way.  TODO: implement a multimap (SockAddr -> SharedSecret)
+--     and wrap cookie queries with store/delete.  TODO: Should the entire
+--     SharedScret cache be keyed on only SockAddr ?  Perhaps the secret cache
+--     should be (NodeId -> Secret) and the cookie-request map should be
+--     (SockAddr -> NodeId)
+
 --   Byte value   Packet Kind           Return address
 --  :----------- :--------------------
 --   `0x00`       Ping Request          DHTNode
 --   `0x01`       Ping Response         -
 --   `0x02`       Nodes Request         DHTNode
 --   `0x04`       Nodes Response        -
---   `0x18`       Cookie Request        DHTNode, but without sending pubkey
---   `0x19`       Cookie Response       -
+--   `0x18`       Cookie Request        DHTNode, but without sending pubkey in response
+--   `0x19`       Cookie Response       - (no pubkey)
 --
 --   `0x21`       LAN Discovery         DHTNode (No reply, port 33445, trigger Nodes Request/Response)
 --
@@ -86,19 +247,22 @@ type HandleLo a = Maybe (Either String (ByteString, SockAddr)) -> IO a
 --   `0x8d`       Onion Response 2      -return
 --   `0x8e`       Onion Response 1      -return
 
-handleOnion :: forall a. TransportCrypto -> HandleHi a -> IO a -> HandleLo a
-handleOnion crypto forMe forThem (Just (Right (bs,saddr))) = case B.head bs of
-    0x20 -> forward forMe bs $ handleDHTRequest crypto saddr forMe forThem
-    0x80 -> forward forMe bs $ handleOnionRequest (Proxy :: Proxy 0) crypto saddr forThem
-    0x81 -> forward forMe bs $ handleOnionRequest (Proxy :: Proxy 1) crypto saddr forThem
-    0x82 -> forward forMe bs $ handleOnionRequest (Proxy :: Proxy 2) crypto saddr forThem
-    0x8c -> forward forMe bs $ handleOnionResponse (Proxy :: Proxy 3) crypto saddr forThem
-    0x8d -> forward forMe bs $ handleOnionResponse (Proxy :: Proxy 2) crypto saddr forThem
-    0x8e -> forward forMe bs $ handleOnionResponse (Proxy :: Proxy 1) crypto saddr forThem
-    typ  -> go typ (B.tail bs)
+handleOnion :: TransportCrypto -> UDPTransport -> UDPTransport -- HandleHi a -> IO a -> HandleLo a
+handleOnion crypto udp = udp { awaitMessage = await' }
  where
-    go :: Word8 -> ByteString -> IO a
-    go typ bs = forMe $ Just (parseMessage typ bs)
+    -- forMe :: HandleHi
+    -- forThem :: handleLo
+    await' :: HandleLo a -> IO a
+    await' forThem = awaitMessage udp $ \case
+        m@(Just (Right (bs,saddr))) -> case B.head bs of
+            0x80 -> forward forThem bs $ handleOnionRequest (Proxy :: Proxy 0) crypto saddr (forThem m)
+            0x81 -> forward forThem bs $ handleOnionRequest (Proxy :: Proxy 1) crypto saddr (forThem m)
+            0x82 -> forward forThem bs $ handleOnionRequest (Proxy :: Proxy 2) crypto saddr (forThem m)
+            0x8c -> forward forThem bs $ handleOnionResponse (Proxy :: Proxy 3) crypto saddr (forThem m)
+            0x8d -> forward forThem bs $ handleOnionResponse (Proxy :: Proxy 2) crypto saddr (forThem m)
+            0x8e -> forward forThem bs $ handleOnionResponse (Proxy :: Proxy 1) crypto saddr (forThem m)
+            _    -> forThem m
+        m -> forThem m
 
 forward :: forall c b b1.
           Serialize b =>
@@ -197,3 +361,41 @@ instance S.Serialize AnnounceRequest where
 
 getOnionRequest :: Get (Assym (Encrypted msg), ReturnPath 3)
 getOnionRequest = _todo
+
+data KeyRecord = NotStored    Nonce32
+               | SendBackKey  PublicKey
+               | Acknowledged Nonce32
+
+getPublicKey :: Get PublicKey
+getPublicKey = _todo
+
+putPublicKey :: PublicKey -> Put
+putPublicKey = _todo
+
+instance S.Serialize KeyRecord where
+    get = do
+        is_stored <- S.get :: S.Get Word8
+        case is_stored of
+            1 -> SendBackKey  <$> getPublicKey
+            2 -> Acknowledged <$> S.get
+            _ -> NotStored    <$> S.get
+    put (NotStored n32)    = S.put (0 :: Word8) >> S.put n32
+    put (SendBackKey key)  = S.put (1 :: Word8) >> putPublicKey key
+    put (Acknowledged n32) = S.put (2 :: Word8) >> S.put n32
+
+data AnnounceResponse = AnnounceResponse
+    { is_stored     :: KeyRecord
+    , announceNodes :: SendNodes
+    }
+
+instance Sized AnnounceResponse where
+    size = VarSize $ \AnnounceResponse {} -> _todo
+
+instance S.Serialize AnnounceResponse where
+    get = AnnounceResponse <$> S.get <*> S.get
+    put (AnnounceResponse st ns) = S.put st >> S.put ns
+
+data DataToRoute = DataToRoute
+    { dataFromKey :: PublicKey
+    , dataToRoute :: Encrypted (Word8,ByteString)
+    }
diff --git a/c b/c
index f11856e2..a9d9755a 100755
--- a/c
+++ b/c
@@ -1,5 +1,7 @@
 #!/bin/sh
+compile=ghc
 defs="-DBENCODE_AESON -DTHREAD_DEBUG"
 hide="-hide-package crypto-random -hide-package crypto-api -hide-package crypto-numbers -hide-package cryptohash -hide-package prettyclass"
 cbits="cbits/*.c"
-ghc -fdefer-typed-holes -Wno-typed-holes -freverse-errors $hide -isrc -XOverloadedStrings -XRecordWildCards $defs $cbits "$@"
+# -Wno-typed-holes
+$compile -fdefer-typed-holes -freverse-errors $hide -isrc -XOverloadedStrings -XRecordWildCards $defs $cbits "$@"
diff --git a/ci b/ci
index 0a699757..0b74496b 100755
--- a/ci
+++ b/ci
@@ -1,4 +1,7 @@
 #!/bin/sh
+compile=ghci
 defs="-DBENCODE_AESON -DTHREAD_DEBUG"
 hide="-hide-package crypto-random -hide-package crypto-api -hide-package crypto-numbers -hide-package cryptohash -hide-package prettyclass"
-ghci -freverse-errors $hide -isrc -XOverloadedStrings -XRecordWildCards $defs "$@"
+# cbits="cbits/*.c"
+$compile -fdefer-typed-holes -Wno-typed-holes -freverse-errors $hide -isrc -XOverloadedStrings -XRecordWildCards $defs $cbits "$@"
+