{- 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(..) , parseToken32 , showToken32 , nodeInfoFromJSON ) where import Control.Applicative import Control.Arrow import Control.Monad #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.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) #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) -- | Convert to and from a Base64 variant that uses .- instead of +/. nmtoken64 :: Bool -> Char -> Char nmtoken64 False '.' = '+' nmtoken64 False '-' = '/' nmtoken64 True '+' = '.' nmtoken64 True '/' = '-' nmtoken64 _ c = c -- | Parse 43-digit base64 token into 32-byte bytestring. parseToken32 :: String -> Either String ByteString parseToken32 str = fmap (BA.drop 1) $ Base64.decode $ C8.pack $ 'A':map (nmtoken64 False) (take 43 str) -- | Encode 32-byte bytestring as 43-digit base64 token. showToken32 :: ByteArrayAccess bin => bin -> String showToken32 bs = map (nmtoken64 True) $ C8.unpack $ BA.drop 1 $ Base64.encode $ BA.cons 0 $ BA.convert bs instance Read NodeId where readsPrec _ str | (bs,_) <- Base16.decode (C8.pack $ take 64 str) , CryptoPassed pub <- publicKey bs -- B.length bs == 32 = [ (key2id pub, drop (2 * B.length bs) str) ] | Right bs <- parseToken32 str , CryptoPassed pub <- publicKey bs -- B.length bs == 32 = [ (key2id pub, drop 43 str) ] | otherwise = [] instance Show NodeId where show nid = showToken32 $ id2key nid instance S.Serialize NodeId where get = key2id <$> getPublicKey put nid = putPublicKey $ 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) let (bs,_) = Base16.decode (C8.pack nidstr) enid = Base64.decode (C8.pack $ 'A' : map (nmtoken64 False) nidstr) idbs <- (guard (B.length bs == 32) >> return bs) <|> either fail (return . B.drop 1) enid 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 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 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 hexdigit :: Char -> Bool hexdigit c = ('0' <= c && c <= '9') || ( 'a' <= c && c <= 'f') || ( 'A' <= c && c <= 'F') b64digit :: Char -> Bool b64digit '.' = True b64digit '+' = True b64digit '-' = True b64digit '/' = True b64digit c = ('0' <= c && c <= '9') || ( 'a' <= c && c <= 'z') || ( 'A' <= c && c <= 'Z') 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 n = 43 -- characters in node id. parseAddr = RP.between (RP.char '(') (RP.char ')') (RP.munch (/=')')) RP.+++ RP.munch (\c -> not (isSpace c) && not (c `elem` ("{}()"::[Char]))) nodeidAt = do (is64,hexhash) <- fmap (True,) (sequence $ replicate n (RP.satisfy b64digit)) RP.+++ fmap (False,) (sequence $ replicate 64 (RP.satisfy isHexDigit)) RP.char '@' RP.+++ RP.satisfy isSpace addrstr <- parseAddr nid <- if is64 then case Base64.decode $ C8.pack $ 'A' : map (nmtoken64 False) hexhash of Right bs | B.length bs - 1==32 -> return (bs2id $ BA.drop 1 bs) _ -> fail "Bad node id." else case Base16.decode $ C8.pack hexhash of (bs,rem) | B.length bs == 32 && B.null rem -> return (bs2id bs) _ -> fail "Bad node id." return (nid,addrstr) (nid,addrstr) <- ( nodeidAt RP.+++ ( (zeroID,) <$> parseAddr) ) (ip,port) <- case RP.readP_to_S (ip_w_port i) 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. -- -- 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 . (']' :) {- 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 -} 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 :: Monad m => t1 -> Get t -> String -> m (t, t1) base64decode rs getter s = either fail (\a -> return (a,rs)) $ runGet getter =<< Base64.decode (C8.pack $ map (nmtoken64 False) s) base16decode :: Monad m => t1 -> Get t -> String -> m (t, t1) base16decode rs getter s = either 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 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 base64 <- case splitAt 43 $ Text.unpack h of (base64,".tox") -> Right base64 _ -> Left "Hostname should be 43 base64 digits followed by .tox." pub <- id2key <$> readEither base64 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) instance Show ToxContact where show = show . showToxContact_ showToxContact_ :: ToxContact -> String showToxContact_ (ToxContact me them) = 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)