diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -0,0 +1,33 @@ +# Changelog + +- 0.1.0 (2026-10-10) + * Breaking: splits the post-handshake session into separate Sender + and Receiver states, so one state can't serve both directions and + a reader thread and a writer thread can each own one. Every + operation returns the next state; the docs now stress that reusing + an old state reuses a nonce (or accepts replays). + + * Breaking: the local static key is a Keypair, so its secret and + public halves can't be mismatched, and the handshake states are + distinct Initiator and Responder types. + + * Breaking: frames are decrypted whole with 'decrypt', or on a + stream with 'decrypt_header' (exactly 18 bytes) followed by + 'decrypt_body'. 'decrypt_frame', 'decrypt_frame_partial' and + FrameResult are removed. + + * Breaking: removes unused API (Key32, SessionNonce, MessagePayload, + HandshakeState, the public Sec type, the DecryptionFailed error) + and the exposed Internal module, renames the InvalidKey error to + InvalidEntropy, and drops the Generic, Show and Eq instances of + secret-bearing types. All public types have NFData instances. + + * Fixes the key rotation docs (keys rotate every 500 messages in each + direction), rotates keys whenever a nonce reaches 1000 or more, and + requires ppad-aead >= 0.3.6 for constant-time MAC comparison. + + * Tests now cover every BOLT #8 Appendix A vector, including all + handshake failure cases and the final keys on both sides. + +- 0.0.1 (2026-04-18) + * Initial release. diff --git a/bench/Fixture.hs b/bench/Fixture.hs new file mode 100644 --- /dev/null +++ b/bench/Fixture.hs @@ -0,0 +1,79 @@ +module Fixture ( + i_s_ent + , i_e_ent + , r_s_ent + , r_e_ent + , msg_32 + , msg_1k + , msg_64k + , Fixture(..) + , fixture + ) where + +import qualified Data.ByteString as BS +import qualified Lightning.Protocol.BOLT8 as BOLT8 + +-- key material from BOLT #8 Appendix A +i_s_ent, i_e_ent, r_s_ent, r_e_ent :: BS.ByteString +i_s_ent = BS.replicate 32 0x11 +i_e_ent = BS.replicate 32 0x12 +r_s_ent = BS.replicate 32 0x21 +r_e_ent = BS.replicate 32 0x22 + +data Fixture = Fixture { + fx_i :: !BOLT8.Keypair + , fx_r :: !BOLT8.Keypair + , fx_msg1 :: !BS.ByteString + , fx_i_hs :: !BOLT8.Initiator + , fx_msg2 :: !BS.ByteString + , fx_r_hs :: !BOLT8.Responder + , fx_msg3 :: !BS.ByteString + , fx_snd :: !BOLT8.Sender + , fx_snd_rot :: !BOLT8.Sender -- its next encrypt rotates the key + , fx_rcv :: !BOLT8.Receiver + , fx_ct_32 :: !BS.ByteString + , fx_ct_1k :: !BS.ByteString + , fx_ct_64k :: !BS.ByteString + , fx_pend_1k :: !BOLT8.Pending -- awaiting the body of fx_ct_1k + } + +fixture :: IO Fixture +fixture = do + i <- orFail "keypair" (maybe (Left ()) Right (BOLT8.keypair i_s_ent)) + r <- orFail "keypair" (maybe (Left ()) Right (BOLT8.keypair r_s_ent)) + (msg1, i_hs) <- orFail "act1" (BOLT8.act1 i (BOLT8.keypair_pub r) i_e_ent) + (msg2, r_hs) <- orFail "act2" (BOLT8.act2 r r_e_ent msg1) + (msg3, i_res) <- orFail "act3" (BOLT8.act3 i_hs msg2) + r_res <- orFail "finalize" (BOLT8.finalize r_hs msg3) + let snd0 = BOLT8.handshake_sender i_res + rcv0 = BOLT8.handshake_receiver r_res + snd_rot <- advance (499 :: Int) snd0 + (ct_32, _) <- orFail "encrypt" (BOLT8.encrypt snd0 msg_32) + (ct_1k, _) <- orFail "encrypt" (BOLT8.encrypt snd0 msg_1k) + (ct_64k, _) <- orFail "encrypt" (BOLT8.encrypt snd0 msg_64k) + (_, pend_1k) <- orFail "header" + (BOLT8.decrypt_header rcv0 (BS.take 18 ct_1k)) + -- benchmark the success path, not MAC failure + mapM_ (orFail "decrypt" . BOLT8.decrypt rcv0) [ct_32, ct_1k, ct_64k] + pure Fixture { + fx_i = i, fx_r = r + , fx_msg1 = msg1, fx_i_hs = i_hs + , fx_msg2 = msg2, fx_r_hs = r_hs + , fx_msg3 = msg3 + , fx_snd = snd0, fx_snd_rot = snd_rot + , fx_rcv = rcv0 + , fx_ct_32 = ct_32, fx_ct_1k = ct_1k, fx_ct_64k = ct_64k + , fx_pend_1k = pend_1k + } + where + orFail :: Show e => String -> Either e a -> IO a + orFail msg = either (\e -> fail (msg <> ": " <> show e)) pure + advance 0 s = pure s + advance n s = do + (_, s') <- orFail "encrypt" (BOLT8.encrypt s msg_32) + advance (n - 1) s' + +msg_32, msg_1k, msg_64k :: BS.ByteString +msg_32 = BS.replicate 32 0x00 +msg_1k = BS.replicate 1024 0x00 +msg_64k = BS.replicate 65535 0x00 diff --git a/bench/Main.hs b/bench/Main.hs --- a/bench/Main.hs +++ b/bench/Main.hs @@ -1,85 +1,50 @@ -{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE OverloadedStrings #-} - module Main where -import Control.DeepSeq import Criterion.Main import qualified Data.ByteString as BS +import Fixture import qualified Lightning.Protocol.BOLT8 as BOLT8 -instance NFData BOLT8.Pub where - rnf p = rnf (BOLT8.serialize_pub p) - -instance NFData BOLT8.Sec -instance NFData BOLT8.Error -instance NFData BOLT8.Session -instance NFData BOLT8.HandshakeState -instance NFData BOLT8.Handshake - main :: IO () -main = defaultMain [ - keys - , handshake - , messages - ] - --- test keys (from BOLT #8 spec) -i_s_ent, i_e_ent, r_s_ent, r_e_ent :: BS.ByteString -i_s_ent = BS.replicate 32 0x11 -i_e_ent = BS.replicate 32 0x12 -r_s_ent = BS.replicate 32 0x21 -r_e_ent = BS.replicate 32 0x22 +main = do + fx <- fixture + defaultMain [ + keys fx + , handshake fx + , transport fx + ] -keys :: Benchmark -keys = bgroup "keys" [ +keys :: Fixture -> Benchmark +keys fx = bgroup "keys" [ bench "keypair" $ nf BOLT8.keypair i_s_ent - , bench "parse_pub" $ nf BOLT8.parse_pub r_s_pub_bs - , bench "serialize_pub" $ nf BOLT8.serialize_pub r_s_pub + , bench "parse_pub" $ nf BOLT8.parse_pub pub_bs + , bench "serialize_pub" $ nf BOLT8.serialize_pub pub ] where - Just (_, r_s_pub) = BOLT8.keypair r_s_ent - r_s_pub_bs = BOLT8.serialize_pub r_s_pub + pub = BOLT8.keypair_pub (fx_r fx) + pub_bs = BOLT8.serialize_pub pub -handshake :: Benchmark -handshake = env setup $ \ ~(i_s_sec, i_s_pub, r_s_sec, r_s_pub, msg1, i_hs, - msg2, r_hs, msg3) -> - bgroup "handshake" [ - bench "act1" $ nf (BOLT8.act1 i_s_sec i_s_pub r_s_pub) i_e_ent - , bench "act2" $ nf (BOLT8.act2 r_s_sec r_s_pub r_e_ent) msg1 - , bench "act3" $ nf (BOLT8.act3 i_hs) msg2 - , bench "finalize" $ nf (BOLT8.finalize r_hs) msg3 - ] - where - setup = do - let Just (!i_s_sec, !i_s_pub) = BOLT8.keypair i_s_ent - Just (!r_s_sec, !r_s_pub) = BOLT8.keypair r_s_ent - Right (!msg1, !i_hs) = BOLT8.act1 i_s_sec i_s_pub r_s_pub i_e_ent - Right (!msg2, !r_hs) = BOLT8.act2 r_s_sec r_s_pub r_e_ent msg1 - Right (!msg3, _) = BOLT8.act3 i_hs msg2 - pure (i_s_sec, i_s_pub, r_s_sec, r_s_pub, msg1, i_hs, msg2, r_hs, msg3) +handshake :: Fixture -> Benchmark +handshake fx = bgroup "handshake" [ + bench "act1" $ + nf (BOLT8.act1 (fx_i fx) (BOLT8.keypair_pub (fx_r fx))) i_e_ent + , bench "act2" $ nf (BOLT8.act2 (fx_r fx) r_e_ent) (fx_msg1 fx) + , bench "act3" $ nf (BOLT8.act3 (fx_i_hs fx)) (fx_msg2 fx) + , bench "finalize" $ nf (BOLT8.finalize (fx_r_hs fx)) (fx_msg3 fx) + ] -messages :: Benchmark -messages = env setup $ \ ~(i_sess, r_sess, ct_small, ct_large) -> - bgroup "messages" [ - bench "encrypt (32B)" $ nf (BOLT8.encrypt i_sess) small_msg - , bench "encrypt (1KB)" $ nf (BOLT8.encrypt i_sess) large_msg - , bench "decrypt (32B)" $ nf (BOLT8.decrypt r_sess) ct_small - , bench "decrypt (1KB)" $ nf (BOLT8.decrypt r_sess) ct_large - ] - where - small_msg = BS.replicate 32 0x00 - large_msg = BS.replicate 1024 0x00 - setup = do - let Just (!i_s_sec, !i_s_pub) = BOLT8.keypair i_s_ent - Just (!r_s_sec, !r_s_pub) = BOLT8.keypair r_s_ent - Right (msg1, i_hs) = BOLT8.act1 i_s_sec i_s_pub r_s_pub i_e_ent - Right (msg2, r_hs) = BOLT8.act2 r_s_sec r_s_pub r_e_ent msg1 - Right (msg3, i_result) = BOLT8.act3 i_hs msg2 - Right r_result = BOLT8.finalize r_hs msg3 - !i_sess = BOLT8.session i_result - !r_sess = BOLT8.session r_result - Right (!ct_small, _) = BOLT8.encrypt i_sess small_msg - Right (!ct_large, _) = BOLT8.encrypt i_sess large_msg - pure (i_sess, r_sess, ct_small, ct_large) +transport :: Fixture -> Benchmark +transport fx = bgroup "transport" [ + bench "encrypt (32B)" $ nf (BOLT8.encrypt (fx_snd fx)) msg_32 + , bench "encrypt (1KB)" $ nf (BOLT8.encrypt (fx_snd fx)) msg_1k + , bench "encrypt (64KB)" $ nf (BOLT8.encrypt (fx_snd fx)) msg_64k + , bench "encrypt (32B, rotating)" $ + nf (BOLT8.encrypt (fx_snd_rot fx)) msg_32 + , bench "decrypt (32B)" $ nf (BOLT8.decrypt (fx_rcv fx)) (fx_ct_32 fx) + , bench "decrypt (1KB)" $ nf (BOLT8.decrypt (fx_rcv fx)) (fx_ct_1k fx) + , bench "decrypt (64KB)" $ nf (BOLT8.decrypt (fx_rcv fx)) (fx_ct_64k fx) + , bench "decrypt_header" $ + nf (BOLT8.decrypt_header (fx_rcv fx)) (BS.take 18 (fx_ct_1k fx)) + , bench "decrypt_body (1KB)" $ + nf (BOLT8.decrypt_body (fx_pend_1k fx)) (BS.drop 18 (fx_ct_1k fx)) + ] diff --git a/bench/Weight.hs b/bench/Weight.hs --- a/bench/Weight.hs +++ b/bench/Weight.hs @@ -1,75 +1,46 @@ -{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE OverloadedStrings #-} - module Main where -import Control.DeepSeq import qualified Data.ByteString as BS +import Fixture import qualified Lightning.Protocol.BOLT8 as BOLT8 import Weigh -instance NFData BOLT8.Pub where - rnf p = rnf (BOLT8.serialize_pub p) - -instance NFData BOLT8.Sec -instance NFData BOLT8.Error -instance NFData BOLT8.Session -instance NFData BOLT8.HandshakeState -instance NFData BOLT8.Handshake - -- note that 'weigh' doesn't work properly in a repl main :: IO () -main = mainWith $ do - keys - handshake - messages - --- test keys (from BOLT #8 spec) -i_s_ent, i_e_ent, r_s_ent, r_e_ent :: BS.ByteString -i_s_ent = BS.replicate 32 0x11 -i_e_ent = BS.replicate 32 0x12 -r_s_ent = BS.replicate 32 0x21 -r_e_ent = BS.replicate 32 0x22 +main = do + fx <- fixture + mainWith $ do + keys fx + handshake fx + transport fx -keys :: Weigh () -keys = - let Just (_, !r_s_pub) = BOLT8.keypair r_s_ent - !r_s_pub_bs = BOLT8.serialize_pub r_s_pub - in wgroup "keys" $ do - func "keypair" BOLT8.keypair i_s_ent - func "parse_pub" BOLT8.parse_pub r_s_pub_bs - func "serialize_pub" BOLT8.serialize_pub r_s_pub +keys :: Fixture -> Weigh () +keys fx = wgroup "keys" $ do + func "keypair" BOLT8.keypair i_s_ent + func "parse_pub" BOLT8.parse_pub pub_bs + func "serialize_pub" BOLT8.serialize_pub pub + where + pub = BOLT8.keypair_pub (fx_r fx) + pub_bs = BOLT8.serialize_pub pub -handshake :: Weigh () -handshake = - let Just (!i_s_sec, !i_s_pub) = BOLT8.keypair i_s_ent - Just (!r_s_sec, !r_s_pub) = BOLT8.keypair r_s_ent - Right (!msg1, !i_hs) = BOLT8.act1 i_s_sec i_s_pub r_s_pub i_e_ent - Right (!msg2, !r_hs) = BOLT8.act2 r_s_sec r_s_pub r_e_ent msg1 - Right (!msg3, _) = BOLT8.act3 i_hs msg2 - in wgroup "handshake" $ do - func "act1" (BOLT8.act1 i_s_sec i_s_pub r_s_pub) i_e_ent - func "act2" (BOLT8.act2 r_s_sec r_s_pub r_e_ent) msg1 - func "act3" (BOLT8.act3 i_hs) msg2 - func "finalize" (BOLT8.finalize r_hs) msg3 +handshake :: Fixture -> Weigh () +handshake fx = wgroup "handshake" $ do + func "act1" + (BOLT8.act1 (fx_i fx) (BOLT8.keypair_pub (fx_r fx))) i_e_ent + func "act2" (BOLT8.act2 (fx_r fx) r_e_ent) (fx_msg1 fx) + func "act3" (BOLT8.act3 (fx_i_hs fx)) (fx_msg2 fx) + func "finalize" (BOLT8.finalize (fx_r_hs fx)) (fx_msg3 fx) -messages :: Weigh () -messages = - let Just (!i_s_sec, !i_s_pub) = BOLT8.keypair i_s_ent - Just (!r_s_sec, !r_s_pub) = BOLT8.keypair r_s_ent - Right (msg1, i_hs) = BOLT8.act1 i_s_sec i_s_pub r_s_pub i_e_ent - Right (msg2, r_hs) = BOLT8.act2 r_s_sec r_s_pub r_e_ent msg1 - Right (msg3, i_result) = BOLT8.act3 i_hs msg2 - Right r_result = BOLT8.finalize r_hs msg3 - !i_sess = BOLT8.session i_result - !r_sess = BOLT8.session r_result - !small_msg = BS.replicate 32 0x00 - !large_msg = BS.replicate 1024 0x00 - Right (!ct_small, _) = BOLT8.encrypt i_sess small_msg - Right (!ct_large, _) = BOLT8.encrypt i_sess large_msg - in wgroup "messages" $ do - func "encrypt (32B)" (BOLT8.encrypt i_sess) small_msg - func "encrypt (1KB)" (BOLT8.encrypt i_sess) large_msg - func "decrypt (32B)" (BOLT8.decrypt r_sess) ct_small - func "decrypt (1KB)" (BOLT8.decrypt r_sess) ct_large +transport :: Fixture -> Weigh () +transport fx = wgroup "transport" $ do + func "encrypt (32B)" (BOLT8.encrypt (fx_snd fx)) msg_32 + func "encrypt (1KB)" (BOLT8.encrypt (fx_snd fx)) msg_1k + func "encrypt (64KB)" (BOLT8.encrypt (fx_snd fx)) msg_64k + func "encrypt (32B, rotating)" (BOLT8.encrypt (fx_snd_rot fx)) msg_32 + func "decrypt (32B)" (BOLT8.decrypt (fx_rcv fx)) (fx_ct_32 fx) + func "decrypt (1KB)" (BOLT8.decrypt (fx_rcv fx)) (fx_ct_1k fx) + func "decrypt (64KB)" (BOLT8.decrypt (fx_rcv fx)) (fx_ct_64k fx) + func "decrypt_header" + (BOLT8.decrypt_header (fx_rcv fx)) (BS.take 18 (fx_ct_1k fx)) + func "decrypt_body (1KB)" + (BOLT8.decrypt_body (fx_pend_1k fx)) (BS.drop 18 (fx_ct_1k fx)) diff --git a/lib/Lightning/Protocol/BOLT8.hs b/lib/Lightning/Protocol/BOLT8.hs --- a/lib/Lightning/Protocol/BOLT8.hs +++ b/lib/Lightning/Protocol/BOLT8.hs @@ -1,705 +1,731 @@ {-# OPTIONS_HADDOCK prune #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ViewPatterns #-} - --- | --- Module: Lightning.Protocol.BOLT8 --- Copyright: (c) 2025 Jared Tobin --- License: MIT --- Maintainer: Jared Tobin --- --- Encrypted and authenticated transport for the Lightning Network, per --- [BOLT #8](https://github.com/lightning/bolts/blob/master/08-transport.md). --- --- This module implements the Noise_XK_secp256k1_ChaChaPoly_SHA256 --- handshake and subsequent encrypted message transport. --- --- = Handshake --- --- A BOLT #8 handshake consists of three acts. The /initiator/ knows the --- responder's static public key in advance and initiates the connection: --- --- @ --- (msg1, state) <- act1 i_sec i_pub r_pub entropy --- -- send msg1 (50 bytes) to responder --- -- receive msg2 (50 bytes) from responder --- (msg3, result) <- act3 state msg2 --- -- send msg3 (66 bytes) to responder --- let session = 'session' result --- @ --- --- The /responder/ receives the connection and authenticates the initiator: --- --- @ --- -- receive msg1 (50 bytes) from initiator --- (msg2, state) <- act2 r_sec r_pub entropy msg1 --- -- send msg2 (50 bytes) to initiator --- -- receive msg3 (66 bytes) from initiator --- result <- finalize state msg3 --- let session = 'session' result --- @ --- --- = Message Transport --- --- After a successful handshake, use 'encrypt' and 'decrypt' to exchange --- messages. Each returns an updated 'Session' that must be used for the --- next operation (keys rotate every 1000 messages): --- --- @ --- -- sender --- (ciphertext, session') <- 'encrypt' session plaintext --- --- -- receiver --- (plaintext, session') <- 'decrypt' session ciphertext --- @ --- --- = Message Framing --- --- BOLT #8 runs over a byte stream, so callers often need to deal with --- partial buffers. Use 'decrypt_frame' when you have exactly one frame, --- or 'decrypt_frame_partial' to handle incremental reads and return how --- many bytes are still needed. --- --- Maximum plaintext size is 65535 bytes. - -module Lightning.Protocol.BOLT8 ( - -- * Keys - Sec - , Pub - , keypair - , parse_pub - , serialize_pub - - -- * Handshake (initiator) - , act1 - , act3 - - -- * Handshake (responder) - , act2 - , finalize - - -- * Session - , Session - , HandshakeState - , Handshake(..) - , encrypt - , decrypt - , decrypt_frame - , decrypt_frame_partial - , FrameResult(..) - - -- * Errors - , Error(..) - ) where - -import Control.Monad (guard, unless) -import qualified Crypto.AEAD.ChaCha20Poly1305 as AEAD -import qualified Crypto.Curve.Secp256k1 as Secp256k1 -import qualified Crypto.Hash.SHA256 as SHA256 -import qualified Crypto.KDF.HMAC as HKDF -import Data.Bits (unsafeShiftR, (.&.)) -import qualified Data.ByteString as BS -import Data.Word (Word16, Word64) -import GHC.Generics (Generic) - --- types --------------------------------------------------------------------- - --- | Secret key (32 bytes). -newtype Sec = Sec BS.ByteString - deriving (Eq, Generic) - --- | Compressed public key. -newtype Pub = Pub Secp256k1.Projective - -instance Eq Pub where - (Pub a) == (Pub b) = - Secp256k1.serialize_point a == Secp256k1.serialize_point b - -instance Show Pub where - show (Pub p) = "Pub " ++ show (Secp256k1.serialize_point p) - --- | Handshake errors. -data Error = - InvalidKey - | InvalidPub - | InvalidMAC - | InvalidVersion - | InvalidLength - | DecryptionFailed - deriving (Eq, Show, Generic) - --- | Result of attempting to decrypt a frame from a partial buffer. -data FrameResult = - NeedMore {-# UNPACK #-} !Int - -- ^ More bytes needed; the 'Int' is the minimum additional bytes required. - | FrameOk !BS.ByteString !BS.ByteString !Session - -- ^ Successfully decrypted: plaintext, remainder, updated session. - | FrameError !Error - -- ^ Decryption failed with the given error. - deriving Generic - --- | Post-handshake session state. -data Session = Session { - sess_sk :: {-# UNPACK #-} !BS.ByteString -- ^ send key (32 bytes) - , sess_sn :: {-# UNPACK #-} !Word64 -- ^ send nonce - , sess_sck :: {-# UNPACK #-} !BS.ByteString -- ^ send chaining key - , sess_rk :: {-# UNPACK #-} !BS.ByteString -- ^ receive key (32 bytes) - , sess_rn :: {-# UNPACK #-} !Word64 -- ^ receive nonce - , sess_rck :: {-# UNPACK #-} !BS.ByteString -- ^ receive chaining key - } - deriving Generic - --- | Result of a successful handshake. -data Handshake = Handshake { - session :: !Session -- ^ session state - , remote_static :: !Pub -- ^ authenticated remote static pubkey - } - deriving Generic - --- | Internal handshake state (exported for benchmarking). -data HandshakeState = HandshakeState { - hs_h :: {-# UNPACK #-} !BS.ByteString -- handshake hash (32 bytes) - , hs_ck :: {-# UNPACK #-} !BS.ByteString -- chaining key (32 bytes) - , hs_temp_k :: {-# UNPACK #-} !BS.ByteString -- temp key (32 bytes) - , hs_e_sec :: !Sec -- ephemeral secret - , hs_e_pub :: !Pub -- ephemeral public - , hs_s_sec :: !Sec -- static secret - , hs_s_pub :: !Pub -- static public - , hs_re :: !(Maybe Pub) -- remote ephemeral - , hs_rs :: !(Maybe Pub) -- remote static - } - deriving Generic - --- protocol constants -------------------------------------------------------- - -_PROTOCOL_NAME :: BS.ByteString -_PROTOCOL_NAME = "Noise_XK_secp256k1_ChaChaPoly_SHA256" - -_PROLOGUE :: BS.ByteString -_PROLOGUE = "lightning" - --- key operations ------------------------------------------------------------ - --- | Derive a keypair from 32 bytes of entropy. --- --- Returns Nothing if the entropy is invalid (zero or >= curve order). --- --- >>> let ent = BS.replicate 32 0x11 --- >>> case keypair ent of { Just _ -> "ok"; Nothing -> "fail" } --- "ok" --- >>> keypair (BS.replicate 31 0x11) -- wrong length --- Nothing -keypair :: BS.ByteString -> Maybe (Sec, Pub) -keypair ent = do - guard (BS.length ent == 32) - k <- Secp256k1.parse_int256 ent - p <- Secp256k1.derive_pub k - pure (Sec ent, Pub p) - --- | Parse a 33-byte compressed public key. --- --- >>> let Just (_, pub) = keypair (BS.replicate 32 0x11) --- >>> let bytes = serialize_pub pub --- >>> case parse_pub bytes of { Just _ -> "ok"; Nothing -> "fail" } --- "ok" --- >>> parse_pub (BS.replicate 32 0x00) -- wrong length --- Nothing -parse_pub :: BS.ByteString -> Maybe Pub -parse_pub bs = do - guard (BS.length bs == 33) - p <- Secp256k1.parse_point bs - pure (Pub p) - --- | Serialize a public key to 33-byte compressed form. --- --- >>> let Just (_, pub) = keypair (BS.replicate 32 0x11) --- >>> BS.length (serialize_pub pub) --- 33 -serialize_pub :: Pub -> BS.ByteString -serialize_pub (Pub p) = Secp256k1.serialize_point p - --- cryptographic primitives -------------------------------------------------- - --- bolt8-style ECDH -ecdh :: Sec -> Pub -> Maybe BS.ByteString -ecdh (Sec sec) (Pub pub) = do - k <- Secp256k1.parse_int256 sec - pt <- Secp256k1.mul pub k - let compressed = Secp256k1.serialize_point pt - pure (SHA256.hash compressed) - --- h' = SHA256(h || data) -mix_hash :: BS.ByteString -> BS.ByteString -> BS.ByteString -mix_hash h dat = SHA256.hash (h <> dat) - --- Mix key: (ck', k) = HKDF(ck, input_key_material) --- --- NB HKDF limits output to 255 * hashlen bytes. For SHA256 that's 8160, --- well above the 64 bytes requested here, so 'Nothing' is impossible. -mix_key :: BS.ByteString -> BS.ByteString -> (BS.ByteString, BS.ByteString) -mix_key ck ikm = case HKDF.derive hmac ck mempty 64 ikm of - Nothing -> error "ppad-bolt8: internal error, please report a bug!" - Just output -> BS.splitAt 32 output - where - hmac k b = case SHA256.hmac k b of - SHA256.MAC mac -> mac - --- Encrypt with associated data using ChaCha20-Poly1305 -encrypt_with_ad - :: BS.ByteString -- ^ key (32 bytes) - -> Word64 -- ^ nonce - -> BS.ByteString -- ^ associated data - -> BS.ByteString -- ^ plaintext - -> Maybe BS.ByteString -- ^ ciphertext || mac (16 bytes) -encrypt_with_ad key n ad pt = - case AEAD.encrypt ad key (encode_nonce n) pt of - Left _ -> Nothing - Right (ct, mac) -> Just (ct <> mac) - --- Decrypt with associated data using ChaCha20-Poly1305 -decrypt_with_ad - :: BS.ByteString -- ^ key (32 bytes) - -> Word64 -- ^ nonce - -> BS.ByteString -- ^ associated data - -> BS.ByteString -- ^ ciphertext || mac - -> Maybe BS.ByteString -- ^ plaintext -decrypt_with_ad key n ad ctmac - | BS.length ctmac < 16 = Nothing - | otherwise = - let (ct, mac) = BS.splitAt (BS.length ctmac - 16) ctmac - in case AEAD.decrypt ad key (encode_nonce n) (ct, mac) of - Left _ -> Nothing - Right pt -> Just pt - --- Encode nonce as 96-bit value: 4 zero bytes + 8-byte little-endian -encode_nonce :: Word64 -> BS.ByteString -encode_nonce n = BS.replicate 4 0x00 <> encode_le64 n - --- Little-endian 64-bit encoding -encode_le64 :: Word64 -> BS.ByteString -encode_le64 n = BS.pack [ - fi (n .&. 0xff) - , fi (unsafeShiftR n 8 .&. 0xff) - , fi (unsafeShiftR n 16 .&. 0xff) - , fi (unsafeShiftR n 24 .&. 0xff) - , fi (unsafeShiftR n 32 .&. 0xff) - , fi (unsafeShiftR n 40 .&. 0xff) - , fi (unsafeShiftR n 48 .&. 0xff) - , fi (unsafeShiftR n 56 .&. 0xff) - ] - --- Big-endian 16-bit encoding -encode_be16 :: Word16 -> BS.ByteString -encode_be16 n = BS.pack [fi (unsafeShiftR n 8), fi (n .&. 0xff)] - --- Big-endian 16-bit decoding -decode_be16 :: BS.ByteString -> Maybe Word16 -decode_be16 bs - | BS.length bs /= 2 = Nothing - | otherwise = - let !b0 = BS.index bs 0 - !b1 = BS.index bs 1 - in Just (fi b0 * 0x100 + fi b1) - --- handshake ----------------------------------------------------------------- - --- Initialize handshake state --- --- h = SHA256(protocol_name) --- ck = h --- h = SHA256(h || prologue) --- h = SHA256(h || responder_static_pubkey) -init_handshake - :: Sec -- ^ local static secret - -> Pub -- ^ local static public - -> Sec -- ^ ephemeral secret - -> Pub -- ^ ephemeral public - -> Maybe Pub -- ^ remote static (initiator knows, responder doesn't) - -> Bool -- ^ True if initiator - -> HandshakeState -init_handshake s_sec s_pub e_sec e_pub m_rs is_initiator = - let !h0 = SHA256.hash _PROTOCOL_NAME - !ck = h0 - !h1 = mix_hash h0 _PROLOGUE - -- Mix in responder's static pubkey - !h2 = case (is_initiator, m_rs) of - (True, Just rs) -> mix_hash h1 (serialize_pub rs) - (False, Nothing) -> mix_hash h1 (serialize_pub s_pub) - _ -> h1 -- shouldn't happen - in HandshakeState { - hs_h = h2 - , hs_ck = ck - , hs_temp_k = BS.replicate 32 0x00 - , hs_e_sec = e_sec - , hs_e_pub = e_pub - , hs_s_sec = s_sec - , hs_s_pub = s_pub - , hs_re = Nothing - , hs_rs = m_rs - } - --- | Initiator: generate Act 1 message (50 bytes). --- --- Takes local static key, remote static pubkey, and 32 bytes of --- entropy for ephemeral key generation. --- --- Returns the 50-byte Act 1 message and handshake state for Act 3. --- --- >>> let Just (i_sec, i_pub) = keypair (BS.replicate 32 0x11) --- >>> let Just (r_sec, r_pub) = keypair (BS.replicate 32 0x21) --- >>> let eph_ent = BS.replicate 32 0x12 --- >>> case act1 i_sec i_pub r_pub eph_ent of { Right (msg, _) -> BS.length msg; Left _ -> 0 } --- 50 -act1 - :: Sec -- ^ local static secret - -> Pub -- ^ local static public - -> Pub -- ^ remote static public (responder's) - -> BS.ByteString -- ^ 32 bytes entropy for ephemeral - -> Either Error (BS.ByteString, HandshakeState) -act1 s_sec s_pub rs ent = do - (e_sec, e_pub) <- note InvalidKey (keypair ent) - let !hs0 = init_handshake s_sec s_pub e_sec e_pub (Just rs) True - !e_pub_bytes = serialize_pub e_pub - !h1 = mix_hash (hs_h hs0) e_pub_bytes - es <- note InvalidKey (ecdh e_sec rs) - let !(ck1, temp_k1) = mix_key (hs_ck hs0) es - c <- note InvalidMAC (encrypt_with_ad temp_k1 0 h1 BS.empty) - let !h2 = mix_hash h1 c - !msg = BS.singleton 0x00 <> e_pub_bytes <> c - !hs1 = hs0 { - hs_h = h2 - , hs_ck = ck1 - , hs_temp_k = temp_k1 - } - pure (msg, hs1) - --- | Responder: process Act 1 and generate Act 2 message (50 bytes). --- --- Takes local static key and 32 bytes of entropy for ephemeral key, --- plus the 50-byte Act 1 message from initiator. --- --- Returns the 50-byte Act 2 message and handshake state for finalize. --- --- >>> let Just (i_sec, i_pub) = keypair (BS.replicate 32 0x11) --- >>> let Just (r_sec, r_pub) = keypair (BS.replicate 32 0x21) --- >>> let Right (msg1, _) = act1 i_sec i_pub r_pub (BS.replicate 32 0x12) --- >>> case act2 r_sec r_pub (BS.replicate 32 0x22) msg1 of { Right (msg, _) -> BS.length msg; Left _ -> 0 } --- 50 -act2 - :: Sec -- ^ local static secret - -> Pub -- ^ local static public - -> BS.ByteString -- ^ 32 bytes entropy for ephemeral - -> BS.ByteString -- ^ Act 1 message (50 bytes) - -> Either Error (BS.ByteString, HandshakeState) -act2 s_sec s_pub ent msg1 = do - require (BS.length msg1 == 50) InvalidLength - let !version = BS.index msg1 0 - !re_bytes = BS.take 33 (BS.drop 1 msg1) - !c = BS.drop 34 msg1 - require (version == 0x00) InvalidVersion - re <- note InvalidPub (parse_pub re_bytes) - (e_sec, e_pub) <- note InvalidKey (keypair ent) - let !hs0 = init_handshake s_sec s_pub e_sec e_pub Nothing False - !h1 = mix_hash (hs_h hs0) re_bytes - es <- note InvalidKey (ecdh s_sec re) - let !(ck1, temp_k1) = mix_key (hs_ck hs0) es - _ <- note InvalidMAC (decrypt_with_ad temp_k1 0 h1 c) - let !h2 = mix_hash h1 c - !e_pub_bytes = serialize_pub e_pub - !h3 = mix_hash h2 e_pub_bytes - ee <- note InvalidKey (ecdh e_sec re) - let !(ck2, temp_k2) = mix_key ck1 ee - c2 <- note InvalidMAC (encrypt_with_ad temp_k2 0 h3 BS.empty) - let !h4 = mix_hash h3 c2 - !msg = BS.singleton 0x00 <> e_pub_bytes <> c2 - !hs1 = hs0 { - hs_h = h4 - , hs_ck = ck2 - , hs_temp_k = temp_k2 - , hs_re = Just re - } - pure (msg, hs1) - --- | Initiator: process Act 2 and generate Act 3 (66 bytes), completing --- the handshake. --- --- Returns the 66-byte Act 3 message and the handshake result. --- --- >>> let Just (i_sec, i_pub) = keypair (BS.replicate 32 0x11) --- >>> let Just (r_sec, r_pub) = keypair (BS.replicate 32 0x21) --- >>> let Right (msg1, i_hs) = act1 i_sec i_pub r_pub (BS.replicate 32 0x12) --- >>> let Right (msg2, _) = act2 r_sec r_pub (BS.replicate 32 0x22) msg1 --- >>> case act3 i_hs msg2 of { Right (msg, _) -> BS.length msg; Left _ -> 0 } --- 66 -act3 - :: HandshakeState -- ^ state after Act 1 - -> BS.ByteString -- ^ Act 2 message (50 bytes) - -> Either Error (BS.ByteString, Handshake) -act3 hs msg2 = do - require (BS.length msg2 == 50) InvalidLength - let !version = BS.index msg2 0 - !re_bytes = BS.take 33 (BS.drop 1 msg2) - !c = BS.drop 34 msg2 - require (version == 0x00) InvalidVersion - re <- note InvalidPub (parse_pub re_bytes) - let !h1 = mix_hash (hs_h hs) re_bytes - ee <- note InvalidKey (ecdh (hs_e_sec hs) re) - let !(ck1, temp_k2) = mix_key (hs_ck hs) ee - _ <- note InvalidMAC (decrypt_with_ad temp_k2 0 h1 c) - let !h2 = mix_hash h1 c - !s_pub_bytes = serialize_pub (hs_s_pub hs) - c3 <- note InvalidMAC (encrypt_with_ad temp_k2 1 h2 s_pub_bytes) - let !h3 = mix_hash h2 c3 - se <- note InvalidKey (ecdh (hs_s_sec hs) re) - let !(ck2, temp_k3) = mix_key ck1 se - t <- note InvalidMAC (encrypt_with_ad temp_k3 0 h3 BS.empty) - let !(sk, rk) = mix_key ck2 BS.empty - !msg = BS.singleton 0x00 <> c3 <> t - !sess = Session { - sess_sk = sk - , sess_sn = 0 - , sess_sck = ck2 - , sess_rk = rk - , sess_rn = 0 - , sess_rck = ck2 - } - rs <- note InvalidPub (hs_rs hs) - let !result = Handshake { - session = sess - , remote_static = rs - } - pure (msg, result) - --- | Responder: process Act 3 (66 bytes) and complete the handshake. --- --- Returns the handshake result with authenticated remote static pubkey. --- --- >>> let Just (i_sec, i_pub) = keypair (BS.replicate 32 0x11) --- >>> let Just (r_sec, r_pub) = keypair (BS.replicate 32 0x21) --- >>> let Right (msg1, i_hs) = act1 i_sec i_pub r_pub (BS.replicate 32 0x12) --- >>> let Right (msg2, r_hs) = act2 r_sec r_pub (BS.replicate 32 0x22) msg1 --- >>> let Right (msg3, _) = act3 i_hs msg2 --- >>> case finalize r_hs msg3 of { Right _ -> "ok"; Left e -> show e } --- "ok" -finalize - :: HandshakeState -- ^ state after Act 2 - -> BS.ByteString -- ^ Act 3 message (66 bytes) - -> Either Error Handshake -finalize hs msg3 = do - require (BS.length msg3 == 66) InvalidLength - let !version = BS.index msg3 0 - !c = BS.take 49 (BS.drop 1 msg3) - !t = BS.drop 50 msg3 - require (version == 0x00) InvalidVersion - rs_bytes <- note InvalidMAC (decrypt_with_ad (hs_temp_k hs) 1 (hs_h hs) c) - rs <- note InvalidPub (parse_pub rs_bytes) - let !h1 = mix_hash (hs_h hs) c - se <- note InvalidKey (ecdh (hs_e_sec hs) rs) - let !(ck1, temp_k3) = mix_key (hs_ck hs) se - _ <- note InvalidMAC (decrypt_with_ad temp_k3 0 h1 t) - -- responder swaps order (receives what initiator sends) - let !(rk, sk) = mix_key ck1 BS.empty - !sess = Session { - sess_sk = sk - , sess_sn = 0 - , sess_sck = ck1 - , sess_rk = rk - , sess_rn = 0 - , sess_rck = ck1 - } - !result = Handshake { - session = sess - , remote_static = rs - } - pure result - --- message encryption -------------------------------------------------------- - --- | Encrypt a message (max 65535 bytes). --- --- Returns the encrypted packet and updated session. Key rotation --- is handled automatically at nonce 1000. --- --- Wire format: encrypted_length (2) || MAC (16) || encrypted_body || MAC (16) --- --- >>> let Just (i_sec, i_pub) = keypair (BS.replicate 32 0x11) --- >>> let Just (r_sec, r_pub) = keypair (BS.replicate 32 0x21) --- >>> let Right (msg1, i_hs) = act1 i_sec i_pub r_pub (BS.replicate 32 0x12) --- >>> let Right (msg2, _) = act2 r_sec r_pub (BS.replicate 32 0x22) msg1 --- >>> let Right (_, i_result) = act3 i_hs msg2 --- >>> let sess = session i_result --- >>> case encrypt sess "hello" of { Right (ct, _) -> BS.length ct; Left _ -> 0 } --- 39 -encrypt - :: Session - -> BS.ByteString -- ^ plaintext (max 65535 bytes) - -> Either Error (BS.ByteString, Session) -encrypt sess pt = do - let !len = BS.length pt - require (len <= 65535) InvalidLength - let !len_bytes = encode_be16 (fi len) - lc <- note InvalidMAC (encrypt_with_ad (sess_sk sess) (sess_sn sess) - BS.empty len_bytes) - let !(sn1, sck1, sk1) = step_nonce (sess_sn sess) (sess_sck sess) (sess_sk sess) - bc <- note InvalidMAC (encrypt_with_ad sk1 sn1 BS.empty pt) - let !(sn2, sck2, sk2) = step_nonce sn1 sck1 sk1 - !packet = lc <> bc - !sess' = sess { - sess_sk = sk2 - , sess_sn = sn2 - , sess_sck = sck2 - } - pure (packet, sess') - --- | Decrypt a message, requiring an exact packet with no trailing bytes. --- --- Returns the plaintext and updated session. Key rotation --- is handled automatically at nonce 1000. --- --- This is a strict variant that rejects any trailing data. For --- streaming use cases where you need to handle multiple frames in a --- buffer, use 'decrypt_frame' instead. --- --- >>> let Just (i_sec, i_pub) = keypair (BS.replicate 32 0x11) --- >>> let Just (r_sec, r_pub) = keypair (BS.replicate 32 0x21) --- >>> let Right (msg1, i_hs) = act1 i_sec i_pub r_pub (BS.replicate 32 0x12) --- >>> let Right (msg2, r_hs) = act2 r_sec r_pub (BS.replicate 32 0x22) msg1 --- >>> let Right (msg3, i_result) = act3 i_hs msg2 --- >>> let Right r_result = finalize r_hs msg3 --- >>> let Right (ct, _) = encrypt (session i_result) "hello" --- >>> case decrypt (session r_result) ct of { Right (pt, _) -> pt; Left _ -> "fail" } --- "hello" -decrypt - :: Session - -> BS.ByteString -- ^ encrypted packet (exact length required) - -> Either Error (BS.ByteString, Session) -decrypt sess packet = do - (pt, remainder, sess') <- decrypt_frame sess packet - require (BS.null remainder) InvalidLength - pure (pt, sess') - --- | Decrypt a single frame from a buffer, returning the remainder. --- --- Returns the plaintext, any unconsumed bytes, and the updated session. --- Key rotation is handled automatically every 1000 messages. --- --- This is useful for streaming scenarios where multiple messages may --- be buffered together. The remainder can be passed to the next call --- to 'decrypt_frame'. --- --- Wire format consumed: encrypted_length (18) || encrypted_body (len + 16) --- --- >>> let Just (i_sec, i_pub) = keypair (BS.replicate 32 0x11) --- >>> let Just (r_sec, r_pub) = keypair (BS.replicate 32 0x21) --- >>> let Right (msg1, i_hs) = act1 i_sec i_pub r_pub (BS.replicate 32 0x12) --- >>> let Right (msg2, r_hs) = act2 r_sec r_pub (BS.replicate 32 0x22) msg1 --- >>> let Right (msg3, i_result) = act3 i_hs msg2 --- >>> let Right r_result = finalize r_hs msg3 --- >>> let Right (ct, _) = encrypt (session i_result) "hello" --- >>> case decrypt_frame (session r_result) ct of { Right (pt, rem, _) -> (pt, BS.null rem); Left _ -> ("fail", False) } --- ("hello",True) -decrypt_frame - :: Session - -> BS.ByteString -- ^ buffer containing at least one encrypted frame - -> Either Error (BS.ByteString, BS.ByteString, Session) -decrypt_frame sess packet = do - require (BS.length packet >= 34) InvalidLength - let !lc = BS.take 18 packet - !rest = BS.drop 18 packet - len_bytes <- note InvalidMAC (decrypt_with_ad (sess_rk sess) (sess_rn sess) - BS.empty lc) - len <- note InvalidLength (decode_be16 len_bytes) - let !(rn1, rck1, rk1) = step_nonce (sess_rn sess) (sess_rck sess) (sess_rk sess) - !body_len = fi len + 16 - require (BS.length rest >= body_len) InvalidLength - let !bc = BS.take body_len rest - !remainder = BS.drop body_len rest - pt <- note InvalidMAC (decrypt_with_ad rk1 rn1 BS.empty bc) - let !(rn2, rck2, rk2) = step_nonce rn1 rck1 rk1 - !sess' = sess { - sess_rk = rk2 - , sess_rn = rn2 - , sess_rck = rck2 - } - pure (pt, remainder, sess') - --- | Decrypt a frame from a partial buffer, indicating when more data needed. --- --- Unlike 'decrypt_frame', this function handles incomplete buffers --- gracefully by returning 'NeedMore' with the number of additional --- bytes required to make progress. --- --- * If the buffer has fewer than 18 bytes (encrypted length + MAC), --- returns @'NeedMore' n@ where @n@ is the bytes still needed. --- * If the length header is complete but the body is incomplete, --- returns @'NeedMore' n@ with bytes needed for the full frame. --- * MAC or decryption failures return 'FrameError'. --- * A complete, valid frame returns 'FrameOk' with plaintext, --- remainder, and updated session. --- --- This is useful for non-blocking I/O where data arrives incrementally. -decrypt_frame_partial - :: Session - -> BS.ByteString -- ^ buffer (possibly incomplete) - -> FrameResult -decrypt_frame_partial sess buf - | buflen < 18 = NeedMore (18 - buflen) - | otherwise = - let !lc = BS.take 18 buf - !rest = BS.drop 18 buf - in case decrypt_with_ad (sess_rk sess) (sess_rn sess) BS.empty lc of - Nothing -> FrameError InvalidMAC - Just len_bytes -> case decode_be16 len_bytes of - Nothing -> FrameError InvalidLength - Just len -> - let !body_len = fi len + 16 - !(rn1, rck1, rk1) = step_nonce (sess_rn sess) - (sess_rck sess) (sess_rk sess) - in if BS.length rest < body_len - then NeedMore (body_len - BS.length rest) - else - let !bc = BS.take body_len rest - !remainder = BS.drop body_len rest - in case decrypt_with_ad rk1 rn1 BS.empty bc of - Nothing -> FrameError InvalidMAC - Just pt -> - let !(rn2, rck2, rk2) = step_nonce rn1 rck1 rk1 - !sess' = sess { - sess_rk = rk2 - , sess_rn = rn2 - , sess_rck = rck2 - } - in FrameOk pt remainder sess' - where - !buflen = BS.length buf - --- key rotation -------------------------------------------------------------- - --- Key rotation occurs after nonce reaches 1000 (i.e., before using 1000) --- (ck', k') = HKDF(ck, k), reset nonce to 0 -step_nonce - :: Word64 - -> BS.ByteString - -> BS.ByteString - -> (Word64, BS.ByteString, BS.ByteString) -step_nonce n ck k - | n + 1 == 1000 = - let !(ck', k') = mix_key ck k - in (0, ck', k') - | otherwise = (n + 1, ck, k) - --- utilities ----------------------------------------------------------------- - --- Lift Maybe to Either -note :: e -> Maybe a -> Either e a -note e = maybe (Left e) Right -{-# INLINE note #-} - --- Require condition or fail +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module: Lightning.Protocol.BOLT8 +-- Copyright: (c) 2025 Jared Tobin +-- License: MIT +-- Maintainer: Jared Tobin +-- +-- Encrypted and authenticated transport for the Lightning Network, per +-- [BOLT #8](https://github.com/lightning/bolts/blob/master/08-transport.md): +-- the @Noise_XK_secp256k1_ChaChaPoly_SHA256@ handshake, followed by +-- length-prefixed, authenticated encryption of messages. +-- +-- The library is pure; reading from and writing to the network is up +-- to the caller. +-- +-- = Handshake +-- +-- The /initiator/ knows the responder's static public key in advance. +-- It sends act one ('act1'), receives act two, and replies with act +-- three ('act3'). The /responder/ receives act one, replies with act two +-- ('act2'), and receives act three ('finalize'), which authenticates +-- the initiator's static key. Both sides end up with a t'Handshake'. +-- +-- >>> :set -XOverloadedStrings +-- >>> import qualified Data.ByteString as BS +-- >>> let Just i = keypair (BS.replicate 32 0x11) +-- >>> let Just r = keypair (BS.replicate 32 0x21) +-- >>> -- initiator, knowing r's public key; entropy must be random! +-- >>> let Right (msg1, i_hs) = act1 i (keypair_pub r) (BS.replicate 32 0x12) +-- >>> -- responder +-- >>> let Right (msg2, r_hs) = act2 r (BS.replicate 32 0x22) msg1 +-- >>> -- initiator +-- >>> let Right (msg3, i_res) = act3 i_hs msg2 +-- >>> -- responder +-- >>> let Right r_res = finalize r_hs msg3 +-- >>> handshake_remote_static r_res == keypair_pub i +-- True +-- +-- = Transport +-- +-- A t'Handshake' carries a t'Sender' for outgoing messages and a +-- t'Receiver' for incoming ones. They are independent, so a writer +-- thread can own the t'Sender' and a reader thread the t'Receiver'. +-- +-- >>> let Right (ct, i_snd) = encrypt (handshake_sender i_res) "hello" +-- >>> fmap fst (decrypt (handshake_receiver r_res) ct) +-- Right "hello" +-- +-- On a byte stream, read exactly 18 bytes and pass them to +-- 'decrypt_header', which returns the number of bytes to read next; +-- then read exactly that many bytes and pass them to 'decrypt_body'. +-- 'decrypt' does both for a buffer holding exactly one frame. +-- +-- Keys rotate every 1000 nonces, i.e. every 500 messages in each +-- direction; this is handled internally. Messages are at most 65535 +-- bytes. +-- +-- = Security +-- +-- * __Use each state exactly once.__ Every function that takes an +-- t'Initiator', t'Responder', t'Sender', t'Receiver' or t'Pending' +-- returns the next state, and the caller must continue with that. +-- States are ordinary immutable values, so nothing stops an old one +-- from being used again, and doing so is catastrophic: encrypting +-- twice with the same t'Sender' reuses a nonce, which reveals the XOR +-- of the two plaintexts and allows forgeries, and decrypting with an +-- old t'Receiver' accepts replayed frames. +-- +-- * __Ephemeral entropy must be fresh.__ The 32 bytes passed to 'act1' +-- and 'act2' are used directly as the ephemeral secret key. They +-- must come from a cryptographically secure random source, be +-- uniformly random, and never be reused. +-- +-- * __Any error is fatal.__ BOLT #8 requires terminating the +-- connection on any handshake or transport failure. Don't retry with +-- the previous state. The one exception is 'encrypt' rejecting an +-- oversized message, which advances nothing. + +module Lightning.Protocol.BOLT8 ( + -- * Keys + Keypair + , keypair + , keypair_pub + , Pub + , parse_pub + , serialize_pub + + -- * Handshake + , Handshake + , handshake_sender + , handshake_receiver + , handshake_remote_static + + -- ** Initiator + , Initiator + , act1 + , act3 + + -- ** Responder + , Responder + , act2 + , finalize + + -- * Transport + , Sender + , encrypt + , Receiver + , decrypt + , Pending + , decrypt_header + , decrypt_body + + -- * Errors + , Error(..) + ) where + +import Control.DeepSeq (NFData(..)) +import Control.Monad (guard, unless) +import qualified Crypto.AEAD.ChaCha20Poly1305 as AEAD +import qualified Crypto.Curve.Secp256k1 as Secp256k1 +import qualified Crypto.Hash.SHA256 as SHA256 +import qualified Crypto.KDF.HMAC as HKDF +import Data.Bits (unsafeShiftR, (.&.)) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Unsafe as BU +import Data.Word (Word8, Word16, Word64) +import GHC.Generics (Generic) + +-- keys ----------------------------------------------------------------------- + +-- A secret key: 32 bytes encoding a valid secp256k1 scalar. +newtype Sec = Sec BS.ByteString + +-- | A secp256k1 public key. +-- +-- 'Show' renders the 33-byte compressed encoding in hex. +newtype Pub = Pub Secp256k1.Projective + +instance Eq Pub where + Pub a == Pub b = + Secp256k1.serialize_point a == Secp256k1.serialize_point b + +instance Show Pub where + showsPrec d p = showParen (d > 10) $ + showString "Pub " . shows (hex (serialize_pub p)) + +instance NFData Pub where + rnf (Pub p) = p `seq` () + +-- | A secp256k1 keypair: a secret key and its public key. +-- +-- Has no 'Show' or 'Eq' instance, as it contains secret material. +data Keypair = Keypair !Sec !Pub + +instance NFData Keypair where + rnf (Keypair (Sec s) p) = s `seq` rnf p + +-- | Construct a keypair from a 32-byte secret key. +-- +-- The bytes are used directly as the secret key, so they must be +-- uniformly random and kept secret. Returns 'Nothing' if the input +-- is not 32 bytes, or is not a valid secp256k1 secret key (zero, or +-- not less than the curve order). +-- +-- >>> import Data.Maybe (isJust) +-- >>> isJust (keypair (BS.replicate 32 0x11)) +-- True +-- >>> isJust (keypair (BS.replicate 32 0x00)) +-- False +keypair :: BS.ByteString -> Maybe Keypair +keypair sec = do + guard (BS.length sec == 32) + k <- Secp256k1.parse_int256 sec + p <- Secp256k1.derive_pub k + pure $! Keypair (Sec sec) (Pub p) + +-- | The public key of a keypair. +-- +-- >>> let Just r = keypair (BS.replicate 32 0x21) +-- >>> keypair_pub r +-- Pub "028d7500dd4c12685d1f568b4c2b5048e8534b873319f3a8daa612b469132ec7f7" +keypair_pub :: Keypair -> Pub +keypair_pub (Keypair _ p) = p + +-- | Parse a 33-byte compressed public key. +-- +-- >>> let Just r = keypair (BS.replicate 32 0x21) +-- >>> parse_pub (serialize_pub (keypair_pub r)) == Just (keypair_pub r) +-- True +-- >>> parse_pub (BS.replicate 33 0x04) +-- Nothing +parse_pub :: BS.ByteString -> Maybe Pub +parse_pub bs = do + guard (BS.length bs == 33) + p <- Secp256k1.parse_point bs + pure (Pub p) + +-- | Serialize a public key in 33-byte compressed form. +-- +-- >>> let Just r = keypair (BS.replicate 32 0x21) +-- >>> BS.length (serialize_pub (keypair_pub r)) +-- 33 +serialize_pub :: Pub -> BS.ByteString +serialize_pub (Pub p) = Secp256k1.serialize_point p + +-- handshake state ------------------------------------------------------------ + +-- | The initiator's handshake state between acts one and three. +-- +-- Produced by 'act1' and consumed by 'act3'. Contains secret +-- material; use it once. +data Initiator = Initiator + {-# UNPACK #-} !BS.ByteString -- handshake hash + {-# UNPACK #-} !BS.ByteString -- chaining key + !Sec -- ephemeral secret + !Keypair -- local static keypair + !Pub -- remote static public key + +instance NFData Initiator where + rnf (Initiator h ck (Sec e) s rs) = + h `seq` ck `seq` e `seq` rnf s `seq` rnf rs + +-- | The responder's handshake state between acts two and three. +-- +-- Produced by 'act2' and consumed by 'finalize'. Contains secret +-- material; use it once. +data Responder = Responder + {-# UNPACK #-} !BS.ByteString -- handshake hash + {-# UNPACK #-} !BS.ByteString -- chaining key + {-# UNPACK #-} !BS.ByteString -- temp_k2 + !Sec -- ephemeral secret + +instance NFData Responder where + rnf (Responder h ck k (Sec e)) = h `seq` ck `seq` k `seq` e `seq` () + +-- | The result of a successful handshake: the initial transport +-- states and the remote party's authenticated static public key. +-- +-- Take the t'Sender' and t'Receiver' out once, right after the +-- handshake, and don't keep the t'Handshake' around: it always yields +-- the /initial/ states, and encrypting with the initial t'Sender' +-- a second time reuses a nonce. +data Handshake = Handshake !Sender !Receiver !Pub + +instance NFData Handshake where + rnf (Handshake s r p) = rnf s `seq` rnf r `seq` rnf p + +-- | The initial t'Sender', for encrypting outgoing messages. +-- +-- Call this once per handshake. Every call returns the same initial +-- state, so encrypting with the result of a second call reuses a +-- nonce. +handshake_sender :: Handshake -> Sender +handshake_sender (Handshake s _ _) = s + +-- | The initial t'Receiver', for decrypting incoming messages. +-- +-- Call this once per handshake. Every call returns the same initial +-- state, so decrypting with the result of a second call accepts +-- replayed frames. +handshake_receiver :: Handshake -> Receiver +handshake_receiver (Handshake _ r _) = r + +-- | The remote party's static public key, authenticated by the +-- handshake. For the initiator, this is the key passed to 'act1'. +handshake_remote_static :: Handshake -> Pub +handshake_remote_static (Handshake _ _ p) = p + +-- transport state ------------------------------------------------------------ + +-- One direction's cipher state. +data Cipher = Cipher + {-# UNPACK #-} !BS.ByteString -- key + {-# UNPACK #-} !Word64 -- nonce, always < 1000 + {-# UNPACK #-} !BS.ByteString -- chaining key + +instance NFData Cipher where + rnf (Cipher k n ck) = k `seq` n `seq` ck `seq` () + +-- | State for encrypting outgoing messages. +-- +-- Each 'encrypt' returns the next t'Sender'. Never use a t'Sender' +-- twice: doing so reuses a nonce. +newtype Sender = Sender Cipher + +instance NFData Sender where + rnf (Sender c) = rnf c + +-- | State for decrypting incoming messages. +-- +-- Each 'decrypt' or 'decrypt_header' consumes the t'Receiver'. +-- Never use a t'Receiver' twice: doing so accepts replayed frames. +newtype Receiver = Receiver Cipher + +instance NFData Receiver where + rnf (Receiver c) = rnf c + +-- | A t'Receiver' that has decrypted a frame header and awaits the +-- frame body. +-- +-- Produced by 'decrypt_header' and consumed by 'decrypt_body'. Use +-- it once. +data Pending = Pending {-# UNPACK #-} !Int !Cipher + +instance NFData Pending where + rnf (Pending n c) = n `seq` rnf c + +-- errors --------------------------------------------------------------------- + +-- | Handshake and transport errors. +-- +-- Any error is fatal for the connection. +data Error = + InvalidEntropy + -- ^ ephemeral entropy is not a valid secret key + | InvalidLength + -- ^ input of the wrong length, or a payload over 65535 bytes + | InvalidVersion + -- ^ unknown handshake version + | InvalidPub + -- ^ invalid public key in a handshake message + | InvalidMAC + -- ^ authentication failed + deriving (Eq, Show, Generic) + +instance NFData Error + +-- protocol constants --------------------------------------------------------- + +_PROTOCOL_NAME :: BS.ByteString +_PROTOCOL_NAME = "Noise_XK_secp256k1_ChaChaPoly_SHA256" + +_PROLOGUE :: BS.ByteString +_PROLOGUE = "lightning" + +-- cryptographic primitives --------------------------------------------------- + +-- ECDH as specified by BOLT #8: SHA256 of the compressed shared point. +-- +-- 'Nothing' is unreachable for a valid secret key and a parsed point. +ecdh :: Sec -> Pub -> Maybe BS.ByteString +ecdh (Sec sec) (Pub pub) = do + k <- Secp256k1.parse_int256 sec + pt <- Secp256k1.mul pub k + pure (SHA256.hash (Secp256k1.serialize_point pt)) + +-- h' = SHA256(h || dat) +mix_hash :: BS.ByteString -> BS.ByteString -> BS.ByteString +mix_hash h dat = SHA256.hash (h <> dat) + +-- (ck', k) = HKDF(ck, ikm), with ck as salt and empty info. +-- +-- HKDF limits output to 255 * hashlen bytes (8160 for SHA256), so +-- 'Nothing' is impossible for the 64 bytes requested here. +mix_key + :: BS.ByteString + -> BS.ByteString + -> (BS.ByteString, BS.ByteString) +mix_key ck ikm = + case HKDF.derive hmac ck mempty 64 ikm of + Nothing -> + error "ppad-bolt8: internal error, please report a bug!" + Just output -> BS.splitAt 32 output + where + hmac k b = case SHA256.hmac k b of + SHA256.MAC mac -> mac + +-- ChaCha20-Poly1305 encryption, returning ciphertext || MAC. +-- +-- Keys are always 32 bytes (halves of HKDF output), nonces always 12 +-- bytes, and plaintexts at most 65535 bytes (far below the ChaCha20 +-- counter limit), so encryption cannot fail. +encrypt_with_ad + :: BS.ByteString -- ^ key (32 bytes) + -> Word64 -- ^ nonce + -> BS.ByteString -- ^ associated data + -> BS.ByteString -- ^ plaintext + -> BS.ByteString +encrypt_with_ad key n ad pt = + case AEAD.encrypt ad key (encode_nonce n) pt of + Left _ -> + error "ppad-bolt8: internal error, please report a bug!" + Right (ct, mac) -> ct <> mac + +-- ChaCha20-Poly1305 decryption of ciphertext || MAC. +decrypt_with_ad + :: BS.ByteString -- ^ key (32 bytes) + -> Word64 -- ^ nonce + -> BS.ByteString -- ^ associated data + -> BS.ByteString -- ^ ciphertext || mac + -> Maybe BS.ByteString -- ^ plaintext +decrypt_with_ad key n ad ctmac + | BS.length ctmac < 16 = Nothing + | otherwise = + let (ct, mac) = BS.splitAt (BS.length ctmac - 16) ctmac + in case AEAD.decrypt ad key (encode_nonce n) (ct, mac) of + Left _ -> Nothing + Right pt -> Just pt + +-- 96-bit nonce: 4 zero bytes followed by the 64-bit nonce, little-endian +encode_nonce :: Word64 -> BS.ByteString +encode_nonce n = BS.replicate 4 0x00 <> BS.pack [ + fi n + , fi (unsafeShiftR n 8) + , fi (unsafeShiftR n 16) + , fi (unsafeShiftR n 24) + , fi (unsafeShiftR n 32) + , fi (unsafeShiftR n 40) + , fi (unsafeShiftR n 48) + , fi (unsafeShiftR n 56) + ] + +-- big-endian 16-bit encoding +encode_be16 :: Word16 -> BS.ByteString +encode_be16 n = BS.pack [fi (unsafeShiftR n 8), fi n] + +-- big-endian 16-bit decoding of exactly two bytes +decode_be16 :: BS.ByteString -> Maybe Word16 +decode_be16 bs + | BS.length bs /= 2 = Nothing + | otherwise = + let !b0 = BU.unsafeIndex bs 0 + !b1 = BU.unsafeIndex bs 1 + in Just (fi b0 * 0x100 + fi b1) + +-- handshake ------------------------------------------------------------------ + +-- Initial (h, ck), given the responder's static public key: +-- +-- h = SHA256(protocol_name); ck = h +-- h = SHA256(h || prologue) +-- h = SHA256(h || rs.pub) +initial_state :: Pub -> (BS.ByteString, BS.ByteString) +initial_state rs = + let !h0 = SHA256.hash _PROTOCOL_NAME + !h1 = mix_hash h0 _PROLOGUE + !h2 = mix_hash h1 (serialize_pub rs) + in (h2, h0) + +-- Split a 50-byte act one or act two message into its ephemeral public +-- key and MAC, checking length and version. +parse_act :: BS.ByteString -> Either Error (BS.ByteString, BS.ByteString) +parse_act msg = do + require (BS.length msg == 50) InvalidLength + require (BU.unsafeHead msg == 0x00) InvalidVersion + let !(e, c) = BS.splitAt 33 (BU.unsafeTail msg) + pure (e, c) + +-- | Initiator: produce act one (50 bytes). +-- +-- Takes the local static keypair, the responder's static public key, +-- and 32 bytes of entropy for the ephemeral key. Returns act one and +-- the state for 'act3'. +-- +-- The entropy is used directly as the ephemeral secret key. It must +-- be fresh, uniformly random output of a cryptographically secure +-- random source, and must never be reused. Fails with +-- 'InvalidEntropy' if it is not a valid secret key. +-- +-- >>> let Just i = keypair (BS.replicate 32 0x11) +-- >>> let Just r = keypair (BS.replicate 32 0x21) +-- >>> let ent = BS.replicate 32 0x12 -- use random bytes in practice +-- >>> fmap (BS.length . fst) (act1 i (keypair_pub r) ent) +-- Right 50 +act1 + :: Keypair -- ^ local static keypair + -> Pub -- ^ responder's static public key + -> BS.ByteString -- ^ 32 bytes of fresh entropy + -> Either Error (BS.ByteString, Initiator) +act1 s rs ent = do + Keypair e_sec e_pub <- note InvalidEntropy (keypair ent) + let !(h0, ck0) = initial_state rs + !e_bytes = serialize_pub e_pub + !h1 = mix_hash h0 e_bytes + es <- note InvalidPub (ecdh e_sec rs) + let !(ck1, temp_k1) = mix_key ck0 es + !c = encrypt_with_ad temp_k1 0 h1 BS.empty + !h2 = mix_hash h1 c + !msg = BS.cons 0x00 (e_bytes <> c) + pure (msg, Initiator h2 ck1 e_sec s rs) + +-- | Responder: process act one and produce act two (50 bytes). +-- +-- Takes the local static keypair, 32 bytes of entropy for the +-- ephemeral key, and act one. Returns act two and the state for +-- 'finalize'. +-- +-- The entropy is used directly as the ephemeral secret key. It must +-- be fresh, uniformly random output of a cryptographically secure +-- random source, and must never be reused. Fails with +-- 'InvalidEntropy' if it is not a valid secret key. +-- +-- Any error means the connection must be terminated. +-- +-- >>> let Just i = keypair (BS.replicate 32 0x11) +-- >>> let Just r = keypair (BS.replicate 32 0x21) +-- >>> let Right (msg1, _) = act1 i (keypair_pub r) (BS.replicate 32 0x12) +-- >>> fmap (BS.length . fst) (act2 r (BS.replicate 32 0x22) msg1) +-- Right 50 +-- >>> fmap fst (act2 r (BS.replicate 32 0x22) (BS.take 49 msg1)) +-- Left InvalidLength +act2 + :: Keypair -- ^ local static keypair + -> BS.ByteString -- ^ 32 bytes of fresh entropy + -> BS.ByteString -- ^ act one + -> Either Error (BS.ByteString, Responder) +act2 (Keypair s_sec s_pub) ent msg1 = do + (re_bytes, c) <- parse_act msg1 + re <- note InvalidPub (parse_pub re_bytes) + Keypair e_sec e_pub <- note InvalidEntropy (keypair ent) + let !(h0, ck0) = initial_state s_pub + !h1 = mix_hash h0 re_bytes + es <- note InvalidPub (ecdh s_sec re) + let !(ck1, temp_k1) = mix_key ck0 es + _ <- note InvalidMAC (decrypt_with_ad temp_k1 0 h1 c) + let !h2 = mix_hash h1 c + !e_bytes = serialize_pub e_pub + !h3 = mix_hash h2 e_bytes + ee <- note InvalidPub (ecdh e_sec re) + let !(ck2, temp_k2) = mix_key ck1 ee + !c2 = encrypt_with_ad temp_k2 0 h3 BS.empty + !h4 = mix_hash h3 c2 + !msg = BS.cons 0x00 (e_bytes <> c2) + pure (msg, Responder h4 ck2 temp_k2 e_sec) + +-- | Initiator: process act two and produce act three (66 bytes), +-- completing the handshake. +-- +-- Any error means the connection must be terminated. +-- +-- Continuing the module-level example: +-- +-- >>> fmap (BS.length . fst) (act3 i_hs msg2) +-- Right 66 +act3 + :: Initiator -- ^ state from 'act1' + -> BS.ByteString -- ^ act two + -> Either Error (BS.ByteString, Handshake) +act3 (Initiator h ck e_sec (Keypair s_sec s_pub) rs) msg2 = do + (re_bytes, c) <- parse_act msg2 + re <- note InvalidPub (parse_pub re_bytes) + let !h1 = mix_hash h re_bytes + ee <- note InvalidPub (ecdh e_sec re) + let !(ck1, temp_k2) = mix_key ck ee + _ <- note InvalidMAC (decrypt_with_ad temp_k2 0 h1 c) + let !h2 = mix_hash h1 c + !c3 = encrypt_with_ad temp_k2 1 h2 (serialize_pub s_pub) + !h3 = mix_hash h2 c3 + se <- note InvalidPub (ecdh s_sec re) + let !(ck2, temp_k3) = mix_key ck1 se + !t = encrypt_with_ad temp_k3 0 h3 BS.empty + !(sk, rk) = mix_key ck2 BS.empty + !msg = BS.cons 0x00 (c3 <> t) + !hs = Handshake (Sender (Cipher sk 0 ck2)) + (Receiver (Cipher rk 0 ck2)) rs + pure (msg, hs) + +-- | Responder: process act three, completing the handshake and +-- authenticating the initiator's static public key. +-- +-- Any error means the connection must be terminated. +-- +-- Continuing the module-level example: +-- +-- >>> let Right r_res' = finalize r_hs msg3 +-- >>> handshake_remote_static r_res' == keypair_pub i +-- True +finalize + :: Responder -- ^ state from 'act2' + -> BS.ByteString -- ^ act three + -> Either Error Handshake +finalize (Responder h ck temp_k2 e_sec) msg3 = do + require (BS.length msg3 == 66) InvalidLength + require (BU.unsafeHead msg3 == 0x00) InvalidVersion + let !(c, t) = BS.splitAt 49 (BU.unsafeTail msg3) + rs_bytes <- note InvalidMAC (decrypt_with_ad temp_k2 1 h c) + rs <- note InvalidPub (parse_pub rs_bytes) + let !h1 = mix_hash h c + se <- note InvalidPub (ecdh e_sec rs) + let !(ck1, temp_k3) = mix_key ck se + _ <- note InvalidMAC (decrypt_with_ad temp_k3 0 h1 t) + let !(rk, sk) = mix_key ck1 BS.empty + pure (Handshake (Sender (Cipher sk 0 ck1)) (Receiver (Cipher rk 0 ck1)) rs) + +-- transport ------------------------------------------------------------------ + +-- Encrypt under the current key and nonce, then advance. +seal :: Cipher -> BS.ByteString -> (BS.ByteString, Cipher) +seal c@(Cipher k n _) pt = + let !ct = encrypt_with_ad k n BS.empty pt + in (ct, step c) + +-- Decrypt under the current key and nonce, then advance. +open :: Cipher -> BS.ByteString -> Maybe (BS.ByteString, Cipher) +open c@(Cipher k n _) ct = do + pt <- decrypt_with_ad k n BS.empty ct + pure (pt, step c) + +-- Increment the nonce, rotating the key once it reaches 1000: +-- +-- (ck', k') = HKDF(ck, k), n' = 0 +step :: Cipher -> Cipher +step (Cipher k n ck) + | n' >= 1000 = + let !(ck', k') = mix_key ck k + in Cipher k' 0 ck' + | otherwise = Cipher k n' ck + where + !n' = n + 1 + +-- | Encrypt a message of at most 65535 bytes. +-- +-- Returns the frame to send (the message length plus 34 bytes) and +-- the next t'Sender', which must be used for the following message. +-- Encrypting with the same t'Sender' twice reuses a nonce and breaks +-- confidentiality and authenticity. +-- +-- Fails only with 'InvalidLength', for an oversized message. Nothing +-- is encrypted in that case, so the given t'Sender' remains the +-- current one and the connection can continue. +-- +-- Continuing the module-level example: +-- +-- >>> fmap (BS.length . fst) (encrypt i_snd "hello") +-- Right 39 +-- >>> fmap fst (encrypt i_snd (BS.replicate 65536 0x00)) +-- Left InvalidLength +encrypt + :: Sender -- ^ current state + -> BS.ByteString -- ^ message + -> Either Error (BS.ByteString, Sender) +encrypt (Sender c0) m = do + let !len = BS.length m + require (len <= 65535) InvalidLength + let !(lc, c1) = seal c0 (encode_be16 (fi len)) + !(bc, c2) = seal c1 m + pure (lc <> bc, Sender c2) + +-- | Decrypt a buffer holding exactly one frame. +-- +-- Returns the message and the next t'Receiver'. Fails with +-- 'InvalidLength' if the buffer is not exactly one frame, and with +-- 'InvalidMAC' if authentication fails. Any error means the +-- connection must be terminated. +-- +-- Continuing the module-level example: +-- +-- >>> fmap fst (decrypt (handshake_receiver r_res) ct) +-- Right "hello" +-- >>> fmap fst (decrypt (handshake_receiver r_res) (BS.take 38 ct)) +-- Left InvalidLength +decrypt + :: Receiver -- ^ current state + -> BS.ByteString -- ^ one frame + -> Either Error (BS.ByteString, Receiver) +decrypt r frame = do + let !(lc, c) = BS.splitAt 18 frame + (_, p) <- decrypt_header r lc + decrypt_body p c + +-- | Decrypt the 18-byte header (encrypted length and its MAC) at the +-- start of a frame. +-- +-- Returns the number of bytes in the rest of the frame (the message +-- length plus a 16-byte MAC), which the caller should read exactly, +-- and the state for 'decrypt_body'. Fails with 'InvalidLength' if +-- the input is not 18 bytes, and with 'InvalidMAC' if +-- authentication fails. Any error means the connection must be +-- terminated. +-- +-- Continuing the module-level example: +-- +-- >>> fmap fst (decrypt_header (handshake_receiver r_res) (BS.take 18 ct)) +-- Right 21 +decrypt_header + :: Receiver -- ^ current state + -> BS.ByteString -- ^ 18-byte header + -> Either Error (Int, Pending) +decrypt_header (Receiver c0) lc = do + require (BS.length lc == 18) InvalidLength + (l, c1) <- note InvalidMAC (open c0 lc) + len <- note InvalidLength (decode_be16 l) + let !body = fi len + 16 + pure (body, Pending body c1) + +-- | Decrypt the rest of a frame, following 'decrypt_header'. +-- +-- The input must be exactly as long as 'decrypt_header' reported. +-- Returns the message and the next t'Receiver'. Fails with +-- 'InvalidLength' on a length mismatch, and with 'InvalidMAC' if +-- authentication fails. Any error means the connection must be +-- terminated. +-- +-- Continuing the module-level example: +-- +-- >>> let (hdr, rest) = BS.splitAt 18 ct +-- >>> let Right (n, p) = decrypt_header (handshake_receiver r_res) hdr +-- >>> fmap fst (decrypt_body p (BS.take n rest)) +-- Right "hello" +decrypt_body + :: Pending -- ^ state from 'decrypt_header' + -> BS.ByteString -- ^ the rest of the frame + -> Either Error (BS.ByteString, Receiver) +decrypt_body (Pending body c1) c = do + require (BS.length c == body) InvalidLength + (m, c2) <- note InvalidMAC (open c1 c) + pure (m, Receiver c2) + +-- utilities ------------------------------------------------------------------ + +-- lowercase hex encoding +hex :: BS.ByteString -> String +hex = BS.foldr (\w acc -> nibble (unsafeShiftR w 4) : nibble (w .&. 15) : acc) + [] + where + nibble :: Word8 -> Char + nibble n + | n < 10 = toEnum (fi n + 0x30) + | otherwise = toEnum (fi n + 0x57) + +note :: e -> Maybe a -> Either e a +note e = maybe (Left e) Right +{-# INLINE note #-} + require :: Bool -> e -> Either e () require cond e = unless cond (Left e) {-# INLINE require #-} diff --git a/ppad-bolt8.cabal b/ppad-bolt8.cabal --- a/ppad-bolt8.cabal +++ b/ppad-bolt8.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: ppad-bolt8 -version: 0.0.1 +version: 0.1.0 synopsis: Encrypted and authenticated transport per BOLT #8 license: MIT license-file: LICENSE @@ -8,30 +8,40 @@ maintainer: jared@ppad.tech category: Cryptography build-type: Simple -tested-with: GHC == 9.10.3 +tested-with: GHC == { 9.10.3 } extra-doc-files: CHANGELOG description: - Encrypted and authenticated transport, per - [BOLT #8](https://github.com/lightning/bolts/blob/master/08-transport.md). + Encrypted and authenticated transport for the Lightning Network, per + [BOLT #8](https://github.com/lightning/bolts/blob/master/08-transport.md): + the Noise_XK_secp256k1_ChaChaPoly_SHA256 handshake and message + transport with key rotation. source-repository head type: git location: git.ppad.tech/bolt8.git +flag llvm + description: Use GHC's LLVM backend. + default: False + manual: True + library default-language: Haskell2010 hs-source-dirs: lib ghc-options: -Wall + if flag(llvm) + ghc-options: -fllvm -O2 exposed-modules: Lightning.Protocol.BOLT8 build-depends: base >= 4.9 && < 5 , bytestring >= 0.9 && < 0.13 - , ppad-aead >= 0.3 && < 0.4 + , deepseq >= 1.4 && < 1.6 + , ppad-aead >= 0.3.6 && < 0.4 , ppad-hkdf >= 0.3.2 && < 0.4 - , ppad-secp256k1 >= 0.5.3 && < 0.6 - , ppad-sha256 >= 0.3 && < 0.4 + , ppad-secp256k1 >= 0.5.8 && < 0.6 + , ppad-sha256 >= 0.3.2 && < 0.4 test-suite bolt8-tests type: exitcode-stdio-1.0 @@ -40,14 +50,16 @@ main-is: Main.hs ghc-options: - -rtsopts -Wall -O2 + -rtsopts -Wall build-depends: base , bytestring + , ppad-aead , ppad-base16 , ppad-bolt8 - , QuickCheck + , ppad-hkdf + , ppad-sha256 , tasty , tasty-hunit , tasty-quickcheck @@ -57,15 +69,15 @@ default-language: Haskell2010 hs-source-dirs: bench main-is: Main.hs + other-modules: Fixture ghc-options: - -rtsopts -O2 -Wall -fno-warn-orphans + -rtsopts -O2 -Wall build-depends: base , bytestring , criterion - , deepseq , ppad-bolt8 benchmark bolt8-weigh @@ -73,14 +85,14 @@ default-language: Haskell2010 hs-source-dirs: bench main-is: Weight.hs + other-modules: Fixture ghc-options: - -rtsopts -O2 -Wall -fno-warn-orphans + -rtsopts -O2 -Wall build-depends: base , bytestring - , deepseq , ppad-bolt8 , weigh diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,657 +1,774 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} - -module Main where - -import Data.Bits (xor) -import qualified Data.ByteString as BS -import qualified Data.ByteString.Base16 as B16 -import qualified Lightning.Protocol.BOLT8 as BOLT8 -import Test.Tasty -import Test.Tasty.HUnit -import Test.Tasty.QuickCheck (Gen, Property, choose, forAll, testProperty, - vectorOf) - --- test helpers ---------------------------------------------------------------- - --- | Extract a Just value or fail the test. -expectJust :: String -> Maybe a -> IO a -expectJust msg = \case - Nothing -> assertFailure msg >> error "unreachable" - Just a -> pure a - --- | Extract a Right value or fail the test. -expectRight :: Show e => String -> Either e a -> IO a -expectRight msg = \case - Left e -> assertFailure (msg ++ ": " ++ show e) >> error "unreachable" - Right a -> pure a - -main :: IO () -main = defaultMain $ testGroup "ppad-bolt8" [ - handshake_tests - , message_tests - , framing_tests - , partial_framing_tests - , negative_tests - , property_tests - ] - --- test vectors from BOLT #8 specification ----------------------------------- - --- initiator static private key -initiator_s_priv :: BS.ByteString -initiator_s_priv = hex - "1111111111111111111111111111111111111111111111111111111111111111" - --- initiator ephemeral private key -initiator_e_priv :: BS.ByteString -initiator_e_priv = hex - "1212121212121212121212121212121212121212121212121212121212121212" - --- responder static private key -responder_s_priv :: BS.ByteString -responder_s_priv = hex - "2121212121212121212121212121212121212121212121212121212121212121" - --- responder static public key (known to initiator) -responder_s_pub :: BS.ByteString -responder_s_pub = hex - "028d7500dd4c12685d1f568b4c2b5048e8534b873319f3a8daa612b469132ec7f7" - --- responder ephemeral private key -responder_e_priv :: BS.ByteString -responder_e_priv = hex - "2222222222222222222222222222222222222222222222222222222222222222" - --- expected act 1 message -expected_act1 :: BS.ByteString -expected_act1 = hex - "00036360e856310ce5d294e8be33fc807077dc56ac80d95d9cd4ddbd21325eff73f7\ - \0df6086551151f58b8afe6c195782c6a" - --- expected act 2 message -expected_act2 :: BS.ByteString -expected_act2 = hex - "0002466d7fcae563e5cb09a0d1870bb580344804617879a14949cf22285f1bae3f27\ - \6e2470b93aac583c9ef6eafca3f730ae" - --- expected act 3 message -expected_act3 :: BS.ByteString -expected_act3 = hex - "00b9e3a702e93e3a9948c2ed6e5fd7590a6e1c3a0344cfc9d5b57357049aa22355\ - \361aa02e55a8fc28fef5bd6d71ad0c38228dc68b1c466263b47fdf31e560e139ba" - --- handshake tests ----------------------------------------------------------- - -handshake_tests :: TestTree -handshake_tests = testGroup "Handshake" [ - testCase "act1 matches spec vector" test_act1 - , testCase "act2 matches spec vector" test_act2 - , testCase "act3 matches spec vector" test_act3 - , testCase "full handshake round-trip" test_full_handshake - ] - -test_act1 :: Assertion -test_act1 = do - (i_s_sec, i_s_pub) <- expectJust "initiator keypair" - (BOLT8.keypair initiator_s_priv) - rs <- expectJust "responder pub" (BOLT8.parse_pub responder_s_pub) - (act1_msg, _) <- expectRight "act1" (BOLT8.act1 i_s_sec i_s_pub rs - initiator_e_priv) - act1_msg @?= expected_act1 - -test_act2 :: Assertion -test_act2 = do - (i_s_sec, i_s_pub) <- expectJust "initiator keypair" - (BOLT8.keypair initiator_s_priv) - (r_s_sec, r_s_pub) <- expectJust "responder keypair" - (BOLT8.keypair responder_s_priv) - rs <- expectJust "responder pub" (BOLT8.parse_pub responder_s_pub) - (msg1, _) <- expectRight "act1" (BOLT8.act1 i_s_sec i_s_pub rs - initiator_e_priv) - (msg2, _) <- expectRight "act2" (BOLT8.act2 r_s_sec r_s_pub responder_e_priv - msg1) - msg2 @?= expected_act2 - -test_act3 :: Assertion -test_act3 = do - (i_s_sec, i_s_pub) <- expectJust "initiator keypair" - (BOLT8.keypair initiator_s_priv) - (r_s_sec, r_s_pub) <- expectJust "responder keypair" - (BOLT8.keypair responder_s_priv) - rs <- expectJust "responder pub" (BOLT8.parse_pub responder_s_pub) - (msg1, i_hs) <- expectRight "act1" (BOLT8.act1 i_s_sec i_s_pub rs - initiator_e_priv) - (msg2, _) <- expectRight "act2" (BOLT8.act2 r_s_sec r_s_pub responder_e_priv - msg1) - (msg3, _) <- expectRight "act3" (BOLT8.act3 i_hs msg2) - msg3 @?= expected_act3 - -test_full_handshake :: Assertion -test_full_handshake = do - (i_s_sec, i_s_pub) <- expectJust "initiator keypair" - (BOLT8.keypair initiator_s_priv) - (r_s_sec, r_s_pub) <- expectJust "responder keypair" - (BOLT8.keypair responder_s_priv) - rs <- expectJust "responder pub" (BOLT8.parse_pub responder_s_pub) - (msg1, i_hs) <- expectRight "act1" (BOLT8.act1 i_s_sec i_s_pub rs - initiator_e_priv) - (msg2, r_hs) <- expectRight "act2" (BOLT8.act2 r_s_sec r_s_pub responder_e_priv - msg1) - (msg3, i_result) <- expectRight "act3" (BOLT8.act3 i_hs msg2) - r_result <- expectRight "finalize" (BOLT8.finalize r_hs msg3) - BOLT8.remote_static i_result @?= r_s_pub - BOLT8.remote_static r_result @?= i_s_pub - --- message encryption tests -------------------------------------------------- - -message_tests :: TestTree -message_tests = testGroup "Message Encryption" [ - testCase "message 0 matches spec" test_message_0 - , testCase "message 1 matches spec" test_message_1 - , testCase "message 500 matches spec" test_message_500 - , testCase "message 501 matches spec" test_message_501 - , testCase "message 1000 matches spec" test_message_1000 - , testCase "message 1001 matches spec" test_message_1001 - , testCase "decrypt round-trip" test_decrypt_roundtrip - ] - --- "hello" = 0x68656c6c6f -hello :: BS.ByteString -hello = "hello" - --- expected encrypted messages -expected_msg_0 :: BS.ByteString -expected_msg_0 = hex - "cf2b30ddf0cf3f80e7c35a6e6730b59fe802473180f396d88a8fb0db8cbcf25d\ - \2f214cf9ea1d95" - -expected_msg_1 :: BS.ByteString -expected_msg_1 = hex - "72887022101f0b6753e0c7de21657d35a4cb2a1f5cde2650528bbc8f837d0f0d\ - \7ad833b1a256a1" - -expected_msg_500 :: BS.ByteString -expected_msg_500 = hex - "178cb9d7387190fa34db9c2d50027d21793c9bc2d40b1e14dcf30ebeeeb220f4\ - \8364f7a4c68bf8" - -expected_msg_501 :: BS.ByteString -expected_msg_501 = hex - "1b186c57d44eb6de4c057c49940d79bb838a145cb528d6e8fd26dbe50a60ca2c\ - \104b56b60e45bd" - -expected_msg_1000 :: BS.ByteString -expected_msg_1000 = hex - "4a2f3cc3b5e78ddb83dcb426d9863d9d9a723b0337c89dd0b005d89f8d3c05c5\ - \2b76b29b740f09" - -expected_msg_1001 :: BS.ByteString -expected_msg_1001 = hex - "2ecd8c8a5629d0d02ab457a0fdd0f7b90a192cd46be5ecb6ca570bfc5e268338\ - \b1a16cf4ef2d36" - --- helper to get initiator session after handshake -get_initiator_session :: IO BOLT8.Session -get_initiator_session = do - (i_s_sec, i_s_pub) <- expectJust "initiator keypair" - (BOLT8.keypair initiator_s_priv) - (r_s_sec, r_s_pub) <- expectJust "responder keypair" - (BOLT8.keypair responder_s_priv) - rs <- expectJust "responder pub" (BOLT8.parse_pub responder_s_pub) - (msg1, i_hs) <- expectRight "act1" (BOLT8.act1 i_s_sec i_s_pub rs - initiator_e_priv) - (msg2, _) <- expectRight "act2" (BOLT8.act2 r_s_sec r_s_pub responder_e_priv - msg1) - (_, result) <- expectRight "act3" (BOLT8.act3 i_hs msg2) - pure (BOLT8.session result) - --- encrypt N messages, return Nth ciphertext -encrypt_n :: Int -> BOLT8.Session -> IO BS.ByteString -encrypt_n n sess0 = go 0 sess0 - where - go i sess - | i == n = case BOLT8.encrypt sess hello of - Left err -> fail $ "encrypt failed at " ++ show i ++ ": " ++ show err - Right (ct, _) -> pure ct - | otherwise = case BOLT8.encrypt sess hello of - Left err -> fail $ "encrypt failed at " ++ show i ++ ": " ++ show err - Right (_, sess') -> go (i + 1) sess' - -test_message_0 :: Assertion -test_message_0 = do - sess <- get_initiator_session - ct <- encrypt_n 0 sess - ct @?= expected_msg_0 - -test_message_1 :: Assertion -test_message_1 = do - sess <- get_initiator_session - ct <- encrypt_n 1 sess - ct @?= expected_msg_1 - -test_message_500 :: Assertion -test_message_500 = do - sess <- get_initiator_session - ct <- encrypt_n 500 sess - ct @?= expected_msg_500 - -test_message_501 :: Assertion -test_message_501 = do - sess <- get_initiator_session - ct <- encrypt_n 501 sess - ct @?= expected_msg_501 - -test_message_1000 :: Assertion -test_message_1000 = do - sess <- get_initiator_session - ct <- encrypt_n 1000 sess - ct @?= expected_msg_1000 - -test_message_1001 :: Assertion -test_message_1001 = do - sess <- get_initiator_session - ct <- encrypt_n 1001 sess - ct @?= expected_msg_1001 - -test_decrypt_roundtrip :: Assertion -test_decrypt_roundtrip = do - (i_s_sec, i_s_pub) <- expectJust "initiator keypair" - (BOLT8.keypair initiator_s_priv) - (r_s_sec, r_s_pub) <- expectJust "responder keypair" - (BOLT8.keypair responder_s_priv) - rs <- expectJust "responder pub" (BOLT8.parse_pub responder_s_pub) - (msg1, i_hs) <- expectRight "act1" (BOLT8.act1 i_s_sec i_s_pub rs - initiator_e_priv) - (msg2, r_hs) <- expectRight "act2" (BOLT8.act2 r_s_sec r_s_pub responder_e_priv - msg1) - (msg3, i_result) <- expectRight "act3" (BOLT8.act3 i_hs msg2) - r_result <- expectRight "finalize" (BOLT8.finalize r_hs msg3) - let i_sess = BOLT8.session i_result - r_sess = BOLT8.session r_result - (ct, _) <- expectRight "encrypt" (BOLT8.encrypt i_sess hello) - (pt, _) <- expectRight "decrypt" (BOLT8.decrypt r_sess ct) - pt @?= hello - --- framing tests ------------------------------------------------------------- - -framing_tests :: TestTree -framing_tests = testGroup "Packet Framing" [ - testCase "decrypt rejects trailing bytes" test_decrypt_trailing - , testCase "decrypt_frame returns remainder" test_decrypt_frame_remainder - , testCase "decrypt_frame handles multiple frames" test_decrypt_frame_multi - ] - -test_decrypt_trailing :: Assertion -test_decrypt_trailing = do - (i_s_sec, i_s_pub) <- expectJust "initiator keypair" - (BOLT8.keypair initiator_s_priv) - (r_s_sec, r_s_pub) <- expectJust "responder keypair" - (BOLT8.keypair responder_s_priv) - rs <- expectJust "responder pub" (BOLT8.parse_pub responder_s_pub) - (msg1, i_hs) <- expectRight "act1" (BOLT8.act1 i_s_sec i_s_pub rs - initiator_e_priv) - (msg2, r_hs) <- expectRight "act2" (BOLT8.act2 r_s_sec r_s_pub responder_e_priv - msg1) - (msg3, i_result) <- expectRight "act3" (BOLT8.act3 i_hs msg2) - r_result <- expectRight "finalize" (BOLT8.finalize r_hs msg3) - let i_sess = BOLT8.session i_result - r_sess = BOLT8.session r_result - (ct, _) <- expectRight "encrypt" (BOLT8.encrypt i_sess hello) - -- append trailing bytes - let ct_with_trailing = ct <> "extra" - case BOLT8.decrypt r_sess ct_with_trailing of - Left BOLT8.InvalidLength -> pure () - Left err -> assertFailure $ "expected InvalidLength, got: " ++ show err - Right _ -> assertFailure "decrypt should reject trailing bytes" - -test_decrypt_frame_remainder :: Assertion -test_decrypt_frame_remainder = do - (i_s_sec, i_s_pub) <- expectJust "initiator keypair" - (BOLT8.keypair initiator_s_priv) - (r_s_sec, r_s_pub) <- expectJust "responder keypair" - (BOLT8.keypair responder_s_priv) - rs <- expectJust "responder pub" (BOLT8.parse_pub responder_s_pub) - (msg1, i_hs) <- expectRight "act1" (BOLT8.act1 i_s_sec i_s_pub rs - initiator_e_priv) - (msg2, r_hs) <- expectRight "act2" (BOLT8.act2 r_s_sec r_s_pub responder_e_priv - msg1) - (msg3, i_result) <- expectRight "act3" (BOLT8.act3 i_hs msg2) - r_result <- expectRight "finalize" (BOLT8.finalize r_hs msg3) - let i_sess = BOLT8.session i_result - r_sess = BOLT8.session r_result - (ct, _) <- expectRight "encrypt" (BOLT8.encrypt i_sess hello) - let trailing = "remainder" - ct_with_trailing = ct <> trailing - (pt, remainder, _) <- expectRight "decrypt_frame" - (BOLT8.decrypt_frame r_sess ct_with_trailing) - pt @?= hello - remainder @?= trailing - -test_decrypt_frame_multi :: Assertion -test_decrypt_frame_multi = do - (i_s_sec, i_s_pub) <- expectJust "initiator keypair" - (BOLT8.keypair initiator_s_priv) - (r_s_sec, r_s_pub) <- expectJust "responder keypair" - (BOLT8.keypair responder_s_priv) - rs <- expectJust "responder pub" (BOLT8.parse_pub responder_s_pub) - (msg1, i_hs) <- expectRight "act1" (BOLT8.act1 i_s_sec i_s_pub rs - initiator_e_priv) - (msg2, r_hs) <- expectRight "act2" (BOLT8.act2 r_s_sec r_s_pub responder_e_priv - msg1) - (msg3, i_result) <- expectRight "act3" (BOLT8.act3 i_hs msg2) - r_result <- expectRight "finalize" (BOLT8.finalize r_hs msg3) - let i_sess = BOLT8.session i_result - r_sess = BOLT8.session r_result - -- encrypt two messages - (ct1, i_sess') <- expectRight "encrypt 1" (BOLT8.encrypt i_sess "first") - (ct2, _) <- expectRight "encrypt 2" (BOLT8.encrypt i_sess' "second") - -- concatenate frames - let buffer = ct1 <> ct2 - -- decrypt first frame - (pt1, rest, r_sess') <- expectRight "frame 1" - (BOLT8.decrypt_frame r_sess buffer) - pt1 @?= "first" - -- decrypt second frame from remainder - (pt2, rest2, _) <- expectRight "frame 2" (BOLT8.decrypt_frame r_sess' rest) - pt2 @?= "second" - rest2 @?= BS.empty - --- partial framing tests ----------------------------------------------------- - -partial_framing_tests :: TestTree -partial_framing_tests = testGroup "Partial Framing" [ - testCase "short buffer returns NeedMore" test_partial_short_buffer - , testCase "partial body returns NeedMore" test_partial_body - , testCase "full frame returns FrameOk" test_partial_full_frame - ] - -test_partial_short_buffer :: Assertion -test_partial_short_buffer = do - (i_s_sec, i_s_pub) <- expectJust "initiator keypair" - (BOLT8.keypair initiator_s_priv) - (r_s_sec, r_s_pub) <- expectJust "responder keypair" - (BOLT8.keypair responder_s_priv) - rs <- expectJust "responder pub" (BOLT8.parse_pub responder_s_pub) - (msg1, i_hs) <- expectRight "act1" (BOLT8.act1 i_s_sec i_s_pub rs - initiator_e_priv) - (msg2, r_hs) <- expectRight "act2" (BOLT8.act2 r_s_sec r_s_pub responder_e_priv - msg1) - (msg3, _) <- expectRight "act3" (BOLT8.act3 i_hs msg2) - r_result <- expectRight "finalize" (BOLT8.finalize r_hs msg3) - let r_sess = BOLT8.session r_result - short_buf = BS.replicate 10 0x00 - case BOLT8.decrypt_frame_partial r_sess short_buf of - BOLT8.NeedMore n -> n @?= 8 - BOLT8.FrameOk {} -> assertFailure "expected NeedMore, got FrameOk" - BOLT8.FrameError err -> - assertFailure $ "expected NeedMore, got: " ++ show err - -test_partial_body :: Assertion -test_partial_body = do - (i_s_sec, i_s_pub) <- expectJust "initiator keypair" - (BOLT8.keypair initiator_s_priv) - (r_s_sec, r_s_pub) <- expectJust "responder keypair" - (BOLT8.keypair responder_s_priv) - rs <- expectJust "responder pub" (BOLT8.parse_pub responder_s_pub) - (msg1, i_hs) <- expectRight "act1" (BOLT8.act1 i_s_sec i_s_pub rs - initiator_e_priv) - (msg2, r_hs) <- expectRight "act2" (BOLT8.act2 r_s_sec r_s_pub responder_e_priv - msg1) - (msg3, i_result) <- expectRight "act3" (BOLT8.act3 i_hs msg2) - r_result <- expectRight "finalize" (BOLT8.finalize r_hs msg3) - let i_sess = BOLT8.session i_result - r_sess = BOLT8.session r_result - (ct, _) <- expectRight "encrypt" (BOLT8.encrypt i_sess hello) - -- take only length header (18 bytes) + 5 bytes of body - let partial = BS.take 23 ct - case BOLT8.decrypt_frame_partial r_sess partial of - BOLT8.NeedMore n -> do - -- "hello" = 5 bytes, so body = 5 + 16 = 21 - -- we have 5 bytes of body, need 16 more - n @?= 16 - BOLT8.FrameOk {} -> assertFailure "expected NeedMore, got FrameOk" - BOLT8.FrameError err -> - assertFailure $ "expected NeedMore, got: " ++ show err - -test_partial_full_frame :: Assertion -test_partial_full_frame = do - (i_s_sec, i_s_pub) <- expectJust "initiator keypair" - (BOLT8.keypair initiator_s_priv) - (r_s_sec, r_s_pub) <- expectJust "responder keypair" - (BOLT8.keypair responder_s_priv) - rs <- expectJust "responder pub" (BOLT8.parse_pub responder_s_pub) - (msg1, i_hs) <- expectRight "act1" (BOLT8.act1 i_s_sec i_s_pub rs - initiator_e_priv) - (msg2, r_hs) <- expectRight "act2" (BOLT8.act2 r_s_sec r_s_pub responder_e_priv - msg1) - (msg3, i_result) <- expectRight "act3" (BOLT8.act3 i_hs msg2) - r_result <- expectRight "finalize" (BOLT8.finalize r_hs msg3) - let i_sess = BOLT8.session i_result - r_sess = BOLT8.session r_result - (ct, _) <- expectRight "encrypt" (BOLT8.encrypt i_sess hello) - let trailing = "extra" - buf = ct <> trailing - case BOLT8.decrypt_frame_partial r_sess buf of - BOLT8.FrameOk pt remainder _ -> do - pt @?= hello - remainder @?= trailing - BOLT8.NeedMore n -> - assertFailure $ "expected FrameOk, got NeedMore " ++ show n - BOLT8.FrameError err -> - assertFailure $ "expected FrameOk, got: " ++ show err - --- negative tests ------------------------------------------------------------ - -negative_tests :: TestTree -negative_tests = testGroup "Negative Tests" [ - testCase "act2 rejects wrong version" test_act2_wrong_version - , testCase "act2 rejects wrong length" test_act2_wrong_length - , testCase "act3 rejects invalid MAC" test_act3_invalid_mac - , testCase "finalize rejects invalid MAC" test_finalize_invalid_mac - , testCase "decrypt rejects short packet" test_decrypt_short_packet - ] - -test_act2_wrong_version :: Assertion -test_act2_wrong_version = do - (i_s_sec, i_s_pub) <- expectJust "initiator keypair" - (BOLT8.keypair initiator_s_priv) - (r_s_sec, r_s_pub) <- expectJust "responder keypair" - (BOLT8.keypair responder_s_priv) - rs <- expectJust "responder pub" (BOLT8.parse_pub responder_s_pub) - (msg1, _) <- expectRight "act1" (BOLT8.act1 i_s_sec i_s_pub rs initiator_e_priv) - let bad_msg1 = BS.cons 0x01 (BS.drop 1 msg1) - case BOLT8.act2 r_s_sec r_s_pub responder_e_priv bad_msg1 of - Left BOLT8.InvalidVersion -> pure () - Left err -> assertFailure $ "expected InvalidVersion, got: " ++ show err - Right _ -> assertFailure "expected rejection, got success" - -test_act2_wrong_length :: Assertion -test_act2_wrong_length = do - (r_s_sec, r_s_pub) <- expectJust "responder keypair" - (BOLT8.keypair responder_s_priv) - let short_msg = BS.replicate 49 0x00 - case BOLT8.act2 r_s_sec r_s_pub responder_e_priv short_msg of - Left BOLT8.InvalidLength -> pure () - Left err -> assertFailure $ "expected InvalidLength, got: " ++ show err - Right _ -> assertFailure "expected rejection, got success" - -test_act3_invalid_mac :: Assertion -test_act3_invalid_mac = do - (i_s_sec, i_s_pub) <- expectJust "initiator keypair" - (BOLT8.keypair initiator_s_priv) - (r_s_sec, r_s_pub) <- expectJust "responder keypair" - (BOLT8.keypair responder_s_priv) - rs <- expectJust "responder pub" (BOLT8.parse_pub responder_s_pub) - (msg1, i_hs) <- expectRight "act1" (BOLT8.act1 i_s_sec i_s_pub rs - initiator_e_priv) - (msg2, _) <- expectRight "act2" (BOLT8.act2 r_s_sec r_s_pub responder_e_priv - msg1) - bad_msg2 <- flip_byte 40 msg2 - case BOLT8.act3 i_hs bad_msg2 of - Left BOLT8.InvalidMAC -> pure () - Left err -> assertFailure $ "expected InvalidMAC, got: " ++ show err - Right _ -> assertFailure "expected rejection, got success" - -test_finalize_invalid_mac :: Assertion -test_finalize_invalid_mac = do - (i_s_sec, i_s_pub) <- expectJust "initiator keypair" - (BOLT8.keypair initiator_s_priv) - (r_s_sec, r_s_pub) <- expectJust "responder keypair" - (BOLT8.keypair responder_s_priv) - rs <- expectJust "responder pub" (BOLT8.parse_pub responder_s_pub) - (msg1, i_hs) <- expectRight "act1" (BOLT8.act1 i_s_sec i_s_pub rs - initiator_e_priv) - (msg2, r_hs) <- expectRight "act2" (BOLT8.act2 r_s_sec r_s_pub responder_e_priv - msg1) - (msg3, _) <- expectRight "act3" (BOLT8.act3 i_hs msg2) - bad_msg3 <- flip_byte 20 msg3 - case BOLT8.finalize r_hs bad_msg3 of - Left BOLT8.InvalidMAC -> pure () - Left err -> assertFailure $ "expected InvalidMAC, got: " ++ show err - Right _ -> assertFailure "expected rejection, got success" - -test_decrypt_short_packet :: Assertion -test_decrypt_short_packet = do - (i_s_sec, i_s_pub) <- expectJust "initiator keypair" - (BOLT8.keypair initiator_s_priv) - (r_s_sec, r_s_pub) <- expectJust "responder keypair" - (BOLT8.keypair responder_s_priv) - rs <- expectJust "responder pub" (BOLT8.parse_pub responder_s_pub) - (msg1, i_hs) <- expectRight "act1" (BOLT8.act1 i_s_sec i_s_pub rs - initiator_e_priv) - (msg2, r_hs) <- expectRight "act2" (BOLT8.act2 r_s_sec r_s_pub responder_e_priv - msg1) - (msg3, _) <- expectRight "act3" (BOLT8.act3 i_hs msg2) - r_result <- expectRight "finalize" (BOLT8.finalize r_hs msg3) - let r_sess = BOLT8.session r_result - short_packet = BS.replicate 17 0x00 - case BOLT8.decrypt r_sess short_packet of - Left BOLT8.InvalidLength -> pure () - Left err -> assertFailure $ "expected InvalidLength, got: " ++ show err - Right _ -> assertFailure "expected rejection, got success" - --- flip one byte in a bytestring at given index -flip_byte :: Int -> BS.ByteString -> IO BS.ByteString -flip_byte i bs - | i < 0 || i >= BS.length bs = - assertFailure "flip_byte: index out of bounds" >> pure bs - | otherwise = - let (pre, post) = BS.splitAt i bs - b = BS.index post 0 - in pure (pre <> BS.cons (b `xor` 0xff) (BS.drop 1 post)) - --- utilities ----------------------------------------------------------------- - --- Safe hex decode for test vectors (only called at top level with known-good --- literals). This uses error since it's for compile-time constants, not runtime --- input; wrapping in IO would break the test vector declarations. -hex :: BS.ByteString -> BS.ByteString -hex bs = case B16.decode bs of - Nothing -> error "hex: invalid test vector literal" - Just r -> r - --- property tests -------------------------------------------------------------- - -property_tests :: TestTree -property_tests = testGroup "Properties" [ - testProperty "handshake round-trip" prop_handshake_roundtrip - , testProperty "encrypt/decrypt round-trip" prop_encrypt_decrypt_roundtrip - , testProperty "decrypt_frame consumes one frame" prop_frame_consumes_one - , testProperty "decrypt_frame_partial NeedMore on short" - prop_partial_needmore_short - ] - --- generators ------------------------------------------------------------------ - --- | Generate 32 bytes of entropy that yields a valid keypair. -genValidEntropy :: Gen BS.ByteString -genValidEntropy = do - bytes <- BS.pack <$> vectorOf 32 (choose (0, 255)) - case BOLT8.keypair bytes of - Just _ -> pure bytes - Nothing -> genValidEntropy - --- | Generate a payload of 0..256 bytes. -genPayload :: Gen BS.ByteString -genPayload = do - len <- choose (0, 256) - BS.pack <$> vectorOf len (choose (0, 255)) - --- | Perform a full handshake with given static key entropy. --- Uses fixed ephemeral keys for determinism. -doHandshake - :: BS.ByteString - -> BS.ByteString - -> Maybe (BOLT8.Session, BOLT8.Session) -doHandshake i_entropy r_entropy = do - (i_s_sec, i_s_pub) <- BOLT8.keypair i_entropy - (r_s_sec, r_s_pub) <- BOLT8.keypair r_entropy - let i_e = BS.replicate 32 0x12 - r_e = BS.replicate 32 0x22 - (msg1, i_hs) <- either (const Nothing) Just $ - BOLT8.act1 i_s_sec i_s_pub r_s_pub i_e - (msg2, r_hs) <- either (const Nothing) Just $ - BOLT8.act2 r_s_sec r_s_pub r_e msg1 - (msg3, i_res) <- either (const Nothing) Just $ - BOLT8.act3 i_hs msg2 - r_res <- either (const Nothing) Just $ - BOLT8.finalize r_hs msg3 - pure (BOLT8.session i_res, BOLT8.session r_res) - --- properties ------------------------------------------------------------------ - --- | Handshake succeeds for valid keys and sessions are consistent. -prop_handshake_roundtrip :: Property -prop_handshake_roundtrip = forAll genValidEntropy $ \i_ent -> - forAll genValidEntropy $ \r_ent -> - case doHandshake i_ent r_ent of - Nothing -> False - Just _ -> True - --- | Encrypt then decrypt yields original payload. -prop_encrypt_decrypt_roundtrip :: Property -prop_encrypt_decrypt_roundtrip = forAll genPayload $ \payload -> - case doHandshake initiator_s_priv responder_s_priv of - Nothing -> False - Just (i_sess, r_sess) -> - case BOLT8.encrypt i_sess payload of - Left _ -> False - Right (ct, _) -> - case BOLT8.decrypt r_sess ct of - Left _ -> False - Right (pt, _) -> pt == payload - --- | decrypt_frame consumes exactly one frame and returns remainder. -prop_frame_consumes_one :: Property -prop_frame_consumes_one = forAll genPayload $ \p1 -> - forAll genPayload $ \p2 -> - case doHandshake initiator_s_priv responder_s_priv of - Nothing -> False - Just (i_sess, r_sess) -> - case BOLT8.encrypt i_sess p1 of - Left _ -> False - Right (ct1, i_sess') -> - case BOLT8.encrypt i_sess' p2 of - Left _ -> False - Right (ct2, _) -> - let buf = ct1 <> ct2 - in case BOLT8.decrypt_frame r_sess buf of - Left _ -> False - Right (pt1, rest, r_sess') -> - pt1 == p1 && - case BOLT8.decrypt_frame r_sess' rest of - Left _ -> False - Right (pt2, rest2, _) -> - pt2 == p2 && BS.null rest2 - --- | decrypt_frame_partial returns NeedMore when buffer < 18 bytes. -prop_partial_needmore_short :: Property -prop_partial_needmore_short = forAll (choose (0, 17)) $ \len -> - case doHandshake initiator_s_priv responder_s_priv of - Nothing -> False - Just (_, r_sess) -> - let buf = BS.replicate len 0x00 - in case BOLT8.decrypt_frame_partial r_sess buf of - BOLT8.NeedMore n -> n == 18 - len - _ -> False +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import qualified Crypto.AEAD.ChaCha20Poly1305 as AEAD +import qualified Crypto.Hash.SHA256 as SHA256 +import qualified Crypto.KDF.HMAC as HKDF +import Data.Bits (shiftR, xor) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Base16 as B16 +import Data.Maybe (isJust, isNothing) +import Data.Word (Word64) +import qualified Lightning.Protocol.BOLT8 as BOLT8 +import Test.Tasty +import Test.Tasty.HUnit +import qualified Test.Tasty.QuickCheck as Q + +main :: IO () +main = defaultMain $ testGroup "ppad-bolt8" [ + key_tests + , handshake_tests + , handshake_failure_tests + , message_tests + , transport_tests + , transport_failure_tests + , property_tests + ] + +-- helpers -------------------------------------------------------------------- + +expect_just :: String -> Maybe a -> IO a +expect_just msg = maybe (assertFailure msg) pure + +expect_right :: Show e => String -> Either e a -> IO a +expect_right msg = either (\e -> assertFailure (msg <> ": " <> show e)) pure + +-- assert failure with a specific error +expect_error :: String -> BOLT8.Error -> Either BOLT8.Error a -> Assertion +expect_error msg want r = case r of + Left got -> assertEqual msg want got + Right _ -> assertFailure (msg <> ": expected " <> show want) + +-- decode a hex literal, failing the test if it is malformed +unhex :: BS.ByteString -> IO BS.ByteString +unhex h = expect_just ("invalid hex: " <> show h) (B16.decode h) + +-- total lookup +at :: Int -> [a] -> Maybe a +at i xs = case drop i xs of + (x : _) | i >= 0 -> Just x + _ -> Nothing + +-- flip all bits of the byte at the given index +flip_byte :: Int -> BS.ByteString -> IO BS.ByteString +flip_byte i bs + | i < 0 || i >= BS.length bs = + assertFailure ("flip_byte: index out of bounds: " <> show i) + | otherwise = + let (pre, post) = BS.splitAt i bs + in pure (pre <> BS.map (xor 0xff) (BS.take 1 post) <> BS.drop 1 post) + +-- payload for the m'th message of a test stream +payload :: Int -> BS.ByteString +payload m = BS.replicate (m `mod` 7) (fromIntegral m) + +-- Appendix A key material ---------------------------------------------------- + +ls_i_sec, e_i_sec, ls_r_sec, e_r_sec :: BS.ByteString +ls_i_sec = BS.replicate 32 0x11 +e_i_sec = BS.replicate 32 0x12 +ls_r_sec = BS.replicate 32 0x21 +e_r_sec = BS.replicate 32 0x22 + +ls_i_pub, ls_r_pub, e_i_pub, e_r_pub :: BS.ByteString +ls_i_pub = + "034f355bdcb7cc0af728ef3cceb9615d90684bb5b2ca5f859ab0f0b704075871aa" +ls_r_pub = + "028d7500dd4c12685d1f568b4c2b5048e8534b873319f3a8daa612b469132ec7f7" +e_i_pub = + "036360e856310ce5d294e8be33fc807077dc56ac80d95d9cd4ddbd21325eff73f7" +e_r_pub = + "02466d7fcae563e5cb09a0d1870bb580344804617879a14949cf22285f1bae3f27" + +act1_msg, act2_msg, act3_msg :: BS.ByteString +act1_msg = + "00036360e856310ce5d294e8be33fc807077dc56ac80d95d9cd4ddbd21325eff73f7\ + \0df6086551151f58b8afe6c195782c6a" +act2_msg = + "0002466d7fcae563e5cb09a0d1870bb580344804617879a14949cf22285f1bae3f27\ + \6e2470b93aac583c9ef6eafca3f730ae" +act3_msg = + "00b9e3a702e93e3a9948c2ed6e5fd7590a6e1c3a0344cfc9d5b57357049aa22355\ + \361aa02e55a8fc28fef5bd6d71ad0c38228dc68b1c466263b47fdf31e560e139ba" + +-- final chaining key, and the initiator's sending and receiving keys +-- (the responder's are swapped) +final_ck, final_sk, final_rk :: BS.ByteString +final_ck = + "919219dbb2920afa8db80f9a51787a840bcf111ed8d588caf9ab4be716e42b01" +final_sk = + "969ab31b4d288cedf6218839b27a3e2140827047f2c0f01bf5c04435d43511a9" +final_rk = + "bb9020b8965f4df047e07f955f3c4b88418984aadc5cdb35096b9ea8fa5c3442" + +spec_keypairs :: IO (BOLT8.Keypair, BOLT8.Keypair) +spec_keypairs = do + i <- expect_just "initiator keypair" (BOLT8.keypair ls_i_sec) + r <- expect_just "responder keypair" (BOLT8.keypair ls_r_sec) + pure (i, r) + +-- the Appendix A handshake, as (initiator, responder) results +spec_handshake :: Either BOLT8.Error (BOLT8.Handshake, BOLT8.Handshake) +spec_handshake = do + i <- maybe (Left BOLT8.InvalidEntropy) Right (BOLT8.keypair ls_i_sec) + r <- maybe (Left BOLT8.InvalidEntropy) Right (BOLT8.keypair ls_r_sec) + handshake i r e_i_sec e_r_sec + +spec_results :: IO (BOLT8.Handshake, BOLT8.Handshake) +spec_results = expect_right "spec handshake" spec_handshake + +handshake + :: BOLT8.Keypair + -> BOLT8.Keypair + -> BS.ByteString + -> BS.ByteString + -> Either BOLT8.Error (BOLT8.Handshake, BOLT8.Handshake) +handshake i r i_e r_e = do + (msg1, i_hs) <- BOLT8.act1 i (BOLT8.keypair_pub r) i_e + (msg2, r_hs) <- BOLT8.act2 r r_e msg1 + (msg3, i_res) <- BOLT8.act3 i_hs msg2 + r_res <- BOLT8.finalize r_hs msg3 + pure (i_res, r_res) + +-- reference transport -------------------------------------------------------- + +-- BOLT #8 framing and rotation built directly on ppad-aead and +-- ppad-hkdf, as an independent check of the library's key schedule. + +ref_nonce :: Word64 -> BS.ByteString +ref_nonce n = BS.replicate 4 0 <> + BS.pack [fromIntegral (n `shiftR` (8 * j)) | j <- [0 .. 7]] + +ref_frame :: BS.ByteString -> Word64 -> BS.ByteString -> IO BS.ByteString +ref_frame k n m = do + let len = BS.length m + l = BS.pack [fromIntegral (len `shiftR` 8), fromIntegral len] + (lc, lt) <- expect_right "aead" (AEAD.encrypt mempty k (ref_nonce n) l) + (c, t) <- expect_right "aead" (AEAD.encrypt mempty k (ref_nonce (n + 1)) m) + pure (lc <> lt <> c <> t) + +-- (ck', k') = HKDF(ck, k) +ref_rotate + :: BS.ByteString -> BS.ByteString -> IO (BS.ByteString, BS.ByteString) +ref_rotate ck k = do + out <- expect_just "hkdf" (HKDF.derive hmac ck mempty 64 k) + pure (BS.splitAt 32 out) + where + hmac a b = case SHA256.hmac a b of SHA256.MAC mac -> mac + +-- frames carrying 'payload' 0 .. count - 1, sent under key k and +-- chaining key ck +ref_stream :: BS.ByteString -> BS.ByteString -> Int -> IO [BS.ByteString] +ref_stream = go 0 0 + where + go m n ck k count + | m == count = pure [] + | n >= 1000 = do + (ck', k') <- ref_rotate ck k + go m 0 ck' k' count + | otherwise = do + f <- ref_frame k n (payload m) + fs <- go (m + 1) (n + 2) ck k count + pure (f : fs) + +-- assert that a Sender encrypts under key k with chaining key ck, +-- across two rotations +check_sender :: BS.ByteString -> BS.ByteString -> BOLT8.Sender -> Assertion +check_sender ck k s0 = do + ref <- ref_stream ck k 1002 + let go _ _ [] = pure () + go m s (f : fs) = do + (ct, s') <- expect_right "encrypt" (BOLT8.encrypt s (payload m)) + assertEqual ("frame " <> show m) f ct + go (m + 1) s' fs + go (0 :: Int) s0 ref + +-- assert that a Receiver decrypts under key k with chaining key ck, +-- across two rotations +check_receiver + :: BS.ByteString -> BS.ByteString -> BOLT8.Receiver -> Assertion +check_receiver ck k r0 = do + ref <- ref_stream ck k 1002 + let go _ _ [] = pure () + go m r (f : fs) = do + (pt, r') <- expect_right ("decrypt " <> show m) (BOLT8.decrypt r f) + assertEqual ("message " <> show m) (payload m) pt + go (m + 1) r' fs + go (0 :: Int) r0 ref + +-- send 'payload' 0 .. count - 1 from a Sender to a Receiver +round_trip :: Int -> BOLT8.Sender -> BOLT8.Receiver -> Assertion +round_trip count = go 0 + where + go m s r + | m == count = pure () + | otherwise = do + (ct, s') <- expect_right "encrypt" (BOLT8.encrypt s (payload m)) + (pt, r') <- expect_right ("decrypt " <> show m) (BOLT8.decrypt r ct) + assertEqual ("message " <> show m) (payload m) pt + go (m + 1) s' r' + +-- keys ----------------------------------------------------------------------- + +-- 32-byte strings (and one short one) that are not valid secret keys +invalid_secrets :: IO [(String, BS.ByteString)] +invalid_secrets = do + n <- unhex + "fffffffffffffffffffffffffffffffebaaedce6af48a03bbfd25e8cd0364141" + pure [ + ("zero", BS.replicate 32 0) + , ("order", n) + , ("2^256 - 1", BS.replicate 32 0xff) + , ("31 bytes", BS.replicate 31 0x12) + ] + +-- 33-byte compressed encodings that are not curve points +invalid_points :: IO [(String, BS.ByteString)] +invalid_points = do + -- x = p + 1 is congruent to 1, which is on the curve, but not < p + p_1 <- unhex + "fffffffffffffffffffffffffffffffffffffffffffffffffffffffefffffc30" + pure [ + ("x = 0, no square root", BS.cons 0x02 (BS.replicate 32 0)) + , ("x = 5, no square root", BS.cons 0x03 (BS.replicate 31 0 <> "\x05")) + , ("x = p + 1", BS.cons 0x02 p_1) + ] + +-- replace the 33-byte key in a 50-byte act one or act two message +with_key :: BS.ByteString -> BS.ByteString -> BS.ByteString +with_key pt msg = BS.take 1 msg <> pt <> BS.drop 34 msg + +key_tests :: TestTree +key_tests = testGroup "keys" [ + testCase "keypair derives the spec static keys" $ do + (i, r) <- spec_keypairs + want_i <- unhex ls_i_pub + want_r <- unhex ls_r_pub + BOLT8.serialize_pub (BOLT8.keypair_pub i) @?= want_i + BOLT8.serialize_pub (BOLT8.keypair_pub r) @?= want_r + , testCase "keypair rejects invalid secrets" $ do + n <- unhex + "fffffffffffffffffffffffffffffffebaaedce6af48a03bbfd25e8cd0364141" + n_1 <- unhex + "fffffffffffffffffffffffffffffffebaaedce6af48a03bbfd25e8cd0364140" + assertBool "31 bytes" (isNothing (BOLT8.keypair (BS.replicate 31 1))) + assertBool "33 bytes" (isNothing (BOLT8.keypair (BS.replicate 33 1))) + assertBool "zero" (isNothing (BOLT8.keypair (BS.replicate 32 0))) + assertBool "order" (isNothing (BOLT8.keypair n)) + assertBool "2^256 - 1" (isNothing (BOLT8.keypair (BS.replicate 32 0xff))) + assertBool "order - 1" (isJust (BOLT8.keypair n_1)) + , testCase "parse_pub round-trips compressed keys" $ do + bs <- unhex ls_r_pub + pub <- expect_just "parse_pub" (BOLT8.parse_pub bs) + BOLT8.serialize_pub pub @?= bs + , testCase "parse_pub rejects points off the curve" $ do + bad <- invalid_points + mapM_ (\(name, pt) -> + assertBool name (isNothing (BOLT8.parse_pub pt))) bad + , testCase "parse_pub rejects other encodings" $ do + -- the generator, uncompressed and x-only + g_full <- unhex + "0479be667ef9dcbbac55a06295ce870b07029bfcdb2dce28d959f2815b16f81798\ + \483ada7726a3c4655da4fbfc0e1108a8fd17b448a68554199c47d08ffb10d4b8" + g_x <- unhex + "79be667ef9dcbbac55a06295ce870b07029bfcdb2dce28d959f2815b16f81798" + bs <- unhex ls_r_pub + assertBool "uncompressed" (isNothing (BOLT8.parse_pub g_full)) + assertBool "x-only" (isNothing (BOLT8.parse_pub g_x)) + assertBool "0x04 prefix" + (isNothing (BOLT8.parse_pub (BS.cons 0x04 (BS.drop 1 bs)))) + assertBool "34 bytes" (isNothing (BOLT8.parse_pub (bs <> "\x00"))) + ] + +-- handshake ------------------------------------------------------------------ + +handshake_tests :: TestTree +handshake_tests = testGroup "handshake" [ + testCase "act one matches spec" $ do + (i, _) <- spec_keypairs + rs <- unhex ls_r_pub >>= expect_just "rs" . BOLT8.parse_pub + (msg1, _) <- expect_right "act1" (BOLT8.act1 i rs e_i_sec) + want <- unhex act1_msg + e <- unhex e_i_pub + msg1 @?= want + BS.take 33 (BS.drop 1 msg1) @?= e + , testCase "act two matches spec" $ do + (_, r) <- spec_keypairs + msg1 <- unhex act1_msg + (msg2, _) <- expect_right "act2" (BOLT8.act2 r e_r_sec msg1) + want <- unhex act2_msg + e <- unhex e_r_pub + msg2 @?= want + BS.take 33 (BS.drop 1 msg2) @?= e + , testCase "act three matches spec" $ do + (i, r) <- spec_keypairs + (_, i_hs) <- expect_right "act1" + (BOLT8.act1 i (BOLT8.keypair_pub r) e_i_sec) + msg2 <- unhex act2_msg + (msg3, _) <- expect_right "act3" (BOLT8.act3 i_hs msg2) + want <- unhex act3_msg + msg3 @?= want + , testCase "finalize accepts spec act three" $ do + (_, r) <- spec_keypairs + msg1 <- unhex act1_msg + msg3 <- unhex act3_msg + (_, r_hs) <- expect_right "act2" (BOLT8.act2 r e_r_sec msg1) + r_res <- expect_right "finalize" (BOLT8.finalize r_hs msg3) + want <- unhex ls_i_pub + BOLT8.serialize_pub (BOLT8.handshake_remote_static r_res) @?= want + , testCase "act1 rejects invalid entropy" $ do + (i, r) <- spec_keypairs + let rs = BOLT8.keypair_pub r + bad <- invalid_secrets + mapM_ (\(name, e) -> expect_error name BOLT8.InvalidEntropy + (BOLT8.act1 i rs e)) bad + , testCase "act2 rejects invalid entropy" $ do + (_, r) <- spec_keypairs + msg1 <- unhex act1_msg + bad <- invalid_secrets + mapM_ (\(name, e) -> expect_error name BOLT8.InvalidEntropy + (BOLT8.act2 r e msg1)) bad + , testCase "act2 rejects an ephemeral key off the curve" $ do + (_, r) <- spec_keypairs + msg1 <- unhex act1_msg + bad <- invalid_points + mapM_ (\(name, pt) -> expect_error name BOLT8.InvalidPub + (BOLT8.act2 r e_r_sec (with_key pt msg1))) bad + , testCase "act3 rejects an ephemeral key off the curve" $ do + (i, r) <- spec_keypairs + (_, i_hs) <- expect_right "act1" + (BOLT8.act1 i (BOLT8.keypair_pub r) e_i_sec) + msg2 <- unhex act2_msg + bad <- invalid_points + mapM_ (\(name, pt) -> expect_error name BOLT8.InvalidPub + (BOLT8.act3 i_hs (with_key pt msg2))) bad + , testCase "acts reject oversized input" $ do + (i, r) <- spec_keypairs + msg1 <- unhex act1_msg + msg2 <- unhex act2_msg + msg3 <- unhex act3_msg + (_, i_hs) <- expect_right "act1" + (BOLT8.act1 i (BOLT8.keypair_pub r) e_i_sec) + (_, r_hs) <- expect_right "act2" (BOLT8.act2 r e_r_sec msg1) + expect_error "act2" BOLT8.InvalidLength + (BOLT8.act2 r e_r_sec (msg1 <> "\x00")) + expect_error "act3" BOLT8.InvalidLength + (BOLT8.act3 i_hs (msg2 <> "\x00")) + expect_error "finalize" BOLT8.InvalidLength + (BOLT8.finalize r_hs (msg3 <> "\x00")) + ] + +-- Appendix A failure vectors ------------------------------------------------- + +data Failure = Failure String BS.ByteString BOLT8.Error + +handshake_failure_tests :: TestTree +handshake_failure_tests = testGroup "Appendix A failure vectors" [ + testGroup "initiator, act two" (fmap initiator_failure act2_failures) + , testGroup "responder, act one" (fmap act1_failure act1_failures) + , testGroup "responder, act three" (fmap act3_failure act3_failures) + ] + +initiator_failure :: Failure -> TestTree +initiator_failure (Failure name input want) = testCase name $ do + (i, _) <- spec_keypairs + rs <- unhex ls_r_pub >>= expect_just "rs" . BOLT8.parse_pub + (msg1, i_hs) <- expect_right "act1" (BOLT8.act1 i rs e_i_sec) + unhex act1_msg >>= (msg1 @?=) + msg2 <- unhex input + expect_error name want (BOLT8.act3 i_hs msg2) + +act1_failure :: Failure -> TestTree +act1_failure (Failure name input want) = testCase name $ do + (_, r) <- spec_keypairs + msg1 <- unhex input + expect_error name want (BOLT8.act2 r e_r_sec msg1) + +act3_failure :: Failure -> TestTree +act3_failure (Failure name input want) = testCase name $ do + (_, r) <- spec_keypairs + msg1 <- unhex act1_msg + (msg2, r_hs) <- expect_right "act2" (BOLT8.act2 r e_r_sec msg1) + unhex act2_msg >>= (msg2 @?=) + msg3 <- unhex input + expect_error name want (BOLT8.finalize r_hs msg3) + +act2_failures :: [Failure] +act2_failures = [ + Failure "short read" + "0002466d7fcae563e5cb09a0d1870bb580344804617879a14949cf22285f1bae3f27\ + \6e2470b93aac583c9ef6eafca3f730" + BOLT8.InvalidLength + , Failure "bad version" + "0102466d7fcae563e5cb09a0d1870bb580344804617879a14949cf22285f1bae3f27\ + \6e2470b93aac583c9ef6eafca3f730ae" + BOLT8.InvalidVersion + , Failure "bad key serialization" + "0004466d7fcae563e5cb09a0d1870bb580344804617879a14949cf22285f1bae3f27\ + \6e2470b93aac583c9ef6eafca3f730ae" + BOLT8.InvalidPub + , Failure "bad MAC" + "0002466d7fcae563e5cb09a0d1870bb580344804617879a14949cf22285f1bae3f27\ + \6e2470b93aac583c9ef6eafca3f730af" + BOLT8.InvalidMAC + ] + +act1_failures :: [Failure] +act1_failures = [ + Failure "short read" + "00036360e856310ce5d294e8be33fc807077dc56ac80d95d9cd4ddbd21325eff73f7\ + \0df6086551151f58b8afe6c195782c" + BOLT8.InvalidLength + , Failure "bad version" + "01036360e856310ce5d294e8be33fc807077dc56ac80d95d9cd4ddbd21325eff73f7\ + \0df6086551151f58b8afe6c195782c6a" + BOLT8.InvalidVersion + , Failure "bad key serialization" + "00046360e856310ce5d294e8be33fc807077dc56ac80d95d9cd4ddbd21325eff73f7\ + \0df6086551151f58b8afe6c195782c6a" + BOLT8.InvalidPub + , Failure "bad MAC" + "00036360e856310ce5d294e8be33fc807077dc56ac80d95d9cd4ddbd21325eff73f7\ + \0df6086551151f58b8afe6c195782c6b" + BOLT8.InvalidMAC + ] + +act3_failures :: [Failure] +act3_failures = [ + Failure "bad version" + "01b9e3a702e93e3a9948c2ed6e5fd7590a6e1c3a0344cfc9d5b57357049aa22355\ + \361aa02e55a8fc28fef5bd6d71ad0c38228dc68b1c466263b47fdf31e560e139ba" + BOLT8.InvalidVersion + , Failure "short read" + "00b9e3a702e93e3a9948c2ed6e5fd7590a6e1c3a0344cfc9d5b57357049aa22355\ + \361aa02e55a8fc28fef5bd6d71ad0c38228dc68b1c466263b47fdf31e560e139" + BOLT8.InvalidLength + , Failure "bad MAC for ciphertext" + "00c9e3a702e93e3a9948c2ed6e5fd7590a6e1c3a0344cfc9d5b57357049aa22355\ + \361aa02e55a8fc28fef5bd6d71ad0c38228dc68b1c466263b47fdf31e560e139ba" + BOLT8.InvalidMAC + , Failure "bad rs" + "00bfe3a702e93e3a9948c2ed6e5fd7590a6e1c3a0344cfc9d5b57357049aa22355\ + \36ad09a8ee351870c2bb7f78b754a26c6cef79a98d25139c856d7efd252c2ae73c" + BOLT8.InvalidPub + , Failure "bad MAC" + "00b9e3a702e93e3a9948c2ed6e5fd7590a6e1c3a0344cfc9d5b57357049aa22355\ + \361aa02e55a8fc28fef5bd6d71ad0c38228dc68b1c466263b47fdf31e560e139bb" + BOLT8.InvalidMAC + ] + +-- message encryption --------------------------------------------------------- + +-- Appendix A message test: "hello" sent 1001 times by the initiator +spec_messages :: [(Int, BS.ByteString)] +spec_messages = [ + (0, "cf2b30ddf0cf3f80e7c35a6e6730b59fe802473180f396d88a8fb0db8cbc\ + \f25d2f214cf9ea1d95") + , (1, "72887022101f0b6753e0c7de21657d35a4cb2a1f5cde2650528bbc8f837d\ + \0f0d7ad833b1a256a1") + , (500, "178cb9d7387190fa34db9c2d50027d21793c9bc2d40b1e14dcf30ebeeeb2\ + \20f48364f7a4c68bf8") + , (501, "1b186c57d44eb6de4c057c49940d79bb838a145cb528d6e8fd26dbe50a60\ + \ca2c104b56b60e45bd") + , (1000, "4a2f3cc3b5e78ddb83dcb426d9863d9d9a723b0337c89dd0b005d89f8d3c\ + \05c52b76b29b740f09") + , (1001, "2ecd8c8a5629d0d02ab457a0fdd0f7b90a192cd46be5ecb6ca570bfc5e26\ + \8338b1a16cf4ef2d36") + ] + +-- the initiator's first n frames, each carrying "hello" +hello_stream :: Int -> IO [BS.ByteString] +hello_stream count = do + (i_res, _) <- spec_results + let go m s + | m == count = pure [] + | otherwise = do + (ct, s') <- expect_right "encrypt" (BOLT8.encrypt s "hello") + (ct :) <$> go (m + 1) s' + go (0 :: Int) (BOLT8.handshake_sender i_res) + +message_tests :: TestTree +message_tests = testGroup "messages" [ + testGroup "spec vectors" (fmap spec_message spec_messages) + , testCase "responder decrypts the spec stream" $ do + (_, r_res) <- spec_results + frames <- hello_stream 1002 + let go _ _ [] = pure () + go m r (f : fs) = do + (pt, r') <- expect_right ("decrypt " <> show m) (BOLT8.decrypt r f) + assertEqual ("message " <> show m) "hello" pt + go (m + 1) r' fs + go (0 :: Int) (BOLT8.handshake_receiver r_res) frames + , testCase "reference key rotation matches spec" $ do + ck <- unhex final_ck + sk <- unhex final_sk + ck1 <- unhex + "cc2c6e467efc8067720c2d09c139d1f77731893aad1defa14f9bf3c48d3f1d31" + k1 <- unhex + "3fbdc101abd1132ca3a0ae34a669d8d9ba69a587e0bb4ddd59524541cf4813d8" + ck2 <- unhex + "728366ed68565dc17cf6dd97330a859a6a56e87e2beef3bd828a4c4a54d8df06" + k2 <- unhex + "9e0477f9850dca41e42db0e4d154e3a098e5a000d995e421849fcd5df27882bd" + ref_rotate ck sk >>= (@?= (ck1, k1)) + ref_rotate ck1 k1 >>= (@?= (ck2, k2)) + , testCase "initiator sends under sk and ck" $ do + (i_res, _) <- spec_results + ck <- unhex final_ck + sk <- unhex final_sk + check_sender ck sk (BOLT8.handshake_sender i_res) + , testCase "initiator receives under rk and ck" $ do + (i_res, _) <- spec_results + ck <- unhex final_ck + rk <- unhex final_rk + check_receiver ck rk (BOLT8.handshake_receiver i_res) + , testCase "responder sends under rk and ck" $ do + (_, r_res) <- spec_results + ck <- unhex final_ck + rk <- unhex final_rk + check_sender ck rk (BOLT8.handshake_sender r_res) + , testCase "responder receives under sk and ck" $ do + (_, r_res) <- spec_results + ck <- unhex final_ck + sk <- unhex final_sk + check_receiver ck sk (BOLT8.handshake_receiver r_res) + , testCase "initiator to responder across rotations" $ do + (i_res, r_res) <- spec_results + round_trip 1600 + (BOLT8.handshake_sender i_res) (BOLT8.handshake_receiver r_res) + , testCase "responder to initiator across rotations" $ do + (i_res, r_res) <- spec_results + round_trip 1600 + (BOLT8.handshake_sender r_res) (BOLT8.handshake_receiver i_res) + ] + +spec_message :: (Int, BS.ByteString) -> TestTree +spec_message (m, h) = testCase ("message " <> show m) $ do + frames <- hello_stream 1002 + got <- expect_just "frame" (at m frames) + want <- unhex h + got @?= want + +-- transport ------------------------------------------------------------------ + +-- the spec handshake's transport states and the initiator's first two +-- frames, carrying "hello" and "world!" +transport_fixture + :: IO (BOLT8.Sender, BOLT8.Receiver, BOLT8.Receiver, BS.ByteString, + BS.ByteString) +transport_fixture = do + (i_res, r_res) <- spec_results + let i_snd = BOLT8.handshake_sender i_res + (f0, i_snd') <- expect_right "encrypt" (BOLT8.encrypt i_snd "hello") + (f1, _) <- expect_right "encrypt" (BOLT8.encrypt i_snd' "world!") + pure ( i_snd, BOLT8.handshake_receiver i_res + , BOLT8.handshake_receiver r_res, f0, f1 ) + +-- consume a buffer of frames via decrypt_header and decrypt_body +consume + :: BOLT8.Receiver + -> BS.ByteString + -> Either BOLT8.Error [BS.ByteString] +consume r buf + | BS.null buf = Right [] + | otherwise = do + let (hdr, rest) = BS.splitAt 18 buf + (n, p) <- BOLT8.decrypt_header r hdr + let (body, rest') = BS.splitAt n rest + (m, r') <- BOLT8.decrypt_body p body + (m :) <$> consume r' rest' + +transport_tests :: TestTree +transport_tests = testGroup "transport" [ + testCase "frame is message length plus 34 bytes" $ do + (_, _, _, f0, f1) <- transport_fixture + BS.length f0 @?= 5 + 34 + BS.length f1 @?= 6 + 34 + , testCase "decrypt_header reports the remaining length" $ do + (_, _, r, f0, _) <- transport_fixture + (n, _) <- expect_right "header" (BOLT8.decrypt_header r (BS.take 18 f0)) + n @?= 5 + 16 + , testCase "header and body decrypt consecutive frames" $ do + (_, _, r, f0, f1) <- transport_fixture + ms <- expect_right "consume" (consume r (f0 <> f1)) + ms @?= ["hello", "world!"] + , testCase "decrypt agrees with header and body" $ do + (_, _, r, f0, f1) <- transport_fixture + (m0, r') <- expect_right "decrypt 0" (BOLT8.decrypt r f0) + (m1, _) <- expect_right "decrypt 1" (BOLT8.decrypt r' f1) + [m0, m1] @?= ["hello", "world!"] + , testCase "empty message round-trips" $ do + (s, _, r, _, _) <- transport_fixture + (f, _) <- expect_right "encrypt" (BOLT8.encrypt s mempty) + BS.length f @?= 34 + (m, _) <- expect_right "decrypt" (BOLT8.decrypt r f) + m @?= mempty + , testCase "65535-byte message round-trips" $ do + (s, _, r, _, _) <- transport_fixture + let big = BS.replicate 65535 0xab + (f, _) <- expect_right "encrypt" (BOLT8.encrypt s big) + BS.length f @?= 65569 + (n, _) <- expect_right "header" (BOLT8.decrypt_header r (BS.take 18 f)) + n @?= 65551 + (m, _) <- expect_right "decrypt" (BOLT8.decrypt r f) + m @?= big + , testCase "encrypt rejects a 65536-byte message" $ do + (s, _, _, _, _) <- transport_fixture + expect_error "encrypt" BOLT8.InvalidLength + (BOLT8.encrypt s (BS.replicate 65536 0)) + ] + +transport_failure_tests :: TestTree +transport_failure_tests = testGroup "transport failures" [ + testCase "bad length MAC" $ do + (_, _, r, f0, _) <- transport_fixture + for_bytes [2, 17] f0 $ \bad -> do + expect_error "decrypt" BOLT8.InvalidMAC (BOLT8.decrypt r bad) + expect_error "decrypt_header" BOLT8.InvalidMAC + (BOLT8.decrypt_header r (BS.take 18 bad)) + , testCase "tampered length" $ do + (_, _, r, f0, _) <- transport_fixture + for_bytes [0, 1] f0 $ \bad -> do + expect_error "decrypt" BOLT8.InvalidMAC (BOLT8.decrypt r bad) + expect_error "decrypt_header" BOLT8.InvalidMAC + (BOLT8.decrypt_header r (BS.take 18 bad)) + , testCase "bad body MAC" $ do + (_, _, r, f0, _) <- transport_fixture + for_bytes [18, 23, BS.length f0 - 1] f0 $ \bad -> do + expect_error "decrypt" BOLT8.InvalidMAC (BOLT8.decrypt r bad) + (n, p) <- expect_right "header" + (BOLT8.decrypt_header r (BS.take 18 bad)) + expect_error "decrypt_body" BOLT8.InvalidMAC + (BOLT8.decrypt_body p (BS.take n (BS.drop 18 bad))) + , testCase "truncated frame" $ do + (_, _, r, f0, _) <- transport_fixture + let short = BS.take (BS.length f0 - 1) f0 + expect_error "decrypt" BOLT8.InvalidLength (BOLT8.decrypt r short) + expect_error "decrypt, header only" BOLT8.InvalidLength + (BOLT8.decrypt r (BS.take 18 f0)) + expect_error "decrypt, partial header" BOLT8.InvalidLength + (BOLT8.decrypt r (BS.take 17 f0)) + expect_error "decrypt, empty" BOLT8.InvalidLength + (BOLT8.decrypt r mempty) + expect_error "decrypt_header" BOLT8.InvalidLength + (BOLT8.decrypt_header r (BS.take 17 f0)) + (_, p) <- expect_right "header" (BOLT8.decrypt_header r (BS.take 18 f0)) + expect_error "decrypt_body" BOLT8.InvalidLength + (BOLT8.decrypt_body p (BS.drop 18 short)) + , testCase "trailing bytes" $ do + (_, _, r, f0, _) <- transport_fixture + let long = f0 <> "\x00" + expect_error "decrypt" BOLT8.InvalidLength (BOLT8.decrypt r long) + expect_error "decrypt_header" BOLT8.InvalidLength + (BOLT8.decrypt_header r (BS.take 19 f0)) + (_, p) <- expect_right "header" (BOLT8.decrypt_header r (BS.take 18 f0)) + expect_error "decrypt_body" BOLT8.InvalidLength + (BOLT8.decrypt_body p (BS.drop 18 long)) + , testCase "replayed frame" $ do + (_, _, r, f0, _) <- transport_fixture + (_, r') <- expect_right "decrypt" (BOLT8.decrypt r f0) + expect_error "replay" BOLT8.InvalidMAC (BOLT8.decrypt r' f0) + , testCase "reordered frame" $ do + (_, _, r, _, f1) <- transport_fixture + expect_error "decrypt" BOLT8.InvalidMAC (BOLT8.decrypt r f1) + , testCase "reflected frame" $ do + (_, i_rcv, _, f0, _) <- transport_fixture + expect_error "decrypt" BOLT8.InvalidMAC (BOLT8.decrypt i_rcv f0) + ] + where + for_bytes is f act = mapM_ (\i -> flip_byte i f >>= act) is + +-- properties ----------------------------------------------------------------- + +property_tests :: TestTree +property_tests = testGroup "properties" [ + Q.testProperty "handshake agrees on keys and statics" prop_handshake + , Q.testProperty "messages up to 65535 bytes round-trip" prop_size + , Q.testProperty "header and body recover a stream" prop_stream + , Q.testProperty "parse_pub inverts serialize_pub" prop_pub + ] + +-- 32 bytes that form a valid secret key +gen_secret :: Q.Gen BS.ByteString +gen_secret = (BS.pack <$> Q.vectorOf 32 Q.arbitrary) + `Q.suchThat` (isJust . BOLT8.keypair) + +gen_bytes :: Int -> Q.Gen BS.ByteString +gen_bytes n = do + len <- Q.choose (0, n) + BS.pack <$> Q.vectorOf len Q.arbitrary + +prop_handshake :: Q.Property +prop_handshake = + Q.forAll gen_secret $ \i_s -> + Q.forAll gen_secret $ \r_s -> + Q.forAll gen_secret $ \i_e -> + Q.forAll gen_secret $ \r_e -> + Q.forAll (gen_bytes 256) $ \m -> + case (BOLT8.keypair i_s, BOLT8.keypair r_s) of + (Just i, Just r) -> check i r (handshake i r i_e r_e) m + _ -> Q.counterexample "keypair" False + where + check _ _ (Left e) _ = Q.counterexample (show e) False + check i r (Right (i_res, r_res)) m = + let there = send (BOLT8.handshake_sender i_res) + (BOLT8.handshake_receiver r_res) m + back = send (BOLT8.handshake_sender r_res) + (BOLT8.handshake_receiver i_res) m + in BOLT8.handshake_remote_static i_res + Q.=== BOLT8.keypair_pub r + Q..&&. BOLT8.handshake_remote_static r_res + Q.=== BOLT8.keypair_pub i + Q..&&. there Q.=== Right m + Q..&&. back Q.=== Right m + send s r m = do + (ct, _) <- BOLT8.encrypt s m + fst <$> BOLT8.decrypt r ct + +prop_size :: Q.Property +prop_size = + Q.forAll gen_len $ \len -> + Q.forAll Q.arbitrary $ \b -> + let m = BS.replicate len b + in case spec_handshake of + Left e -> Q.counterexample (show e) False + Right (i_res, r_res) -> + case BOLT8.encrypt (BOLT8.handshake_sender i_res) m of + Left e -> Q.counterexample (show e) False + Right (f, _) -> + let r = BOLT8.handshake_receiver r_res + in BS.length f Q.=== len + 34 + Q..&&. fmap fst (BOLT8.decrypt_header r (BS.take 18 f)) + Q.=== Right (len + 16) + Q..&&. fmap fst (BOLT8.decrypt r f) Q.=== Right m + where + gen_len = Q.frequency [ + (1, pure 0) + , (1, pure 65535) + , (8, Q.choose (0, 65535)) + ] + +prop_stream :: Q.Property +prop_stream = + Q.forAll (Q.listOf (gen_bytes 512)) $ \ms -> + case spec_handshake of + Left e -> Q.counterexample (show e) False + Right (i_res, r_res) -> + let enc _ [] = Right [] + enc s (m : rest) = do + (f, s') <- BOLT8.encrypt s m + (f :) <$> enc s' rest + in case enc (BOLT8.handshake_sender i_res) ms of + Left e -> Q.counterexample (show e) False + Right fs -> + consume (BOLT8.handshake_receiver r_res) (BS.concat fs) + Q.=== Right ms + +prop_pub :: Q.Property +prop_pub = Q.forAll gen_secret $ \sec -> + case BOLT8.keypair sec of + Nothing -> Q.counterexample "keypair" False + Just kp -> + let pub = BOLT8.keypair_pub kp + in BOLT8.parse_pub (BOLT8.serialize_pub pub) Q.=== Just pub