From d2f038970f7ca1af290d27c0a8fd9ee634a28242 Mon Sep 17 00:00:00 2001 From: Balazs Komuves Date: Tue, 28 Apr 2026 20:22:28 +0200 Subject: [PATCH] first working version of (generic) Sphinx header construction and processing --- .gitignore | 1 + reference/Crypto/Symmetric.hs | 137 ++++++++-- reference/Crypto/Symmetric/Blake2b.hs | 2 +- reference/Crypto/Symmetric/HMAC.hs | 3 +- reference/Crypto/Types.hs | 5 +- reference/Crypto/X25519/DH.hs | 64 +++-- reference/Octet.hs | 54 ++-- reference/Sphinx/Header.hs | 371 ++++++++++++++++++++++++++ 8 files changed, 570 insertions(+), 67 deletions(-) create mode 100644 reference/Sphinx/Header.hs diff --git a/.gitignore b/.gitignore index 1779116..206a80d 100644 --- a/.gitignore +++ b/.gitignore @@ -1,4 +1,5 @@ .DS_Store +tmp/ *.a *.o *.hi diff --git a/reference/Crypto/Symmetric.hs b/reference/Crypto/Symmetric.hs index f754e31..8b1e792 100644 --- a/reference/Crypto/Symmetric.hs +++ b/reference/Crypto/Symmetric.hs @@ -5,13 +5,36 @@ module Crypto.Symmetric where -------------------------------------------------------------------------------- --- | Domain separation -data Domain - = SphinxRouteEncKey -- ^ key for encrypting the routing header in Sphinx - | SphinxRouteEncIV -- ^ initialization vector for header stream cipher (if required) - | SphinxMacKey -- ^ key for the MAC in the Sphinx header - | SphinxPayloadEncKey -- ^ key to encrypt the Sphinx payload - | SphinxBlinding -- ^ key to compute the blinding factor +import Data.Bits +import Data.Word + +import qualified Crypto.Symmetric.AES128 as AES128 +import qualified Crypto.Symmetric.SHA256 as SHA256 +import qualified Crypto.Symmetric.Blake2b as Blake2b +import qualified Crypto.Symmetric.HMAC as HMac + +import Crypto.Types +import Octet + +-------------------------------------------------------------------------------- + +-- | Hash functions +data HashFunction + = SHA256 + | Blake2b256 + deriving (Eq,Show) + +-- | Keyed hash functions +data KeyedHash + = KeyedHash_SHA256_Prepend -- ^ @SHA256( key | input )@ + | KeyedHash_Blake2b -- ^ Blake2b support keying natively + | KeyedHash_HMAC_SHA256 -- ^ HMAC can be used as a keyed hash function + deriving (Eq,Show) + +-- | Hash-based message authentication codes +data HMAC + = HMAC128 HashFunction -- ^ standard HMAC + | Blake2bMAC deriving (Eq,Show) -- | Stream ciphers @@ -20,30 +43,21 @@ data StreamCipher | ChaCha20 -- ^ ChaCha20 deriving (Eq,Show ) +-- | Domain separation (for KDFs) +data Domain + = SphinxRouteEncKey -- ^ key for encrypting the routing header in Sphinx + | SphinxRouteEncIV -- ^ initialization vector for header stream cipher (if required) + | SphinxMacKey -- ^ key for the MAC in the Sphinx header + | SphinxPayloadEncKey -- ^ key to encrypt the Sphinx payload + | SphinxBlinding -- ^ key to compute the blinding factor + deriving (Eq,Show) + -- | Key derivation functions data KDF = KDF_SHA256 -- ^ @SHA256( domain | input )@ - | KDF_TurboShake -- ^ @TurboShake( domain | input ) - | KDF_HMAC_SHA256 -- ^ HMAC with `key=domain` - deriving (Eq,Show) - --- | Hash functions -data HashFunction - = SHA256 - | Blake2b256 - deriving (Eq,Show) - --- | Hash-based message authentication codes -data HMAC - = HMAC128 HashFunction - | HMAC256 HashFunction - deriving (Eq,Show) - --- | Keyed hash functions -data KeyedHash - = KeyedHash_SHA256_Prepend -- ^ @SHA256( key | input )@ - | KeyedHash_Blake2b -- ^ Blake2b support keying natively - | KeyedHash_HMAC_SHA256 + | KDF_TurboShake -- ^ @TurboShake( domain | input )@ + | KDF_HMAC_SHA256 -- ^ HMAC with @key=domain@ + | KDF_KeyedBlake2b -- ^ Blake2b with @key=domain@ deriving (Eq,Show) -- | Cipher to encode the Sphinx payload (note: stream ciphers are not a valid choice here!) @@ -52,3 +66,70 @@ data SphinxPayloadCipher deriving (Eq,Show) -------------------------------------------------------------------------------- + +domainConstant :: Domain -> Word128 +domainConstant domain = + case domain of + SphinxRouteEncKey -> asciiStringToWord128 "route-enc-key" + SphinxRouteEncIV -> asciiStringToWord128 "route-enc-iv" + SphinxMacKey -> asciiStringToWord128 "mac-key" + SphinxPayloadEncKey -> asciiStringToWord128 "payload-enc-key" + SphinxBlinding -> asciiStringToWord128 "sphinx-blinding" + where + asciiStringToWord128 :: String -> Word128 + asciiStringToWord128 input + | n <= 16 = W128 (map ord8 input ++ replicate (16-n) 0) + | otherwise = error "stringToWord128: input string longer than 16 characters" + where + n = length input + +domainConstantBytes :: Domain -> [Word8] +domainConstantBytes = fromWord128 . domainConstant + +-------------------------------------------------------------------------------- + +hash :: HashFunction -> [Word8] -> Word256 +hash SHA256 = SHA256.sha256 +hash Blake2b256 = Blake2b.blake2b + +keyedHash :: KeyedHash -> Key -> [Word8] -> Word256 +keyedHash which (Key key) input = case which of + KeyedHash_SHA256_Prepend -> SHA256.sha256 (fromWord128 key ++ input) + KeyedHash_HMAC_SHA256 -> HMac.genericHMac256 (hash SHA256) (Key key) input + KeyedHash_Blake2b -> error "not implemented: KeyedHash_Blake2b" + +hmac :: HMAC -> Key -> [Word8] -> MAC +hmac (HMAC128 hashfun) key msg = MAC $ HMac.genericHMac128 (hash hashfun) key msg + +streamCipherEncrypt :: StreamCipher -> Key -> IV -> [Word128] -> [Word128] +streamCipherEncrypt cipher = case cipher of + AES128_CTR -> AES128.encrypt_AES128CTR + ChaCha20 -> error "not implemented: ChaCha20" + +streamCipherDecrypt :: StreamCipher -> Key -> IV -> [Word128] -> [Word128] +streamCipherDecrypt cipher = case cipher of + AES128_CTR -> AES128.decrypt_AES128CTR + ChaCha20 -> error "not implemented: ChaCha20" + +streamCipherPRG :: StreamCipher -> Key -> IV -> [Word128] +streamCipherPRG cipher = case cipher of + AES128_CTR -> AES128.stream_AES128CTR + ChaCha20 -> error "not implemented: ChaCha20" + +streamCipherPRGBytes :: StreamCipher -> Key -> IV -> [Word8] +streamCipherPRGBytes cipher key iv = concatMap fromWord128 (streamCipherPRG cipher key iv) + +streamCipherXorBytes :: StreamCipher -> Key -> IV -> [Word8] -> [Word8] +streamCipherXorBytes cipher key iv input = zipWith xor input (streamCipherPRGBytes cipher key iv) + +kdf128 :: KDF -> Domain -> [Word8] -> Word128 +kdf128 kdf domain input = truncate128 (kdf256 kdf domain input) + +kdf256 :: KDF -> Domain -> [Word8] -> Word256 +kdf256 kdf domain input = case kdf of + KDF_SHA256 -> SHA256.sha256 (domainConstantBytes domain ++ input) + KDF_HMAC_SHA256 -> HMac.genericHMac256 (hash SHA256) (Key $ domainConstant domain) input + KDF_TurboShake -> error "not implemented: KDF_TurboShake" + KDF_KeyedBlake2b -> error "not implemented: KDF_KeyedBlake2b" + +-------------------------------------------------------------------------------- diff --git a/reference/Crypto/Symmetric/Blake2b.hs b/reference/Crypto/Symmetric/Blake2b.hs index afd895d..92b6ea7 100644 --- a/reference/Crypto/Symmetric/Blake2b.hs +++ b/reference/Crypto/Symmetric/Blake2b.hs @@ -4,7 +4,7 @@ -- See {-# LANGUAGE BangPatterns, TypeApplications, FlexibleInstances, NumericUnderscores #-} -module Ref.Blake2.BLAKE2b where +module Crypto.Symmetric.Blake2b where -------------------------------------------------------------------------------- diff --git a/reference/Crypto/Symmetric/HMAC.hs b/reference/Crypto/Symmetric/HMAC.hs index 1e52083..0bba3a1 100644 --- a/reference/Crypto/Symmetric/HMAC.hs +++ b/reference/Crypto/Symmetric/HMAC.hs @@ -31,7 +31,6 @@ genericHMac256 :: Hash256 -> Key -> Message -> Word256 genericHMac256 hashfun (Key key) msg = outer where outer = hashfun (key_xor_opad ++ toBytesBE inner) - inner = hashfun (key_xor_ipad ++ msg) key_xor_opad = zipWith xor key' opad @@ -44,6 +43,6 @@ genericHMac256 hashfun (Key key) msg = outer where -------------------------------------------------------------------------------- genericHMac128 :: Hash256 -> Key -> Message -> Word128 -genericHMac128 hashfun key msg = fst $ split128 $ genericHMac256 hashfun key msg +genericHMac128 hashfun key msg = truncate128 $ genericHMac256 hashfun key msg -------------------------------------------------------------------------------- diff --git a/reference/Crypto/Types.hs b/reference/Crypto/Types.hs index 5a363e8..a00a06b 100644 --- a/reference/Crypto/Types.hs +++ b/reference/Crypto/Types.hs @@ -20,9 +20,12 @@ newtype IV -- | Message authentication code (128 bits) newtype MAC - = Mac Word128 + = MAC Word128 deriving (Eq,Show) type Message = [Word8] -------------------------------------------------------------------------------- + +macBytes :: MAC -> [Word8] +macBytes (MAC w) = fromWord128 w \ No newline at end of file diff --git a/reference/Crypto/X25519/DH.hs b/reference/Crypto/X25519/DH.hs index 968838d..5b5e099 100644 --- a/reference/Crypto/X25519/DH.hs +++ b/reference/Crypto/X25519/DH.hs @@ -17,23 +17,10 @@ import System.Random import Octet --------------------------------------------------------------------------------- - -sanityDiffieHellman :: IO () -sanityDiffieHellman = do - alice <- randomKeyPair - bob <- randomKeyPair - putStrLn $ "Alice: " ++ show alice - putStrLn $ "Bob: " ++ show bob - let sharedAlice = scalarMul (secretKeyToInteger $ fst alice) (pubKeyToGroup $ snd bob ) - let sharedBob = scalarMul (secretKeyToInteger $ fst bob ) (pubKeyToGroup $ snd alice) - putStrLn $ "shared secret of Alice = " ++ show (xcoordAsWordLE sharedAlice) - putStrLn $ "shared secret of Bob = " ++ show (xcoordAsWordLE sharedBob ) - print (sharedAlice == sharedBob) -------------------------------------------------------------------------------- --- | 32 bytes, little-endian +-- | 32 bytes, little-endian (@X = x/z@ coordinate of the curve point) newtype PubKey = PK Word256 deriving (Eq,Show,IsWord) @@ -43,13 +30,41 @@ newtype SecretKey = SK Word256 deriving (Eq,Show,IsWord) -xcoordAsWordLE :: G -> Word256 -xcoordAsWordLE pt = fromIntegerLE (xcoordAsInteger pt) +fromPubKey :: PubKey -> Word256 +fromPubKey (PK word) = word + +fromSecretKey :: SecretKey -> Word256 +fromSecretKey (SK word) = word + +pubKeyBytes :: PubKey -> [Word8] +pubKeyBytes = fromWord256 . fromPubKey + +secretKeyBytes :: SecretKey -> [Word8] +secretKeyBytes = fromWord256 . fromSecretKey + +-------------------------------------------------------------------------------- secretKeyToPubKey :: SecretKey -> PubKey secretKeyToPubKey sk = pubKeyFromGroup g where g = scalarMul (secretKeyToInteger sk) basePoint +diffieHellmanSharedSecret :: SecretKey -> PubKey -> Word256 +diffieHellmanSharedSecret sk pk + = xcoordAsWordLE + $ scalarMul (secretKeyToInteger sk) (pubKeyToGroup pk) + +-- | Multiply the secret key by an integer (modulo Q). +-- Note: the result does not necessarily satisfy the masking properties; however +-- at least it should remain in the cofactor 8 subgroup, which is the important part (I think...). +blindSecretKey :: Integer -> SecretKey -> SecretKey +blindSecretKey factor sk = secretKeyFromInteger (fromFq product) where + product = toFq factor * toFq (secretKeyToInteger sk) + +blindPublicKey :: Integer -> PubKey -> PubKey +blindPublicKey factor pk = pubKeyFromGroup (scalarMul factor $ pubKeyToGroup pk) + +-------------------------------------------------------------------------------- + -- | Clear bits 0, 1, 2 of the first byte, clear bit 7 of the last -- byte, and set bit 6 of the last byte. (NOTE: it's all little-endian!) maskSecretKey :: Word256 -> SecretKey @@ -71,6 +86,9 @@ randomKeyPair = do let pk = secretKeyToPubKey sk return (sk,pk) +xcoordAsWordLE :: G -> Word256 +xcoordAsWordLE pt = fromIntegerLE (xcoordAsInteger pt) + -------------------------------------------------------------------------------- pubKeyToGroup :: PubKey -> G @@ -92,3 +110,17 @@ secretKeyFromInteger :: Integer -> SecretKey secretKeyFromInteger n = SK (fromIntegerLE n) -------------------------------------------------------------------------------- + +sanityCheckDiffieHellman :: IO () +sanityCheckDiffieHellman = do + alice <- randomKeyPair + bob <- randomKeyPair + putStrLn $ "Alice: " ++ show alice + putStrLn $ "Bob: " ++ show bob + let sharedAlice = scalarMul (secretKeyToInteger $ fst alice) (pubKeyToGroup $ snd bob ) + let sharedBob = scalarMul (secretKeyToInteger $ fst bob ) (pubKeyToGroup $ snd alice) + putStrLn $ "shared secret of Alice = " ++ show (xcoordAsWordLE sharedAlice) + putStrLn $ "shared secret of Bob = " ++ show (xcoordAsWordLE sharedBob ) + print (sharedAlice == sharedBob) + +-------------------------------------------------------------------------------- diff --git a/reference/Octet.hs b/reference/Octet.hs index 3aed034..08c5c3e 100644 --- a/reference/Octet.hs +++ b/reference/Octet.hs @@ -1,4 +1,8 @@ +-- | Dealing with byte sequences +-- +-- (TODO: refactor this to something nicer...) + {-# LANGUAGE ScopedTypeVariables, TypeApplications #-} module Octet where @@ -38,12 +42,12 @@ fromIntegerBE = fromBytes . bytesFromIntegerBE (vecLength (Proxy @a)) -------------------------------------------------------------------------------- --- | 128-bit words, stored in Big-Endian order! +-- | 128-bit words, stored as bytes in Big-Endian order! newtype Word128 = W128 [Word8] deriving Eq --- | 256-bit words, stored in Big-Endian order! +-- | 256-bit words, stored as bytes in Big-Endian order! newtype Word256 = W256 [Word8] deriving Eq @@ -54,11 +58,11 @@ fromWord128 (W128 bs) =bs fromWord256 :: Word256 -> [Word8] fromWord256 (W256 bs) = bs -instance Show Word128 where show (W128 bs) = showBytes bs -instance Show Word256 where show (W256 bs) = showBytes bs +instance Show Word128 where show (W128 bs) = showHexBytes bs +instance Show Word256 where show (W256 bs) = showHexBytes bs -stringToByteList :: String -> [Word8] -stringToByteList = map readByte . splitString where +hexStringToByteList :: String -> [Word8] +hexStringToByteList = map readByte . splitString where readByte :: String -> Word8 readByte [a,b] = read ("0x" ++ [a,b]) @@ -66,25 +70,31 @@ stringToByteList = map readByte . splitString where splitString :: String -> [String] splitString [] = [] splitString (a:b:rest) = [a,b] : splitString rest - splitString [_] = error "stringToByteList: odd length" + splitString [_] = error "hexStringToByteList: odd length" -stringToWord128 :: String -> Word128 -stringToWord128 str +hexStringToWord128 :: String -> Word128 +hexStringToWord128 str | length bs == 16 = W128 bs - | otherwise = error "stringToWord128: expecting 32 hex characters" + | otherwise = error "hexStringToWord128: expecting 32 hex characters" where - bs = stringToByteList str + bs = hexStringToByteList str -stringToWord256 :: String -> Word256 -stringToWord256 str +hexStringToWord256 :: String -> Word256 +hexStringToWord256 str | length bs == 32 = W256 bs - | otherwise = error "stringToWord256: expecting 64 hex characters" + | otherwise = error "hexStringToWord256: expecting 64 hex characters" where - bs = stringToByteList str + bs = hexStringToByteList str -------------------------------------------------------------------------------- -- TODO: make this nicer... +zero128 :: Word128 +zero128 = W128 (replicate 16 0) + +zero256 :: Word256 +zero256 = W256 (replicate 32 0) + xor128 :: Word128 -> Word128 -> Word128 xor128 (W128 as) (W128 bs) = W128 (zipWith xor as bs) @@ -115,6 +125,9 @@ rnd128 = W128 <$> replicateM 16 randomIO rnd256 :: IO Word256 rnd256 = W256 <$> replicateM 32 randomIO +truncate128 :: Word256 -> Word128 +truncate128 = fst . split128 + -------------------------------------------------------------------------------- class IsWord a where @@ -186,14 +199,14 @@ bytesFromIntegerBE len x = reverse (bytesFromIntegerLE len x) -------------------------------------------------------------------------------- -showBytes :: [Word8] -> String -showBytes bs = concat [ printf "%02x" b | b <- bs ] +showHexBytes :: [Word8] -> String +showHexBytes bs = concat [ printf "%02x" b | b <- bs ] toHexStringLE :: IsWord a => a -> String -toHexStringLE = showBytes . toBytesLE +toHexStringLE = showHexBytes . toBytesLE toHexStringBE :: IsWord a => a -> String -toHexStringBE = showBytes . toBytesBE +toHexStringBE = showHexBytes . toBytesBE ord8 :: Char -> Word8 ord8 = fromIntegral . ord @@ -201,6 +214,9 @@ ord8 = fromIntegral . ord chr8 :: Word8 -> Char chr8 = chr . fromIntegral +randomBytes :: Int -> IO [Word8] +randomBytes len = replicateM len randomIO + -------------------------------------------------------------------------------- class ToByteString a where diff --git a/reference/Sphinx/Header.hs b/reference/Sphinx/Header.hs new file mode 100644 index 0000000..3422b73 --- /dev/null +++ b/reference/Sphinx/Header.hs @@ -0,0 +1,371 @@ + +-- | The Sphinx packet format header. +-- +-- See: +-- +-- * George Danezis, Ian Goldberg: "Sphinx: A Compact and Provably Secure Mix Format" +-- +-- +-- + +{-# OPTIONS_GHC -Wno-x-partial #-} +{-# LANGUAGE DeriveGeneric, TypeApplications #-} +module Sphinx.Header where + +-------------------------------------------------------------------------------- + +import Data.Bits +import Data.Word +import Data.Semigroup +import Data.Monoid + +import Control.Monad +import System.Random + +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as L +import GHC.Generics +import Data.Binary + +import Crypto.X25519.DH +import Crypto.X25519.Elliptic +import Crypto.X25519.ScalarField ( Fq , toFq ) + +import Crypto.Symmetric +import Crypto.Types + +import Octet + +-------------------------------------------------------------------------------- +-- * global constants + +-- | Maximum number of hops +maxNumberOfHops :: Int +maxNumberOfHops = 5 + +-- | Targeted security in bits = size of symmetric keys = size of MACs = half the size of private keys +lambda :: Int +lambda = 128 + +lambdaBytes :: Int +lambdaBytes = div lambda 8 + +-------------------------------------------------------------------------------- +-- * crypto primitives + +mixKDF :: Domain -> [Word8] -> Word128 +mixKDF = kdf128 KDF_SHA256 + +mixMAC :: Key -> [Word8] -> MAC +mixMAC = hmac (HMAC128 SHA256) + +mixPRG :: Key -> IV -> [Word8] +mixPRG = streamCipherPRGBytes AES128_CTR + +mixRouteEnc :: Key -> IV -> [Word8] -> [Word8] +mixRouteEnc key iv input = zipWith xor input (mixPRG key iv) + +mixRouteDec :: Key -> IV -> [Word8] -> [Word8] +mixRouteDec = mixRouteEnc + +-------------------------------------------------------------------------------- +-- * types + +-- | Size of something measured in bytes +type SizeInBytes = Int + +-- | The actual number of hops. Can be less or equal to @maxNumberOfHops@. +type NHops = Int + +-- | A destination address is usually outside the mix network. We represent it by +-- a string (padded to a fixed length) +type DestinationAddr = String + +-- | A mix node address should be represented as a fixed length bytestring +newtype MixAddr + = MkMixAddr [Word8] + deriving (Eq,Show) + +-- | A (random) message identifier, to identify replies. +type MessageId = Word128 + +-- | A mix node (extenal view) has a public key and an address +data MixNodeExt = MkMixNodeExt + { nodePubKey :: PubKey + , nodeAddress :: MixAddr + } + deriving (Eq,Show) + +-- | Internally, a mix node also has a private key (required for processing) +data MixNodeInt = MkMixNodeInt + { nodePrivKey :: SecretKey + , nodeExt :: MixNodeExt + } + deriving (Eq,Show) + +data Address + = ForwardDestination !DestinationAddr + | ReplyDestination !DestinationAddr + | MixNode !MixAddr + deriving (Eq,Show) + +-- | A mix path is a route consisting of several mix nodes +type MixPath = [MixNodeInt] + +-- | A Sphinx header consists of three part, denoted (after the Sphinx paper) by alpha, beta, and gamma. +data SphinxHeader = MkHeader + { sphinxAlpha :: PubKey -- ^ blinded per-hop public key + , sphinxBeta :: [Word8] -- ^ encrypted routing info + , sphinxGamma :: MAC -- ^ MAC of beta + } + deriving (Eq) -- ,Show) + +instance Show SphinxHeader where + show (MkHeader alpha beta gamma) = unlines + [ "alpha = " ++ show alpha + , "beta = " ++ showHexBytes beta + , "gamma = " ++ show gamma + ] + +-------------------------------------------------------------------------------- +-- * per-hop secrets + +data PerHopSecrets = MkPerHopSecrets + { hopSecretKey :: SecretKey -- ^ per-node secret key @x@ (an element of the scalar field) + , hopPublicKey :: PubKey -- ^ per-node public key @alpha@ (an element of the elliptic curve group) + , hopSharedSecret :: Word256 -- ^ per-node shared secret @s@ (a group element interpreted as 32 bytes) + , hopBlindingFactor :: Fq -- ^ the blinding factor @b@ is also an element of the scalar field + } + deriving (Eq,Show) + +-- TODO: really the blinder should be computed by a "proper" KDF, but everybody out there just uses plain SHA256... +computeBlinder :: PubKey -> Word256 -> Integer +computeBlinder alpha sharedSecret = toIntegerLE blinder where + blindInput = pubKeyBytes alpha ++ fromWord256 sharedSecret :: [Word8] + blinder = hash SHA256 blindInput :: Word256 + +computePerHopSecrets :: SecretKey -> [MixNodeExt] -> [PerHopSecrets] +computePerHopSecrets initialSecret path = go initialSecret path where + go :: SecretKey -> [MixNodeExt] -> [PerHopSecrets] + go _ [] = [] + go x (mixnode:rest) = this : go x' rest where + alpha = secretKeyToPubKey x :: PubKey + shared = diffieHellmanSharedSecret x (nodePubKey mixnode) :: Word256 + blindInput = pubKeyBytes alpha ++ fromWord256 shared :: [Word8] + blinder = computeBlinder alpha shared :: Integer + x' = blindSecretKey blinder x + this = MkPerHopSecrets + { hopSecretKey = x + , hopPublicKey = alpha + , hopSharedSecret = shared + , hopBlindingFactor = toFq blinder + } + +-------------------------------------------------------------------------------- +-- * filler strings + +newtype Filler + = Filler [Word8] + deriving (Eq) + +instance Show Filler where + show (Filler bs) = "<" ++ showHexBytes bs ++ ">" + +fromFiller :: Filler -> [Word8] +fromFiller (Filler ws) = ws + +emptyFiller :: Filler +emptyFiller = Filler [] + +zeroFiller :: SizeInBytes -> Filler +zeroFiller len = Filler $ replicate len 0 + +fillerSize :: Filler -> SizeInBytes +fillerSize (Filler bs) = length bs + +instance Semigroup Filler where + (<>) (Filler ws1) (Filler ws2) = Filler (ws1 ++ ws2) + +instance Monoid Filler where + mempty = emptyFiller + +-- | compute the both the unencrypted (plain) and encrypted fillers +computeAllFillers :: SizeInBytes -> [(PerHopSecrets,SizeInBytes)] -> [Filler] +computeAllFillers headerBetaSize hops + | padding < 0 = error "computeFillers: cannot fit in the given header beta size" + | otherwise = go emptyFiller hops + where + used = sum (map snd hops) + padding = headerBetaSize - used + + go :: Filler -> [(PerHopSecrets,SizeInBytes)] -> [Filler] + go prev [] = [] + go prev ((perhop,size):rest) = prev : go this rest where + ss = fromWord256 $ hopSharedSecret perhop + key = Key (mixKDF SphinxRouteEncKey ss) + iv = IV (mixKDF SphinxRouteEncIV ss) + thisPlain = fromFiller (prev <> zeroFiller size) + this = Filler $ zipWith xor thisPlain (drop padlen $ mixPRG key iv) + padlen = headerBetaSize - fillerSize prev + +computeFinalFiller :: SizeInBytes -> [(PerHopSecrets,SizeInBytes)] -> Filler +computeFinalFiller headerBetaSize perHops = last $ computeAllFillers headerBetaSize perHops + +-------------------------------------------------------------------------------- +-- * constructing mix headers + +encodeIntoBytes :: Binary a => a -> [Word8] +encodeIntoBytes = L.unpack . encode + +decodeFromBytes :: Binary a => [Word8] -> Maybe (a, SizeInBytes, [Word8]) +decodeFromBytes what = case decodeOrFail (L.pack what) of + Left _ -> Nothing + Right (rest,size,y) -> Just (y, fromIntegral size, L.unpack rest) + +computeHeaderGeneric :: Binary route => SizeInBytes -> [(PerHopSecrets,route)] -> SphinxHeader +computeHeaderGeneric betaSize hops = head $ computeAllHeadersGeneric betaSize hops + +data NextBeta + = NextBeta { _nextBeta :: [Word8] , _nextMac :: [Word8] } -- ^ @beta, gamma@ + | FinalBeta { _nextBeta :: [Word8] , _nextFiller :: Filler } -- ^ @beta, filler@ + deriving Show + +computeAllHeadersGeneric :: Binary route => SizeInBytes -> [(PerHopSecrets,route)] -> [SphinxHeader] +computeAllHeadersGeneric headerBetaSize hops + | sum sizes > headerBetaSize = error "computeHeadersGeneric: total route size is larger than the header beta size" + | otherwise = reverse $ worker finalBeta $ reverse (zip perhops routes) + where + nhops = length hops + perhops = map fst hops :: [PerHopSecrets] + routes = map (encodeIntoBytes . snd) hops :: [[Word8]] + sizes = map length routes :: [SizeInBytes] + + -- add the size of the mac to the size of the route, except for the final destination + addMacSize :: [SizeInBytes] -> [SizeInBytes] + addMacSize [] = [] + addMacSize [final] = [final] + addMacSize (n:ns) = (n+16) : addMacSize ns + + finalFiller = computeFinalFiller headerBetaSize (zip perhops $ addMacSize sizes) + finalRoute = last routes + finalPad = headerBetaSize - length finalRoute - fillerSize finalFiller + finalBeta = FinalBeta (replicate finalPad 0) finalFiller + + worker :: NextBeta -> [(PerHopSecrets, [Word8])] -> [SphinxHeader] + worker next [] = [] + worker next ((perhop,route):rest) = header : worker next' rest where + + ss = fromWord256 $ hopSharedSecret perhop + encKey = Key (mixKDF SphinxRouteEncKey ss) + encIV = IV (mixKDF SphinxRouteEncIV ss) + macKey = Key (mixKDF SphinxMacKey ss) + + encrypt :: [Word8] -> [Word8] + encrypt = mixRouteEnc encKey encIV + + beta = case next of + NextBeta nextBeta nextGamma -> encrypt $ take headerBetaSize $ (route ++ nextGamma ++ nextBeta) + FinalBeta nextBeta filler -> encrypt (route ++ nextBeta) ++ fromFiller filler + + alpha = hopPublicKey perhop + gamma = mixMAC macKey beta + header = MkHeader alpha beta gamma + next' = NextBeta beta (macBytes gamma) + +-------------------------------------------------------------------------------- +-- * processing mix headers + +processMixHeaderGeneric :: Binary route => MixNodeInt -> SphinxHeader -> Either String (route, SphinxHeader) +processMixHeaderGeneric mixNode (MkHeader alpha beta gamma) = + if gamma /= macBeta + then Left $ "MAC of beta doesn't match\n - header gamma = " ++ show gamma ++ "\n - MAC(beta) = " ++ show macBeta + else case decodeFromBytes betaTilde of + Nothing -> Left "cannot parse beginning of beta" + Just (route, _size, rest) -> Right (route, MkHeader alpha' beta' gamma') where + (gamma1, rest1) = splitAt 16 rest + gamma' = MAC (W128 gamma1) + beta' = take betaSize rest1 + + where + shared = diffieHellmanSharedSecret (nodePrivKey mixNode) alpha + ss = fromWord256 shared + encKey = Key (mixKDF SphinxRouteEncKey ss) + encIV = IV (mixKDF SphinxRouteEncIV ss) + macKey = Key (mixKDF SphinxMacKey ss) + + betaSize = length beta + macBeta = mixMAC macKey beta + betaTilde = mixRouteDec encKey encIV (beta ++ replicate betaSize 0) -- we don't know yet how long "route" is, so just add enough zeros lol + + blinder = computeBlinder alpha shared + alpha' = blindPublicKey blinder alpha + +-------------------------------------------------------------------------------- +-- * generate random mix nodes + +randomMixAddr :: Int -> IO MixAddr +randomMixAddr len = MkMixAddr <$> replicateM len randomIO + +randomMixNode :: IO MixNodeInt +randomMixNode = do + (sk,pk) <- randomKeyPair + addr <- randomMixAddr 16 + let nodeExt = MkMixNodeExt + { nodePubKey = pk + , nodeAddress = addr + } + return $ MkMixNodeInt + { nodePrivKey = sk + , nodeExt = nodeExt + } + +randomMixPath :: NHops -> IO [MixNodeInt] +randomMixPath nhops = replicateM nhops randomMixNode + +-------------------------------------------------------------------------------- +-- * testing + +data TestRouting + = A String + | B Int + | C Bool [Int] + | F String + deriving (Eq,Show,Generic) + +instance Binary TestRouting + +testRoute :: [TestRouting] +testRoute = + [ A "foobar" + , B 1137 + , C True [3,4,5] + , A "whatever" + , A "almafa" + , B 777 + , F "final destination" + ] + +testProcess :: [MixNodeInt] -> SphinxHeader -> [TestRouting] +testProcess = go 0 where + go idx [] _ = [] + go idx (node:nodes) header = case processMixHeaderGeneric node header of + Left errmsg -> error $ "error at hop #" ++ show idx ++ ": " ++ errmsg + Right (route,header') -> route : go (idx+1) nodes header' + +testMain :: IO () +testMain = do + let headerBetaSize = 250 + sk <- randomSecretKey + let route = testRoute + let nhops = length route + mixpath <- randomMixPath nhops + let perhopsecrets = computePerHopSecrets sk (map nodeExt mixpath) + + let headers = computeAllHeadersGeneric headerBetaSize (zip perhopsecrets route) + -- mapM_ print headers + let header = head headers + print $ map (length . sphinxBeta) headers + print $ testProcess mixpath header + +-------------------------------------------------------------------------------- +