Main.hs (53574B)
1 {-# LANGUAGE OverloadedStrings #-} 2 3 module Main where 4 5 import Bitcoin.Prim.Tx (OutPoint(..), Tx(..), TxId, TxIn(..), 6 TxOut(..), Witness(..)) 7 import qualified Bitcoin.Prim.Tx as BT 8 import Bitcoin.Prim.Tx.Sighash (SighashType(..), encode_sighash) 9 import qualified Crypto.Hash.SHA256 as SHA256 10 import qualified Data.ByteString as BS 11 import Data.List.NonEmpty (NonEmpty(..)) 12 import Data.Word (Word8, Word32, Word64) 13 import Lightning.Protocol.BOLT1 (MilliSatoshi, PaymentHash, Satoshi) 14 import qualified Lightning.Protocol.BOLT1 as BOLT1 15 import Lightning.Protocol.BOLT3 16 import qualified Lightning.Protocol.BOLT5 as B5 17 import Test.Tasty 18 import Test.Tasty.HUnit 19 import Test.Tasty.QuickCheck 20 21 main :: IO () 22 main = defaultMain $ testGroup "ppad-bolt5" [ 23 types_tests 24 , detect_tests 25 , classify_tests 26 , spend_tests 27 , htlc_spend_tests 28 , remote_spend_tests 29 , revoked_htlc_spend_tests 30 , weight_tests 31 , property_tests 32 ] 33 34 -- helpers ------------------------------------------------------------ 35 36 -- | Unwrap a Just, failing the enclosing test on Nothing. 37 need :: String -> Maybe a -> IO a 38 need msg = maybe (assertFailure msg) pure 39 40 sat :: Word64 -> IO Satoshi 41 sat = need "invalid satoshi amount" . BOLT1.satoshi 42 43 msat :: Word64 -> IO MilliSatoshi 44 msat = need "invalid millisatoshi amount" . BOLT1.milli_satoshi 45 46 -- | Decode a hex string. 47 unhex :: BS.ByteString -> Maybe BS.ByteString 48 unhex bs 49 | odd (BS.length bs) = Nothing 50 | otherwise = BS.pack <$> go (BS.unpack bs) 51 where 52 go (a:b:rest) = (:) <$> byte a b <*> go rest 53 go _ = Just [] 54 byte a b = (\hi lo -> hi * 16 + lo) <$> nibble a <*> nibble b 55 nibble c 56 | c >= 0x30 && c <= 0x39 = Just (c - 0x30) 57 | c >= 0x61 && c <= 0x66 = Just (c - 0x57) 58 | otherwise = Nothing 59 60 -- | A point from hex. 61 pt :: BS.ByteString -> IO BOLT1.Point 62 pt h = need ("invalid point " <> show h) (unhex h >>= BOLT1.point) 63 64 -- | Total head for NonEmpty. 65 head' :: NonEmpty a -> a 66 head' (x :| _) = x 67 68 -- | Value of a spending transaction's single output. 69 out_value :: B5.SpendingTx -> Word64 70 out_value = txout_value . head' . tx_outputs . B5.stx_tx 71 72 -- | nSequence of a spending transaction's single input. 73 in_sequence :: B5.SpendingTx -> Word32 74 in_sequence = txin_sequence . head' . tx_inputs . B5.stx_tx 75 76 -- fixtures ----------------------------------------------------------- 77 78 -- | Fixtures shared by the unit and property tests. Each key role 79 -- gets its own point, so a key used in the wrong role changes the 80 -- script. 81 data Fx = Fx 82 { fx_revpk :: !RevocationPubkey 83 , fx_delayed :: !LocalDelayedPubkey 84 , fx_local_htlc :: !LocalHtlcPubkey 85 , fx_remote_htlc :: !RemoteHtlcPubkey 86 , fx_funding :: !FundingPubkey 87 , fx_keys :: !CommitmentKeys 88 , fx_hash :: !PaymentHash 89 , fx_offered :: !HTLC 90 -- ^ offered, 1000 sat, expiry 500000 91 , fx_received :: !HTLC 92 -- ^ as 'fx_offered', but received 93 , fx_local_commit :: !CommitmentTx 94 -- ^ to_local and to_remote outputs 95 , fx_htlc_commit :: !CommitmentTx 96 -- ^ as 'fx_local_commit', plus both HTLCs 97 , fx_remote_commit :: !CommitmentTx 98 -- ^ distinct from 'fx_local_commit' 99 } 100 101 fixtures :: Maybe Fx 102 fixtures = do 103 let point b = BOLT1.point (BS.pack (0x02 : replicate 32 b)) 104 revpk <- RevocationPubkey <$> point 0x01 105 delayed <- LocalDelayedPubkey <$> point 0x02 106 local_htlc <- LocalHtlcPubkey <$> point 0x03 107 remote_htlc <- RemoteHtlcPubkey <$> point 0x04 108 remote_payment <- RemotePubkey <$> point 0x06 109 funding <- FundingPubkey <$> point 0x07 110 remote_funding <- FundingPubkey <$> point 0x08 111 ph <- BOLT1.payment_hash (BS.replicate 32 0xAA) 112 amt <- BOLT1.milli_satoshi 1000000 113 v1000 <- BOLT1.satoshi 1000 114 v20k <- BOLT1.satoshi 20000 115 v30k <- BOLT1.satoshi 30000 116 v40k <- BOLT1.satoshi 40000 117 v50k <- BOLT1.satoshi 50000 118 let keys = CommitmentKeys 119 { ck_revocation_pubkey = revpk 120 , ck_local_delayed = delayed 121 , ck_local_htlc = local_htlc 122 , ck_remote_htlc = remote_htlc 123 , ck_remote_payment = remote_payment 124 , ck_local_funding = funding 125 , ck_remote_funding = remote_funding 126 } 127 offered = HTLC 128 { htlc_direction = HTLCOffered 129 , htlc_amount_msat = amt 130 , htlc_payment_hash = ph 131 , htlc_cltv_expiry = CltvExpiry 500000 132 } 133 received = offered { htlc_direction = HTLCReceived } 134 to_local = to_p2wsh (to_local_script revpk dummyDelay delayed) 135 htlc_out h = CommitmentOutput v1000 136 (to_p2wsh (htlc_witness_script keys StaticRemotekey h)) 137 (OutputHTLC h) 138 commit lt outs = CommitmentTx 139 { ctx_version = 2 140 , ctx_locktime = Locktime lt 141 , ctx_input_outpoint = dummyOutPoint 142 , ctx_input_sequence = Sequence 0 143 , ctx_outputs = outs 144 , ctx_funding_script = dummyDestScript 145 } 146 local_outs = 147 CommitmentOutput v50k to_local OutputToLocal 148 :| [CommitmentOutput v30k dummyDestScript OutputToRemote] 149 pure Fx 150 { fx_revpk = revpk 151 , fx_delayed = delayed 152 , fx_local_htlc = local_htlc 153 , fx_remote_htlc = remote_htlc 154 , fx_funding = funding 155 , fx_keys = keys 156 , fx_hash = ph 157 , fx_offered = offered 158 , fx_received = received 159 , fx_local_commit = commit 0 local_outs 160 , fx_htlc_commit = commit 0 $ local_outs 161 <> (htlc_out offered :| [htlc_out received]) 162 , fx_remote_commit = commit 1 $ 163 CommitmentOutput v40k to_local OutputToLocal 164 :| [CommitmentOutput v20k dummyDestScript OutputToRemote] 165 } 166 167 -- | Run a test with the fixtures. 168 with_fx :: (Fx -> Assertion) -> Assertion 169 with_fx k = need "invalid fixtures" fixtures >>= k 170 171 -- | A property over the fixtures. 172 prop_fx :: Testable p => (Fx -> p) -> Property 173 prop_fx k = case fixtures of 174 Nothing -> counterexample "invalid fixtures" False 175 Just fx -> property (k fx) 176 177 dummyTxId :: TxId 178 dummyTxId = BT.null_txid 179 180 dummyOutPoint :: OutPoint 181 dummyOutPoint = OutPoint dummyTxId 0 182 183 dummyDelay :: ToSelfDelay 184 dummyDelay = ToSelfDelay 144 185 186 dummyFeerate :: FeeratePerKw 187 dummyFeerate = FeeratePerKw 253 188 189 -- | A P2WPKH scriptPubKey. 190 dummyDestScript :: Script 191 dummyDestScript = Script $ BS.pack [0x00, 0x14] <> BS.replicate 20 0xCC 192 193 -- | The witness script of an HTLC output of a commitment with the 194 -- given keys. 195 htlc_witness_script :: CommitmentKeys -> CommitmentFormat -> HTLC -> Script 196 htlc_witness_script keys fmt h = case htlc_direction h of 197 HTLCOffered -> offered_htlc_script (ck_revocation_pubkey keys) 198 (ck_remote_htlc keys) (ck_local_htlc keys) (htlc_payment_hash h) fmt 199 HTLCReceived -> received_htlc_script (ck_revocation_pubkey keys) 200 (ck_remote_htlc keys) (ck_local_htlc keys) (htlc_payment_hash h) 201 (htlc_cltv_expiry h) fmt 202 203 -- | An HTLC context for one of the fixture HTLCs. 204 htlc_context :: Fx -> HTLC -> CommitmentFormat -> HTLCContext 205 htlc_context fx h fmt = HTLCContext 206 { hc_commitment_txid = dummyTxId 207 , hc_output_index = 0 208 , hc_htlc = h 209 , hc_to_self_delay = dummyDelay 210 , hc_feerate = dummyFeerate 211 , hc_format = fmt 212 , hc_revocation_pubkey = fx_revpk fx 213 , hc_local_delayed = fx_delayed fx 214 } 215 216 -- BOLT #3 Appendix C/F vectors ------------------------------------- 217 218 -- | Payment hash of an Appendix C HTLC whose preimage is 32 copies 219 -- of the given byte. 220 vecPaymentHash :: Word8 -> IO PaymentHash 221 vecPaymentHash b = 222 need "payment hash" (BOLT1.payment_hash (SHA256.hash (BS.replicate 32 b))) 223 224 -- | An Appendix C HTLC, given its direction, amount (msat), expiry 225 -- and preimage byte. 226 vecHtlc :: HTLCDirection -> Word64 -> Word32 -> Word8 -> IO HTLC 227 vecHtlc dir amt expiry b = do 228 a <- msat amt 229 ph <- vecPaymentHash b 230 pure HTLC 231 { htlc_direction = dir 232 , htlc_amount_msat = a 233 , htlc_payment_hash = ph 234 , htlc_cltv_expiry = CltvExpiry expiry 235 } 236 237 vecHtlc0, vecHtlc1, vecHtlc2, vecHtlc3, vecHtlc4 :: IO HTLC 238 vecHtlc0 = vecHtlc HTLCReceived 1000000 500 0x00 239 vecHtlc1 = vecHtlc HTLCReceived 2000000 501 0x01 240 vecHtlc2 = vecHtlc HTLCOffered 2000000 502 0x02 241 vecHtlc3 = vecHtlc HTLCOffered 3000000 503 0x03 242 vecHtlc4 = vecHtlc HTLCReceived 4000000 504 0x04 243 244 vecHtlc5, vecHtlc6 :: IO HTLC 245 vecHtlc5 = vecHtlc HTLCOffered 5000000 506 0x05 246 vecHtlc6 = vecHtlc HTLCOffered 5000001 505 0x05 247 248 -- | Appendix C keys for the local commitment (Appendix F uses the 249 -- same keys). 250 vecKeys :: IO CommitmentKeys 251 vecKeys = do 252 rev <- pt 253 "0212a140cd0c6539d07cd08dfe09984dec3251ea808b892efeac3ede9402bf2b19" 254 delayed <- pt 255 "03fd5960528dc152014952efdb702a88f71e3c1653b2314431701ec77e57fde83c" 256 localHtlc <- pt 257 "030d417a46946384f88d5f3337267c5e579765875dc4daca813e21734b140639e7" 258 remoteHtlc <- pt 259 "0394854aa6eab5b2a8122cc726e9dded053a2184d88256816826d6231c068d4a5b" 260 remotePayment <- pt 261 "032c0b7cf95324a07d05398b240174dc0c2be444d96b159aa6c7f7b1e668680991" 262 localFunding <- pt 263 "023da092f6980e58d2c037173180e9a465476026ee50f96695963e8efe436f54eb" 264 remoteFunding <- pt 265 "030e9f7b623d2ccc7c9bd44d66d5ce21ce504c0acf6385a132cec6d3c39fa711c1" 266 pure CommitmentKeys 267 { ck_revocation_pubkey = RevocationPubkey rev 268 , ck_local_delayed = LocalDelayedPubkey delayed 269 , ck_local_htlc = LocalHtlcPubkey localHtlc 270 , ck_remote_htlc = RemoteHtlcPubkey remoteHtlc 271 , ck_remote_payment = RemotePubkey remotePayment 272 , ck_local_funding = FundingPubkey localFunding 273 , ck_remote_funding = FundingPubkey remoteFunding 274 } 275 276 -- | Rebuild an Appendix C/F local commitment with bolt3, given the 277 -- feerate, commitment format, to_local balance (msat) and HTLCs. 278 vecCommitment 279 :: FeeratePerKw -> CommitmentFormat -> Word64 -> [HTLC] 280 -> IO CommitmentTx 281 vecCommitment feerate fmt toLocal htlcs = do 282 keys <- vecKeys 283 fundingTxid <- need "funding txid" $ BT.mk_txid =<< unhex 284 "bef67e4e2fb9ddeeb3461973cd4c62abb35050b1add772995b820b584a488489" 285 cn <- need "commitment number" (commitment_number 42) 286 localBp <- pt 287 "034f355bdcb7cc0af728ef3cceb9615d90684bb5b2ca5f859ab0f0b704075871aa" 288 remoteBp <- pt 289 "032c0b7cf95324a07d05398b240174dc0c2be444d96b159aa6c7f7b1e668680991" 290 dust <- sat 546 291 toLocalMsat <- msat toLocal 292 toRemoteMsat <- msat 3000000000 293 need "build_commitment_tx" $ build_commitment_tx CommitmentContext 294 { cc_funding_outpoint = OutPoint fundingTxid 0 295 , cc_commitment_number = cn 296 , cc_local_payment_bp = PaymentBasepoint localBp 297 , cc_remote_payment_bp = PaymentBasepoint remoteBp 298 , cc_to_self_delay = ToSelfDelay 144 299 , cc_dust_limit = DustLimit dust 300 , cc_feerate = feerate 301 , cc_format = fmt 302 , cc_is_funder = True 303 , cc_to_local_msat = toLocalMsat 304 , cc_to_remote_msat = toRemoteMsat 305 , cc_htlcs = htlcs 306 , cc_keys = keys 307 } 308 309 -- | The Appendix C commitment with two offered HTLCs sharing a 310 -- payment hash and amount. 311 vecCommitSameHash :: IO CommitmentTx 312 vecCommitSameHash = do 313 h1 <- vecHtlc1 314 h5 <- vecHtlc5 315 h6 <- vecHtlc6 316 vecCommitment (FeeratePerKw 253) StaticRemotekey 6987999999 [h1, h5, h6] 317 318 -- | The Appendix F (anchors) "commitment tx with seven outputs 319 -- untrimmed". 320 vecCommitAnchors :: IO CommitmentTx 321 vecCommitAnchors = do 322 hs <- sequence [vecHtlc0, vecHtlc1, vecHtlc2, vecHtlc3, vecHtlc4] 323 vecCommitment (FeeratePerKw 644) Anchors 6988000000 hs 324 325 -- | Appendix C: commitment tx with 3 htlc outputs, 2 offered 326 -- having the same amount and preimage (signed). 327 vecCCommitSameHash :: BS.ByteString 328 vecCCommitSameHash = 329 "02000000000101bef67e4e2fb9ddeeb3461973cd4c62abb35050b1add772995b\ 330 \820b584a488489000000000038b02b8005d007000000000000220020748eba94\ 331 \4fedc8827f6b06bc44678f93c0f9e6078b35c6331ed31e75f8ce0c2d88130000\ 332 \00000000220020305c12e1a0bc21e283c131cea1c66d68857d28b7b2fce0a6fb\ 333 \c40c164852121b8813000000000000220020305c12e1a0bc21e283c131cea1c6\ 334 \6d68857d28b7b2fce0a6fbc40c164852121bc0c62d0000000000160014cc1b07\ 335 \838e387deacd0e5232e1e8b49f4c29e484a69f6a00000000002200204adb4e2f\ 336 \00643db396dd120d4e7dc17625f5f2c11a40d857accc862d6b7dd80e04004730\ 337 \4402200d10bf5bc5397fc59d7188ae438d80c77575595a2d488e41bd6363a810\ 338 \cc8d72022012b57e714fbbfdf7a28c47d5b370cb8ac37c8545f596216e5b21e9\ 339 \b236ef457c0147304402207d0870964530f97b62497b11153c551dca0a1e2268\ 340 \15ef0a336651158da0f82402200f5378beee0e77759147b8a0a284decd11bfd2\ 341 \bc55c8fafa41c134fe996d43c801475221023da092f6980e58d2c037173180e9\ 342 \a465476026ee50f96695963e8efe436f54eb21030e9f7b623d2ccc7c9bd44d66\ 343 \d5ce21ce504c0acf6385a132cec6d3c39fa711c152ae3e195220" 344 345 -- | Appendix C: HTLC-success tx for htlc #1 from the same 346 -- commitment (signed). 347 vecCHtlcSuccess1 :: BS.ByteString 348 vecCHtlcSuccess1 = 349 "020000000001014bdccf28653066a2c554cafeffdfe1e678e64a69b056684deb\ 350 \0c4fba909423ec000000000000000000011f070000000000002200204adb4e2f\ 351 \00643db396dd120d4e7dc17625f5f2c11a40d857accc862d6b7dd80e05004830\ 352 \45022100b470fe12e5b7fea9eccb8cbff1972cea4f96758041898982a02bcc7f\ 353 \9d56d50b0220338a75b2afaab4ec00cdd2d9273c68c7581ff5a28bcbb40c4d13\ 354 \8b81f1d45ce501473044022017b90c65207522a907fb6a137f9dd528b3389465\ 355 \a8ae72308d9e1d564f512cf402204fc917b4f0e88604a3e994f85bfae7c7c1f9\ 356 \d9e9f78e8cd112e0889720d9405b012001010101010101010101010101010101\ 357 \010101010101010101010101010101018a76a91414011f7254d96b819c76986c\ 358 \277d115efce6f7b58763ac67210394854aa6eab5b2a8122cc726e9dded053a21\ 359 \84d88256816826d6231c068d4a5b7c8201208763a9144b6b2e5444c2639cc0fb\ 360 \7bcea5afba3f3cdce23988527c21030d417a46946384f88d5f3337267c5e5797\ 361 \65875dc4daca813e21734b140639e752ae677502f501b175ac686800000000" 362 363 -- | Appendix C: HTLC-timeout tx for htlc #6 from the same 364 -- commitment (signed). 365 vecCHtlcTimeout6 :: BS.ByteString 366 vecCHtlcTimeout6 = 367 "020000000001014bdccf28653066a2c554cafeffdfe1e678e64a69b056684deb\ 368 \0c4fba909423ec01000000000000000001e1120000000000002200204adb4e2f\ 369 \00643db396dd120d4e7dc17625f5f2c11a40d857accc862d6b7dd80e05004830\ 370 \45022100b575379f6d8743cb0087648f81cfd82d17a97fbf8f67e058c65ce8b9\ 371 \d25df9500220554a210d65b02d9f36c6adf0f639430ca8293196ba5089bf67cc\ 372 \3a9813b7b00a01483045022100ee2e16b90930a479b13f8823a7f14b600198c8\ 373 \38161160b9436ed086d3fc57e002202a66fa2324f342a17129949c640bfe934c\ 374 \bc73a869ba7c06aa25c5a3d0bfb53d01008576a91414011f7254d96b819c7698\ 375 \6c277d115efce6f7b58763ac67210394854aa6eab5b2a8122cc726e9dded053a\ 376 \2184d88256816826d6231c068d4a5b7c820120876475527c21030d417a469463\ 377 \84f88d5f3337267c5e579765875dc4daca813e21734b140639e752ae67a91420\ 378 \02cc93ebefbb1b73f0af055dcc27a0b504ad7688ac6868f9010000" 379 380 -- | Appendix C: HTLC-timeout tx for htlc #5 from the same 381 -- commitment (signed). 382 vecCHtlcTimeout5 :: BS.ByteString 383 vecCHtlcTimeout5 = 384 "020000000001014bdccf28653066a2c554cafeffdfe1e678e64a69b056684deb\ 385 \0c4fba909423ec02000000000000000001e1120000000000002200204adb4e2f\ 386 \00643db396dd120d4e7dc17625f5f2c11a40d857accc862d6b7dd80e05004730\ 387 \440220471c9f3ad92e49b13b7b8059f43ecf8f7887b0dccbb9fdb54bfe23d62a\ 388 \8ae332022024bd22fae0740e86a44228c35330da9526fd7306dffb2b9dc362d5\ 389 \e78abef7cc0147304402207157f452f2506d73c315192311893800cfb3cc235c\ 390 \c1185b1cfcc136b55230db022014be242dbc6c5da141fec4034e7f387f74d6ff\ 391 \1899453d72ba957467540e1ecb01008576a91414011f7254d96b819c76986c27\ 392 \7d115efce6f7b58763ac67210394854aa6eab5b2a8122cc726e9dded053a2184\ 393 \d88256816826d6231c068d4a5b7c820120876475527c21030d417a46946384f8\ 394 \8d5f3337267c5e579765875dc4daca813e21734b140639e752ae67a9142002cc\ 395 \93ebefbb1b73f0af055dcc27a0b504ad7688ac6868fa010000" 396 397 -- | Appendix F: HTLC-timeout tx for htlc #2 from "commitment tx 398 -- with seven outputs untrimmed" (signed). 399 vecFHtlcTimeout2 :: BS.ByteString 400 vecFHtlcTimeout2 = 401 "02000000000101b8cefef62ea66f5178b9361b2371be0759cbc8c689bcfa7a8e\ 402 \6746d497ec221a03000000000100000001d0070000000000002200204adb4e2f\ 403 \00643db396dd120d4e7dc17625f5f2c11a40d857accc862d6b7dd80e05004830\ 404 \45022100a847bc3b8cf2441013725ae32dc589c419835d069afd6d7f3d9834d8\ 405 \be7cea6e02204ce9d35ec7f0788da80e4d62e810c4ccd13617e58fa10832e38f\ 406 \b7ae87bdf33883473044022026739b1adbfa34c485bf0e5a19e0cf7532f64545\ 407 \bcc5c95b95643ccc2d351e1902201743bb1b34f00e031cc15f6eff0f8ab76450\ 408 \8d2681ff965ba62e76e540bca1e801008876a91414011f7254d96b819c76986c\ 409 \277d115efce6f7b58763ac67210394854aa6eab5b2a8122cc726e9dded053a21\ 410 \84d88256816826d6231c068d4a5b7c820120876475527c21030d417a46946384\ 411 \f88d5f3337267c5e579765875dc4daca813e21734b140639e752ae67a914b43e\ 412 \1b38138a41b37f7cd9a1d274bc63e3a9b5d188ac6851b27568f6010000" 413 414 -- | Appendix F: HTLC-success tx for htlc #1 from "commitment tx 415 -- with seven outputs untrimmed" (signed). 416 vecFHtlcSuccess1 :: BS.ByteString 417 vecFHtlcSuccess1 = 418 "02000000000101b8cefef62ea66f5178b9361b2371be0759cbc8c689bcfa7a8e\ 419 \6746d497ec221a04000000000100000001d0070000000000002200204adb4e2f\ 420 \00643db396dd120d4e7dc17625f5f2c11a40d857accc862d6b7dd80e05004730\ 421 \44022035977f2aa6d6ae12f1dae3366440faa17558e9c88c3188bfc8df7e276c\ 422 \6c65410220659f1f9070c725d9d46e43b99a36fc6d711d36069704add2d57fc1\ 423 \fa2818cf12834730440220191ba44e57b1601a59d99f85971d4801b286d428de\ 424 \275487c87ceeb8df1a4811022002215875d92833df0c9615c9096cf97152f871\ 425 \39ed9f82718bbb5b8b3d31252401200101010101010101010101010101010101\ 426 \0101010101010101010101010101018d76a91414011f7254d96b819c76986c27\ 427 \7d115efce6f7b58763ac67210394854aa6eab5b2a8122cc726e9dded053a2184\ 428 \d88256816826d6231c068d4a5b7c8201208763a9144b6b2e5444c2639cc0fb7b\ 429 \cea5afba3f3cdce23988527c21030d417a46946384f88d5f3337267c5e579765\ 430 \875dc4daca813e21734b140639e752ae677502f501b175ac6851b27568000000\ 431 \00" 432 433 434 -- | Parse a hex-encoded transaction, failing the test otherwise. 435 parseTx :: BS.ByteString -> IO Tx 436 parseTx = need "invalid transaction hex" . BT.from_base16 437 438 -- | Witness stack of a single-input transaction. 439 singleWitness :: Tx -> IO [BS.ByteString] 440 singleWitness tx = case tx_inputs tx of 441 i :| [] | Witness items <- txin_witness i -> pure items 442 _ -> assertFailure "expected a single input" 443 444 -- | Remote signature and offered HTLC witness script, taken from the 445 -- Appendix C HTLC-timeout tx for htlc #5. 446 offeredClaimParts :: IO (BS.ByteString, Script) 447 offeredClaimParts = do 448 items <- singleWitness =<< parseTx vecCHtlcTimeout5 449 case items of 450 [_, sig, _, _, script] -> pure (sig, Script script) 451 _ -> assertFailure "unexpected HTLC-timeout witness" 452 453 -- | Signatures and received HTLC witness script, taken from the 454 -- Appendix C HTLC-success tx for htlc #1. 455 successParts :: IO (BS.ByteString, BS.ByteString, Script) 456 successParts = do 457 items <- singleWitness =<< parseTx vecCHtlcSuccess1 458 case items of 459 [_, remoteSig, localSig, _, script] -> 460 pure (remoteSig, localSig, Script script) 461 _ -> assertFailure "unexpected HTLC-success witness" 462 463 -- | Build the HTLC tx for an HTLC output of an Appendix C/F 464 -- commitment (to_self_delay 144). 465 vecHtlcTx :: FeeratePerKw -> B5.UnresolvedOutput -> IO B5.SpendingTx 466 vecHtlcTx feerate uo = case B5.uo_type uo of 467 B5.SpendHTLCTimeout htlc keys fmt -> build htlc keys fmt 468 B5.SpendHTLCSuccess htlc keys fmt -> build htlc keys fmt 469 other -> assertFailure ("expected an HTLC output, got " <> show other) 470 where 471 build htlc keys fmt = need "spend_htlc_tx" $ 472 B5.spend_htlc_tx (ctx htlc keys fmt) keys 473 ctx htlc keys fmt = HTLCContext 474 { hc_commitment_txid = op_txid (B5.uo_outpoint uo) 475 , hc_output_index = op_vout (B5.uo_outpoint uo) 476 , hc_htlc = htlc 477 , hc_to_self_delay = ToSelfDelay 144 478 , hc_feerate = feerate 479 , hc_format = fmt 480 , hc_revocation_pubkey = ck_revocation_pubkey keys 481 , hc_local_delayed = ck_local_delayed keys 482 } 483 484 -- | Check an HTLC tx against a signed BOLT #3 vector: the unsigned 485 -- tx and the witness script must match. 486 assertHtlcTx :: B5.SpendingTx -> BS.ByteString -> Assertion 487 assertHtlcTx stx vec = do 488 tx <- parseTx vec 489 items <- singleWitness tx 490 B5.stx_tx stx @?= tx { tx_inputs = fmap 491 (\i -> i { txin_witness = Witness [] }) (tx_inputs tx) } 492 case reverse items of 493 script : _ -> B5.stx_input_script stx @?= Script script 494 [] -> assertFailure "empty witness" 495 496 -- | Check the sighash flags of the signatures in a signed BOLT #3 497 -- HTLC-tx vector: the local one must be the type the 'SpendingTx' 498 -- gives, the remote one bolt3's 'remote_htlc_sighash'. 499 assertSighashFlags 500 :: B5.SpendingTx -> CommitmentFormat -> BS.ByteString -> Assertion 501 assertSighashFlags stx fmt vec = do 502 items <- singleWitness =<< parseTx vec 503 case items of 504 [_, remoteSig, localSig, _, _] -> do 505 flag remoteSig @?= Just (encode_sighash (remote_htlc_sighash fmt)) 506 flag localSig 507 @?= Just (encode_sighash (B5.stx_sighash_type stx)) 508 _ -> assertFailure "unexpected HTLC-tx witness" 509 where 510 flag = fmap (fromIntegral . snd) . BS.unsnoc 511 512 -- types tests -------------------------------------------------------- 513 514 types_tests :: TestTree 515 types_tests = testGroup "Types" [ 516 testCase "CloseType constructors" $ do 517 B5.MutualClose @?= B5.MutualClose 518 B5.LocalCommitClose @?= B5.LocalCommitClose 519 B5.RemoteCommitClose @?= B5.RemoteCommitClose 520 B5.RevokedCommitClose @?= B5.RevokedCommitClose 521 522 , testCase "spending_fee calculation" $ 523 BOLT1.un_satoshi (B5.spending_fee (FeeratePerKw 1000) 500) @?= 500 524 525 , testCase "spending_fee at low feerate" $ 526 -- 253 * 324 / 1000 = 81.972 -> 81 527 BOLT1.un_satoshi (B5.spending_fee (FeeratePerKw 253) 324) @?= 81 528 529 , testCase "spending_fee saturates at 21 million BTC" $ 530 B5.spending_fee (FeeratePerKw maxBound) maxBound 531 @?= BOLT1.max_satoshi 532 533 , testCase "weight constants" $ do 534 B5.to_local_penalty_witness_weight @?= 160 535 B5.to_local_penalty_input_weight @?= 324 536 B5.offered_htlc_penalty_input_weight @?= 407 537 B5.accepted_htlc_penalty_input_weight @?= 413 538 B5.offered_htlc_penalty_input_weight_anchors @?= 410 539 B5.accepted_htlc_penalty_input_weight_anchors @?= 416 540 B5.to_remote_input_weight @?= 272 541 B5.max_standard_weight @?= 400000 542 ] 543 544 -- detect tests ------------------------------------------------------- 545 546 detect_tests :: TestTree 547 detect_tests = testGroup "Detect" [ 548 testCase "extract_preimage_htlc_success - Appendix C" $ do 549 items <- singleWitness =<< parseTx vecCHtlcSuccess1 550 ph <- vecPaymentHash 0x01 551 fmap BOLT1.un_payment_preimage 552 (B5.extract_preimage_htlc_success ph (Witness items)) 553 @?= Just (BS.replicate 32 0x01) 554 555 , testCase "extract_preimage_htlc_success - Appendix F" $ do 556 items <- singleWitness =<< parseTx vecFHtlcSuccess1 557 ph <- vecPaymentHash 0x01 558 fmap BOLT1.un_payment_preimage 559 (B5.extract_preimage_htlc_success ph (Witness items)) 560 @?= Just (BS.replicate 32 0x01) 561 562 , testCase "extract_preimage_htlc_success - bolt3 witness" $ do 563 (remoteSig, localSig, script) <- successParts 564 ph <- vecPaymentHash 0x01 565 preimage <- need "preimage" 566 (BOLT1.payment_preimage (BS.replicate 32 0x01)) 567 B5.extract_preimage_htlc_success ph 568 (htlc_success_witness remoteSig localSig preimage script) 569 @?= Just preimage 570 571 , testCase "extract_preimage_htlc_success - wrong hash" $ do 572 items <- singleWitness =<< parseTx vecCHtlcSuccess1 573 ph <- vecPaymentHash 0x05 574 B5.extract_preimage_htlc_success ph (Witness items) @?= Nothing 575 576 , testCase "extract_preimage_htlc_success - timeout witness" $ do 577 items <- singleWitness =<< parseTx vecCHtlcTimeout5 578 ph <- vecPaymentHash 0x05 579 B5.extract_preimage_htlc_success ph (Witness items) @?= Nothing 580 (remoteSig, localSig, script) <- successParts 581 B5.extract_preimage_htlc_success ph 582 (htlc_timeout_witness remoteSig localSig script) 583 @?= Nothing 584 585 , testCase "extract_preimage_htlc_success - no script" $ do 586 items <- singleWitness =<< parseTx vecCHtlcSuccess1 587 ph <- vecPaymentHash 0x01 588 B5.extract_preimage_htlc_success ph (Witness (take 4 items)) 589 @?= Nothing 590 591 , testCase "extract_preimage_offered - remote claim" $ do 592 -- <remotehtlcsig> <payment_preimage> <witness_script>; the 593 -- signature is not checked. 594 (sig, script) <- offeredClaimParts 595 ph <- vecPaymentHash 0x05 596 preimage <- need "preimage" 597 (BOLT1.payment_preimage (BS.replicate 32 0x05)) 598 B5.extract_preimage_offered ph 599 (offered_htlc_witness_preimage sig preimage script) 600 @?= Just preimage 601 602 , testCase "extract_preimage_offered - wrong hash" $ do 603 (sig, script) <- offeredClaimParts 604 ph <- vecPaymentHash 0x01 605 preimage <- need "preimage" 606 (BOLT1.payment_preimage (BS.replicate 32 0x05)) 607 B5.extract_preimage_offered ph 608 (offered_htlc_witness_preimage sig preimage script) 609 @?= Nothing 610 611 , testCase "extract_preimage_offered - revocation spend" $ with_fx $ 612 \fx -> do 613 -- <revocation_sig> <revocationpubkey> <witness_script> 614 (sig, script) <- offeredClaimParts 615 ph <- vecPaymentHash 0x05 616 B5.extract_preimage_offered ph 617 (offered_htlc_witness_revoke sig (fx_revpk fx) script) 618 @?= Nothing 619 620 , testCase "extract_preimage_offered - no script" $ do 621 (sig, _) <- offeredClaimParts 622 ph <- vecPaymentHash 0x05 623 B5.extract_preimage_offered ph 624 (Witness [sig, BS.replicate 32 0x05]) 625 @?= Nothing 626 627 , testCase "htlc_timed_out - at expiry" $ with_fx $ \fx -> 628 B5.htlc_timed_out 500000 (fx_offered fx) @?= True 629 630 , testCase "htlc_timed_out - past expiry" $ with_fx $ \fx -> 631 B5.htlc_timed_out 500001 (fx_offered fx) @?= True 632 633 , testCase "htlc_timed_out - before expiry" $ with_fx $ \fx -> 634 B5.htlc_timed_out 499999 (fx_offered fx) @?= False 635 ] 636 637 -- classify tests ----------------------------------------------------- 638 639 classify_tests :: TestTree 640 classify_tests = testGroup "Classify" [ 641 testCase "identify_close - signed local commitment" $ with_fx $ 642 \fx -> do 643 commit <- vecCommitSameHash 644 signed <- need "hex" (unhex vecCCommitSameHash) 645 B5.identify_close commit (fx_remote_commit fx) signed 646 @?= Just B5.LocalCommitClose 647 648 , testCase "identify_close - signed remote commitment" $ with_fx $ 649 \fx -> do 650 commit <- vecCommitSameHash 651 signed <- need "hex" (unhex vecCCommitSameHash) 652 B5.identify_close (fx_local_commit fx) commit signed 653 @?= Just B5.RemoteCommitClose 654 655 , testCase "identify_close - unsigned commitment" $ with_fx $ \fx -> do 656 commit <- vecCommitSameHash 657 B5.identify_close commit (fx_remote_commit fx) 658 (encode_commitment_tx commit) 659 @?= Just B5.LocalCommitClose 660 661 , testCase "identify_close - no match" $ with_fx $ \fx -> do 662 signed <- need "hex" (unhex vecCCommitSameHash) 663 B5.identify_close (fx_local_commit fx) (fx_remote_commit fx) signed 664 @?= Nothing 665 666 , testCase "identify_close - unparseable" $ with_fx $ \fx -> 667 B5.identify_close (fx_local_commit fx) (fx_remote_commit fx) 668 "unknown bytes" 669 @?= Nothing 670 671 , testCase "classify_local - to_local and to_remote" $ with_fx $ \fx -> 672 map B5.uo_type 673 (B5.classify_local_commit_outputs (fx_local_commit fx) 674 (fx_keys fx) dummyDelay StaticRemotekey) 675 @?= [ B5.SpendToLocal dummyDelay (fx_revpk fx) (fx_delayed fx) 676 , B5.Resolved 677 ] 678 679 , testCase "classify_local - outpoints and values" $ with_fx $ \fx -> do 680 let commit = fx_htlc_commit fx 681 txid = BT.txid (commitment_to_tx commit) 682 outs = B5.classify_local_commit_outputs commit (fx_keys fx) 683 dummyDelay StaticRemotekey 684 map B5.uo_outpoint outs @?= map (OutPoint txid) [0 .. 3] 685 map (BOLT1.un_satoshi . B5.uo_value) outs 686 @?= [50000, 30000, 1000, 1000] 687 688 , testCase "classify_local - HTLC outputs" $ with_fx $ \fx -> 689 map B5.uo_type 690 (drop 2 (B5.classify_local_commit_outputs (fx_htlc_commit fx) 691 (fx_keys fx) dummyDelay StaticRemotekey)) 692 @?= [ B5.SpendHTLCTimeout (fx_offered fx) (fx_keys fx) 693 StaticRemotekey 694 , B5.SpendHTLCSuccess (fx_received fx) (fx_keys fx) 695 StaticRemotekey 696 ] 697 698 , testCase "classify_remote - HTLC outputs" $ with_fx $ \fx -> 699 map B5.uo_type 700 (B5.classify_remote_commit_outputs (fx_htlc_commit fx) 701 (fx_keys fx)) 702 @?= [ B5.Resolved 703 , B5.Resolved 704 , B5.SpendHTLCPreimageDirect (fx_offered fx) 705 , B5.SpendHTLCTimeoutDirect (fx_received fx) 706 ] 707 708 , testCase "classify_revoked - to_local and HTLCs" $ with_fx $ \fx -> 709 map B5.uo_type 710 (B5.classify_revoked_commit_outputs (fx_htlc_commit fx) 711 (fx_revpk fx)) 712 @?= [ B5.Revoke (fx_revpk fx) 713 , B5.Resolved 714 , B5.RevokeHTLC (fx_revpk fx) 715 (B5.HTLCOfferedOutput (CltvExpiry 500000)) 716 , B5.RevokeHTLC (fx_revpk fx) 717 (B5.HTLCReceivedOutput (CltvExpiry 500000)) 718 ] 719 720 , testCase "classify - anchor outputs" $ with_fx $ \fx -> do 721 v330 <- sat 330 722 let keys = fx_keys fx 723 anchor pk = to_p2wsh (anchor_script pk) 724 commit = (fx_local_commit fx) 725 { ctx_outputs = 726 CommitmentOutput v330 (anchor (ck_local_funding keys)) 727 OutputLocalAnchor 728 :| [CommitmentOutput v330 729 (anchor (ck_remote_funding keys)) 730 OutputRemoteAnchor] 731 } 732 map B5.uo_type 733 (B5.classify_local_commit_outputs commit keys dummyDelay Anchors) 734 @?= [B5.AnchorSpend (ck_local_funding keys), B5.Resolved] 735 map B5.uo_type (B5.classify_remote_commit_outputs commit keys) 736 @?= [B5.Resolved, B5.AnchorSpend (ck_remote_funding keys)] 737 map B5.uo_type 738 (B5.classify_revoked_commit_outputs commit (fx_revpk fx)) 739 @?= [B5.Resolved, B5.Resolved] 740 741 , testCase "classify_remote - non-HTLC outputs" $ with_fx $ \fx -> 742 map B5.uo_type 743 (B5.classify_remote_commit_outputs (fx_remote_commit fx) 744 (fx_keys fx)) 745 @?= [B5.Resolved, B5.Resolved] 746 747 , testCase "classify_local - HTLCs sharing a payment hash" $ do 748 -- Appendix C: htlcs #5 and #6 share a payment hash and amount 749 -- (5000 sat) and differ only in CLTV expiry (506 and 505). 750 commit <- vecCommitSameHash 751 keys <- vecKeys 752 h1 <- vecHtlc1 753 h5 <- vecHtlc5 754 h6 <- vecHtlc6 755 let outs = B5.classify_local_commit_outputs commit keys 756 (ToSelfDelay 144) StaticRemotekey 757 map B5.uo_type (take 3 outs) @?= 758 [ B5.SpendHTLCSuccess h1 keys StaticRemotekey 759 , B5.SpendHTLCTimeout h6 keys StaticRemotekey 760 , B5.SpendHTLCTimeout h5 keys StaticRemotekey 761 ] 762 763 , testCase "HTLC txs - Appendix C, shared payment hash" $ do 764 commit <- vecCommitSameHash 765 keys <- vecKeys 766 let outs = B5.classify_local_commit_outputs commit keys 767 (ToSelfDelay 144) StaticRemotekey 768 case outs of 769 o0 : o1 : o2 : _ -> do 770 stx0 <- vecHtlcTx (FeeratePerKw 253) o0 771 assertHtlcTx stx0 vecCHtlcSuccess1 772 stx1 <- vecHtlcTx (FeeratePerKw 253) o1 773 assertHtlcTx stx1 vecCHtlcTimeout6 774 assertSighashFlags stx1 StaticRemotekey vecCHtlcTimeout6 775 stx2 <- vecHtlcTx (FeeratePerKw 253) o2 776 assertHtlcTx stx2 vecCHtlcTimeout5 777 _ -> assertFailure "expected at least 3 outputs" 778 779 , testCase "classify_remote - HTLCs sharing a payment hash" $ do 780 commit <- vecCommitSameHash 781 keys <- vecKeys 782 h1 <- vecHtlc1 783 h5 <- vecHtlc5 784 h6 <- vecHtlc6 785 let outs = B5.classify_remote_commit_outputs commit keys 786 map B5.uo_type (take 3 outs) @?= 787 [ B5.SpendHTLCTimeoutDirect h1 788 , B5.SpendHTLCPreimageDirect h6 789 , B5.SpendHTLCPreimageDirect h5 790 ] 791 792 , testCase "classify_local - HTLCs differing only in amount" $ do 793 hA <- vecHtlc HTLCOffered 5000000 600 0x07 794 hB <- vecHtlc HTLCOffered 9000000 600 0x07 795 commit <- vecCommitment (FeeratePerKw 253) StaticRemotekey 796 6000000000 [hB, hA] 797 keys <- vecKeys 798 let outs = B5.classify_local_commit_outputs commit keys 799 (ToSelfDelay 144) StaticRemotekey 800 [ (BOLT1.un_satoshi (B5.uo_value o), h) 801 | o <- outs 802 , B5.SpendHTLCTimeout h _ _ <- [B5.uo_type o] ] 803 @?= [(5000, hA), (9000, hB)] 804 805 , testCase "classify_local - one resolution per HTLC output" $ do 806 h <- vecHtlc HTLCOffered 5000000 600 0x07 807 keys <- vecKeys 808 let timeouts commit = length 809 [ () 810 | o <- B5.classify_local_commit_outputs commit keys 811 (ToSelfDelay 144) StaticRemotekey 812 , B5.SpendHTLCTimeout {} <- [B5.uo_type o] ] 813 one <- vecCommitment (FeeratePerKw 253) StaticRemotekey 814 6000000000 [h] 815 two <- vecCommitment (FeeratePerKw 253) StaticRemotekey 816 6000000000 [h, h] 817 timeouts one @?= 1 818 timeouts two @?= 2 819 ] 820 821 -- spend tests -------------------------------------------------------- 822 823 spend_tests :: TestTree 824 spend_tests = testGroup "Spend" [ 825 testCase "spend_to_local produces valid tx" $ with_fx $ \fx -> do 826 value <- sat 100000 827 stx <- need "spend_to_local" $ 828 B5.spend_to_local dummyOutPoint value (fx_revpk fx) dummyDelay 829 (fx_delayed fx) dummyDestScript dummyFeerate 830 let tx = B5.stx_tx stx 831 tx_version tx @?= 2 832 length (tx_inputs tx) @?= 1 833 length (tx_outputs tx) @?= 1 834 assertBool "output < input" (out_value stx < 100000) 835 B5.stx_sighash_type stx @?= SIGHASH_ALL 836 B5.stx_input_value stx @?= value 837 B5.stx_input_script stx 838 @?= to_local_script (fx_revpk fx) dummyDelay (fx_delayed fx) 839 -- nSequence encodes the delay 840 in_sequence stx @?= 144 841 842 , testCase "spend_to_local fee deduction" $ with_fx $ \fx -> do 843 value <- sat 100000 844 stx <- need "spend_to_local" $ 845 B5.spend_to_local dummyOutPoint value (fx_revpk fx) dummyDelay 846 (fx_delayed fx) dummyDestScript dummyFeerate 847 let fee = B5.spending_fee dummyFeerate 848 (B5.to_local_penalty_input_weight + B5.penalty_tx_base_weight) 849 out_value stx @?= 100000 - BOLT1.un_satoshi fee 850 851 , testCase "spend_revoked_to_local nSequence" $ with_fx $ \fx -> do 852 value <- sat 100000 853 stx <- need "spend_revoked_to_local" $ 854 B5.spend_revoked_to_local dummyOutPoint value (fx_revpk fx) 855 dummyDelay (fx_delayed fx) dummyDestScript dummyFeerate 856 in_sequence stx @?= 0xFFFFFFFF 857 B5.stx_input_script stx 858 @?= to_local_script (fx_revpk fx) dummyDelay (fx_delayed fx) 859 860 , testCase "spend_anchor_owner tx structure" $ with_fx $ \fx -> do 861 value <- sat 330 862 let stx = B5.spend_anchor_owner dummyOutPoint value 863 (fx_funding fx) dummyDestScript 864 tx = B5.stx_tx stx 865 tx_version tx @?= 2 866 tx_locktime tx @?= 0 867 B5.stx_sighash_type stx @?= SIGHASH_ALL 868 B5.stx_input_script stx @?= anchor_script (fx_funding fx) 869 870 , testCase "spend_anchor_anyone nSequence" $ with_fx $ \fx -> do 871 value <- sat 330 872 let stx = B5.spend_anchor_anyone dummyOutPoint value 873 (fx_funding fx) dummyDestScript 874 in_sequence stx @?= 16 875 876 , testCase "spend_htlc_output is spend_to_local" $ with_fx $ \fx -> do 877 value <- sat 50000 878 let spend f = f dummyOutPoint value (fx_revpk fx) dummyDelay 879 (fx_delayed fx) dummyDestScript dummyFeerate 880 stx1 <- need "spend_to_local" (spend B5.spend_to_local) 881 stx2 <- need "spend_htlc_output" (spend B5.spend_htlc_output) 882 stx1 @?= stx2 883 884 , testCase "spend_to_local fee underflow" $ with_fx $ \fx -> do 885 value <- sat 1 886 B5.spend_to_local dummyOutPoint value (fx_revpk fx) dummyDelay 887 (fx_delayed fx) dummyDestScript dummyFeerate 888 @?= Nothing 889 890 , testCase "spend_to_local dust threshold by script" $ with_fx $ \fx -> do 891 let fee = BOLT1.un_satoshi $ B5.spending_fee dummyFeerate 892 (B5.to_local_penalty_input_weight + B5.penalty_tx_base_weight) 893 sweep dest v = do 894 value <- sat v 895 pure $ B5.spend_to_local dummyOutPoint value (fx_revpk fx) 896 dummyDelay (fx_delayed fx) dest dummyFeerate 897 check (name, dest, dust) = do 898 at <- sweep dest (fee + dust) 899 assertEqual (name <> " at threshold") (Just dust) 900 (fmap out_value at) 901 below <- sweep dest (fee + dust - 1) 902 assertEqual (name <> " below threshold") Nothing below 903 mapM_ check 904 [ ("p2pkh", Script $ BS.pack ([0x76, 0xa9, 0x14] 905 <> replicate 20 0xCC <> [0x88, 0xac]), 546) 906 , ("p2sh", Script $ BS.pack ([0xa9, 0x14] 907 <> replicate 20 0xCC <> [0x87]), 540) 908 , ("p2wpkh", dummyDestScript, 294) 909 , ("p2wsh", Script $ BS.pack ([0x00, 0x20] 910 <> replicate 32 0xCC), 330) 911 , ("p2tr", Script $ BS.pack ([0x51, 0x20] 912 <> replicate 32 0xCC), 330) 913 ] 914 ] 915 916 -- htlc spend tests --------------------------------------------------- 917 918 htlc_spend_tests :: TestTree 919 htlc_spend_tests = testGroup "HTLC Spend" [ 920 testCase "spend_htlc_tx - HTLC-timeout" $ with_fx $ \fx -> do 921 stx <- need "spend_htlc_tx" $ B5.spend_htlc_tx 922 (htlc_context fx (fx_offered fx) StaticRemotekey) (fx_keys fx) 923 let tx = B5.stx_tx stx 924 tx_version tx @?= 2 925 length (tx_inputs tx) @?= 1 926 length (tx_outputs tx) @?= 1 927 tx_locktime tx @?= 500000 928 in_sequence stx @?= 0 929 B5.stx_sighash_type stx @?= SIGHASH_ALL 930 B5.stx_input_value stx 931 @?= BOLT1.msat_to_sat (htlc_amount_msat (fx_offered fx)) 932 B5.stx_input_script stx @?= 933 htlc_witness_script (fx_keys fx) StaticRemotekey (fx_offered fx) 934 935 , testCase "spend_htlc_tx - HTLC-success" $ with_fx $ \fx -> do 936 stx <- need "spend_htlc_tx" $ B5.spend_htlc_tx 937 (htlc_context fx (fx_received fx) StaticRemotekey) (fx_keys fx) 938 let tx = B5.stx_tx stx 939 tx_version tx @?= 2 940 length (tx_inputs tx) @?= 1 941 tx_locktime tx @?= 0 942 B5.stx_sighash_type stx @?= SIGHASH_ALL 943 B5.stx_input_script stx @?= 944 htlc_witness_script (fx_keys fx) StaticRemotekey (fx_received fx) 945 946 , testCase "spend_htlc_tx - HTLC-timeout anchors sighash" $ with_fx $ 947 \fx -> do 948 stx <- need "spend_htlc_tx" $ B5.spend_htlc_tx 949 (htlc_context fx (fx_offered fx) Anchors) (fx_keys fx) 950 B5.stx_sighash_type stx @?= SIGHASH_ALL 951 in_sequence stx @?= 1 952 953 , testCase "spend_htlc_tx - HTLC-success anchors sighash" $ with_fx $ 954 \fx -> do 955 stx <- need "spend_htlc_tx" $ B5.spend_htlc_tx 956 (htlc_context fx (fx_received fx) Anchors) (fx_keys fx) 957 B5.stx_sighash_type stx @?= SIGHASH_ALL 958 959 , testCase "spend_htlc_tx - fee exceeds amount" $ with_fx $ \fx -> do 960 -- 5000 * 663 / 1000 = 3315 sat, more than the 1000 sat HTLC 961 let ctx = (htlc_context fx (fx_offered fx) StaticRemotekey) 962 { hc_feerate = FeeratePerKw 5000 } 963 B5.spend_htlc_tx ctx (fx_keys fx) @?= Nothing 964 965 , testCase "HTLC txs - Appendix F (anchors)" $ do 966 -- The local signature uses SIGHASH_ALL and the remote one 967 -- SIGHASH_SINGLE|SIGHASH_ANYONECANPAY. 968 commit <- vecCommitAnchors 969 keys <- vecKeys 970 let outs = B5.classify_local_commit_outputs commit keys 971 (ToSelfDelay 144) Anchors 972 check uo vec = do 973 stx <- vecHtlcTx (FeeratePerKw 644) uo 974 assertHtlcTx stx vec 975 B5.stx_sighash_type stx @?= SIGHASH_ALL 976 assertSighashFlags stx Anchors vec 977 case drop 3 outs of 978 o3 : o4 : _ -> do 979 check o3 vecFHtlcTimeout2 980 check o4 vecFHtlcSuccess1 981 _ -> assertFailure "expected at least 5 outputs" 982 ] 983 984 -- remote spend tests ------------------------------------------------- 985 986 remote_spend_tests :: TestTree 987 remote_spend_tests = testGroup "Remote Spend" [ 988 testCase "spend_remote_htlc_timeout structure" $ with_fx $ \fx -> do 989 value <- sat 50000 990 stx <- need "spend_remote_htlc_timeout" $ 991 B5.spend_remote_htlc_timeout dummyOutPoint value (fx_offered fx) 992 (fx_keys fx) StaticRemotekey dummyDestScript dummyFeerate 993 let tx = B5.stx_tx stx 994 tx_version tx @?= 2 995 length (tx_inputs tx) @?= 1 996 B5.stx_sighash_type stx @?= SIGHASH_ALL 997 B5.stx_input_value stx @?= value 998 B5.stx_input_script stx @?= 999 htlc_witness_script (fx_keys fx) StaticRemotekey (fx_received fx) 1000 -- locktime is the HTLC's CLTV expiry 1001 tx_locktime tx @?= 500000 1002 1003 , testCase "spend_remote_htlc_timeout fee deduction" $ with_fx $ 1004 \fx -> do 1005 value <- sat 50000 1006 stx <- need "spend_remote_htlc_timeout" $ 1007 B5.spend_remote_htlc_timeout dummyOutPoint value 1008 (fx_offered fx) (fx_keys fx) StaticRemotekey 1009 dummyDestScript dummyFeerate 1010 let fee = B5.spending_fee dummyFeerate 1011 (B5.accepted_htlc_penalty_input_weight 1012 + B5.penalty_tx_base_weight) 1013 out_value stx @?= 50000 - BOLT1.un_satoshi fee 1014 1015 , testCase "spend_remote_htlc_preimage structure" $ with_fx $ \fx -> do 1016 value <- sat 50000 1017 stx <- need "spend_remote_htlc_preimage" $ 1018 B5.spend_remote_htlc_preimage dummyOutPoint value 1019 (fx_received fx) (fx_keys fx) StaticRemotekey 1020 dummyDestScript dummyFeerate 1021 let tx = B5.stx_tx stx 1022 tx_version tx @?= 2 1023 B5.stx_sighash_type stx @?= SIGHASH_ALL 1024 B5.stx_input_script stx @?= 1025 htlc_witness_script (fx_keys fx) StaticRemotekey (fx_offered fx) 1026 -- locktime is 0 for preimage claims 1027 tx_locktime tx @?= 0 1028 1029 , testCase "spend_remote_htlc_timeout anchors seq" $ with_fx $ \fx -> do 1030 value <- sat 50000 1031 stx <- need "spend_remote_htlc_timeout" $ 1032 B5.spend_remote_htlc_timeout dummyOutPoint value (fx_offered fx) 1033 (fx_keys fx) Anchors dummyDestScript dummyFeerate 1034 in_sequence stx @?= 1 1035 1036 , testCase "spend_remote_htlc_timeout no-anchor seq" $ with_fx $ 1037 \fx -> do 1038 value <- sat 50000 1039 stx <- need "spend_remote_htlc_timeout" $ 1040 B5.spend_remote_htlc_timeout dummyOutPoint value 1041 (fx_offered fx) (fx_keys fx) StaticRemotekey 1042 dummyDestScript dummyFeerate 1043 in_sequence stx @?= 0 1044 1045 , testCase "spend_remote_htlc_preimage nSequence" $ with_fx $ \fx -> do 1046 value <- sat 50000 1047 stx <- need "spend_remote_htlc_preimage" $ 1048 B5.spend_remote_htlc_preimage dummyOutPoint value 1049 (fx_received fx) (fx_keys fx) StaticRemotekey 1050 dummyDestScript dummyFeerate 1051 in_sequence stx @?= 0 1052 ] 1053 1054 -- revoked htlc spend tests ------------------------------------------ 1055 1056 revoked_htlc_spend_tests :: TestTree 1057 revoked_htlc_spend_tests = testGroup "Revoked HTLC Spend" [ 1058 testCase "spend_revoked_htlc - offered" $ with_fx $ \fx -> do 1059 value <- sat 50000 1060 stx <- need "spend_revoked_htlc" $ 1061 B5.spend_revoked_htlc dummyOutPoint value 1062 (B5.HTLCOfferedOutput (CltvExpiry 500000)) (fx_revpk fx) 1063 (fx_keys fx) StaticRemotekey (fx_hash fx) dummyDestScript 1064 dummyFeerate 1065 tx_version (B5.stx_tx stx) @?= 2 1066 B5.stx_sighash_type stx @?= SIGHASH_ALL 1067 in_sequence stx @?= 0xFFFFFFFF 1068 B5.stx_input_script stx @?= 1069 htlc_witness_script (fx_keys fx) StaticRemotekey (fx_offered fx) 1070 1071 , testCase "spend_revoked_htlc - received" $ with_fx $ \fx -> do 1072 value <- sat 50000 1073 stx <- need "spend_revoked_htlc" $ 1074 B5.spend_revoked_htlc dummyOutPoint value 1075 (B5.HTLCReceivedOutput (CltvExpiry 500000)) (fx_revpk fx) 1076 (fx_keys fx) StaticRemotekey (fx_hash fx) dummyDestScript 1077 dummyFeerate 1078 B5.stx_sighash_type stx @?= SIGHASH_ALL 1079 assertBool "output < input" (out_value stx < 50000) 1080 B5.stx_input_script stx @?= 1081 htlc_witness_script (fx_keys fx) StaticRemotekey (fx_received fx) 1082 1083 , testCase "htlc_output_type - HTLC outputs" $ with_fx $ \fx -> do 1084 B5.htlc_output_type (OutputHTLC (fx_offered fx)) 1085 @?= Just (B5.HTLCOfferedOutput (CltvExpiry 500000)) 1086 B5.htlc_output_type (OutputHTLC (fx_received fx)) 1087 @?= Just (B5.HTLCReceivedOutput (CltvExpiry 500000)) 1088 1089 , testCase "htlc_output_type - non-HTLC outputs" $ do 1090 B5.htlc_output_type OutputToLocal @?= Nothing 1091 B5.htlc_output_type OutputToRemote @?= Nothing 1092 B5.htlc_output_type OutputLocalAnchor @?= Nothing 1093 B5.htlc_output_type OutputRemoteAnchor @?= Nothing 1094 1095 , testCase "spend_revoked_htlc_output structure" $ with_fx $ \fx -> do 1096 value <- sat 50000 1097 stx <- need "spend_revoked_htlc_output" $ 1098 B5.spend_revoked_htlc_output dummyOutPoint value (fx_revpk fx) 1099 dummyDelay (fx_delayed fx) dummyDestScript dummyFeerate 1100 tx_version (B5.stx_tx stx) @?= 2 1101 B5.stx_sighash_type stx @?= SIGHASH_ALL 1102 in_sequence stx @?= 0xFFFFFFFF 1103 ] 1104 1105 -- weight tests ------------------------------------------------------- 1106 1107 weight_tests :: TestTree 1108 weight_tests = testGroup "Weight" [ 1109 testCase "penalty input = base + witness" $ do 1110 -- to_local: 164 (txinput) + 160 (witness) = 324 1111 B5.to_local_penalty_input_weight @?= 1112 (164 + B5.to_local_penalty_witness_weight) 1113 -- offered: 164 + 243 = 407 1114 B5.offered_htlc_penalty_input_weight @?= 1115 (164 + B5.offered_htlc_penalty_witness_weight) 1116 -- accepted: 164 + 249 = 413 1117 B5.accepted_htlc_penalty_input_weight @?= 1118 (164 + B5.accepted_htlc_penalty_witness_weight) 1119 -- with anchors: 164 + 246 = 410, 164 + 252 = 416 1120 B5.offered_htlc_penalty_input_weight_anchors @?= 1121 (164 + B5.offered_htlc_penalty_witness_weight_anchors) 1122 B5.accepted_htlc_penalty_input_weight_anchors @?= 1123 (164 + B5.accepted_htlc_penalty_witness_weight_anchors) 1124 1125 , testCase "penalty witness weights match HTLC scripts" $ with_fx $ 1126 \fx -> do 1127 -- 1 (item count) + 1 + 73 (signature) + 1 + 33 1128 -- (revocationpubkey) + 1 + script, for a 3-byte CLTV expiry 1129 let witnessWeight fmt h = 1130 let Script s = htlc_witness_script (fx_keys fx) fmt h 1131 in fromIntegral (110 + BS.length s) 1132 witnessWeight StaticRemotekey (fx_offered fx) 1133 @?= B5.offered_htlc_penalty_witness_weight 1134 witnessWeight StaticRemotekey (fx_received fx) 1135 @?= B5.accepted_htlc_penalty_witness_weight 1136 witnessWeight Anchors (fx_offered fx) 1137 @?= B5.offered_htlc_penalty_witness_weight_anchors 1138 witnessWeight Anchors (fx_received fx) 1139 @?= B5.accepted_htlc_penalty_witness_weight_anchors 1140 1141 , testCase "spend_revoked_htlc weight by commitment format" $ with_fx $ 1142 \fx -> do 1143 value <- sat 50000 1144 let outValue fmt htype = fmap out_value 1145 (B5.spend_revoked_htlc dummyOutPoint value htype 1146 (fx_revpk fx) (fx_keys fx) fmt (fx_hash fx) 1147 dummyDestScript dummyFeerate) 1148 expected inputWeight = Just $ 50000 - BOLT1.un_satoshi 1149 (B5.spending_fee dummyFeerate 1150 (inputWeight + B5.penalty_tx_base_weight)) 1151 offered = B5.HTLCOfferedOutput (CltvExpiry 500000) 1152 received = B5.HTLCReceivedOutput (CltvExpiry 500000) 1153 outValue StaticRemotekey offered 1154 @?= expected B5.offered_htlc_penalty_input_weight 1155 outValue StaticRemotekey received 1156 @?= expected B5.accepted_htlc_penalty_input_weight 1157 outValue Anchors offered 1158 @?= expected B5.offered_htlc_penalty_input_weight_anchors 1159 outValue Anchors received 1160 @?= expected B5.accepted_htlc_penalty_input_weight_anchors 1161 1162 , testCase "max HTLCs in single penalty tx" $ 1163 -- Per spec: (400000 - 324 - 272 - (4 * 53) - 2) / 413 = 966, 1164 -- where penalty_tx_base_weight = 4 * 53 + 2. 1165 (B5.max_standard_weight 1166 - B5.to_local_penalty_input_weight 1167 - B5.to_remote_input_weight 1168 - B5.penalty_tx_base_weight) 1169 `div` B5.accepted_htlc_penalty_input_weight 1170 @?= 966 1171 ] 1172 1173 -- property tests ----------------------------------------------------- 1174 1175 property_tests :: TestTree 1176 property_tests = testGroup "Properties" [ 1177 testProperty "output + fee = input (spend_to_local)" $ prop_fx $ 1178 \fx -> forAll (choose (100000, 2100000000000000)) $ \v -> 1179 let fee = B5.spending_fee dummyFeerate 1180 (B5.to_local_penalty_input_weight + B5.penalty_tx_base_weight) 1181 spent = do 1182 value <- BOLT1.satoshi v 1183 B5.spend_to_local dummyOutPoint value (fx_revpk fx) 1184 dummyDelay (fx_delayed fx) dummyDestScript dummyFeerate 1185 in fmap (\stx -> out_value stx + BOLT1.un_satoshi fee) spent 1186 === Just v 1187 1188 , testProperty "sweeps never create dust outputs" $ prop_fx $ \fx -> 1189 forAll (choose (0, 3000)) $ \v -> 1190 let sweeps value = 1191 [ B5.spend_to_local dummyOutPoint value (fx_revpk fx) 1192 dummyDelay (fx_delayed fx) dummyDestScript dummyFeerate 1193 , B5.spend_remote_htlc_timeout dummyOutPoint value 1194 (fx_offered fx) (fx_keys fx) StaticRemotekey 1195 dummyDestScript dummyFeerate 1196 , B5.spend_remote_htlc_preimage dummyOutPoint value 1197 (fx_received fx) (fx_keys fx) StaticRemotekey 1198 dummyDestScript dummyFeerate 1199 , B5.spend_revoked_to_local dummyOutPoint value 1200 (fx_revpk fx) dummyDelay (fx_delayed fx) 1201 dummyDestScript dummyFeerate 1202 , B5.spend_revoked_htlc dummyOutPoint value 1203 (B5.HTLCOfferedOutput (CltvExpiry 500000)) 1204 (fx_revpk fx) (fx_keys fx) StaticRemotekey 1205 (fx_hash fx) dummyDestScript dummyFeerate 1206 , B5.spend_revoked_htlc dummyOutPoint value 1207 (B5.HTLCReceivedOutput (CltvExpiry 500000)) 1208 (fx_revpk fx) (fx_keys fx) StaticRemotekey 1209 (fx_hash fx) dummyDestScript dummyFeerate 1210 , B5.spend_revoked_htlc_output dummyOutPoint value 1211 (fx_revpk fx) dummyDelay (fx_delayed fx) 1212 dummyDestScript dummyFeerate 1213 ] 1214 notDust = maybe True (\stx -> out_value stx >= 294) 1215 in case BOLT1.satoshi v of 1216 Nothing -> counterexample "invalid amount" False 1217 Just value -> property (all notDust (sweeps value)) 1218 1219 , testProperty "htlc_timed_out monotonic" $ prop_fx $ 1220 \fx (NonNegative h1) (NonNegative h2) -> 1221 let htlc = (fx_offered fx) { htlc_cltv_expiry = CltvExpiry 1000 } 1222 lo = min h1 h2 1223 hi = max h1 h2 1224 in not (B5.htlc_timed_out lo htlc) || B5.htlc_timed_out hi htlc 1225 1226 , testProperty "fee monotonic in feerate" $ 1227 \r1 r2 -> 1228 let w = B5.to_local_penalty_input_weight + B5.penalty_tx_base_weight 1229 fee r = B5.spending_fee (FeeratePerKw r) w 1230 in fee (min r1 r2) <= fee (max r1 r2) 1231 1232 , testProperty "spend_to_local always version 2" $ prop_fx $ 1233 \fx -> forAll (choose (100000, 2100000000000000)) $ \v -> 1234 let spent = do 1235 value <- BOLT1.satoshi v 1236 B5.spend_to_local dummyOutPoint value (fx_revpk fx) 1237 dummyDelay (fx_delayed fx) dummyDestScript dummyFeerate 1238 in fmap (tx_version . B5.stx_tx) spent === Just 2 1239 1240 , testProperty "revoked nSequence is 0xFFFFFFFF" $ prop_fx $ 1241 \fx -> forAll (choose (100000, 2100000000000000)) $ \v -> 1242 let spent = do 1243 value <- BOLT1.satoshi v 1244 B5.spend_revoked_to_local dummyOutPoint value (fx_revpk fx) 1245 dummyDelay (fx_delayed fx) dummyDestScript dummyFeerate 1246 in fmap in_sequence spent === Just 0xFFFFFFFF 1247 1248 , testProperty "htlc_output_type preserves direction and expiry" $ 1249 prop_fx $ \fx expiry -> 1250 let ce = CltvExpiry expiry 1251 at h = OutputHTLC h { htlc_cltv_expiry = ce } 1252 in B5.htlc_output_type (at (fx_offered fx)) 1253 == Just (B5.HTLCOfferedOutput ce) 1254 && B5.htlc_output_type (at (fx_received fx)) 1255 == Just (B5.HTLCReceivedOutput ce) 1256 1257 , testProperty "revoked_output_weight by type" $ 1258 \expiry -> 1259 let ce = CltvExpiry expiry 1260 ro t = case BOLT1.satoshi 1000 of 1261 Nothing -> Nothing 1262 Just v -> Just (B5.RevokedOutput dummyOutPoint v t) 1263 weight fmt t = fmap (B5.revoked_output_weight fmt) (ro t) 1264 offered = B5.RevokedHTLC (B5.HTLCOfferedOutput ce) 1265 received = B5.RevokedHTLC (B5.HTLCReceivedOutput ce) 1266 in weight StaticRemotekey B5.RevokedToLocal 1267 == Just B5.to_local_penalty_input_weight 1268 && weight StaticRemotekey offered 1269 == Just B5.offered_htlc_penalty_input_weight 1270 && weight StaticRemotekey received 1271 == Just B5.accepted_htlc_penalty_input_weight 1272 && weight Anchors B5.RevokedToLocal 1273 == Just B5.to_local_penalty_input_weight 1274 && weight Anchors offered 1275 == Just B5.offered_htlc_penalty_input_weight_anchors 1276 && weight Anchors received 1277 == Just B5.accepted_htlc_penalty_input_weight_anchors 1278 ]