From 2d0d30e70bea230ede343bd1cc2700b11becb494 Mon Sep 17 00:00:00 2001 From: joe Date: Wed, 30 Aug 2017 06:17:23 -0400 Subject: More progress on ToxTransport and related modules. --- ToxAddress.hs | 7 +- ToxCrypto.hs | 9 +++ ToxPacket.hs | 46 +++++++++++ ToxTransport.hs | 234 ++++++++++++++++++++++++++++++++++++++++++++++++++++---- c | 4 +- ci | 5 +- 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 "$@" + -- cgit v1.2.3