├── .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 |
--------------------------------------------------------------------------------