Main.hs (13588B)
1 {-# LANGUAGE OverloadedStrings #-} 2 3 module Main where 4 5 import qualified Data.ByteString as BS 6 import qualified Data.ByteString.Base16 as B16 7 import Data.Maybe (isJust, isNothing) 8 import Test.Tasty 9 import Test.Tasty.HUnit 10 import Lightning.Protocol.BOLT3 11 12 main :: IO () 13 main = defaultMain $ testGroup "ppad-bolt3" [ 14 testGroup "Key derivation" [ 15 keyDerivationTests 16 ] 17 , testGroup "Secret generation" [ 18 secretGenerationTests 19 ] 20 , testGroup "Secret storage" [ 21 secretStorageTests 22 ] 23 , testGroup "Fee calculation" [ 24 feeCalculationTests 25 ] 26 , testGroup "Trimming" [ 27 trimmingTests 28 ] 29 , testGroup "Smart constructors" [ 30 smartConstructorTests 31 ] 32 ] 33 34 -- hex decoding helper 35 hex :: BS.ByteString -> BS.ByteString 36 hex h = case B16.decode h of 37 Right bs -> bs 38 Left _ -> error "invalid hex" 39 40 -- Key derivation test vectors from Appendix E --------------------------------- 41 42 keyDerivationTests :: TestTree 43 keyDerivationTests = testGroup "BOLT #3 Appendix E" [ 44 testCase "derive_pubkey" $ do 45 let basepoint = Point $ hex 46 "036d6caac248af96f6afa7f904f550253a0f3ef3f5aa2fe6838a95b216691468e2" 47 perCommitmentPoint = PerCommitmentPoint $ Point $ hex 48 "025f7117a78150fe2ef97db7cfc83bd57b2e2c0d0dd25eaf467a4a1c2a45ce1486" 49 expected = hex 50 "0235f2dbfaa89b57ec7b055afe29849ef7ddfeb1cefdb9ebdc43f5494984db29e5" 51 case derive_pubkey basepoint perCommitmentPoint of 52 Nothing -> assertFailure "derive_pubkey returned Nothing" 53 Just (Pubkey pk) -> pk @?= expected 54 55 , testCase "derive_revocationpubkey" $ do 56 let revocationBasepoint = RevocationBasepoint $ Point $ hex 57 "036d6caac248af96f6afa7f904f550253a0f3ef3f5aa2fe6838a95b216691468e2" 58 perCommitmentPoint = PerCommitmentPoint $ Point $ hex 59 "025f7117a78150fe2ef97db7cfc83bd57b2e2c0d0dd25eaf467a4a1c2a45ce1486" 60 expected = hex 61 "02916e326636d19c33f13e8c0c3a03dd157f332f3e99c317c141dd865eb01f8ff0" 62 case derive_revocationpubkey revocationBasepoint perCommitmentPoint of 63 Nothing -> assertFailure "derive_revocationpubkey returned Nothing" 64 Just (RevocationPubkey (Pubkey pk)) -> pk @?= expected 65 ] 66 67 -- Secret generation test vectors from Appendix D ------------------------------ 68 69 secretGenerationTests :: TestTree 70 secretGenerationTests = testGroup "BOLT #3 Appendix D - Generation" [ 71 testCase "generate_from_seed 0 final node" $ do 72 let seed = hex 73 "0000000000000000000000000000000000000000000000000000000000000000" 74 i = 281474976710655 75 expected = hex 76 "02a40c85b6f28da08dfdbe0926c53fab2de6d28c10301f8f7c4073d5e42e3148" 77 generate_from_seed seed i @?= expected 78 79 , testCase "generate_from_seed FF final node" $ do 80 let seed = hex 81 "FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF" 82 i = 281474976710655 83 expected = hex 84 "7cc854b54e3e0dcdb010d7a3fee464a9687be6e8db3be6854c475621e007a5dc" 85 generate_from_seed seed i @?= expected 86 87 , testCase "generate_from_seed FF alternate bits 1" $ do 88 let seed = hex 89 "FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF" 90 i = 0xaaaaaaaaaaa 91 expected = hex 92 "56f4008fb007ca9acf0e15b054d5c9fd12ee06cea347914ddbaed70d1c13a528" 93 generate_from_seed seed i @?= expected 94 95 , testCase "generate_from_seed FF alternate bits 2" $ do 96 let seed = hex 97 "FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF" 98 i = 0x555555555555 99 expected = hex 100 "9015daaeb06dba4ccc05b91b2f73bd54405f2be9f217fbacd3c5ac2e62327d31" 101 generate_from_seed seed i @?= expected 102 103 , testCase "generate_from_seed 01 last nontrivial node" $ do 104 let seed = hex 105 "0101010101010101010101010101010101010101010101010101010101010101" 106 i = 1 107 expected = hex 108 "915c75942a26bb3a433a8ce2cb0427c29ec6c1775cfc78328b57f6ba7bfeaa9c" 109 generate_from_seed seed i @?= expected 110 ] 111 112 -- Secret storage test vectors from Appendix D --------------------------------- 113 114 secretStorageTests :: TestTree 115 secretStorageTests = testGroup "BOLT #3 Appendix D - Storage" [ 116 testCase "insert_secret correct sequence" $ do 117 let secrets = [ 118 (281474976710655, hex 119 "7cc854b54e3e0dcdb010d7a3fee464a9687be6e8db3be6854c475621e007a5dc") 120 , (281474976710654, hex 121 "c7518c8ae4660ed02894df8976fa1a3659c1a8b4b5bec0c4b872abeba4cb8964") 122 , (281474976710653, hex 123 "2273e227a5b7449b6e70f1fb4652864038b1cbf9cd7c043a7d6456b7fc275ad8") 124 , (281474976710652, hex 125 "27cddaa5624534cb6cb9d7da077cf2b22ab21e9b506fd4998a51d54502e99116") 126 , (281474976710651, hex 127 "c65716add7aa98ba7acb236352d665cab17345fe45b55fb879ff80e6bd0c41dd") 128 , (281474976710650, hex 129 "969660042a28f32d9be17344e09374b379962d03db1574df5a8a5a47e19ce3f2") 130 , (281474976710649, hex 131 "a5a64476122ca0925fb344bdc1854c1c0a59fc614298e50a33e331980a220f32") 132 , (281474976710648, hex 133 "05cde6323d949933f7f7b78776bcc1ea6d9b31447732e3802e1f7ac44b650e17") 134 ] 135 let insertAll store [] = Just store 136 insertAll store ((idx, secret):rest) = 137 case insert_secret secret idx store of 138 Nothing -> Nothing 139 Just store' -> insertAll store' rest 140 case insertAll empty_store secrets of 141 Nothing -> assertFailure "insert_secret failed on correct sequence" 142 Just _ -> return () 143 144 , testCase "insert_secret #1 incorrect" $ do 145 -- First secret is from wrong seed, second should fail 146 let store0 = empty_store 147 case insert_secret (hex 148 "02a40c85b6f28da08dfdbe0926c53fab2de6d28c10301f8f7c4073d5e42e3148") 149 281474976710655 store0 of 150 Nothing -> assertFailure "First insert should succeed" 151 Just store1 -> 152 case insert_secret (hex 153 "c7518c8ae4660ed02894df8976fa1a3659c1a8b4b5bec0c4b872abeba4cb8964") 154 281474976710654 store1 of 155 Nothing -> return () -- Expected to fail 156 Just _ -> assertFailure "Second insert should fail" 157 ] 158 159 -- Fee calculation tests ------------------------------------------------------- 160 161 feeCalculationTests :: TestTree 162 feeCalculationTests = testGroup "Fee calculation" [ 163 testCase "commitment_fee no anchors, 0 htlcs" $ do 164 let feerate = FeeratePerKw 5000 165 features = ChannelFeatures { cf_option_anchors = False } 166 fee = commitment_fee feerate features 0 167 fee @?= Satoshi 3620 -- 5000 * 724 / 1000 = 3620 168 169 , testCase "commitment_fee no anchors, 2 htlcs" $ do 170 let feerate = FeeratePerKw 5000 171 features = ChannelFeatures { cf_option_anchors = False } 172 fee = commitment_fee feerate features 2 173 -- weight = 724 + 172*2 = 1068 174 -- fee = 5000 * 1068 / 1000 = 5340 175 fee @?= Satoshi 5340 176 177 , testCase "commitment_fee with anchors, 0 htlcs" $ do 178 let feerate = FeeratePerKw 5000 179 features = ChannelFeatures { cf_option_anchors = True } 180 fee = commitment_fee feerate features 0 181 -- 5000 * 1124 / 1000 = 5620 182 fee @?= Satoshi 5620 183 184 , testCase "htlc_timeout_fee no anchors" $ do 185 let feerate = FeeratePerKw 5000 186 features = ChannelFeatures { cf_option_anchors = False } 187 fee = htlc_timeout_fee feerate features 188 -- 5000 * 663 / 1000 = 3315 189 fee @?= Satoshi 3315 190 191 , testCase "htlc_success_fee no anchors" $ do 192 let feerate = FeeratePerKw 5000 193 features = ChannelFeatures { cf_option_anchors = False } 194 fee = htlc_success_fee feerate features 195 -- 5000 * 703 / 1000 = 3515 196 fee @?= Satoshi 3515 197 198 , testCase "htlc_timeout_fee with anchors is 0" $ do 199 let feerate = FeeratePerKw 5000 200 features = ChannelFeatures { cf_option_anchors = True } 201 fee = htlc_timeout_fee feerate features 202 fee @?= Satoshi 0 203 204 , testCase "htlc_success_fee with anchors is 0" $ do 205 let feerate = FeeratePerKw 5000 206 features = ChannelFeatures { cf_option_anchors = True } 207 fee = htlc_success_fee feerate features 208 fee @?= Satoshi 0 209 ] 210 211 -- Trimming tests -------------------------------------------------------------- 212 213 trimmingTests :: TestTree 214 trimmingTests = testGroup "HTLC trimming" [ 215 testCase "offered HTLC above threshold not trimmed" $ do 216 let dust = DustLimit (Satoshi 546) 217 feerate = FeeratePerKw 5000 218 features = ChannelFeatures { cf_option_anchors = False } 219 htlc = HTLC 220 { htlc_direction = HTLCOffered 221 , htlc_amount_msat = MilliSatoshi 5000000 -- 5000 sats 222 , htlc_payment_hash = PaymentHash (BS.replicate 32 0) 223 , htlc_cltv_expiry = CltvExpiry 500000 224 } 225 -- threshold = 546 + 3315 = 3861 226 -- 5000 > 3861, so not trimmed 227 is_trimmed dust feerate features htlc @?= False 228 229 , testCase "offered HTLC below threshold is trimmed" $ do 230 let dust = DustLimit (Satoshi 546) 231 feerate = FeeratePerKw 5000 232 features = ChannelFeatures { cf_option_anchors = False } 233 htlc = HTLC 234 { htlc_direction = HTLCOffered 235 , htlc_amount_msat = MilliSatoshi 1000000 -- 1000 sats 236 , htlc_payment_hash = PaymentHash (BS.replicate 32 0) 237 , htlc_cltv_expiry = CltvExpiry 500000 238 } 239 -- threshold = 546 + 3315 = 3861 240 -- 1000 < 3861, so trimmed 241 is_trimmed dust feerate features htlc @?= True 242 243 , testCase "received HTLC above threshold not trimmed" $ do 244 let dust = DustLimit (Satoshi 546) 245 feerate = FeeratePerKw 5000 246 features = ChannelFeatures { cf_option_anchors = False } 247 htlc = HTLC 248 { htlc_direction = HTLCReceived 249 , htlc_amount_msat = MilliSatoshi 7000000 -- 7000 sats 250 , htlc_payment_hash = PaymentHash (BS.replicate 32 0) 251 , htlc_cltv_expiry = CltvExpiry 500000 252 } 253 -- threshold = 546 + 3515 = 4061 254 -- 7000 > 4061, so not trimmed 255 is_trimmed dust feerate features htlc @?= False 256 257 , testCase "received HTLC below threshold is trimmed" $ do 258 let dust = DustLimit (Satoshi 546) 259 feerate = FeeratePerKw 5000 260 features = ChannelFeatures { cf_option_anchors = False } 261 htlc = HTLC 262 { htlc_direction = HTLCReceived 263 , htlc_amount_msat = MilliSatoshi 800000 -- 800 sats 264 , htlc_payment_hash = PaymentHash (BS.replicate 32 0) 265 , htlc_cltv_expiry = CltvExpiry 500000 266 } 267 -- threshold = 546 + 3515 = 4061 268 -- 800 < 4061, so trimmed 269 is_trimmed dust feerate features htlc @?= True 270 ] 271 272 -- Smart constructor tests ----------------------------------------------------- 273 274 smartConstructorTests :: TestTree 275 smartConstructorTests = testGroup "validation" [ 276 -- 33-byte types 277 testCase "pubkey accepts 33 bytes" $ do 278 let bs = BS.replicate 33 0x02 279 isJust (pubkey bs) @?= True 280 , testCase "pubkey rejects 32 bytes" $ do 281 let bs = BS.replicate 32 0x02 282 isNothing (pubkey bs) @?= True 283 , testCase "pubkey rejects 34 bytes" $ do 284 let bs = BS.replicate 34 0x02 285 isNothing (pubkey bs) @?= True 286 , testCase "point accepts 33 bytes" $ do 287 let bs = BS.replicate 33 0x03 288 isJust (point bs) @?= True 289 , testCase "point rejects 32 bytes" $ do 290 let bs = BS.replicate 32 0x03 291 isNothing (point bs) @?= True 292 293 -- 32-byte types 294 , testCase "seckey accepts 32 bytes" $ do 295 let bs = BS.replicate 32 0x01 296 isJust (seckey bs) @?= True 297 , testCase "seckey rejects 31 bytes" $ do 298 let bs = BS.replicate 31 0x01 299 isNothing (seckey bs) @?= True 300 , testCase "seckey rejects 33 bytes" $ do 301 let bs = BS.replicate 33 0x01 302 isNothing (seckey bs) @?= True 303 , testCase "mkTxId accepts 32 bytes" $ do 304 let bs = BS.replicate 32 0x00 305 isJust (mkTxId bs) @?= True 306 , testCase "mkTxId rejects 31 bytes" $ do 307 let bs = BS.replicate 31 0x00 308 isNothing (mkTxId bs) @?= True 309 , testCase "payment_hash accepts 32 bytes" $ do 310 let bs = BS.replicate 32 0xab 311 isJust (payment_hash bs) @?= True 312 , testCase "payment_hash rejects 33 bytes" $ do 313 let bs = BS.replicate 33 0xab 314 isNothing (payment_hash bs) @?= True 315 , testCase "payment_preimage accepts 32 bytes" $ do 316 let bs = BS.replicate 32 0xcd 317 isJust (payment_preimage bs) @?= True 318 , testCase "payment_preimage rejects 31 bytes" $ do 319 let bs = BS.replicate 31 0xcd 320 isNothing (payment_preimage bs) @?= True 321 , testCase "per_commitment_secret accepts 32 bytes" $ do 322 let bs = BS.replicate 32 0xef 323 isJust (per_commitment_secret bs) @?= True 324 , testCase "per_commitment_secret rejects 33 bytes" $ do 325 let bs = BS.replicate 33 0xef 326 isNothing (per_commitment_secret bs) @?= True 327 328 -- 48-bit commitment number 329 , testCase "commitment_number accepts 0" $ do 330 isJust (commitment_number 0) @?= True 331 , testCase "commitment_number accepts 2^48-1" $ do 332 isJust (commitment_number 281474976710655) @?= True 333 , testCase "commitment_number rejects 2^48" $ do 334 isNothing (commitment_number 281474976710656) @?= True 335 , testCase "commitment_number rejects maxBound Word64" $ do 336 isNothing (commitment_number maxBound) @?= True 337 ]