Main.hs (30406B)
1 {-# LANGUAGE LambdaCase #-} 2 {-# LANGUAGE OverloadedStrings #-} 3 4 module Main where 5 6 import Data.Bits (xor) 7 import qualified Data.ByteString as BS 8 import qualified Data.ByteString.Base16 as B16 9 import qualified Lightning.Protocol.BOLT8 as BOLT8 10 import Test.Tasty 11 import Test.Tasty.HUnit 12 import Test.Tasty.QuickCheck (Gen, Property, choose, forAll, 13 testProperty, vectorOf, (===), 14 (.&&.)) 15 16 -- test helpers ---------------------------------------------------------------- 17 18 -- | Extract a Just value or fail the test. 19 expectJust :: String -> Maybe a -> IO a 20 expectJust msg = \case 21 Nothing -> assertFailure msg >> error "unreachable" 22 Just a -> pure a 23 24 -- | Extract a Right value or fail the test. 25 expectRight :: Show e => String -> Either e a -> IO a 26 expectRight msg = \case 27 Left e -> assertFailure (msg ++ ": " ++ show e) >> error "unreachable" 28 Right a -> pure a 29 30 main :: IO () 31 main = defaultMain $ testGroup "ppad-bolt8" [ 32 handshake_tests 33 , message_tests 34 , framing_tests 35 , partial_framing_tests 36 , negative_tests 37 , property_tests 38 ] 39 40 -- test vectors from BOLT #8 specification ----------------------------------- 41 42 -- initiator static private key 43 initiator_s_priv :: BS.ByteString 44 initiator_s_priv = hex 45 "1111111111111111111111111111111111111111111111111111111111111111" 46 47 -- initiator ephemeral private key 48 initiator_e_priv :: BS.ByteString 49 initiator_e_priv = hex 50 "1212121212121212121212121212121212121212121212121212121212121212" 51 52 -- responder static private key 53 responder_s_priv :: BS.ByteString 54 responder_s_priv = hex 55 "2121212121212121212121212121212121212121212121212121212121212121" 56 57 -- responder static public key (known to initiator) 58 responder_s_pub :: BS.ByteString 59 responder_s_pub = hex 60 "028d7500dd4c12685d1f568b4c2b5048e8534b873319f3a8daa612b469132ec7f7" 61 62 -- responder ephemeral private key 63 responder_e_priv :: BS.ByteString 64 responder_e_priv = hex 65 "2222222222222222222222222222222222222222222222222222222222222222" 66 67 -- expected act 1 message 68 expected_act1 :: BS.ByteString 69 expected_act1 = hex 70 "00036360e856310ce5d294e8be33fc807077dc56ac80d95d9cd4ddbd21325eff73f7\ 71 \0df6086551151f58b8afe6c195782c6a" 72 73 -- expected act 2 message 74 expected_act2 :: BS.ByteString 75 expected_act2 = hex 76 "0002466d7fcae563e5cb09a0d1870bb580344804617879a14949cf22285f1bae3f27\ 77 \6e2470b93aac583c9ef6eafca3f730ae" 78 79 -- expected act 3 message 80 expected_act3 :: BS.ByteString 81 expected_act3 = hex 82 "00b9e3a702e93e3a9948c2ed6e5fd7590a6e1c3a0344cfc9d5b57357049aa22355\ 83 \361aa02e55a8fc28fef5bd6d71ad0c38228dc68b1c466263b47fdf31e560e139ba" 84 85 -- handshake tests ----------------------------------------------------------- 86 87 handshake_tests :: TestTree 88 handshake_tests = testGroup "Handshake" [ 89 testCase "act1 matches spec vector" test_act1 90 , testCase "act2 matches spec vector" test_act2 91 , testCase "act3 matches spec vector" test_act3 92 , testCase "full handshake round-trip" test_full_handshake 93 ] 94 95 test_act1 :: Assertion 96 test_act1 = do 97 (i_s_sec, i_s_pub) <- expectJust "initiator keypair" 98 (BOLT8.keypair initiator_s_priv) 99 rs <- expectJust "responder pub" (BOLT8.parse_pub responder_s_pub) 100 (act1_msg, _) <- expectRight "act1" (BOLT8.act1 i_s_sec i_s_pub rs 101 initiator_e_priv) 102 act1_msg @?= expected_act1 103 104 test_act2 :: Assertion 105 test_act2 = do 106 (i_s_sec, i_s_pub) <- expectJust "initiator keypair" 107 (BOLT8.keypair initiator_s_priv) 108 (r_s_sec, r_s_pub) <- expectJust "responder keypair" 109 (BOLT8.keypair responder_s_priv) 110 rs <- expectJust "responder pub" (BOLT8.parse_pub responder_s_pub) 111 (msg1, _) <- expectRight "act1" (BOLT8.act1 i_s_sec i_s_pub rs 112 initiator_e_priv) 113 (msg2, _) <- expectRight "act2" (BOLT8.act2 r_s_sec r_s_pub responder_e_priv 114 msg1) 115 msg2 @?= expected_act2 116 117 test_act3 :: Assertion 118 test_act3 = do 119 (i_s_sec, i_s_pub) <- expectJust "initiator keypair" 120 (BOLT8.keypair initiator_s_priv) 121 (r_s_sec, r_s_pub) <- expectJust "responder keypair" 122 (BOLT8.keypair responder_s_priv) 123 rs <- expectJust "responder pub" (BOLT8.parse_pub responder_s_pub) 124 (msg1, i_hs) <- expectRight "act1" (BOLT8.act1 i_s_sec i_s_pub rs 125 initiator_e_priv) 126 (msg2, _) <- expectRight "act2" (BOLT8.act2 r_s_sec r_s_pub responder_e_priv 127 msg1) 128 (msg3, _) <- expectRight "act3" (BOLT8.act3 i_hs msg2) 129 msg3 @?= expected_act3 130 131 test_full_handshake :: Assertion 132 test_full_handshake = do 133 (i_s_sec, i_s_pub) <- expectJust "initiator keypair" 134 (BOLT8.keypair initiator_s_priv) 135 (r_s_sec, r_s_pub) <- expectJust "responder keypair" 136 (BOLT8.keypair responder_s_priv) 137 rs <- expectJust "responder pub" (BOLT8.parse_pub responder_s_pub) 138 (msg1, i_hs) <- expectRight "act1" (BOLT8.act1 i_s_sec i_s_pub rs 139 initiator_e_priv) 140 (msg2, r_hs) <- expectRight "act2" (BOLT8.act2 r_s_sec r_s_pub responder_e_priv 141 msg1) 142 (msg3, i_result) <- expectRight "act3" (BOLT8.act3 i_hs msg2) 143 r_result <- expectRight "finalize" (BOLT8.finalize r_hs msg3) 144 BOLT8.remote_static i_result @?= r_s_pub 145 BOLT8.remote_static r_result @?= i_s_pub 146 147 -- message encryption tests -------------------------------------------------- 148 149 message_tests :: TestTree 150 message_tests = testGroup "Message Encryption" [ 151 testCase "message 0 matches spec" test_message_0 152 , testCase "message 1 matches spec" test_message_1 153 , testCase "message 500 matches spec" test_message_500 154 , testCase "message 501 matches spec" test_message_501 155 , testCase "message 1000 matches spec" test_message_1000 156 , testCase "message 1001 matches spec" test_message_1001 157 , testCase "decrypt round-trip" test_decrypt_roundtrip 158 ] 159 160 -- "hello" = 0x68656c6c6f 161 hello :: BS.ByteString 162 hello = "hello" 163 164 -- expected encrypted messages 165 expected_msg_0 :: BS.ByteString 166 expected_msg_0 = hex 167 "cf2b30ddf0cf3f80e7c35a6e6730b59fe802473180f396d88a8fb0db8cbcf25d\ 168 \2f214cf9ea1d95" 169 170 expected_msg_1 :: BS.ByteString 171 expected_msg_1 = hex 172 "72887022101f0b6753e0c7de21657d35a4cb2a1f5cde2650528bbc8f837d0f0d\ 173 \7ad833b1a256a1" 174 175 expected_msg_500 :: BS.ByteString 176 expected_msg_500 = hex 177 "178cb9d7387190fa34db9c2d50027d21793c9bc2d40b1e14dcf30ebeeeb220f4\ 178 \8364f7a4c68bf8" 179 180 expected_msg_501 :: BS.ByteString 181 expected_msg_501 = hex 182 "1b186c57d44eb6de4c057c49940d79bb838a145cb528d6e8fd26dbe50a60ca2c\ 183 \104b56b60e45bd" 184 185 expected_msg_1000 :: BS.ByteString 186 expected_msg_1000 = hex 187 "4a2f3cc3b5e78ddb83dcb426d9863d9d9a723b0337c89dd0b005d89f8d3c05c5\ 188 \2b76b29b740f09" 189 190 expected_msg_1001 :: BS.ByteString 191 expected_msg_1001 = hex 192 "2ecd8c8a5629d0d02ab457a0fdd0f7b90a192cd46be5ecb6ca570bfc5e268338\ 193 \b1a16cf4ef2d36" 194 195 -- helper to get initiator session after handshake 196 get_initiator_session :: IO BOLT8.Session 197 get_initiator_session = do 198 (i_s_sec, i_s_pub) <- expectJust "initiator keypair" 199 (BOLT8.keypair initiator_s_priv) 200 (r_s_sec, r_s_pub) <- expectJust "responder keypair" 201 (BOLT8.keypair responder_s_priv) 202 rs <- expectJust "responder pub" (BOLT8.parse_pub responder_s_pub) 203 (msg1, i_hs) <- expectRight "act1" (BOLT8.act1 i_s_sec i_s_pub rs 204 initiator_e_priv) 205 (msg2, _) <- expectRight "act2" (BOLT8.act2 r_s_sec r_s_pub responder_e_priv 206 msg1) 207 (_, result) <- expectRight "act3" (BOLT8.act3 i_hs msg2) 208 pure (BOLT8.session result) 209 210 -- encrypt N messages, return Nth ciphertext 211 encrypt_n :: Int -> BOLT8.Session -> IO BS.ByteString 212 encrypt_n n sess0 = go 0 sess0 213 where 214 go i sess 215 | i == n = case BOLT8.encrypt sess hello of 216 Left err -> fail $ "encrypt failed at " ++ show i ++ ": " ++ show err 217 Right (ct, _) -> pure ct 218 | otherwise = case BOLT8.encrypt sess hello of 219 Left err -> fail $ "encrypt failed at " ++ show i ++ ": " ++ show err 220 Right (_, sess') -> go (i + 1) sess' 221 222 test_message_0 :: Assertion 223 test_message_0 = do 224 sess <- get_initiator_session 225 ct <- encrypt_n 0 sess 226 ct @?= expected_msg_0 227 228 test_message_1 :: Assertion 229 test_message_1 = do 230 sess <- get_initiator_session 231 ct <- encrypt_n 1 sess 232 ct @?= expected_msg_1 233 234 test_message_500 :: Assertion 235 test_message_500 = do 236 sess <- get_initiator_session 237 ct <- encrypt_n 500 sess 238 ct @?= expected_msg_500 239 240 test_message_501 :: Assertion 241 test_message_501 = do 242 sess <- get_initiator_session 243 ct <- encrypt_n 501 sess 244 ct @?= expected_msg_501 245 246 test_message_1000 :: Assertion 247 test_message_1000 = do 248 sess <- get_initiator_session 249 ct <- encrypt_n 1000 sess 250 ct @?= expected_msg_1000 251 252 test_message_1001 :: Assertion 253 test_message_1001 = do 254 sess <- get_initiator_session 255 ct <- encrypt_n 1001 sess 256 ct @?= expected_msg_1001 257 258 test_decrypt_roundtrip :: Assertion 259 test_decrypt_roundtrip = do 260 (i_s_sec, i_s_pub) <- expectJust "initiator keypair" 261 (BOLT8.keypair initiator_s_priv) 262 (r_s_sec, r_s_pub) <- expectJust "responder keypair" 263 (BOLT8.keypair responder_s_priv) 264 rs <- expectJust "responder pub" (BOLT8.parse_pub responder_s_pub) 265 (msg1, i_hs) <- expectRight "act1" (BOLT8.act1 i_s_sec i_s_pub rs 266 initiator_e_priv) 267 (msg2, r_hs) <- expectRight "act2" (BOLT8.act2 r_s_sec r_s_pub responder_e_priv 268 msg1) 269 (msg3, i_result) <- expectRight "act3" (BOLT8.act3 i_hs msg2) 270 r_result <- expectRight "finalize" (BOLT8.finalize r_hs msg3) 271 let i_sess = BOLT8.session i_result 272 r_sess = BOLT8.session r_result 273 (ct, _) <- expectRight "encrypt" (BOLT8.encrypt i_sess hello) 274 (pt, _) <- expectRight "decrypt" (BOLT8.decrypt r_sess ct) 275 pt @?= hello 276 277 -- framing tests ------------------------------------------------------------- 278 279 framing_tests :: TestTree 280 framing_tests = testGroup "Packet Framing" [ 281 testCase "decrypt rejects trailing bytes" test_decrypt_trailing 282 , testCase "decrypt_frame returns remainder" test_decrypt_frame_remainder 283 , testCase "decrypt_frame handles multiple frames" test_decrypt_frame_multi 284 ] 285 286 test_decrypt_trailing :: Assertion 287 test_decrypt_trailing = do 288 (i_s_sec, i_s_pub) <- expectJust "initiator keypair" 289 (BOLT8.keypair initiator_s_priv) 290 (r_s_sec, r_s_pub) <- expectJust "responder keypair" 291 (BOLT8.keypair responder_s_priv) 292 rs <- expectJust "responder pub" (BOLT8.parse_pub responder_s_pub) 293 (msg1, i_hs) <- expectRight "act1" (BOLT8.act1 i_s_sec i_s_pub rs 294 initiator_e_priv) 295 (msg2, r_hs) <- expectRight "act2" (BOLT8.act2 r_s_sec r_s_pub responder_e_priv 296 msg1) 297 (msg3, i_result) <- expectRight "act3" (BOLT8.act3 i_hs msg2) 298 r_result <- expectRight "finalize" (BOLT8.finalize r_hs msg3) 299 let i_sess = BOLT8.session i_result 300 r_sess = BOLT8.session r_result 301 (ct, _) <- expectRight "encrypt" (BOLT8.encrypt i_sess hello) 302 -- append trailing bytes 303 let ct_with_trailing = ct <> "extra" 304 case BOLT8.decrypt r_sess ct_with_trailing of 305 Left BOLT8.InvalidLength -> pure () 306 Left err -> assertFailure $ "expected InvalidLength, got: " ++ show err 307 Right _ -> assertFailure "decrypt should reject trailing bytes" 308 309 test_decrypt_frame_remainder :: Assertion 310 test_decrypt_frame_remainder = do 311 (i_s_sec, i_s_pub) <- expectJust "initiator keypair" 312 (BOLT8.keypair initiator_s_priv) 313 (r_s_sec, r_s_pub) <- expectJust "responder keypair" 314 (BOLT8.keypair responder_s_priv) 315 rs <- expectJust "responder pub" (BOLT8.parse_pub responder_s_pub) 316 (msg1, i_hs) <- expectRight "act1" (BOLT8.act1 i_s_sec i_s_pub rs 317 initiator_e_priv) 318 (msg2, r_hs) <- expectRight "act2" (BOLT8.act2 r_s_sec r_s_pub responder_e_priv 319 msg1) 320 (msg3, i_result) <- expectRight "act3" (BOLT8.act3 i_hs msg2) 321 r_result <- expectRight "finalize" (BOLT8.finalize r_hs msg3) 322 let i_sess = BOLT8.session i_result 323 r_sess = BOLT8.session r_result 324 (ct, _) <- expectRight "encrypt" (BOLT8.encrypt i_sess hello) 325 let trailing = "remainder" 326 ct_with_trailing = ct <> trailing 327 (pt, remainder, _) <- expectRight "decrypt_frame" 328 (BOLT8.decrypt_frame r_sess ct_with_trailing) 329 pt @?= hello 330 remainder @?= trailing 331 332 test_decrypt_frame_multi :: Assertion 333 test_decrypt_frame_multi = do 334 (i_s_sec, i_s_pub) <- expectJust "initiator keypair" 335 (BOLT8.keypair initiator_s_priv) 336 (r_s_sec, r_s_pub) <- expectJust "responder keypair" 337 (BOLT8.keypair responder_s_priv) 338 rs <- expectJust "responder pub" (BOLT8.parse_pub responder_s_pub) 339 (msg1, i_hs) <- expectRight "act1" (BOLT8.act1 i_s_sec i_s_pub rs 340 initiator_e_priv) 341 (msg2, r_hs) <- expectRight "act2" (BOLT8.act2 r_s_sec r_s_pub responder_e_priv 342 msg1) 343 (msg3, i_result) <- expectRight "act3" (BOLT8.act3 i_hs msg2) 344 r_result <- expectRight "finalize" (BOLT8.finalize r_hs msg3) 345 let i_sess = BOLT8.session i_result 346 r_sess = BOLT8.session r_result 347 -- encrypt two messages 348 (ct1, i_sess') <- expectRight "encrypt 1" (BOLT8.encrypt i_sess "first") 349 (ct2, _) <- expectRight "encrypt 2" (BOLT8.encrypt i_sess' "second") 350 -- concatenate frames 351 let buffer = ct1 <> ct2 352 -- decrypt first frame 353 (pt1, rest, r_sess') <- expectRight "frame 1" 354 (BOLT8.decrypt_frame r_sess buffer) 355 pt1 @?= "first" 356 -- decrypt second frame from remainder 357 (pt2, rest2, _) <- expectRight "frame 2" (BOLT8.decrypt_frame r_sess' rest) 358 pt2 @?= "second" 359 rest2 @?= BS.empty 360 361 -- partial framing tests ----------------------------------------------------- 362 363 partial_framing_tests :: TestTree 364 partial_framing_tests = testGroup "Partial Framing" [ 365 testCase "short buffer returns NeedMore" test_partial_short_buffer 366 , testCase "partial body returns NeedMore" test_partial_body 367 , testCase "full frame returns FrameOk" test_partial_full_frame 368 ] 369 370 test_partial_short_buffer :: Assertion 371 test_partial_short_buffer = do 372 (i_s_sec, i_s_pub) <- expectJust "initiator keypair" 373 (BOLT8.keypair initiator_s_priv) 374 (r_s_sec, r_s_pub) <- expectJust "responder keypair" 375 (BOLT8.keypair responder_s_priv) 376 rs <- expectJust "responder pub" (BOLT8.parse_pub responder_s_pub) 377 (msg1, i_hs) <- expectRight "act1" (BOLT8.act1 i_s_sec i_s_pub rs 378 initiator_e_priv) 379 (msg2, r_hs) <- expectRight "act2" (BOLT8.act2 r_s_sec r_s_pub responder_e_priv 380 msg1) 381 (msg3, _) <- expectRight "act3" (BOLT8.act3 i_hs msg2) 382 r_result <- expectRight "finalize" (BOLT8.finalize r_hs msg3) 383 let r_sess = BOLT8.session r_result 384 short_buf = BS.replicate 10 0x00 385 case BOLT8.decrypt_frame_partial r_sess short_buf of 386 BOLT8.NeedMore n -> n @?= 8 387 BOLT8.FrameOk {} -> assertFailure "expected NeedMore, got FrameOk" 388 BOLT8.FrameError err -> 389 assertFailure $ "expected NeedMore, got: " ++ show err 390 391 test_partial_body :: Assertion 392 test_partial_body = do 393 (i_s_sec, i_s_pub) <- expectJust "initiator keypair" 394 (BOLT8.keypair initiator_s_priv) 395 (r_s_sec, r_s_pub) <- expectJust "responder keypair" 396 (BOLT8.keypair responder_s_priv) 397 rs <- expectJust "responder pub" (BOLT8.parse_pub responder_s_pub) 398 (msg1, i_hs) <- expectRight "act1" (BOLT8.act1 i_s_sec i_s_pub rs 399 initiator_e_priv) 400 (msg2, r_hs) <- expectRight "act2" (BOLT8.act2 r_s_sec r_s_pub responder_e_priv 401 msg1) 402 (msg3, i_result) <- expectRight "act3" (BOLT8.act3 i_hs msg2) 403 r_result <- expectRight "finalize" (BOLT8.finalize r_hs msg3) 404 let i_sess = BOLT8.session i_result 405 r_sess = BOLT8.session r_result 406 (ct, _) <- expectRight "encrypt" (BOLT8.encrypt i_sess hello) 407 -- take only length header (18 bytes) + 5 bytes of body 408 let partial = BS.take 23 ct 409 case BOLT8.decrypt_frame_partial r_sess partial of 410 BOLT8.NeedMore n -> do 411 -- "hello" = 5 bytes, so body = 5 + 16 = 21 412 -- we have 5 bytes of body, need 16 more 413 n @?= 16 414 BOLT8.FrameOk {} -> assertFailure "expected NeedMore, got FrameOk" 415 BOLT8.FrameError err -> 416 assertFailure $ "expected NeedMore, got: " ++ show err 417 418 test_partial_full_frame :: Assertion 419 test_partial_full_frame = do 420 (i_s_sec, i_s_pub) <- expectJust "initiator keypair" 421 (BOLT8.keypair initiator_s_priv) 422 (r_s_sec, r_s_pub) <- expectJust "responder keypair" 423 (BOLT8.keypair responder_s_priv) 424 rs <- expectJust "responder pub" (BOLT8.parse_pub responder_s_pub) 425 (msg1, i_hs) <- expectRight "act1" (BOLT8.act1 i_s_sec i_s_pub rs 426 initiator_e_priv) 427 (msg2, r_hs) <- expectRight "act2" (BOLT8.act2 r_s_sec r_s_pub responder_e_priv 428 msg1) 429 (msg3, i_result) <- expectRight "act3" (BOLT8.act3 i_hs msg2) 430 r_result <- expectRight "finalize" (BOLT8.finalize r_hs msg3) 431 let i_sess = BOLT8.session i_result 432 r_sess = BOLT8.session r_result 433 (ct, _) <- expectRight "encrypt" (BOLT8.encrypt i_sess hello) 434 let trailing = "extra" 435 buf = ct <> trailing 436 case BOLT8.decrypt_frame_partial r_sess buf of 437 BOLT8.FrameOk pt remainder _ -> do 438 pt @?= hello 439 remainder @?= trailing 440 BOLT8.NeedMore n -> 441 assertFailure $ "expected FrameOk, got NeedMore " ++ show n 442 BOLT8.FrameError err -> 443 assertFailure $ "expected FrameOk, got: " ++ show err 444 445 -- negative tests ------------------------------------------------------------ 446 447 negative_tests :: TestTree 448 negative_tests = testGroup "Negative Tests" [ 449 testCase "act2 rejects wrong version" test_act2_wrong_version 450 , testCase "act2 rejects wrong length" test_act2_wrong_length 451 , testCase "act3 rejects invalid MAC" test_act3_invalid_mac 452 , testCase "finalize rejects invalid MAC" test_finalize_invalid_mac 453 , testCase "decrypt rejects short packet" test_decrypt_short_packet 454 ] 455 456 test_act2_wrong_version :: Assertion 457 test_act2_wrong_version = do 458 (i_s_sec, i_s_pub) <- expectJust "initiator keypair" 459 (BOLT8.keypair initiator_s_priv) 460 (r_s_sec, r_s_pub) <- expectJust "responder keypair" 461 (BOLT8.keypair responder_s_priv) 462 rs <- expectJust "responder pub" (BOLT8.parse_pub responder_s_pub) 463 (msg1, _) <- expectRight "act1" (BOLT8.act1 i_s_sec i_s_pub rs initiator_e_priv) 464 let bad_msg1 = BS.cons 0x01 (BS.drop 1 msg1) 465 case BOLT8.act2 r_s_sec r_s_pub responder_e_priv bad_msg1 of 466 Left BOLT8.InvalidVersion -> pure () 467 Left err -> assertFailure $ "expected InvalidVersion, got: " ++ show err 468 Right _ -> assertFailure "expected rejection, got success" 469 470 test_act2_wrong_length :: Assertion 471 test_act2_wrong_length = do 472 (r_s_sec, r_s_pub) <- expectJust "responder keypair" 473 (BOLT8.keypair responder_s_priv) 474 let short_msg = BS.replicate 49 0x00 475 case BOLT8.act2 r_s_sec r_s_pub responder_e_priv short_msg of 476 Left BOLT8.InvalidLength -> pure () 477 Left err -> assertFailure $ "expected InvalidLength, got: " ++ show err 478 Right _ -> assertFailure "expected rejection, got success" 479 480 test_act3_invalid_mac :: Assertion 481 test_act3_invalid_mac = do 482 (i_s_sec, i_s_pub) <- expectJust "initiator keypair" 483 (BOLT8.keypair initiator_s_priv) 484 (r_s_sec, r_s_pub) <- expectJust "responder keypair" 485 (BOLT8.keypair responder_s_priv) 486 rs <- expectJust "responder pub" (BOLT8.parse_pub responder_s_pub) 487 (msg1, i_hs) <- expectRight "act1" (BOLT8.act1 i_s_sec i_s_pub rs 488 initiator_e_priv) 489 (msg2, _) <- expectRight "act2" (BOLT8.act2 r_s_sec r_s_pub responder_e_priv 490 msg1) 491 bad_msg2 <- flip_byte 40 msg2 492 case BOLT8.act3 i_hs bad_msg2 of 493 Left BOLT8.InvalidMAC -> pure () 494 Left err -> assertFailure $ "expected InvalidMAC, got: " ++ show err 495 Right _ -> assertFailure "expected rejection, got success" 496 497 test_finalize_invalid_mac :: Assertion 498 test_finalize_invalid_mac = do 499 (i_s_sec, i_s_pub) <- expectJust "initiator keypair" 500 (BOLT8.keypair initiator_s_priv) 501 (r_s_sec, r_s_pub) <- expectJust "responder keypair" 502 (BOLT8.keypair responder_s_priv) 503 rs <- expectJust "responder pub" (BOLT8.parse_pub responder_s_pub) 504 (msg1, i_hs) <- expectRight "act1" (BOLT8.act1 i_s_sec i_s_pub rs 505 initiator_e_priv) 506 (msg2, r_hs) <- expectRight "act2" (BOLT8.act2 r_s_sec r_s_pub responder_e_priv 507 msg1) 508 (msg3, _) <- expectRight "act3" (BOLT8.act3 i_hs msg2) 509 bad_msg3 <- flip_byte 20 msg3 510 case BOLT8.finalize r_hs bad_msg3 of 511 Left BOLT8.InvalidMAC -> pure () 512 Left err -> assertFailure $ "expected InvalidMAC, got: " ++ show err 513 Right _ -> assertFailure "expected rejection, got success" 514 515 test_decrypt_short_packet :: Assertion 516 test_decrypt_short_packet = do 517 (i_s_sec, i_s_pub) <- expectJust "initiator keypair" 518 (BOLT8.keypair initiator_s_priv) 519 (r_s_sec, r_s_pub) <- expectJust "responder keypair" 520 (BOLT8.keypair responder_s_priv) 521 rs <- expectJust "responder pub" (BOLT8.parse_pub responder_s_pub) 522 (msg1, i_hs) <- expectRight "act1" (BOLT8.act1 i_s_sec i_s_pub rs 523 initiator_e_priv) 524 (msg2, r_hs) <- expectRight "act2" (BOLT8.act2 r_s_sec r_s_pub responder_e_priv 525 msg1) 526 (msg3, _) <- expectRight "act3" (BOLT8.act3 i_hs msg2) 527 r_result <- expectRight "finalize" (BOLT8.finalize r_hs msg3) 528 let r_sess = BOLT8.session r_result 529 short_packet = BS.replicate 17 0x00 530 case BOLT8.decrypt r_sess short_packet of 531 Left BOLT8.InvalidLength -> pure () 532 Left err -> assertFailure $ "expected InvalidLength, got: " ++ show err 533 Right _ -> assertFailure "expected rejection, got success" 534 535 -- flip one byte in a bytestring at given index 536 flip_byte :: Int -> BS.ByteString -> IO BS.ByteString 537 flip_byte i bs 538 | i < 0 || i >= BS.length bs = 539 assertFailure "flip_byte: index out of bounds" >> pure bs 540 | otherwise = 541 let (pre, post) = BS.splitAt i bs 542 b = BS.index post 0 543 in pure (pre <> BS.cons (b `xor` 0xff) (BS.drop 1 post)) 544 545 -- utilities ----------------------------------------------------------------- 546 547 -- Safe hex decode for test vectors (only called at top level with known-good 548 -- literals). This uses error since it's for compile-time constants, not runtime 549 -- input; wrapping in IO would break the test vector declarations. 550 hex :: BS.ByteString -> BS.ByteString 551 hex bs = case B16.decode bs of 552 Nothing -> error "hex: invalid test vector literal" 553 Just r -> r 554 555 -- property tests -------------------------------------------------------------- 556 557 property_tests :: TestTree 558 property_tests = testGroup "Properties" [ 559 testProperty "handshake round-trip" prop_handshake_roundtrip 560 , testProperty "encrypt/decrypt round-trip" 561 prop_encrypt_decrypt_roundtrip 562 , testProperty "decrypt_frame consumes one frame" 563 prop_frame_consumes_one 564 , testProperty "decrypt_frame_partial NeedMore on short" 565 prop_partial_needmore_short 566 , testProperty "handshake authenticates remote statics" 567 prop_handshake_remote_statics 568 , testProperty "encrypt/decrypt survives key rotation" 569 prop_key_rotation_roundtrip 570 , testProperty "mkMessagePayload validates size" 571 prop_mkMessagePayload_validates 572 , testProperty "key32 validates length" 573 prop_key32_validates 574 ] 575 576 -- generators ------------------------------------------------------------------ 577 578 -- | Generate 32 bytes of entropy that yields a valid keypair. 579 genValidEntropy :: Gen BS.ByteString 580 genValidEntropy = do 581 bytes <- BS.pack <$> vectorOf 32 (choose (0, 255)) 582 case BOLT8.keypair bytes of 583 Just _ -> pure bytes 584 Nothing -> genValidEntropy 585 586 -- | Generate a payload of 0..256 bytes. 587 genPayload :: Gen BS.ByteString 588 genPayload = do 589 len <- choose (0, 256) 590 BS.pack <$> vectorOf len (choose (0, 255)) 591 592 -- | Perform a full handshake with given static key entropy. 593 -- Uses fixed ephemeral keys for determinism. 594 doHandshake 595 :: BS.ByteString 596 -> BS.ByteString 597 -> Maybe (BOLT8.Session, BOLT8.Session) 598 doHandshake i_entropy r_entropy = do 599 (i_res, r_res) <- doHandshake' i_entropy r_entropy 600 pure (BOLT8.session i_res, BOLT8.session r_res) 601 602 -- | Like 'doHandshake' but returns full Handshake results. 603 doHandshake' 604 :: BS.ByteString 605 -> BS.ByteString 606 -> Maybe (BOLT8.Handshake, BOLT8.Handshake) 607 doHandshake' i_entropy r_entropy = do 608 (i_s_sec, i_s_pub) <- BOLT8.keypair i_entropy 609 (r_s_sec, r_s_pub) <- BOLT8.keypair r_entropy 610 let i_e = BS.replicate 32 0x12 611 r_e = BS.replicate 32 0x22 612 (msg1, i_hs) <- either (const Nothing) Just $ 613 BOLT8.act1 i_s_sec i_s_pub r_s_pub i_e 614 (msg2, r_hs) <- either (const Nothing) Just $ 615 BOLT8.act2 r_s_sec r_s_pub r_e msg1 616 (msg3, i_res) <- either (const Nothing) Just $ 617 BOLT8.act3 i_hs msg2 618 r_res <- either (const Nothing) Just $ 619 BOLT8.finalize r_hs msg3 620 pure (i_res, r_res) 621 622 -- | Send n messages from initiator to responder, 623 -- advancing both session states in sync. 624 advanceSessions 625 :: Int 626 -> BOLT8.Session 627 -> BOLT8.Session 628 -> Maybe (BOLT8.Session, BOLT8.Session) 629 advanceSessions 0 i r = Just (i, r) 630 advanceSessions n i r = 631 case BOLT8.encrypt i (BS.replicate 5 0x00) of 632 Left _ -> Nothing 633 Right (ct, i') -> 634 case BOLT8.decrypt r ct of 635 Left _ -> Nothing 636 Right (_, r') -> advanceSessions (n - 1) i' r' 637 638 -- properties ------------------------------------------------------------------ 639 640 -- | Handshake succeeds for valid keys and sessions are consistent. 641 prop_handshake_roundtrip :: Property 642 prop_handshake_roundtrip = forAll genValidEntropy $ \i_ent -> 643 forAll genValidEntropy $ \r_ent -> 644 case doHandshake i_ent r_ent of 645 Nothing -> False 646 Just _ -> True 647 648 -- | Encrypt then decrypt yields original payload. 649 prop_encrypt_decrypt_roundtrip :: Property 650 prop_encrypt_decrypt_roundtrip = forAll genPayload $ \payload -> 651 case doHandshake initiator_s_priv responder_s_priv of 652 Nothing -> False 653 Just (i_sess, r_sess) -> 654 case BOLT8.encrypt i_sess payload of 655 Left _ -> False 656 Right (ct, _) -> 657 case BOLT8.decrypt r_sess ct of 658 Left _ -> False 659 Right (pt, _) -> pt == payload 660 661 -- | decrypt_frame consumes exactly one frame and returns remainder. 662 prop_frame_consumes_one :: Property 663 prop_frame_consumes_one = forAll genPayload $ \p1 -> 664 forAll genPayload $ \p2 -> 665 case doHandshake initiator_s_priv responder_s_priv of 666 Nothing -> False 667 Just (i_sess, r_sess) -> 668 case BOLT8.encrypt i_sess p1 of 669 Left _ -> False 670 Right (ct1, i_sess') -> 671 case BOLT8.encrypt i_sess' p2 of 672 Left _ -> False 673 Right (ct2, _) -> 674 let buf = ct1 <> ct2 675 in case BOLT8.decrypt_frame r_sess buf of 676 Left _ -> False 677 Right (pt1, rest, r_sess') -> 678 pt1 == p1 && 679 case BOLT8.decrypt_frame r_sess' rest of 680 Left _ -> False 681 Right (pt2, rest2, _) -> 682 pt2 == p2 && BS.null rest2 683 684 -- | decrypt_frame_partial returns NeedMore when buffer < 18 bytes. 685 prop_partial_needmore_short :: Property 686 prop_partial_needmore_short = forAll (choose (0, 17)) $ \len -> 687 case doHandshake initiator_s_priv responder_s_priv of 688 Nothing -> False 689 Just (_, r_sess) -> 690 let buf = BS.replicate len 0x00 691 in case BOLT8.decrypt_frame_partial r_sess buf of 692 BOLT8.NeedMore n -> n == 18 - len 693 _ -> False 694 695 -- | Handshake authenticates remote static keys: each side 696 -- sees the other's static pubkey. 697 prop_handshake_remote_statics :: Property 698 prop_handshake_remote_statics = 699 forAll genValidEntropy $ \i_ent -> 700 forAll genValidEntropy $ \r_ent -> 701 case (doHandshake' i_ent r_ent, 702 BOLT8.keypair i_ent, 703 BOLT8.keypair r_ent) of 704 (Just (i_res, r_res), 705 Just (_, i_pub), 706 Just (_, r_pub)) -> 707 BOLT8.remote_static i_res == r_pub 708 && BOLT8.remote_static r_res == i_pub 709 _ -> False 710 711 -- | Encrypt/decrypt roundtrip survives key rotation at 712 -- nonce 1000. Each encrypt uses 2 nonces (length + 713 -- body), so rotation happens after 500 messages. 714 -- We advance to message 499 then send a test payload 715 -- across the rotation boundary. 716 prop_key_rotation_roundtrip :: Property 717 prop_key_rotation_roundtrip = forAll genPayload $ \payload -> 718 case doHandshake initiator_s_priv responder_s_priv of 719 Nothing -> False 720 Just (i_sess, r_sess) -> 721 case advanceSessions 499 i_sess r_sess of 722 Nothing -> False 723 Just (i_sess', r_sess') -> 724 case BOLT8.encrypt i_sess' payload of 725 Left _ -> False 726 Right (ct, _) -> 727 case BOLT8.decrypt r_sess' ct of 728 Left _ -> False 729 Right (pt, _) -> pt == payload 730 731 -- | mkMessagePayload accepts payloads <= 65535 bytes and 732 -- rejects payloads > 65535. 733 prop_mkMessagePayload_validates :: Property 734 prop_mkMessagePayload_validates = 735 forAll (choose (0, 256)) $ \len -> 736 let bs = BS.replicate len 0x00 737 in case BOLT8.mkMessagePayload bs of 738 Right mp -> 739 BOLT8.unMessagePayload mp === bs 740 Left _ -> False === True 741 742 -- | key32 accepts exactly 32-byte inputs and rejects others. 743 prop_key32_validates :: Property 744 prop_key32_validates = 745 forAll (choose (0, 64)) $ \len -> 746 let bs = BS.replicate len 0x00 747 in case BOLT8.key32 bs of 748 Just k -> len === 32 749 .&&. BOLT8.unKey32 k === bs 750 Nothing -> (len /= 32) === True