diff --git a/.gitignore b/.gitignore index 9f13c47..7b5fbc2 100644 --- a/.gitignore +++ b/.gitignore @@ -6,3 +6,4 @@ dist-newstyle/ *.o *.hi .ghc.environment* +cabal.project \ No newline at end of file diff --git a/README.md b/README.md index aa824a3..72d271d 100644 --- a/README.md +++ b/README.md @@ -7,7 +7,7 @@ a transport abstraction layer over the [Mix Protocol](https://lip.logos.co/ift-t The idea is to hide the packet size and other limitations of Mix behind a nice abstraction layer, so applications can pretend they are communicating over a "normal" network not unlike TCP (a very slow, and moderately reliable, -but otherwise pretty normally behaving network). +but otherwise pretty normally behaving network socket). -Furthermore, we also take the opportunity to document both the Sphinx mix packet -format, and SURBs (Single Use Reply Blocks). +Furthermore, we also take the opportunity to document (including an executable +specification) both the Sphinx mix packet format, and SURBs (Single Use Reply Blocks). diff --git a/reference/Crypto/Lioness.hs b/reference/Crypto/PRP/Lioness.hs similarity index 95% rename from reference/Crypto/Lioness.hs rename to reference/Crypto/PRP/Lioness.hs index 22df5f3..c383092 100644 --- a/reference/Crypto/Lioness.hs +++ b/reference/Crypto/PRP/Lioness.hs @@ -7,17 +7,19 @@ -- {-# LANGUAGE NumericUnderscores #-} -module Crypto.Lioness where +module Crypto.PRP.Lioness where -------------------------------------------------------------------------------- import Data.Bits import Data.Word +import qualified Data.ByteString as B + import Crypto.Symmetric -- for testing only?? import Crypto.Types -import Octet +import Data.Octets -------------------------------------------------------------------------------- @@ -66,6 +68,9 @@ xorWithKey (Key256 key) bytes = Key256 $ W256 $ xorBytes bytes (fromWord256 key) -------------------------------------------------------------------------------- +lionessPermBS :: LionessInstance -> Key256 -> B.ByteString -> B.ByteString +lionessPermBS inst key = B.pack . lionessPerm inst key . B.unpack + lionessPerm :: LionessInstance -> Key256 -> [Word8] -> [Word8] lionessPerm inst@(MkLioness kdfFun hashFun streamFun) masterKey input | n < 64 = error "lionessPerm: input is too small (the minimum is 64 bytes)" diff --git a/reference/Crypto/Symmetric.hs b/reference/Crypto/Symmetric.hs index ca6da40..d225d61 100644 --- a/reference/Crypto/Symmetric.hs +++ b/reference/Crypto/Symmetric.hs @@ -14,7 +14,7 @@ import qualified Crypto.Symmetric.Blake2b as Blake2b import qualified Crypto.Symmetric.HMAC as HMac import Crypto.Types -import Octet +import Data.Octets -------------------------------------------------------------------------------- diff --git a/reference/Crypto/Symmetric/AES128.hs b/reference/Crypto/Symmetric/AES128.hs index 9422440..2f18ebd 100644 --- a/reference/Crypto/Symmetric/AES128.hs +++ b/reference/Crypto/Symmetric/AES128.hs @@ -16,7 +16,7 @@ import Data.Int -- import Text.Printf -import Octet +import Data.Octets import Crypto.Types -------------------------------------------------------------------------------- diff --git a/reference/Crypto/Symmetric/Blake2b.hs b/reference/Crypto/Symmetric/Blake2b.hs index 92b6ea7..46f1fa7 100644 --- a/reference/Crypto/Symmetric/Blake2b.hs +++ b/reference/Crypto/Symmetric/Blake2b.hs @@ -14,10 +14,12 @@ import Data.Bits import Data.Char import Data.List hiding (partition) -import Octet +import Data.Octets -------------------------------------------------------------------------------- +-- TODO: implement keyed version + kk = 0 -- key bytes nn = 32 -- output bytes diff --git a/reference/Crypto/Symmetric/HMAC.hs b/reference/Crypto/Symmetric/HMAC.hs index d64bc17..ff70334 100644 --- a/reference/Crypto/Symmetric/HMAC.hs +++ b/reference/Crypto/Symmetric/HMAC.hs @@ -9,7 +9,7 @@ import Data.Char import Crypto.Symmetric.SHA256 -import Octet +import Data.Octets import Crypto.Types -------------------------------------------------------------------------------- diff --git a/reference/Crypto/Symmetric/SHA256.hs b/reference/Crypto/Symmetric/SHA256.hs index 56f9f8a..70d2b5e 100644 --- a/reference/Crypto/Symmetric/SHA256.hs +++ b/reference/Crypto/Symmetric/SHA256.hs @@ -19,7 +19,7 @@ import Data.Word import Data.ByteString (ByteString) import qualified Data.ByteString as B -import Octet +import Data.Octets -------------------------------------------------------------------------------- diff --git a/reference/Crypto/Types.hs b/reference/Crypto/Types.hs index 26008c3..4d229d7 100644 --- a/reference/Crypto/Types.hs +++ b/reference/Crypto/Types.hs @@ -4,7 +4,7 @@ module Crypto.Types where -------------------------------------------------------------------------------- import Data.Word -import Octet +import Data.Octets -------------------------------------------------------------------------------- diff --git a/reference/Crypto/X25519/DH.hs b/reference/Crypto/X25519/DH.hs index 5d1d735..b4c7f6d 100644 --- a/reference/Crypto/X25519/DH.hs +++ b/reference/Crypto/X25519/DH.hs @@ -16,8 +16,7 @@ import Crypto.X25519.Elliptic import Control.Monad import System.Random -import Octet - +import Data.Octets -------------------------------------------------------------------------------- diff --git a/reference/Octet.hs b/reference/Data/Octets.hs similarity index 99% rename from reference/Octet.hs rename to reference/Data/Octets.hs index 08c5c3e..6306b3f 100644 --- a/reference/Octet.hs +++ b/reference/Data/Octets.hs @@ -4,7 +4,7 @@ -- (TODO: refactor this to something nicer...) {-# LANGUAGE ScopedTypeVariables, TypeApplications #-} -module Octet where +module Data.Octets where -------------------------------------------------------------------------------- diff --git a/reference/Mix/Address.hs b/reference/Mix/Address.hs new file mode 100644 index 0000000..8aa6db3 --- /dev/null +++ b/reference/Mix/Address.hs @@ -0,0 +1,71 @@ + +-- | Mix address field encoding + +{-# LANGUAGE StrictData #-} +module Mix.Address where + +-------------------------------------------------------------------------------- + +import Data.Word + +import Control.Monad +import System.Random + +import Data.Octets + +-------------------------------------------------------------------------------- +-- * network addresses + +-- | We encode networks addresses as strings for simplicity +type NetworkAddress = String + +-- | Compressed mix addresses are something like a hash +newtype ComprMixAddr + = MkMixAddr [Word8] + deriving (Eq,Show) + +-- | A mix node can have a full address or a compressed address +data MixAddress + = CompressedMixAddr ComprMixAddr + | FullMixAddr NetworkAddress + deriving (Eq,Show) + +-- | An address can be a mix node or an external address +data SomeAddress + = MixAddress MixAddress + | ExternalAddress NetworkAddress + deriving (Eq,Show) + +-------------------------------------------------------------------------------- +-- * delays + +newtype DelayHint + = DelayHint Word16 + deriving (Eq,Show) + +randomDelayHint :: IO DelayHint +randomDelayHint = DelayHint <$> randomRIO (1,2^15-1) + +-------------------------------------------------------------------------------- +-- * mix addresses + +data TransportVersion + = TransportVersion1 + deriving (Eq,Show) + +data RecvProtocol + = BasicMixProtocol -- ^ just sending packets + | MixTransportProtocol TransportVersion -- ^ it's the transport layer protocol + deriving (Eq,Show) + +data FwdAddress + = ForwardingHop MixAddress + | FinalHop RecvProtocol SomeAddress + deriving (Eq,Show) + +-- | An address field contains a delay hint, and an forwarding address +data AddressField + = MkAddressField DelayHint FwdAddress + deriving (Eq,Show) + +-------------------------------------------------------------------------------- diff --git a/reference/Mix/Packet.hs b/reference/Mix/Packet.hs new file mode 100644 index 0000000..236e759 --- /dev/null +++ b/reference/Mix/Packet.hs @@ -0,0 +1,18 @@ + +module Mix.Packet where + +-------------------------------------------------------------------------------- + +import Data.Word +import Sphinx.Header +import Mix.Address + +-------------------------------------------------------------------------------- + +data MixPacket = MkMixPacket + { mixHeader :: SphinxHeader + , mixPayload :: ByteString + } + deriving (Eq) + +-------------------------------------------------------------------------------- diff --git a/reference/Sphinx/Header.hs b/reference/Sphinx/Header.hs index 3422b73..7fff7af 100644 --- a/reference/Sphinx/Header.hs +++ b/reference/Sphinx/Header.hs @@ -4,8 +4,9 @@ -- See: -- -- * George Danezis, Ian Goldberg: "Sphinx: A Compact and Provably Secure Mix Format" +-- -- --- +-- * see also the @docs@ subdirectory in this repo -- {-# OPTIONS_GHC -Wno-x-partial #-} @@ -34,7 +35,7 @@ import Crypto.X25519.ScalarField ( Fq , toFq ) import Crypto.Symmetric import Crypto.Types -import Octet +import Data.Octets -------------------------------------------------------------------------------- -- * global constants @@ -43,12 +44,14 @@ import Octet 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 @@ -62,11 +65,9 @@ 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) +mixRouteEncDec :: Key -> IV -> [Word8] -> [Word8] +mixRouteEncDec key iv input = zipWith xor input (mixPRG key iv) -mixRouteDec :: Key -> IV -> [Word8] -> [Word8] -mixRouteDec = mixRouteEnc -------------------------------------------------------------------------------- -- * types @@ -77,40 +78,42 @@ 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 +-- | A compressed mix node address should be represented as a fixed length bytestring +newtype ComprMixAddr = 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 node (extenal view) has a public key and an address +data MixNodeExt addr = MkMixNodeExt + { nodePubKey :: PubKey + , nodeAddress :: addr + } + deriving (Eq,Show) + +-- | Internally, a mix node also has a private key (required for processing) +data MixNodeInt addr = MkMixNodeInt + { nodePrivKey :: SecretKey + , nodeExt :: MixNodeExt addr + } + deriving (Eq,Show) -- | A mix path is a route consisting of several mix nodes -type MixPath = [MixNodeInt] +type MixPath addr = [MixNodeInt addr] -- | A Sphinx header consists of three part, denoted (after the Sphinx paper) by alpha, beta, and gamma. data SphinxHeader = MkHeader @@ -144,9 +147,9 @@ computeBlinder alpha sharedSecret = toIntegerLE blinder where blindInput = pubKeyBytes alpha ++ fromWord256 sharedSecret :: [Word8] blinder = hash SHA256 blindInput :: Word256 -computePerHopSecrets :: SecretKey -> [MixNodeExt] -> [PerHopSecrets] +computePerHopSecrets :: SecretKey -> [MixNodeExt addr] -> [PerHopSecrets] computePerHopSecrets initialSecret path = go initialSecret path where - go :: SecretKey -> [MixNodeExt] -> [PerHopSecrets] + go :: SecretKey -> [MixNodeExt addr] -> [PerHopSecrets] go _ [] = [] go x (mixnode:rest) = this : go x' rest where alpha = secretKeyToPubKey x :: PubKey @@ -261,7 +264,7 @@ computeAllHeadersGeneric headerBetaSize hops macKey = Key (mixKDF SphinxMacKey ss) encrypt :: [Word8] -> [Word8] - encrypt = mixRouteEnc encKey encIV + encrypt = mixRouteEncDec encKey encIV beta = case next of NextBeta nextBeta nextGamma -> encrypt $ take headerBetaSize $ (route ++ nextGamma ++ nextBeta) @@ -275,7 +278,7 @@ computeAllHeadersGeneric headerBetaSize hops -------------------------------------------------------------------------------- -- * processing mix headers -processMixHeaderGeneric :: Binary route => MixNodeInt -> SphinxHeader -> Either String (route, SphinxHeader) +processMixHeaderGeneric :: Binary route => MixNodeInt addr -> 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 @@ -295,7 +298,7 @@ processMixHeaderGeneric mixNode (MkHeader alpha beta gamma) = 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 + betaTilde = mixRouteEncDec 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 @@ -303,13 +306,10 @@ processMixHeaderGeneric mixNode (MkHeader alpha beta gamma) = -------------------------------------------------------------------------------- -- * generate random mix nodes -randomMixAddr :: Int -> IO MixAddr -randomMixAddr len = MkMixAddr <$> replicateM len randomIO - -randomMixNode :: IO MixNodeInt -randomMixNode = do +randomMixNode' :: IO addr -> IO (MixNodeInt addr) +randomMixNode' mkRndAddr = do (sk,pk) <- randomKeyPair - addr <- randomMixAddr 16 + addr <- mkRndAddr -- randomMixAddr 16 let nodeExt = MkMixNodeExt { nodePubKey = pk , nodeAddress = addr @@ -319,11 +319,18 @@ randomMixNode = do , nodeExt = nodeExt } -randomMixPath :: NHops -> IO [MixNodeInt] -randomMixPath nhops = replicateM nhops randomMixNode +randomMixPath' :: IO addr -> NHops -> IO [MixNodeInt addr] +randomMixPath' mkRndAddr nhops = replicateM nhops (randomMixNode' mkRndAddr) -------------------------------------------------------------------------------- --- * testing +-- * basic sanity check testing + +newtype TmpAddr + = MkTmpAddr [Word8] + deriving (Eq,Show) + +randomTmpAddr :: Int -> IO TmpAddr +randomTmpAddr len = MkTmpAddr <$> replicateM len randomIO data TestRouting = A String @@ -345,7 +352,7 @@ testRoute = , F "final destination" ] -testProcess :: [MixNodeInt] -> SphinxHeader -> [TestRouting] +testProcess :: [MixNodeInt TmpAddr] -> SphinxHeader -> [TestRouting] testProcess = go 0 where go idx [] _ = [] go idx (node:nodes) header = case processMixHeaderGeneric node header of @@ -358,7 +365,7 @@ testMain = do sk <- randomSecretKey let route = testRoute let nhops = length route - mixpath <- randomMixPath nhops + mixpath <- randomMixPath' (randomTmpAddr 16) nhops let perhopsecrets = computePerHopSecrets sk (map nodeExt mixpath) let headers = computeAllHeadersGeneric headerBetaSize (zip perhopsecrets route) diff --git a/reference/Transport/Chunks.hs b/reference/Transport/Chunks.hs new file mode 100644 index 0000000..6363d36 --- /dev/null +++ b/reference/Transport/Chunks.hs @@ -0,0 +1,176 @@ + +-- | For transporting data not fitting into a single Mix packet, we need +-- to chunk it (ideally with redundancy) +-- + +{-# LANGUAGE StrictData, RecordWildCards, DerivingVia #-} +module Transport.Chunks where + +-------------------------------------------------------------------------------- + +import Data.Bits +import Data.Word +import Data.Array + +import Data.ByteString (ByteString ) ; import qualified Data.ByteString as B +import Data.ByteString.Lazy (LazyByteString) ; import qualified Data.ByteString.Lazy as L +import Data.Binary +import Data.Binary.Get +import Data.Binary.Put + +import Control.Monad + +-- import Leopard.Binding +-- import Leopard.Types +import Leopard.Misc + +import Transport.Types +import Transport.Misc + +-------------------------------------------------------------------------------- +-- TODO: move these somewhere else + +-- | Payload size including the integerity check @= |delta|@ +grossPayloadSize :: Int +grossPayloadSize = 4096 + 16 + 24 + +-- | Payload size without the integerity check (and other metadata) +netPayloadSize :: Int +netPayloadSize = grossPayloadSize - 16 + +-------------------------------------------------------------------------------- + +-- | normally 16 + 8 = 24 bytes +chunkMetaSize :: Int +chunkMetaSize = sessionIdSize + 4 + 2 + 2 + +-- | Should by divisible by 64 (because of Leopard restriction) +chunkDataSize :: Int +chunkDataSize = netPayloadSize - chunkMetaSize + +-------------------------------------------------------------------------------- + +-- | We prepend the length of the payload, then pad to a multiple of chunk data size, +-- partition into pieces, and prepare each chunk's metadata +chunkMsgPayload :: SessionId -> MsgIdx -> ByteString -> Array Int Chunk +chunkMsgPayload sessionId msgIdx msgPayload = arr where + padded = buildLazyByteString (putMsgPayload msgPayload) + m = fromIntegral (L.length padded) + (k,0) = divMod m chunkDataSize + nOrigs = fromIntegral k + pieces = partitionLazyByteString chunkDataSize padded + arr = listArray (0,k-1) + [ MkChunk (MkChunkMeta sessionId msgIdx nOrigs) i (L.toStrict dat) | (i,dat) <- zip [0..] pieces ] + +-- | Before chunking, we encoded message payloads by prepending their length (8 bytes), +-- and then padding with zero bytes. We need to reverse this after recovering from EC chunks +parseMsgPayload :: ByteString -> Maybe ByteString +parseMsgPayload bs = case runGetOrFail getMsgPayload (L.fromStrict bs) of + Left _ -> Nothing + Right (rem, _, out) -> Just out + +putMsgPayload :: ByteString -> Put +putMsgPayload rawmsg = do + putWord64be (fromIntegral rawlen) + putByteString rawmsg + putByteString (B.replicate padlen 0) + where + padlen = requiredPadToMultipleOf chunkDataSize (rawlen + 8) + rawlen = B.length rawmsg + +getMsgPayload :: Get ByteString +getMsgPayload = do + len <- getWord64be + getByteString (fromIntegral len) + +partitionLazyByteString :: Int -> L.ByteString -> [L.ByteString] +partitionLazyByteString m = go where + m64 = fromIntegral m + go lbs = if L.null lbs + then [] + else L.take m64 lbs : go (L.drop m64 lbs) + +-------------------------------------------------------------------------------- + +-- | Note: We don't need the the number of parity chunks, because we think of the parity +-- in a streaming fashion. We send some amount of parity chunks initially, and if the other party +-- doesn't receive enough data to reconstruct, we can simply send more parity chunks +-- +data ChunkMeta = MkChunkMeta + { _cmSessionId :: SessionId -- ^ session id + , _cmMessageIdx :: Word32 -- ^ message index within the session + , _cmNOrigChunks :: Word16 -- ^ K = number of chunks containing the original data + } + deriving (Eq,Show) + +data Chunk = MkChunk + { _chunkMeta :: ChunkMeta -- ^ metadata shared by all chunks of a message + , _chunkIndex :: Word16 -- ^ index of this chunk (0 <= idx < K is original chunk, K >= idx is parity chunk) + , _chunkData :: ByteString -- ^ chunk raw data (usually an EC chunk) + } + deriving Eq + +instance Show Chunk where + show (MkChunk meta idx dat) + = "MkChunk" + ++ " { _chunkMeta = " ++ show meta + ++ " ; _chunkIndex = " ++ show idx + ++ " ; _chunkData = " ++ showByteString dat + ++ " }" + +-------------------------------------------------------------------------------- +-- * Serialization + +encodeChunk :: Chunk -> ByteString +encodeChunk = buildStrictByteString . putChunk + +buildStrictByteString :: Put -> ByteString +buildStrictByteString = B.toStrict . buildLazyByteString + +buildLazyByteString :: Put -> L.ByteString +buildLazyByteString = runPut + +putChunk :: Chunk -> Put +putChunk (MkChunk meta idx raw) = do + putChunkMeta meta + putWord16be idx + putByteString raw + +putChunkMeta :: ChunkMeta -> Put +putChunkMeta (MkChunkMeta{..}) = do + putSessionId _cmSessionId + putWord32be _cmMessageIdx + putWord16be _cmNOrigChunks + +putSessionId :: SessionId -> Put +putSessionId (MkSessionId bytes) = mapM_ putWord8 bytes + +---------------------------------------- +-- * Deserialization + +decodeChunk :: ByteString -> Maybe Chunk +decodeChunk = decodeChunkLazy . L.fromStrict + +decodeChunkLazy :: LazyByteString -> Maybe Chunk +decodeChunkLazy bs = case runGetOrFail getChunk bs of + Left _ -> Nothing + Right (rem, _, ck) -> if L.null rem + then Just ck + else Nothing + +getChunk :: Get Chunk +getChunk = MkChunk + <$> getChunkMeta + <*> getWord16be + <*> getByteString chunkDataSize + +getChunkMeta :: Get ChunkMeta +getChunkMeta = MkChunkMeta + <$> getSessionId + <*> getWord32be + <*> getWord16be + +getSessionId :: Get SessionId +getSessionId = MkSessionId <$> replicateM sessionIdSize getWord8 + +-------------------------------------------------------------------------------- diff --git a/reference/Transport/EC.hs b/reference/Transport/EC.hs new file mode 100644 index 0000000..0c47fbf --- /dev/null +++ b/reference/Transport/EC.hs @@ -0,0 +1,216 @@ + +-- | Erasure coding of chunks + +{-# OPTIONS_GHC -Wno-x-partial #-} +{-# LANGUAGE StrictData, RecordWildCards, DerivingVia #-} +module Transport.EC where + +-------------------------------------------------------------------------------- + +import Data.Bits +import Data.Word +import Data.Array +import Data.List +import Data.Ord +import Data.Maybe + +import Data.ByteString (ByteString ) ; import qualified Data.ByteString as B +import Data.ByteString.Lazy (LazyByteString) ; import qualified Data.ByteString.Lazy as L + +import Control.Monad +import System.IO.Unsafe +import System.Random + +import Leopard.Binding +import Leopard.Types +import Leopard.Misc + +import Transport.Chunks +import Transport.Types +import Transport.Misc + +-------------------------------------------------------------------------------- +-- * sanity check "testing" + +findCounterExample :: IO () +findCounterExample = do + putStrLn "---------------------------------" + ok <- testEC + when ok findCounterExample + +testEC :: IO Bool +testEC = withLeopard $ do + sessionId <- randomSessionId + msgIdx <- randomRIO (0,99) + len <- randomRIO (5000,50000) -- singleton chunks need to be handled specially... + payload <- randomByteString len + + let origChunksArr = chunkMsgPayload sessionId msgIdx payload + let origChunks = elems origChunksArr + let ecK = length origChunks + let ecM = deterministicParityCount ecK -- min 5 ecK + + let parityChunks = computeParityChunks' ecM origChunks + let allChunks = origChunks ++ parityChunks + let ecN = length allChunks + + bad <- randomRIO (0,ecM+1) + received <- catMaybes <$> maskListRandomly bad allChunks + + -- putStrLn $ "chunks received:" + -- forM_ received $ \chunk -> do + -- putStrLn $ " - " ++ show chunk + -- putStrLn "" + + putStrLn $ "chunks received = " ++ show (map _chunkIndex received) + + let ei = decodeFromChunks received + + putStrLn $ "session id = " ++ show sessionId + putStrLn $ "message idx = " ++ show msgIdx + putStrLn $ "original payload length = " ++ show len + putStrLn $ "K = " ++ show ecK + putStrLn $ "M = " ++ show ecM + putStrLn $ "N = " ++ show ecN ++ " | N == K + M: " ++ show (ecN == ecK + ecM) + putStrLn $ "didn't receive = " ++ show bad + putStrLn $ "did receive = " ++ show (ecN - bad) + putStrLn $ "result:" + + fine <- case ei of + + Left err -> do + putStrLn $ " - error = " ++ show err + return (bad > ecM) + + Right dec -> case dec of + MkDecodedMessage reSId reIdx bs -> do + let ok = bs == payload + putStrLn $ " - recovered session id = " ++ show reSId + putStrLn $ " - recovered message idx = " ++ show reIdx + putStrLn $ " - recovered payload length = " ++ show (B.length bs) + putStrLn $ " - recovered payload matches = " ++ show ok + return ok + + return fine + +-------------------------------------------------------------------------------- + +-- | Unfortunately, Leopard doesn't seem to work the way I naively assumed, namely +-- that we can just add parity chunks (up to a limit) +-- +-- This is not that suprising: it probably uses the smallest power-of-two subgroup +-- into which @N = K + M@ fits; so if we vary M, the subgroup can change. +-- +-- Hence for any K we just deterministically figure out an M, and always use that. +-- +deterministicECParams :: Int -> ECParams +deterministicECParams k = ECParams k n where + n = k + m + m = min k m' -- we have the restriction M < K + m' = if k < 16 + then 8 + else div k 2 -- TODO: finetune this! + +deterministicParityCount :: Int -> Int +deterministicParityCount k = let ECParams k' n = deterministicECParams k in (n - k') + +-------------------------------------------------------------------------------- +-- * EC encoding + +computeParityChunks :: [Chunk] -> [Chunk] +computeParityChunks chunks = computeParityChunks' m chunks where + m = deterministicParityCount (length chunks) + +{-# NOINLINE computeParityChunks' #-} +computeParityChunks' :: Int -> [Chunk] -> [Chunk] +computeParityChunks' 0 origChunks = origChunks +computeParityChunks' mparity [origChunk] = [origChunk] +computeParityChunks' mparity origChunks = + case fromChunks origChunks of + Left err -> error err + Right (meta,ibss) -> case unsafePerformIO (unsafeEncodeIOList ecp $ map snd ibss) of + Left err -> error $ decodeLeopardResult err + Right bss -> [ MkChunk meta (fromIntegral j) bs | (j,bs) <- zip [k..] bss ] + where + ecp = ECParams k (k+mparity) + k = length origChunks + +-------------------------------------------------------------------------------- +-- * EC decoding + +data DecodeError + = NotEnoughChunks Int -- ^ how many more is required + | InvalidChunks String -- ^ invalid and\/or incompatible set of chunks + | LeopardError LeopardResult -- ^ Leopard reported an error + | CannotParseMsg -- ^ can't parse the decoded bytestring + deriving (Eq,Show) + +data DecodedMessage = MkDecodedMessage + { _msgSessionId :: SessionId + , _msgMessageIdx :: MsgIdx + , _msgPayload :: ByteString + } + deriving (Eq,Show) + +---------------------------------------- + +{-# NOINLINE decodeFromChunks #-} +decodeFromChunks :: [Chunk] -> Either DecodeError DecodedMessage +decodeFromChunks [] = error "decodeFromChunks: fatal: empty input" +decodeFromChunks chunks = + + case fromChunks chunks of + Left err -> Left $ InvalidChunks err + Right (meta,ibss) -> handle meta ibss + + where + + handle :: ChunkMeta -> [(ChunkIdx,ByteString)] -> Either DecodeError DecodedMessage + handle meta ibss + | minIdx < 0 = Left $ InvalidChunks "negative chunk index" + | maxIdx >= 2*ecK = Left $ InvalidChunks "too big chunk index (max is 2*K because of Leopard)" + | repeated_idxs = Left $ InvalidChunks "repeated chunk indicies" + | haveCnt < ecK_int = Left $ NotEnoughChunks (ecK_int - haveCnt) + | otherwise = case unsafePerformIO (unsafeDecodeIO ecp mbArr) of + Left leoRes -> Left (LeopardError leoRes) + Right arr -> case parseMsgPayload (B.concat (elems arr)) of + Nothing -> Left $ CannotParseMsg + Just bs -> Right $ MkDecodedMessage sessionId msgIdx bs + + where + MkChunkMeta sessionId msgIdx ecK = meta + ecK_int = fromIntegral ecK :: Int + ecp = deterministicECParams ecK_int :: ECParams + ecM_int = _ecM ecp :: Int + ecN_int = _ecN ecp :: Int + haveIdxs = map fst ibss :: [ChunkIdx] + haveCnt = length haveIdxs :: Int + minIdx = minimum haveIdxs :: ChunkIdx + maxIdx = maximum haveIdxs :: ChunkIdx + -- maxIdxI = fromIntegral maxIdx :: Int + -- ecN_int = maxIdxI + 1 :: Int + repeated_idxs = nubOrd haveIdxs /= sort haveIdxs + mbArr = listArray (0,ecN_int-1) (map fun' [0..ecN_int-1]) + + fun' :: Int -> Maybe ByteString + fun' j = fun (fromIntegral j) + + fun :: ChunkIdx -> Maybe ByteString + fun j = case find (\(i,bs) -> i == j) ibss of + Just (_,bs) -> Just bs + Nothing -> Nothing + +-------------------------------------------------------------------------------- +-- * Shared + +-- | Chunks of the same message +fromChunks :: [Chunk] -> Either String (ChunkMeta,[(ChunkIdx,ByteString)]) +fromChunks [] = error "fromChunks: fatal: empty input" +fromChunks chunks + | any (/= chunkMeta) (map _chunkMeta chunks) = Left $ "fromChunks: chunk metadata differs from each other" + | otherwise = Right (chunkMeta, map f chunks) + where + chunkMeta = _chunkMeta (head chunks) + f (MkChunk meta idx payload) = (idx, payload) + +-------------------------------------------------------------------------------- diff --git a/reference/Transport/Misc.hs b/reference/Transport/Misc.hs new file mode 100644 index 0000000..5211775 --- /dev/null +++ b/reference/Transport/Misc.hs @@ -0,0 +1,27 @@ + +module Transport.Misc where + +-------------------------------------------------------------------------------- + +import Data.Word + +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as L + +import qualified Data.Set as Set + +-------------------------------------------------------------------------------- +-- * alternative Show instance for ByteString + +showByteString :: B.ByteString -> String +showByteString b = "<>" + +showLazyByteString :: L.ByteString -> String +showLazyByteString lb = "<>" + +-------------------------------------------------------------------------------- + +nubOrd :: (Eq a, Ord a) => [a] -> [a] +nubOrd = Set.toList . Set.fromList + +-------------------------------------------------------------------------------- diff --git a/reference/Transport/Protocol.hs b/reference/Transport/Protocol.hs new file mode 100644 index 0000000..9ced540 --- /dev/null +++ b/reference/Transport/Protocol.hs @@ -0,0 +1,50 @@ + + +{-# LANGUAGE StrictData, DerivingVia #-} +module Transport.Protocol where + +-------------------------------------------------------------------------------- + +import Data.Word + +import Data.ByteString (ByteString ) ; import qualified Data.ByteString as B +import Data.ByteString.Lazy (LazyByteString) ; import qualified Data.ByteString.Lazy as L + +import Transport.Types +import Transport.Misc + +-------------------------------------------------------------------------------- + +data SessionControl + = InitialMessage + | Continue + | CloseSession + deriving (Eq,Show) + +data AckEntry + = MsgReceived MsgIdx -- ^ message received intact + | MsgFailed MsgIdx -- ^ message failed (eg. decoding or checksum) + | NeedMoreChunks MsgIdx Int -- ^ we need more chunks + deriving (Eq,Show) + +-------------------------------------------------------------------------------- + +data MsgMeta = MkMsgMeta + { _msgControl :: SessionControl -- ^ where we are in the session + , _msgReqSURBs :: Int -- ^ how many more SURBs we need + , _msgAcks :: [AckEntry] -- ^ status of previous messages + } + deriving (Eq,Show) + +data Message = MkMessage + { _msgMeta :: MsgMeta -- ^ message metadata + , _msgSURBs :: [SURB] -- ^ the new SURBs we send + , _msgPayload :: ByteString -- ^ the actual payload + } + deriving Eq + +instance Show Message where + show (MkMessage meta surbs payload) = + "MkMessage (" ++ show meta ++ ") " ++ show surbs ++ " " ++ showByteString payload + +-------------------------------------------------------------------------------- diff --git a/reference/Transport/State.hs b/reference/Transport/State.hs new file mode 100644 index 0000000..0d5ea9b --- /dev/null +++ b/reference/Transport/State.hs @@ -0,0 +1,76 @@ + +-- | State of a connection + +{-# LANGUAGE StrictData #-} +module Transport.State where + +-------------------------------------------------------------------------------- + +import Data.IORef + +import Data.Map as Map +import qualified Data.Map as Map + +import Transport.Chunks +import Transport.Types + +-------------------------------------------------------------------------------- + +-- | Our role in the protocol +data Role + = Client -- ^ the initiator of the connection + | Server -- ^ the other party in the connection + deriving (Eq,Show) + +-- | The address of the other party +data ConnAddress + = NetworkAddress String -- ^ we know some kind of address for the other party + | ReplyToSURB -- ^ we don't know their address, instead we can use SURBs to send + deriving (Eq,Show) + +data Connection = MkConnection + { _connSessionId :: SessionId -- ^ the session id + , _connRole :: Role -- ^ our role in the connection (client or server) + , _connDestAddr :: ConnAddress -- ^ the address of the other party + , _connState :: IORef ConnectionState -- ^ current state of the connection + } + +data ConnectionState = MkConnState + { _connNextSendIdx :: MsgIdx -- ^ index of the next message to send + , _connNextRecvIdx :: MsgIdx -- ^ index of the next message to receive + , _connUnusedSURBs :: [SURB] -- ^ set of unused SURBs + , _connSentMsgState :: Map MsgIdx SentMsgState -- ^ state of messages we sent + , _connRecvMsgState :: Map MsgIdx RecvMsgState -- ^ state of messages we are receiving + , _connExpectedData :: Maybe Int -- ^ number of bytes we are expecting to receive, and haven't sent SURBs for yet + } + deriving (Eq,Show) + +-- | State of a message we are sending +data SentMsgState = SentMsgState + { _origChunks :: [Chunk] + , _parityChunks :: [Chunk] + , _msgStatus :: SentMsgStatus + } + deriving (Eq,Show) + +data SentCounter = MkSentCounter + { _alreadySent :: Int -- ^ we already sent this many chunks (0..K-1 means orig; >= K means parity) + , _needsToSend :: Int -- ^ we were asked for this many more chunks + } + deriving (Eq,Show) + +data SentMsgStatus + = SentMsgFailed -- ^ the message failed completely; we should probably retransmit + | SentMsgSingleton -- ^ the message was only a single chunk, so we don't do EC; we can just retransmit + | SentMsgNeedsMoreChunks SentCounter -- ^ the other party asked for more chunks + deriving (Eq,Show) + +-- | State of a message we are receiving +data RecvMsgState = RecvMsgState + { _receivedChunks :: Map ChunkIdx Chunk -- ^ chunks we received so far + , _msgNOrigCHunks :: Int -- ^ number of original chunks + } + deriving (Eq,Show) + +-------------------------------------------------------------------------------- + diff --git a/reference/Transport/Types.hs b/reference/Transport/Types.hs new file mode 100644 index 0000000..b48f52c --- /dev/null +++ b/reference/Transport/Types.hs @@ -0,0 +1,51 @@ + +module Transport.Types where + +-------------------------------------------------------------------------------- + +import Data.Word + +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as L + +import Control.Monad +import System.Random + +import Data.Octets + +-------------------------------------------------------------------------------- + +-- | Message index within a session +type MsgIdx = Word32 + +-- | Chunk index within a chunked messages +type ChunkIdx = Word16 + +-------------------------------------------------------------------------------- + +-- | A (random) session identifier +newtype SessionId + = MkSessionId [Word8] + deriving (Eq) + +instance Show SessionId where + show (MkSessionId xs) = "" + +-- | Session Ids have constant length (16 bytes) +sessionIdSize :: Int +sessionIdSize = 16 + +randomSessionId :: IO SessionId +randomSessionId = MkSessionId <$> replicateM sessionIdSize randomIO + +-- | Here we just look at a SURB as a fixed-sized bytestring +data OpaqueSURB + = MkOpaqueSURB B.ByteString + deriving Eq + +instance Show OpaqueSURB where + show (MkOpaqueSURB bs) = "<>" + +type SURB = OpaqueSURB + +-------------------------------------------------------------------------------- diff --git a/transport-over-mix.cabal b/transport-over-mix.cabal index 6e79f90..d1c3e92 100644 --- a/transport-over-mix.cabal +++ b/transport-over-mix.cabal @@ -29,26 +29,34 @@ source-repository head Library - Build-Depends: base >= 4 && <5, + Build-Depends: base >= 4 && < 5, array >= 0.5 && < 0.6, - random >= 1.3 && < 1.4, + containers >= 0.7 && < 0.8, bytestring >= 0.12 && < 0.14, - binary >= 0.8 && < 0.9 + random >= 1.3 && < 1.4, + binary >= 0.8 && < 0.9, + hs-leopard >= 0.0.1 && < 0.0.3 Exposed-Modules: Sphinx.Header + Transport.Protocol + Transport.State + Transport.EC + Transport.Chunks + Transport.Types + Transport.Misc Crypto.Symmetric Crypto.Symmetric.AES128 Crypto.Symmetric.Blake2b Crypto.Symmetric.HMAC Crypto.Symmetric.KeccakPerm Crypto.Symmetric.SHA256 + Crypto.PRP.Lioness Crypto.X25519.BaseField Crypto.X25519.ScalarField Crypto.X25519.Elliptic Crypto.X25519.DH - Crypto.Lioness Crypto.Types - Octet + Data.Octets Default-Language: Haskell2010 Default-Extensions: BangPatterns, NumericUnderscores