{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UndecidableInstances #-} module Data.Tox.Relay ( module Network.Tox.TCP.NodeId , module Data.Tox.Relay ) where import Data.Aeson (ToJSON(..),FromJSON(..)) import qualified Data.Aeson as JSON import Data.ByteString as B import Data.Data import Data.Functor.Contravariant import Data.Hashable import qualified Data.HashMap.Strict as HashMap import Data.List import Data.Monoid import Data.Ord import Data.Serialize import qualified Data.Vector as Vector import Data.Word import Network.Socket import qualified Rank2 import qualified Text.ParserCombinators.ReadP as RP import Crypto.Tox import Network.Tox.TCP.NodeId import Data.Tox.Onion import qualified Network.Tox.NodeId as UDP import Network.Tox.TCP.NodeId as TCP newtype ConId = ConId Word8 deriving (Eq,Show,Ord,Data,Serialize) badcon :: ConId badcon = ConId 0 -- Maps to a range -120 .. 119 c2key :: ConId -> Maybe Int c2key (ConId x) | x < 16 = Nothing | otherwise = Just $ case divMod (x - 15) 2 of (q,0) -> negate $ fromIntegral q (q,1) -> fromIntegral q -- Maps to range 16 .. 255 -- negatives become odds key2c :: Int -> ConId key2c y = ConId $ if y < 0 then 15 + fromIntegral (negate y * 2) else 16 + fromIntegral (y * 2) data RelayPacket = RoutingRequest PublicKey | RoutingResponse ConId PublicKey -- 0 for refusal, 16-255 for success. | ConnectNotification ConId | DisconnectNotification ConId | RelayPing Nonce8 | RelayPong Nonce8 | OOBSend PublicKey ByteString | OOBRecv PublicKey ByteString | OnionPacket Nonce24 (Addressed (Forwarding N2 (OnionMessage Encrypted))) -- (OnionRequest N0) | OnionPacketResponse (OnionMessage Encrypted) -- 0x0A through 0x0F reserved for future use. | RelayData ByteString ConId deriving (Eq,Ord,Show,Data) newtype PacketNumber = PacketNumber { packetNumberToWord8 :: Word8 } deriving (Eq,Ord,Show) pattern RoutingRequestPacket = PacketNumber 0 pattern PingPacket = PacketNumber 4 pattern OnionPacketID = PacketNumber 8 packetNumber :: RelayPacket -> PacketNumber packetNumber (RelayData _ (ConId conid)) = PacketNumber $ conid -- 0 to 15 not allowed. packetNumber rp = PacketNumber $ fromIntegral $ pred $ constrIndex $ toConstr rp instance Sized RelayPacket where size = mappend (ConstSize 1) $ VarSize $ \x -> case x of RoutingRequest k -> 32 RoutingResponse rpid k -> 33 ConnectNotification conid -> 1 DisconnectNotification conid -> 1 RelayPing pingid -> 8 RelayPong pingid -> 8 OOBSend k bs -> 32 + B.length bs OOBRecv k bs -> 32 + B.length bs OnionPacket n24 query -> 24 + case contramap (`asTypeOf` query) size of ConstSize n -> n VarSize f -> f query OnionPacketResponse answer -> case contramap (`asTypeOf` answer) size of ConstSize n -> n VarSize f -> f answer RelayData bs _ -> B.length bs instance Serialize RelayPacket where get = do pktid <- getWord8 case pktid of 0 -> RoutingRequest <$> getPublicKey 1 -> RoutingResponse <$> get <*> getPublicKey 2 -> ConnectNotification <$> get 3 -> DisconnectNotification <$> get 4 -> RelayPing <$> get 5 -> RelayPong <$> get 6 -> OOBSend <$> getPublicKey <*> (remaining >>= getBytes) 7 -> OOBRecv <$> getPublicKey <*> (remaining >>= getBytes) 8 -> OnionPacket <$> get <*> get 9 -> OnionPacketResponse <$> get conid -> (`RelayData` ConId conid) <$> (remaining >>= getBytes) put rp = do putWord8 $ packetNumberToWord8 $ packetNumber rp case rp of RoutingRequest k -> putPublicKey k RoutingResponse rpid k -> put rpid >> putPublicKey k ConnectNotification conid -> put conid DisconnectNotification conid -> put conid RelayPing pingid -> put pingid RelayPong pingid -> put pingid OOBSend k bs -> putPublicKey k >> putByteString bs OOBRecv k bs -> putPublicKey k >> putByteString bs OnionPacket n24 query -> put n24 >> put query OnionPacketResponse answer -> put answer RelayData bs _ -> putByteString bs -- | Initial client-to-server handshake message. newtype Hello (f :: * -> *) = Hello (Asymm (f HelloData)) deriving instance Show (f HelloData) => Show (Hello f) helloFrom :: Hello f -> PublicKey helloFrom (Hello x) = senderKey x helloNonce :: Hello f -> Nonce24 helloNonce (Hello x) = asymmNonce x helloData :: Hello f -> f HelloData helloData (Hello x) = asymmData x instance Rank2.Functor Hello where f <$> Hello (Asymm k n dta) = Hello $ Asymm k n (f dta) instance Payload Serialize Hello where mapPayload _ f (Hello (Asymm k n dta)) = Hello $ Asymm k n (f dta) instance Rank2.Foldable Hello where foldMap f (Hello (Asymm k n dta)) = f dta instance Rank2.Traversable Hello where traverse f (Hello (Asymm k n dta)) = Hello . Asymm k n <$> f dta instance Sized (Hello Encrypted) where size = ConstSize 56 <> contramap helloData size instance Serialize (Hello Encrypted) where get = Hello <$> getAsymm put (Hello asym) = putAsymm asym data HelloData = HelloData { sessionPublicKey :: PublicKey , sessionBaseNonce :: Nonce24 } deriving Show instance Sized HelloData where size = ConstSize 56 instance Serialize HelloData where get = HelloData <$> getPublicKey <*> get put (HelloData k n) = putPublicKey k >> put n -- | Handshake server-to-client response packet. data Welcome (f :: * -> *) = Welcome { welcomeNonce :: Nonce24 , welcomeData :: f HelloData } deriving instance Show (f HelloData) => Show (Welcome f) instance Rank2.Functor Welcome where f <$> Welcome n dta = Welcome n (f dta) instance Payload Serialize Welcome where mapPayload _ f (Welcome n dta) = Welcome n (f dta) instance Rank2.Foldable Welcome where foldMap f (Welcome _ dta) = f dta instance Rank2.Traversable Welcome where traverse f (Welcome n dta) = Welcome n <$> f dta instance Sized (Welcome Encrypted) where size = ConstSize 24 <> contramap welcomeData size instance Serialize (Welcome Encrypted) where get = Welcome <$> get <*> get put (Welcome n dta) = put n >> put dta tcpPortScore :: Word16 -> Word16 tcpPortScore 443 = 0 tcpPortScore 80 = 0 tcpPortScore 3389 = 1 tcpPortScore _ = 2 instance FromJSON NodeInfo where parseJSON json = do -- Instead of using ordinary parseJSON to parse the udp node, -- we are using a variation that prefers IPv4 over IPv6. -- The rationale is that must lans without UDP will be using -- IPv4. udp <- UDP.nodeInfoFromJSON True json port <- case json of JSON.Object v -> do ps <- v JSON..: "tcp_ports" if Prelude.null (ps :: [Word16]) then fail "TCP.NodeInfo: missing tcp port" else do let portnum = minimumBy (comparing tcpPortScore) ps return (fromIntegral portnum) _ -> fail "TCP.NodeInfo: Expected JSON object." return $ NodeInfo udp port instance Hashable NodeInfo where hashWithSalt s n = hashWithSalt s (udpNodeInfo n)