{- LANGUAGE ApplicativeDo -} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TupleSections #-} {- LANGUAGE TypeApplications -} module Network.Tox.NodeId ( NodeInfo(..) , NodeId , nodeInfo , nodeAddr , zeroID , key2id , id2key , getIP , xorNodeId , testNodeIdBit , sampleNodeId , NoSpam(..) , NoSpamId(..) , noSpamIdToHex , parseNoSpamId , nospam64 , nospam16 , verifyChecksum , ToxContact(..) , ToxProgress(..) , showBase64Key256 , showBase32Key256 , nodeInfoFromJSON , showHexId ) where import Control.Applicative import Control.Arrow import Control.Monad import Control.Monad.Fail as MF #ifdef CRYPTONITE_BACKPORT import Crypto.Error.Types (CryptoFailable (..), throwCryptoError) #else import Crypto.Error #endif import Crypto.PubKey.Curve25519 import qualified Data.Aeson.Types 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.Base32.Z as Base32 import qualified Data.ByteString.Base64 as Base64 import qualified Data.ByteString.Char8 as C8 import Data.Char import Data.Data import Data.Hashable #if MIN_VERSION_iproute(1,7,4) import Data.IP hiding ( fromSockAddr #if MIN_VERSION_iproute(1,7,8) , toSockAddr #endif ) #else import Data.IP #endif import Data.List import Data.Maybe 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 hiding (get) import Data.Bits import Crypto.Tox import Foreign.Ptr import Data.Function import System.Endian import qualified Data.Text as Text ;import Data.Text (Text) import Util (splitJID) -- | 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 :: ByteArrayAccess bs => bs -> [Word64] unpackPublicKey bs = loop 0 where loop i | i == (BA.length bs `div` 8) = [] | otherwise = let !v = unsafeDoIO $ BA.withByteArray bs (\p -> fromBE64 <$> peekElemOff p i) in v : loop (i+1) packPublicKey :: BA.ByteArray bs => [Word64] -> bs packPublicKey ws = BA.allocAndFreeze (8 * length ws) $ flip fix ws $ \loop ys ptr -> case ys of [] -> return () x:xs -> do poke ptr (toBE64 x) loop xs (plusPtr ptr 8) {-# NOINLINE packPublicKey #-} -- We represent the node id redundantly in two formats. The [Word64] format is -- convenient for short-circuiting xor/distance comparisons. The PublicKey -- format is convenient for encryption. data NodeId = NodeId [Word64] !(Maybe PublicKey) deriving Data instance Data PublicKey where -- Data a => (forall d b . Data d => c (d -> b) -> d -> c b) -> (forall g . g -> c g) -> a -> c a gfoldl f z txt = z (throwCryptoError . publicKey) `f` (BA.convert txt :: ByteString) toConstr _ = error "Crypto.PubKey.Curve25519.toConstr" gunfold _ _ = error "Crypto.PubKey.Curve25519.gunfold" #if MIN_VERSION_base(4,2,0) dataTypeOf _ = mkNoRepType "Crypto.PubKey.Curve25519.PublicKey" #else dataTypeOf _ = mkNorepType "Crypto.PubKey.Curve25519.PublicKey" #endif instance Eq NodeId where (NodeId ws _) == (NodeId xs _) = ws == xs instance Ord NodeId where compare (NodeId ws _) (NodeId xs _) = compare ws xs instance Sized NodeId where size = ConstSize 32 key2id :: PublicKey -> NodeId key2id k = NodeId (unpackPublicKey k) (Just k) bs2id :: ByteString -> NodeId bs2id bs = uncurry NodeId . (unpackPublicKey &&& Just) $ throwCryptoError . publicKey $ bs id2key :: NodeId -> PublicKey id2key (NodeId ws (Just key)) = key id2key (NodeId key Nothing) = throwCryptoError . publicKey $ (packPublicKey key :: BA.Bytes) zeroKey :: PublicKey zeroKey = throwCryptoError $ publicKey $ B.replicate 32 0 zeroID :: NodeId zeroID = NodeId (replicate 4 0) (Just zeroKey) instance Read NodeId where readsPrec _ str = readsPrecKey256 (fmap key2id . maybeCryptoError . publicKey) str instance Show NodeId where show nid = showBase32Key256 $ id2key nid instance S.Serialize NodeId where get = key2id <$> getPublicKey put nid = putPublicKey $ id2key nid showHexId :: NodeId -> String showHexId nid = C8.unpack $ Base16.encode $ BA.convert $ id2key nid instance Hashable NodeId where hashWithSalt salt (NodeId ws _) = hashWithSalt salt (head ws) testNodeIdBit :: NodeId -> Word -> Bool testNodeIdBit (NodeId ws _) i -- TODO: Optmize: use ByteArray key if it's available. | fromIntegral i < 256 -- 256 bits , (q, r) <- quotRem (fromIntegral i) 64 = testBit (ws !! q) (63 - r) | otherwise = False xorNodeId :: NodeId -> NodeId -> NodeId xorNodeId (NodeId xs _) (NodeId ys _) = NodeId (zipWith xor xs ys) Nothing sampleNodeId :: Applicative m => (Int -> m ByteString) -> NodeId -> (Int,Word8,Word8) -> m NodeId sampleNodeId gen (NodeId self k) (q,m,b) | q <= 0 = bs2id <$> gen 32 | q >= 32 = pure (NodeId self k) | let (qw,r) = (q+7) `divMod` 8 -- How many Word64 to prepend? bw = shiftL (fromIntegral b) (8*(7-r)) mw = bw - 1 :: Word64 (hd, t0 : _) = splitAt (qw-1) self h = xor bw (complement mw .&. t0) = flip fmap (gen $ 8 * (4 - (qw-1)) ) $ \bs -> let (w:ws) = unpackPublicKey bs in NodeId (hd ++ (h .|. (w .&. mw)) : ws) Nothing 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 = nodeInfoFromJSON False nodeInfoFromJSON :: Bool -> JSON.Value -> JSON.Parser NodeInfo nodeInfoFromJSON prefer4 (JSON.Object v) = do nidstr <- v JSON..: "public_key" ip6str <- v JSON..:? "ipv6" ip4str <- v JSON..:? "ipv4" portnum <- v JSON..: "port" ip <- if prefer4 then maybe empty (return . IPv4) (ip4str >>= readMaybe) <|> maybe empty (return . IPv6) (ip6str >>= readMaybe) else maybe empty (return . IPv6) (ip6str >>= readMaybe) <|> maybe empty (return . IPv4) (ip4str >>= readMaybe) idbs <- parseKey256 nidstr return $ NodeInfo (bs2id idbs) 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 TOX_TCP_INET getIP 0x8a = IPv6 <$> S.get -- TODO: TCP TOX_TCP_INET6 getIP x = MF.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 let fallback = do -- FIXME: Handle unrecognized address families. IPv6 <$> S.get return $ IPv6 (read "::" :: IPv6) ip <- getIP addrfam <|> fallback 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 ip_w_port :: Int -> RP.ReadP (IP, PortNumber) ip_w_port i = 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) instance Read NodeInfo where readsPrec i = RP.readP_to_S $ do RP.skipSpaces let parseAddr = RP.between (RP.char '(') (RP.char ')') (RP.munch (/=')')) RP.+++ RP.munch (\c -> not (isSpace c) && not (c `elem` ("{}()"::[Char]))) nodeidAt = do nid <- bs2id <$> readP_key256 RP.char '@' RP.+++ RP.satisfy isSpace addrstr <- parseAddr return (nid,addrstr) (nid,addrstr) <- ( nodeidAt RP.+++ ( (zeroID,) <$> parseAddr) ) (ip,port) <- case RP.readP_to_S (ip_w_port i) addrstr of [] -> MF.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. -- -- TODO: Why is the node id excluded? 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 newtype ForwardPath (n::Nat) = ForwardPath ByteString deriving (Eq, Ord,Data) data NoSpam = NoSpam !Word32 !(Maybe Word16) deriving (Eq,Ord,Show) instance Serialize NoSpam where get = NoSpam <$> get <*> get put (NoSpam w32 w16) = do put w32 put w16 -- Utilizes Data.Serialize format for Word32 nospam and Word16 checksum. instance Read NoSpam where readsPrec d s = case break isSpace s of ('$':ws ,rs) | (length ws == 8) -> base64decode rs (NoSpam <$> get <*> (Just <$> get)) ws ('0':'x':ws,rs) | (length ws == 12) -> base16decode rs (NoSpam <$> get <*> (Just <$> get)) ws _ -> [] base64decode :: MonadFail m => t1 -> Get t -> String -> m (t, t1) base64decode rs getter s = either MF.fail (\a -> return (a,rs)) $ runGet getter =<< Base64.decode (C8.pack $ map (nmtoken64 False) s) base16decode :: MonadFail m => t1 -> Get t -> String -> m (t, t1) base16decode rs getter s = either MF.fail (\a -> return (a,rs)) $ runGet getter $ fst $ Base16.decode (C8.pack s) verifyChecksum :: PublicKey -> Word16 -> Either String () verifyChecksum _ _ = return () -- TODO data NoSpamId = NoSpamId NoSpam PublicKey deriving (Eq,Ord) noSpamIdToHex :: NoSpamId -> String noSpamIdToHex (NoSpamId nspam pub) = C8.unpack (Base16.encode $ BA.convert pub) ++ nospam16 nspam nospam16 :: NoSpam -> String nospam16 (NoSpam w32 Nothing) = n ++ "????" where n = take 8 $ nospam16 (NoSpam w32 (Just 0)) nospam16 (NoSpam w32 (Just w16)) = C8.unpack $ Base16.encode $ runPut $ do put w32 put w16 nospam64 :: NoSpam -> String nospam64 (NoSpam w32 Nothing) = n ++ "???" where n = take 5 $ nospam64 (NoSpam w32 (Just 0)) nospam64 (NoSpam w32 (Just w16)) = map (nmtoken64 True) $ C8.unpack $ Base64.encode $ runPut $ do put w32 put w16 instance Show NoSpamId where show (NoSpamId nspam pub) = '$' : nospam64 nspam ++ "@" ++ show (key2id pub) ++ ".tox" instance Read NoSpamId where readsPrec d s = either MF.fail id $ do (jid,xs) <- Right $ break isSpace s nsid <- parseNoSpamId $ Text.pack jid return [(nsid,xs)] parseNoSpamHex :: Text -> Either String NoSpamId parseNoSpamHex hex = Right $ NoSpamId (read $ "0x"++nospamsum) (id2key $ read hkey) where (hkey,nospamsum) = splitAt 64 $ Text.unpack hex parseNoSpamId :: Text -> Either String NoSpamId parseNoSpamId spec | Text.length spec == 76 , Text.all isHexDigit spec = parseNoSpamHex spec | otherwise = parseNoSpamJID spec parseNoSpamJID :: Text -> Either String NoSpamId parseNoSpamJID jid = do (u,h) <- maybe (Left "Invalid JID.") Right $ let (mu,h,_) = splitJID jid in fmap (, h) mu based <- case stripSuffix ".tox" h of Just base32 -> Right $ Text.unpack base32 _ -> Left "Hostname should be 52 z-base32 digits followed by .tox." pub <- id2key <$> readEither based let ustr = Text.unpack u case ustr of '$' : b64digits -> solveBase64NoSpamID b64digits pub '0' : 'x' : hexdigits -> do nospam <- readEither ('0':'x':hexdigits) return $ NoSpamId nospam pub _ -> Left "Missing nospam." solveBase64NoSpamID :: String -> PublicKey -> Either String NoSpamId solveBase64NoSpamID b64digits pub = do NoSpam nospam mx <- readEither $ '$' : map (\case; '?' -> '0'; c -> c) b64digits maybe (const $ Left "missing checksum") (flip ($)) mx $ \x -> do let nlo = fromIntegral (0x0FFFF .&. nospam) :: Word16 nhi = fromIntegral (0x0FFFF .&. (nospam `shiftR` 16)) :: Word16 sum = x `xor` nlo `xor` nhi `xor` xorsum pub -- Find any question mark indices. qs = catMaybes $ zipWith (\case; '?' -> Just ; _ -> const Nothing) b64digits [0..7] -- Break up the /sum/ into a numbered list of two-bit non-zero nibbles. ns = filter (\case; (_,0) -> False; _ -> True) $ zip [0..7] $ unfoldr (\s -> Just (s .&. 0xC000, s `shiftL` 2)) sum -- Represent the nospam value as a Word64 n64 = shiftL (fromIntegral nospam) 32 .|. shiftL (fromIntegral x) 16 :: Word64 -- q=0 1 2 3 4 5 6 7 -- 012 345 670 123 456 701 234 567 nibblePlace n q = case mod (n - 3 * q) 8 of p | p < 3 -> Just (q,p) _ -> Nothing solve [] !ac = Right ac solve ((n,b):ns) !ac = do -- Find nibble p of question-digit q that corresponds to nibble n. (q,p) <- maybe (Left "Unsolvable nospam.") Right $ foldr (<|>) Nothing $ map (nibblePlace n) qs let bitpos = q * 6 + p * 2 ac' = ac `xor` shiftR (fromIntegral b `shiftL` 48) bitpos solve ns ac' n64' <- solve ns n64 let nospam' = fromIntegral (n64' `shiftR` 32) cksum' = fromIntegral (n64' `shiftR` 16) return $ NoSpamId (NoSpam nospam' (Just cksum')) pub -- | This type indicates a roster-link relationship between a local toxid and a -- remote toxid. Note that these toxids are represented as the type 'NodeId' -- even though they are long-term keys rather than the public keys of Tox DHT -- nodes. data ToxContact = ToxContact NodeId{-me-} NodeId{-them-} deriving (Eq,Ord,Data) instance Show ToxContact where show = show . showToxContact_ showToxContact_ :: ToxContact -> String showToxContact_ (ToxContact me them) = "(" ++ take 8 (show me) ++ ")" ++ show them -- | This type indicates the progress of a tox encrypted friend link -- connection. Two scenarios are illustrated below. The parenthesis show the -- current 'G.Status' 'ToxProgress' of the session. -- -- -- Perfect handshake scenario: -- -- Peer 1 Peer 2 -- (InProgress AcquiringCookie) (Dormant/InProgress AcquiringCookie) -- Cookie request -> -- <- Cookie response -- (InProgress AwaitingHandshake) (Dormant/InProgress AcquiringCookie) -- Handshake packet -> -- * accepts connection -- (InProgress AwaitingSessionPacket) -- <- Handshake packet -- *accepts connection -- (InProgress AwaitingSessionPacket) -- Encrypted packet -> <- Encrypted packet -- *confirms connection *confirms connection -- (Established) (Established) -- -- Connection successful. -- -- Encrypted packets -> <- Encrypted packets -- -- -- -- -- More realistic handshake scenario: -- Peer 1 Peer 2 -- (InProgress AcquiringCookie) (Dormant/InProgress AcquiringCookie) -- Cookie request -> *packet lost* -- Cookie request -> -- <- Cookie response -- (InProgress AwaitingHandshake) (Dormant/InProgress AcquiringCookie) -- -- *Peer 2 randomly starts new connection to peer 1 -- (InProgress AcquiringCookie) -- <- Cookie request -- Cookie response -> -- (InProgress AwaitingHandshake) -- -- Handshake packet -> <- Handshake packet -- *accepts connection * accepts connection -- (InProgress AwaitingSessionPacket) (InProgress AwaitingSessionPacket) -- -- Encrypted packet -> <- Encrypted packet -- *confirms connection *confirms connection -- (Established) (Established) -- -- Connection successful. -- -- Encrypted packets -> <- Encrypted packets data ToxProgress = AwaitingDHTKey -- ^ Waiting to receive their DHT key. | AcquiringIPAddress -- ^ Searching DHT to obtain their node's IP & port. | AcquiringCookie -- ^ Attempting to obtain a cookie. | AwaitingHandshake -- ^ Waiting to receive a handshake. | AwaitingSessionPacket -- ^ Connection is "accepted" but not yet "confirmed". deriving (Eq,Ord,Enum,Show)