{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} module Tox where 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, toSockAddr, setPort, un4map, WantIP(..), ipFamily) 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 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 40 str) ] | otherwise = [] zeroID :: NodeId zeroID = NodeId $ B.replicate 32 0 data NodeInfo = NodeInfo { nodeId :: NodeId , nodeIP :: IP , nodePort :: PortNumber } deriving (Eq,Ord) instance S.Serialize NodeInfo where get = do nid <- S.get addrfam <- S.get :: S.Get Word8 ip <- case addrfam of 2 -> IPv4 <$> S.get 10 -> IPv6 <$> S.get 130 -> IPv4 <$> S.get -- TODO: TCP 138 -> IPv6 <$> S.get -- TODO: TCP _ -> fail "unsupported address family" port <- S.get :: S.Get PortNumber return $ NodeInfo nid ip port put (NodeInfo nid ip port) = do S.put nid case ip of IPv4 ip4 -> S.put (2 :: Word8) >> S.put ip4 IPv6 ip6 -> S.put (10 :: Word8) >> S.put ip6 S.put port -- 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. } newtype Method = MessageType Word8 deriving (Eq, Ord, S.Serialize) pattern PingType = MessageType 0 pattern PongType = MessageType 1 pattern GetNodesType = MessageType 2 pattern SendNodesType = MessageType 4 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 (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 data Message a = Message { msgType :: Method , msgOrigin :: NodeId , msgNonce :: Nonce24 -- cryptoNonce of TransactionId , msgPayload :: a } deriving (Eq, Show, Generic, Functor, Foldable, Traversable) data Ciphered = Ciphered { cipheredMAC :: Poly1305.Auth , cipheredBytes :: ByteString } deriving Eq getMessage :: S.Get (Message Ciphered) getMessage = do typ <- S.get nid <- S.get tid <- S.get mac <- Poly1305.Auth . BA.convert <$> S.getBytes 16 cnt <- S.remaining bs <- S.getBytes cnt return Message { msgType = typ , msgOrigin = nid , msgNonce = tid , msgPayload = Ciphered mac bs } putMessage :: Message Ciphered -> S.Put putMessage (Message {..}) = do S.put msgType S.put msgOrigin S.put msgNonce let Ciphered (Poly1305.Auth mac) bs = msgPayload S.putByteString (BA.convert mac) S.putByteString bs {- 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 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 Ciphered encryptMessage sk _ recipient plaintext = withSecret encipherAndHash sk recipient (msgNonce plaintext) <$> 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 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 -- 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 = do ciphered <- S.runGet getMessage bs msg <- decryptMessage sk cache ciphered ni <- nodeInfo (msgOrigin msg) addr return (msg, ni) 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 drg <- getSystemDRG let tentative_info = NodeInfo { nodeId = pubkey , nodeIP = fromMaybe (toEnum 0) $ fromSockAddr addr , nodePort = fromMaybe 0 $ sockAddrPort addr } tentative_info6 <- maybe tentative_info (\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_info 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) $ 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 = return Nothing } } dispatch tbl = DispatchMethods { classifyInbound = classify , lookupHandler = handlers , tableMethods = tbl } handlers :: Method -> Maybe Handler handlers PingType = handler PongType pingH handlers GetNodesType = handler SendNodesType $ getNodesH routing handlers _ = Nothing 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 , clientErrorReporter = printErrors stderr , 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) 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 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 PingType GetNodesType -> IsQuery GetNodesType PongType -> IsResponse SendNodesType -> IsResponse encodePayload typ (TransactionId (Nonce8 tid) nonce) self dest b = Message { msgType = typ , msgOrigin = nodeId self , msgNonce = nonce , 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 updateRouting :: ToxClient -> Routing -> NodeInfo -> Message ByteString -> IO () updateRouting = error "todo updateRouting" 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' pingH :: NodeInfo -> Ping -> IO Pong pingH _ Ping = return Pong prefer4or6 :: NodeInfo -> Maybe WantIP -> WantIP prefer4or6 addr iptyp = fromMaybe (ipFamily $ nodeIP addr) iptyp getNodesH :: Routing -> NodeInfo -> GetNodes -> IO SendNodes getNodesH = error "todo: getNodesH" 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 -> ((Nonce8, Nonce24), 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'' )