├── .gitignore ├── .gitmodules ├── .ocamlformat ├── CHANGES ├── LICENSE ├── LICENSE.md ├── README.md ├── bin ├── dune └── node.ml ├── bitcoin-node.opam ├── bitcoin.opam ├── cstruct ├── bitcoin_cstruct.ml └── dune ├── dune-project ├── lib ├── block.ml ├── block.mli ├── bloom.ml ├── bloom.mli ├── dune ├── header.ml ├── header.mli ├── merkle.ml ├── merkle.mli ├── outpoint.ml ├── outpoint.mli ├── p2p.ml ├── p2p.mli ├── script.ml ├── script.mli ├── transaction.ml ├── transaction.mli ├── txin.ml ├── txin.mli ├── txout.ml ├── txout.mli ├── util.ml ├── util.mli ├── wallet.ml └── wallet.mli └── test ├── dune └── test.ml /.gitignore: -------------------------------------------------------------------------------- 1 | _build 2 | **/.merlin 3 | *.install -------------------------------------------------------------------------------- /.gitmodules: -------------------------------------------------------------------------------- 1 | [submodule "vendors/ocaml-base58"] 2 | path = vendors/ocaml-base58 3 | url = git@github.com:vbmithr/ocaml-base58 4 | [submodule "vendors/ocaml-murmur3"] 5 | path = vendors/ocaml-murmur3 6 | url = git@github.com:vbmithr/ocaml-murmur3 7 | -------------------------------------------------------------------------------- /.ocamlformat: -------------------------------------------------------------------------------- 1 | profile = janestreet 2 | version = 0.27.0 -------------------------------------------------------------------------------- /CHANGES: -------------------------------------------------------------------------------- 1 | 0.1 (2020-04-16) Paris 2 | ---------------------- 3 | 4 | - First public release -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | GNU AFFERO GENERAL PUBLIC LICENSE 2 | Version 3, 19 November 2007 3 | 4 | Copyright (C) 2007 Free Software Foundation, Inc. 5 | Everyone is permitted to copy and distribute verbatim copies 6 | of this license document, but changing it is not allowed. 7 | 8 | Preamble 9 | 10 | The GNU Affero General Public License is a free, copyleft license for 11 | software and other kinds of works, specifically designed to ensure 12 | cooperation with the community in the case of network server software. 13 | 14 | The licenses for most software and other practical works are designed 15 | to take away your freedom to share and change the works. By contrast, 16 | our General Public Licenses are intended to guarantee your freedom to 17 | share and change all versions of a program--to make sure it remains free 18 | software for all its users. 19 | 20 | When we speak of free software, we are referring to freedom, not 21 | price. Our General Public Licenses are designed to make sure that you 22 | have the freedom to distribute copies of free software (and charge for 23 | them if you wish), that you receive source code or can get it if you 24 | want it, that you can change the software or use pieces of it in new 25 | free programs, and that you know you can do these things. 26 | 27 | Developers that use our General Public Licenses protect your rights 28 | with two steps: (1) assert copyright on the software, and (2) offer 29 | you this License which gives you legal permission to copy, distribute 30 | and/or modify the software. 31 | 32 | A secondary benefit of defending all users' freedom is that 33 | improvements made in alternate versions of the program, if they 34 | receive widespread use, become available for other developers to 35 | incorporate. Many developers of free software are heartened and 36 | encouraged by the resulting cooperation. However, in the case of 37 | software used on network servers, this result may fail to come about. 38 | The GNU General Public License permits making a modified version and 39 | letting the public access it on a server without ever releasing its 40 | source code to the public. 41 | 42 | The GNU Affero General Public License is designed specifically to 43 | ensure that, in such cases, the modified source code becomes available 44 | to the community. It requires the operator of a network server to 45 | provide the source code of the modified version running there to the 46 | users of that server. Therefore, public use of a modified version, on 47 | a publicly accessible server, gives the public access to the source 48 | code of the modified version. 49 | 50 | An older license, called the Affero General Public License and 51 | published by Affero, was designed to accomplish similar goals. This is 52 | a different license, not a version of the Affero GPL, but Affero has 53 | released a new version of the Affero GPL which permits relicensing under 54 | this license. 55 | 56 | The precise terms and conditions for copying, distribution and 57 | modification follow. 58 | 59 | TERMS AND CONDITIONS 60 | 61 | 0. Definitions. 62 | 63 | "This License" refers to version 3 of the GNU Affero General Public License. 64 | 65 | "Copyright" also means copyright-like laws that apply to other kinds of 66 | works, such as semiconductor masks. 67 | 68 | "The Program" refers to any copyrightable work licensed under this 69 | License. Each licensee is addressed as "you". "Licensees" and 70 | "recipients" may be individuals or organizations. 71 | 72 | To "modify" a work means to copy from or adapt all or part of the work 73 | in a fashion requiring copyright permission, other than the making of an 74 | exact copy. The resulting work is called a "modified version" of the 75 | earlier work or a work "based on" the earlier work. 76 | 77 | A "covered work" means either the unmodified Program or a work based 78 | on the Program. 79 | 80 | To "propagate" a work means to do anything with it that, without 81 | permission, would make you directly or secondarily liable for 82 | infringement under applicable copyright law, except executing it on a 83 | computer or modifying a private copy. Propagation includes copying, 84 | distribution (with or without modification), making available to the 85 | public, and in some countries other activities as well. 86 | 87 | To "convey" a work means any kind of propagation that enables other 88 | parties to make or receive copies. Mere interaction with a user through 89 | a computer network, with no transfer of a copy, is not conveying. 90 | 91 | An interactive user interface displays "Appropriate Legal Notices" 92 | to the extent that it includes a convenient and prominently visible 93 | feature that (1) displays an appropriate copyright notice, and (2) 94 | tells the user that there is no warranty for the work (except to the 95 | extent that warranties are provided), that licensees may convey the 96 | work under this License, and how to view a copy of this License. If 97 | the interface presents a list of user commands or options, such as a 98 | menu, a prominent item in the list meets this criterion. 99 | 100 | 1. Source Code. 101 | 102 | The "source code" for a work means the preferred form of the work 103 | for making modifications to it. "Object code" means any non-source 104 | form of a work. 105 | 106 | A "Standard Interface" means an interface that either is an official 107 | standard defined by a recognized standards body, or, in the case of 108 | interfaces specified for a particular programming language, one that 109 | is widely used among developers working in that language. 110 | 111 | The "System Libraries" of an executable work include anything, other 112 | than the work as a whole, that (a) is included in the normal form of 113 | packaging a Major Component, but which is not part of that Major 114 | Component, and (b) serves only to enable use of the work with that 115 | Major Component, or to implement a Standard Interface for which an 116 | implementation is available to the public in source code form. A 117 | "Major Component", in this context, means a major essential component 118 | (kernel, window system, and so on) of the specific operating system 119 | (if any) on which the executable work runs, or a compiler used to 120 | produce the work, or an object code interpreter used to run it. 121 | 122 | The "Corresponding Source" for a work in object code form means all 123 | the source code needed to generate, install, and (for an executable 124 | work) run the object code and to modify the work, including scripts to 125 | control those activities. However, it does not include the work's 126 | System Libraries, or general-purpose tools or generally available free 127 | programs which are used unmodified in performing those activities but 128 | which are not part of the work. For example, Corresponding Source 129 | includes interface definition files associated with source files for 130 | the work, and the source code for shared libraries and dynamically 131 | linked subprograms that the work is specifically designed to require, 132 | such as by intimate data communication or control flow between those 133 | subprograms and other parts of the work. 134 | 135 | The Corresponding Source need not include anything that users 136 | can regenerate automatically from other parts of the Corresponding 137 | Source. 138 | 139 | The Corresponding Source for a work in source code form is that 140 | same work. 141 | 142 | 2. Basic Permissions. 143 | 144 | All rights granted under this License are granted for the term of 145 | copyright on the Program, and are irrevocable provided the stated 146 | conditions are met. This License explicitly affirms your unlimited 147 | permission to run the unmodified Program. The output from running a 148 | covered work is covered by this License only if the output, given its 149 | content, constitutes a covered work. This License acknowledges your 150 | rights of fair use or other equivalent, as provided by copyright law. 151 | 152 | You may make, run and propagate covered works that you do not 153 | convey, without conditions so long as your license otherwise remains 154 | in force. You may convey covered works to others for the sole purpose 155 | of having them make modifications exclusively for you, or provide you 156 | with facilities for running those works, provided that you comply with 157 | the terms of this License in conveying all material for which you do 158 | not control copyright. Those thus making or running the covered works 159 | for you must do so exclusively on your behalf, under your direction 160 | and control, on terms that prohibit them from making any copies of 161 | your copyrighted material outside their relationship with you. 162 | 163 | Conveying under any other circumstances is permitted solely under 164 | the conditions stated below. Sublicensing is not allowed; section 10 165 | makes it unnecessary. 166 | 167 | 3. Protecting Users' Legal Rights From Anti-Circumvention Law. 168 | 169 | No covered work shall be deemed part of an effective technological 170 | measure under any applicable law fulfilling obligations under article 171 | 11 of the WIPO copyright treaty adopted on 20 December 1996, or 172 | similar laws prohibiting or restricting circumvention of such 173 | measures. 174 | 175 | When you convey a covered work, you waive any legal power to forbid 176 | circumvention of technological measures to the extent such circumvention 177 | is effected by exercising rights under this License with respect to 178 | the covered work, and you disclaim any intention to limit operation or 179 | modification of the work as a means of enforcing, against the work's 180 | users, your or third parties' legal rights to forbid circumvention of 181 | technological measures. 182 | 183 | 4. Conveying Verbatim Copies. 184 | 185 | You may convey verbatim copies of the Program's source code as you 186 | receive it, in any medium, provided that you conspicuously and 187 | appropriately publish on each copy an appropriate copyright notice; 188 | keep intact all notices stating that this License and any 189 | non-permissive terms added in accord with section 7 apply to the code; 190 | keep intact all notices of the absence of any warranty; and give all 191 | recipients a copy of this License along with the Program. 192 | 193 | You may charge any price or no price for each copy that you convey, 194 | and you may offer support or warranty protection for a fee. 195 | 196 | 5. Conveying Modified Source Versions. 197 | 198 | You may convey a work based on the Program, or the modifications to 199 | produce it from the Program, in the form of source code under the 200 | terms of section 4, provided that you also meet all of these conditions: 201 | 202 | a) The work must carry prominent notices stating that you modified 203 | it, and giving a relevant date. 204 | 205 | b) The work must carry prominent notices stating that it is 206 | released under this License and any conditions added under section 207 | 7. This requirement modifies the requirement in section 4 to 208 | "keep intact all notices". 209 | 210 | c) You must license the entire work, as a whole, under this 211 | License to anyone who comes into possession of a copy. This 212 | License will therefore apply, along with any applicable section 7 213 | additional terms, to the whole of the work, and all its parts, 214 | regardless of how they are packaged. This License gives no 215 | permission to license the work in any other way, but it does not 216 | invalidate such permission if you have separately received it. 217 | 218 | d) If the work has interactive user interfaces, each must display 219 | Appropriate Legal Notices; however, if the Program has interactive 220 | interfaces that do not display Appropriate Legal Notices, your 221 | work need not make them do so. 222 | 223 | A compilation of a covered work with other separate and independent 224 | works, which are not by their nature extensions of the covered work, 225 | and which are not combined with it such as to form a larger program, 226 | in or on a volume of a storage or distribution medium, is called an 227 | "aggregate" if the compilation and its resulting copyright are not 228 | used to limit the access or legal rights of the compilation's users 229 | beyond what the individual works permit. Inclusion of a covered work 230 | in an aggregate does not cause this License to apply to the other 231 | parts of the aggregate. 232 | 233 | 6. Conveying Non-Source Forms. 234 | 235 | You may convey a covered work in object code form under the terms 236 | of sections 4 and 5, provided that you also convey the 237 | machine-readable Corresponding Source under the terms of this License, 238 | in one of these ways: 239 | 240 | a) Convey the object code in, or embodied in, a physical product 241 | (including a physical distribution medium), accompanied by the 242 | Corresponding Source fixed on a durable physical medium 243 | customarily used for software interchange. 244 | 245 | b) Convey the object code in, or embodied in, a physical product 246 | (including a physical distribution medium), accompanied by a 247 | written offer, valid for at least three years and valid for as 248 | long as you offer spare parts or customer support for that product 249 | model, to give anyone who possesses the object code either (1) a 250 | copy of the Corresponding Source for all the software in the 251 | product that is covered by this License, on a durable physical 252 | medium customarily used for software interchange, for a price no 253 | more than your reasonable cost of physically performing this 254 | conveying of source, or (2) access to copy the 255 | Corresponding Source from a network server at no charge. 256 | 257 | c) Convey individual copies of the object code with a copy of the 258 | written offer to provide the Corresponding Source. This 259 | alternative is allowed only occasionally and noncommercially, and 260 | only if you received the object code with such an offer, in accord 261 | with subsection 6b. 262 | 263 | d) Convey the object code by offering access from a designated 264 | place (gratis or for a charge), and offer equivalent access to the 265 | Corresponding Source in the same way through the same place at no 266 | further charge. You need not require recipients to copy the 267 | Corresponding Source along with the object code. If the place to 268 | copy the object code is a network server, the Corresponding Source 269 | may be on a different server (operated by you or a third party) 270 | that supports equivalent copying facilities, provided you maintain 271 | clear directions next to the object code saying where to find the 272 | Corresponding Source. Regardless of what server hosts the 273 | Corresponding Source, you remain obligated to ensure that it is 274 | available for as long as needed to satisfy these requirements. 275 | 276 | e) Convey the object code using peer-to-peer transmission, provided 277 | you inform other peers where the object code and Corresponding 278 | Source of the work are being offered to the general public at no 279 | charge under subsection 6d. 280 | 281 | A separable portion of the object code, whose source code is excluded 282 | from the Corresponding Source as a System Library, need not be 283 | included in conveying the object code work. 284 | 285 | A "User Product" is either (1) a "consumer product", which means any 286 | tangible personal property which is normally used for personal, family, 287 | or household purposes, or (2) anything designed or sold for incorporation 288 | into a dwelling. In determining whether a product is a consumer product, 289 | doubtful cases shall be resolved in favor of coverage. For a particular 290 | product received by a particular user, "normally used" refers to a 291 | typical or common use of that class of product, regardless of the status 292 | of the particular user or of the way in which the particular user 293 | actually uses, or expects or is expected to use, the product. A product 294 | is a consumer product regardless of whether the product has substantial 295 | commercial, industrial or non-consumer uses, unless such uses represent 296 | the only significant mode of use of the product. 297 | 298 | "Installation Information" for a User Product means any methods, 299 | procedures, authorization keys, or other information required to install 300 | and execute modified versions of a covered work in that User Product from 301 | a modified version of its Corresponding Source. The information must 302 | suffice to ensure that the continued functioning of the modified object 303 | code is in no case prevented or interfered with solely because 304 | modification has been made. 305 | 306 | If you convey an object code work under this section in, or with, or 307 | specifically for use in, a User Product, and the conveying occurs as 308 | part of a transaction in which the right of possession and use of the 309 | User Product is transferred to the recipient in perpetuity or for a 310 | fixed term (regardless of how the transaction is characterized), the 311 | Corresponding Source conveyed under this section must be accompanied 312 | by the Installation Information. But this requirement does not apply 313 | if neither you nor any third party retains the ability to install 314 | modified object code on the User Product (for example, the work has 315 | been installed in ROM). 316 | 317 | The requirement to provide Installation Information does not include a 318 | requirement to continue to provide support service, warranty, or updates 319 | for a work that has been modified or installed by the recipient, or for 320 | the User Product in which it has been modified or installed. Access to a 321 | network may be denied when the modification itself materially and 322 | adversely affects the operation of the network or violates the rules and 323 | protocols for communication across the network. 324 | 325 | Corresponding Source conveyed, and Installation Information provided, 326 | in accord with this section must be in a format that is publicly 327 | documented (and with an implementation available to the public in 328 | source code form), and must require no special password or key for 329 | unpacking, reading or copying. 330 | 331 | 7. Additional Terms. 332 | 333 | "Additional permissions" are terms that supplement the terms of this 334 | License by making exceptions from one or more of its conditions. 335 | Additional permissions that are applicable to the entire Program shall 336 | be treated as though they were included in this License, to the extent 337 | that they are valid under applicable law. If additional permissions 338 | apply only to part of the Program, that part may be used separately 339 | under those permissions, but the entire Program remains governed by 340 | this License without regard to the additional permissions. 341 | 342 | When you convey a copy of a covered work, you may at your option 343 | remove any additional permissions from that copy, or from any part of 344 | it. (Additional permissions may be written to require their own 345 | removal in certain cases when you modify the work.) You may place 346 | additional permissions on material, added by you to a covered work, 347 | for which you have or can give appropriate copyright permission. 348 | 349 | Notwithstanding any other provision of this License, for material you 350 | add to a covered work, you may (if authorized by the copyright holders of 351 | that material) supplement the terms of this License with terms: 352 | 353 | a) Disclaiming warranty or limiting liability differently from the 354 | terms of sections 15 and 16 of this License; or 355 | 356 | b) Requiring preservation of specified reasonable legal notices or 357 | author attributions in that material or in the Appropriate Legal 358 | Notices displayed by works containing it; or 359 | 360 | c) Prohibiting misrepresentation of the origin of that material, or 361 | requiring that modified versions of such material be marked in 362 | reasonable ways as different from the original version; or 363 | 364 | d) Limiting the use for publicity purposes of names of licensors or 365 | authors of the material; or 366 | 367 | e) Declining to grant rights under trademark law for use of some 368 | trade names, trademarks, or service marks; or 369 | 370 | f) Requiring indemnification of licensors and authors of that 371 | material by anyone who conveys the material (or modified versions of 372 | it) with contractual assumptions of liability to the recipient, for 373 | any liability that these contractual assumptions directly impose on 374 | those licensors and authors. 375 | 376 | All other non-permissive additional terms are considered "further 377 | restrictions" within the meaning of section 10. If the Program as you 378 | received it, or any part of it, contains a notice stating that it is 379 | governed by this License along with a term that is a further 380 | restriction, you may remove that term. If a license document contains 381 | a further restriction but permits relicensing or conveying under this 382 | License, you may add to a covered work material governed by the terms 383 | of that license document, provided that the further restriction does 384 | not survive such relicensing or conveying. 385 | 386 | If you add terms to a covered work in accord with this section, you 387 | must place, in the relevant source files, a statement of the 388 | additional terms that apply to those files, or a notice indicating 389 | where to find the applicable terms. 390 | 391 | Additional terms, permissive or non-permissive, may be stated in the 392 | form of a separately written license, or stated as exceptions; 393 | the above requirements apply either way. 394 | 395 | 8. Termination. 396 | 397 | You may not propagate or modify a covered work except as expressly 398 | provided under this License. Any attempt otherwise to propagate or 399 | modify it is void, and will automatically terminate your rights under 400 | this License (including any patent licenses granted under the third 401 | paragraph of section 11). 402 | 403 | However, if you cease all violation of this License, then your 404 | license from a particular copyright holder is reinstated (a) 405 | provisionally, unless and until the copyright holder explicitly and 406 | finally terminates your license, and (b) permanently, if the copyright 407 | holder fails to notify you of the violation by some reasonable means 408 | prior to 60 days after the cessation. 409 | 410 | Moreover, your license from a particular copyright holder is 411 | reinstated permanently if the copyright holder notifies you of the 412 | violation by some reasonable means, this is the first time you have 413 | received notice of violation of this License (for any work) from that 414 | copyright holder, and you cure the violation prior to 30 days after 415 | your receipt of the notice. 416 | 417 | Termination of your rights under this section does not terminate the 418 | licenses of parties who have received copies or rights from you under 419 | this License. If your rights have been terminated and not permanently 420 | reinstated, you do not qualify to receive new licenses for the same 421 | material under section 10. 422 | 423 | 9. Acceptance Not Required for Having Copies. 424 | 425 | You are not required to accept this License in order to receive or 426 | run a copy of the Program. Ancillary propagation of a covered work 427 | occurring solely as a consequence of using peer-to-peer transmission 428 | to receive a copy likewise does not require acceptance. However, 429 | nothing other than this License grants you permission to propagate or 430 | modify any covered work. These actions infringe copyright if you do 431 | not accept this License. Therefore, by modifying or propagating a 432 | covered work, you indicate your acceptance of this License to do so. 433 | 434 | 10. Automatic Licensing of Downstream Recipients. 435 | 436 | Each time you convey a covered work, the recipient automatically 437 | receives a license from the original licensors, to run, modify and 438 | propagate that work, subject to this License. You are not responsible 439 | for enforcing compliance by third parties with this License. 440 | 441 | An "entity transaction" is a transaction transferring control of an 442 | organization, or substantially all assets of one, or subdividing an 443 | organization, or merging organizations. If propagation of a covered 444 | work results from an entity transaction, each party to that 445 | transaction who receives a copy of the work also receives whatever 446 | licenses to the work the party's predecessor in interest had or could 447 | give under the previous paragraph, plus a right to possession of the 448 | Corresponding Source of the work from the predecessor in interest, if 449 | the predecessor has it or can get it with reasonable efforts. 450 | 451 | You may not impose any further restrictions on the exercise of the 452 | rights granted or affirmed under this License. For example, you may 453 | not impose a license fee, royalty, or other charge for exercise of 454 | rights granted under this License, and you may not initiate litigation 455 | (including a cross-claim or counterclaim in a lawsuit) alleging that 456 | any patent claim is infringed by making, using, selling, offering for 457 | sale, or importing the Program or any portion of it. 458 | 459 | 11. Patents. 460 | 461 | A "contributor" is a copyright holder who authorizes use under this 462 | License of the Program or a work on which the Program is based. The 463 | work thus licensed is called the contributor's "contributor version". 464 | 465 | A contributor's "essential patent claims" are all patent claims 466 | owned or controlled by the contributor, whether already acquired or 467 | hereafter acquired, that would be infringed by some manner, permitted 468 | by this License, of making, using, or selling its contributor version, 469 | but do not include claims that would be infringed only as a 470 | consequence of further modification of the contributor version. For 471 | purposes of this definition, "control" includes the right to grant 472 | patent sublicenses in a manner consistent with the requirements of 473 | this License. 474 | 475 | Each contributor grants you a non-exclusive, worldwide, royalty-free 476 | patent license under the contributor's essential patent claims, to 477 | make, use, sell, offer for sale, import and otherwise run, modify and 478 | propagate the contents of its contributor version. 479 | 480 | In the following three paragraphs, a "patent license" is any express 481 | agreement or commitment, however denominated, not to enforce a patent 482 | (such as an express permission to practice a patent or covenant not to 483 | sue for patent infringement). To "grant" such a patent license to a 484 | party means to make such an agreement or commitment not to enforce a 485 | patent against the party. 486 | 487 | If you convey a covered work, knowingly relying on a patent license, 488 | and the Corresponding Source of the work is not available for anyone 489 | to copy, free of charge and under the terms of this License, through a 490 | publicly available network server or other readily accessible means, 491 | then you must either (1) cause the Corresponding Source to be so 492 | available, or (2) arrange to deprive yourself of the benefit of the 493 | patent license for this particular work, or (3) arrange, in a manner 494 | consistent with the requirements of this License, to extend the patent 495 | license to downstream recipients. "Knowingly relying" means you have 496 | actual knowledge that, but for the patent license, your conveying the 497 | covered work in a country, or your recipient's use of the covered work 498 | in a country, would infringe one or more identifiable patents in that 499 | country that you have reason to believe are valid. 500 | 501 | If, pursuant to or in connection with a single transaction or 502 | arrangement, you convey, or propagate by procuring conveyance of, a 503 | covered work, and grant a patent license to some of the parties 504 | receiving the covered work authorizing them to use, propagate, modify 505 | or convey a specific copy of the covered work, then the patent license 506 | you grant is automatically extended to all recipients of the covered 507 | work and works based on it. 508 | 509 | A patent license is "discriminatory" if it does not include within 510 | the scope of its coverage, prohibits the exercise of, or is 511 | conditioned on the non-exercise of one or more of the rights that are 512 | specifically granted under this License. You may not convey a covered 513 | work if you are a party to an arrangement with a third party that is 514 | in the business of distributing software, under which you make payment 515 | to the third party based on the extent of your activity of conveying 516 | the work, and under which the third party grants, to any of the 517 | parties who would receive the covered work from you, a discriminatory 518 | patent license (a) in connection with copies of the covered work 519 | conveyed by you (or copies made from those copies), or (b) primarily 520 | for and in connection with specific products or compilations that 521 | contain the covered work, unless you entered into that arrangement, 522 | or that patent license was granted, prior to 28 March 2007. 523 | 524 | Nothing in this License shall be construed as excluding or limiting 525 | any implied license or other defenses to infringement that may 526 | otherwise be available to you under applicable patent law. 527 | 528 | 12. No Surrender of Others' Freedom. 529 | 530 | If conditions are imposed on you (whether by court order, agreement or 531 | otherwise) that contradict the conditions of this License, they do not 532 | excuse you from the conditions of this License. If you cannot convey a 533 | covered work so as to satisfy simultaneously your obligations under this 534 | License and any other pertinent obligations, then as a consequence you may 535 | not convey it at all. For example, if you agree to terms that obligate you 536 | to collect a royalty for further conveying from those to whom you convey 537 | the Program, the only way you could satisfy both those terms and this 538 | License would be to refrain entirely from conveying the Program. 539 | 540 | 13. Remote Network Interaction; Use with the GNU General Public License. 541 | 542 | Notwithstanding any other provision of this License, if you modify the 543 | Program, your modified version must prominently offer all users 544 | interacting with it remotely through a computer network (if your version 545 | supports such interaction) an opportunity to receive the Corresponding 546 | Source of your version by providing access to the Corresponding Source 547 | from a network server at no charge, through some standard or customary 548 | means of facilitating copying of software. This Corresponding Source 549 | shall include the Corresponding Source for any work covered by version 3 550 | of the GNU General Public License that is incorporated pursuant to the 551 | following paragraph. 552 | 553 | Notwithstanding any other provision of this License, you have 554 | permission to link or combine any covered work with a work licensed 555 | under version 3 of the GNU General Public License into a single 556 | combined work, and to convey the resulting work. The terms of this 557 | License will continue to apply to the part which is the covered work, 558 | but the work with which it is combined will remain governed by version 559 | 3 of the GNU General Public License. 560 | 561 | 14. Revised Versions of this License. 562 | 563 | The Free Software Foundation may publish revised and/or new versions of 564 | the GNU Affero General Public License from time to time. Such new versions 565 | will be similar in spirit to the present version, but may differ in detail to 566 | address new problems or concerns. 567 | 568 | Each version is given a distinguishing version number. If the 569 | Program specifies that a certain numbered version of the GNU Affero General 570 | Public License "or any later version" applies to it, you have the 571 | option of following the terms and conditions either of that numbered 572 | version or of any later version published by the Free Software 573 | Foundation. If the Program does not specify a version number of the 574 | GNU Affero General Public License, you may choose any version ever published 575 | by the Free Software Foundation. 576 | 577 | If the Program specifies that a proxy can decide which future 578 | versions of the GNU Affero General Public License can be used, that proxy's 579 | public statement of acceptance of a version permanently authorizes you 580 | to choose that version for the Program. 581 | 582 | Later license versions may give you additional or different 583 | permissions. However, no additional obligations are imposed on any 584 | author or copyright holder as a result of your choosing to follow a 585 | later version. 586 | 587 | 15. Disclaimer of Warranty. 588 | 589 | THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY 590 | APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT 591 | HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY 592 | OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, 593 | THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR 594 | PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM 595 | IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF 596 | ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 597 | 598 | 16. Limitation of Liability. 599 | 600 | IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING 601 | WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS 602 | THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY 603 | GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE 604 | USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF 605 | DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD 606 | PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), 607 | EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF 608 | SUCH DAMAGES. 609 | 610 | 17. Interpretation of Sections 15 and 16. 611 | 612 | If the disclaimer of warranty and limitation of liability provided 613 | above cannot be given local legal effect according to their terms, 614 | reviewing courts shall apply local law that most closely approximates 615 | an absolute waiver of all civil liability in connection with the 616 | Program, unless a warranty or assumption of liability accompanies a 617 | copy of the Program in return for a fee. 618 | 619 | END OF TERMS AND CONDITIONS 620 | 621 | How to Apply These Terms to Your New Programs 622 | 623 | If you develop a new program, and you want it to be of the greatest 624 | possible use to the public, the best way to achieve this is to make it 625 | free software which everyone can redistribute and change under these terms. 626 | 627 | To do so, attach the following notices to the program. It is safest 628 | to attach them to the start of each source file to most effectively 629 | state the exclusion of warranty; and each file should have at least 630 | the "copyright" line and a pointer to where the full notice is found. 631 | 632 | 633 | Copyright (C) 634 | 635 | This program is free software: you can redistribute it and/or modify 636 | it under the terms of the GNU Affero General Public License as published by 637 | the Free Software Foundation, either version 3 of the License, or 638 | (at your option) any later version. 639 | 640 | This program is distributed in the hope that it will be useful, 641 | but WITHOUT ANY WARRANTY; without even the implied warranty of 642 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 643 | GNU Affero General Public License for more details. 644 | 645 | You should have received a copy of the GNU Affero General Public License 646 | along with this program. If not, see . 647 | 648 | Also add information on how to contact you by electronic and paper mail. 649 | 650 | If your software can interact with users remotely through a computer 651 | network, you should also make sure that it provides a way for users to 652 | get its source. For example, if your program is a web application, its 653 | interface could display a "Source" link that leads users to an archive 654 | of the code. There are many ways you could offer source, and different 655 | solutions will be better for different programs; see section 13 for the 656 | specific requirements. 657 | 658 | You should also get your employer (if you work as a programmer) or school, 659 | if any, to sign a "copyright disclaimer" for the program, if necessary. 660 | For more information on this, and how to apply and follow the GNU AGPL, see 661 | . 662 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | Copyright (c) 2017-2020 Vincent Bernardoff 2 | 3 | Permission to use, copy, modify, and/or distribute this software for any 4 | purpose with or without fee is hereby granted, provided that the above 5 | copyright notice and this permission notice appear in all copies. 6 | 7 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 8 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 9 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 10 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 11 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 12 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 13 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 14 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vbmithr/ocaml-bitcoin/a4373133b5cf77802060a8673db55a5467733b88/README.md -------------------------------------------------------------------------------- /bin/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name node) 3 | (public_name bitcoin-node) 4 | (package bitcoin-node) 5 | (libraries 6 | bitcoin 7 | core 8 | async 9 | uri 10 | base58)) 11 | -------------------------------------------------------------------------------- /bin/node.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open Async 3 | open Bitcoin 4 | open Bitcoin.Util 5 | open Bitcoin.P2p 6 | open Log.Global 7 | 8 | let headers = Hash256.Table.create 13 9 | let best_hh = ref Header.genesis_hash 10 | let buf = Cstruct.create 4096 11 | let network = ref Network.Mainnet 12 | let my_addresses = BitcoinAddr.of_string_exn "mjVrE2kfz42sLR5gFcfvG6PwbAjhpmsKnn" 13 | 14 | let write_cstruct w (cs : Cstruct.t) = 15 | (* debug "write_cstruct %d %d" cs.off cs.len ; *) 16 | Writer.write_bigstring w cs.buffer ~pos:cs.off ~len:cs.len 17 | ;; 18 | 19 | let write_cstruct2 w cs cs2 = 20 | let len = cs2.Cstruct.off - cs.Cstruct.off in 21 | Writer.write_bigstring w cs.buffer ~pos:cs.off ~len 22 | ;; 23 | 24 | let request_hdrs w start = 25 | let msg = Message.GetHeaders (GetHashes.create [ start ]) in 26 | let cs = Message.to_cstruct ~network:!network buf msg in 27 | write_cstruct2 w buf cs; 28 | debug "Sent GetHeaders" 29 | ;; 30 | 31 | let load_filter w data = 32 | let filterload = FilterLoad.of_data data Update_none in 33 | let msg = Message.FilterLoad filterload in 34 | let cs = Message.to_cstruct ~network:!network buf msg in 35 | write_cstruct2 w buf cs; 36 | debug "Sent FilterLoad" 37 | ;; 38 | 39 | (* let get_data w invs = *) 40 | (* let msg = Message.GetData invs in *) 41 | (* let cs = Message.to_cstruct ~network:!network buf msg in *) 42 | (* write_cstruct2 w buf cs; *) 43 | (* debug "Sent GetData" *) 44 | (* ;; *) 45 | 46 | let process_error _w header = sexp ~level:`Error (MessageHeader.sexp_of_t header) 47 | 48 | let process_msg w msg = 49 | (* sexp ~level:`Debug (Message.sexp_of_t msg) ; *) 50 | match msg with 51 | | Message.Version _ -> 52 | let cs = Message.to_cstruct ~network:!network buf VerAck in 53 | write_cstruct2 w buf cs; 54 | debug "Sent VerAck" 55 | | VerAck -> 56 | debug "Got VerAck!"; 57 | let data = [ Cstruct.of_string my_addresses.payload ] in 58 | load_filter w data 59 | (* get_data w [Inv.filteredblock (Hash256.of_hex_rpc (`Hex "00000000000007650b584bdba841c87876c9536953fe29ddd1a9107f0f25e486"))] *) 60 | (* Requesting headers *) 61 | (* request_hdrs w Header.genesis_hash *) 62 | | Reject rej -> error "%s" (Format.asprintf "%a" Reject.pp rej) 63 | | SendHeaders -> debug "Got SendHeaders!" 64 | (* let nb_headers = String.Table.length headers in *) 65 | (* let cs = CompactSize.to_cstruct_int buf nb_headers in *) 66 | (* write_cstruct2 w buf cs ; *) 67 | (* String.Table.iter headers ~f:begin fun h -> *) 68 | (* let cs = Header.to_cstruct buf h in *) 69 | (* write_cstruct2 w buf cs *) 70 | (* end ; *) 71 | (* debug "Sent %d headers" nb_headers *) 72 | | SendCmpct t -> sexp ~level:`Debug (SendCmpct.sexp_of_t t) 73 | | GetAddr -> debug "Got GetAddr!" 74 | | Addr _ -> debug "Got Addr!" 75 | | Ping i -> 76 | debug "Got Ping!"; 77 | let cs = Message.to_cstruct ~network:!network buf (Pong i) in 78 | write_cstruct2 w buf cs; 79 | debug "Sent Pong" 80 | | Pong _ -> debug "Got Pong!" 81 | | GetBlocks _ -> debug "Got GetBlocks!" 82 | | GetData _ -> debug "Got GetData!" 83 | | GetHeaders _ -> debug "Got GetHeaders!" 84 | | Block _ -> debug "Got Block!" 85 | | MerkleBlock mblock -> 86 | debug "MerkleBlock %s" (Sexplib.Sexp.to_string_hum (MerkleBlock.sexp_of_t mblock)) 87 | | Headers hdrs -> 88 | List.iteri hdrs ~f:(fun _i h -> 89 | let hh = Header.hash256 h in 90 | (* debug "Got block header %d: %s" i (Hash256.show hh) ; *) 91 | Hash256.Table.add headers hh h; 92 | best_hh := hh); 93 | debug "headers table has %d entries" (Hash256.Table.length headers); 94 | if List.length hdrs = 2000 then request_hdrs w !best_hh 95 | | Inv invs -> 96 | List.iter invs ~f:(fun inv -> 97 | debug "Inv %s" (Sexplib.Sexp.to_string_hum (Inv.sexp_of_t inv))) 98 | | NotFound _ -> debug "Got NotFound!" 99 | | MemPool -> debug "Got MemPool!" 100 | | Tx _ -> 101 | debug "Got Tx!" 102 | (* debug "%s" (Sexplib.Sexp.to_string_hum (Transaction.sexp_of_t tx)) *) 103 | | FeeFilter fee -> debug "Got FeeFilter: %Ld" fee 104 | | FilterAdd _ -> debug "Got FilterAdd!" 105 | | FilterClear -> debug "Got FilterClear!" 106 | | FilterLoad _ -> debug "Got FilterLoad!" 107 | ;; 108 | 109 | let handle_chunk w buf ~pos ~len = 110 | (* debug "consume_cs %d %d" pos len ; *) 111 | if len < MessageHeader.size 112 | then return (`Consumed (0, `Need MessageHeader.size)) 113 | else ( 114 | let cs = Cstruct.of_bigarray ~off:pos ~len buf in 115 | let hdr, cs_payload = MessageHeader.of_cstruct cs in 116 | let msg_size = MessageHeader.size + hdr.size in 117 | if Cstruct.length cs_payload < hdr.size 118 | then return (`Consumed (0, `Need msg_size)) 119 | else ( 120 | match Message.of_cstruct cs with 121 | | Error (Invalid_checksum h), _ -> 122 | process_error w h; 123 | return (`Stop ()) 124 | | Ok (_, msg), _ -> 125 | process_msg w msg; 126 | return (`Consumed (msg_size, `Need_unknown)))) 127 | ;; 128 | 129 | let main_loop port _s r w = 130 | info "Connected!"; 131 | let cs = 132 | Message.to_cstruct 133 | ~network:!network 134 | buf 135 | (Version (Version.create ~recv_port:port ~trans_port:port ())) 136 | in 137 | write_cstruct w (Cstruct.sub buf 0 cs.off); 138 | Reader.read_one_chunk_at_a_time r ~handle_chunk:(handle_chunk w) 139 | >>= function 140 | | `Eof -> 141 | info "EOF"; 142 | Deferred.unit 143 | | `Eof_with_unconsumed_data _data -> 144 | info "EOF with unconsumed data"; 145 | Deferred.unit 146 | | `Stopped _ -> 147 | info "Stopped"; 148 | Deferred.unit 149 | ;; 150 | 151 | let set_loglevel = function 152 | | 2 -> set_level `Info 153 | | 3 -> set_level `Debug 154 | | _ -> () 155 | ;; 156 | 157 | let main testnet host port _daemon _datadir _rundir _logdir loglevel () = 158 | set_loglevel loglevel; 159 | if testnet then network := Network.Testnet; 160 | let host = 161 | match testnet, host with 162 | | _, Some host -> host 163 | | true, None -> List.hd_exn Network.(seed Testnet) 164 | | false, None -> List.hd_exn Network.(seed Mainnet) 165 | in 166 | let port = 167 | match testnet, port with 168 | | _, Some port -> port 169 | | true, None -> Network.(port Testnet) 170 | | false, None -> Network.(port Mainnet) 171 | in 172 | stage (fun `Scheduler_started -> 173 | info "Connecting to %s:%d" host port; 174 | Tcp.( 175 | with_connection 176 | Where_to_connect.(of_host_and_port (Host_and_port.create ~host ~port)) 177 | (main_loop port))) 178 | ;; 179 | 180 | let command = 181 | let spec = 182 | let open Command.Spec in 183 | empty 184 | +> flag "-testnet" no_arg ~doc:" Use testnet" 185 | +> flag "-host" (optional string) ~doc:"string Hostname to use" 186 | +> flag "-port" (optional int) ~doc:"int TCP port to use" 187 | +> flag "-daemon" no_arg ~doc:" Run as a daemon" 188 | +> flag 189 | "-datadir" 190 | (optional_with_default "data" string) 191 | ~doc:"dirname Data directory (data)" 192 | +> flag 193 | "-rundir" 194 | (optional_with_default "run" string) 195 | ~doc:"dirname Run directory (run)" 196 | +> flag 197 | "-logdir" 198 | (optional_with_default "log" string) 199 | ~doc:"dirname Log directory (log)" 200 | +> flag "-loglevel" (optional_with_default 1 int) ~doc:"1-3 global loglevel" 201 | in 202 | Command.Staged.async_spec ~summary:"Bitcoin Node" spec main 203 | ;; 204 | 205 | let () = Command_unix.run command 206 | -------------------------------------------------------------------------------- /bitcoin-node.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: "Bitcoin node implementation with Async" 4 | description: "" 5 | maintainer: ["Vincent Bernardoff"] 6 | authors: ["Vincent Bernardoff "] 7 | license: "LICENSE" 8 | tags: ["crypto" "bitcoin"] 9 | homepage: "https://github.com/vbmithr/ocaml-bitcoin" 10 | doc: "https://url/to/documentation" 11 | bug-reports: "https://github.com/vbmithr/ocaml-bitcoin/issues" 12 | depends: [ 13 | "ocaml" 14 | "dune" {>= "3.16"} 15 | "bitcoin" 16 | "core" 17 | "async" 18 | "uri" 19 | "base58" 20 | "odoc" {with-doc} 21 | ] 22 | build: [ 23 | ["dune" "subst"] {dev} 24 | [ 25 | "dune" 26 | "build" 27 | "-p" 28 | name 29 | "-j" 30 | jobs 31 | "@install" 32 | "@runtest" {with-test} 33 | "@doc" {with-doc} 34 | ] 35 | ] 36 | dev-repo: "git+https://github.com/vbmithr/ocaml-bitcoin.git" 37 | -------------------------------------------------------------------------------- /bitcoin.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: "Bitcoin library" 4 | description: "" 5 | maintainer: ["Vincent Bernardoff"] 6 | authors: ["Vincent Bernardoff "] 7 | license: "LICENSE" 8 | tags: ["crypto" "bitcoin"] 9 | homepage: "https://github.com/vbmithr/ocaml-bitcoin" 10 | doc: "https://url/to/documentation" 11 | bug-reports: "https://github.com/vbmithr/ocaml-bitcoin/issues" 12 | depends: [ 13 | "ocaml" 14 | "dune" {>= "3.16"} 15 | "fmt" 16 | "cstruct" 17 | "cstruct-sexp" 18 | "sexplib" 19 | "rresult" 20 | "stdint" 21 | "ipaddr" 22 | "ipaddr-sexp" 23 | "ptime" 24 | "hex" 25 | "bitv" 26 | "murmur3" 27 | "digestif" 28 | "secp256k1-internal" 29 | "base58" 30 | "alcotest" {with-test} 31 | "odoc" {with-doc} 32 | ] 33 | build: [ 34 | ["dune" "subst"] {dev} 35 | [ 36 | "dune" 37 | "build" 38 | "-p" 39 | name 40 | "-j" 41 | jobs 42 | "@install" 43 | "@runtest" {with-test} 44 | "@doc" {with-doc} 45 | ] 46 | ] 47 | dev-repo: "git+https://github.com/vbmithr/ocaml-bitcoin.git" 48 | -------------------------------------------------------------------------------- /cstruct/bitcoin_cstruct.ml: -------------------------------------------------------------------------------- 1 | module Header = struct 2 | [%%cstruct 3 | type t = 4 | { version : uint32_t 5 | ; prev_block : uint8_t [@len 32] 6 | ; merkle_root : uint8_t [@len 32] 7 | ; timestamp : uint32_t 8 | ; bits : uint32_t 9 | ; nonce : uint32_t 10 | } 11 | [@@little_endian]] 12 | end 13 | 14 | module Outpoint = struct 15 | [%%cstruct 16 | type t = 17 | { hash : uint8_t [@len 32] 18 | ; index : uint32_t 19 | } 20 | [@@little_endian]] 21 | end 22 | 23 | module MessageHeader = struct 24 | [%%cstruct 25 | type t = 26 | { start_string : uint8_t [@len 4] 27 | ; command_name : uint8_t [@len 12] 28 | ; payload_size : uint32_t 29 | ; checksum : uint8_t [@len 4] 30 | } 31 | [@@little_endian]] 32 | end 33 | 34 | module Version = struct 35 | [%%cstruct 36 | type t = 37 | { version : uint32_t 38 | ; services : uint64_t 39 | ; timestamp : uint64_t 40 | ; recv_services : uint64_t 41 | ; recv_ipaddr : uint8_t [@len 16] 42 | ; recv_port : uint8_t [@len 2] 43 | ; trans_services : uint64_t 44 | ; trans_ipaddr : uint8_t [@len 16] 45 | ; trans_port : uint8_t [@len 2] 46 | ; nonce : uint64_t 47 | } 48 | [@@little_endian]] 49 | end 50 | 51 | module Address = struct 52 | [%%cstruct 53 | type t = 54 | { timestamp : uint32_t 55 | ; services : uint64_t 56 | ; ipaddr : uint8_t [@len 16] 57 | ; port : uint8_t [@len 2] 58 | } 59 | [@@little_endian]] 60 | end 61 | 62 | module Inv = struct 63 | [%%cstruct 64 | type t = 65 | { id : uint32_t 66 | ; hash : uint8_t [@len 32] 67 | } 68 | [@@little_endian]] 69 | end 70 | 71 | module SendCmpct = struct 72 | [%%cstruct 73 | type t = 74 | { b : uint8_t 75 | ; version : uint64_t 76 | } 77 | [@@little_endian]] 78 | end 79 | -------------------------------------------------------------------------------- /cstruct/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name bitcoin_cstruct) 3 | (public_name bitcoin.cstruct) 4 | (preprocess (pps ppx_cstruct)) 5 | (libraries 6 | ptime 7 | cstruct) 8 | ) 9 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 3.16) 2 | 3 | (name bitcoin) 4 | 5 | (generate_opam_files true) 6 | 7 | (source 8 | (github vbmithr/ocaml-bitcoin)) 9 | 10 | (authors "Vincent Bernardoff ") 11 | 12 | (maintainers "Vincent Bernardoff") 13 | 14 | (license LICENSE) 15 | 16 | (documentation https://url/to/documentation) 17 | 18 | (package 19 | (name bitcoin) 20 | (synopsis "Bitcoin library") 21 | (description "") 22 | (depends 23 | ocaml 24 | dune 25 | fmt 26 | cstruct 27 | cstruct-sexp 28 | sexplib 29 | rresult 30 | stdint 31 | ipaddr 32 | ipaddr-sexp 33 | ptime 34 | hex 35 | bitv 36 | murmur3 37 | digestif 38 | secp256k1-internal 39 | base58 40 | (alcotest :with-test) 41 | ) 42 | (tags (crypto bitcoin))) 43 | 44 | (package 45 | (name bitcoin-node) 46 | (synopsis "Bitcoin node implementation with Async") 47 | (description "") 48 | (depends 49 | ocaml 50 | dune 51 | bitcoin 52 | core 53 | async 54 | uri 55 | base58 56 | ) 57 | (tags (crypto bitcoin))) 58 | -------------------------------------------------------------------------------- /lib/block.ml: -------------------------------------------------------------------------------- 1 | open Sexplib.Std 2 | open Util 3 | module CS = Bitcoin_cstruct 4 | 5 | type t = 6 | { header : Header.t 7 | ; txns : Transaction.t list 8 | } 9 | [@@deriving sexp] 10 | 11 | let pp ppf t = Sexplib.Sexp.pp_hum ppf (sexp_of_t t) 12 | let show t = Format.asprintf "%a" pp t 13 | 14 | let of_cstruct cs = 15 | let header, cs = Header.of_cstruct cs in 16 | let txns, cs = ObjList.of_cstruct ~f:Transaction.of_cstruct cs in 17 | { header; txns }, cs 18 | ;; 19 | -------------------------------------------------------------------------------- /lib/block.mli: -------------------------------------------------------------------------------- 1 | module CS = Bitcoin_cstruct 2 | 3 | type t = 4 | { header : Header.t 5 | ; txns : Transaction.t list 6 | } 7 | [@@deriving sexp] 8 | 9 | val pp : Format.formatter -> t -> unit 10 | val show : t -> string 11 | val of_cstruct : Cstruct.t -> t * Cstruct.t 12 | -------------------------------------------------------------------------------- /lib/bloom.ml: -------------------------------------------------------------------------------- 1 | open Sexplib.Std 2 | open Util 3 | 4 | let bytes_max = 36000 5 | let funcs_max = 50 6 | let seed_mult = 0xfba4c795l 7 | 8 | type t = 9 | { filter : Bitv.t 10 | ; len : int 11 | ; nb_funcs : int 12 | ; tweak : int32 13 | } 14 | [@@deriving sexp] 15 | 16 | (* let filter_len { filter; _ } = 17 | * Bitv.length filter / 8 *) 18 | 19 | let to_filter { filter; _ } = 20 | try Bitv.to_string_le filter with 21 | | _ -> invalid_arg "Bloom.to_string" 22 | ;; 23 | 24 | let pp_hex ppf t = 25 | let (`Hex filter_hex) = Hex.of_string (to_filter t) in 26 | Format.fprintf ppf "%s" filter_hex 27 | ;; 28 | 29 | let of_filter filter nb_funcs tweak = 30 | let len = String.length filter in 31 | if len > bytes_max || nb_funcs > funcs_max then invalid_arg "Bloom.of_filter"; 32 | { filter = Bitv.of_string_le filter; len; nb_funcs; tweak } 33 | ;; 34 | 35 | let create n p tweak = 36 | let n = Float.of_int n in 37 | let filter_len_bytes = 38 | let open Float in 39 | min (-1. /. (log 2. *. log 2.) *. n *. log p /. 8.) (of_int bytes_max) |> to_int 40 | in 41 | let nb_funcs = 42 | let open Float in 43 | min (of_int filter_len_bytes *. 8. /. n *. log 2.) (of_int funcs_max) |> to_int 44 | in 45 | { filter = Bitv.create (filter_len_bytes * 8) false 46 | ; len = filter_len_bytes 47 | ; nb_funcs 48 | ; tweak 49 | } 50 | ;; 51 | 52 | let reset t = { t with filter = Bitv.(create (length t.filter) false) } 53 | 54 | let hash { filter; tweak; len; _ } data func_id = 55 | let res = Cstruct.create 4 in 56 | let seed = Int32.(add (mul (of_int func_id) seed_mult) tweak) in 57 | Murmur3.Murmur_cstruct.murmur_x86_32 res data seed; 58 | let open Stdint in 59 | let res = Uint32.of_int32 (Cstruct.LE.get_uint32 res 0) in 60 | let filter_size = Uint32.of_int (len * 8) in 61 | let i = Uint32.(rem res filter_size |> to_int) in 62 | Bitv.set filter i true 63 | ;; 64 | 65 | let add ({ nb_funcs; _ } as t) data = 66 | for i = 0 to nb_funcs - 1 do 67 | hash t data i 68 | done 69 | ;; 70 | 71 | let mem t data = 72 | let empty = reset t in 73 | add empty data; 74 | let bitv_and = Bitv.bw_and empty.filter t.filter in 75 | Stdlib.( = ) bitv_and empty.filter 76 | ;; 77 | 78 | let _ = 79 | let data_hex = 80 | `Hex "019f5b01d4195ecbc9398fbf3c3b1fa9bb3183301d7a1fb3bd174fcfa40a2b65" 81 | in 82 | let data = Hex.to_string data_hex |> Cstruct.of_string in 83 | let bloom = create 1 0.0001 0l in 84 | add bloom data; 85 | let filter = to_filter bloom in 86 | let filter2 = of_filter filter bloom.nb_funcs bloom.tweak in 87 | let (`Hex msg) = Hex.of_string filter in 88 | Printf.printf "%s\n%!" msg; 89 | assert (filter2 = bloom) 90 | ;; 91 | -------------------------------------------------------------------------------- /lib/bloom.mli: -------------------------------------------------------------------------------- 1 | type t = private 2 | { filter : Bitv.t 3 | ; len : int 4 | ; nb_funcs : int 5 | ; tweak : Int32.t 6 | } 7 | [@@deriving sexp] 8 | 9 | val pp_hex : t Fmt.t 10 | 11 | (** [create max_elts false_pos_rate tweak] is a bloom filter 12 | configured to hold a maximum of [max_elts] for a false positive 13 | rate below [false_pos_rate]. *) 14 | val create : int -> float -> Int32.t -> t 15 | 16 | (** [to_filter t] is the serialized bit vector (FilterLoad "filter" 17 | field). *) 18 | val to_filter : t -> string 19 | 20 | (** [import bitv nb_funcs tweak] imports a bloom filter from a 21 | FilterLoad message. *) 22 | val of_filter : string -> int -> Int32.t -> t 23 | 24 | val reset : t -> t 25 | val add : t -> Cstruct.t -> unit 26 | val mem : t -> Cstruct.t -> bool 27 | -------------------------------------------------------------------------------- /lib/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name bitcoin) 3 | (public_name bitcoin) 4 | (preprocess (pps ppx_sexp_conv)) 5 | (libraries 6 | fmt 7 | cstruct-sexp 8 | sexplib 9 | rresult 10 | bitcoin_cstruct 11 | stdint 12 | ocplib-endian 13 | ipaddr 14 | ipaddr-sexp 15 | ptime 16 | ptime.clock.os 17 | cstruct 18 | hex 19 | bitv 20 | murmur3 21 | digestif.c 22 | secp256k1-internal 23 | base58)) 24 | -------------------------------------------------------------------------------- /lib/header.ml: -------------------------------------------------------------------------------- 1 | open Sexplib.Std 2 | open Util 3 | module CS = Bitcoin_cstruct 4 | 5 | type t = 6 | { version : int32 7 | ; prev_block : Hash256.t 8 | ; merkle_root : Hash256.t 9 | ; timestamp : Timestamp.t 10 | ; bits : int32 11 | ; nonce : int32 12 | } 13 | [@@deriving sexp] 14 | 15 | let genesis = 16 | { version = 1l 17 | ; prev_block = Hash256.empty 18 | ; merkle_root = 19 | Hash256.of_hex_internal 20 | (`Hex "3BA3EDFD7A7B12B27AC72C3E67768F617FC81BC3888A51323A9FB8AA4B1E5E4A") 21 | ; timestamp = Timestamp.of_int_sec 1231006505 22 | ; bits = 0x1d00ffffl 23 | ; nonce = 2083236893l 24 | } 25 | ;; 26 | 27 | let of_cstruct cs = 28 | let open CS.Header in 29 | let version = get_t_version cs in 30 | let prev_block, _ = get_t_prev_block cs |> Hash256.of_cstruct in 31 | let merkle_root, _ = get_t_merkle_root cs |> Hash256.of_cstruct in 32 | let timestamp = get_t_timestamp cs |> Timestamp.of_int32_sec in 33 | let bits = get_t_bits cs in 34 | let nonce = get_t_nonce cs in 35 | { version; prev_block; merkle_root; timestamp; bits; nonce }, Cstruct.shift cs sizeof_t 36 | ;; 37 | 38 | let of_cstruct_txcount cs = 39 | let t, cs = of_cstruct cs in 40 | t, Cstruct.shift cs 1 41 | ;; 42 | 43 | let to_cstruct cs { version; prev_block; merkle_root; timestamp; bits; nonce } = 44 | let open CS.Header in 45 | set_t_version cs version; 46 | set_t_prev_block (Hash256.to_string prev_block) 0 cs; 47 | set_t_merkle_root (Hash256.to_string merkle_root) 0 cs; 48 | set_t_timestamp cs (Timestamp.to_int32_sec timestamp); 49 | set_t_bits cs bits; 50 | set_t_nonce cs nonce; 51 | Cstruct.shift cs sizeof_t 52 | ;; 53 | 54 | let size = CS.Header.sizeof_t 55 | 56 | let hash256 t = 57 | let cs = Cstruct.create size in 58 | let _ = to_cstruct cs t in 59 | Hash256.compute_cstruct cs 60 | ;; 61 | 62 | let compare = Stdlib.compare 63 | let equal = Stdlib.( = ) 64 | 65 | (* let hash t = *) 66 | (* let Hash256.Hash s = hash256 t in *) 67 | (* let i32 = EndianString.BigEndian.get_int32 s 0 in *) 68 | (* Int32.(i32 lsr 1 |> to_int_exn) *) 69 | 70 | let genesis_hash = hash256 genesis 71 | -------------------------------------------------------------------------------- /lib/header.mli: -------------------------------------------------------------------------------- 1 | open Util 2 | 3 | type t = 4 | { version : Int32.t 5 | ; prev_block : Hash256.t 6 | ; merkle_root : Hash256.t 7 | ; timestamp : Timestamp.t 8 | ; bits : Int32.t 9 | ; nonce : Int32.t 10 | } 11 | [@@deriving sexp] 12 | 13 | val genesis : t 14 | val genesis_hash : Hash256.t 15 | val compare : t -> t -> int 16 | val equal : t -> t -> bool 17 | (* val hash : t -> int *) 18 | 19 | val of_cstruct : Cstruct.t -> t * Cstruct.t 20 | 21 | (** For reading headers from a Header P2P message. *) 22 | val of_cstruct_txcount : Cstruct.t -> t * Cstruct.t 23 | 24 | val to_cstruct : Cstruct.t -> t -> Cstruct.t 25 | 26 | (** Serialized size *) 27 | val size : int 28 | 29 | val hash256 : t -> Hash256.t 30 | -------------------------------------------------------------------------------- /lib/merkle.ml: -------------------------------------------------------------------------------- 1 | open Util 2 | open P2p 3 | 4 | type t = 5 | | Empty 6 | | Node of t * Hash256.t * t 7 | 8 | let node l h r = Node (l, h, r) 9 | let leaf h = Node (Empty, h, Empty) 10 | 11 | let compute a b = 12 | match a, b with 13 | | Node (_, h1, _), Node (_, h2, _) -> Hash256.compute_concat h1 h2 14 | | _ -> invalid_arg "Merkle.compute" 15 | ;; 16 | 17 | let depth n = 18 | let rec inner acc n = if n = 0 then acc else inner (succ acc) (n / 2) in 19 | inner 0 (if n mod 2 = 0 then n else succ n) 20 | ;; 21 | 22 | let verify max_depth hashes flags = 23 | let rec inner depth hashes flags = 24 | match flags, depth, hashes with 25 | | false :: flags, _, h :: hashes -> node Empty h Empty, hashes, flags 26 | | true :: flags, _, _ when depth < max_depth -> 27 | let l, hashes, flags = inner (succ depth) hashes flags in 28 | let r, hashes, flags = inner (succ depth) hashes flags in 29 | node l (compute l r) r, hashes, flags 30 | | true :: flags, _, h :: hashes -> leaf h, hashes, flags 31 | | _ -> invalid_arg "Merkle.verify" 32 | in 33 | inner 0 hashes flags 34 | ;; 35 | 36 | let verify { MerkleBlock.header; txn_count; hashes; flags } = 37 | let flags = Bitv.to_bool_list flags in 38 | let depth = depth txn_count in 39 | match verify depth hashes flags with 40 | | Node (_, h, _), _, _ -> Hash256.equal header.merkle_root h 41 | | _ -> invalid_arg "Merkle.verify" 42 | ;; 43 | -------------------------------------------------------------------------------- /lib/merkle.mli: -------------------------------------------------------------------------------- 1 | open P2p 2 | 3 | val verify : MerkleBlock.t -> bool 4 | -------------------------------------------------------------------------------- /lib/outpoint.ml: -------------------------------------------------------------------------------- 1 | open Sexplib.Std 2 | open Util 3 | module CS = Bitcoin_cstruct 4 | 5 | type t = 6 | { hash : Hash256.t 7 | ; i : int 8 | } 9 | [@@deriving sexp] 10 | 11 | let pp ppf { hash; i } = Format.fprintf ppf "%a %d" Hash256.pp hash i 12 | let show { hash; i } = Format.asprintf "%a %d" Hash256.pp hash i 13 | let create hash i = { hash; i } 14 | let size = CS.Outpoint.sizeof_t 15 | 16 | let of_cstruct cs = 17 | let open CS.Outpoint in 18 | let hash, _ = get_t_hash cs |> Hash256.of_cstruct in 19 | let i = get_t_index cs |> Int32.to_int in 20 | { hash; i }, Cstruct.shift cs sizeof_t 21 | ;; 22 | 23 | let to_cstruct cs { hash = Hash payload; i } = 24 | let open CS.Outpoint in 25 | set_t_hash payload 0 cs; 26 | set_t_index cs (Int32.of_int i); 27 | Cstruct.shift cs size 28 | ;; 29 | -------------------------------------------------------------------------------- /lib/outpoint.mli: -------------------------------------------------------------------------------- 1 | open Util 2 | 3 | type t = 4 | { hash : Hash256.t 5 | ; i : int 6 | } 7 | [@@deriving sexp] 8 | 9 | (* val pp : Format.formatter -> t -> unit 10 | * val show : t -> string *) 11 | 12 | val create : Hash256.t -> int -> t 13 | val of_cstruct : Cstruct.t -> t * Cstruct.t 14 | val to_cstruct : Cstruct.t -> t -> Cstruct.t 15 | val pp : Format.formatter -> t -> unit 16 | val show : t -> string 17 | val size : int 18 | -------------------------------------------------------------------------------- /lib/p2p.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2017 Vincent Bernardoff. All rights reserved. 3 | Distributed under the GNU Affero GPL license, see LICENSE. 4 | ---------------------------------------------------------------------------*) 5 | 6 | open Util 7 | open Sexplib.Std 8 | open StdLabels 9 | module CS = Bitcoin_cstruct 10 | 11 | module Network = struct 12 | type t = 13 | | Mainnet 14 | | Testnet 15 | | Regtest 16 | [@@deriving sexp] 17 | 18 | let pp ppf = function 19 | | Mainnet -> Format.pp_print_string ppf "Mainnet" 20 | | Testnet -> Format.pp_print_string ppf "Testnet" 21 | | Regtest -> Format.pp_print_string ppf "Regtest" 22 | ;; 23 | 24 | let show t = Format.asprintf "%a" pp t 25 | 26 | let seed = function 27 | | Mainnet -> [ "seed.bitcoin.sipa.be"; "dnsseed.bluematt.me" ] 28 | | Testnet -> [ "seed.tbtc.petertodd.org"; "testnet-seed.bitcoin.jonasschnelli.ch" ] 29 | | _ -> invalid_arg "Network.seed" 30 | ;; 31 | 32 | let port = function 33 | | Mainnet -> 8333 34 | | Testnet -> 18333 35 | | Regtest -> 18444 36 | ;; 37 | 38 | let start_string = function 39 | | Mainnet -> "\xf9\xbe\xb4\xd9" 40 | | Testnet -> "\x0b\x11\x09\x07" 41 | | Regtest -> "\xfa\xbf\xb5\xda" 42 | ;; 43 | 44 | let max_nBits = function 45 | | Mainnet -> 0x1d00ffffl 46 | | Testnet -> 0x1d00ffffl 47 | | Regtest -> 0x207fffffl 48 | ;; 49 | 50 | let of_start_string = function 51 | | "\xf9\xbe\xb4\xd9" -> Mainnet 52 | | "\x0b\x11\x09\x07" -> Testnet 53 | | "\xfa\xbf\xb5\xda" -> Regtest 54 | | s -> invalid_arg ("Network.of_start_string: got " ^ String.escaped s) 55 | ;; 56 | 57 | let of_cstruct cs = of_start_string (Cstruct.to_string cs) 58 | end 59 | 60 | module MessageName = struct 61 | type t = 62 | | Block 63 | | GetBlocks 64 | | GetData 65 | | GetHeaders 66 | | Headers 67 | | Inv 68 | | MemPool 69 | | MerkleBlock 70 | | NotFound 71 | | Tx 72 | | Addr 73 | | Alert 74 | | FeeFilter 75 | | FilterAdd 76 | | FilterClear 77 | | FilterLoad 78 | | GetAddr 79 | | Ping 80 | | Pong 81 | | Reject 82 | | SendHeaders 83 | | VerAck 84 | | Version 85 | | SendCmpct 86 | [@@deriving sexp] 87 | 88 | let of_string = function 89 | | "block" -> Block 90 | | "getblocks" -> GetBlocks 91 | | "getdata" -> GetData 92 | | "getheaders" -> GetHeaders 93 | | "headers" -> Headers 94 | | "inv" -> Inv 95 | | "mempool" -> MemPool 96 | | "merkleblock" -> MerkleBlock 97 | | "notfound" -> NotFound 98 | | "tx" -> Tx 99 | | "addr" -> Addr 100 | | "alert" -> Alert 101 | | "feefilter" -> FeeFilter 102 | | "filteradd" -> FilterAdd 103 | | "filterclear" -> FilterClear 104 | | "filterload" -> FilterLoad 105 | | "getaddr" -> GetAddr 106 | | "ping" -> Ping 107 | | "pong" -> Pong 108 | | "reject" -> Reject 109 | | "sendheaders" -> SendHeaders 110 | | "verack" -> VerAck 111 | | "version" -> Version 112 | | "sendcmpct" -> SendCmpct 113 | | s -> invalid_arg ("MessageName.of_string: " ^ s) 114 | ;; 115 | 116 | let to_string = function 117 | | Block -> "block" 118 | | GetBlocks -> "getblocks" 119 | | GetData -> "getdata" 120 | | GetHeaders -> "getheaders" 121 | | Headers -> "headers" 122 | | Inv -> "inv" 123 | | MemPool -> "mempool" 124 | | MerkleBlock -> "merkleblock" 125 | | NotFound -> "notfound" 126 | | Tx -> "tx" 127 | | Addr -> "addr" 128 | | Alert -> "alert" 129 | | FeeFilter -> "feefilter" 130 | | FilterAdd -> "filteradd" 131 | | FilterClear -> "filterclear" 132 | | FilterLoad -> "filterload" 133 | | GetAddr -> "getaddr" 134 | | Ping -> "ping" 135 | | Pong -> "pong" 136 | | Reject -> "reject" 137 | | SendHeaders -> "sendheaders" 138 | | VerAck -> "verack" 139 | | Version -> "version" 140 | | SendCmpct -> "sendcmpct" 141 | ;; 142 | 143 | let of_cstruct cs = c_string_of_cstruct cs |> of_string 144 | let pp ppf s = Format.pp_print_string ppf (to_string s) 145 | let show = to_string 146 | end 147 | 148 | module GetHashes = struct 149 | type t = 150 | { version : int 151 | ; hashes : Hash256.t list 152 | ; stop_hash : Hash256.t 153 | } 154 | [@@deriving sexp] 155 | 156 | let create ?(version = 75015) ?(stop_hash = Hash256.empty) hashes = 157 | { version; hashes; stop_hash } 158 | ;; 159 | 160 | let rec read_hash acc cs = function 161 | | 0 -> List.rev acc, cs 162 | | n -> 163 | let h, cs = Hash256.of_cstruct cs in 164 | read_hash (h :: acc) cs (pred n) 165 | ;; 166 | 167 | let of_cstruct cs = 168 | let open Cstruct in 169 | let version = LE.get_uint32 cs 0 |> Int32.to_int in 170 | let cs = shift cs 4 in 171 | let nb_hashes, cs = CompactSize.of_cstruct_int cs in 172 | let hashes, cs = read_hash [] cs nb_hashes in 173 | let stop_hash, cs = Hash256.of_cstruct cs in 174 | { version; hashes; stop_hash }, cs 175 | ;; 176 | 177 | let of_cstruct_only_hashes cs = 178 | let nb_hashes, cs = CompactSize.of_cstruct_int cs in 179 | let hashes, cs = read_hash [] cs nb_hashes in 180 | hashes, cs 181 | ;; 182 | 183 | let to_cstruct cs { version; hashes; stop_hash } = 184 | let open Cstruct in 185 | LE.set_uint32 cs 0 (Int32.of_int version); 186 | let nb_hashes = List.length hashes in 187 | let cs = shift cs 4 in 188 | let cs = CompactSize.to_cstruct_int cs nb_hashes in 189 | let cs = List.fold_left hashes ~init:cs ~f:(fun cs h -> Hash256.to_cstruct cs h) in 190 | Hash256.to_cstruct cs stop_hash 191 | ;; 192 | end 193 | 194 | module MessageHeader = struct 195 | type t = 196 | { network : Network.t 197 | ; msgname : MessageName.t 198 | ; size : int 199 | ; checksum : string 200 | } 201 | [@@deriving sexp] 202 | 203 | let size = CS.MessageHeader.sizeof_t 204 | let empty_checksum = "\x5d\xf6\xe0\xe2" 205 | let version ~network = { network; msgname = Version; size = 0; checksum = "" } 206 | let verack ~network = { network; msgname = VerAck; size = 0; checksum = empty_checksum } 207 | let pong ~network = { network; msgname = Pong; size = 8; checksum = "" } 208 | let getheaders ~network = { network; msgname = GetHeaders; size = 0; checksum = "" } 209 | let filterload ~network = { network; msgname = FilterLoad; size = 0; checksum = "" } 210 | let getdata ~network = { network; msgname = GetData; size = 0; checksum = "" } 211 | 212 | let of_cstruct cs = 213 | let open CS.MessageHeader in 214 | let network = get_t_start_string cs |> Network.of_cstruct in 215 | let msgname = get_t_command_name cs |> MessageName.of_cstruct in 216 | let size = get_t_payload_size cs |> Int32.to_int in 217 | let checksum = get_t_checksum cs |> Cstruct.to_string in 218 | { network; msgname; size; checksum }, Cstruct.shift cs sizeof_t 219 | ;; 220 | 221 | let to_cstruct cs t = 222 | let open CS.MessageHeader in 223 | set_t_start_string (Network.start_string t.network) 0 cs; 224 | set_t_command_name (MessageName.to_string t.msgname |> bytes_with_msg ~len:12) 0 cs; 225 | set_t_payload_size cs (Int32.of_int t.size); 226 | set_t_checksum t.checksum 0 cs; 227 | Cstruct.shift cs sizeof_t 228 | ;; 229 | end 230 | 231 | module Service = struct 232 | type t = 233 | | Network 234 | | Getutxo 235 | | Bloom 236 | [@@deriving sexp] 237 | 238 | let of_int64 v = 239 | let open Int64 in 240 | List.filter_map 241 | ~f:(fun a -> a) 242 | [ (if logand v 1L <> 0L then Some Network else None) 243 | ; (if logand v 2L <> 0L then Some Getutxo else None) 244 | ; (if logand v 4L <> 0L then Some Bloom else None) 245 | ] 246 | ;; 247 | 248 | let to_int64 = function 249 | | Network -> 1L 250 | | Getutxo -> 2L 251 | | Bloom -> 4L 252 | ;; 253 | 254 | let to_int64 = 255 | List.fold_left ~init:0L ~f:(fun a l -> 256 | let l = to_int64 l in 257 | Int64.logor a l) 258 | ;; 259 | end 260 | 261 | module Version = struct 262 | type t = 263 | { version : int 264 | ; services : Service.t list 265 | ; timestamp : Timestamp.t 266 | ; recv_services : Service.t list 267 | ; recv_ipaddr : Ipaddr_sexp.V6.t 268 | ; recv_port : int 269 | ; trans_services : Service.t list 270 | ; trans_ipaddr : Ipaddr_sexp.V6.t 271 | ; trans_port : int 272 | ; nonce : int64 273 | ; user_agent : string 274 | ; start_height : int 275 | ; relay : bool 276 | } 277 | [@@deriving sexp] 278 | 279 | let create 280 | ?(version = 70015) 281 | ?(services = []) 282 | ?(timestamp = Timestamp.now ()) 283 | ?(recv_services = [ Service.Network ]) 284 | ?(recv_ipaddr = Ipaddr.V6.localhost) 285 | ~recv_port 286 | ?(trans_services = []) 287 | ?(trans_ipaddr = Ipaddr.V6.localhost) 288 | ~trans_port 289 | ?(nonce = Int64.of_int (Random.bits ())) 290 | ?(user_agent = "/OCamlBitcoin:0.1/") 291 | ?(start_height = 0) 292 | ?(relay = false) 293 | () 294 | = 295 | { version 296 | ; services 297 | ; timestamp 298 | ; recv_services 299 | ; recv_ipaddr 300 | ; recv_port 301 | ; trans_services 302 | ; trans_ipaddr 303 | ; trans_port 304 | ; nonce 305 | ; user_agent 306 | ; start_height 307 | ; relay 308 | } 309 | ;; 310 | 311 | let of_cstruct cs = 312 | let open CS.Version in 313 | let version = get_t_version cs |> Int32.to_int in 314 | let services = get_t_services cs |> Service.of_int64 in 315 | let timestamp = get_t_timestamp cs |> Timestamp.of_int64_sec in 316 | let recv_services = get_t_recv_services cs |> Service.of_int64 in 317 | let recv_ipaddr = 318 | get_t_recv_ipaddr cs |> Cstruct.to_string |> Ipaddr.V6.of_octets_exn 319 | in 320 | let recv_port = Cstruct.BE.get_uint16 (get_t_recv_port cs) 0 in 321 | let trans_services = get_t_trans_services cs |> Service.of_int64 in 322 | let trans_ipaddr = 323 | get_t_trans_ipaddr cs |> Cstruct.to_string |> Ipaddr.V6.of_octets_exn 324 | in 325 | let trans_port = Cstruct.BE.get_uint16 (get_t_trans_port cs) 0 in 326 | let nonce = get_t_nonce cs in 327 | let cs = Cstruct.shift cs sizeof_t in 328 | let user_agent, cs = VarString.of_cstruct cs in 329 | let start_height = Cstruct.LE.get_uint32 cs 0 |> Int32.to_int in 330 | let relay = 331 | match Cstruct.get_uint8 cs 4 with 332 | | exception _ -> true 333 | | 0x01 -> true 334 | | 0x00 -> false 335 | | _ -> invalid_arg "Version.of_cstruct: unsupported value for relay field" 336 | in 337 | ( { version 338 | ; services 339 | ; timestamp 340 | ; recv_services 341 | ; recv_ipaddr 342 | ; recv_port 343 | ; trans_services 344 | ; trans_ipaddr 345 | ; trans_port 346 | ; nonce 347 | ; user_agent 348 | ; start_height 349 | ; relay 350 | } 351 | , Cstruct.shift cs 5 ) 352 | ;; 353 | 354 | let to_cstruct cs msg = 355 | let open CS.Version in 356 | set_t_version cs (Int32.of_int msg.version); 357 | set_t_services cs (Service.to_int64 msg.services); 358 | set_t_timestamp cs (Timestamp.to_int64_sec msg.timestamp); 359 | set_t_recv_services cs (Service.to_int64 msg.recv_services); 360 | set_t_recv_ipaddr (Ipaddr.V6.to_octets msg.recv_ipaddr) 0 cs; 361 | Cstruct.BE.set_uint16 (get_t_recv_port cs) 0 msg.recv_port; 362 | set_t_trans_services cs (Service.to_int64 msg.trans_services); 363 | set_t_trans_ipaddr (Ipaddr.V6.to_octets msg.trans_ipaddr) 0 cs; 364 | Cstruct.BE.set_uint16 (get_t_trans_port cs) 0 msg.trans_port; 365 | set_t_nonce cs msg.nonce; 366 | let cs = Cstruct.shift cs sizeof_t in 367 | let cs = VarString.to_cstruct cs msg.user_agent in 368 | Cstruct.LE.set_uint32 cs 0 (Int32.of_int msg.start_height); 369 | Cstruct.set_uint8 cs 4 (if msg.relay then 0x01 else 0x00); 370 | Cstruct.shift cs 5 371 | ;; 372 | end 373 | 374 | module Address = struct 375 | type t = 376 | { timestamp : Timestamp.t 377 | ; services : Service.t list 378 | ; ipaddr : Ipaddr_sexp.V6.t 379 | ; port : int 380 | } 381 | [@@deriving sexp] 382 | 383 | let of_cstruct cs = 384 | let open CS.Address in 385 | let timestamp = get_t_timestamp cs |> Timestamp.of_int32_sec in 386 | let services = get_t_services cs |> Service.of_int64 in 387 | let ipaddr = get_t_ipaddr cs |> Cstruct.to_string |> Ipaddr.V6.of_octets_exn in 388 | let port = Cstruct.BE.get_uint16 (get_t_port cs) 0 in 389 | { timestamp; services; ipaddr; port }, Cstruct.shift cs sizeof_t 390 | ;; 391 | end 392 | 393 | module Inv = struct 394 | type id = 395 | | Tx 396 | | Block 397 | | FilteredBlock 398 | [@@deriving sexp] 399 | 400 | let id_of_int32 = function 401 | | 1l -> Tx 402 | | 2l -> Block 403 | | 3l -> FilteredBlock 404 | | _ -> invalid_arg "Inv.id_of_int32" 405 | ;; 406 | 407 | let int32_of_id = function 408 | | Tx -> 1l 409 | | Block -> 2l 410 | | FilteredBlock -> 3l 411 | ;; 412 | 413 | type t = 414 | { id : id 415 | ; hash : Hash256.t 416 | } 417 | [@@deriving sexp] 418 | 419 | let size = CS.Inv.sizeof_t 420 | let tx hash = { id = Tx; hash } 421 | let block hash = { id = Block; hash } 422 | let filteredblock hash = { id = FilteredBlock; hash } 423 | 424 | let of_cstruct cs = 425 | let open CS.Inv in 426 | let id = get_t_id cs |> id_of_int32 in 427 | let hash, _ = get_t_hash cs |> Hash256.of_cstruct in 428 | { id; hash }, Cstruct.shift cs sizeof_t 429 | ;; 430 | 431 | let to_cstruct cs { id; hash } = 432 | let open CS.Inv in 433 | set_t_id cs (int32_of_id id); 434 | set_t_hash (Hash256.to_string hash) 0 cs; 435 | Cstruct.shift cs size 436 | ;; 437 | end 438 | 439 | module PingPong = struct 440 | let of_cstruct cs = Cstruct.(LE.get_uint64 cs 0, shift cs 8) 441 | end 442 | 443 | module MerkleBlock = struct 444 | type t = 445 | { header : Header.t 446 | ; txn_count : int 447 | ; hashes : Hash256.t list 448 | ; flags : Bitv.t 449 | } 450 | [@@deriving sexp] 451 | 452 | let of_cstruct cs = 453 | let header, cs = Header.of_cstruct cs in 454 | let txn_count = Cstruct.LE.get_uint32 cs 0 |> Int32.to_int in 455 | let cs = Cstruct.shift cs 4 in 456 | let hashes, cs = GetHashes.of_cstruct_only_hashes cs in 457 | let flags_len, cs = CompactSize.of_cstruct_int cs in 458 | let flags = Cstruct.(sub cs 0 flags_len |> to_string |> Bitv.of_string_le) in 459 | { header; txn_count; hashes; flags }, Cstruct.shift cs flags_len 460 | ;; 461 | end 462 | 463 | module FeeFilter = struct 464 | let of_cstruct cs = Cstruct.(LE.get_uint64 cs 0, shift cs 8) 465 | end 466 | 467 | module FilterAdd = struct 468 | let of_cstruct cs = 469 | let nb_bytes, cs = CompactSize.of_cstruct_int cs in 470 | Cstruct.(sub cs 0 nb_bytes |> to_string, shift cs nb_bytes) 471 | ;; 472 | 473 | (* let to_cstruct cs data = 474 | * let datalen = String.length data in 475 | * let cs = CompactSize.to_cstruct_int cs datalen in 476 | * Cstruct.blit_from_string data 0 cs 0 datalen ; 477 | * Cstruct.shift cs datalen *) 478 | end 479 | 480 | module FilterLoad = struct 481 | type flag = 482 | | Update_none 483 | | Update_all 484 | | Update_p2pkh_only 485 | [@@deriving sexp] 486 | 487 | let flag_of_int = function 488 | | 0 -> Update_none 489 | | 1 -> Update_all 490 | | 2 -> Update_p2pkh_only 491 | | _ -> invalid_arg "FilterLoad.flag_of_int" 492 | ;; 493 | 494 | let int_of_flag = function 495 | | Update_none -> 0 496 | | Update_all -> 1 497 | | Update_p2pkh_only -> 2 498 | ;; 499 | 500 | type t = 501 | { filter : Bloom.t 502 | ; flag : flag 503 | } 504 | [@@deriving sexp] 505 | 506 | let of_data 507 | ?(false_pos_rate = 0.0001) 508 | ?(tweak = Random.int32 Int32.max_int) 509 | elts 510 | ?(nb_elts = List.length elts) 511 | flag 512 | = 513 | let filter = Bloom.create nb_elts false_pos_rate tweak in 514 | List.iter elts ~f:(Bloom.add filter); 515 | { filter; flag } 516 | ;; 517 | 518 | let of_cstruct cs = 519 | let nb_bytes, cs = CompactSize.of_cstruct_int cs in 520 | let filter, cs = Cstruct.(sub cs 0 nb_bytes |> to_string, shift cs nb_bytes) in 521 | let nb_funcs = Cstruct.LE.get_uint32 cs 0 |> Int32.to_int in 522 | let tweak = Cstruct.LE.get_uint32 cs 4 in 523 | let flag = Cstruct.get_uint8 cs 8 |> flag_of_int in 524 | let filter = Bloom.of_filter filter nb_funcs tweak in 525 | { filter; flag }, Cstruct.shift cs 9 526 | ;; 527 | 528 | let to_cstruct cs { filter; flag } = 529 | let cs = CompactSize.to_cstruct_int cs filter.len in 530 | let filter_bytes = Bloom.to_filter filter in 531 | Cstruct.blit_from_string filter_bytes 0 cs 0 filter.len; 532 | let cs = Cstruct.shift cs filter.len in 533 | Cstruct.LE.set_uint32 cs 0 (Int32.of_int filter.nb_funcs); 534 | let cs = Cstruct.shift cs 4 in 535 | Cstruct.LE.set_uint32 cs 0 filter.tweak; 536 | let cs = Cstruct.shift cs 4 in 537 | Cstruct.set_uint8 cs 0 (int_of_flag flag); 538 | Cstruct.shift cs 1 539 | ;; 540 | end 541 | 542 | module Reject = struct 543 | module Code = struct 544 | type t = 545 | | Decode_error 546 | | Invalid_block of Hash256.t 547 | | Invalid_transaction of Hash256.t 548 | | Block_version_too_old of Hash256.t 549 | | Protocol_too_old 550 | | Double_spend of Hash256.t 551 | | Too_many_version_messages 552 | | Non_standard_transaction of Hash256.t 553 | | Dust of Hash256.t 554 | | Fee_too_low of Hash256.t 555 | | Wrong_blockchain of Hash256.t 556 | [@@deriving sexp] 557 | 558 | let pp ppf = function 559 | | Decode_error -> Format.fprintf ppf "decode error" 560 | | Invalid_block h -> Format.fprintf ppf "invalid block %a" Hash256.pp h 561 | | Invalid_transaction h -> Format.fprintf ppf "invalid transaction %a" Hash256.pp h 562 | | Block_version_too_old h -> 563 | Format.fprintf ppf "block version too old %a" Hash256.pp h 564 | | Protocol_too_old -> Format.fprintf ppf "protocol too old" 565 | | Double_spend h -> Format.fprintf ppf "double spend %a" Hash256.pp h 566 | | Too_many_version_messages -> Format.fprintf ppf "too many version messages" 567 | | Non_standard_transaction h -> 568 | Format.fprintf ppf "non standard transaction %a" Hash256.pp h 569 | | Dust h -> Format.fprintf ppf "dust %a" Hash256.pp h 570 | | Fee_too_low h -> Format.fprintf ppf "fee too low %a" Hash256.pp h 571 | | Wrong_blockchain h -> Format.fprintf ppf "wrong blockchain %a" Hash256.pp h 572 | ;; 573 | 574 | (* let show t = Format.asprintf "%a" pp t *) 575 | end 576 | 577 | type t = 578 | { message : MessageName.t 579 | ; code : Code.t 580 | ; reason : string 581 | } 582 | [@@deriving sexp] 583 | 584 | let pp ppf { message; code; reason } = 585 | Format.fprintf ppf "Reject %a (%a) (%s)" MessageName.pp message Code.pp code reason 586 | ;; 587 | 588 | let show t = Format.asprintf "%a" pp t 589 | 590 | let code_of_cs code rejected_message cs = 591 | let open Code in 592 | match code, rejected_message with 593 | | 0x01, _ -> Decode_error, cs 594 | | 0x10, MessageName.Block -> 595 | let hash, cs = Hash256.of_cstruct cs in 596 | Invalid_block hash, cs 597 | | 0x10, Tx -> 598 | let hash, cs = Hash256.of_cstruct cs in 599 | Invalid_transaction hash, cs 600 | | 0x11, Block -> 601 | let hash, cs = Hash256.of_cstruct cs in 602 | Block_version_too_old hash, cs 603 | | 0x11, Version -> Protocol_too_old, cs 604 | | 0x12, Tx -> 605 | let hash, cs = Hash256.of_cstruct cs in 606 | Double_spend hash, cs 607 | | 0x12, Version -> Too_many_version_messages, cs 608 | | 0x40, Tx -> 609 | let hash, cs = Hash256.of_cstruct cs in 610 | Non_standard_transaction hash, cs 611 | | 0x41, Tx -> 612 | let hash, cs = Hash256.of_cstruct cs in 613 | Dust hash, cs 614 | | 0x42, Tx -> 615 | let hash, cs = Hash256.of_cstruct cs in 616 | Fee_too_low hash, cs 617 | | 0x43, Block -> 618 | let hash, cs = Hash256.of_cstruct cs in 619 | Wrong_blockchain hash, cs 620 | | _ -> failwith "Unsupported" 621 | ;; 622 | 623 | let of_cstruct cs = 624 | let msg_name_len, cs = CompactSize.of_cstruct_int cs in 625 | let msg_name = Cstruct.(sub cs 0 msg_name_len |> to_string) in 626 | let cs = Cstruct.shift cs msg_name_len in 627 | let message = MessageName.of_string msg_name in 628 | let code = Cstruct.get_uint8 cs 0 in 629 | let cs = Cstruct.shift cs 1 in 630 | let reason_len, cs = CompactSize.of_cstruct_int cs in 631 | let reason = Cstruct.(sub cs 0 reason_len |> to_string) in 632 | let cs = Cstruct.shift cs reason_len in 633 | let code, cs = code_of_cs code message cs in 634 | { message; code; reason }, cs 635 | ;; 636 | end 637 | 638 | module SendCmpct = struct 639 | type t = 640 | { compact : bool 641 | ; version : int 642 | } 643 | [@@deriving sexp] 644 | 645 | let of_cstruct cs = 646 | let open CS.SendCmpct in 647 | let compact = get_t_b cs |> Bool.of_int in 648 | let version = get_t_version cs |> Int64.to_int in 649 | { compact; version }, Cstruct.shift cs sizeof_t 650 | ;; 651 | end 652 | 653 | module Message = struct 654 | type t = 655 | | Version of Version.t 656 | | VerAck 657 | | GetAddr 658 | | Addr of Address.t list 659 | | Ping of int64 660 | | Pong of int64 661 | | GetBlocks of GetHashes.t 662 | | GetData of Inv.t list 663 | | GetHeaders of GetHashes.t 664 | | Block of Block.t 665 | | MerkleBlock of MerkleBlock.t 666 | | Headers of Header.t list 667 | | Inv of Inv.t list 668 | | NotFound of Inv.t list 669 | | MemPool 670 | | SendHeaders 671 | | Tx of Transaction.t 672 | | FeeFilter of int64 673 | | FilterAdd of string 674 | | FilterClear 675 | | FilterLoad of FilterLoad.t 676 | | Reject of Reject.t 677 | | SendCmpct of SendCmpct.t 678 | [@@deriving sexp] 679 | 680 | type error = Invalid_checksum of MessageHeader.t 681 | 682 | let of_cstruct cs = 683 | let h, cs = MessageHeader.of_cstruct cs in 684 | let payload = Cstruct.sub cs 0 h.size in 685 | match Chksum.verify ~expected:h.checksum payload with 686 | | false -> Error (Invalid_checksum h), cs 687 | | true -> 688 | let msg, cs = 689 | match h.msgname with 690 | | Version -> 691 | let version, cs = Version.of_cstruct payload in 692 | Version version, cs 693 | | VerAck -> VerAck, cs 694 | | GetAddr -> GetAddr, cs 695 | | Addr -> 696 | let addrs, cs = ObjList.of_cstruct ~f:Address.of_cstruct payload in 697 | Addr addrs, cs 698 | | Ping -> 699 | let nonce, cs = PingPong.of_cstruct payload in 700 | Ping nonce, cs 701 | | Pong -> 702 | let nonce, cs = PingPong.of_cstruct payload in 703 | Pong nonce, cs 704 | | GetBlocks -> 705 | let objs, cs = GetHashes.of_cstruct payload in 706 | GetBlocks objs, cs 707 | | GetData -> 708 | let invs, cs = ObjList.of_cstruct ~f:Inv.of_cstruct payload in 709 | GetData invs, cs 710 | | GetHeaders -> 711 | let objs, cs = GetHashes.of_cstruct payload in 712 | GetHeaders objs, cs 713 | | Block -> 714 | let block, cs = Block.of_cstruct payload in 715 | Block block, cs 716 | | MerkleBlock -> 717 | let mblock, cs = MerkleBlock.of_cstruct payload in 718 | MerkleBlock mblock, cs 719 | | Headers -> 720 | let hdrs, cs = ObjList.of_cstruct ~f:Header.of_cstruct_txcount payload in 721 | Headers hdrs, cs 722 | | Inv -> 723 | let invs, cs = ObjList.of_cstruct ~f:Inv.of_cstruct payload in 724 | Inv invs, cs 725 | | NotFound -> 726 | let invs, cs = ObjList.of_cstruct ~f:Inv.of_cstruct payload in 727 | NotFound invs, cs 728 | | MemPool -> MemPool, cs 729 | | SendHeaders -> SendHeaders, cs 730 | | Tx -> 731 | let tx, cs = Transaction.of_cstruct payload in 732 | Tx tx, cs 733 | | FeeFilter -> 734 | let fee, cs = FeeFilter.of_cstruct payload in 735 | FeeFilter fee, cs 736 | | FilterAdd -> 737 | let filter, cs = FilterAdd.of_cstruct payload in 738 | FilterAdd filter, cs 739 | | FilterClear -> FilterClear, cs 740 | | FilterLoad -> 741 | let filter, cs = FilterLoad.of_cstruct payload in 742 | FilterLoad filter, cs 743 | | Reject -> 744 | let reject, cs = Reject.of_cstruct payload in 745 | Reject reject, cs 746 | | SendCmpct -> 747 | let sendcmpct, cs = SendCmpct.of_cstruct payload in 748 | SendCmpct sendcmpct, cs 749 | | _ -> failwith "Unsupported" 750 | in 751 | Ok (h, msg), cs 752 | ;; 753 | 754 | let to_cstruct ~network cs = function 755 | | Version ver -> 756 | let hdr = MessageHeader.version ~network in 757 | let payload_cs = Cstruct.shift cs MessageHeader.size in 758 | let end_cs = Version.to_cstruct payload_cs ver in 759 | let size, checksum = Chksum.compute' payload_cs end_cs in 760 | let _ = MessageHeader.to_cstruct cs { hdr with size; checksum } in 761 | end_cs 762 | | VerAck -> MessageHeader.(to_cstruct cs (verack ~network)) 763 | | Pong i -> 764 | let hdr = MessageHeader.pong ~network in 765 | let payload_cs = Cstruct.shift cs MessageHeader.size in 766 | Cstruct.LE.set_uint64 payload_cs 0 i; 767 | let end_cs = Cstruct.shift payload_cs 8 in 768 | let size, checksum = Chksum.compute' payload_cs end_cs in 769 | let _ = MessageHeader.to_cstruct cs { hdr with size; checksum } in 770 | end_cs 771 | | GetHeaders hashes -> 772 | let hdr = MessageHeader.getheaders ~network in 773 | let payload_cs = Cstruct.shift cs MessageHeader.size in 774 | let end_cs = GetHashes.to_cstruct payload_cs hashes in 775 | let size, checksum = Chksum.compute' payload_cs end_cs in 776 | let _ = MessageHeader.to_cstruct cs { hdr with size; checksum } in 777 | end_cs 778 | | FilterLoad filterload -> 779 | let hdr = MessageHeader.filterload ~network in 780 | let payload_cs = Cstruct.shift cs MessageHeader.size in 781 | let end_cs = FilterLoad.to_cstruct payload_cs filterload in 782 | let size, checksum = Chksum.compute' payload_cs end_cs in 783 | let _ = MessageHeader.to_cstruct cs { hdr with size; checksum } in 784 | end_cs 785 | | GetData invs -> 786 | let hdr = MessageHeader.getdata ~network in 787 | let payload_cs = Cstruct.shift cs MessageHeader.size in 788 | let end_cs = ObjList.to_cstruct payload_cs invs ~f:Inv.to_cstruct in 789 | let size, checksum = Chksum.compute' payload_cs end_cs in 790 | let _ = MessageHeader.to_cstruct cs { hdr with size; checksum } in 791 | end_cs 792 | | _ -> failwith "Unsupported" 793 | ;; 794 | end 795 | -------------------------------------------------------------------------------- /lib/p2p.mli: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2017 Vincent Bernardoff. All rights reserved. 3 | Distributed under the GNU Affero GPL license, see LICENSE. 4 | ---------------------------------------------------------------------------*) 5 | 6 | open Util 7 | 8 | module Network : sig 9 | type t = 10 | | Mainnet 11 | | Testnet 12 | | Regtest 13 | 14 | val pp : Format.formatter -> t -> unit 15 | val show : t -> string 16 | val port : t -> int 17 | val seed : t -> string list 18 | val start_string : t -> string 19 | val max_nBits : t -> Int32.t 20 | val of_start_string : string -> t 21 | end 22 | 23 | module Service : sig 24 | type t = 25 | | Network 26 | | Getutxo 27 | | Bloom 28 | end 29 | 30 | module Version : sig 31 | type t = 32 | { version : int 33 | ; services : Service.t list 34 | ; timestamp : Timestamp.t 35 | ; recv_services : Service.t list 36 | ; recv_ipaddr : Ipaddr.V6.t 37 | ; recv_port : int 38 | ; trans_services : Service.t list 39 | ; trans_ipaddr : Ipaddr.V6.t 40 | ; trans_port : int 41 | ; nonce : Int64.t 42 | ; user_agent : string 43 | ; start_height : int 44 | ; relay : bool 45 | } 46 | 47 | val create 48 | : ?version:int 49 | -> ?services:Service.t list 50 | -> ?timestamp:Timestamp.t 51 | -> ?recv_services:Service.t list 52 | -> ?recv_ipaddr:Ipaddr.V6.t 53 | -> recv_port:int 54 | -> ?trans_services:Service.t list 55 | -> ?trans_ipaddr:Ipaddr.V6.t 56 | -> trans_port:int 57 | -> ?nonce:Int64.t 58 | -> ?user_agent:string 59 | -> ?start_height:int 60 | -> ?relay:bool 61 | -> unit 62 | -> t 63 | end 64 | 65 | module Address : sig 66 | type t = 67 | { timestamp : Timestamp.t 68 | ; services : Service.t list 69 | ; ipaddr : Ipaddr.V6.t 70 | ; port : int 71 | } 72 | end 73 | 74 | module GetHashes : sig 75 | type t = 76 | { version : int 77 | ; hashes : Hash256.t list 78 | ; stop_hash : Hash256.t 79 | } 80 | 81 | val create : ?version:int -> ?stop_hash:Hash256.t -> Hash256.t list -> t 82 | val to_cstruct : Cstruct.t -> t -> Cstruct.t 83 | end 84 | 85 | module Inv : sig 86 | type id = 87 | | Tx 88 | | Block 89 | | FilteredBlock 90 | 91 | type t = 92 | { id : id 93 | ; hash : Hash256.t 94 | } 95 | [@@deriving sexp] 96 | 97 | val tx : Hash256.t -> t 98 | val block : Hash256.t -> t 99 | val filteredblock : Hash256.t -> t 100 | end 101 | 102 | module MerkleBlock : sig 103 | type t = 104 | { header : Header.t 105 | ; txn_count : int 106 | ; hashes : Hash256.t list 107 | ; flags : Bitv.t 108 | } 109 | [@@deriving sexp] 110 | end 111 | 112 | module FilterLoad : sig 113 | type flag = 114 | | Update_none 115 | | Update_all 116 | | Update_p2pkh_only 117 | 118 | type t = 119 | { filter : Bloom.t 120 | ; flag : flag 121 | } 122 | 123 | val of_data 124 | : ?false_pos_rate:float 125 | -> ?tweak:Int32.t 126 | -> Cstruct.t list 127 | -> ?nb_elts:int 128 | -> flag 129 | -> t 130 | end 131 | 132 | module MessageName : sig 133 | type t = 134 | | Block 135 | | GetBlocks 136 | | GetData 137 | | GetHeaders 138 | | Headers 139 | | Inv 140 | | MemPool 141 | | MerkleBlock 142 | | NotFound 143 | | Tx 144 | | Addr 145 | | Alert 146 | | FeeFilter 147 | | FilterAdd 148 | | FilterClear 149 | | FilterLoad 150 | | GetAddr 151 | | Ping 152 | | Pong 153 | | Reject 154 | | SendHeaders 155 | | VerAck 156 | | Version 157 | | SendCmpct 158 | 159 | val show : t -> string 160 | val of_string : string -> t 161 | val of_cstruct : Cstruct.t -> t 162 | val to_string : t -> string 163 | end 164 | 165 | module MessageHeader : sig 166 | type t = 167 | { network : Network.t 168 | ; msgname : MessageName.t 169 | ; size : int 170 | ; checksum : string 171 | } 172 | [@@deriving sexp] 173 | 174 | val size : int 175 | val of_cstruct : Cstruct.t -> t * Cstruct.t 176 | end 177 | 178 | module Reject : sig 179 | module Code : sig 180 | type t = 181 | | Decode_error 182 | | Invalid_block of Hash256.t 183 | | Invalid_transaction of Hash256.t 184 | | Block_version_too_old of Hash256.t 185 | | Protocol_too_old 186 | | Double_spend of Hash256.t 187 | | Too_many_version_messages 188 | | Non_standard_transaction of Hash256.t 189 | | Dust of Hash256.t 190 | | Fee_too_low of Hash256.t 191 | | Wrong_blockchain of Hash256.t 192 | end 193 | 194 | type t = 195 | { message : MessageName.t 196 | ; code : Code.t 197 | ; reason : string 198 | } 199 | 200 | val pp : Format.formatter -> t -> unit 201 | val show : t -> string 202 | val of_cstruct : Cstruct.t -> t * Cstruct.t 203 | end 204 | 205 | module SendCmpct : sig 206 | type t = 207 | { compact : bool 208 | ; version : int 209 | } 210 | [@@deriving sexp] 211 | end 212 | 213 | module Message : sig 214 | type t = 215 | | Version of Version.t 216 | | VerAck 217 | | GetAddr 218 | | Addr of Address.t list 219 | | Ping of Int64.t 220 | | Pong of Int64.t 221 | | GetBlocks of GetHashes.t 222 | | GetData of Inv.t list 223 | | GetHeaders of GetHashes.t 224 | | Block of Block.t 225 | | MerkleBlock of MerkleBlock.t 226 | | Headers of Header.t list 227 | | Inv of Inv.t list 228 | | NotFound of Inv.t list 229 | | MemPool 230 | | SendHeaders 231 | | Tx of Transaction.t 232 | | FeeFilter of Int64.t 233 | | FilterAdd of string 234 | | FilterClear 235 | | FilterLoad of FilterLoad.t 236 | | Reject of Reject.t 237 | | SendCmpct of SendCmpct.t 238 | [@@deriving sexp] 239 | 240 | type error = Invalid_checksum of MessageHeader.t 241 | 242 | val of_cstruct : Cstruct.t -> (MessageHeader.t * t, error) result * Cstruct.t 243 | val to_cstruct : network:Network.t -> Cstruct.t -> t -> Cstruct.t 244 | end 245 | -------------------------------------------------------------------------------- /lib/script.ml: -------------------------------------------------------------------------------- 1 | open Sexplib.Std 2 | open Libsecp256k1.External 3 | open Util 4 | 5 | module Opcode = struct 6 | type t = 7 | | Op_pushdata of int 8 | | Op_pushdata1 9 | | Op_pushdata2 10 | | Op_pushdata4 11 | | Op_1negate 12 | | Op_1 13 | | Op_2 14 | | Op_3 15 | | Op_4 16 | | Op_5 17 | | Op_6 18 | | Op_7 19 | | Op_8 20 | | Op_9 21 | | Op_10 22 | | Op_11 23 | | Op_12 24 | | Op_13 25 | | Op_14 26 | | Op_15 27 | | Op_16 28 | | Op_nop 29 | | Op_if 30 | | Op_notif 31 | | Op_else 32 | | Op_endif 33 | | Op_verify 34 | | Op_return 35 | | Op_toaltstack 36 | | Op_fromaltstack 37 | | Op_ifdup 38 | | Op_depth 39 | | Op_drop 40 | | Op_dup 41 | | Op_nip 42 | | Op_over 43 | | Op_pick 44 | | Op_roll 45 | | Op_rot 46 | | Op_swap 47 | | Op_tuck 48 | | Op_2drop 49 | | Op_2dup 50 | | Op_3dup 51 | | Op_2over 52 | | Op_2rot 53 | | Op_2swap 54 | | Op_cat 55 | | Op_substr 56 | | Op_left 57 | | Op_right 58 | | Op_size 59 | | Op_invert 60 | | Op_and 61 | | Op_or 62 | | Op_xor 63 | | Op_equal 64 | | Op_equalverify 65 | | Op_1add 66 | | Op_1sub 67 | | Op_2mul 68 | | Op_2div 69 | | Op_negate 70 | | Op_abs 71 | | Op_not 72 | | Op_0notequal 73 | | Op_add 74 | | Op_sub 75 | | Op_mul 76 | | Op_div 77 | | Op_mod 78 | | Op_lshift 79 | | Op_rshift 80 | | Op_booland 81 | | Op_boolor 82 | | Op_numequal 83 | | Op_numequalverify 84 | | Op_numnotequal 85 | | Op_lessthan 86 | | Op_greaterthan 87 | | Op_lessthanorequal 88 | | Op_greaterthanorequal 89 | | Op_min 90 | | Op_max 91 | | Op_within 92 | | Op_ripemd160 93 | | Op_sha1 94 | | Op_sha256 95 | | Op_hash160 96 | | Op_hash256 97 | | Op_codeseparator 98 | | Op_checksig 99 | | Op_checksigverify 100 | | Op_checkmultisig 101 | | Op_checkmultisigverify 102 | | Op_checklocktimeverify 103 | | Op_checksequenceverify 104 | | Op_pubkeyhash 105 | | Op_pubkey 106 | | Op_invalidopcode 107 | | Op_reserved 108 | | Op_ver 109 | | Op_verif 110 | | Op_vernotif 111 | | Op_reserved1 112 | | Op_reserved2 113 | | Op_nop1 114 | | Op_nop4 115 | | Op_nop5 116 | | Op_nop6 117 | | Op_nop7 118 | | Op_nop8 119 | | Op_nop9 120 | | Op_nop10 121 | [@@deriving sexp] 122 | 123 | let to_int = function 124 | | Op_pushdata n -> if n < 0 || n > 75 then failwith "Script.to_int" else n 125 | | Op_pushdata1 -> 76 126 | | Op_pushdata2 -> 77 127 | | Op_pushdata4 -> 78 128 | | Op_1negate -> 79 129 | | Op_1 -> 81 130 | | Op_2 -> 82 131 | | Op_3 -> 83 132 | | Op_4 -> 84 133 | | Op_5 -> 85 134 | | Op_6 -> 86 135 | | Op_7 -> 87 136 | | Op_8 -> 88 137 | | Op_9 -> 89 138 | | Op_10 -> 90 139 | | Op_11 -> 91 140 | | Op_12 -> 92 141 | | Op_13 -> 93 142 | | Op_14 -> 94 143 | | Op_15 -> 95 144 | | Op_16 -> 96 145 | | Op_nop -> 97 146 | | Op_if -> 99 147 | | Op_notif -> 100 148 | | Op_else -> 103 149 | | Op_endif -> 104 150 | | Op_verify -> 105 151 | | Op_return -> 106 152 | | Op_toaltstack -> 107 153 | | Op_fromaltstack -> 108 154 | | Op_ifdup -> 115 155 | | Op_depth -> 116 156 | | Op_drop -> 117 157 | | Op_dup -> 118 158 | | Op_nip -> 119 159 | | Op_over -> 120 160 | | Op_pick -> 121 161 | | Op_roll -> 122 162 | | Op_rot -> 123 163 | | Op_swap -> 124 164 | | Op_tuck -> 125 165 | | Op_2drop -> 109 166 | | Op_2dup -> 110 167 | | Op_3dup -> 111 168 | | Op_2over -> 112 169 | | Op_2rot -> 113 170 | | Op_2swap -> 114 171 | | Op_cat -> 126 172 | | Op_substr -> 127 173 | | Op_left -> 128 174 | | Op_right -> 129 175 | | Op_size -> 130 176 | | Op_invert -> 131 177 | | Op_and -> 132 178 | | Op_or -> 133 179 | | Op_xor -> 134 180 | | Op_equal -> 135 181 | | Op_equalverify -> 136 182 | | Op_1add -> 139 183 | | Op_1sub -> 140 184 | | Op_2mul -> 141 185 | | Op_2div -> 142 186 | | Op_negate -> 143 187 | | Op_abs -> 144 188 | | Op_not -> 145 189 | | Op_0notequal -> 146 190 | | Op_add -> 147 191 | | Op_sub -> 148 192 | | Op_mul -> 149 193 | | Op_div -> 150 194 | | Op_mod -> 151 195 | | Op_lshift -> 152 196 | | Op_rshift -> 153 197 | | Op_booland -> 154 198 | | Op_boolor -> 155 199 | | Op_numequal -> 156 200 | | Op_numequalverify -> 157 201 | | Op_numnotequal -> 158 202 | | Op_lessthan -> 159 203 | | Op_greaterthan -> 160 204 | | Op_lessthanorequal -> 161 205 | | Op_greaterthanorequal -> 162 206 | | Op_min -> 163 207 | | Op_max -> 164 208 | | Op_within -> 165 209 | | Op_ripemd160 -> 166 210 | | Op_sha1 -> 167 211 | | Op_sha256 -> 168 212 | | Op_hash160 -> 169 213 | | Op_hash256 -> 170 214 | | Op_codeseparator -> 171 215 | | Op_checksig -> 172 216 | | Op_checksigverify -> 173 217 | | Op_checkmultisig -> 174 218 | | Op_checkmultisigverify -> 175 219 | | Op_checklocktimeverify -> 177 220 | | Op_checksequenceverify -> 178 221 | | Op_pubkeyhash -> 253 222 | | Op_pubkey -> 254 223 | | Op_invalidopcode -> 255 224 | | Op_reserved -> 80 225 | | Op_ver -> 98 226 | | Op_verif -> 101 227 | | Op_vernotif -> 102 228 | | Op_reserved1 -> 137 229 | | Op_reserved2 -> 138 230 | | Op_nop1 -> 176 231 | | Op_nop4 -> 179 232 | | Op_nop5 -> 180 233 | | Op_nop6 -> 181 234 | | Op_nop7 -> 182 235 | | Op_nop8 -> 183 236 | | Op_nop9 -> 184 237 | | Op_nop10 -> 185 238 | ;; 239 | 240 | let of_int = function 241 | | n when n >= 0 && n < 76 -> Op_pushdata n 242 | | 76 -> Op_pushdata1 243 | | 77 -> Op_pushdata2 244 | | 78 -> Op_pushdata4 245 | | 79 -> Op_1negate 246 | | 80 -> Op_reserved 247 | | 81 -> Op_1 248 | | 82 -> Op_2 249 | | 83 -> Op_3 250 | | 84 -> Op_4 251 | | 85 -> Op_5 252 | | 86 -> Op_6 253 | | 87 -> Op_7 254 | | 88 -> Op_8 255 | | 89 -> Op_9 256 | | 90 -> Op_10 257 | | 91 -> Op_11 258 | | 92 -> Op_12 259 | | 93 -> Op_13 260 | | 94 -> Op_14 261 | | 95 -> Op_15 262 | | 96 -> Op_16 263 | | 97 -> Op_nop 264 | | 98 -> Op_ver 265 | | 99 -> Op_if 266 | | 100 -> Op_notif 267 | | 101 -> Op_verif 268 | | 102 -> Op_vernotif 269 | | 103 -> Op_else 270 | | 104 -> Op_endif 271 | | 105 -> Op_verify 272 | | 106 -> Op_return 273 | | 107 -> Op_toaltstack 274 | | 108 -> Op_fromaltstack 275 | | 115 -> Op_ifdup 276 | | 116 -> Op_depth 277 | | 117 -> Op_drop 278 | | 118 -> Op_dup 279 | | 119 -> Op_nip 280 | | 120 -> Op_over 281 | | 121 -> Op_pick 282 | | 122 -> Op_roll 283 | | 123 -> Op_rot 284 | | 124 -> Op_swap 285 | | 125 -> Op_tuck 286 | | 109 -> Op_2drop 287 | | 110 -> Op_2dup 288 | | 111 -> Op_3dup 289 | | 112 -> Op_2over 290 | | 113 -> Op_2rot 291 | | 114 -> Op_2swap 292 | | 126 -> Op_cat 293 | | 127 -> Op_substr 294 | | 128 -> Op_left 295 | | 129 -> Op_right 296 | | 130 -> Op_size 297 | | 131 -> Op_invert 298 | | 132 -> Op_and 299 | | 133 -> Op_or 300 | | 134 -> Op_xor 301 | | 135 -> Op_equal 302 | | 136 -> Op_equalverify 303 | | 137 -> Op_reserved1 304 | | 138 -> Op_reserved2 305 | | 139 -> Op_1add 306 | | 140 -> Op_1sub 307 | | 141 -> Op_2mul 308 | | 142 -> Op_2div 309 | | 143 -> Op_negate 310 | | 144 -> Op_abs 311 | | 145 -> Op_not 312 | | 146 -> Op_0notequal 313 | | 147 -> Op_add 314 | | 148 -> Op_sub 315 | | 149 -> Op_mul 316 | | 150 -> Op_div 317 | | 151 -> Op_mod 318 | | 152 -> Op_lshift 319 | | 153 -> Op_rshift 320 | | 154 -> Op_booland 321 | | 155 -> Op_boolor 322 | | 156 -> Op_numequal 323 | | 157 -> Op_numequalverify 324 | | 158 -> Op_numnotequal 325 | | 159 -> Op_lessthan 326 | | 160 -> Op_greaterthan 327 | | 161 -> Op_lessthanorequal 328 | | 162 -> Op_greaterthanorequal 329 | | 163 -> Op_min 330 | | 164 -> Op_max 331 | | 165 -> Op_within 332 | | 166 -> Op_ripemd160 333 | | 167 -> Op_sha1 334 | | 168 -> Op_sha256 335 | | 169 -> Op_hash160 336 | | 170 -> Op_hash256 337 | | 171 -> Op_codeseparator 338 | | 172 -> Op_checksig 339 | | 173 -> Op_checksigverify 340 | | 174 -> Op_checkmultisig 341 | | 175 -> Op_checkmultisigverify 342 | | 176 -> Op_nop1 343 | | 177 -> Op_checklocktimeverify 344 | | 178 -> Op_checksequenceverify 345 | | 179 -> Op_nop4 346 | | 180 -> Op_nop5 347 | | 181 -> Op_nop6 348 | | 182 -> Op_nop7 349 | | 183 -> Op_nop8 350 | | 184 -> Op_nop9 351 | | 185 -> Op_nop10 352 | | 253 -> Op_pubkeyhash 353 | | 254 -> Op_pubkey 354 | | 255 -> Op_invalidopcode 355 | | n -> invalid_arg ("Opcode.of_int: got " ^ string_of_int n) 356 | ;; 357 | 358 | let of_cstruct cs = Cstruct.(get_uint8 cs 0 |> of_int, shift cs 1) 359 | 360 | let to_cstruct cs opcode = 361 | Cstruct.set_uint8 cs 0 (to_int opcode); 362 | Cstruct.shift cs 1 363 | ;; 364 | end 365 | 366 | module Element = struct 367 | type t = 368 | | O of Opcode.t 369 | | D of Cstruct_sexp.t 370 | [@@deriving sexp] 371 | 372 | let op_size_prefix buf = 373 | let len = Cstruct.length buf in 374 | if len <= 0x4b 375 | then [ O (Op_pushdata len) ] 376 | else ( 377 | assert (len <= 255); 378 | let sbuf = Cstruct.create 1 in 379 | Cstruct.set_uint8 sbuf 0 len; 380 | [ O Op_pushdata1; D sbuf ]) 381 | ;; 382 | 383 | let op_data buf = op_size_prefix buf @ [ D buf ] 384 | 385 | let to_cstruct cs = function 386 | | O opcode -> Opcode.to_cstruct cs opcode 387 | | D buf -> 388 | let len = Cstruct.length buf in 389 | Cstruct.blit buf 0 cs 0 len; 390 | Cstruct.shift cs len 391 | ;; 392 | 393 | let length = function 394 | | O _ -> 1 395 | | D cs -> Cstruct.length cs 396 | ;; 397 | end 398 | 399 | type t = Element.t list [@@deriving sexp] 400 | 401 | let pp ppf t = Sexplib.Sexp.pp_hum ppf (sexp_of_t t) 402 | let size elts = ListLabels.fold_left elts ~init:0 ~f:(fun acc e -> acc + Element.length e) 403 | 404 | let read_all cs = 405 | let open Element in 406 | let rec inner acc data_len cs = 407 | if Cstruct.length cs = 0 408 | then List.rev acc 409 | else if cs.len = 0 && data_len <> 0 410 | then invalid_arg "Script.read_all: cs too short" 411 | else if data_len > 0 412 | then inner (D (Cstruct.sub cs 0 data_len) :: acc) 0 (Cstruct.shift cs data_len) 413 | else ( 414 | let elt, cs = Opcode.of_cstruct cs in 415 | match elt with 416 | | Op_pushdata n -> inner (O (Op_pushdata n) :: acc) n cs 417 | | Op_pushdata1 -> 418 | let data_len = Cstruct.get_uint8 cs 0 in 419 | let len = Cstruct.sub cs 0 1 in 420 | inner (D len :: O Op_pushdata1 :: acc) data_len (Cstruct.shift cs 1) 421 | | Op_pushdata2 -> 422 | let data_len = Cstruct.LE.get_uint16 cs 0 in 423 | let len = Cstruct.sub cs 0 2 in 424 | inner (D len :: O Op_pushdata2 :: acc) data_len (Cstruct.shift cs 2) 425 | | Op_pushdata4 -> 426 | let data_len = Cstruct.LE.get_uint32 cs 0 |> Int32.to_int in 427 | let len = Cstruct.sub cs 0 4 in 428 | inner (D len :: O Op_pushdata4 :: acc) data_len (Cstruct.shift cs 4) 429 | | op -> inner (O op :: acc) 0 cs) 430 | in 431 | inner [] 0 cs 432 | ;; 433 | 434 | let of_cstruct ?(pos = 0) ?len cs = 435 | let len = 436 | match len with 437 | | None -> Cstruct.length cs 438 | | Some l -> l 439 | in 440 | read_all (Cstruct.sub cs pos len), Cstruct.shift cs len 441 | ;; 442 | 443 | let to_cstruct cs elts = ListLabels.fold_left elts ~init:cs ~f:Element.to_cstruct 444 | 445 | let serialize elts = 446 | let len = size elts in 447 | let cs = Cstruct.create len in 448 | let _ = to_cstruct cs elts in 449 | cs 450 | ;; 451 | 452 | let hash160 t = 453 | let scriptlen = size t in 454 | let cs = Cstruct.create scriptlen in 455 | let _ = to_cstruct cs t in 456 | Hash160.compute_cstruct cs 457 | ;; 458 | 459 | module Std = struct 460 | module P2PKH = struct 461 | let scriptRedeem { BitcoinAddr.version; payload } = 462 | (match version with 463 | | P2PKH | Testnet_P2PKH -> () 464 | | _ -> invalid_arg "must be a P2PKH address"); 465 | let payload = Cstruct.of_string payload in 466 | Element. 467 | [ O Op_dup 468 | ; O Op_hash160 469 | ; O (Op_pushdata 20) 470 | ; D payload 471 | ; O Op_equalverify 472 | ; O Op_checksig 473 | ] 474 | ;; 475 | 476 | let scriptSig ctx signature pk = 477 | let pk = Cstruct.of_bigarray (Key.to_bytes ctx pk) in 478 | Element.(op_data signature @ op_data pk) 479 | ;; 480 | end 481 | 482 | module P2SH = struct 483 | let scriptRedeem script = 484 | let script_hash = Cstruct.create Hash160.length in 485 | let _ = Hash160.to_cstruct script_hash (hash160 script) in 486 | Element.[ O Op_hash160; O (Op_pushdata 20); D script_hash; O Op_equalverify ] 487 | ;; 488 | end 489 | end 490 | 491 | module Stack = struct 492 | open Stdint 493 | 494 | let to_int32 cs = 495 | match Cstruct.length cs with 496 | | 0 -> 0l 497 | | 1 -> Int8.(of_bytes_little_endian (Cstruct.to_bytes cs) 0 |> to_int32) 498 | | 2 -> Int16.(of_bytes_little_endian (Cstruct.to_bytes cs) 0 |> to_int32) 499 | | 3 -> Int24.(of_bytes_little_endian (Cstruct.to_bytes cs) 0 |> to_int32) 500 | | 4 -> Int32.(of_bytes_little_endian (Cstruct.to_bytes cs) 0) 501 | | _ -> invalid_arg "Stack.to_int32: input is longer than 4 bytes" 502 | ;; 503 | 504 | let of_int32 i = 505 | let buf = Bytes.create 4 in 506 | match i with 507 | | i when i >= -128l && i < 128l -> 508 | Int8.(to_bytes_little_endian (of_int32 i) buf 0); 509 | Cstruct.of_bytes (Bytes.sub buf 0 1) 510 | | i when i >= -32768l && i < 32767l -> 511 | Int16.(to_bytes_little_endian (of_int32 i) buf 0); 512 | Cstruct.of_bytes (Bytes.sub buf 0 2) 513 | | i when i >= 16777216l && i < 16777215l -> 514 | Int24.(to_bytes_little_endian (of_int32 i) buf 0); 515 | Cstruct.of_bytes (Bytes.sub buf 0 3) 516 | | _ -> 517 | Int32.(to_bytes_little_endian i buf 0); 518 | Cstruct.of_bytes (Bytes.sub buf 0 4) 519 | ;; 520 | 521 | let to_bool cs = to_int32 cs <> 0l 522 | 523 | let of_bool = function 524 | | true -> of_int32 1l 525 | | false -> Cstruct.create 0 526 | ;; 527 | end 528 | 529 | module Run = struct 530 | let eval_exn code = 531 | let rec drop stack altstack n current = function 532 | | Element.O Op_if :: rest -> drop stack altstack n (succ current) rest 533 | | O Op_notif :: rest -> drop stack altstack n (succ current) rest 534 | | O Op_else :: rest when current > n -> drop stack altstack n current rest 535 | | O Op_else :: rest when n = current -> eval_main n stack altstack rest 536 | | O Op_endif :: rest when current > n -> drop stack altstack n (pred current) rest 537 | | O Op_endif :: rest when current = n -> eval_main n stack altstack rest 538 | | _ :: rest -> drop stack altstack n current rest 539 | | [] -> invalid_arg "Run.eval: unfinished if sequence" 540 | and eval_main iflevel stack altstack code = 541 | match code, stack with 542 | | Element.D buf :: rest, _ -> eval_main iflevel (buf :: stack) altstack rest 543 | | O (Op_pushdata _) :: rest, _ 544 | | O Op_pushdata1 :: rest, _ 545 | | O Op_pushdata2 :: rest, _ 546 | | O Op_pushdata4 :: rest, _ -> eval_main iflevel stack altstack rest 547 | | O Op_1negate :: rest, _ -> 548 | eval_main iflevel (Stack.of_int32 (-1l) :: stack) altstack rest 549 | | O Op_1 :: rest, _ -> eval_main iflevel (Stack.of_int32 1l :: stack) altstack rest 550 | | O Op_2 :: rest, _ -> eval_main iflevel (Stack.of_int32 2l :: stack) altstack rest 551 | | O Op_3 :: rest, _ -> eval_main iflevel (Stack.of_int32 3l :: stack) altstack rest 552 | | O Op_4 :: rest, _ -> eval_main iflevel (Stack.of_int32 4l :: stack) altstack rest 553 | | O Op_5 :: rest, _ -> eval_main iflevel (Stack.of_int32 5l :: stack) altstack rest 554 | | O Op_6 :: rest, _ -> eval_main iflevel (Stack.of_int32 6l :: stack) altstack rest 555 | | O Op_7 :: rest, _ -> eval_main iflevel (Stack.of_int32 7l :: stack) altstack rest 556 | | O Op_8 :: rest, _ -> eval_main iflevel (Stack.of_int32 8l :: stack) altstack rest 557 | | O Op_9 :: rest, _ -> eval_main iflevel (Stack.of_int32 9l :: stack) altstack rest 558 | | O Op_10 :: rest, _ -> 559 | eval_main iflevel (Stack.of_int32 10l :: stack) altstack rest 560 | | O Op_11 :: rest, _ -> 561 | eval_main iflevel (Stack.of_int32 11l :: stack) altstack rest 562 | | O Op_12 :: rest, _ -> 563 | eval_main iflevel (Stack.of_int32 12l :: stack) altstack rest 564 | | O Op_13 :: rest, _ -> 565 | eval_main iflevel (Stack.of_int32 13l :: stack) altstack rest 566 | | O Op_14 :: rest, _ -> 567 | eval_main iflevel (Stack.of_int32 14l :: stack) altstack rest 568 | | O Op_15 :: rest, _ -> 569 | eval_main iflevel (Stack.of_int32 15l :: stack) altstack rest 570 | | O Op_16 :: rest, _ -> 571 | eval_main iflevel (Stack.of_int32 16l :: stack) altstack rest 572 | | O Op_nop :: rest, _ -> eval_main iflevel stack altstack rest 573 | | O Op_if :: _rest, [] -> invalid_arg "Run.eval: if with empty stack" 574 | | O Op_notif :: _rest, [] -> invalid_arg "Run.eval: notif with empty stack" 575 | | O Op_if :: rest, v :: _ -> 576 | if Stack.to_bool v 577 | then eval_main (succ iflevel) stack altstack rest 578 | else drop stack altstack (succ iflevel) (succ iflevel) rest 579 | | O Op_notif :: rest, v :: _ -> 580 | if Stack.to_bool v 581 | then drop stack altstack (succ iflevel) (succ iflevel) rest 582 | else eval_main (succ iflevel) stack altstack rest 583 | | O Op_else :: rest, _ -> 584 | if iflevel = 0 585 | then invalid_arg "Run.eval: unconsistent else" 586 | else drop stack altstack iflevel iflevel rest 587 | | O Op_endif :: rest, _ -> 588 | let iflevel = pred iflevel in 589 | if iflevel < 0 590 | then invalid_arg "Run.eval: unconsistent endif" 591 | else eval_main iflevel stack altstack rest 592 | | O Op_verify :: _rest, [] -> 593 | invalid_arg "Run.eval: op_verify without a top stack element" 594 | | O Op_verify :: rest, v :: _ -> Stack.to_bool v, stack, rest 595 | | O Op_return :: rest, _ -> false, stack, rest 596 | | O Op_toaltstack :: _rest, [] -> 597 | invalid_arg "Run.eval: op_toaltstack without a top stack element" 598 | | O Op_toaltstack :: rest, v :: stack -> 599 | eval_main iflevel stack (v :: altstack) rest 600 | | O Op_fromaltstack :: rest, stack -> 601 | (match altstack with 602 | | [] -> invalid_arg "Run.eval: op_fromaltstack without a top stack element" 603 | | v :: altstack -> eval_main iflevel (v :: stack) altstack rest) 604 | | O Op_ifdup :: _rest, [] -> 605 | invalid_arg "Run.eval: op_ifdup without a top stack element" 606 | | O Op_ifdup :: rest, v :: _ when Stack.to_bool v -> 607 | eval_main iflevel (v :: stack) altstack rest 608 | | O Op_ifdup :: rest, stack -> eval_main iflevel stack altstack rest 609 | | O Op_depth :: rest, _ -> 610 | let length = List.length stack |> Int32.of_int |> Stack.of_int32 in 611 | eval_main iflevel (length :: stack) altstack rest 612 | | O Op_drop :: _rest, [] -> 613 | invalid_arg "Run.eval: op_drop without a top stack element" 614 | | O Op_drop :: rest, _v :: stack -> eval_main iflevel stack altstack rest 615 | | O Op_dup :: _rest, [] -> 616 | invalid_arg "Run.eval: op_dup without a top stack element" 617 | | O Op_dup :: rest, v :: _ -> eval_main iflevel (v :: stack) altstack rest 618 | | O Op_nip :: rest, x :: _ :: stack -> eval_main iflevel (x :: stack) altstack rest 619 | | O Op_nip :: _rest, _ -> 620 | invalid_arg "Run.eval: op_nip without at least two stack elements" 621 | | O Op_over :: rest, _ :: x :: _ -> eval_main iflevel (x :: stack) altstack rest 622 | | O Op_over :: _rest, _ -> 623 | invalid_arg "Run.eval: op_over without at least two stack element" 624 | | O Op_pick :: _rest, [] -> 625 | invalid_arg "Run.eval: op_pick without a top stack element" 626 | | O Op_pick :: rest, v :: stack -> 627 | let n = Stack.to_int32 v |> Int32.to_int in 628 | (try eval_main iflevel (List.nth stack n :: stack) altstack rest with 629 | | _ -> invalid_arg "Run.eval: op_pick with stack too shallow") 630 | | O Op_roll :: _rest, [] -> 631 | invalid_arg "Run.eval: op_roll without a top stack element" 632 | | O Op_roll :: rest, v :: stack -> 633 | let n = Stack.to_int32 v |> Int32.to_int in 634 | let stack, _, e = 635 | ListLabels.fold_left 636 | stack 637 | ~f:(fun (a, i, v) e -> if i = n then a, succ i, Some e else e :: a, succ i, v) 638 | ~init:([], 0, None) 639 | in 640 | (match e with 641 | | None -> invalid_arg "Run.eval: op_roll with stack too shallow" 642 | | Some v -> eval_main iflevel (v :: stack) altstack rest) 643 | | O Op_rot :: rest, z :: y :: x :: stack -> 644 | eval_main iflevel (y :: z :: x :: stack) altstack rest 645 | | O Op_rot :: _rest, _ -> 646 | invalid_arg "Run.eval: op_rot without at least 3 stack elements" 647 | | O Op_swap :: rest, x :: y :: stack -> 648 | eval_main iflevel (y :: x :: stack) altstack rest 649 | | O Op_swap :: _rest, _ -> 650 | invalid_arg "Run.eval: op_swap without at least 2 stack elements" 651 | | O Op_tuck :: rest, y :: x :: stack -> 652 | eval_main iflevel (y :: x :: y :: stack) altstack rest 653 | | O Op_tuck :: _rest, _ -> 654 | invalid_arg "Run.eval: op_tuck without at least 2 stack elements" 655 | | O Op_2drop :: rest, _ :: _ :: stack -> eval_main iflevel stack altstack rest 656 | | O Op_2drop :: _rest, _ -> 657 | invalid_arg "Run.eval: op_2drop without at least 2 stack elements" 658 | | O Op_2dup :: rest, y :: x :: stack -> 659 | eval_main iflevel (y :: x :: y :: x :: stack) altstack rest 660 | | O Op_2dup :: _rest, _ -> 661 | invalid_arg "Run.eval: op_2dup without at least 2 stack elements" 662 | | O Op_3dup :: rest, z :: y :: x :: stack -> 663 | eval_main iflevel (z :: y :: x :: z :: y :: x :: stack) altstack rest 664 | | O Op_3dup :: _rest, _ -> 665 | invalid_arg "Run.eval: op_3dup without at least 3 stack elements" 666 | | O Op_2over :: rest, t :: z :: y :: x :: stack -> 667 | eval_main iflevel (y :: x :: t :: z :: y :: x :: stack) altstack rest 668 | | O Op_2over :: _rest, _ -> 669 | invalid_arg "Run.eval: op_2over without at least 4 stack elements" 670 | | O Op_2rot :: rest, v :: u :: t :: z :: y :: x :: stack -> 671 | eval_main iflevel (y :: x :: v :: u :: t :: z :: stack) altstack rest 672 | | O Op_2rot :: _rest, _ -> 673 | invalid_arg "Run.eval: op_2rot without at least 6 stack elements" 674 | | O Op_2swap :: rest, t :: z :: y :: x :: stack -> 675 | eval_main iflevel (y :: x :: t :: z :: stack) altstack rest 676 | | O Op_cat :: _, _ -> invalid_arg "Run.eval: op_cat is disabled" 677 | | O Op_substr :: _, _ -> invalid_arg "Run.eval: op_substr is disabled" 678 | | O Op_left :: _, _ -> invalid_arg "Run.eval: op_left is disabled" 679 | | O Op_right :: _, _ -> invalid_arg "Run.eval: op_right is disabled" 680 | | O Op_size :: rest, v :: stack -> 681 | let stacklen = Cstruct.length v |> Int32.of_int |> Stack.of_int32 in 682 | eval_main iflevel (stacklen :: stack) altstack rest 683 | | O Op_invert :: _, _ -> invalid_arg "Run.eval: op_invert is disabled" 684 | | O Op_and :: _, _ -> invalid_arg "Run.eval: op_and is disabled" 685 | | O Op_or :: _, _ -> invalid_arg "Run.eval: op_or is disabled" 686 | | O Op_xor :: _, _ -> invalid_arg "Run.eval: op_xor is disabled" 687 | | O Op_equal :: rest, x :: y :: stack -> 688 | let ret = Cstruct.compare x y |> Int32.of_int |> Stack.of_int32 in 689 | eval_main iflevel (ret :: stack) altstack rest 690 | | O Op_equal :: _, _ -> 691 | invalid_arg "Run.eval: op_equal without at least 2 stack elements" 692 | | O Op_equalverify :: rest, x :: y :: stack -> Cstruct.compare x y = 0, stack, rest 693 | | O Op_equalverify :: _, _ -> 694 | invalid_arg "Run.eval: op_equalverify without at least 2 stack elements" 695 | | O Op_1add :: rest, v :: stack -> 696 | (try 697 | let v' = Stack.(to_int32 v |> Int32.succ |> of_int32) in 698 | eval_main iflevel (v' :: stack) altstack rest 699 | with 700 | | _ -> invalid_arg "Run.eval: op_1add is limited to 4 bytes max input") 701 | | O Op_1add :: _, _ -> invalid_arg "Run.eval: op_1add without a top stack element" 702 | | O Op_1sub :: rest, v :: stack -> 703 | (try 704 | let v' = Stack.(to_int32 v |> Int32.pred |> of_int32) in 705 | eval_main iflevel (v' :: stack) altstack rest 706 | with 707 | | _ -> invalid_arg "Run.eval: op_1sub is limited to 4 bytes max input") 708 | | O Op_1sub :: _, _ -> invalid_arg "Run.eval: op_1sub without a top stack element" 709 | | O Op_2mul :: _, _ -> invalid_arg "Run.eval: op_2mul is disabled" 710 | | O Op_2div :: _, _ -> invalid_arg "Run.eval: op_2div is disabled" 711 | | O Op_negate :: rest, v :: stack -> 712 | (try 713 | let v' = Stack.(to_int32 v |> Int32.neg |> of_int32) in 714 | eval_main iflevel (v' :: stack) altstack rest 715 | with 716 | | _ -> invalid_arg "Run.eval: op_negate is limited to 4 bytes max input") 717 | | O Op_negate :: _rest, _ -> 718 | invalid_arg "Run.eval: op_negate without a top stack element" 719 | | O Op_abs :: rest, v :: stack -> 720 | (try 721 | let v' = Stack.(to_int32 v |> Int32.abs |> of_int32) in 722 | eval_main iflevel (v' :: stack) altstack rest 723 | with 724 | | _ -> invalid_arg "Run.eval: op_abs is limited to 4 bytes max input") 725 | | O Op_abs :: _rest, _ -> invalid_arg "Run.eval: op_abs without a top stack element" 726 | | O Op_not :: rest, v :: stack -> 727 | (try 728 | let v' = Stack.(of_bool (not (to_bool v))) in 729 | eval_main iflevel (v' :: stack) altstack rest 730 | with 731 | | _ -> invalid_arg "Run.eval: op_not is limited to 4 bytes max input") 732 | | O Op_not :: _rest, _ -> invalid_arg "Run.eval: op_not without a top stack element" 733 | | O Op_0notequal :: rest, v :: stack -> 734 | (try 735 | let v' = Stack.(to_bool v |> of_bool) in 736 | eval_main iflevel (v' :: stack) altstack rest 737 | with 738 | | _ -> invalid_arg "Run.eval: op_0notequal is limited to 4 bytes max input") 739 | | O Op_0notequal :: _rest, _ -> 740 | invalid_arg "Run.eval: op_0notequal without a top stack element" 741 | | O Op_add :: rest, x :: y :: stack -> 742 | let sum = Stack.(Int32.add (to_int32 x) (to_int32 y) |> of_int32) in 743 | eval_main iflevel (sum :: stack) altstack rest 744 | | O Op_add :: _, _ -> 745 | invalid_arg "Run.eval: op_add without at least 2 stack elements" 746 | | O Op_sub :: rest, x :: y :: stack -> 747 | let diff = Stack.(Int32.sub (to_int32 x) (to_int32 y) |> of_int32) in 748 | eval_main iflevel (diff :: stack) altstack rest 749 | | O Op_sub :: _, _ -> 750 | invalid_arg "Run.eval: op_sub without at least 2 stack elements" 751 | | O Op_mul :: _, _ -> invalid_arg "Run.eval: op_mul is disabled" 752 | | O Op_div :: _, _ -> invalid_arg "Run.eval: op_div is disabled" 753 | | O Op_mod :: _, _ -> invalid_arg "Run.eval: op_mod is disabled" 754 | | O Op_lshift :: _, _ -> invalid_arg "Run.eval: op_lshift is disabled" 755 | | O Op_rshift :: _, _ -> invalid_arg "Run.eval: op_rshift is disabled" 756 | | O Op_booland :: rest, x :: y :: stack -> 757 | let conj = Stack.((to_bool x && to_bool y) |> of_bool) in 758 | eval_main iflevel (conj :: stack) altstack rest 759 | | O Op_booland :: _, _ -> 760 | invalid_arg "Run.eval: op_booland without at least 2 stack elements" 761 | | O Op_boolor :: rest, x :: y :: stack -> 762 | let disj = Stack.((to_bool x || to_bool y) |> of_bool) in 763 | eval_main iflevel (disj :: stack) altstack rest 764 | | O Op_boolor :: _, _ -> 765 | invalid_arg "Run.eval: op_boolor without at least 2 stack elements" 766 | | O Op_numequal :: rest, x :: y :: stack -> 767 | let res = Stack.(to_int32 x = to_int32 y |> of_bool) in 768 | eval_main iflevel (res :: stack) altstack rest 769 | | O Op_numequal :: _, _ -> 770 | invalid_arg "Run.eval: op_numequal without at least 2 stack elements" 771 | | O Op_numequalverify :: rest, x :: y :: stack -> 772 | Stack.(to_int32 x = to_int32 y), stack, rest 773 | | O Op_numequalverify :: _, _ -> 774 | invalid_arg "Run.eval: op_numequalverify without at least 2 stack elements" 775 | | O Op_numnotequal :: rest, x :: y :: stack -> 776 | let res = Stack.(to_int32 x <> to_int32 y |> of_bool) in 777 | eval_main iflevel (res :: stack) altstack rest 778 | | O Op_numnotequal :: _, _ -> 779 | invalid_arg "Run.eval: op_numnotequal without at least 2 stack elements" 780 | | O Op_lessthan :: rest, x :: y :: stack -> 781 | let res = Stack.(to_int32 x < to_int32 y |> of_bool) in 782 | eval_main iflevel (res :: stack) altstack rest 783 | | O Op_lessthan :: _, _ -> 784 | invalid_arg "Run.eval: op_lessthan without at least 2 stack elements" 785 | | O Op_greaterthan :: rest, x :: y :: stack -> 786 | let res = Stack.(to_int32 x > to_int32 y |> of_bool) in 787 | eval_main iflevel (res :: stack) altstack rest 788 | | O Op_greaterthan :: _, _ -> 789 | invalid_arg "Run.eval: op_greaterthan without at least 2 stack elements" 790 | | O Op_lessthanorequal :: rest, x :: y :: stack -> 791 | let res = Stack.(to_int32 x <= to_int32 y |> of_bool) in 792 | eval_main iflevel (res :: stack) altstack rest 793 | | O Op_lessthanorequal :: _, _ -> 794 | invalid_arg "Run.eval: op_lessthanorequal without at least 2 stack elements" 795 | | O Op_greaterthanorequal :: rest, x :: y :: stack -> 796 | let res = Stack.(to_int32 x >= to_int32 y |> of_bool) in 797 | eval_main iflevel (res :: stack) altstack rest 798 | | O Op_greaterthanorequal :: _, _ -> 799 | invalid_arg "Run.eval: op_greaterthanorequal without at least 2 stack elements" 800 | | O Op_min :: rest, x :: y :: stack -> 801 | let res = Stack.(min (to_int32 x) (to_int32 y) |> of_int32) in 802 | eval_main iflevel (res :: stack) altstack rest 803 | | O Op_min :: _, _ -> 804 | invalid_arg "Run.eval: op_min without at least 2 stack elements" 805 | | O Op_max :: rest, x :: y :: stack -> 806 | let res = Stack.(max (to_int32 x) (to_int32 y) |> of_int32) in 807 | eval_main iflevel (res :: stack) altstack rest 808 | | O Op_max :: _, _ -> 809 | invalid_arg "Run.eval: op_max without at least 2 stack elements" 810 | | O Op_within :: rest, ma :: mi :: v :: stack -> 811 | let ma = Stack.to_int32 ma in 812 | let mi = Stack.to_int32 mi in 813 | let v = Stack.to_int32 v in 814 | eval_main iflevel (Stack.of_bool (v >= mi && v < ma) :: stack) altstack rest 815 | | O Op_within :: _, _ -> 816 | invalid_arg "Run.eval: op_within without at least 3 stack elements" 817 | | O Op_ripemd160 :: rest, v :: stack -> 818 | let digest = 819 | let open Digestif.RMD160 in 820 | Cstruct.(of_string (to_raw_string (digest_bigstring (to_bigarray v)))) 821 | in 822 | eval_main iflevel (digest :: stack) altstack rest 823 | | O Op_ripemd160 :: _, _ -> 824 | invalid_arg "Run.eval: op_ripemd160 without a top stack element" 825 | | O Op_sha1 :: rest, v :: stack -> 826 | let digest = 827 | let open Digestif.SHA1 in 828 | Cstruct.(of_string (to_raw_string (digest_bigstring (to_bigarray v)))) 829 | in 830 | eval_main iflevel (digest :: stack) altstack rest 831 | | O Op_sha1 :: _, _ -> invalid_arg "Run.eval: op_sha1 without a top stack element" 832 | | O Op_sha256 :: rest, v :: stack -> 833 | let open Digestif.SHA256 in 834 | let digest = 835 | Cstruct.(of_string (to_raw_string (digest_bigstring (to_bigarray v)))) 836 | in 837 | eval_main iflevel (digest :: stack) altstack rest 838 | | O Op_sha256 :: _, _ -> 839 | invalid_arg "Run.eval: op_sha256 without a top stack element" 840 | | O Op_hash160 :: rest, v :: stack -> 841 | let open Digestif in 842 | let first_hash = 843 | SHA256.(to_raw_string (digest_bigstring (Cstruct.to_bigarray v))) 844 | in 845 | let second_hash = RMD160.(to_raw_string (digest_string first_hash)) in 846 | let digest = Cstruct.of_string second_hash in 847 | eval_main iflevel (digest :: stack) altstack rest 848 | | O Op_hash160 :: _, _ -> 849 | invalid_arg "Run.eval: op_hash160 without a top stack element" 850 | | O Op_hash256 :: rest, v :: stack -> 851 | let open Digestif in 852 | let first_hash = 853 | SHA256.(to_raw_string (digest_bigstring (Cstruct.to_bigarray v))) 854 | in 855 | let second_hash = SHA256.(to_raw_string (digest_string first_hash)) in 856 | let digest = Cstruct.of_string second_hash in 857 | eval_main iflevel (digest :: stack) altstack rest 858 | | O Op_hash256 :: _, _ -> 859 | invalid_arg "Run.eval: op_hash256 without a top stack element" 860 | | _ -> invalid_arg "Run.eval: unsupported" 861 | in 862 | eval_main 0 [] [] code 863 | ;; 864 | end 865 | -------------------------------------------------------------------------------- /lib/script.mli: -------------------------------------------------------------------------------- 1 | open Util 2 | 3 | module Opcode : sig 4 | type t = 5 | | Op_pushdata of int 6 | | Op_pushdata1 7 | | Op_pushdata2 8 | | Op_pushdata4 9 | | Op_1negate 10 | | Op_1 11 | | Op_2 12 | | Op_3 13 | | Op_4 14 | | Op_5 15 | | Op_6 16 | | Op_7 17 | | Op_8 18 | | Op_9 19 | | Op_10 20 | | Op_11 21 | | Op_12 22 | | Op_13 23 | | Op_14 24 | | Op_15 25 | | Op_16 26 | | Op_nop 27 | | Op_if 28 | | Op_notif 29 | | Op_else 30 | | Op_endif 31 | | Op_verify 32 | | Op_return 33 | | Op_toaltstack 34 | | Op_fromaltstack 35 | | Op_ifdup 36 | | Op_depth 37 | | Op_drop 38 | | Op_dup 39 | | Op_nip 40 | | Op_over 41 | | Op_pick 42 | | Op_roll 43 | | Op_rot 44 | | Op_swap 45 | | Op_tuck 46 | | Op_2drop 47 | | Op_2dup 48 | | Op_3dup 49 | | Op_2over 50 | | Op_2rot 51 | | Op_2swap 52 | | Op_cat 53 | | Op_substr 54 | | Op_left 55 | | Op_right 56 | | Op_size 57 | | Op_invert 58 | | Op_and 59 | | Op_or 60 | | Op_xor 61 | | Op_equal 62 | | Op_equalverify 63 | | Op_1add 64 | | Op_1sub 65 | | Op_2mul 66 | | Op_2div 67 | | Op_negate 68 | | Op_abs 69 | | Op_not 70 | | Op_0notequal 71 | | Op_add 72 | | Op_sub 73 | | Op_mul 74 | | Op_div 75 | | Op_mod 76 | | Op_lshift 77 | | Op_rshift 78 | | Op_booland 79 | | Op_boolor 80 | | Op_numequal 81 | | Op_numequalverify 82 | | Op_numnotequal 83 | | Op_lessthan 84 | | Op_greaterthan 85 | | Op_lessthanorequal 86 | | Op_greaterthanorequal 87 | | Op_min 88 | | Op_max 89 | | Op_within 90 | | Op_ripemd160 91 | | Op_sha1 92 | | Op_sha256 93 | | Op_hash160 94 | | Op_hash256 95 | | Op_codeseparator 96 | | Op_checksig 97 | | Op_checksigverify 98 | | Op_checkmultisig 99 | | Op_checkmultisigverify 100 | | Op_checklocktimeverify 101 | | Op_checksequenceverify 102 | | Op_pubkeyhash 103 | | Op_pubkey 104 | | Op_invalidopcode 105 | | Op_reserved 106 | | Op_ver 107 | | Op_verif 108 | | Op_vernotif 109 | | Op_reserved1 110 | | Op_reserved2 111 | | Op_nop1 112 | | Op_nop4 113 | | Op_nop5 114 | | Op_nop6 115 | | Op_nop7 116 | | Op_nop8 117 | | Op_nop9 118 | | Op_nop10 119 | 120 | val of_int : int -> t 121 | val to_int : t -> int 122 | end 123 | 124 | module Element : sig 125 | type t = 126 | | O of Opcode.t 127 | | D of Cstruct.t 128 | 129 | val op_size_prefix : Cstruct.t -> t list 130 | val op_data : Cstruct.t -> t list 131 | end 132 | 133 | type t = Element.t list [@@deriving sexp] 134 | 135 | val pp : Format.formatter -> t -> unit 136 | val size : t -> int 137 | val of_cstruct : ?pos:int -> ?len:int -> Cstruct.t -> t * Cstruct.t 138 | val to_cstruct : Cstruct.t -> Element.t list -> Cstruct.t 139 | val serialize : t -> Cstruct.t 140 | val hash160 : t -> Util.Hash160.t 141 | 142 | module Std : sig 143 | module P2PKH : sig 144 | open Libsecp256k1.External 145 | 146 | val scriptRedeem : BitcoinAddr.t -> t 147 | 148 | (** [scriptSig] is [[signature ; pkh]] *) 149 | val scriptSig : Context.t -> Cstruct.t -> Key.public Key.t -> t 150 | end 151 | 152 | module P2SH : sig 153 | val scriptRedeem : t -> t 154 | end 155 | end 156 | 157 | module Run : sig 158 | val eval_exn : t -> bool * Cstruct.t list * t 159 | end 160 | -------------------------------------------------------------------------------- /lib/transaction.ml: -------------------------------------------------------------------------------- 1 | open Sexplib.Std 2 | open Libsecp256k1.External 3 | open Util 4 | 5 | module LockTime = struct 6 | type t = 7 | | Timestamp of Timestamp.t 8 | | Block of int 9 | [@@deriving sexp] 10 | 11 | let timestamp ts = Timestamp ts 12 | let block height = Block height 13 | 14 | let of_int32 i = 15 | if i < 500_000_000l 16 | then Block (Int32.to_int i) 17 | else Timestamp (Timestamp.of_int32_sec i) 18 | ;; 19 | 20 | let to_int32 = function 21 | | Block n -> Int32.of_int n 22 | | Timestamp ts -> Timestamp.to_int32_sec ts 23 | ;; 24 | 25 | let of_cstruct cs = of_int32 (Cstruct.LE.get_uint32 cs 0), Cstruct.shift cs 4 26 | 27 | let to_cstruct cs t = 28 | Cstruct.LE.set_uint32 cs 0 (to_int32 t); 29 | Cstruct.shift cs 4 30 | ;; 31 | end 32 | 33 | type t = 34 | { version : int 35 | ; inputs : Txin.t array 36 | ; outputs : Txout.t array 37 | ; lock_time : LockTime.t 38 | } 39 | [@@deriving sexp] 40 | 41 | let nb_inputs { inputs; _ } = Array.length inputs 42 | let nb_outputs { outputs; _ } = Array.length outputs 43 | let pp ppf t = Format.fprintf ppf "%a" Sexplib.Sexp.pp_hum (sexp_of_t t) 44 | let show t = Sexplib.Sexp.to_string_hum (sexp_of_t t) 45 | 46 | let create ?(version = 1) ?(lock_time = LockTime.block 0) ~inputs ~outputs () = 47 | { version; inputs; outputs; lock_time } 48 | ;; 49 | 50 | let size { inputs; outputs; _ } = 51 | 8 + ObjArray.(size inputs ~f:Txin.size + size outputs ~f:Txout.size) 52 | ;; 53 | 54 | let of_cstruct cs = 55 | let version = Cstruct.LE.get_uint32 cs 0 |> Int32.to_int in 56 | let cs = Cstruct.shift cs 4 in 57 | let inputs, cs = ObjArray.of_cstruct ~f:Txin.of_cstruct cs in 58 | let outputs, cs = ObjArray.of_cstruct ~f:Txout.of_cstruct cs in 59 | let lock_time, cs = LockTime.of_cstruct cs in 60 | { version; inputs; outputs; lock_time }, cs 61 | ;; 62 | 63 | let to_cstruct cs { version; inputs; outputs; lock_time } = 64 | Cstruct.LE.set_uint32 cs 0 (Int32.of_int version); 65 | let cs = Cstruct.shift cs 4 in 66 | let cs = ObjArray.to_cstruct cs inputs ~f:Txin.to_cstruct in 67 | let cs = ObjArray.to_cstruct cs outputs ~f:Txout.to_cstruct in 68 | LockTime.to_cstruct cs lock_time 69 | ;; 70 | 71 | let to_hex t = 72 | let cs = Cstruct.create (size t) in 73 | let _ = to_cstruct cs t in 74 | Hex.of_cstruct cs 75 | ;; 76 | 77 | let of_hex hex = 78 | let cs = Hex.to_cstruct hex in 79 | fst (of_cstruct cs) 80 | ;; 81 | 82 | let hash256 t = 83 | let cs = Cstruct.create (size t) in 84 | let _ = to_cstruct cs t in 85 | Hash256.compute_cstruct cs 86 | ;; 87 | 88 | type sighash = 89 | | All 90 | | None 91 | | Single 92 | | AllAny 93 | | NoneAny 94 | | SingleAny 95 | 96 | let int_of_sighash = function 97 | | All -> 0x01 98 | | None -> 0x02 99 | | Single -> 0x03 100 | | AllAny -> 0x81 101 | | NoneAny -> 0x82 102 | | SingleAny -> 0x83 103 | ;; 104 | 105 | let sign ?prev_out_script t idx sk kind = 106 | if idx < 0 || idx >= nb_inputs t 107 | then 108 | invalid_arg 109 | (Printf.sprintf "Protocol.Transaction.sign: %d is not a valid input index" idx); 110 | match kind with 111 | | All -> 112 | let inputs = 113 | Array.mapi 114 | (fun i input -> 115 | if i <> idx 116 | then Txin.remove_script input 117 | else ( 118 | match prev_out_script with 119 | | None -> input 120 | | Some script -> { input with script })) 121 | t.inputs 122 | in 123 | let t = { t with inputs } in 124 | let cs = Cstruct.create (size t + 1) in 125 | let cs = to_cstruct cs t in 126 | Cstruct.set_uint8 cs 0 (int_of_sighash kind); 127 | let Util.Hash256.Hash h, _ = Util.Hash256.of_cstruct cs in 128 | let signature = Sign.sign_exn Util.context ~sk (Bigstring.of_string h) in 129 | let signature_bytes = Sign.to_bytes ~der:true Util.context signature in 130 | let signature_length = Bigstring.length signature_bytes in 131 | let signature_bytes_final = Bigstring.create (signature_length + 1) in 132 | Bigstring.blit signature_bytes 0 signature_bytes_final 0 signature_length; 133 | Bigstring.set signature_bytes_final signature_length '\x01'; 134 | Cstruct.of_bigarray signature_bytes_final 135 | | _ -> invalid_arg "Protocol.Transaction.sign: signature type unsupported" 136 | ;; 137 | 138 | let sign_bch ?prev_out_script t idx sk kind = 139 | ignore (prev_out_script, t, idx, sk, kind); 140 | invalid_arg "Protocol.Transaction.sign_bch: unsupported" 141 | ;; 142 | -------------------------------------------------------------------------------- /lib/transaction.mli: -------------------------------------------------------------------------------- 1 | open Libsecp256k1.External 2 | open Util 3 | 4 | module LockTime : sig 5 | type t = 6 | | Timestamp of Timestamp.t 7 | | Block of int 8 | 9 | val timestamp : Timestamp.t -> t 10 | val block : int -> t 11 | val to_int32 : t -> Int32.t 12 | val of_cstruct : Cstruct.t -> t * Cstruct.t 13 | val to_cstruct : Cstruct.t -> t -> Cstruct.t 14 | end 15 | 16 | type t = 17 | { version : int 18 | ; inputs : Txin.t array 19 | ; outputs : Txout.t array 20 | ; lock_time : LockTime.t 21 | } 22 | [@@deriving sexp] 23 | 24 | val nb_inputs : t -> int 25 | val nb_outputs : t -> int 26 | val pp : Format.formatter -> t -> unit 27 | val show : t -> string 28 | 29 | val create 30 | : ?version:int 31 | -> ?lock_time:LockTime.t 32 | -> inputs:Txin.t array 33 | -> outputs:Txout.t array 34 | -> unit 35 | -> t 36 | 37 | val of_cstruct : Cstruct.t -> t * Cstruct.t 38 | val to_cstruct : Cstruct.t -> t -> Cstruct.t 39 | val of_hex : Hex.t -> t 40 | val to_hex : t -> Hex.t 41 | val size : t -> int 42 | val hash256 : t -> Hash256.t 43 | 44 | type sighash = 45 | | All 46 | | None 47 | | Single 48 | | AllAny 49 | | NoneAny 50 | | SingleAny 51 | 52 | val int_of_sighash : sighash -> int 53 | 54 | (** [sign ?prev_out_script t i sk sighash] is the endorsement of [t] 55 | by input [i], using secret key [sk] and sighash [sighash]. If 56 | [prev_out_script] is provided, it is used as the script for the 57 | [i]'s input, otherwise [i]'s input script is left as-is. *) 58 | val sign 59 | : ?prev_out_script:Script.t 60 | -> t 61 | -> int 62 | -> Key.secret Key.t 63 | -> sighash 64 | -> Cstruct.t 65 | 66 | (** See above, but for Bitcoin Cash. *) 67 | val sign_bch 68 | : ?prev_out_script:Script.t 69 | -> t 70 | -> int 71 | -> Key.secret Key.t 72 | -> sighash 73 | -> Cstruct.t 74 | -------------------------------------------------------------------------------- /lib/txin.ml: -------------------------------------------------------------------------------- 1 | open Sexplib.Std 2 | open Util 3 | 4 | type t = 5 | { prev_out : Outpoint.t 6 | ; script : Script.t 7 | ; seq : int32 8 | } 9 | [@@deriving sexp] 10 | 11 | let pp ppf t = Format.fprintf ppf "%a" Sexplib.Sexp.pp_hum (sexp_of_t t) 12 | let show t = Sexplib.Sexp.to_string_hum (sexp_of_t t) 13 | let create ?(seq = 0xffffffffl) ~prev_out ~script () = { prev_out; script; seq } 14 | 15 | let create' ?(seq = 0xffffffffl) ~prev_out_hash ~prev_out_i ~script () = 16 | let prev_out = Outpoint.create prev_out_hash prev_out_i in 17 | { prev_out; script; seq } 18 | ;; 19 | 20 | let size { script; _ } = 21 | let scriptsize = Script.size script in 22 | let scriptsizesize = CompactSize.(of_int scriptsize |> size) in 23 | Outpoint.size + scriptsizesize + scriptsize + 4 24 | ;; 25 | 26 | let of_cstruct cs = 27 | let prev_out, cs = Outpoint.of_cstruct cs in 28 | let scriptsize, cs = CompactSize.of_cstruct_int cs in 29 | let script, cs = Script.of_cstruct cs ~len:scriptsize in 30 | let seq = Cstruct.LE.get_uint32 cs 0 in 31 | { prev_out; script; seq }, Cstruct.shift cs 4 32 | ;; 33 | 34 | let to_cstruct cs { prev_out; script; seq } = 35 | let scriptsize = Script.size script in 36 | let cs = Outpoint.to_cstruct cs prev_out in 37 | let cs = CompactSize.to_cstruct_int cs scriptsize in 38 | let cs = Script.to_cstruct cs script in 39 | Cstruct.LE.set_uint32 cs 0 seq; 40 | Cstruct.shift cs 4 41 | ;; 42 | 43 | let remove_script t = { t with script = [] } 44 | -------------------------------------------------------------------------------- /lib/txin.mli: -------------------------------------------------------------------------------- 1 | open Util 2 | 3 | type t = 4 | { prev_out : Outpoint.t 5 | ; script : Script.t 6 | ; seq : Int32.t 7 | } 8 | [@@deriving sexp] 9 | 10 | val pp : Format.formatter -> t -> unit 11 | val show : t -> string 12 | val create : ?seq:Int32.t -> prev_out:Outpoint.t -> script:Script.t -> unit -> t 13 | 14 | val create' 15 | : ?seq:Int32.t 16 | -> prev_out_hash:Hash256.t 17 | -> prev_out_i:int 18 | -> script:Script.t 19 | -> unit 20 | -> t 21 | 22 | val size : t -> int 23 | val of_cstruct : Cstruct.t -> t * Cstruct.t 24 | val to_cstruct : Cstruct.t -> t -> Cstruct.t 25 | 26 | (** [remove_script t] is [t] with [t.script] set to [[]]. *) 27 | val remove_script : t -> t 28 | -------------------------------------------------------------------------------- /lib/txout.ml: -------------------------------------------------------------------------------- 1 | open Sexplib.Std 2 | open Util 3 | 4 | type t = 5 | { value : int64 6 | ; script : Script.t 7 | } 8 | [@@deriving sexp] 9 | 10 | let pp ppf t = Format.fprintf ppf "%a" Sexplib.Sexp.pp_hum (sexp_of_t t) 11 | let show t = Sexplib.Sexp.to_string_hum (sexp_of_t t) 12 | let create ~value ~script = { value; script } 13 | 14 | let size { script; _ } = 15 | let scriptsize = Script.size script in 16 | let scriptsizesize = CompactSize.(of_int scriptsize |> size) in 17 | 8 + scriptsizesize + scriptsize 18 | ;; 19 | 20 | let of_cstruct cs = 21 | let value = Cstruct.LE.get_uint64 cs 0 in 22 | let scriptsize, cs = CompactSize.of_cstruct_int (Cstruct.shift cs 8) in 23 | let script, cs = Script.of_cstruct cs ~len:scriptsize in 24 | { value; script }, cs 25 | ;; 26 | 27 | let to_cstruct cs { value; script } = 28 | let scriptsize = Script.size script in 29 | Cstruct.LE.set_uint64 cs 0 value; 30 | let cs = CompactSize.to_cstruct_int (Cstruct.shift cs 8) scriptsize in 31 | Script.to_cstruct cs script 32 | ;; 33 | -------------------------------------------------------------------------------- /lib/txout.mli: -------------------------------------------------------------------------------- 1 | type t = 2 | { value : Int64.t 3 | ; script : Script.t 4 | } 5 | [@@deriving sexp] 6 | 7 | val pp : Format.formatter -> t -> unit 8 | val show : t -> string 9 | val create : value:Int64.t -> script:Script.t -> t 10 | val size : t -> int 11 | val of_cstruct : Cstruct.t -> t * Cstruct.t 12 | val to_cstruct : Cstruct.t -> t -> Cstruct.t 13 | -------------------------------------------------------------------------------- /lib/util.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2017 Vincent Bernardoff. All rights reserved. 3 | Distributed under the GNU Affero GPL license, see LICENSE. 4 | ---------------------------------------------------------------------------*) 5 | 6 | let string_rev s = 7 | let len = String.length s in 8 | let r = Bytes.create len in 9 | for i = 0 to len - 1 do 10 | Bytes.set r i (String.get s (len - 1 - i)) 11 | done; 12 | Bytes.unsafe_to_string r 13 | ;; 14 | 15 | let c_string_of_cstruct cs = 16 | let str = Cstruct.to_string cs in 17 | String.(sub str 0 (index str '\x00')) 18 | ;; 19 | 20 | let bytes_with_msg ~len msg = 21 | let buf = Bytes.make len '\x00' in 22 | Bytes.blit_string msg 0 buf 0 (min (Bytes.length buf - 1) (String.length msg)); 23 | Bytes.unsafe_to_string buf 24 | ;; 25 | 26 | module Bool = struct 27 | let of_int = function 28 | | 1 -> true 29 | | 0 -> false 30 | | _ -> invalid_arg "Bool.of_int" 31 | ;; 32 | 33 | let to_int = function 34 | | false -> 0 35 | | true -> 1 36 | ;; 37 | end 38 | 39 | module Timestamp = struct 40 | include Ptime 41 | 42 | let t_of_sexp sexp = 43 | let open Sexplib.Std in 44 | let sexp_str = string_of_sexp sexp in 45 | match of_rfc3339 sexp_str with 46 | | Ok (t, _, _) -> t 47 | | _ -> invalid_arg "Timestamp.t_of_sexp" 48 | ;; 49 | 50 | let sexp_of_t t = 51 | let open Sexplib.Std in 52 | sexp_of_string (to_rfc3339 t) 53 | ;; 54 | 55 | let of_int_sec s = 56 | match Span.of_int_s s |> of_span with 57 | | None -> invalid_arg "Timestamp.of_int_sec" 58 | | Some t -> t 59 | ;; 60 | 61 | let to_int_sec t = 62 | match Span.to_int_s (to_span t) with 63 | | None -> invalid_arg "Timestamp.to_int_sec" 64 | | Some s -> s 65 | ;; 66 | 67 | let of_int32_sec s = of_int_sec (Int32.to_int s) 68 | let to_int32_sec s = Int32.of_int (to_int_sec s) 69 | let of_int64_sec s = of_int_sec (Int64.to_int s) 70 | let to_int64_sec s = Int64.of_int (to_int_sec s) 71 | 72 | (* let of_int64 i = *) 73 | (* let to_int64 t = Int64.of_float (Ptime.to_float_s t) *) 74 | 75 | (* let of_int32 i = 76 | * match Int32.to_float i |> Ptime.of_float_s with 77 | * | None -> invalid_arg "Timestamp.of_int64" 78 | * | Some ts -> ts 79 | * 80 | * let to_int32 t = Int32.of_float (Ptime.to_float_s t) *) 81 | 82 | include Ptime_clock 83 | end 84 | 85 | module Hash (H2 : Digestif.S) (H1 : Digestif.S) = struct 86 | module T = struct 87 | type t = Hash of string 88 | 89 | let hash = Hashtbl.hash 90 | let compare (Hash a) (Hash b) = String.compare a b 91 | let equal (Hash a) (Hash b) = String.equal a b 92 | end 93 | 94 | include T 95 | module Set = Set.Make (T) 96 | module Map = Map.Make (T) 97 | module Table = Hashtbl.Make (T) 98 | 99 | let length = H2.digest_size 100 | 101 | let of_string s = 102 | if String.length s <> length 103 | then invalid_arg (Printf.sprintf "Hash.of_string: length must be %d" length) 104 | else Hash s 105 | ;; 106 | 107 | let empty = of_string (String.make length '\x00') 108 | let of_hex_internal h = of_string (Hex.to_string h) 109 | let of_hex_rpc h = Hex.to_string h |> string_rev |> of_string 110 | 111 | let to_cstruct cs (Hash s) = 112 | Cstruct.blit_from_string s 0 cs 0 length; 113 | Cstruct.shift cs length 114 | ;; 115 | 116 | let to_string (Hash s) = s 117 | 118 | let pp ppf (Hash s) = 119 | let (`Hex s_hex) = Hex.of_string (string_rev s) in 120 | Format.fprintf ppf "%s" s_hex 121 | ;; 122 | 123 | let show t = Format.asprintf "%a" pp t 124 | let sexp_of_t t = Sexplib.Std.sexp_of_string (show t) 125 | let t_of_sexp sexp = of_hex_rpc (`Hex (Sexplib.Std.string_of_sexp sexp)) 126 | 127 | let of_cstruct cs = 128 | Hash (Cstruct.to_string cs ~off:0 ~len:length), Cstruct.shift cs length 129 | ;; 130 | 131 | let compute_bigarray data = 132 | let first_hash = H1.(to_raw_string (digest_bigstring data)) in 133 | let second_hash = H2.(to_raw_string (digest_string first_hash)) in 134 | Hash second_hash 135 | ;; 136 | 137 | let compute_cstruct cs = compute_bigarray (Cstruct.to_bigarray cs) 138 | 139 | let compute_string data = 140 | let first_hash = H1.(to_raw_string (digest_string data)) in 141 | let second_hash = H2.(to_raw_string (digest_string first_hash)) in 142 | Hash second_hash 143 | ;; 144 | 145 | let compute_concat (Hash h1) (Hash h2) = compute_string (h1 ^ h2) 146 | end 147 | 148 | module type HASH = sig 149 | type t = private Hash of string [@@deriving sexp] 150 | 151 | val compare : t -> t -> int 152 | val equal : t -> t -> bool 153 | val length : int 154 | val hash : t -> int 155 | val empty : t 156 | val of_hex_internal : Hex.t -> t 157 | val of_hex_rpc : Hex.t -> t 158 | val pp : Format.formatter -> t -> unit 159 | val show : t -> string 160 | val compute_bigarray : Cstruct.buffer -> t 161 | val compute_cstruct : Cstruct.t -> t 162 | val compute_string : string -> t 163 | val compute_concat : t -> t -> t 164 | val of_string : string -> t 165 | val of_cstruct : Cstruct.t -> t * Cstruct.t 166 | val to_string : t -> string 167 | val to_cstruct : Cstruct.t -> t -> Cstruct.t 168 | 169 | module Set : Set.S with type elt = t 170 | module Map : Map.S with type key = t 171 | module Table : Hashtbl.S with type key = t 172 | end 173 | 174 | module Hash160 : HASH = Hash (Digestif.RMD160) (Digestif.SHA256) 175 | module Hash256 : HASH = Hash (Digestif.SHA256) (Digestif.SHA256) 176 | 177 | module BitcoinAddr = Base58.Bitcoin.Make (struct 178 | let sha256 x = Digestif.SHA256.(digest_string x |> to_raw_string) 179 | end) 180 | 181 | module Chksum = struct 182 | let compute cs = 183 | let data = Cstruct.to_bigarray cs in 184 | let open Digestif.SHA256 in 185 | let first_hash = to_raw_string (digest_bigstring data) in 186 | let second_hash = to_raw_string (digest_string first_hash) in 187 | String.sub second_hash 0 4 188 | ;; 189 | 190 | let compute' cs_start cs_end = 191 | let size = cs_end.Cstruct.off - cs_start.Cstruct.off in 192 | size, compute (Cstruct.sub cs_start 0 size) 193 | ;; 194 | 195 | let verify ~expected data = String.equal expected (compute data) 196 | 197 | exception Invalid_checksum of string * string 198 | 199 | let verify_exn ~expected data = 200 | let computed = compute data in 201 | if not (String.equal expected computed) 202 | then raise (Invalid_checksum (expected, computed)) 203 | ;; 204 | end 205 | 206 | module CompactSize = struct 207 | type t = 208 | | Int of int 209 | | Int32 of Int32.t 210 | | Int64 of Int64.t 211 | 212 | let of_int i = Int i 213 | let of_int32 i = Int32 i 214 | let of_int64 i = Int64 i 215 | 216 | let size = function 217 | | Int n when n < 0xFD -> 1 218 | | Int n when n < 0x10000 -> 3 219 | | Int _ -> 5 220 | | Int32 _ -> 5 221 | | Int64 _ -> 9 222 | ;; 223 | 224 | (* let read ?(pos=0) buf = 225 | * let open EndianString.LittleEndian in 226 | * match get_uint8 buf pos with 227 | * | 0xFD -> Int (get_uint16 buf (pos+1)) 228 | * | 0xFE -> Int32 (get_int32 buf (pos+1)) 229 | * | 0xFF -> Int64 (get_int64 buf (pos+1)) 230 | * | n -> Int n 231 | * 232 | * let write ?(pos=0) buf t = 233 | * let open EndianString.LittleEndian in 234 | * match t with 235 | * | Int n when n < 0xFD -> set_int8 buf pos n 236 | * | Int n when n < 0x10000 -> 237 | * set_int8 buf pos 0xFD ; 238 | * set_int16 buf (pos+1) n 239 | * | Int n -> 240 | * set_int8 buf pos 0xFE ; 241 | * set_int32 buf (pos+1) (Int32.of_int n) 242 | * | Int32 n -> 243 | * set_int8 buf pos 0xFE ; 244 | * set_int32 buf (pos+1) n 245 | * | Int64 n -> 246 | * set_int8 buf pos 0xFF ; 247 | * set_int64 buf (pos+1) n *) 248 | 249 | let of_cstruct cs = 250 | let open Cstruct in 251 | match get_uint8 cs 0 with 252 | | 0xFD -> Int (LE.get_uint16 cs 1), shift cs 3 253 | | 0xFE -> Int32 (LE.get_uint32 cs 1), shift cs 5 254 | | 0xFF -> Int64 (LE.get_uint64 cs 1), shift cs 9 255 | | n -> Int n, shift cs 1 256 | ;; 257 | 258 | let of_cstruct_int cs = 259 | match of_cstruct cs with 260 | | Int i, cs -> i, cs 261 | | Int32 i, cs -> Int32.to_int i, cs 262 | | Int64 i, cs -> Int64.to_int i, cs 263 | ;; 264 | 265 | let to_cstruct cs t = 266 | let open Cstruct in 267 | match t with 268 | | Int n when n < 0xFD -> 269 | set_uint8 cs 0 n; 270 | shift cs 1 271 | | Int n when n < 0x10000 -> 272 | set_uint8 cs 0 0xFD; 273 | LE.set_uint16 cs 1 n; 274 | shift cs 3 275 | | Int n -> 276 | set_uint8 cs 0 0xFE; 277 | LE.set_uint32 cs 1 (Int32.of_int n); 278 | shift cs 5 279 | | Int32 n -> 280 | set_uint8 cs 0 0xFE; 281 | LE.set_uint32 cs 1 n; 282 | shift cs 5 283 | | Int64 n -> 284 | set_uint8 cs 0 0xFF; 285 | LE.set_uint64 cs 1 n; 286 | shift cs 9 287 | ;; 288 | 289 | let to_cstruct_int cs i = to_cstruct cs (Int i) 290 | end 291 | 292 | module VarString = struct 293 | let of_cstruct cs = 294 | let length', cs = CompactSize.of_cstruct_int cs in 295 | Cstruct.(sub cs 0 length' |> to_string, shift cs length') 296 | ;; 297 | 298 | let to_cstruct cs s = 299 | let len = String.length s in 300 | let cs = CompactSize.to_cstruct_int cs len in 301 | Cstruct.blit_from_string s 0 cs 0 len; 302 | Cstruct.shift cs len 303 | ;; 304 | end 305 | 306 | module type COLL = sig 307 | type 'a t 308 | 309 | val of_list : 'a list -> 'a t 310 | val length : 'a t -> int 311 | val fold_left : f:('a -> 'b -> 'a) -> init:'a -> 'b t -> 'a 312 | end 313 | 314 | module ObjColl (C : COLL) = struct 315 | let size elts ~f = 316 | C.fold_left 317 | elts 318 | ~init:(CompactSize.size (Int (C.length elts))) 319 | ~f:(fun a e -> a + f e) 320 | ;; 321 | 322 | let rec inner obj_of_cstruct acc cs = function 323 | | 0 -> C.of_list (List.rev acc), cs 324 | | n -> 325 | let obj, cs = obj_of_cstruct cs in 326 | inner obj_of_cstruct (obj :: acc) cs (pred n) 327 | ;; 328 | 329 | let of_cstruct cs ~f = 330 | let nb_objs, cs = CompactSize.of_cstruct_int cs in 331 | inner f [] cs nb_objs 332 | ;; 333 | 334 | let to_cstruct cs objs ~f = 335 | let len = C.length objs in 336 | let cs = CompactSize.to_cstruct_int cs len in 337 | C.fold_left objs ~init:cs ~f:(fun cs o -> f cs o) 338 | ;; 339 | end 340 | 341 | module ObjList = ObjColl (struct 342 | include ListLabels 343 | 344 | let of_list a = a 345 | end) 346 | 347 | module ObjArray = ObjColl (ArrayLabels) 348 | 349 | module Bitv = struct 350 | open Sexplib.Std 351 | include Bitv 352 | 353 | let t_of_sexp sexp = string_of_sexp sexp |> Bitv.L.of_string 354 | let sexp_of_t t = Bitv.L.to_string t |> sexp_of_string 355 | 356 | let to_string_le bitv = 357 | let nb_bytes = Bitv.length bitv / 8 in 358 | let s = Bytes.create nb_bytes in 359 | let v = ref 0 in 360 | for i = 0 to nb_bytes - 1 do 361 | v := 0; 362 | for j = 0 to 7 do 363 | if Bitv.get bitv ((8 * i) + j) then v := !v lor (1 lsl j) 364 | done; 365 | Bytes.set_int8 s i !v 366 | done; 367 | Bytes.unsafe_to_string s 368 | ;; 369 | 370 | let of_string_le s = 371 | let len = String.length s in 372 | let bitv = Bitv.create (len * 8) false in 373 | for i = 0 to len - 1 do 374 | let v = String.get_int8 s i in 375 | for j = 0 to 7 do 376 | if v land (1 lsl j) <> 0 then Bitv.set bitv ((8 * i) + j) true 377 | done 378 | done; 379 | bitv 380 | ;; 381 | 382 | let to_bool_list bv = Bitv.fold_right (fun v acc -> v :: acc) bv [] 383 | end 384 | 385 | module Crypto = struct 386 | let sha256 s = Digestif.SHA256.(to_raw_string (digest_string s)) 387 | end 388 | 389 | let context = Libsecp256k1.External.Context.create () 390 | -------------------------------------------------------------------------------- /lib/util.mli: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2017 Vincent Bernardoff. All rights reserved. 3 | Distributed under the GNU Affero GPL license, see LICENSE. 4 | ---------------------------------------------------------------------------*) 5 | 6 | val c_string_of_cstruct : Cstruct.t -> string 7 | val bytes_with_msg : len:int -> string -> String.t 8 | 9 | module Bool : sig 10 | val of_int : int -> bool 11 | val to_int : bool -> int 12 | end 13 | 14 | module Timestamp : sig 15 | include module type of Ptime 16 | 17 | val t_of_sexp : Sexplib.Sexp.t -> t 18 | val sexp_of_t : t -> Sexplib.Sexp.t 19 | val of_int_sec : int -> t 20 | val to_int_sec : t -> int 21 | val of_int64_sec : Int64.t -> t 22 | val to_int64_sec : t -> Int64.t 23 | val of_int32_sec : Int32.t -> t 24 | val to_int32_sec : t -> Int32.t 25 | val now : unit -> t 26 | end 27 | 28 | module type HASH = sig 29 | type t = private Hash of string [@@deriving sexp] 30 | 31 | val compare : t -> t -> int 32 | val equal : t -> t -> bool 33 | val length : int 34 | val hash : t -> int 35 | val empty : t 36 | val of_hex_internal : Hex.t -> t 37 | val of_hex_rpc : Hex.t -> t 38 | val pp : Format.formatter -> t -> unit 39 | val show : t -> string 40 | val compute_bigarray : Cstruct.buffer -> t 41 | val compute_cstruct : Cstruct.t -> t 42 | val compute_string : string -> t 43 | val compute_concat : t -> t -> t 44 | val of_string : string -> t 45 | val of_cstruct : Cstruct.t -> t * Cstruct.t 46 | val to_string : t -> string 47 | val to_cstruct : Cstruct.t -> t -> Cstruct.t 48 | 49 | module Set : Set.S with type elt = t 50 | module Map : Map.S with type key = t 51 | module Table : Hashtbl.S with type key = t 52 | end 53 | 54 | module Hash160 : HASH 55 | module Hash256 : HASH 56 | module BitcoinAddr : Base58.S with type version = Base58.Bitcoin.Version.t 57 | 58 | module Chksum : sig 59 | val compute : Cstruct.t -> string 60 | val compute' : Cstruct.t -> Cstruct.t -> int * string 61 | val verify : expected:string -> Cstruct.t -> bool 62 | 63 | exception Invalid_checksum of string * string 64 | 65 | (** @raises Invalid_checksum on error. *) 66 | val verify_exn : expected:string -> Cstruct.t -> unit 67 | end 68 | 69 | module CompactSize : sig 70 | type t = 71 | | Int of int 72 | | Int32 of Int32.t 73 | | Int64 of Int64.t 74 | 75 | val of_int : int -> t 76 | val of_int32 : Int32.t -> t 77 | val of_int64 : Int64.t -> t 78 | val size : t -> int 79 | val of_cstruct : Cstruct.t -> t * Cstruct.t 80 | val of_cstruct_int : Cstruct.t -> int * Cstruct.t 81 | val to_cstruct : Cstruct.t -> t -> Cstruct.t 82 | val to_cstruct_int : Cstruct.t -> int -> Cstruct.t 83 | end 84 | 85 | module VarString : sig 86 | val of_cstruct : Cstruct.t -> string * Cstruct.t 87 | val to_cstruct : Cstruct.t -> string -> Cstruct.t 88 | end 89 | 90 | module ObjList : sig 91 | val size : 'a list -> f:('a -> int) -> int 92 | val of_cstruct : Cstruct.t -> f:(Cstruct.t -> 'a * Cstruct.t) -> 'a list * Cstruct.t 93 | val to_cstruct : Cstruct.t -> 'a list -> f:(Cstruct.t -> 'a -> Cstruct.t) -> Cstruct.t 94 | end 95 | 96 | module ObjArray : sig 97 | val size : 'a array -> f:('a -> int) -> int 98 | val of_cstruct : Cstruct.t -> f:(Cstruct.t -> 'a * Cstruct.t) -> 'a array * Cstruct.t 99 | val to_cstruct : Cstruct.t -> 'a array -> f:(Cstruct.t -> 'a -> Cstruct.t) -> Cstruct.t 100 | end 101 | 102 | module Bitv : sig 103 | include module type of Bitv with type t = Bitv.t 104 | 105 | val t_of_sexp : Sexplib.Sexp.t -> t 106 | val sexp_of_t : t -> Sexplib.Sexp.t 107 | val to_string_le : t -> string 108 | val of_string_le : string -> t 109 | val to_bool_list : t -> bool list 110 | end 111 | 112 | module Crypto : Base58.CRYPTO 113 | 114 | (** [context] is a [secp256k1] context initialized for signind and 115 | verifying. *) 116 | val context : Libsecp256k1.External.Context.t 117 | -------------------------------------------------------------------------------- /lib/wallet.ml: -------------------------------------------------------------------------------- 1 | open Libsecp256k1.External 2 | open Util 3 | 4 | (* module Private = struct 5 | * let generate ctx = 6 | * let buf = Bigstring.create 32 in 7 | * let rec loop_gen () = 8 | * let _nb_written = Monocypher.Rand.write buf in 9 | * match Key.read_sk ctx buf with 10 | * | Ok t -> t 11 | * | Error _ -> loop_gen () 12 | * in loop_gen () 13 | * end *) 14 | 15 | module WIF = struct 16 | type t = 17 | { privkey : Key.secret Key.t 18 | ; testnet : bool 19 | ; compress : bool 20 | } 21 | 22 | let create ?(testnet = false) ?(compress = true) privkey = 23 | { privkey; testnet; compress } 24 | ;; 25 | 26 | let to_base58 ctx { privkey; testnet; compress } = 27 | let version = if testnet then Base58.Bitcoin.Version.Testnet_privkey else Privkey in 28 | let cs = Cstruct.create (if compress then 32 else 33) in 29 | let _nb_written = Key.write ~compress ctx cs.buffer privkey in 30 | if compress then Cstruct.set_uint8 cs 32 0x01; 31 | BitcoinAddr.create ~version ~payload:(Cstruct.to_string cs) 32 | ;; 33 | 34 | let of_base58 ctx { BitcoinAddr.version; payload } = 35 | let open Rresult in 36 | (match version with 37 | | Privkey -> R.return false 38 | | Testnet_privkey -> R.return true 39 | | _ -> R.fail "Wallet.WIF.of_base58: not a private key") 40 | >>= fun testnet -> 41 | let compress = String.length payload = 33 in 42 | let cs = Cstruct.of_string payload in 43 | Key.read_sk ctx cs.buffer >>| fun privkey -> create ~testnet ~compress privkey 44 | ;; 45 | 46 | let pp ctx ppf t = BitcoinAddr.pp ppf (to_base58 ctx t) 47 | let show ctx t = BitcoinAddr.show (to_base58 ctx t) 48 | end 49 | 50 | module Address = struct 51 | let of_wif ctx { WIF.privkey; testnet; compress } = 52 | let pk = Key.neuterize_exn ctx privkey in 53 | let pk = Key.to_bytes ~compress ctx pk in 54 | let hash160 = Util.Hash160.compute_bigarray pk in 55 | BitcoinAddr.create 56 | ~version:(if testnet then Testnet_P2PKH else P2PKH) 57 | ~payload:(Util.Hash160.to_string hash160) 58 | ;; 59 | 60 | let of_pubkey ?(version = Base58.Bitcoin.Version.P2PKH) ?(compress = true) ctx pk = 61 | let pk = Key.to_bytes ~compress ctx pk in 62 | let hash160 = Util.Hash160.compute_bigarray pk in 63 | BitcoinAddr.create ~version ~payload:(Util.Hash160.to_string hash160) 64 | ;; 65 | 66 | let max_serialized_script_size = 520 67 | 68 | let of_script ?(version = Base58.Bitcoin.Version.P2SH) script = 69 | let cs = Cstruct.create max_serialized_script_size in 70 | let cs' = Script.to_cstruct cs script in 71 | let hash160 = Util.Hash160.compute_cstruct (Cstruct.sub cs 0 cs'.off) in 72 | BitcoinAddr.create ~version ~payload:(Util.Hash160.to_string hash160) 73 | ;; 74 | 75 | let to_script { BitcoinAddr.version; payload } = 76 | match version with 77 | | P2PKH | Testnet_P2PKH -> 78 | Script.Element. 79 | [ O Op_dup 80 | ; O Op_hash160 81 | ; O (Op_pushdata 20) 82 | ; D (Cstruct.of_string payload) 83 | ; O Op_equalverify 84 | ; O Op_checksig 85 | ] 86 | | P2SH | Testnet_P2SH -> 87 | Script.Element. 88 | [ O Op_hash160 89 | ; O (Op_pushdata 20) 90 | ; D (Cstruct.of_string payload) 91 | ; O Op_equalverify 92 | ] 93 | | _ -> invalid_arg "Address.to_script: unsupported address format" 94 | ;; 95 | end 96 | 97 | module KeyPath = struct 98 | let of_hardened i = Int32.logand i 0x7fff_ffffl 99 | let to_hardened i = Int32.logor i 0x8000_0000l 100 | 101 | let derivation_of_string d = 102 | match String.(get d (length d - 1)) with 103 | | '\'' -> 104 | let v = String.(sub d 0 (length d - 1)) |> Int32.of_string in 105 | Int32.logor 0x8000_0000l v 106 | | _ -> Int32.of_string d 107 | ;; 108 | 109 | let string_of_derivation = function 110 | | i when Int32.logand 0x8000_0000l i = 0l -> Int32.to_string i 111 | | i -> Int32.to_string (of_hardened i) ^ "'" 112 | ;; 113 | 114 | type t = Int32.t list 115 | 116 | let of_string_exn s = 117 | try 118 | let derivations = String.split_on_char '/' s in 119 | ListLabels.map derivations ~f:derivation_of_string 120 | with 121 | | _ -> invalid_arg (Printf.sprintf "KeyPath.of_string_exn: got %S" s) 122 | ;; 123 | 124 | let of_string s = 125 | try Some (of_string_exn s) with 126 | | _ -> None 127 | ;; 128 | 129 | let to_string t = ListLabels.map t ~f:string_of_derivation |> String.concat "/" 130 | let pp ppf t = Format.pp_print_string ppf (to_string t) 131 | 132 | let write_be buf pos t = 133 | let len = 134 | ListLabels.fold_left t ~init:0 ~f:(fun i v -> 135 | Bytes.set_int32_be buf (pos + (i * 4)) v; 136 | i + 1) 137 | in 138 | pos + (len * 4) 139 | ;; 140 | 141 | let write_be_cstruct cs t = 142 | let open Cstruct in 143 | ListLabels.fold_left t ~init:cs ~f:(fun cs v -> 144 | BE.set_uint32 cs 0 v; 145 | Cstruct.shift cs 4) 146 | ;; 147 | end 148 | 149 | module Bip44 = struct 150 | module CoinType = struct 151 | type t = 152 | | Bitcoin 153 | | Bitcoin_testnet 154 | 155 | let to_int32 = function 156 | | Bitcoin -> 0l 157 | | Bitcoin_testnet -> 1l 158 | ;; 159 | 160 | let of_int32 = function 161 | | 0l -> Bitcoin 162 | | 1l -> Bitcoin_testnet 163 | | _ -> invalid_arg "Bip44.CoinType.of_int" 164 | ;; 165 | 166 | let pp ppf ct = Format.fprintf ppf "%ld" (to_int32 ct) 167 | end 168 | 169 | module Chain = struct 170 | type t = 171 | | External 172 | | Internal 173 | 174 | let to_int32 = function 175 | | External -> 0l 176 | | Internal -> 1l 177 | ;; 178 | 179 | let of_int32 = function 180 | | 0l -> External 181 | | 1l -> Internal 182 | | _ -> invalid_arg "Bip44.Chain.of_int" 183 | ;; 184 | 185 | let pp ppf chain = Format.fprintf ppf "%ld" (to_int32 chain) 186 | end 187 | 188 | module Purpose = struct 189 | type t = Bip44 190 | 191 | let to_int32 = function 192 | | Bip44 -> 44l 193 | ;; 194 | 195 | let of_int32 = function 196 | | 44l -> Bip44 197 | | _ -> invalid_arg "Bip44.Purpose.of_int" 198 | ;; 199 | 200 | let pp ppf purpose = Format.fprintf ppf "%ld" (to_int32 purpose) 201 | end 202 | 203 | type t = 204 | { purpose : Purpose.t 205 | ; coin_type : CoinType.t 206 | ; account : int 207 | ; chain : Chain.t 208 | ; index : int 209 | } 210 | 211 | let create 212 | ?(purpose = Purpose.Bip44) 213 | ?(coin_type = CoinType.Bitcoin) 214 | ?(account = 0) 215 | ?(chain = Chain.External) 216 | ?(index = 0) 217 | () 218 | = 219 | { purpose; coin_type; account; chain; index } 220 | ;; 221 | 222 | let of_keypath = function 223 | | [ purpose; coin_type; account; chain; index ] -> 224 | let purpose = Purpose.of_int32 (KeyPath.of_hardened purpose) in 225 | let coin_type = CoinType.of_int32 (KeyPath.of_hardened coin_type) in 226 | let account = Int32.to_int (KeyPath.of_hardened account) in 227 | let chain = Chain.of_int32 chain in 228 | let index = Int32.to_int index in 229 | { purpose; coin_type; account; chain; index } 230 | | _ -> invalid_arg "Bip44.of_keypath" 231 | ;; 232 | 233 | let to_keypath { purpose; coin_type; account; chain; index } = 234 | KeyPath. 235 | [ to_hardened (Purpose.to_int32 purpose) 236 | ; to_hardened (CoinType.to_int32 coin_type) 237 | ; to_hardened (Int32.of_int account) 238 | ; Chain.to_int32 chain 239 | ; Int32.of_int index 240 | ] 241 | ;; 242 | end 243 | -------------------------------------------------------------------------------- /lib/wallet.mli: -------------------------------------------------------------------------------- 1 | open Util 2 | open Libsecp256k1.External 3 | 4 | (* module Private : sig 5 | * val generate : Context.t -> Key.secret Key.t 6 | * end *) 7 | 8 | module WIF : sig 9 | type t = private 10 | { privkey : Key.secret Key.t 11 | ; testnet : bool 12 | ; compress : bool 13 | } 14 | 15 | val pp : Context.t -> Format.formatter -> t -> unit 16 | val show : Context.t -> t -> string 17 | val create : ?testnet:bool -> ?compress:bool -> Key.secret Key.t -> t 18 | val to_base58 : Context.t -> t -> BitcoinAddr.t 19 | val of_base58 : Context.t -> BitcoinAddr.t -> (t, string) result 20 | end 21 | 22 | module Address : sig 23 | val of_wif : Context.t -> WIF.t -> BitcoinAddr.t 24 | 25 | val of_pubkey 26 | : ?version:BitcoinAddr.version 27 | -> ?compress:bool 28 | -> Context.t 29 | -> Key.public Key.t 30 | -> BitcoinAddr.t 31 | 32 | val of_script : ?version:BitcoinAddr.version -> Script.t -> BitcoinAddr.t 33 | val to_script : BitcoinAddr.t -> Script.t 34 | end 35 | 36 | module KeyPath : sig 37 | type t = Int32.t list 38 | 39 | val of_hardened : int32 -> int32 40 | val to_hardened : int32 -> int32 41 | val of_string_exn : string -> t 42 | val of_string : string -> t option 43 | val to_string : t -> string 44 | val pp : Format.formatter -> t -> unit 45 | val write_be : Bytes.t -> int -> t -> int 46 | val write_be_cstruct : Cstruct.t -> t -> Cstruct.t 47 | end 48 | 49 | module Bip44 : sig 50 | module Purpose : sig 51 | type t = Bip44 52 | 53 | val pp : Format.formatter -> t -> unit 54 | end 55 | 56 | module CoinType : sig 57 | type t = 58 | | Bitcoin 59 | | Bitcoin_testnet 60 | 61 | val pp : Format.formatter -> t -> unit 62 | end 63 | 64 | module Chain : sig 65 | type t = 66 | | External 67 | | Internal 68 | 69 | val pp : Format.formatter -> t -> unit 70 | end 71 | 72 | type t = 73 | { purpose : Purpose.t 74 | ; coin_type : CoinType.t 75 | ; account : int 76 | ; chain : Chain.t 77 | ; index : int 78 | } 79 | 80 | val create 81 | : ?purpose:Purpose.t 82 | -> ?coin_type:CoinType.t 83 | -> ?account:int 84 | -> ?chain:Chain.t 85 | -> ?index:int 86 | -> unit 87 | -> t 88 | 89 | val of_keypath : KeyPath.t -> t 90 | val to_keypath : t -> KeyPath.t 91 | end 92 | -------------------------------------------------------------------------------- /test/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name test) 3 | (libraries 4 | bitcoin 5 | alcotest)) 6 | -------------------------------------------------------------------------------- /test/test.ml: -------------------------------------------------------------------------------- 1 | open Alcotest 2 | open Bitcoin 3 | 4 | module TestUtil = struct 5 | open Util 6 | 7 | let verify_size () = 8 | check 9 | int 10 | "size" 11 | Hash160.length 12 | (String.length Hash160.(compute_string "" |> to_string)) 13 | ;; 14 | 15 | let runtest = [ test_case "Hash160.{of_string,to_string}" `Quick verify_size ] 16 | end 17 | 18 | let rawTx = 19 | `Hex 20 | "0100000002ba0eb35fa910ccd759ff46b5233663e96017e8dfaedd315407dc5be45d8c260f000000001976a9146ce472b3cfced15a7d50b6b0cd75a3b042554e8e88acfdffffff69c84956a9cc0ec5986091e1ab229e1a7ea6f4813beb367c01c8ccc708e160cc000000001976a9146ce472b3cfced15a7d50b6b0cd75a3b042554e8e88acfdffffff01a17c0100000000001976a914efd0919fc05311850a8382b9c7e80abcd347343288ac00000000" 21 | ;; 22 | 23 | let rawPrevTxs = 24 | [ `Hex 25 | "010000000324c6fae955eae55c27639e5537d00e6ef11559c26f9c36c6770030b38702b19b0d0000006b483045022100c369493b6caa7016efd537eedce8d9e44fe14c345cd5edbb8bdca5545daf4cbe022053ac076f1c04f2f10f107f2890d5d95513547690b9a27d647d1c1ea68f6f3512012102f812962645e606a97728876d93324f030c1fe944d58466960104d810e8dc4945ffffffff24c6fae955eae55c27639e5537d00e6ef11559c26f9c36c6770030b38702b19b0a0000006b48304502210094f901df086a6499f24f678eef305e81eed11d730696cfa23cf1a9e2208ab98302205e628d259e2450d71d67ad54a58b0f58d6b643b70957c8a72e8df1293b2eb9be012102f812962645e606a97728876d93324f030c1fe944d58466960104d810e8dc4945ffffffff24c6fae955eae55c27639e5537d00e6ef11559c26f9c36c6770030b38702b19b0c0000006a47304402205c59502f9075f764dad17d59da9eb5429e969e2608ab579e3185f639dfda2eee0220614d2101e2c17612dc59a247f6f5cbdefcd7ea8f74654caa08b11f42873e586201210268a925507fd7e84295e172b3eea2f056c166ddc874fcda45864d872725094225ffffffff0150c30000000000001976a9146ce472b3cfced15a7d50b6b0cd75a3b042554e8e88ac00000000" 26 | ; `Hex 27 | "0100000001df5401686b5608195037e8978f6775db0c59d6cee8bb82aa25f4d8635481f56f010000006a47304402201d43a31c9d0f23f2bf2d39ae6d03ff217cb8bf7ddc7c5b1725f6f2f98d855b0c0220459426150782b01ca75958428e34f5e345e85ccae4333025eeb9baef85b3f9fc0121024bb68261bac7e49c99ad1e52fb5e91f09973d45f5d24715c9e64582a24856cc3ffffffff0260ea0000000000001976a9146ce472b3cfced15a7d50b6b0cd75a3b042554e8e88ac91351900000000001976a914efd0919fc05311850a8382b9c7e80abcd347343288ac00000000" 28 | ] 29 | ;; 30 | 31 | let hex = testable Hex.pp ( = ) 32 | let cstruct = testable Cstruct.hexdump_pp Cstruct.equal 33 | 34 | module TestScript = struct 35 | let script = testable Script.pp ( = ) 36 | 37 | let scripts = 38 | List.map 39 | Cstruct.of_hex 40 | [ "004730440220689033c6b759eafaeb2cec9840889b11d91bbd5c0bf7ca1cc5c1aeb472d6ef830220031592f971bf2e7e28d61b8211e1cbdac2fb2d845c5e4966051525e585bedbc9014830450221009427f4b53eae2b422985a719d6d4a7ffd855d05b5bac30721576165191f6bd4102204390383f80df68bd6f235b21a04c03190a608e73f417ae9432bb19ce081fc348014c69522102ab6a688dac39dbf7720e8acc35dd60c9859ac9fe028153bb86cbcd49efe5298a2102afec872249e4cb6d7defa91d2bacba96124acb35ace1f1e791e216381abace9721039b35123f8e66a2f226230d4fa59fb6e6c5c0a5195f5d404a72b73566e08fcb5753ae" 41 | ] 42 | ;; 43 | 44 | let round () = 45 | List.iter 46 | (fun cs -> 47 | let s, _ = Script.of_cstruct cs in 48 | Format.eprintf "%a@." Script.pp s; 49 | let cs' = Script.serialize s in 50 | let s', _ = Script.of_cstruct cs' in 51 | check script "type equality" s s'; 52 | check cstruct "string equality" cs cs') 53 | scripts 54 | ;; 55 | 56 | open Script 57 | 58 | let check_opcode i = 59 | let a = Opcode.of_int i in 60 | let b = Opcode.to_int a in 61 | if b <> i then failwith (Printf.sprintf "Problem at index %d" i) 62 | ;; 63 | 64 | let test_opcodes () = 65 | for i = 0 to 185 do 66 | check_opcode i 67 | done; 68 | for i = 253 to 255 do 69 | check_opcode i 70 | done 71 | ;; 72 | 73 | let runtest = 74 | [ test_case "Opcode.{of,to}_int" `Quick test_opcodes; test_case "trip" `Quick round ] 75 | ;; 76 | end 77 | 78 | module TestTransaction = struct 79 | let transaction = testable Transaction.pp ( = ) 80 | 81 | let hash256 = 82 | let open Util.Hash256 in 83 | testable pp equal 84 | ;; 85 | 86 | let txs = 87 | [ ( Util.Hash256.of_hex_rpc 88 | (`Hex "0ae0a4865e68a12d4a54c8293329fd8a56ff2a2c72167a7aa828d8f1b68f4367") 89 | , `Hex 90 | "0100000001b5b6d3c4cbe2152001da0fe745202b5ae1676bf5616907c2b2661ea8a928f75b00000000fdfd00004730440220689033c6b759eafaeb2cec9840889b11d91bbd5c0bf7ca1cc5c1aeb472d6ef830220031592f971bf2e7e28d61b8211e1cbdac2fb2d845c5e4966051525e585bedbc9014830450221009427f4b53eae2b422985a719d6d4a7ffd855d05b5bac30721576165191f6bd4102204390383f80df68bd6f235b21a04c03190a608e73f417ae9432bb19ce081fc348014c69522102ab6a688dac39dbf7720e8acc35dd60c9859ac9fe028153bb86cbcd49efe5298a2102afec872249e4cb6d7defa91d2bacba96124acb35ace1f1e791e216381abace9721039b35123f8e66a2f226230d4fa59fb6e6c5c0a5195f5d404a72b73566e08fcb5753aeffffffff02400d0300000000001976a914e825af66403780479d8bfa4cf2e956623ed7f34a88acb3545c020000000017a91471c6a5ec5d76727767e3da0ac36e1f13db459f268700000000" 91 | ) 92 | ] 93 | ;; 94 | 95 | let trip () = 96 | List.iter 97 | (fun (h, tx_hex) -> 98 | let t = Transaction.of_hex tx_hex in 99 | let h' = Transaction.hash256 t in 100 | check hash256 "hash" h h'; 101 | let tx_hex' = Transaction.to_hex t in 102 | let t' = Transaction.of_hex tx_hex' in 103 | check transaction "trip_t" t t'; 104 | check hex "trip_t_string" tx_hex tx_hex') 105 | txs 106 | ;; 107 | 108 | let test_transaction () = 109 | let print_tx (`Hex _tx_hex as tx) = 110 | let tx_cstruct = Hex.to_cstruct tx in 111 | let tx, _ = Transaction.of_cstruct tx_cstruct in 112 | let len = Transaction.size tx in 113 | let buf = Cstruct.create len in 114 | let (_ : Cstruct.t) = Transaction.to_cstruct buf tx in 115 | let tx_trip, _ = Transaction.of_cstruct buf in 116 | (* let `Hex tx_hex' = Hex.of_cstruct buf in *) 117 | if not (Cstruct.equal tx_cstruct buf) 118 | then ( 119 | Printf.printf "%s\n\n%!" (Sexplib.Sexp.to_string_hum (Transaction.sexp_of_t tx)); 120 | Printf.printf 121 | "%s\n%!" 122 | (Sexplib.Sexp.to_string_hum (Transaction.sexp_of_t tx_trip)); 123 | failwith "trip did not succeed") 124 | in 125 | List.iter print_tx (rawTx :: rawPrevTxs) 126 | ;; 127 | 128 | let runtest = 129 | [ test_case "trip" `Quick trip 130 | ; test_case "Transaction.of_cstruct" `Quick test_transaction 131 | ] 132 | ;; 133 | end 134 | 135 | let kp_tst = testable (Fmt.list Fmt.int32) (List.equal Int32.equal) 136 | 137 | module Wallet = struct 138 | let test_keyPath_of_string () = 139 | let open Wallet.KeyPath in 140 | let kp = of_string_exn "44'/1'/0'/0/0" in 141 | check kp_tst "wallet" kp [ to_hardened 44l; to_hardened 1l; to_hardened 0l; 0l; 0l ] 142 | ;; 143 | 144 | let runtest = [ test_case "KeyPath.of_string" `Quick test_keyPath_of_string ] 145 | end 146 | 147 | let () = 148 | run 149 | "bitcoin" 150 | [ "Util", TestUtil.runtest 151 | ; "Script", TestScript.runtest 152 | ; "Transaction", TestTransaction.runtest 153 | ; "Wallet", Wallet.runtest 154 | ] 155 | ;; 156 | --------------------------------------------------------------------------------