{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} module Tox where import Control.Applicative import Control.Arrow import Control.Concurrent (MVar) import Control.Concurrent.STM import qualified Crypto.Cipher.Salsa as Salsa import qualified Crypto.Cipher.XSalsa as XSalsa import Crypto.ECC.Class import qualified Crypto.Error as Cryptonite import Crypto.Error.Types import qualified Crypto.MAC.Poly1305 as Poly1305 import Crypto.PubKey.Curve25519 import Crypto.PubKey.ECC.Types import Crypto.Random import Data.Bool import qualified Data.ByteArray as BA ;import Data.ByteArray (ByteArrayAccess,Bytes) import qualified Data.ByteString as B ;import Data.ByteString (ByteString) import qualified Data.ByteString.Base16 as Base16 import qualified Data.ByteString.Char8 as C8 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 import Data.Word import Foreign.Marshal.Alloc import Foreign.Ptr import Foreign.Storable import GHC.Generics (Generic) import Network.Address (Address, fromSockAddr, sockAddrPort, testIdBit, toSockAddr, setPort, un4map, WantIP(..), ipFamily, either4or6) import Network.QueryResponse import Network.Socket import System.Endian import Data.Hashable import Data.Bits import Data.Bits.ByteString () import qualified Text.ParserCombinators.ReadP as RP import Data.Char import TriadCommittee import qualified Network.DHT.Routing as R import qualified Data.Wrapper.PSQInt as Int import Data.Time.Clock.POSIX (POSIXTime) import Global6 import Data.Ord import System.IO import qualified Data.Aeson as JSON ;import Data.Aeson (FromJSON, ToJSON, (.=)) import Control.Monad import Text.Read import Kademlia import Network.BitTorrent.DHT.Search (Search (..)) import Text.Printf import qualified Crypto.Cipher.ChaChaPoly1305 as Symmetric import Data.Bitraversable (bisequence) newtype NodeId = NodeId ByteString deriving (Eq,Ord,ByteArrayAccess, Bits, Hashable) instance Show NodeId where show (NodeId bs) = C8.unpack $ Base16.encode bs instance S.Serialize NodeId where get = NodeId <$> S.getBytes 32 put (NodeId bs) = S.putByteString bs instance FiniteBits NodeId where finiteBitSize _ = 256 instance Read NodeId where readsPrec _ str | (bs, xs) <- Base16.decode $ C8.pack str , B.length bs == 32 = [ (NodeId bs, drop 64 str) ] | otherwise = [] zeroID :: NodeId zeroID = NodeId $ B.replicate 32 0 data NodeInfo = NodeInfo { nodeId :: NodeId , nodeIP :: IP , nodePort :: PortNumber } deriving (Eq,Ord) instance ToJSON NodeInfo where toJSON (NodeInfo nid (IPv4 ip) port) = JSON.object [ "public_key" .= show nid , "ipv4" .= show ip , "port" .= (fromIntegral port :: Int) ] toJSON (NodeInfo nid (IPv6 ip6) port) | Just ip <- un4map ip6 = JSON.object [ "public_key" .= show nid , "ipv4" .= show ip , "port" .= (fromIntegral port :: Int) ] | otherwise = JSON.object [ "public_key" .= show nid , "ipv6" .= show ip6 , "port" .= (fromIntegral port :: Int) ] instance FromJSON NodeInfo where parseJSON (JSON.Object v) = do nidstr <- v JSON..: "public_key" ip6str <- v JSON..:? "ipv6" ip4str <- v JSON..:? "ipv4" portnum <- v JSON..: "port" ip <- maybe empty (return . IPv6) (ip6str >>= readMaybe) <|> maybe empty (return . IPv4) (ip4str >>= readMaybe) let (bs,_) = Base16.decode (C8.pack nidstr) guard (B.length bs == 32) return $ NodeInfo (NodeId bs) ip (fromIntegral (portnum :: Word16)) getIP :: Word8 -> S.Get IP getIP 0x02 = IPv4 <$> S.get getIP 0x0a = IPv6 <$> S.get getIP 0x82 = IPv4 <$> S.get -- TODO: TCP getIP 0x8a = IPv6 <$> S.get -- TODO: TCP getIP x = fail ("unsupported address family ("++show x++")") instance S.Serialize NodeInfo where get = do addrfam <- S.get :: S.Get Word8 ip <- getIP addrfam port <- S.get :: S.Get PortNumber nid <- S.get return $ NodeInfo nid ip port put (NodeInfo nid ip port) = do case ip of IPv4 ip4 -> S.put (2 :: Word8) >> S.put ip4 IPv6 ip6 -> S.put (10 :: Word8) >> S.put ip6 S.put port S.put nid -- node format: -- [uint8_t family (2 == IPv4, 10 == IPv6, 130 == TCP IPv4, 138 == TCP IPv6)] -- [ip (in network byte order), length=4 bytes if ipv4, 16 bytes if ipv6] -- [port (in network byte order), length=2 bytes] -- [char array (node_id), length=32 bytes] -- hexdigit :: Char -> Bool hexdigit c = ('0' <= c && c <= '9') || ( 'a' <= c && c <= 'f') || ( 'A' <= c && c <= 'F') instance Read NodeInfo where readsPrec i = RP.readP_to_S $ do RP.skipSpaces let n = 64 -- characters in node id. parseAddr = RP.between (RP.char '(') (RP.char ')') (RP.munch (/=')')) RP.+++ RP.munch (not . isSpace) nodeidAt = do hexhash <- sequence $ replicate n (RP.satisfy hexdigit) RP.char '@' RP.+++ RP.satisfy isSpace addrstr <- parseAddr nid <- case Base16.decode $ C8.pack hexhash of (bs,_) | B.length bs==32 -> return (NodeId bs) _ -> fail "Bad node id." return (nid,addrstr) (nid,addrstr) <- ( nodeidAt RP.+++ ( (zeroID,) <$> parseAddr) ) let raddr = do ip <- RP.between (RP.char '[') (RP.char ']') (IPv6 <$> RP.readS_to_P (readsPrec i)) RP.+++ (IPv4 <$> RP.readS_to_P (readsPrec i)) _ <- RP.char ':' port <- toEnum <$> RP.readS_to_P (readsPrec i) return (ip, port) (ip,port) <- case RP.readP_to_S raddr addrstr of [] -> fail "Bad address." ((ip,port),_):_ -> return (ip,port) return $ NodeInfo nid ip port -- The Hashable instance depends only on the IP address and port number. instance Hashable NodeInfo where hashWithSalt s ni = hashWithSalt s (nodeIP ni , nodePort ni) {-# INLINE hashWithSalt #-} instance Show NodeInfo where showsPrec _ (NodeInfo nid ip port) = shows nid . ('@' :) . showsip . (':' :) . shows port where showsip | IPv4 ip4 <- ip = shows ip4 | IPv6 ip6 <- ip , Just ip4 <- un4map ip6 = shows ip4 | otherwise = ('[' :) . shows ip . (']' :) nodeAddr :: NodeInfo -> SockAddr nodeAddr (NodeInfo _ ip port) = setPort port $ toSockAddr ip nodeInfo :: NodeId -> SockAddr -> Either String NodeInfo nodeInfo nid saddr | Just ip <- fromSockAddr saddr , Just port <- sockAddrPort saddr = Right $ NodeInfo nid ip port | otherwise = Left "Address family not supported." data TransactionId = TransactionId { transactionKey :: Nonce8 -- ^ Used to lookup pending query. , cryptoNonce :: Nonce24 -- ^ Used during the encryption layer. } -- https://toktok.ltd/spec#packet-kind -- calls this "Packet Kind" newtype Method = MessageType Word8 deriving (Eq, Ord, S.Serialize) pattern PingType = MessageType 0 -- 0x00 Ping Request pattern PongType = MessageType 1 -- 0x01 Ping Response pattern GetNodesType = MessageType 2 -- 0x02 Nodes Request pattern SendNodesType = MessageType 4 -- 0x04 Nodes Response -- 0x18 Cookie Request -- 0x19 Cookie Response -- 0x1a Crypto Handshake -- 0x1b Crypto Data -- TODO: Auth fail: pattern DHTRequestType = MessageType 32 -- 0x20 DHT Request -- 0x21 LAN Discovery -- TODO: Auth fail: pattern OnionRequest0 = MessageType 128 -- 0x80 Onion Request 0 pattern OnionRequest1 = MessageType 129 -- 0x81 Onion Request 1 pattern OnionRequest2 = MessageType 130 -- 0x82 Onion Request 2 pattern AnnounceType = MessageType 131 -- 0x83 Announce Request -- 0x84 Announce Response -- 0x85 Onion Data Request (data to route request packet) -- 0x86 Onion Data Response (data to route response packet) -- 0x8c Onion Response 3 -- 0x8d Onion Response 2 pattern OnionResponse1 = MessageType 142 -- 0x8e Onion Response 1 -- 0xf0 Bootstrap Info -- TODO Fix these fails... -- GetNodesType decipherAndAuth: auth fail -- MessageType 128 decipherAndAuth: auth fail -- MessageType 129 decipherAndAuth: auth fail -- MessageType 130 decipherAndAuth: auth fail -- MessageType 131 decipherAndAuth: auth fail -- MessageType 32 decipherAndAuth: auth fail instance Show Method where showsPrec d PingType = mappend "PingType" showsPrec d PongType = mappend "PongType" showsPrec d GetNodesType = mappend "GetNodesType" showsPrec d SendNodesType = mappend "SendNodesType" showsPrec d DHTRequestType = mappend "DHTRequestType" showsPrec d OnionRequest0 = mappend "OnionRequest0" showsPrec d OnionResponse1 = mappend "OnionResponse1" showsPrec d AnnounceType = mappend "AnnounceType" showsPrec d (MessageType x) = mappend "MessageType " . showsPrec (d+1) x newtype Nonce8 = Nonce8 Word64 deriving (Eq, Ord) instance ByteArrayAccess Nonce8 where length _ = 8 withByteArray (Nonce8 w64) kont = allocaBytes 8 $ \p -> do poke (castPtr p :: Ptr Word64) $ toBE64 w64 kont p instance Show Nonce8 where showsPrec d nonce = quoted (mappend $ bin2hex nonce) newtype Nonce24 = Nonce24 ByteString deriving (Eq, Ord, ByteArrayAccess) instance Show Nonce24 where showsPrec d nonce = quoted (mappend $ bin2hex nonce) instance S.Serialize Nonce24 where get = Nonce24 <$> S.getBytes 24 put (Nonce24 bs) = S.putByteString bs quoted :: ShowS -> ShowS quoted shows s = '"':shows ('"':s) bin2hex :: ByteArrayAccess bs => bs -> String bin2hex = C8.unpack . Base16.encode . BA.convert newtype SymmetricCiphered = SymmetricCiphered ByteString deriving (Eq,Show) data Message a = Message { msgType :: Method , msgOrigin :: NodeId , msgNonce :: Nonce24 -- cryptoNonce of TransactionId , msgReturnPath :: Maybe SymmetricCiphered , msgPayload :: a } deriving (Eq, Show, Generic, Functor, Foldable, Traversable) typeHasEncryptedPayload OnionResponse1 = False typeHasEncryptedPayload _ = True msgDHTKey Message{ msgOrigin, msgType = PingType } = Just msgOrigin msgDHTKey Message{ msgOrigin, msgType = PongType } = Just msgOrigin msgDHTKey Message{ msgOrigin, msgType = GetNodesType } = Just msgOrigin msgDHTKey Message{ msgOrigin, msgType = SendNodesType } = Just msgOrigin msgDHTKey Message{ msgOrigin, msgType = OnionRequest0 } = Just msgOrigin msgDHTKey _ = Nothing data Ciphered = Ciphered { cipheredMAC :: Poly1305.Auth , cipheredBytes :: ByteString } deriving Eq newtype OnionPayload = OnionPayload { unpackOnionPayload :: ByteString } instance S.Serialize OnionPayload where get = OnionPayload <$> (S.remaining >>= S.getBytes) put (OnionPayload bs) = S.putByteString bs getMessage :: S.Get (Message (Either OnionPayload Ciphered)) getMessage = do typ <- S.get (nid,nonce) <- case typ of -- Seriously... what the fuck? DHTRequestType -> do S.skip 32 -- TODO: get destination key -- If it is ours, decrypt and handle. -- If not ours, search routing table and forward if it's in there. flip (,) <$> S.get <*> S.get OnionRequest0 -> flip (,) <$> S.get <*> S.get OnionRequest1 -> flip (,) <$> S.get <*> S.get -- OnionRequest2 -> flip (,) <$> S.get <*> S.get AnnounceType -> flip (,) <$> S.get <*> S.get OnionResponse1 -> (NodeId $ BA.convert zeros32,) <$> S.get -- XXX: no msgOrigin! _ -> (,) <$> S.get <*> S.get (payload,rpath) <- case typ of OnionResponse1 -> do rpath <- Just . SymmetricCiphered <$> S.getBytes (16 + 19) payload <- Left . OnionPayload <$> (S.remaining >>= S.getBytes) return (payload,rpath) _ -> do payload <- Right <$> getCiphered return (payload,Nothing) return Message { msgType = typ , msgOrigin = nid , msgNonce = nonce , msgReturnPath = rpath , msgPayload = payload } putOnionPayload :: OnionPayload -> S.Put putOnionPayload (OnionPayload bs) = S.putByteString bs putMessage :: Message (Either OnionPayload Ciphered) -> S.Put putMessage (Message {..}) = do S.put msgType case msgType of -- Seriously... what the fuck? DHTRequestType -> S.put msgNonce >> S.put msgOrigin OnionRequest0 -> S.put msgNonce >> S.put msgOrigin OnionRequest1 -> S.put msgNonce >> S.put msgOrigin -- OnionRequest2 -> S.put msgNonce >> S.put msgOrigin AnnounceType -> S.put msgNonce >> S.put msgOrigin _ -> S.put msgOrigin >> S.put msgNonce let putPayload = either putOnionPayload putCiphered msgPayload putReturnPath = forM_ msgReturnPath $ \(SymmetricCiphered bs) -> S.putByteString bs case msgType of OnionResponse1 -> putReturnPath >> putPayload _ -> putPayload >> putReturnPath {- data Plain a = Plain { plainId :: Nonce8 -- transactionKey of TransactionId , plainPayload :: a } deriving (Eq, Show, Generic, Functor, Foldable, Traversable) instance Serialize a => Serialize (Plain a) where get = flip Plain <$> get get put (Plain tid a) = put a >> put tid -} -- TODO: Cache shared symmetric keys. data SecretsCache = SecretsCache newEmptyCache = return SecretsCache id2key :: NodeId -> PublicKey id2key recipient = case publicKey recipient of CryptoPassed key -> key -- This should never happen because a NodeId is 32 bytes. CryptoFailed e -> error ("Unexpected pattern fail: "++show e) key2id :: PublicKey -> NodeId key2id pk = case S.decode (BA.convert pk) of Left _ -> error "key2id" Right nid -> nid zeros32 :: Bytes zeros32 = BA.replicate 32 0 zeros24 :: Bytes zeros24 = BA.take 24 zeros32 hsalsa20 k n = a <> b where Salsa.State st = XSalsa.initialize 20 k n (_, as) = BA.splitAt 4 st (a, xs) = BA.splitAt 16 as (_, bs) = BA.splitAt 24 xs (b, _ ) = BA.splitAt 16 bs computeSharedSecret :: SecretKey -> NodeId -> Nonce24 -> (Poly1305.State, XSalsa.State) computeSharedSecret sk recipient nonce = (hash, crypt) where -- diffie helman shared = ecdh (Proxy :: Proxy Curve_X25519) sk (id2key recipient) -- shared secret XSalsa key k = hsalsa20 shared zeros24 -- cipher state st0 = XSalsa.initialize 20 k nonce -- Poly1305 key (rs, crypt) = XSalsa.combine st0 zeros32 -- Since rs is 32 bytes, this pattern should never fail... Cryptonite.CryptoPassed hash = Poly1305.initialize rs encryptMessage :: SecretKey -> SecretsCache -> NodeId -> Message ByteString -> Message (Either OnionPayload Ciphered) encryptMessage sk _ recipient plaintext = if typeHasEncryptedPayload (msgType plaintext) then Right . withSecret encipherAndHash sk recipient (msgNonce plaintext) <$> plaintext else Left . OnionPayload <$> plaintext decryptMessage :: SecretKey -> SecretsCache -> Message Ciphered -> Either String (Message ByteString) decryptMessage sk _ ciphertext = mapM (withSecret decipherAndAuth sk (msgOrigin ciphertext) (msgNonce ciphertext)) ciphertext withSecret f sk recipient nonce x = f hash crypt x where (hash, crypt) = computeSharedSecret sk recipient nonce -- Encrypt-then-Mac: Encrypt the cleartext, then compute the MAC on the -- ciphertext, and prepend it to the ciphertext encipherAndHash :: Poly1305.State -> XSalsa.State -> ByteString -> Ciphered encipherAndHash hash crypt m = Ciphered a c where c = fst . XSalsa.combine crypt $ m a = Poly1305.finalize . Poly1305.update hash $ c decipherAndAuth :: Poly1305.State -> XSalsa.State -> Ciphered -> Either String ByteString decipherAndAuth hash crypt (Ciphered mac c) | (a == mac) = Right m | otherwise = Left "decipherAndAuth: auth fail" where m = fst . XSalsa.combine crypt $ c a = Poly1305.finalize . Poly1305.update hash $ c nibble :: Word8 -> Char nibble b = intToDigit (fromIntegral (b .&. 0x0F)) xxd :: Int -> ByteString -> [String] xxd offset bs | B.null bs = [] xxd offset bs = printf "%03x: %s" offset ds : xxd (offset + B.length xs) bs' where ds = unwords $ map (\byte -> [nibble (byte `shiftR` 4), nibble byte]) $ B.unpack xs (xs,bs') = B.splitAt 16 bs showPayloadError ciphered naddr flow err = unlines (map (prefix ++) xs) where xs = unwords [show (msgType ciphered), err] : xxd 0 (BA.convert mac <> ciphertext) Message { msgPayload = Ciphered (Poly1305.Auth mac) ciphertext } = ciphered prefix = show naddr <> flow showParseError bs addr err = unlines $ concat [ either show show (either4or6 addr), " --> ", err ] : xxd 0 bs unzipMessage :: Message (Either a b) -> Either (Message a) (Message b) unzipMessage msg = either (\x -> Left msg { msgPayload = x }) (\y -> Right msg { msgPayload = y }) (msgPayload msg) -- TODO: -- Represents the encrypted portion of a Tox packet. -- data Payload a = Payload a !Nonce8 -- -- Generic packet type: Message (Payload ByteString) parsePacket :: SecretKey -> SecretsCache -> ByteString -> SockAddr -> Either String (Message ByteString, NodeInfo) parsePacket sk cache bs addr = left (showParseError bs addr) $ do msg <- S.runGet getMessage bs ni <- nodeInfo (msgOrigin msg) addr let decrypt ciphered = left (showPayloadError ciphered ni " --> ") $ do msg <- decryptMessage sk cache ciphered return (msg, ni) passthrough onion = return (unpackOnionPayload <$> onion, ni) either passthrough decrypt $ unzipMessage msg encodePacket :: SecretKey -> SecretsCache -> Message ByteString -> NodeInfo -> (ByteString, SockAddr) encodePacket sk cache msg ni = ( S.runPut . putMessage $ encryptMessage sk cache (nodeId ni) msg , nodeAddr ni ) data Routing = Routing { tentativeId :: NodeInfo , sched4 :: !( TVar (Int.PSQ POSIXTime) ) , routing4 :: !( TVar (R.BucketList NodeInfo) ) , committee4 :: TriadCommittee NodeId SockAddr , sched6 :: !( TVar (Int.PSQ POSIXTime) ) , routing6 :: !( TVar (R.BucketList NodeInfo) ) , committee6 :: TriadCommittee NodeId SockAddr } type ToxClient = Client String Method TransactionId NodeInfo (Message ByteString) newClient :: SockAddr -> IO (ToxClient, Routing) newClient addr = do udp <- udpTransport addr secret <- generateSecretKey let pubkey = key2id $ toPublic secret cache <- newEmptyCache (symkey, drg) <- do drg0 <- getSystemDRG return $ randomBytesGenerate 32 drg0 :: IO (ByteString, SystemDRG) let tentative_ip4 = fromMaybe (IPv4 $ toEnum 0) (IPv4 <$> fromSockAddr addr) tentative_ip6 = fromMaybe (IPv6 $ toEnum 0) (IPv6 <$> fromSockAddr addr) tentative_info = NodeInfo { nodeId = pubkey , nodeIP = fromMaybe (toEnum 0) (fromSockAddr addr) , nodePort = fromMaybe 0 $ sockAddrPort addr } tentative_info4 = tentative_info { nodeIP = tentative_ip4 } tentative_info6 <- maybe (tentative_info { nodeIP = tentative_ip6 }) (\ip6 -> tentative_info { nodeIP = IPv6 ip6 }) <$> global6 addr4 <- atomically $ newTChan addr6 <- atomically $ newTChan routing <- atomically $ do let nobkts = R.defaultBucketCount :: Int tbl4 <- newTVar $ R.nullTable (comparing nodeId) (\s -> hashWithSalt s . nodeId) tentative_info4 nobkts tbl6 <- newTVar $ R.nullTable (comparing nodeId) (\s -> hashWithSalt s . nodeId) tentative_info6 nobkts let updateIPVote tblvar addrvar a = do bkts <- readTVar tblvar case nodeInfo (nodeId (R.thisNode bkts)) a of Right ni -> writeTVar tblvar (bkts { R.thisNode = ni }) Left _ -> return () writeTChan addrvar (a,map fst $ concat $ R.toList bkts) committee4 <- newTriadCommittee $ updateIPVote tbl4 addr4 committee6 <- newTriadCommittee $ updateIPVote tbl6 addr6 sched4 <- newTVar Int.empty sched6 <- newTVar Int.empty return $ Routing tentative_info sched4 tbl4 committee4 sched6 tbl6 committee6 -- If we have 8-byte keys for IntMap, then use it for transaction lookups. -- Otherwise, use ordinary Map. The details of which will be hidden by an -- existential closure (see mkclient below). tblvar <- if fitsInInt (Proxy :: Proxy Word64) then do let intmapT = transactionMethods (contramapT intKey intMapMethods) gen intmap_var <- atomically $ newTVar (drg, mempty) return $ Right (intmapT,intmap_var) else do let mapT = transactionMethods (contramapT nonceKey mapMethods) gen map_var <- atomically $ newTVar (drg, mempty) return $ Left (mapT,map_var) let net = onInbound (updateRouting outgoingClient routing) $ addVerbosity $ layerTransport (parsePacket secret cache) (encodePacket secret cache) $ udp -- Paranoid: It's safe to define /net/ and /client/ to be mutually -- recursive since 'updateRouting' does not invoke 'awaitMessage' which -- which was modified by 'onInbound'. However, I'm going to avoid the -- mutual reference just to be safe. outgoingClient = client { clientNet = net { awaitMessage = ($ Nothing) } } dispatch tbl var = DispatchMethods { classifyInbound = classify , lookupHandler = handlers var , tableMethods = tbl } -- handlers :: TVar -> Method -> Maybe Handler handlers var PingType = handler PongType pingH handlers var GetNodesType = handler SendNodesType $ getNodesH routing {- handlers var OnionRequest0 = noreply OnionRequest0 $ onionSend0H (symmetricCipher (return symkey) (fst <$> readTVar var) (modifyTVar' var . first . const)) udp handlers var OnionResponse1 = noreply OnionResponse1 $ onionResponse1H (symmetricDecipher (return symkey)) udp -} handlers var _ = Nothing -- TODO DHTRequest public key (onion) -- TODO DHTRequest NAT ping -- TODO BootstrapInfo 0xf0 genNonce24 var (TransactionId nonce8 _) = atomically $ do (g,pending) <- readTVar var let (bs, g') = randomBytesGenerate 24 g writeTVar var (g',pending) return $ TransactionId nonce8 (Nonce24 bs) client = either mkclient mkclient tblvar mkclient :: DRG g => ( TransactionMethods (g,t (MVar (Message ByteString))) TransactionId (Message ByteString) , TVar (g, t (MVar (Message ByteString))) ) -> ToxClient mkclient (tbl,var) = Client { clientNet = net , clientDispatcher = dispatch tbl var , clientErrorReporter = (printErrors stderr) { reportTimeout = reportTimeout ignoreErrors } , clientPending = var , clientAddress = \maddr -> atomically $ do let var = case flip prefer4or6 Nothing <$> maddr of Just Want_IP6 -> routing6 routing _ -> routing4 routing R.thisNode <$> readTVar var , clientResponseId = genNonce24 var } return (client, routing) toxKademlia :: ToxClient -> TriadCommittee NodeId SockAddr -> TVar (R.BucketList NodeInfo) -> TVar (Int.PSQ POSIXTime) -> Kademlia NodeId NodeInfo toxKademlia client committee var sched = Kademlia quietInsertions toxSpace (vanillaIO var $ ping client) { tblTransition = \tr -> do io1 <- transitionCommittee committee tr io2 <- touchBucket toxSpace (15*60) var sched tr return $ do io1 >> io2 hPutStrLn stderr $ unwords [ show (transitionedTo tr) , show (transitioningNode tr) ] } toxSpace :: R.KademliaSpace NodeId NodeInfo toxSpace = R.KademliaSpace { R.kademliaLocation = nodeId , R.kademliaTestBit = testIdBit , R.kademliaXor = xor } last8 :: ByteString -> Nonce8 last8 bs | let len = B.length bs , (len >= 8) = Nonce8 $ let bs' = B.drop (len - 8) bs Right w = S.runGet S.getWord64be bs' in w | otherwise = Nonce8 0 dropEnd8 :: ByteString -> ByteString dropEnd8 bs = B.take (B.length bs - 8) bs -- Add detailed printouts for every packet. addVerbosity tr = tr { awaitMessage = \kont -> awaitMessage tr $ \m -> do forM_ m $ mapM_ $ \(msg,addr) -> do hPutStrLn stderr ( (show addr) ++ " --> " ++ show (msgType msg)) kont m , sendMessage = \addr msg -> do hPutStrLn stderr ( (show addr) ++ " <-- " ++ show (msgType msg)) sendMessage tr addr msg } classify :: Message ByteString -> MessageClass String Method TransactionId classify (Message { msgType = typ , msgPayload = bs , msgNonce = nonce24 }) = go $ TransactionId (last8 bs) nonce24 where go = case typ of PingType -> IsQuery typ GetNodesType -> IsQuery typ PongType -> IsResponse SendNodesType -> IsResponse DHTRequestType -> IsQuery typ OnionRequest0 -> IsQuery typ OnionRequest1 -> IsQuery typ OnionRequest2 -> IsQuery typ AnnounceType -> IsQuery typ _ -> const $ IsUnknown ("Unknown message type: "++show typ) encodePayload typ (TransactionId (Nonce8 tid) nonce) self dest b = Message { msgType = typ , msgOrigin = nodeId self , msgNonce = nonce , msgReturnPath = Nothing , msgPayload = S.encode b <> S.runPut (S.putWord64be tid) } decodePayload :: S.Serialize a => Message ByteString -> Either String a decodePayload msg = S.decode $ dropEnd8 $ msgPayload msg type Handler = MethodHandler String TransactionId NodeInfo (Message ByteString) handler typ f = Just $ MethodHandler decodePayload (encodePayload typ) f noreply :: S.Serialize b => Method -> (addr -> Message b -> IO ()) -> Maybe (MethodHandler String tid addr (Message ByteString)) noreply typ f = Just $ NoReply (mapM deserialize) f where deserialize = S.decode . bool id dropEnd8 (typeHasEncryptedPayload typ) transitionCommittee :: TriadCommittee NodeId SockAddr -> RoutingTransition NodeInfo -> STM (IO ()) transitionCommittee committee (RoutingTransition ni Stranger) = do delVote committee (nodeId ni) return $ do hPutStrLn stderr $ "delVote "++show (nodeId ni) transitionCommittee committee _ = return $ return () updateRouting :: ToxClient -> Routing -> NodeInfo -> Message ByteString -> IO () updateRouting client routing addr msg = do forM_ (msgDHTKey msg) $ \nid -> do let naddr = addr { nodeId = nid } case prefer4or6 naddr Nothing of Want_IP4 -> updateTable client naddr (routing4 routing) (committee4 routing) (sched4 routing) Want_IP6 -> updateTable client naddr (routing6 routing) (committee6 routing) (sched6 routing) updateTable client naddr tbl committee sched = do self <- atomically $ R.thisNode <$> readTVar tbl when (nodeIP self /= nodeIP naddr) $ do -- TODO: IP address vote? insertNode (toxKademlia client committee tbl sched) naddr 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 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' -- self -> A -- OnionRequest0: Message (OnionWrap (OnionWrap (Forward msg))) -- OnionRequest0: Message (OnionWrap (OnionWrap Ciphered)) -- OnionRequest0: Message (OnionWrap Ciphered) -- OnionRequest0: Message Ciphered -- A -> B -- OnionRequest0: Message Ciphered -- OnionRequest0: Message (OnionWrap Ciphered) -- OnionRequest1: Message Ciphered ++ SockAddr -- OnionRequest1: Message Ciphered ++ SymmetricCiphered -- -- B -> C -- OnionRequest1: Message Ciphered ++ SymmetricCiphered -- OnionRequest1: Message (OnionWrap Ciphered) ++ SymmetricCiphered -- OnionRequest2: Message Ciphered ++ (SockAddr ++ SymmetricCiphered) -- OnionRequest2: Message Ciphered ++ SymmetricCiphered -- -- C -> D -- OnionRequest2: Message Ciphered ++ SymmetricCiphered -- OnionRequest2: Message (Forward msg) ++ SymmetricCiphered -- ?????????????: msg ++ ( SockAddr ++ SymmetricCiphered) -- ?????????????: msg ++ SymmetricCiphered -- D -> C -- ?????????????: msg ++ SymmetricCiphered -- OnionResponse3: Message SymmetricCiphered ++ response -- -- C -> B -- OnionResponse3: Message SymmetricCiphered ++ response -- OnionResponse3: Message (SockAddr ++ SymmetricCiphered) ++ response -- OnionResponse2: Message SymmetricCiphered ++ response -- -- B -> A -- OnionResponse2: Message SymmetricCiphered ++ response -- OnionResponse2: Message (SockAddr ++ SymmetricCiphered) ++ response -- OnionResponse1: Message SymmetricCiphered ++ response -- -- A -> self -- OnionResponse1: Message SymmetricCiphered ++ response -- OnionResponse1: Message SockAddr ++ response -- ??????????????: response -- -- Onion payloads: -- AnounceRequest (0x83) -- = SeekingKey nid -- | AnnouncingKey pingid nid sendback_key -- -- AnnounceResponse (0x84) -- = KeyNotFound pingid [ni] -- is_stored=0 -- | KeyFound sendback_key [ni] -- is_stored=1 -- | Announced pingid [ni] -- is_stored=2 What's the pingid for in this caes? -- -- Should it be a fresh one? -- -- -- After you find an announce node for your friend, you share your dht nodeid thus: -- DataToRouteRequest (0x85) -- -- cleartext: Public key of destination node (used to lookup the sendback_key,ip,port of onion-return path) -- -- cleartext: nonce -- -- cleartext: alias (just generated key) -- -- encrypted (nonce,alias,sendback_key): -- real public key -- id byte -- -- encrypted -- DHTPublicKey (0x9c) -- { no_replay :: Word64 -- , dhtKey :: NodeId -- , nearbyNodes :: [NodeInfo] -- } -- payload (optional) -- -- -- The announce node forwards your message thus: -- -- This is the same as 0x85, but the destination key was removed. -- DataToRouteResponse (0x86) -- -- cleartext: nonce -- -- cleartext: alias -- -- encrypted payload. data OnionWrap a = OnionWrap { forwardAddress :: SockAddr , forwardAlias :: NodeId , onionPayload :: a } instance S.Serialize (OnionWrap Ciphered) where get = getOnion put = putOnion getOnion :: S.Get (OnionWrap Ciphered) getOnion = do addr <- getForwardAddr alias <- S.get ciphered <- getCiphered return $ OnionWrap addr alias ciphered getForwardAddr :: S.Get SockAddr getForwardAddr = do addrfam <- S.get :: S.Get Word8 ip <- getIP addrfam case ip of IPv4 _ -> S.skip 12 -- compliant peers would zero-fill this. IPv6 _ -> return () port <- S.get :: S.Get PortNumber return $ setPort port $ toSockAddr ip putForwardAddr :: SockAddr -> S.Put putForwardAddr saddr = fromMaybe (return $ error "unsupported SockAddr family") $ do port <- sockAddrPort saddr ip <- fromSockAddr $ either id id $ either4or6 saddr return $ do case ip of IPv4 ip4 -> S.put (0x02 :: Word8) >> S.put ip4 >> S.putByteString (B.replicate 12 0) IPv6 ip6 -> S.put (0x0a :: Word8) >> S.put ip6 S.put port putOnion :: OnionWrap Ciphered -> S.Put putOnion = error "todo: putOnion" getCiphered :: S.Get Ciphered getCiphered = do mac <- Poly1305.Auth . BA.convert <$> S.getBytes 16 cnt <- S.remaining bs <- S.getBytes cnt return $ Ciphered mac bs putCiphered :: Ciphered -> S.Put putCiphered (Ciphered (Poly1305.Auth mac) bs) = do S.putByteString (BA.convert mac) S.putByteString bs data Announce = Announce { announcePingId :: NodeId -- Ping ID , announceSeeking :: NodeId -- Public key we are searching for , announceKey :: NodeId -- Public key that we want those sending back data packets to use } pingH :: NodeInfo -> Ping -> IO Pong pingH _ Ping = return Pong prefer4or6 :: NodeInfo -> Maybe WantIP -> WantIP prefer4or6 addr iptyp = fromMaybe (ipFamily $ nodeIP addr) iptyp -- TODO: This should cover more cases isLocal (IPv6 ip6) = (ip6 == toEnum 0) isLocal (IPv4 ip4) = (ip4 == toEnum 0) isGlobal = not . isLocal getNodesH :: Routing -> NodeInfo -> GetNodes -> IO SendNodes getNodesH routing addr (GetNodes nid) = do let preferred = prefer4or6 addr Nothing (append4,append6) <- atomically $ do ni4 <- R.thisNode <$> readTVar (routing4 routing) ni6 <- R.thisNode <$> readTVar (routing6 routing) return $ case ipFamily (nodeIP addr) of Want_IP4 | isGlobal (nodeIP ni6) -> (id, (++ [ni6])) Want_IP6 | isGlobal (nodeIP ni4) -> ((++ [ni4]), id) _ -> (id, id) ks <- go append4 $ routing4 routing ks6 <- go append6 $ routing6 routing let (ns1,ns2) = case preferred of Want_IP6 -> (ks6,ks) Want_IP4 -> (ks,ks6) return $ SendNodes $ if null ns2 then ns1 else take 4 (take 3 ns1 ++ ns2) where go f var = f . R.kclosest toxSpace k nid <$> atomically (readTVar var) k = 4 symmetricCipher :: DRG g => STM ByteString -> STM g -> (g -> STM ()) -> ByteString -> IO SymmetricCiphered symmetricCipher currentSymmetricKey readG writeG bs = (>>= \e -> hPutStrLn stderr (show e) >> Cryptonite.throwCryptoErrorIO e) $ atomically $ do g <- readG let (sym_nonce_bytes, g') = randomBytesGenerate 12 g writeG g' symmkey <- currentSymmetricKey return $ do sym_nonce <- Symmetric.nonce12 sym_nonce_bytes symm <- Symmetric.initialize symmkey sym_nonce let (rpath_bs, symm') = Symmetric.encrypt bs symm auth = Symmetric.finalize symm' -- 16 bytes -- For a single SockAddr, bs will be 19 bytes which gives -- 12 + 16 + 19 = 47 bytes. -- We need 12 more make 59 bytes, so we'll include the nonce twice. return $ SymmetricCiphered (sym_nonce_bytes <> sym_nonce_bytes <> BA.convert auth <> rpath_bs) symmetricDecipher currentSymmetricKey (Nonce24 nonce24) (SymmetricCiphered bs) = atomically $ do symmkey <- currentSymmetricKey return $ do let sym_nonce_bytes = B.drop 12 nonce24 (mac, bs'') = B.splitAt 16 bs symm <- left show . Cryptonite.eitherCryptoError $ do sym_nonce <- Symmetric.nonce12 sym_nonce_bytes Symmetric.initialize symmkey sym_nonce let (ds, symm') = Symmetric.decrypt bs'' symm auth = Symmetric.finalize symm' if BA.convert auth /= mac then Left "symmetricDecipher: Auth fail." else return $ ds -- OnionRequest0 onionSend0H :: (ByteString -> IO SymmetricCiphered) -> Transport err SockAddr ByteString -> NodeInfo -> Message (OnionWrap Ciphered) -> IO () onionSend0H symcipher udp addr Message{ msgNonce , msgPayload = OnionWrap forward alias ciphered } = do hPutStrLn stderr $ "onionSend0H( " ++ show addr ++ " --> " ++ either show show (either4or6 forward) ++ ")" rpath <- symcipher (S.runPut $ putForwardAddr forward) sendMessage udp forward $ S.runPut $ putMessage Message { msgType = OnionRequest1 , msgOrigin = alias , msgNonce = msgNonce , msgReturnPath = Just rpath , msgPayload = Right ciphered } hPutStrLn stderr $ "onionSend0H SENT ( " ++ show addr ++ " --> " ++ either show show (either4or6 forward) ++ ")" -- OnionResponse1 -- -- No public-key decryption here. onionResponse1H :: (Nonce24 -> SymmetricCiphered -> IO (Either String ByteString)) -> Transport err SockAddr ByteString -> NodeInfo -> Message OnionPayload -> IO () onionResponse1H symdecipher udp addr Message{ msgNonce , msgReturnPath , msgPayload } = do hPutStrLn stderr $ "onionResponse1H " ++ show addr ++ maybe " Nothing" (const" Just") msgReturnPath forM_ msgReturnPath $ \rpath -> do eaddr <- (>>= S.runGet getForwardAddr) <$> symdecipher msgNonce rpath let go forward = do hPutStrLn stderr $ "onionResponse1H( " ++ show addr ++ " --> " ++ either show show (either4or6 forward) ++ ")" sendMessage udp forward (unpackOnionPayload msgPayload) either (hPutStrLn stderr . mappend "onionResponse1H decipher ERROR ") (\x -> go x >> hPutStrLn stderr "onionResponse1H SENT") eaddr intKey :: TransactionId -> Int intKey (TransactionId (Nonce8 w) _) = fromIntegral w nonceKey :: TransactionId -> Nonce8 nonceKey (TransactionId n _) = n -- randomBytesGenerate :: ByteArray byteArray => Int -> gen -> (byteArray, gen) gen :: forall gen. DRG gen => gen -> (TransactionId, gen) -- gen :: SystemDRG -> (TransactionId, SystemDRG) gen g = let (bs, g') = randomBytesGenerate 24 g (ws, g'') = randomBytesGenerate 8 g' Right w = S.runGet S.getWord64be ws in ( TransactionId (Nonce8 w) (Nonce24 bs), g'' ) toxSend meth unwrap msg client nid addr = do reply <- sendQuery client serializer (msg nid) addr -- sendQuery will return (Just (Left _)) on a parse error. We're going to -- blow it away with the join-either sequence. -- TODO: Do something with parse errors. return $ join $ either (const Nothing) Just <$> reply where serializer = MethodSerializer { methodTimeout = 5 , method = meth -- wrapQuery :: tid -> addr -> addr -> a -> x , wrapQuery = encodePayload meth -- unwrapResponse :: x -> b , unwrapResponse = fmap unwrap . decodePayload } ping :: ToxClient -> NodeInfo -> IO Bool ping client addr = fromMaybe False <$> toxSend PingType (\Pong -> True) (const Ping) client () addr getNodes :: ToxClient -> NodeId -> NodeInfo -> IO (Maybe ([NodeInfo],[NodeInfo],())) getNodes = toxSend GetNodesType unwrapNodes $ GetNodes unwrapNodes (SendNodes ns) = (ns,ns,()) toxSearch qry = Search { searchSpace = toxSpace , searchNodeAddress = nodeIP &&& nodePort , searchQuery = qry } nodeSearch client = toxSearch (getNodes client)