{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} module ToxAddress (NodeInfo(..),NodeId(..),nodeInfo,nodeAddr,zeroID,key2id,id2key) where import Control.Applicative import Control.Monad import Crypto.Error.Types (CryptoFailable (..), throwCryptoError) import Crypto.PubKey.Curve25519 import qualified Data.Aeson as JSON ;import Data.Aeson (FromJSON, ToJSON, (.=)) import Data.Bits.ByteString () import qualified Data.ByteArray as BA ;import Data.ByteArray as BA (ByteArrayAccess) 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.Char import Data.Data import Data.Hashable import Data.IP import Data.Serialize as S import Data.Word import Foreign.Storable import GHC.TypeLits import Network.Address hiding (nodePort) import System.IO.Unsafe (unsafeDupablePerformIO) import qualified Text.ParserCombinators.ReadP as RP import Text.Read import Data.Bits import ToxCrypto -- | perform io for hashes that do allocation and ffi. -- unsafeDupablePerformIO is used when possible as the -- computation is pure and the output is directly linked -- to the input. we also do not modify anything after it has -- been returned to the user. unsafeDoIO :: IO a -> a #if __GLASGOW_HASKELL__ > 704 unsafeDoIO = unsafeDupablePerformIO #else unsafeDoIO = unsafePerformIO #endif unpackPublicKey :: PublicKey -> [Word64] unpackPublicKey bs = loop 0 where loop i | i == 4 = [] | otherwise = let !v = unsafeDoIO $ BA.withByteArray bs (\p -> peekElemOff p i) in v : loop (i+1) newtype NodeId = NodeId PublicKey deriving (Eq,ByteArrayAccess) -- (Eq,Ord,ByteArrayAccess, Bits, Hashable) key2id :: PublicKey -> NodeId key2id = NodeId id2key :: NodeId -> PublicKey id2key (NodeId key) = key {- 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 -} instance Ord NodeId where compare (NodeId a) (NodeId b) = compare (unpackPublicKey a) (unpackPublicKey b) zeroID :: NodeId zeroID = NodeId $ throwCryptoError $ publicKey $ B.replicate 32 0 instance Read NodeId where readsPrec _ str | (bs, xs) <- Base16.decode $ C8.pack 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 instance S.Serialize NodeId where get = NodeId <$> getPublicKey put (NodeId bs) = putPublicKey bs instance Bits NodeId where -- TODO instance Hashable NodeId where hashWithSalt salt (NodeId key) = hashWithSalt salt (BA.convert key :: ByteString) instance FiniteBits NodeId where finiteBitSize _ = 256 data NodeInfo = NodeInfo { nodeId :: NodeId , nodeIP :: IP , nodePort :: PortNumber } deriving (Eq,Ord) 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." 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 $ throwCryptoError . publicKey $ 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 Sized NodeInfo where size = VarSize $ \(NodeInfo nid ip port) -> case ip of IPv4 _ -> 39 -- 35 + 4 = 1 + 4 + 2 + 32 IPv6 _ -> 51 -- 35 + 16 = 1 + 16 + 2 + 32 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 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 $ throwCryptoError . publicKey $ 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 . (']' :) {- type NodeId = PubKey pattern NodeId bs = PubKey bs -- TODO: This should probably be represented by Curve25519.PublicKey, but -- ByteString has more instances... newtype PubKey = PubKey ByteString deriving (Eq,Ord,Data, ByteArrayAccess, Bits, Hashable) instance Serialize PubKey where get = PubKey <$> getBytes 32 put (PubKey bs) = putByteString bs instance Show PubKey where show (PubKey bs) = C8.unpack $ Base16.encode bs instance FiniteBits PubKey where finiteBitSize _ = 256 instance Read PubKey where readsPrec _ str | (bs, xs) <- Base16.decode $ C8.pack str , B.length bs == 32 = [ (PubKey bs, drop 64 str) ] | otherwise = [] data NodeInfo = NodeInfo { nodeId :: NodeId , nodeIP :: IP , nodePort :: PortNumber } deriving (Eq,Ord,Data) instance Data PortNumber where dataTypeOf _ = mkNoRepType "PortNumber" toConstr _ = error "PortNumber.toConstr" gunfold _ _ = error "PortNumber.gunfold" 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 (PubKey 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 . (']' :) 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." zeroID :: NodeId zeroID = PubKey $ B.replicate 32 0 -} nodeAddr :: NodeInfo -> SockAddr nodeAddr (NodeInfo _ ip port) = setPort port $ toSockAddr ip newtype ForwardPath (n::Nat) = ForwardPath ByteString deriving (Eq, Ord,Data) {- class KnownNat n => OnionPacket n where mkOnion :: ReturnPath n -> Packet -> Packet instance OnionPacket 0 where mkOnion _ = id instance OnionPacket 3 where mkOnion = OnionResponse3 -}