Main.hs (61445B)
1 {-# LANGUAGE OverloadedStrings #-} 2 3 module Main where 4 5 import Control.Monad (forM_) 6 import qualified Crypto.Cipher.ChaCha20 as ChaCha 7 import qualified Crypto.Curve.Secp256k1 as Secp256k1 8 import qualified Crypto.Hash.SHA256 as SHA256 9 import Data.Bits (xor) 10 import qualified Data.ByteString as BS 11 import qualified Data.ByteString.Base16 as B16 12 import Data.List (nubBy) 13 import Data.Word (Word8, Word16, Word32, Word64) 14 import qualified Lightning.Protocol.BOLT1 as BOLT1 15 import Lightning.Protocol.BOLT4 16 import qualified Lightning.Protocol.BOLT9 as BOLT9 17 import Test.Tasty 18 import Test.Tasty.HUnit 19 import Test.Tasty.QuickCheck 20 import qualified Vectors as V 21 22 main :: IO () 23 main = defaultMain $ testGroup "ppad-bolt4" [ 24 key_tests 25 , codec_tests 26 , failure_tests 27 , construct_tests 28 , process_tests 29 , blinding_tests 30 , error_tests 31 , testGroup "spec vectors" [ 32 onion_vectors 33 , error_vectors 34 , trace_vectors 35 , route_blinding_vectors 36 , blinded_payment_vectors 37 ] 38 , properties 39 ] 40 41 -- helpers -------------------------------------------------------------------- 42 43 demand :: String -> Maybe a -> IO a 44 demand _ (Just a) = pure a 45 demand msg Nothing = assertFailure msg 46 47 right :: Show e => String -> Either e a -> IO a 48 right _ (Right a) = pure a 49 right msg (Left e) = assertFailure (msg ++ ": " ++ show e) 50 51 unhex :: BS.ByteString -> IO BS.ByteString 52 unhex = demand "invalid hex" . B16.decode 53 54 hex_key :: BS.ByteString -> IO SecretKey 55 hex_key h = unhex h >>= demand "invalid secret key" . secret_key 56 57 hex_point :: BS.ByteString -> IO BOLT1.Point 58 hex_point h = unhex h >>= demand "invalid point" . BOLT1.point 59 60 hex_secret :: BS.ByteString -> IO SharedSecret 61 hex_secret h = unhex h >>= demand "invalid shared secret" . shared_secret 62 63 -- strip a BigSize length prefix, checking that it is exact 64 unprefix :: BS.ByteString -> IO BS.ByteString 65 unprefix bs = do 66 (len, body) <- demand "invalid length prefix" (BOLT1.decode_bigsize bs) 67 assertEqual "length prefix" (fromIntegral len) (BS.length body) 68 pure body 69 70 msat :: Word64 -> IO BOLT1.MilliSatoshi 71 msat = demand "invalid amount" . BOLT1.milli_satoshi 72 73 scid :: Word32 -> Word32 -> Word16 -> IO BOLT1.ShortChannelId 74 scid b t o = demand "invalid scid" (BOLT1.short_channel_id b t o) 75 76 tlvs :: [BOLT1.TlvRecord] -> IO BOLT1.TlvStream 77 tlvs = demand "invalid tlv stream" . BOLT1.tlv_stream 78 79 no_tlvs :: BOLT1.TlvStream 80 no_tlvs = BOLT1.empty_tlv_stream 81 82 key :: Word8 -> IO SecretKey 83 key b = demand "invalid secret key" (secret_key (BS.replicate 32 b)) 84 85 ad :: BS.ByteString 86 ad = BS.replicate 32 0x42 87 88 -- a point with a valid prefix but not on the curve 89 off_curve :: IO BOLT1.Point 90 off_curve = 91 case [ p | x <- [0 .. 255 :: Word8] 92 , let bs = BS.cons 0x02 (BS.replicate 31 0 <> BS.singleton x) 93 , Secp256k1.parse_point bs == Nothing 94 , Just p <- [BOLT1.point bs] ] of 95 p : _ -> pure p 96 [] -> assertFailure "no off-curve point found" 97 98 -- a payload with the given outgoing_cltv_value 99 cltv_payload :: Word32 -> HopPayload 100 cltv_payload c = empty_hop_payload { hp_outgoing_cltv_value = Just c } 101 102 expect_process 103 :: ProcessError -> Either ProcessError ProcessResult -> Assertion 104 expect_process e r = case r of 105 Left e' -> e' @?= e 106 Right _ -> assertFailure ("expected " ++ show e) 107 108 forward :: Either ProcessError ProcessResult -> IO ForwardInfo 109 forward r = case r of 110 Right (Forward f) -> pure f 111 Right (Receive _) -> assertFailure "expected Forward, got Receive" 112 Left e -> assertFailure ("process: " ++ show e) 113 114 receive :: Either ProcessError ProcessResult -> IO ReceiveInfo 115 receive r = case r of 116 Right (Receive i) -> pure i 117 Right (Forward _) -> assertFailure "expected Receive, got Forward" 118 Left e -> assertFailure ("process: " ++ show e) 119 120 -- A single-hop onion, built independently of the library, whose 121 -- decrypted hop_payloads is the given 1300-byte plaintext. 122 raw_onion :: SecretKey -> BS.ByteString -> IO OnionPacket 123 raw_onion node plain = do 124 let session = BS.replicate 32 0x77 125 e <- demand "session" (Secp256k1.parse_int256 session) 126 epub <- demand "session pub" (Secp256k1.derive_pub e) 127 n <- demand "node pub" 128 (Secp256k1.parse_point (BOLT1.un_point (public_key node))) 129 pt <- demand "ecdh" (Secp256k1.mul n e) 130 let ss = SHA256.hash (Secp256k1.serialize_point pt) 131 derive l = let SHA256.MAC k = SHA256.hmac l ss in k 132 stream <- right "chacha" 133 (ChaCha.cipher (derive "rho") 0 (BS.replicate 12 0) 134 (BS.replicate 1300 0)) 135 let body = BS.packZipWith xor plain stream 136 SHA256.MAC mac = SHA256.hmac (derive "mu") (body <> ad) 137 pk <- demand "point" (BOLT1.point (Secp256k1.serialize_point epub)) 138 OnionPacket 0 pk 139 <$> demand "hop_payloads" (hop_payloads body) 140 <*> demand "hmac" (hmac32 mac) 141 142 -- pad a plaintext region to 1300 bytes 143 pad1300 :: BS.ByteString -> BS.ByteString 144 pad1300 bs = bs <> BS.replicate (1300 - BS.length bs) 0 145 146 -- keys ----------------------------------------------------------------------- 147 148 key_tests :: TestTree 149 key_tests = testGroup "keys" [ 150 testCase "secret_key accepts 32-byte keys in range" $ do 151 _ <- key 0x01 152 sk <- demand "n - 1" . secret_key =<< unhex 153 "fffffffffffffffffffffffffffffffebaaedce6af48a03bbfd25e8cd0364140" 154 BS.length (BOLT1.un_point (public_key sk)) @?= 33 155 , testCase "secret_key rejects other lengths" $ do 156 assertNone (secret_key (BS.replicate 31 0x01)) 157 assertNone (secret_key (BS.replicate 33 0x01)) 158 assertNone (secret_key (BS.cons 0x00 (BS.replicate 32 0x01))) 159 assertNone (secret_key BS.empty) 160 , testCase "secret_key rejects zero and keys >= n" $ do 161 assertNone (secret_key (BS.replicate 32 0x00)) 162 n <- unhex 163 "fffffffffffffffffffffffffffffffebaaedce6af48a03bbfd25e8cd0364141" 164 assertNone (secret_key n) 165 assertNone (secret_key (BS.replicate 32 0xff)) 166 , testCase "public_key matches secp256k1" $ do 167 sk <- key 0x41 168 expected <- unhex V.onionPubKey0 169 BOLT1.un_point (public_key sk) @?= expected 170 , testCase "shared_secret requires 32 bytes" $ do 171 assertNone (shared_secret (BS.replicate 31 0)) 172 assertNone (shared_secret (BS.replicate 33 0)) 173 ss <- demand "ss" (shared_secret (BS.replicate 32 7)) 174 un_shared_secret ss @?= BS.replicate 32 7 175 , testCase "shared secrets compare by value" $ do 176 a <- demand "a" (shared_secret (BS.replicate 32 7)) 177 b <- demand "b" (shared_secret (BS.replicate 32 7)) 178 c <- demand "c" (shared_secret (BS.cons 8 (BS.replicate 31 7))) 179 assertBool "equal" (a == b) 180 assertBool "not equal" (a /= c) 181 , testCase "secrets don't show their bytes" $ do 182 sk <- key 0x41 183 ss <- demand "ss" (shared_secret (BS.replicate 32 0x41)) 184 ps <- demand "ps" (payment_secret (BS.replicate 32 0x41)) 185 show sk @?= "SecretKey <redacted>" 186 show ss @?= "SharedSecret <redacted>" 187 show ps @?= "PaymentSecret <redacted>" 188 ] 189 where 190 assertNone m = case m of 191 Nothing -> pure () 192 Just _ -> assertFailure "expected Nothing" 193 194 -- codecs --------------------------------------------------------------------- 195 196 codec_tests :: TestTree 197 codec_tests = testGroup "codecs" [ 198 testCase "decode_onion_packet rejects other lengths" $ do 199 decode_onion_packet (BS.replicate 1365 0) @?= Left InvalidLength 200 decode_onion_packet (BS.replicate 1367 0) @?= Left InvalidLength 201 decode_onion_packet BS.empty @?= Left InvalidLength 202 , testCase "decode_onion_packet rejects a bad point prefix" $ do 203 let bs = BS.concat [ BS.singleton 0, BS.singleton 0x04 204 , BS.replicate 1364 0 ] 205 decode_onion_packet bs @?= Left InvalidPoint 206 , testCase "decode_onion_packet keeps the version byte" $ do 207 let bs = BS.concat [ BS.singleton 7, BS.singleton 0x02 208 , BS.replicate 1364 0 ] 209 pkt <- right "decode" (decode_onion_packet bs) 210 onion_version pkt @?= 7 211 encode_onion_packet pkt @?= bs 212 , testCase "smart constructors check lengths" $ do 213 hop_payloads (BS.replicate 1299 0) @?= Nothing 214 hop_payloads (BS.replicate 1301 0) @?= Nothing 215 hmac32 (BS.replicate 31 0) @?= Nothing 216 onion_hash (BS.replicate 33 0) @?= Nothing 217 case payment_secret (BS.replicate 31 0) of 218 Nothing -> pure () 219 Just _ -> assertFailure "short payment secret" 220 221 , testCase "hop payload: all typed fields" $ do 222 amt <- msat 1000 223 tot <- msat 5000 224 s <- scid 1 2 3 225 ps <- demand "ps" (payment_secret (BS.replicate 32 0xaa)) 226 pk <- hex_point V.onionPubKey0 227 ex <- tlvs [BOLT1.TlvRecord 19 "x"] 228 let hp = HopPayload 229 { hp_amt_to_forward = Just amt 230 , hp_outgoing_cltv_value = Just 500000 231 , hp_short_channel_id = Just s 232 , hp_payment_data = Just (PaymentData ps tot) 233 , hp_encrypted_data = Just "enc" 234 , hp_current_path_key = Just pk 235 , hp_payment_metadata = Just "meta" 236 , hp_total_amount_msat = Just tot 237 , hp_extra = ex 238 } 239 bs <- right "encode" (encode_hop_payload hp) 240 expected <- unhex $ BS.concat 241 [ "020203e8", "040307a120", "06080000010000020003" 242 , "0822", BS.concat (replicate 32 "aa"), "1388" 243 , "0a03656e63", "0c21", V.onionPubKey0, "10046d657461" 244 , "12021388", "130178" ] 245 bs @?= expected 246 decode_hop_payload bs @?= Right hp 247 , testCase "hop payload: zero values encode minimally" $ do 248 zero <- msat 0 249 let hp = empty_hop_payload { hp_amt_to_forward = Just zero 250 , hp_outgoing_cltv_value = Just 0 } 251 encode_hop_payload hp @?= Right "\STX\NUL\EOT\NUL" 252 decode_hop_payload "\STX\NUL\EOT\NUL" @?= Right hp 253 , testCase "hop payload: unknown odd types are kept" $ do 254 hp <- right "decode" (decode_hop_payload "\STX\SOH\SOH\ETX\NUL") 255 ex <- tlvs [BOLT1.TlvRecord 3 ""] 256 hp_extra hp @?= ex 257 encode_hop_payload hp @?= Right "\STX\SOH\SOH\ETX\NUL" 258 , testCase "hop payload: rejects unknown even types" $ do 259 decode_hop_payload "\DC4\NUL" @?= 260 Left (InvalidTlvStream (BOLT1.TlvUnknownEvenType 20)) 261 decode_hop_payload "\SO\NUL" @?= 262 Left (InvalidTlvStream (BOLT1.TlvUnknownEvenType 14)) 263 , testCase "hop payload: rejects malformed streams" $ do 264 decode_hop_payload "\EOT\SOH\SOH\STX\SOH\SOH" @?= 265 Left (InvalidTlvStream BOLT1.TlvNotStrictlyIncreasing) 266 decode_hop_payload "\STX\SOH\SOH\STX\SOH\SOH" @?= 267 Left (InvalidTlvStream BOLT1.TlvNotStrictlyIncreasing) 268 decode_hop_payload "\STX\ENQ\SOH" @?= 269 Left (InvalidTlvStream BOLT1.TlvTruncated) 270 decode_hop_payload "\STX\255\255\255\255\255\255\255\255\255" @?= 271 Left (InvalidTlvStream BOLT1.TlvTruncated) 272 decode_hop_payload "\253\NUL\STX\NUL" @?= 273 Left (InvalidTlvStream BOLT1.TlvNonMinimalBigSize) 274 , testCase "hop payload: rejects malformed values" $ do 275 -- non-minimal tu64 and tu32 276 decode_hop_payload "\STX\STX\NUL\SOH" @?= Left (InvalidTlvValue 2) 277 decode_hop_payload "\EOT\STX\NUL\SOH" @?= Left (InvalidTlvValue 4) 278 -- tu32 longer than 4 bytes 279 decode_hop_payload "\EOT\ENQ\SOH\SOH\SOH\SOH\SOH" @?= 280 Left (InvalidTlvValue 4) 281 -- amount above 21M BTC 282 decode_hop_payload "\STX\b\255\255\255\255\255\255\255\255" @?= 283 Left (InvalidTlvValue 2) 284 -- short_channel_id of 7 bytes 285 decode_hop_payload (BS.pack [6, 7] <> BS.replicate 7 0) @?= 286 Left (InvalidTlvValue 6) 287 -- payment_data with a 31-byte secret 288 decode_hop_payload (BS.pack [8, 31] <> BS.replicate 31 0) @?= 289 Left (InvalidTlvValue 8) 290 -- current_path_key of the wrong length or prefix 291 decode_hop_payload (BS.pack [12, 32] <> BS.replicate 32 2) @?= 292 Left (InvalidTlvValue 12) 293 decode_hop_payload (BS.pack [12, 33, 4] <> BS.replicate 32 2) @?= 294 Left (InvalidTlvValue 12) 295 -- total_amount_msat non-minimal 296 decode_hop_payload "\DC2\STX\NUL\SOH" @?= Left (InvalidTlvValue 18) 297 , testCase "hop payload: extra records may not have known types" $ do 298 ex <- tlvs [BOLT1.TlvRecord 16 "meta"] 299 encode_hop_payload empty_hop_payload { hp_extra = ex } @?= 300 Left ConflictingTlv 301 ex' <- tlvs [BOLT1.TlvRecord 2 "\SOH"] 302 encode_hop_payload (cltv_payload 1) { hp_extra = ex' } @?= 303 Left ConflictingTlv 304 , testCase "hop payload: extra records may have unknown even types" $ do 305 ex <- tlvs [BOLT1.TlvRecord 5482373484 (BS.replicate 32 1)] 306 bs <- right "encode" (encode_hop_payload (cltv_payload 1) 307 { hp_extra = ex }) 308 decode_hop_payload bs @?= 309 Left (InvalidTlvStream (BOLT1.TlvUnknownEvenType 5482373484)) 310 311 , testCase "blinded hop data: all typed fields" $ do 312 s <- scid 0 0 1729 313 pk <- hex_point V.rbDavePathKey 314 m <- msat 1500 315 ex <- tlvs [BOLT1.TlvRecord 561 "\DC24V"] 316 let d = BlindedHopData 317 { bhd_padding = Just (BS.replicate 3 0) 318 , bhd_short_channel_id = Just s 319 , bhd_next_node_id = Just pk 320 , bhd_path_id = Just "id" 321 , bhd_next_path_key_override = Just pk 322 , bhd_payment_relay = Just (PaymentRelay 36 150 10000) 323 , bhd_payment_constraints = 324 Just (PaymentConstraints 748005 m) 325 , bhd_allowed_features = Just (BOLT9.parse "\STX") 326 , bhd_extra = ex 327 } 328 bs <- right "encode" (encode_blinded_hop_data d) 329 expected <- unhex $ BS.concat 330 [ "0103000000", "020800000000000006c1", "0421", V.rbDavePathKey 331 , "06026964", "0821", V.rbDavePathKey, "0a080024000000962710" 332 , "0c06000b69e505dc", "0e0102", "fd023103123456" ] 333 bs @?= expected 334 decode_blinded_hop_data bs @?= Right d 335 , testCase "blinded hop data: unknown types" $ do 336 decode_blinded_hop_data "\DLE\NUL" @?= 337 Left (InvalidTlvStream (BOLT1.TlvUnknownEvenType 16)) 338 d <- right "decode" (decode_blinded_hop_data "\ETX\NUL") 339 ex <- tlvs [BOLT1.TlvRecord 3 ""] 340 bhd_extra d @?= ex 341 , testCase "blinded hop data: rejects malformed values" $ do 342 -- payment_relay shorter than its fixed fields 343 decode_blinded_hop_data "\n\ENQ\NUL\NUL\NUL\NUL\NUL" @?= 344 Left (InvalidTlvValue 10) 345 -- payment_relay with a non-minimal fee_base_msat 346 decode_blinded_hop_data "\n\a\NUL\NUL\NUL\NUL\NUL\NUL\NUL" @?= 347 Left (InvalidTlvValue 10) 348 -- payment_constraints shorter than its fixed fields 349 decode_blinded_hop_data "\f\ETX\NUL\NUL\NUL" @?= 350 Left (InvalidTlvValue 12) 351 -- next_node_id and next_path_key_override of the wrong length 352 decode_blinded_hop_data (BS.pack [4, 2, 2, 2]) @?= 353 Left (InvalidTlvValue 4) 354 decode_blinded_hop_data (BS.pack [8, 2, 2, 2]) @?= 355 Left (InvalidTlvValue 8) 356 -- short_channel_id of 9 bytes 357 decode_blinded_hop_data (BS.pack [2, 9] <> BS.replicate 9 0) @?= 358 Left (InvalidTlvValue 2) 359 , testCase "blinded hop data: extra records may not have known types" $ do 360 ex <- tlvs [BOLT1.TlvRecord 1 ""] 361 encode_blinded_hop_data empty_blinded_hop_data { bhd_extra = ex } @?= 362 Left ConflictingTlv 363 ] 364 365 -- failure messages ----------------------------------------------------------- 366 367 failure_tests :: TestTree 368 failure_tests = testGroup "failure messages" [ 369 testCase "encodings and codes of every failure" $ do 370 h <- demand "hash" (onion_hash (BS.replicate 32 0xab)) 371 m <- msat 100 372 let hh = BS.concat (replicate 32 "ab") 373 cases = 374 [ (TemporaryNodeFailure, "2002") 375 , (PermanentNodeFailure, "6002") 376 , (RequiredNodeFeatureMissing, "6003") 377 , (InvalidOnionVersion h, "c004" <> hh) 378 , (InvalidOnionHmac h, "c005" <> hh) 379 , (InvalidOnionKey h, "c006" <> hh) 380 , (TemporaryChannelFailure "cu", "100700026375") 381 , (PermanentChannelFailure, "4008") 382 , (RequiredChannelFeatureMissing, "4009") 383 , (UnknownNextPeer, "400a") 384 , (AmountBelowMinimum m "", "100b00000000000000640000") 385 , (FeeInsufficient m "cu", "100c000000000000006400026375") 386 , (IncorrectCltvExpiry 800000 "", "100d000c35000000") 387 , (ExpiryTooSoon "", "100e0000") 388 , ( IncorrectOrUnknownPaymentDetails m 800000 389 , "400f0000000000000064000c3500" ) 390 , (FinalIncorrectCltvExpiry 800000, "0012000c3500") 391 , (FinalIncorrectHtlcAmount m, "00130000000000000064") 392 , (ChannelDisabled 0 "", "101400000000") 393 , (ExpiryTooFar, "0015") 394 , (InvalidOnionPayload Nothing, "4016") 395 , (InvalidOnionPayload (Just (2, 7)), "401602 0007") 396 , (MppTimeout, "0017") 397 , (InvalidOnionBlinding h, "c018" <> hh) 398 , (UnknownFailure 0x0042 "data", "004264617461") 399 ] 400 forM_ cases $ \(f, hx) -> do 401 bs <- unhex (BS.filter (/= 0x20) hx) 402 let fm = FailureMessage f no_tlvs 403 encode_failure_message fm @?= Right bs 404 decode_failure_message bs @?= Right fm 405 Just (failure_code f) @?= fmap fst (BOLT1.decode_u16 bs) 406 , testCase "flags" $ do 407 h <- demand "hash" (onion_hash (BS.replicate 32 0)) 408 let flags f = (is_badonion f, is_perm f, is_node f, is_update f) 409 flags TemporaryNodeFailure @?= (False, False, True, False) 410 flags PermanentNodeFailure @?= (False, True, True, False) 411 flags (InvalidOnionBlinding h) @?= (True, True, False, False) 412 flags (ExpiryTooSoon "") @?= (False, False, False, True) 413 flags MppTimeout @?= (False, False, False, False) 414 flags (UnknownFailure 0xf000 "") @?= (True, True, True, True) 415 , testCase "spec example: incorrect_or_unknown_payment_details" $ do 416 bs <- unhex "400f0000000000000064000c3500" 417 m <- msat 100 418 decode_failure_message bs @?= Right 419 (FailureMessage (IncorrectOrUnknownPaymentDetails m 800000) no_tlvs) 420 , testCase "a trailing TLV stream is kept" $ do 421 ex <- tlvs [BOLT1.TlvRecord 34001 (BS.replicate 3 0x80)] 422 let fm = FailureMessage TemporaryNodeFailure ex 423 bs <- right "encode" (encode_failure_message fm) 424 bs @?= "\x20\x02\xfd\x84\xd1\x03\x80\x80\x80" 425 decode_failure_message bs @?= Right fm 426 , testCase "other trailing bytes are ignored" $ do 427 let ignored f bs = decode_failure_message bs @?= 428 Right (FailureMessage f no_tlvs) 429 ignored TemporaryNodeFailure "\x20\x02\xff" 430 -- an even type: not a valid stream without known types 431 ignored TemporaryNodeFailure "\x20\x02\x02\x00" 432 ignored (FinalIncorrectCltvExpiry 1) "\NUL\DC2\NUL\NUL\NUL\SOH\SOH" 433 , testCase "truncated data is rejected" $ do 434 decode_failure_message "" @?= Left InvalidLength 435 decode_failure_message "\x20" @?= Left InvalidLength 436 decode_failure_message "\xc0\x05\x00" @?= 437 Left (InvalidFailureData 0xc005) 438 decode_failure_message "\x10\x07\x00\x02\x00" @?= 439 Left (InvalidFailureData 0x1007) 440 decode_failure_message "\x40\x0f\x00\x00\x00\x00\x00\x00\x00\x64" @?= 441 Left (InvalidFailureData 0x400f) 442 decode_failure_message "\x00\x13\x00" @?= 443 Left (InvalidFailureData 0x0013) 444 decode_failure_message "\x10\x14\x00\x00\x00" @?= 445 Left (InvalidFailureData 0x1014) 446 , testCase "amounts above 21M BTC are rejected" $ 447 decode_failure_message "\x00\x13\xff\xff\xff\xff\xff\xff\xff\xff" @?= 448 Left (InvalidFailureData 0x0013) 449 , testCase "unknown codes keep their data" $ 450 decode_failure_message "\x12\x34\x01\x00" @?= 451 Right (FailureMessage (UnknownFailure 0x1234 "\x01\x00") no_tlvs) 452 , testCase "channel_update longer than 65535 bytes" $ 453 encode_failure_message 454 (FailureMessage (ExpiryTooSoon (BS.replicate 65536 0)) no_tlvs) 455 @?= Left FieldTooLong 456 ] 457 458 -- construct ------------------------------------------------------------------ 459 460 construct_tests :: TestTree 461 construct_tests = testGroup "construct" [ 462 testCase "empty route" $ do 463 sk <- key 0x41 464 assertConstructError EmptyRoute (construct sk [] ad) 465 , testCase "more than 20 hops" $ do 466 sk <- key 0x41 467 node <- key 0x42 468 let hop = Hop (public_key node) (cltv_payload 1) 469 assertConstructError TooManyHops (construct sk (replicate 21 hop) ad) 470 case construct sk (replicate 20 hop) ad of 471 Right (_, sss) -> length sss @?= 20 472 Left e -> assertFailure (show e) 473 , testCase "invalid hop public key" $ do 474 sk <- key 0x41 475 node <- key 0x42 476 bad <- off_curve 477 let good = Hop (public_key node) (cltv_payload 1) 478 assertConstructError (InvalidHopPubKey 1) 479 (construct sk [good, Hop bad (cltv_payload 1), good] ad) 480 , testCase "payloads under 2 bytes" $ do 481 sk <- key 0x41 482 node <- key 0x42 483 let good = Hop (public_key node) (cltv_payload 1) 484 assertConstructError (InvalidHopPayload 1) 485 (construct sk [good, Hop (public_key node) empty_hop_payload] ad) 486 , testCase "unencodable payload" $ do 487 sk <- key 0x41 488 node <- key 0x42 489 ex <- tlvs [BOLT1.TlvRecord 4 "\SOH"] 490 let bad = Hop (public_key node) empty_hop_payload { hp_extra = ex } 491 assertConstructError (InvalidHopPayload 0) (construct sk [bad] ad) 492 , testCase "payloads over 1300 bytes" $ do 493 sk <- key 0x41 494 node <- key 0x42 495 -- a 1265-byte payload exactly fills hop_payloads 496 ex <- tlvs [BOLT1.TlvRecord 1 (BS.replicate 1261 0)] 497 let full = Hop (public_key node) empty_hop_payload { hp_extra = ex } 498 case construct sk [full] ad of 499 Right _ -> pure () 500 Left e -> assertFailure (show e) 501 ex' <- tlvs [BOLT1.TlvRecord 1 (BS.replicate 1262 0)] 502 let over = Hop (public_key node) empty_hop_payload { hp_extra = ex' } 503 assertConstructError (PayloadsTooLarge 1301) (construct sk [over] ad) 504 let hops = replicate 2 (Hop (public_key node) (cltv_payload 1)) 505 assertConstructError (PayloadsTooLarge 1372) 506 (construct sk (full : hops) ad) 507 ] 508 where 509 assertConstructError e r = case r of 510 Left e' -> e' @?= e 511 Right _ -> assertFailure ("expected " ++ show e) 512 513 -- process -------------------------------------------------------------------- 514 515 process_tests :: TestTree 516 process_tests = testGroup "process" [ 517 testCase "rejects versions other than 0" $ do 518 (node, pkt) <- simple_onion 519 expect_process (InvalidVersion 1) 520 (process node pkt { onion_version = 1 } ad Nothing) 521 , testCase "rejects a public key not on the curve" $ do 522 (node, pkt) <- simple_onion 523 bad <- off_curve 524 expect_process InvalidPublicKey 525 (process node pkt { onion_public_key = bad } ad Nothing) 526 , testCase "rejects a wrong HMAC" $ do 527 (node, pkt) <- simple_onion 528 flipped <- demand "flip" $ 529 case BS.uncons (un_hop_payloads (onion_hop_payloads pkt)) of 530 Just (h, t) -> hop_payloads (BS.cons (h `xor` 1) t) 531 Nothing -> Nothing 532 expect_process HmacMismatch 533 (process node pkt { onion_hop_payloads = flipped } ad Nothing) 534 mac <- demand "mac" (hmac32 (BS.replicate 32 0)) 535 expect_process HmacMismatch 536 (process node pkt { onion_hmac = mac } ad Nothing) 537 , testCase "rejects other associated data" $ do 538 (node, pkt) <- simple_onion 539 expect_process HmacMismatch 540 (process node pkt (BS.replicate 32 0) Nothing) 541 , testCase "rejects other node keys" $ do 542 (_, pkt) <- simple_onion 543 other <- key 0x44 544 expect_process HmacMismatch (process other pkt ad Nothing) 545 , testCase "rejects payload lengths 0 and 1" $ do 546 node <- key 0x42 547 p0 <- raw_onion node (pad1300 "\NUL") 548 expect_process InvalidPayloadLength (process node p0 ad Nothing) 549 p1 <- raw_onion node (pad1300 "\SOH\SOH") 550 expect_process InvalidPayloadLength (process node p1 ad Nothing) 551 , testCase "rejects a malformed length prefix" $ do 552 node <- key 0x42 553 p <- raw_onion node (pad1300 "\253\NUL\DLE") 554 expect_process InvalidPayloadLength (process node p ad Nothing) 555 , testCase "rejects payloads past the end of hop_payloads" $ do 556 node <- key 0x42 557 -- 3-byte prefix, 1265-byte payload and 32-byte HMAC fill it 558 let rec n = BS.concat [ "\SOH\253", BOLT1.encode_u16 n 559 , BS.replicate (fromIntegral n) 0 ] 560 ok <- raw_onion node (pad1300 ("\253\EOT\241" <> rec 1261)) 561 _ <- receive (process node ok ad Nothing) 562 over <- raw_onion node (pad1300 ("\253\EOT\242" <> rec 1262)) 563 expect_process InvalidPayloadLength (process node over ad Nothing) 564 -- a length reaching into the zero-extended stream 565 far <- raw_onion node (pad1300 ("\253\a\208" <> rec 1261)) 566 expect_process InvalidPayloadLength (process node far ad Nothing) 567 huge <- raw_onion node 568 (pad1300 ("\255\128\NUL\NUL\NUL\NUL\NUL\NUL\NUL" <> rec 1)) 569 expect_process InvalidPayloadLength (process node huge ad Nothing) 570 , testCase "rejects malformed payloads" $ do 571 node <- key 0x42 572 let bad pl = raw_onion node 573 (pad1300 (BOLT1.encode_bigsize (fromIntegral (BS.length pl)) 574 <> pl)) 575 p0 <- bad "\EOT\SOH\SOH\STX\SOH\SOH" 576 expect_process 577 (InvalidPayload (InvalidTlvStream BOLT1.TlvNotStrictlyIncreasing)) 578 (process node p0 ad Nothing) 579 p1 <- bad "\DC4\NUL" 580 expect_process 581 (InvalidPayload (InvalidTlvStream (BOLT1.TlvUnknownEvenType 20))) 582 (process node p1 ad Nothing) 583 p2 <- bad "\STX\STX\NUL\SOH" 584 expect_process (InvalidPayload (InvalidTlvValue 2)) 585 (process node p2 ad Nothing) 586 , testCase "the final hop receives" $ do 587 (node, pkt) <- simple_onion 588 info <- receive (process node pkt ad Nothing) 589 rcv_payload info @?= cltv_payload 144 590 rcv_blinded info @?= Nothing 591 , testCase "forwarded packets are well formed" $ do 592 sk <- key 0x41 593 a <- key 0x42 594 b <- key 0x43 595 (pkt, sss) <- right "construct" $ construct sk 596 [Hop (public_key a) (cltv_payload 1), Hop (public_key b) 597 (cltv_payload 2)] ad 598 fwd <- forward (process a pkt ad Nothing) 599 let next = fwd_next_packet fwd 600 onion_version next @?= 0 601 decode_onion_packet (encode_onion_packet next) @?= Right next 602 Just (fwd_shared_secret fwd) @?= safe_head sss 603 rcv <- receive (process b next ad Nothing) 604 rcv_payload rcv @?= cltv_payload 2 605 , testCase "path keys without encrypted_recipient_data" $ do 606 sk <- key 0x41 607 alice <- key 0x42 608 seed <- key 0x01 609 path <- right "path" $ 610 create_blinded_path seed [(public_key alice, empty_blinded_hop_data)] 611 bid <- blinded_id path 0 612 let pk = bp_first_path_key path 613 -- a path_key, onion encrypted to the blinded id 614 (p0, _) <- right "construct" $ 615 construct sk [Hop bid (cltv_payload 1)] ad 616 expect_process UnexpectedPathKey (process alice p0 ad (Just pk)) 617 -- a current_path_key 618 let pl = (cltv_payload 1) { hp_current_path_key = Just pk } 619 (p1, _) <- right "construct" $ 620 construct sk [Hop (public_key alice) pl] ad 621 expect_process UnexpectedPathKey (process alice p1 ad Nothing) 622 , testCase "both a path_key and a current_path_key" $ do 623 sk <- key 0x41 624 alice <- key 0x42 625 seed <- key 0x01 626 path <- right "path" $ 627 create_blinded_path seed [(public_key alice, empty_blinded_hop_data)] 628 bid <- blinded_id path 0 629 enc <- blinded_data path 0 630 let pk = bp_first_path_key path 631 pl = empty_hop_payload { hp_encrypted_data = Just enc 632 , hp_current_path_key = Just pk } 633 (pkt, _) <- right "construct" $ construct sk [Hop bid pl] ad 634 expect_process UnexpectedPathKey (process alice pkt ad (Just pk)) 635 , testCase "encrypted_recipient_data without a path key" $ do 636 sk <- key 0x41 637 alice <- key 0x42 638 let pl = empty_hop_payload { hp_encrypted_data = Just "data" } 639 (pkt, _) <- right "construct" $ 640 construct sk [Hop (public_key alice) pl] ad 641 expect_process MissingPathKey (process alice pkt ad Nothing) 642 , testCase "undecryptable encrypted_recipient_data" $ do 643 sk <- key 0x41 644 alice <- key 0x42 645 pk <- hex_point V.rbBobPathKey 646 let pl = empty_hop_payload { hp_encrypted_data = Just 647 (BS.replicate 40 0) 648 , hp_current_path_key = Just pk } 649 (pkt, _) <- right "construct" $ 650 construct sk [Hop (public_key alice) pl] ad 651 expect_process InvalidRecipientData (process alice pkt ad Nothing) 652 , testCase "invalid path keys" $ do 653 sk <- key 0x41 654 alice <- key 0x42 655 bad <- off_curve 656 let pl = empty_hop_payload { hp_encrypted_data = Just "data" 657 , hp_current_path_key = Just bad } 658 (pkt, _) <- right "construct" $ 659 construct sk [Hop (public_key alice) pl] ad 660 expect_process InvalidPathKey (process alice pkt ad Nothing) 661 (pkt', _) <- right "construct" $ 662 construct sk [Hop (public_key alice) (cltv_payload 1)] ad 663 expect_process InvalidPathKey (process alice pkt' ad (Just bad)) 664 ] 665 where 666 simple_onion = do 667 sk <- key 0x41 668 node <- key 0x42 669 (pkt, _) <- right "construct" $ 670 construct sk [Hop (public_key node) (cltv_payload 144)] ad 671 pure (node, pkt) 672 673 three :: [a] -> IO (a, a, a) 674 three xs = case xs of 675 [a, b, c] -> pure (a, b, c) 676 _ -> assertFailure "expected three elements" 677 678 safe_head :: [a] -> Maybe a 679 safe_head xs = case xs of 680 x : _ -> Just x 681 [] -> Nothing 682 683 safe_index :: [a] -> Int -> Maybe a 684 safe_index xs i = safe_head (drop i xs) 685 686 blinded_id :: BlindedPath -> Int -> IO BOLT1.Point 687 blinded_id p i = 688 demand "blinded hop" (bh_blinded_node_id <$> safe_index (bp_hops p) i) 689 690 blinded_data :: BlindedPath -> Int -> IO BS.ByteString 691 blinded_data p i = 692 demand "blinded hop" (bh_encrypted_data <$> safe_index (bp_hops p) i) 693 694 -- route blinding ------------------------------------------------------------- 695 696 blinding_tests :: TestTree 697 blinding_tests = testGroup "route blinding" [ 698 testCase "empty path" $ do 699 seed <- key 0x01 700 create_blinded_path seed [] @?= Left EmptyPath 701 , testCase "invalid node id" $ do 702 seed <- key 0x01 703 alice <- key 0x42 704 bad <- off_curve 705 create_blinded_path seed 706 [ (public_key alice, empty_blinded_hop_data) 707 , (bad, empty_blinded_hop_data) ] 708 @?= Left (InvalidNodeId 1) 709 , testCase "unencodable hop data" $ do 710 seed <- key 0x01 711 alice <- key 0x42 712 ex <- tlvs [BOLT1.TlvRecord 6 "id"] 713 create_blinded_path seed 714 [(public_key alice, empty_blinded_hop_data { bhd_extra = ex })] 715 @?= Left (InvalidHopData 0 ConflictingTlv) 716 , testCase "decrypt_recipient_data rejects bad input" $ do 717 seed <- key 0x01 718 alice <- key 0x42 719 bob <- key 0x43 720 path <- right "path" $ 721 create_blinded_path seed [(public_key alice, empty_blinded_hop_data)] 722 enc <- blinded_data path 0 723 let pk = bp_first_path_key path 724 _ <- right "decrypt" (decrypt_recipient_data alice pk enc) 725 decrypt_recipient_data bob pk enc @?= Left InvalidRecipientData 726 decrypt_recipient_data alice pk (BS.take 15 enc) @?= 727 Left InvalidRecipientData 728 decrypt_recipient_data alice pk (BS.drop 1 enc) @?= 729 Left InvalidRecipientData 730 bad <- off_curve 731 decrypt_recipient_data alice bad enc @?= Left InvalidPathKey 732 , testCase "unknown even types in encrypted data are rejected" $ do 733 seed <- key 0x01 734 alice <- key 0x42 735 ex <- tlvs [BOLT1.TlvRecord 20 ""] 736 path <- right "path" $ create_blinded_path seed 737 [(public_key alice, empty_blinded_hop_data { bhd_extra = ex })] 738 enc <- blinded_data path 0 739 decrypt_recipient_data alice (bp_first_path_key path) enc @?= 740 Left InvalidRecipientData 741 , testCase "a payment through a blinded route" $ do 742 -- Carol creates a route Alice -> Bob -> Carol; Dave pays through it, 743 -- reaching Alice unblinded with current_path_key. 744 seed <- key 0x01 745 session <- key 0x02 746 alice <- key 0x42 747 bob <- key 0x43 748 carol <- key 0x44 749 s1 <- scid 1 1 1 750 s2 <- scid 2 2 2 751 m <- msat 1 752 let relay = Just (PaymentRelay 40 100 1000) 753 cons = Just (PaymentConstraints 900000 m) 754 alice_data = empty_blinded_hop_data 755 { bhd_short_channel_id = Just s1, bhd_payment_relay = relay 756 , bhd_payment_constraints = cons } 757 bob_data = empty_blinded_hop_data 758 { bhd_short_channel_id = Just s2, bhd_payment_relay = relay 759 , bhd_payment_constraints = cons } 760 carol_data = empty_blinded_hop_data 761 { bhd_path_id = Just "invoice" } 762 path <- right "path" $ create_blinded_path seed 763 [ (public_key alice, alice_data), (public_key bob, bob_data) 764 , (public_key carol, carol_data) ] 765 bp_first_node_id path @?= public_key alice 766 bp_first_path_key path @?= public_key seed 767 (e0, e1, e2) <- three =<< mapM (blinded_data path) [0, 1, 2] 768 (_, b1, b2) <- three =<< mapM (blinded_id path) [0, 1, 2] 769 amt <- msat 5000 770 let intro = empty_hop_payload 771 { hp_encrypted_data = Just e0 772 , hp_current_path_key = Just (bp_first_path_key path) } 773 final = empty_hop_payload 774 { hp_encrypted_data = Just e2, hp_amt_to_forward = Just amt 775 , hp_outgoing_cltv_value = Just 800000 776 , hp_total_amount_msat = Just amt } 777 route = [ Hop (public_key alice) intro 778 , Hop b1 empty_hop_payload { hp_encrypted_data = Just e1 } 779 , Hop b2 final ] 780 (pkt, sss) <- right "construct" (construct session route ad) 781 fa <- forward (process alice pkt ad Nothing) 782 ia <- demand "alice blinded" (fwd_blinded fa) 783 bi_data ia @?= alice_data 784 fb <- forward (process bob (fwd_next_packet fa) ad 785 (Just (bi_next_path_key ia))) 786 ib <- demand "bob blinded" (fwd_blinded fb) 787 bi_data ib @?= bob_data 788 rc <- receive (process carol (fwd_next_packet fb) ad 789 (Just (bi_next_path_key ib))) 790 ic <- demand "carol blinded" (rcv_blinded rc) 791 bi_data ic @?= carol_data 792 rcv_payload rc @?= final 793 [fwd_shared_secret fa, fwd_shared_secret fb, rcv_shared_secret rc] 794 @?= sss 795 -- the wrong path key yields the wrong blinded key 796 expect_process HmacMismatch 797 (process bob (fwd_next_packet fa) ad 798 (Just (bp_first_path_key path))) 799 ] 800 801 -- returning errors ----------------------------------------------------------- 802 803 error_tests :: TestTree 804 error_tests = testGroup "returning errors" [ 805 testCase "padding brings failure_len + pad_len to 256" $ do 806 ss <- demand "ss" (shared_secret (BS.replicate 32 1)) 807 let fm = FailureMessage TemporaryNodeFailure no_tlvs 808 pkt <- right "construct_error" (construct_error ss fm) 809 let ErrorPacket raw = wrap_error ss pkt 810 BS.length raw @?= 32 + 2 + 2 + 2 + 254 811 BS.take 4 (BS.drop 32 raw) @?= "\NUL\STX\x20\x02" 812 BS.take 2 (BS.drop 36 raw) @?= "\NUL\254" 813 , testCase "long failure messages are not padded" $ do 814 ss <- demand "ss" (shared_secret (BS.replicate 32 1)) 815 ex <- tlvs [BOLT1.TlvRecord 1 (BS.replicate 300 0)] 816 let fm = FailureMessage TemporaryNodeFailure ex 817 ErrorPacket raw <- wrap_error ss <$> 818 right "construct_error" (construct_error ss fm) 819 BS.length raw @?= 32 + 2 + 306 + 2 820 BS.drop (32 + 2 + 306) raw @?= "\NUL\NUL" 821 , testCase "failure messages over 65535 bytes" $ do 822 ss <- demand "ss" (shared_secret (BS.replicate 32 1)) 823 ex <- tlvs [BOLT1.TlvRecord 1 (BS.replicate 65535 0)] 824 construct_error ss (FailureMessage TemporaryNodeFailure ex) 825 @?= Left FieldTooLong 826 , testCase "attributes the failing hop" $ do 827 sss <- mapM (\b -> demand "ss" (shared_secret (BS.replicate 32 b))) 828 [1 .. 5] 829 let fm = FailureMessage PermanentChannelFailure no_tlvs 830 forM_ (zip [0 ..] sss) $ \(i, ss) -> do 831 pkt <- right "construct_error" (construct_error ss fm) 832 let back = foldr wrap_error pkt (take i sss) 833 unwrap_error sss back @?= Attributed i fm 834 , testCase "reports the hop of a malformed failure" $ do 835 sss <- mapM (\b -> demand "ss" (shared_secret (BS.replicate 32 b))) 836 [1 .. 3] 837 ss2 <- demand "ss2" (safe_index sss 2) 838 -- incorrect_cltv_expiry with no data 839 let fm = FailureMessage (UnknownFailure 0x100d "") no_tlvs 840 pkt <- right "construct_error" (construct_error ss2 fm) 841 let back = foldr wrap_error pkt (take 2 sss) 842 unwrap_error sss back @?= MalformedFailure 2 843 , testCase "reports a malformed return packet" $ do 844 ss <- demand "ss" (shared_secret (BS.replicate 32 1)) 845 -- a valid HMAC over a body whose failure_len overruns it 846 let body = "\SOH\NUL\x20\x02" 847 SHA256.MAC um = SHA256.hmac "um" (un_shared_secret ss) 848 SHA256.MAC mac = SHA256.hmac um body 849 pkt = wrap_error ss (ErrorPacket (mac <> body)) 850 unwrap_error [ss] pkt @?= MalformedFailure 0 851 , testCase "unknown origin" $ do 852 sss <- mapM (\b -> demand "ss" (shared_secret (BS.replicate 32 b))) 853 [1 .. 3] 854 other <- demand "ss" (shared_secret (BS.replicate 32 9)) 855 let fm = FailureMessage TemporaryNodeFailure no_tlvs 856 pkt <- right "construct_error" (construct_error other fm) 857 unwrap_error sss pkt @?= UnknownOrigin 858 unwrap_error [] pkt @?= UnknownOrigin 859 unwrap_error sss (ErrorPacket "short") @?= UnknownOrigin 860 ] 861 862 -- spec vectors: onion-test.json ---------------------------------------------- 863 864 onion_hops :: IO [(SecretKey, BOLT1.Point, BS.ByteString)] 865 onion_hops = mapM hop 866 [ (V.onionNodeKey0, V.onionPubKey0, V.onionPayload0) 867 , (V.onionNodeKey1, V.onionPubKey1, V.onionPayload1) 868 , (V.onionNodeKey2, V.onionPubKey2, V.onionPayload2) 869 , (V.onionNodeKey3, V.onionPubKey3, V.onionPayload3) 870 , (V.onionNodeKey4, V.onionPubKey4, V.onionPayload4) 871 ] 872 where 873 hop (k, p, pl) = (,,) <$> hex_key k <*> hex_point p 874 <*> (unhex pl >>= unprefix) 875 876 -- the shared secrets of the onion-test.json route, as listed in 877 -- onion-error-test.json 878 route_secrets :: IO [SharedSecret] 879 route_secrets = mapM hex_secret 880 [ V.errSharedSecret0, V.errSharedSecret1, V.errSharedSecret2 881 , V.errSharedSecret3, V.errSharedSecret4 ] 882 883 onion_vectors :: TestTree 884 onion_vectors = testGroup "onion-test.json" [ 885 testCase "construct reproduces the onion" $ do 886 hops <- onion_hops 887 sk <- hex_key V.onionSessionKey 888 assoc <- unhex V.onionAssocData 889 expected <- unhex V.onionPacket 890 sss <- route_secrets 891 route <- mapM (\(_, pub, body) -> do 892 hp <- right "decode_hop_payload" (decode_hop_payload body) 893 encode_hop_payload hp @?= Right body 894 pure (Hop pub hp)) hops 895 (pkt, secrets) <- right "construct" (construct sk route assoc) 896 encode_onion_packet pkt @?= expected 897 secrets @?= sss 898 , testCase "process peels the onion at every hop" $ do 899 hops <- onion_hops 900 assoc <- unhex V.onionAssocData 901 sss <- route_secrets 902 pkt <- unhex V.onionPacket >>= right "decode" . decode_onion_packet 903 let go [] _ = assertFailure "no hops" 904 go [((k, _, body), ss)] p = do 905 r <- receive (process k p assoc Nothing) 906 encode_hop_payload (rcv_payload r) @?= Right body 907 rcv_shared_secret r @?= ss 908 go (((k, _, body), ss) : rest) p = do 909 f <- forward (process k p assoc Nothing) 910 encode_hop_payload (fwd_payload f) @?= Right body 911 fwd_shared_secret f @?= ss 912 fwd_blinded f @?= Nothing 913 go rest (fwd_next_packet f) 914 go (zip hops sss) pkt 915 ] 916 917 -- spec vectors: onion-error-test.json ---------------------------------------- 918 919 -- the failing node's shared secret, and those of the hops back to the 920 -- origin, from hop 3 to hop 0 921 error_wrappers :: IO (SharedSecret, [SharedSecret]) 922 error_wrappers = do 923 sss <- route_secrets 924 case reverse sss of 925 ss4 : rest -> pure (ss4, rest) 926 [] -> assertFailure "no shared secrets" 927 928 error_vectors :: TestTree 929 error_vectors = testGroup "onion-error-test.json" [ 930 testCase "failure message" $ do 931 msg <- unhex V.errFailureMessage 932 let fm = FailureMessage TemporaryNodeFailure no_tlvs 933 encode_failure_message fm @?= Right msg 934 decode_failure_message msg @?= Right fm 935 , testCase "the failing node's return packet" $ do 936 (ss4, _) <- error_wrappers 937 payload <- unhex V.errPayload4 938 let fm = FailureMessage TemporaryNodeFailure no_tlvs 939 pkt <- right "construct_error" (construct_error ss4 fm) 940 -- removing hop 4's obfuscation leaves the HMAC and payload 941 let ErrorPacket raw = wrap_error ss4 pkt 942 BS.drop 32 raw @?= payload 943 , testCase "wrapping at each hop yields the returned packet" $ do 944 (ss4, wrappers) <- error_wrappers 945 expected <- unhex V.errPacket 946 let fm = FailureMessage TemporaryNodeFailure no_tlvs 947 pkt <- right "construct_error" (construct_error ss4 fm) 948 foldl (flip wrap_error) pkt wrappers @?= ErrorPacket expected 949 , testCase "the origin attributes the packet to hop 4" $ do 950 sss <- route_secrets 951 pkt <- unhex V.errPacket 952 unwrap_error sss (ErrorPacket pkt) @?= 953 Attributed 4 (FailureMessage TemporaryNodeFailure no_tlvs) 954 ] 955 956 -- spec vectors: 'Returning Errors' trace ------------------------------------- 957 958 trace_failure :: IO FailureMessage 959 trace_failure = do 960 m <- msat 100 961 ex <- tlvs [BOLT1.TlvRecord 34001 (BS.replicate 300 0x80)] 962 pure (FailureMessage (IncorrectOrUnknownPaymentDetails m 800000) ex) 963 964 trace_vectors :: TestTree 965 trace_vectors = testGroup "returning errors trace" [ 966 testCase "failure message encoding" $ do 967 fm <- trace_failure 968 -- the trace lists failuremsg || pad_len || pad 969 encoded <- unhex V.traceFailureMessage 970 msg <- right "encode" (encode_failure_message fm) 971 BS.length msg @?= 320 972 BS.take 320 encoded @?= msg 973 decode_failure_message msg @?= Right fm 974 , testCase "each hop's packet matches the trace" $ do 975 (ss4, wrappers) <- error_wrappers 976 raw <- unhex V.traceRawPacket 977 expected <- mapM unhex 978 [ V.tracePacket4, V.tracePacket3, V.tracePacket2 979 , V.tracePacket1, V.tracePacket0 ] 980 let packets = drop 1 $ 981 scanl (flip wrap_error) (ErrorPacket raw) (ss4 : wrappers) 982 packets @?= map ErrorPacket expected 983 , testCase "the origin attributes the packet to hop 4" $ do 984 fm <- trace_failure 985 sss <- route_secrets 986 pkt <- unhex V.tracePacket0 987 unwrap_error sss (ErrorPacket pkt) @?= Attributed 4 fm 988 ] 989 990 -- spec vectors: route-blinding-test.json ------------------------------------- 991 992 empty_features :: Maybe BOLT9.FeatureVector 993 empty_features = Just (BOLT9.parse BS.empty) 994 995 rb_bob_data :: IO BlindedHopData 996 rb_bob_data = do 997 s <- scid 0 0 1729 998 m <- msat 1500 999 ex <- tlvs [BOLT1.TlvRecord 561 "\DC24V"] 1000 pure empty_blinded_hop_data 1001 { bhd_padding = Just (BS.replicate 26 0) 1002 , bhd_short_channel_id = Just s 1003 , bhd_payment_relay = Just (PaymentRelay 36 150 10000) 1004 , bhd_payment_constraints = Just (PaymentConstraints 748005 m) 1005 , bhd_allowed_features = empty_features 1006 , bhd_extra = ex 1007 } 1008 1009 rb_carol_data :: IO BlindedHopData 1010 rb_carol_data = do 1011 s <- scid 0 0 1105 1012 m <- msat 1500 1013 override <- hex_point V.rbDavePathKey 1014 pure empty_blinded_hop_data 1015 { bhd_short_channel_id = Just s 1016 , bhd_next_path_key_override = Just override 1017 , bhd_payment_relay = Just (PaymentRelay 48 100 500) 1018 , bhd_payment_constraints = Just (PaymentConstraints 747969 m) 1019 , bhd_allowed_features = empty_features 1020 } 1021 1022 rb_dave_data :: IO BlindedHopData 1023 rb_dave_data = do 1024 s <- scid 0 0 561 1025 m <- msat 1500 1026 pure empty_blinded_hop_data 1027 { bhd_padding = Just (BS.replicate 35 0) 1028 , bhd_short_channel_id = Just s 1029 , bhd_payment_relay = Just (PaymentRelay 144 250 0) 1030 , bhd_payment_constraints = Just (PaymentConstraints 747921 m) 1031 , bhd_allowed_features = empty_features 1032 } 1033 1034 rb_eve_data :: IO BlindedHopData 1035 rb_eve_data = do 1036 m <- msat 1500 1037 ex <- tlvs [BOLT1.TlvRecord 65535 "\ACK\193"] 1038 pure empty_blinded_hop_data 1039 { bhd_padding = Just (BS.replicate 26 0) 1040 , bhd_path_id = Just "\222\173\190\239" 1041 , bhd_payment_constraints = Just (PaymentConstraints 747777 m) 1042 , bhd_allowed_features = 1043 Just (BOLT9.parse (BS.cons 0x02 (BS.replicate 14 0))) 1044 , bhd_extra = ex 1045 } 1046 1047 -- a hop of route-blinding-test.json 1048 data RbHop = RbHop 1049 { rb_data :: !BlindedHopData 1050 , rb_node_id :: !BOLT1.Point 1051 , rb_tlvs :: !BS.ByteString 1052 , rb_path_key :: !BOLT1.Point 1053 , rb_encrypted :: !BS.ByteString 1054 , rb_blinded_id :: !BOLT1.Point 1055 , rb_node_key :: !SecretKey 1056 , rb_next_path_key :: !BOLT1.Point 1057 } 1058 1059 rb_hops :: IO [RbHop] 1060 rb_hops = sequence 1061 [ hop rb_bob_data 1062 ( V.rbBobNodeId, V.rbBobTlvs, V.rbBobPathKey 1063 , V.rbBobEncryptedData, V.rbBobBlindedNodeId ) 1064 (V.rbBobNodeKey, V.rbBobNextPathKey) 1065 , hop rb_carol_data 1066 ( V.rbCarolNodeId, V.rbCarolTlvs, V.rbCarolPathKey 1067 , V.rbCarolEncryptedData, V.rbCarolBlindedNodeId ) 1068 (V.rbCarolNodeKey, V.rbCarolNextPathKey) 1069 , hop rb_dave_data 1070 ( V.rbDaveNodeId, V.rbDaveTlvs, V.rbDavePathKey 1071 , V.rbDaveEncryptedData, V.rbDaveBlindedNodeId ) 1072 (V.rbDaveNodeKey, V.rbDaveNextPathKey) 1073 , hop rb_eve_data 1074 ( V.rbEveNodeId, V.rbEveTlvs, V.rbEvePathKey 1075 , V.rbEveEncryptedData, V.rbEveBlindedNodeId ) 1076 (V.rbEveNodeKey, V.rbEveNextPathKey) 1077 ] 1078 where 1079 hop mk (nid, tl, pk, enc, bid) (nk, npk) = 1080 RbHop <$> mk <*> hex_point nid <*> unhex tl <*> hex_point pk 1081 <*> unhex enc <*> hex_point bid <*> hex_key nk 1082 <*> hex_point npk 1083 1084 route_blinding_vectors :: TestTree 1085 route_blinding_vectors = testGroup "route-blinding-test.json" [ 1086 testCase "encrypted_data_tlv encodings" $ do 1087 hops <- rb_hops 1088 forM_ hops $ \h -> do 1089 encode_blinded_hop_data (rb_data h) @?= Right (rb_tlvs h) 1090 decode_blinded_hop_data (rb_tlvs h) @?= Right (rb_data h) 1091 , testCase "create_blinded_path reproduces the route" $ do 1092 hops <- rb_hops 1093 (bob, carol, dave, eve) <- case hops of 1094 [b, c, d, e] -> pure (b, c, d, e) 1095 _ -> assertFailure "expected 4 hops" 1096 -- Bob creates Bob -> Carol, Eve creates Dave -> Eve 1097 bob_seed <- hex_key V.rbBobPathPrivKey 1098 dave_seed <- hex_key V.rbDavePathPrivKey 1099 let check seed hs = do 1100 path <- right "create_blinded_path" $ create_blinded_path seed 1101 [ (rb_node_id h, rb_data h) | h <- hs ] 1102 case hs of 1103 h : _ -> do 1104 bp_first_node_id path @?= rb_node_id h 1105 bp_first_path_key path @?= rb_path_key h 1106 [] -> assertFailure "no hops" 1107 bp_hops path @?= 1108 [ BlindedHop (rb_blinded_id h) (rb_encrypted h) | h <- hs ] 1109 check bob_seed [bob, carol] 1110 check dave_seed [dave, eve] 1111 , testCase "each hop decrypts its data and next path key" $ do 1112 hops <- rb_hops 1113 forM_ hops $ \h -> do 1114 info <- right "decrypt_recipient_data" $ 1115 decrypt_recipient_data (rb_node_key h) (rb_path_key h) 1116 (rb_encrypted h) 1117 bi_data info @?= rb_data h 1118 encode_blinded_hop_data (bi_data info) @?= Right (rb_tlvs h) 1119 -- Carol's next path key is her next_path_key_override 1120 bi_next_path_key info @?= rb_next_path_key h 1121 , testCase "each hop decrypts an onion to its blinded id" $ do 1122 -- the onion is encrypted to blinded_node_id, so processing it 1123 -- requires the blinded private key of the vector 1124 hops <- rb_hops 1125 session <- key 0x55 1126 forM_ hops $ \h -> do 1127 let pl = empty_hop_payload 1128 { hp_encrypted_data = Just (rb_encrypted h) } 1129 (pkt, sss) <- right "construct" $ 1130 construct session [Hop (rb_blinded_id h) pl] ad 1131 r <- receive (process (rb_node_key h) pkt ad (Just (rb_path_key h))) 1132 Just (rcv_shared_secret r) @?= safe_head sss 1133 fmap bi_next_path_key (rcv_blinded r) @?= Just (rb_next_path_key h) 1134 ] 1135 1136 -- spec vectors: blinded-payment-onion-test.json ------------------------------ 1137 1138 bp_bob_data :: IO BlindedHopData 1139 bp_bob_data = do 1140 s <- scid 0 0 1 1141 m <- msat 50 1142 pure empty_blinded_hop_data 1143 { bhd_padding = Just (BS.replicate 32 0) 1144 , bhd_short_channel_id = Just s 1145 , bhd_payment_relay = Just (PaymentRelay 50 0 10000) 1146 , bhd_payment_constraints = Just (PaymentConstraints 750150 m) 1147 , bhd_allowed_features = empty_features 1148 } 1149 1150 bp_carol_data :: IO BlindedHopData 1151 bp_carol_data = do 1152 s <- scid 0 0 2 1153 m <- msat 50 1154 override <- hex_point V.rbDavePathKey 1155 pure empty_blinded_hop_data 1156 { bhd_short_channel_id = Just s 1157 , bhd_next_path_key_override = Just override 1158 , bhd_payment_relay = Just (PaymentRelay 75 150 100) 1159 , bhd_payment_constraints = Just (PaymentConstraints 750100 m) 1160 , bhd_allowed_features = empty_features 1161 } 1162 1163 bp_dave_data :: IO BlindedHopData 1164 bp_dave_data = do 1165 s <- scid 0 0 3 1166 m <- msat 50 1167 pure empty_blinded_hop_data 1168 { bhd_padding = Just (BS.replicate 34 0) 1169 , bhd_short_channel_id = Just s 1170 , bhd_payment_relay = Just (PaymentRelay 25 100 0) 1171 , bhd_payment_constraints = Just (PaymentConstraints 750025 m) 1172 , bhd_allowed_features = empty_features 1173 } 1174 1175 bp_eve_data :: IO BlindedHopData 1176 bp_eve_data = do 1177 m <- msat 50 1178 path_id <- unhex "c9cf92f45ade68345bc20ae672e2012f4af487ed4415" 1179 pure empty_blinded_hop_data 1180 { bhd_padding = Just (BS.replicate 28 0) 1181 , bhd_path_id = Just path_id 1182 , bhd_payment_constraints = Just (PaymentConstraints 750000 m) 1183 , bhd_allowed_features = empty_features 1184 } 1185 1186 -- per hop: node key, public key the onion is encrypted to, onion 1187 -- received, payload (without its length prefix) 1188 bp_route 1189 :: IO [(SecretKey, BOLT1.Point, BS.ByteString, BS.ByteString)] 1190 bp_route = mapM hop 1191 [ (V.onionNodeKey0, V.bpAlicePubKey, V.bpAliceOnion, V.bpAlicePayload) 1192 , (V.rbBobNodeKey, V.bpBobPubKey, V.bpBobOnion, V.bpBobPayload) 1193 , (V.rbCarolNodeKey, V.bpCarolPubKey, V.bpCarolOnion, V.bpCarolPayload) 1194 , (V.rbDaveNodeKey, V.bpDavePubKey, V.bpDaveOnion, V.bpDavePayload) 1195 , (V.rbEveNodeKey, V.bpEvePubKey, V.bpEveOnion, V.bpEvePayload) 1196 ] 1197 where 1198 hop (k, p, o, pl) = (,,,) <$> hex_key k <*> hex_point p <*> unhex o 1199 <*> (unhex pl >>= unprefix) 1200 1201 blinded_payment_vectors :: TestTree 1202 blinded_payment_vectors = testGroup "blinded-payment-onion-test.json" [ 1203 testCase "construct reproduces the onion" $ do 1204 route <- bp_route 1205 sk <- hex_key V.bpSessionKey 1206 assoc <- unhex V.bpAssocData 1207 expected <- unhex V.bpAliceOnion 1208 hops <- mapM (\(_, pub, _, body) -> do 1209 hp <- right "decode_hop_payload" (decode_hop_payload body) 1210 encode_hop_payload hp @?= Right body 1211 pure (Hop pub hp)) route 1212 (pkt, _) <- right "construct" (construct sk hops assoc) 1213 encode_onion_packet pkt @?= expected 1214 , testCase "the route's payloads" $ do 1215 route <- bp_route 1216 first_pk <- hex_point V.rbBobPathKey 1217 s <- scid 0 0 10 1218 (a0, a1, a2) <- three =<< mapM msat [110125, 100000, 150000] 1219 payloads <- mapM (\(_, _, _, body) -> 1220 right "decode_hop_payload" (decode_hop_payload body)) route 1221 case payloads of 1222 [alice, bob, carol, dave, eve] -> do 1223 alice @?= empty_hop_payload 1224 { hp_short_channel_id = Just s, hp_amt_to_forward = Just a0 1225 , hp_outgoing_cltv_value = Just 749150 } 1226 hp_current_path_key bob @?= Just first_pk 1227 forM_ [bob, carol, dave] $ \hp -> do 1228 assertBool "encrypted data" (hp_encrypted_data hp /= Nothing) 1229 hp { hp_encrypted_data = Nothing 1230 , hp_current_path_key = Nothing } @?= empty_hop_payload 1231 eve { hp_encrypted_data = Nothing } @?= empty_hop_payload 1232 { hp_amt_to_forward = Just a1, hp_total_amount_msat = Just a2 1233 , hp_outgoing_cltv_value = Just 749000 } 1234 _ -> assertFailure "expected 5 payloads" 1235 , testCase "each hop processes its onion" $ do 1236 route <- bp_route 1237 assoc <- unhex V.bpAssocData 1238 datas <- sequence [bp_bob_data, bp_carol_data, bp_dave_data, 1239 bp_eve_data] 1240 nexts <- mapM hex_point 1241 [ V.bpBobNextPathKey, V.bpCarolNextPathKey, V.bpDaveNextPathKey 1242 , V.bpEveNextPathKey ] 1243 -- (hop, path_key received, expected blinded info) 1244 let expect = zip3 route 1245 (Nothing : Nothing : map Just (take 3 nexts)) 1246 (Nothing : map Just (zipWith BlindedInfo datas nexts)) 1247 go [] = assertFailure "no hops" 1248 go [((k, _, onion, body), mpk, binfo)] = do 1249 pkt <- right "decode" (decode_onion_packet onion) 1250 r <- receive (process k pkt assoc mpk) 1251 encode_hop_payload (rcv_payload r) @?= Right body 1252 rcv_blinded r @?= binfo 1253 go (((k, _, onion, body), mpk, binfo) : rest) = do 1254 pkt <- right "decode" (decode_onion_packet onion) 1255 f <- forward (process k pkt assoc mpk) 1256 encode_hop_payload (fwd_payload f) @?= Right body 1257 fwd_blinded f @?= binfo 1258 forM_ (take 1 rest) $ \((_, _, next, _), _, _) -> 1259 encode_onion_packet (fwd_next_packet f) @?= next 1260 go rest 1261 go expect 1262 ] 1263 1264 -- properties ----------------------------------------------------------------- 1265 1266 properties :: TestTree 1267 properties = testGroup "properties" [ 1268 testProperty "onion packets round-trip" $ 1269 forAll gen_onion $ \pkt -> 1270 decode_onion_packet (encode_onion_packet pkt) === Right pkt 1271 , testProperty "hop payloads round-trip" $ 1272 forAll gen_hop_payload $ \hp -> 1273 fmap decode_hop_payload (encode_hop_payload hp) === Right (Right hp) 1274 , testProperty "blinded hop data round-trips" $ 1275 forAll gen_blinded_hop_data $ \d -> 1276 fmap decode_blinded_hop_data (encode_blinded_hop_data d) 1277 === Right (Right d) 1278 , testProperty "failure messages round-trip" $ 1279 forAll gen_failure_message $ \fm -> 1280 fmap decode_failure_message (encode_failure_message fm) 1281 === Right (Right fm) 1282 , testProperty "wrap_error is an involution" $ 1283 forAll gen_secret $ \ss -> 1284 forAll (gen_bytes 0 600) $ \bs -> 1285 wrap_error ss (wrap_error ss (ErrorPacket bs)) === ErrorPacket bs 1286 , testProperty "errors are attributed to the failing hop" $ 1287 forAll (choose (1, 20)) $ \n -> 1288 forAll (vectorOf n gen_secret) $ \sss -> 1289 forAll (choose (0, n - 1)) $ \i -> 1290 forAll gen_failure_message $ \fm -> 1291 case drop i sss of 1292 ss : _ | Right pkt <- construct_error ss fm -> 1293 unwrap_error sss (foldr wrap_error pkt (take i sss)) 1294 === Attributed i fm 1295 _ -> property False 1296 , testProperty "routes of 1 to 20 hops construct and process" $ 1297 forAll (choose (1, 20)) $ \n -> 1298 forAll gen_key $ \sk -> 1299 forAll (vectorOf n gen_key) $ \keys -> 1300 forAll (vectorOf n (gen_route_payload n)) $ \pls -> 1301 route_roundtrip sk (zip keys pls) 1302 ] 1303 1304 -- construct an onion over a route, then process it at every hop 1305 route_roundtrip :: SecretKey -> [(SecretKey, HopPayload)] -> Property 1306 route_roundtrip sk route = 1307 case construct sk [Hop (public_key k) hp | (k, hp) <- route] ad of 1308 Left e -> counterexample (show e) False 1309 Right (pkt, sss) -> length sss === length route .&&. go route sss pkt 1310 where 1311 go [(k, hp)] [ss] pkt = case process k pkt ad Nothing of 1312 Right (Receive r) -> 1313 rcv_payload r === hp .&&. property (rcv_shared_secret r == ss) 1314 other -> counterexample (show other) False 1315 go ((k, hp) : rest) (ss : sss) pkt = case process k pkt ad Nothing of 1316 Right (Forward f) -> 1317 fwd_payload f === hp 1318 .&&. property (fwd_shared_secret f == ss) 1319 .&&. go rest sss (fwd_next_packet f) 1320 other -> counterexample (show other) False 1321 go _ _ _ = property False 1322 1323 -- generators ----------------------------------------------------------------- 1324 1325 gen_bytes :: Int -> Int -> Gen BS.ByteString 1326 gen_bytes lo hi = do 1327 n <- choose (lo, hi) 1328 BS.pack <$> vectorOf n arbitrary 1329 1330 gen_key :: Gen SecretKey 1331 gen_key = gen_bytes 32 32 `suchThatMap` secret_key 1332 1333 gen_secret :: Gen SharedSecret 1334 gen_secret = gen_bytes 32 32 `suchThatMap` shared_secret 1335 1336 gen_point :: Gen BOLT1.Point 1337 gen_point = do 1338 prefix <- elements [0x02, 0x03] 1339 x <- gen_bytes 32 32 1340 pure (BS.cons prefix x) `suchThatMap` BOLT1.point 1341 1342 gen_msat :: Gen BOLT1.MilliSatoshi 1343 gen_msat = oneof 1344 [ choose (0, 0xffff), choose (0, BOLT1.un_milli_satoshi 1345 BOLT1.max_milli_satoshi) ] 1346 `suchThatMap` BOLT1.milli_satoshi 1347 1348 gen_scid :: Gen BOLT1.ShortChannelId 1349 gen_scid = BOLT1.ShortChannelId <$> arbitrary 1350 1351 gen_maybe :: Gen a -> Gen (Maybe a) 1352 gen_maybe g = oneof [pure Nothing, Just <$> g] 1353 1354 -- extra records with odd types not in the given list 1355 gen_extra :: [Word64] -> Gen BOLT1.TlvStream 1356 gen_extra known = do 1357 n <- choose (0, 3) 1358 ts <- vectorOf n (oneof [choose (1, 300), choose (65536, 70000)]) 1359 recs <- mapM (\t -> BOLT1.TlvRecord t <$> gen_bytes 0 20) 1360 [ t | t <- ts, odd t, t `notElem` known ] 1361 let uniq = nubBy (\a b -> BOLT1.tlv_type a == BOLT1.tlv_type b) recs 1362 pure uniq `suchThatMap` BOLT1.tlv_stream 1363 1364 gen_onion :: Gen OnionPacket 1365 gen_onion = OnionPacket 1366 <$> arbitrary 1367 <*> gen_point 1368 <*> (gen_bytes 1300 1300 `suchThatMap` hop_payloads) 1369 <*> (gen_bytes 32 32 `suchThatMap` hmac32) 1370 1371 gen_hop_payload :: Gen HopPayload 1372 gen_hop_payload = HopPayload 1373 <$> gen_maybe gen_msat 1374 <*> gen_maybe arbitrary 1375 <*> gen_maybe gen_scid 1376 <*> gen_maybe (PaymentData 1377 <$> (gen_bytes 32 32 `suchThatMap` payment_secret) 1378 <*> gen_msat) 1379 <*> gen_maybe (gen_bytes 0 50) 1380 <*> gen_maybe gen_point 1381 <*> gen_maybe (gen_bytes 0 50) 1382 <*> gen_maybe gen_msat 1383 <*> gen_extra [] 1384 1385 gen_blinded_hop_data :: Gen BlindedHopData 1386 gen_blinded_hop_data = BlindedHopData 1387 <$> gen_maybe (gen_bytes 0 40) 1388 <*> gen_maybe gen_scid 1389 <*> gen_maybe gen_point 1390 <*> gen_maybe (gen_bytes 0 40) 1391 <*> gen_maybe gen_point 1392 <*> gen_maybe (PaymentRelay <$> arbitrary <*> arbitrary <*> arbitrary) 1393 <*> gen_maybe (PaymentConstraints <$> arbitrary <*> gen_msat) 1394 <*> gen_maybe (BOLT9.parse <$> gen_bytes 0 8) 1395 <*> gen_extra [1] 1396 1397 gen_failure_message :: Gen FailureMessage 1398 gen_failure_message = do 1399 f <- gen_failure 1400 ex <- case f of 1401 -- these take every byte after the code, or may be ambiguous with a 1402 -- TLV stream 1403 UnknownFailure _ _ -> pure no_tlvs 1404 InvalidOnionPayload Nothing -> pure no_tlvs 1405 _ -> gen_extra [] 1406 pure (FailureMessage f ex) 1407 1408 gen_failure :: Gen Failure 1409 gen_failure = oneof 1410 [ pure TemporaryNodeFailure 1411 , pure PermanentNodeFailure 1412 , pure RequiredNodeFeatureMissing 1413 , InvalidOnionVersion <$> hash 1414 , InvalidOnionHmac <$> hash 1415 , InvalidOnionKey <$> hash 1416 , TemporaryChannelFailure <$> update 1417 , pure PermanentChannelFailure 1418 , pure RequiredChannelFeatureMissing 1419 , pure UnknownNextPeer 1420 , AmountBelowMinimum <$> gen_msat <*> update 1421 , FeeInsufficient <$> gen_msat <*> update 1422 , IncorrectCltvExpiry <$> arbitrary <*> update 1423 , ExpiryTooSoon <$> update 1424 , IncorrectOrUnknownPaymentDetails <$> gen_msat <*> arbitrary 1425 , FinalIncorrectCltvExpiry <$> arbitrary 1426 , FinalIncorrectHtlcAmount <$> gen_msat 1427 , ChannelDisabled <$> arbitrary <*> update 1428 , pure ExpiryTooFar 1429 , InvalidOnionPayload <$> gen_maybe ((,) <$> arbitrary <*> arbitrary) 1430 , pure MppTimeout 1431 , InvalidOnionBlinding <$> hash 1432 , UnknownFailure <$> (arbitrary `suchThat` unknown) <*> gen_bytes 0 20 1433 ] 1434 where 1435 hash = gen_bytes 32 32 `suchThatMap` onion_hash 1436 update = gen_bytes 0 100 1437 unknown c = c `notElem` 1438 [ 0x2002, 0x6002, 0x6003, 0xc004, 0xc005, 0xc006, 0x1007, 0x4008 1439 , 0x4009, 0x400a, 0x100b, 0x100c, 0x100d, 0x100e, 0x400f, 0x0012 1440 , 0x0013, 0x1014, 0x0015, 0x4016, 0x0017, 0xc018 ] 1441 1442 -- a payload whose shift size fits n hops in 1300 bytes 1443 -- 1444 -- The typed fields take at most 26 bytes; an odd record of type 65537 1445 -- adds at most 8 bytes of framing plus its value. With a 3-byte length 1446 -- prefix and 32-byte HMAC a hop then shifts at most 69 bytes plus the 1447 -- value's length. 1448 gen_route_payload :: Int -> Gen HopPayload 1449 gen_route_payload n = do 1450 amt <- gen_msat 1451 cltv <- arbitrary 1452 s <- gen_maybe gen_scid 1453 let budget = 1300 `div` n - 69 1454 ex <- if budget < 0 1455 then pure no_tlvs 1456 else do 1457 v <- gen_bytes 0 budget 1458 pure (BOLT1.TlvRecord 65537 v : []) 1459 `suchThatMap` BOLT1.tlv_stream 1460 pure empty_hop_payload 1461 { hp_amt_to_forward = Just amt 1462 , hp_outgoing_cltv_value = Just cltv 1463 , hp_short_channel_id = s 1464 , hp_extra = ex 1465 }