├── .gitignore ├── .gitlab-ci.yml ├── .stylish-haskell.yaml ├── Dockerfile ├── LICENSE ├── Makefile ├── README.md ├── Setup.hs ├── app ├── Config.hs ├── DB.hs ├── Main.hs ├── Options.hs └── Payout.hs ├── default.nix ├── nix ├── default.nix └── update.sh ├── package.yaml ├── src └── Backerei │ ├── Delegation.hs │ ├── RPC.hs │ └── Types.hs ├── stack.yaml ├── stack.yaml.lock └── test └── Spec.hs /.gitignore: -------------------------------------------------------------------------------- 1 | *.swp 2 | .ghci 3 | .stack-work/ 4 | backerei.cabal 5 | result 6 | -------------------------------------------------------------------------------- /.gitlab-ci.yml: -------------------------------------------------------------------------------- 1 | image: docker:stable 2 | services: 3 | - docker:dind 4 | 5 | variables: 6 | DOCKER_HOST: tcp://docker:2375 7 | DOCKER_DRIVER: overlay2 8 | IMAGE_TAG: $CI_REGISTRY_IMAGE:$CI_COMMIT_REF_SLUG 9 | IMAGE_LATEST_TAG: $CI_REGISTRY_IMAGE:latest 10 | 11 | before_script: 12 | - docker login -u $CI_REGISTRY_USER -p $CI_REGISTRY_PASSWORD $CI_REGISTRY 13 | 14 | build: 15 | stage: build 16 | script: 17 | - docker build -t $IMAGE_TAG . 18 | - docker push $IMAGE_TAG 19 | - docker build -t $IMAGE_LATEST_TAG . 20 | - docker push $IMAGE_LATEST_TAG 21 | only: 22 | refs: 23 | - master 24 | -------------------------------------------------------------------------------- /.stylish-haskell.yaml: -------------------------------------------------------------------------------- 1 | steps: 2 | # - unicode_syntax: 3 | # add_language_pragma: false 4 | 5 | - simple_align: 6 | cases: true 7 | top_level_patterns: true 8 | records: true 9 | 10 | - imports: 11 | align: global 12 | list_align: after_alias 13 | long_list_align: inline 14 | empty_list_align: inherit 15 | list_padding: 4 16 | separate_lists: true 17 | 18 | - language_pragmas: 19 | style: vertical 20 | align: true 21 | remove_redundant: true 22 | 23 | - trailing_whitespace: {} 24 | 25 | columns: 80 26 | 27 | newline: native 28 | 29 | language_extensions: 30 | - TemplateHaskell 31 | - QuasiQuotes 32 | - LambdaCase 33 | - ScopedTypeVariables 34 | - FunctionalDependencies 35 | - MultiParamTypeClasses 36 | - FlexibleContexts 37 | - UnicodeSyntax 38 | - InstanceSigs 39 | - ExistentialQuantification 40 | - MultiWayIf 41 | - DefaultSignatures 42 | - DerivingStrategies 43 | - FlexibleInstances 44 | - DataKinds 45 | - RankNTypes 46 | -------------------------------------------------------------------------------- /Dockerfile: -------------------------------------------------------------------------------- 1 | FROM alpine@sha256:c19173c5ada610a5989151111163d28a67368362762534d8a8121ce95cf2bd5a AS base 2 | 3 | RUN apk update && \ 4 | apk add bash perl alpine-sdk wget curl libc-dev xz 5 | 6 | 7 | ################################################################################ 8 | # Intermediate layer that assembles 'stack' tooling 9 | FROM base AS stack 10 | 11 | ENV STACK_VERSION=1.9.3 12 | ENV STACK_SHA256="c9bf6d371b51de74f4bfd5b50965966ac57f75b0544aebb59ade22195d0b7543 stack-${STACK_VERSION}-linux-x86_64-static.tar.gz" 13 | 14 | RUN echo "Downloading stack" &&\ 15 | cd /tmp &&\ 16 | wget -P /tmp/ "https://github.com/commercialhaskell/stack/releases/download/v${STACK_VERSION}/stack-${STACK_VERSION}-linux-x86_64-static.tar.gz" &&\ 17 | if ! echo -n "${STACK_SHA256}" | sha256sum -c -; then \ 18 | echo "stack-${STACK_VERSION} checksum failed" >&2 &&\ 19 | exit 1 ;\ 20 | fi ;\ 21 | tar -xvzf /tmp/stack-${STACK_VERSION}-linux-x86_64-static.tar.gz &&\ 22 | cp -L /tmp/stack-${STACK_VERSION}-linux-x86_64-static/stack /usr/bin/stack &&\ 23 | rm /tmp/stack-${STACK_VERSION}-linux-x86_64-static.tar.gz &&\ 24 | rm -rf /tmp/stack-${STACK_VERSION}-linux-x86_64-static 25 | ################################################################################ 26 | 27 | 28 | FROM stack as stack_intermediate 29 | 30 | ENV GHC_VERSION=8.4.4 31 | ENV GHC_INSTALL_PATH=/opt/ghc 32 | 33 | RUN wget https://github.com/redneb/ghc-alt-libc/releases/download/ghc-${GHC_VERSION}-musl/ghc-${GHC_VERSION}-x86_64-unknown-linux-musl.tar.xz && \ 34 | tar xf ghc-${GHC_VERSION}-x86_64-unknown-linux-musl.tar.xz 35 | 36 | RUN apk update && \ 37 | apk add bash perl alpine-sdk wget make curl git libc-dev xz coreutils zlib-dev shadow gmp-dev 38 | 39 | 40 | WORKDIR ghc-${GHC_VERSION} 41 | 42 | RUN ./configure --prefix=${GHC_INSTALL_PATH} && \ 43 | make install 44 | 45 | ENV PATH=${GHC_INSTALL_PATH}/bin:$PATH 46 | 47 | COPY --from=stack /usr/bin/stack /usr/bin/stack 48 | RUN stack config set system-ghc --global true 49 | RUN mkdir /build 50 | COPY . /build 51 | RUN cd /build && make build && make install 52 | 53 | FROM tezos/tezos:mainnet 54 | COPY --from=stack_intermediate /root/.local/bin/backerei /home/tezos 55 | WORKDIR /home/tezos 56 | ENTRYPOINT ["./backerei"] 57 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | GNU GENERAL PUBLIC LICENSE 2 | Version 3, 29 June 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 General Public License is a free, copyleft license for 11 | software and other kinds of works. 12 | 13 | The licenses for most software and other practical works are designed 14 | to take away your freedom to share and change the works. By contrast, 15 | the GNU General Public License is intended to guarantee your freedom to 16 | share and change all versions of a program--to make sure it remains free 17 | software for all its users. We, the Free Software Foundation, use the 18 | GNU General Public License for most of our software; it applies also to 19 | any other work released this way by its authors. You can apply it to 20 | your programs, too. 21 | 22 | When we speak of free software, we are referring to freedom, not 23 | price. Our General Public Licenses are designed to make sure that you 24 | have the freedom to distribute copies of free software (and charge for 25 | them if you wish), that you receive source code or can get it if you 26 | want it, that you can change the software or use pieces of it in new 27 | free programs, and that you know you can do these things. 28 | 29 | To protect your rights, we need to prevent others from denying you 30 | these rights or asking you to surrender the rights. Therefore, you have 31 | certain responsibilities if you distribute copies of the software, or if 32 | you modify it: responsibilities to respect the freedom of others. 33 | 34 | For example, if you distribute copies of such a program, whether 35 | gratis or for a fee, you must pass on to the recipients the same 36 | freedoms that you received. You must make sure that they, too, receive 37 | or can get the source code. And you must show them these terms so they 38 | know their rights. 39 | 40 | Developers that use the GNU GPL protect your rights with two steps: 41 | (1) assert copyright on the software, and (2) offer you this License 42 | giving you legal permission to copy, distribute and/or modify it. 43 | 44 | For the developers' and authors' protection, the GPL clearly explains 45 | that there is no warranty for this free software. For both users' and 46 | authors' sake, the GPL requires that modified versions be marked as 47 | changed, so that their problems will not be attributed erroneously to 48 | authors of previous versions. 49 | 50 | Some devices are designed to deny users access to install or run 51 | modified versions of the software inside them, although the manufacturer 52 | can do so. This is fundamentally incompatible with the aim of 53 | protecting users' freedom to change the software. The systematic 54 | pattern of such abuse occurs in the area of products for individuals to 55 | use, which is precisely where it is most unacceptable. Therefore, we 56 | have designed this version of the GPL to prohibit the practice for those 57 | products. If such problems arise substantially in other domains, we 58 | stand ready to extend this provision to those domains in future versions 59 | of the GPL, as needed to protect the freedom of users. 60 | 61 | Finally, every program is threatened constantly by software patents. 62 | States should not allow patents to restrict development and use of 63 | software on general-purpose computers, but in those that do, we wish to 64 | avoid the special danger that patents applied to a free program could 65 | make it effectively proprietary. To prevent this, the GPL assures that 66 | patents cannot be used to render the program non-free. 67 | 68 | The precise terms and conditions for copying, distribution and 69 | modification follow. 70 | 71 | TERMS AND CONDITIONS 72 | 73 | 0. Definitions. 74 | 75 | "This License" refers to version 3 of the GNU General Public License. 76 | 77 | "Copyright" also means copyright-like laws that apply to other kinds of 78 | works, such as semiconductor masks. 79 | 80 | "The Program" refers to any copyrightable work licensed under this 81 | License. Each licensee is addressed as "you". "Licensees" and 82 | "recipients" may be individuals or organizations. 83 | 84 | To "modify" a work means to copy from or adapt all or part of the work 85 | in a fashion requiring copyright permission, other than the making of an 86 | exact copy. The resulting work is called a "modified version" of the 87 | earlier work or a work "based on" the earlier work. 88 | 89 | A "covered work" means either the unmodified Program or a work based 90 | on the Program. 91 | 92 | To "propagate" a work means to do anything with it that, without 93 | permission, would make you directly or secondarily liable for 94 | infringement under applicable copyright law, except executing it on a 95 | computer or modifying a private copy. Propagation includes copying, 96 | distribution (with or without modification), making available to the 97 | public, and in some countries other activities as well. 98 | 99 | To "convey" a work means any kind of propagation that enables other 100 | parties to make or receive copies. Mere interaction with a user through 101 | a computer network, with no transfer of a copy, is not conveying. 102 | 103 | An interactive user interface displays "Appropriate Legal Notices" 104 | to the extent that it includes a convenient and prominently visible 105 | feature that (1) displays an appropriate copyright notice, and (2) 106 | tells the user that there is no warranty for the work (except to the 107 | extent that warranties are provided), that licensees may convey the 108 | work under this License, and how to view a copy of this License. If 109 | the interface presents a list of user commands or options, such as a 110 | menu, a prominent item in the list meets this criterion. 111 | 112 | 1. Source Code. 113 | 114 | The "source code" for a work means the preferred form of the work 115 | for making modifications to it. "Object code" means any non-source 116 | form of a work. 117 | 118 | A "Standard Interface" means an interface that either is an official 119 | standard defined by a recognized standards body, or, in the case of 120 | interfaces specified for a particular programming language, one that 121 | is widely used among developers working in that language. 122 | 123 | The "System Libraries" of an executable work include anything, other 124 | than the work as a whole, that (a) is included in the normal form of 125 | packaging a Major Component, but which is not part of that Major 126 | Component, and (b) serves only to enable use of the work with that 127 | Major Component, or to implement a Standard Interface for which an 128 | implementation is available to the public in source code form. A 129 | "Major Component", in this context, means a major essential component 130 | (kernel, window system, and so on) of the specific operating system 131 | (if any) on which the executable work runs, or a compiler used to 132 | produce the work, or an object code interpreter used to run it. 133 | 134 | The "Corresponding Source" for a work in object code form means all 135 | the source code needed to generate, install, and (for an executable 136 | work) run the object code and to modify the work, including scripts to 137 | control those activities. However, it does not include the work's 138 | System Libraries, or general-purpose tools or generally available free 139 | programs which are used unmodified in performing those activities but 140 | which are not part of the work. For example, Corresponding Source 141 | includes interface definition files associated with source files for 142 | the work, and the source code for shared libraries and dynamically 143 | linked subprograms that the work is specifically designed to require, 144 | such as by intimate data communication or control flow between those 145 | subprograms and other parts of the work. 146 | 147 | The Corresponding Source need not include anything that users 148 | can regenerate automatically from other parts of the Corresponding 149 | Source. 150 | 151 | The Corresponding Source for a work in source code form is that 152 | same work. 153 | 154 | 2. Basic Permissions. 155 | 156 | All rights granted under this License are granted for the term of 157 | copyright on the Program, and are irrevocable provided the stated 158 | conditions are met. This License explicitly affirms your unlimited 159 | permission to run the unmodified Program. The output from running a 160 | covered work is covered by this License only if the output, given its 161 | content, constitutes a covered work. This License acknowledges your 162 | rights of fair use or other equivalent, as provided by copyright law. 163 | 164 | You may make, run and propagate covered works that you do not 165 | convey, without conditions so long as your license otherwise remains 166 | in force. You may convey covered works to others for the sole purpose 167 | of having them make modifications exclusively for you, or provide you 168 | with facilities for running those works, provided that you comply with 169 | the terms of this License in conveying all material for which you do 170 | not control copyright. Those thus making or running the covered works 171 | for you must do so exclusively on your behalf, under your direction 172 | and control, on terms that prohibit them from making any copies of 173 | your copyrighted material outside their relationship with you. 174 | 175 | Conveying under any other circumstances is permitted solely under 176 | the conditions stated below. Sublicensing is not allowed; section 10 177 | makes it unnecessary. 178 | 179 | 3. Protecting Users' Legal Rights From Anti-Circumvention Law. 180 | 181 | No covered work shall be deemed part of an effective technological 182 | measure under any applicable law fulfilling obligations under article 183 | 11 of the WIPO copyright treaty adopted on 20 December 1996, or 184 | similar laws prohibiting or restricting circumvention of such 185 | measures. 186 | 187 | When you convey a covered work, you waive any legal power to forbid 188 | circumvention of technological measures to the extent such circumvention 189 | is effected by exercising rights under this License with respect to 190 | the covered work, and you disclaim any intention to limit operation or 191 | modification of the work as a means of enforcing, against the work's 192 | users, your or third parties' legal rights to forbid circumvention of 193 | technological measures. 194 | 195 | 4. Conveying Verbatim Copies. 196 | 197 | You may convey verbatim copies of the Program's source code as you 198 | receive it, in any medium, provided that you conspicuously and 199 | appropriately publish on each copy an appropriate copyright notice; 200 | keep intact all notices stating that this License and any 201 | non-permissive terms added in accord with section 7 apply to the code; 202 | keep intact all notices of the absence of any warranty; and give all 203 | recipients a copy of this License along with the Program. 204 | 205 | You may charge any price or no price for each copy that you convey, 206 | and you may offer support or warranty protection for a fee. 207 | 208 | 5. Conveying Modified Source Versions. 209 | 210 | You may convey a work based on the Program, or the modifications to 211 | produce it from the Program, in the form of source code under the 212 | terms of section 4, provided that you also meet all of these conditions: 213 | 214 | a) The work must carry prominent notices stating that you modified 215 | it, and giving a relevant date. 216 | 217 | b) The work must carry prominent notices stating that it is 218 | released under this License and any conditions added under section 219 | 7. This requirement modifies the requirement in section 4 to 220 | "keep intact all notices". 221 | 222 | c) You must license the entire work, as a whole, under this 223 | License to anyone who comes into possession of a copy. This 224 | License will therefore apply, along with any applicable section 7 225 | additional terms, to the whole of the work, and all its parts, 226 | regardless of how they are packaged. This License gives no 227 | permission to license the work in any other way, but it does not 228 | invalidate such permission if you have separately received it. 229 | 230 | d) If the work has interactive user interfaces, each must display 231 | Appropriate Legal Notices; however, if the Program has interactive 232 | interfaces that do not display Appropriate Legal Notices, your 233 | work need not make them do so. 234 | 235 | A compilation of a covered work with other separate and independent 236 | works, which are not by their nature extensions of the covered work, 237 | and which are not combined with it such as to form a larger program, 238 | in or on a volume of a storage or distribution medium, is called an 239 | "aggregate" if the compilation and its resulting copyright are not 240 | used to limit the access or legal rights of the compilation's users 241 | beyond what the individual works permit. Inclusion of a covered work 242 | in an aggregate does not cause this License to apply to the other 243 | parts of the aggregate. 244 | 245 | 6. Conveying Non-Source Forms. 246 | 247 | You may convey a covered work in object code form under the terms 248 | of sections 4 and 5, provided that you also convey the 249 | machine-readable Corresponding Source under the terms of this License, 250 | in one of these ways: 251 | 252 | a) Convey the object code in, or embodied in, a physical product 253 | (including a physical distribution medium), accompanied by the 254 | Corresponding Source fixed on a durable physical medium 255 | customarily used for software interchange. 256 | 257 | b) Convey the object code in, or embodied in, a physical product 258 | (including a physical distribution medium), accompanied by a 259 | written offer, valid for at least three years and valid for as 260 | long as you offer spare parts or customer support for that product 261 | model, to give anyone who possesses the object code either (1) a 262 | copy of the Corresponding Source for all the software in the 263 | product that is covered by this License, on a durable physical 264 | medium customarily used for software interchange, for a price no 265 | more than your reasonable cost of physically performing this 266 | conveying of source, or (2) access to copy the 267 | Corresponding Source from a network server at no charge. 268 | 269 | c) Convey individual copies of the object code with a copy of the 270 | written offer to provide the Corresponding Source. This 271 | alternative is allowed only occasionally and noncommercially, and 272 | only if you received the object code with such an offer, in accord 273 | with subsection 6b. 274 | 275 | d) Convey the object code by offering access from a designated 276 | place (gratis or for a charge), and offer equivalent access to the 277 | Corresponding Source in the same way through the same place at no 278 | further charge. You need not require recipients to copy the 279 | Corresponding Source along with the object code. If the place to 280 | copy the object code is a network server, the Corresponding Source 281 | may be on a different server (operated by you or a third party) 282 | that supports equivalent copying facilities, provided you maintain 283 | clear directions next to the object code saying where to find the 284 | Corresponding Source. Regardless of what server hosts the 285 | Corresponding Source, you remain obligated to ensure that it is 286 | available for as long as needed to satisfy these requirements. 287 | 288 | e) Convey the object code using peer-to-peer transmission, provided 289 | you inform other peers where the object code and Corresponding 290 | Source of the work are being offered to the general public at no 291 | charge under subsection 6d. 292 | 293 | A separable portion of the object code, whose source code is excluded 294 | from the Corresponding Source as a System Library, need not be 295 | included in conveying the object code work. 296 | 297 | A "User Product" is either (1) a "consumer product", which means any 298 | tangible personal property which is normally used for personal, family, 299 | or household purposes, or (2) anything designed or sold for incorporation 300 | into a dwelling. In determining whether a product is a consumer product, 301 | doubtful cases shall be resolved in favor of coverage. For a particular 302 | product received by a particular user, "normally used" refers to a 303 | typical or common use of that class of product, regardless of the status 304 | of the particular user or of the way in which the particular user 305 | actually uses, or expects or is expected to use, the product. A product 306 | is a consumer product regardless of whether the product has substantial 307 | commercial, industrial or non-consumer uses, unless such uses represent 308 | the only significant mode of use of the product. 309 | 310 | "Installation Information" for a User Product means any methods, 311 | procedures, authorization keys, or other information required to install 312 | and execute modified versions of a covered work in that User Product from 313 | a modified version of its Corresponding Source. The information must 314 | suffice to ensure that the continued functioning of the modified object 315 | code is in no case prevented or interfered with solely because 316 | modification has been made. 317 | 318 | If you convey an object code work under this section in, or with, or 319 | specifically for use in, a User Product, and the conveying occurs as 320 | part of a transaction in which the right of possession and use of the 321 | User Product is transferred to the recipient in perpetuity or for a 322 | fixed term (regardless of how the transaction is characterized), the 323 | Corresponding Source conveyed under this section must be accompanied 324 | by the Installation Information. But this requirement does not apply 325 | if neither you nor any third party retains the ability to install 326 | modified object code on the User Product (for example, the work has 327 | been installed in ROM). 328 | 329 | The requirement to provide Installation Information does not include a 330 | requirement to continue to provide support service, warranty, or updates 331 | for a work that has been modified or installed by the recipient, or for 332 | the User Product in which it has been modified or installed. Access to a 333 | network may be denied when the modification itself materially and 334 | adversely affects the operation of the network or violates the rules and 335 | protocols for communication across the network. 336 | 337 | Corresponding Source conveyed, and Installation Information provided, 338 | in accord with this section must be in a format that is publicly 339 | documented (and with an implementation available to the public in 340 | source code form), and must require no special password or key for 341 | unpacking, reading or copying. 342 | 343 | 7. Additional Terms. 344 | 345 | "Additional permissions" are terms that supplement the terms of this 346 | License by making exceptions from one or more of its conditions. 347 | Additional permissions that are applicable to the entire Program shall 348 | be treated as though they were included in this License, to the extent 349 | that they are valid under applicable law. If additional permissions 350 | apply only to part of the Program, that part may be used separately 351 | under those permissions, but the entire Program remains governed by 352 | this License without regard to the additional permissions. 353 | 354 | When you convey a copy of a covered work, you may at your option 355 | remove any additional permissions from that copy, or from any part of 356 | it. (Additional permissions may be written to require their own 357 | removal in certain cases when you modify the work.) You may place 358 | additional permissions on material, added by you to a covered work, 359 | for which you have or can give appropriate copyright permission. 360 | 361 | Notwithstanding any other provision of this License, for material you 362 | add to a covered work, you may (if authorized by the copyright holders of 363 | that material) supplement the terms of this License with terms: 364 | 365 | a) Disclaiming warranty or limiting liability differently from the 366 | terms of sections 15 and 16 of this License; or 367 | 368 | b) Requiring preservation of specified reasonable legal notices or 369 | author attributions in that material or in the Appropriate Legal 370 | Notices displayed by works containing it; or 371 | 372 | c) Prohibiting misrepresentation of the origin of that material, or 373 | requiring that modified versions of such material be marked in 374 | reasonable ways as different from the original version; or 375 | 376 | d) Limiting the use for publicity purposes of names of licensors or 377 | authors of the material; or 378 | 379 | e) Declining to grant rights under trademark law for use of some 380 | trade names, trademarks, or service marks; or 381 | 382 | f) Requiring indemnification of licensors and authors of that 383 | material by anyone who conveys the material (or modified versions of 384 | it) with contractual assumptions of liability to the recipient, for 385 | any liability that these contractual assumptions directly impose on 386 | those licensors and authors. 387 | 388 | All other non-permissive additional terms are considered "further 389 | restrictions" within the meaning of section 10. If the Program as you 390 | received it, or any part of it, contains a notice stating that it is 391 | governed by this License along with a term that is a further 392 | restriction, you may remove that term. If a license document contains 393 | a further restriction but permits relicensing or conveying under this 394 | License, you may add to a covered work material governed by the terms 395 | of that license document, provided that the further restriction does 396 | not survive such relicensing or conveying. 397 | 398 | If you add terms to a covered work in accord with this section, you 399 | must place, in the relevant source files, a statement of the 400 | additional terms that apply to those files, or a notice indicating 401 | where to find the applicable terms. 402 | 403 | Additional terms, permissive or non-permissive, may be stated in the 404 | form of a separately written license, or stated as exceptions; 405 | the above requirements apply either way. 406 | 407 | 8. Termination. 408 | 409 | You may not propagate or modify a covered work except as expressly 410 | provided under this License. Any attempt otherwise to propagate or 411 | modify it is void, and will automatically terminate your rights under 412 | this License (including any patent licenses granted under the third 413 | paragraph of section 11). 414 | 415 | However, if you cease all violation of this License, then your 416 | license from a particular copyright holder is reinstated (a) 417 | provisionally, unless and until the copyright holder explicitly and 418 | finally terminates your license, and (b) permanently, if the copyright 419 | holder fails to notify you of the violation by some reasonable means 420 | prior to 60 days after the cessation. 421 | 422 | Moreover, your license from a particular copyright holder is 423 | reinstated permanently if the copyright holder notifies you of the 424 | violation by some reasonable means, this is the first time you have 425 | received notice of violation of this License (for any work) from that 426 | copyright holder, and you cure the violation prior to 30 days after 427 | your receipt of the notice. 428 | 429 | Termination of your rights under this section does not terminate the 430 | licenses of parties who have received copies or rights from you under 431 | this License. If your rights have been terminated and not permanently 432 | reinstated, you do not qualify to receive new licenses for the same 433 | material under section 10. 434 | 435 | 9. Acceptance Not Required for Having Copies. 436 | 437 | You are not required to accept this License in order to receive or 438 | run a copy of the Program. Ancillary propagation of a covered work 439 | occurring solely as a consequence of using peer-to-peer transmission 440 | to receive a copy likewise does not require acceptance. However, 441 | nothing other than this License grants you permission to propagate or 442 | modify any covered work. These actions infringe copyright if you do 443 | not accept this License. Therefore, by modifying or propagating a 444 | covered work, you indicate your acceptance of this License to do so. 445 | 446 | 10. Automatic Licensing of Downstream Recipients. 447 | 448 | Each time you convey a covered work, the recipient automatically 449 | receives a license from the original licensors, to run, modify and 450 | propagate that work, subject to this License. You are not responsible 451 | for enforcing compliance by third parties with this License. 452 | 453 | An "entity transaction" is a transaction transferring control of an 454 | organization, or substantially all assets of one, or subdividing an 455 | organization, or merging organizations. If propagation of a covered 456 | work results from an entity transaction, each party to that 457 | transaction who receives a copy of the work also receives whatever 458 | licenses to the work the party's predecessor in interest had or could 459 | give under the previous paragraph, plus a right to possession of the 460 | Corresponding Source of the work from the predecessor in interest, if 461 | the predecessor has it or can get it with reasonable efforts. 462 | 463 | You may not impose any further restrictions on the exercise of the 464 | rights granted or affirmed under this License. For example, you may 465 | not impose a license fee, royalty, or other charge for exercise of 466 | rights granted under this License, and you may not initiate litigation 467 | (including a cross-claim or counterclaim in a lawsuit) alleging that 468 | any patent claim is infringed by making, using, selling, offering for 469 | sale, or importing the Program or any portion of it. 470 | 471 | 11. Patents. 472 | 473 | A "contributor" is a copyright holder who authorizes use under this 474 | License of the Program or a work on which the Program is based. The 475 | work thus licensed is called the contributor's "contributor version". 476 | 477 | A contributor's "essential patent claims" are all patent claims 478 | owned or controlled by the contributor, whether already acquired or 479 | hereafter acquired, that would be infringed by some manner, permitted 480 | by this License, of making, using, or selling its contributor version, 481 | but do not include claims that would be infringed only as a 482 | consequence of further modification of the contributor version. For 483 | purposes of this definition, "control" includes the right to grant 484 | patent sublicenses in a manner consistent with the requirements of 485 | this License. 486 | 487 | Each contributor grants you a non-exclusive, worldwide, royalty-free 488 | patent license under the contributor's essential patent claims, to 489 | make, use, sell, offer for sale, import and otherwise run, modify and 490 | propagate the contents of its contributor version. 491 | 492 | In the following three paragraphs, a "patent license" is any express 493 | agreement or commitment, however denominated, not to enforce a patent 494 | (such as an express permission to practice a patent or covenant not to 495 | sue for patent infringement). To "grant" such a patent license to a 496 | party means to make such an agreement or commitment not to enforce a 497 | patent against the party. 498 | 499 | If you convey a covered work, knowingly relying on a patent license, 500 | and the Corresponding Source of the work is not available for anyone 501 | to copy, free of charge and under the terms of this License, through a 502 | publicly available network server or other readily accessible means, 503 | then you must either (1) cause the Corresponding Source to be so 504 | available, or (2) arrange to deprive yourself of the benefit of the 505 | patent license for this particular work, or (3) arrange, in a manner 506 | consistent with the requirements of this License, to extend the patent 507 | license to downstream recipients. "Knowingly relying" means you have 508 | actual knowledge that, but for the patent license, your conveying the 509 | covered work in a country, or your recipient's use of the covered work 510 | in a country, would infringe one or more identifiable patents in that 511 | country that you have reason to believe are valid. 512 | 513 | If, pursuant to or in connection with a single transaction or 514 | arrangement, you convey, or propagate by procuring conveyance of, a 515 | covered work, and grant a patent license to some of the parties 516 | receiving the covered work authorizing them to use, propagate, modify 517 | or convey a specific copy of the covered work, then the patent license 518 | you grant is automatically extended to all recipients of the covered 519 | work and works based on it. 520 | 521 | A patent license is "discriminatory" if it does not include within 522 | the scope of its coverage, prohibits the exercise of, or is 523 | conditioned on the non-exercise of one or more of the rights that are 524 | specifically granted under this License. You may not convey a covered 525 | work if you are a party to an arrangement with a third party that is 526 | in the business of distributing software, under which you make payment 527 | to the third party based on the extent of your activity of conveying 528 | the work, and under which the third party grants, to any of the 529 | parties who would receive the covered work from you, a discriminatory 530 | patent license (a) in connection with copies of the covered work 531 | conveyed by you (or copies made from those copies), or (b) primarily 532 | for and in connection with specific products or compilations that 533 | contain the covered work, unless you entered into that arrangement, 534 | or that patent license was granted, prior to 28 March 2007. 535 | 536 | Nothing in this License shall be construed as excluding or limiting 537 | any implied license or other defenses to infringement that may 538 | otherwise be available to you under applicable patent law. 539 | 540 | 12. No Surrender of Others' Freedom. 541 | 542 | If conditions are imposed on you (whether by court order, agreement or 543 | otherwise) that contradict the conditions of this License, they do not 544 | excuse you from the conditions of this License. If you cannot convey a 545 | covered work so as to satisfy simultaneously your obligations under this 546 | License and any other pertinent obligations, then as a consequence you may 547 | not convey it at all. For example, if you agree to terms that obligate you 548 | to collect a royalty for further conveying from those to whom you convey 549 | the Program, the only way you could satisfy both those terms and this 550 | License would be to refrain entirely from conveying the Program. 551 | 552 | 13. Use with the GNU Affero General Public License. 553 | 554 | Notwithstanding any other provision of this License, you have 555 | permission to link or combine any covered work with a work licensed 556 | under version 3 of the GNU Affero General Public License into a single 557 | combined work, and to convey the resulting work. The terms of this 558 | License will continue to apply to the part which is the covered work, 559 | but the special requirements of the GNU Affero General Public License, 560 | section 13, concerning interaction through a network will apply to the 561 | combination as such. 562 | 563 | 14. Revised Versions of this License. 564 | 565 | The Free Software Foundation may publish revised and/or new versions of 566 | the GNU General Public License from time to time. Such new versions will 567 | be similar in spirit to the present version, but may differ in detail to 568 | address new problems or concerns. 569 | 570 | Each version is given a distinguishing version number. If the 571 | Program specifies that a certain numbered version of the GNU General 572 | Public License "or any later version" applies to it, you have the 573 | option of following the terms and conditions either of that numbered 574 | version or of any later version published by the Free Software 575 | Foundation. If the Program does not specify a version number of the 576 | GNU General Public License, you may choose any version ever published 577 | by the Free Software Foundation. 578 | 579 | If the Program specifies that a proxy can decide which future 580 | versions of the GNU General Public License can be used, that proxy's 581 | public statement of acceptance of a version permanently authorizes you 582 | to choose that version for the Program. 583 | 584 | Later license versions may give you additional or different 585 | permissions. However, no additional obligations are imposed on any 586 | author or copyright holder as a result of your choosing to follow a 587 | later version. 588 | 589 | 15. Disclaimer of Warranty. 590 | 591 | THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY 592 | APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT 593 | HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY 594 | OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, 595 | THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR 596 | PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM 597 | IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF 598 | ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 599 | 600 | 16. Limitation of Liability. 601 | 602 | IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING 603 | WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS 604 | THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY 605 | GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE 606 | USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF 607 | DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD 608 | PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), 609 | EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF 610 | SUCH DAMAGES. 611 | 612 | 17. Interpretation of Sections 15 and 16. 613 | 614 | If the disclaimer of warranty and limitation of liability provided 615 | above cannot be given local legal effect according to their terms, 616 | reviewing courts shall apply local law that most closely approximates 617 | an absolute waiver of all civil liability in connection with the 618 | Program, unless a warranty or assumption of liability accompanies a 619 | copy of the Program in return for a fee. 620 | 621 | END OF TERMS AND CONDITIONS 622 | 623 | How to Apply These Terms to Your New Programs 624 | 625 | If you develop a new program, and you want it to be of the greatest 626 | possible use to the public, the best way to achieve this is to make it 627 | free software which everyone can redistribute and change under these terms. 628 | 629 | To do so, attach the following notices to the program. It is safest 630 | to attach them to the start of each source file to most effectively 631 | state the exclusion of warranty; and each file should have at least 632 | the "copyright" line and a pointer to where the full notice is found. 633 | 634 | 635 | Copyright (C) 636 | 637 | This program is free software: you can redistribute it and/or modify 638 | it under the terms of the GNU General Public License as published by 639 | the Free Software Foundation, either version 3 of the License, or 640 | (at your option) any later version. 641 | 642 | This program is distributed in the hope that it will be useful, 643 | but WITHOUT ANY WARRANTY; without even the implied warranty of 644 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 645 | GNU General Public License for more details. 646 | 647 | You should have received a copy of the GNU General Public License 648 | along with this program. If not, see . 649 | 650 | Also add information on how to contact you by electronic and paper mail. 651 | 652 | If the program does terminal interaction, make it output a short 653 | notice like this when it starts in an interactive mode: 654 | 655 | Copyright (C) 656 | This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'. 657 | This is free software, and you are welcome to redistribute it 658 | under certain conditions; type `show c' for details. 659 | 660 | The hypothetical commands `show w' and `show c' should show the appropriate 661 | parts of the General Public License. Of course, your program's commands 662 | might be different; for a GUI interface, you would use an "about box". 663 | 664 | You should also get your employer (if you work as a programmer) or school, 665 | if any, to sign a "copyright disclaimer" for the program, if necessary. 666 | For more information on this, and how to apply and follow the GNU GPL, see 667 | . 668 | 669 | The GNU General Public License does not permit incorporating your program 670 | into proprietary programs. If your program is a subroutine library, you 671 | may consider it more useful to permit linking proprietary applications with 672 | the library. If this is what you want to do, use the GNU Lesser General 673 | Public License instead of this License. But first, please read 674 | . 675 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | all: build install 2 | 3 | build: 4 | stack build 5 | 6 | install: build 7 | stack install 8 | 9 | lint: 10 | stack exec -- hlint app src test 11 | 12 | test: 13 | stack test 14 | 15 | repl: 16 | stack ghci 17 | 18 | clean: 19 | stack clean --full 20 | 21 | .PHONY: all build install test lint repl clean 22 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ## Bäckerei 2 | 3 | **Backerei is now deprecated as of August 2021. Please use the [Tezos Rewards Distributor](https://github.com/tezos-reward-distributor-organization/tezos-reward-distributor).** 4 | 5 | Bäckerei is tooling that we wrote for the Cryptium Tezos Bäckerei. At a high 6 | level it manages the payments from us, the baker, to our delegators. Bäckerei 7 | is initialised with a TZ1 address which is used for baking. When run, it connects to 8 | a full-node and scans the entire transaction history to determine who the 9 | delegators are and how much they should get paid. Note that this full-node must 10 | be trusted. 11 | 12 | You can check out all the configuration options in `$HOME/.backerei.yaml`. 13 | You can set your fee, the RPC URL of your full node, etc. 14 | 15 | When run, Bäckerei reads and updates a simple JSON database file. You can see 16 | ours [here](https://github.com/cryptiumlabs/library/blob/master/validation-records/tezos/db.json). 17 | All your delegators can use that file to check whether they have been paid 18 | correctly, and on top of it you can build front-ends on it like 19 | [this one](https://tezos.cryptium.ch/dashboard). 20 | 21 | Bäckerei also allows you to specify a different payout address. This means that you 22 | can pay from a KT1 account on a separate server instead of having to pay 23 | directly from your Nano Ledger S. 24 | 25 | Note that Bäckerei calculates *idealized* payouts, not *realized* payouts. On-chain 26 | and off-chain delegators will be paid according to what your baker would have made if 27 | you had successfully baked and endorsed all scheduled blocks and endorsement slots (plus 28 | realized fees). This is roughly equivalent to insuring liveness. 29 | 30 | ### Usage 31 | 32 | #### Initialization 33 | 34 | Initialize Bäckerei with the tz1 address of your baker, for example that of 35 | [Cryptium Labs](https://tzstats.com/tz1eEnQhbwf6trb8Q8mPb2RaPkNk2rN7BKi8), 36 | the address you want to send payouts from, the alias associated with that address, 37 | the path to your database file, and the first cycle in which you baked or endorsed blocks: 38 | 39 | ```bash 40 | backerei init \ 41 | --tz1 tz1eEnQhbwf6trb8Q8mPb2RaPkNk2rN7BKi8 \ 42 | --from tz1eEnQhbwf6trb8Q8mPb2RaPkNk2rN7BKi8 \ 43 | --from-name payout \ 44 | --client-config-file $HOME/.tezos-client/config \ 45 | --starting-cycle 11 46 | ``` 47 | 48 | More options can be passed if desired. Run `backerei init --help` for a full 49 | list. You can also edit the config file directly. 50 | 51 | #### Executing payouts 52 | 53 | Bäckerei is stateful and will calculate outstanding payouts automatically. 54 | Simply run: 55 | 56 | ```bash 57 | backerei payout 58 | ``` 59 | 60 | By default, that command will execute a dry run and only display what payouts 61 | need to be sent. 62 | 63 | In order to actually send transactions, run: 64 | 65 | ```bash 66 | backerei payout --no-dry-run 67 | ``` 68 | 69 | In order to run continuously (so that payouts will be sent as soon as new cycle 70 | starts): 71 | 72 | ```bash 73 | backerei payout --no-dry-run --continuous 74 | ``` 75 | 76 | Bäckerei is fairly well tested, but be careful! Ensure you trust the Tezos node 77 | to which you are connecting. In any case, you would be well-advised to pay from 78 | an isolated account with the minimal requisite balance. 79 | 80 | #### Fee format 81 | 82 | The `--fee` parameter to `backerei init` requires the format "n % d" where `n` is 83 | numerator and `d` is denominator. 84 | 85 | For example: 86 | 87 | ``` 88 | # set up a 9.5% fee 89 | backerei init --fee "19 % 200" <...> 90 | 91 | # set up a 5% fee 92 | backerei init --fee "5 % 100" <...> 93 | ``` 94 | 95 | #### Constants 96 | 97 | Different networks such as alphanet may have different constants. You need to specify these constants during initialisation for Backerei to work correctly. 98 | 99 | The default values for these constants work on the Tezos mainnet. 100 | 101 | * `--cycle-length` defaults to 4096. For alphanet, set to 2048 102 | * `--snapshot-interval` defaults to 512. For alphanet, set to 256 103 | * `--preserved-cycles`: defaults to 5. For alphanet, set to 3 104 | 105 | #### Estimated rewards vs final rewards 106 | 107 | The payout calculator assumes 100% liveness of your own baking and endorsing node, and pays 108 | accordingly. However, the effective rewards for a given baker also depends on the behaviour 109 | of other bakers in the network. For example, if bakers fail to endorse your block, or fail 110 | to include your endorsment in their block, then your rewards are lower. 111 | 112 | Estimated rewards assume perfect behaviour of the entire set of active delegates for 113 | a given block. Final rewards take into account the actual faulty behaviour of other nodes 114 | (not yours) and are accordingly a few percent lower. 115 | 116 | #### Delayed payouts 117 | 118 | By default, the payouts are paid after `PRESERVED_CYCLES`, which corresponds to when 119 | the Tezos network unfreezes them. You may choose to pay them earlier or later: 120 | 121 | * `--payout-delay 2` will pay the rewards two cycles (six days) later 122 | * `--payout-delay -1` will pay the rewards one cycle (three days) before you actually 123 | get access to them 124 | 125 | You cannot set a payout delay of less than negative `PRESERVED_CYCLES` because final 126 | rewards can not be computed before the cycle ends. However, you may set up a payout delay 127 | of up to `2*PRESERVED_CYCLES + 1` if you use the `--pay-estimated-rewards` option. 128 | 129 | This option will likely pay more than the final fee, so adjust your fee accordingly. 130 | 131 | #### Verifying payouts 132 | 133 | You can find historical payout logs for Cryptium Labs 134 | [here](https://github.com/cryptiumlabs/library/tree/master/validation-records/tezos) 135 | and cross-check against a payout database generated locally. 136 | 137 | ### Development 138 | 139 | [Stack](https://haskellstack.org) required for the build process. Once Bäckerei is installed, you can uninstall Stack. 140 | 141 | #### Building 142 | 143 | ```bash 144 | make build 145 | ``` 146 | 147 | #### Testing 148 | 149 | ```bash 150 | make test 151 | ``` 152 | 153 | #### Linting 154 | 155 | Not required unless you want to modify the code and contribute upstream. 156 | 157 | First, install [Hlint](https://hackage.haskell.org/package/hlint): 158 | 159 | ```bash 160 | stack install hlint 161 | ``` 162 | 163 | Then run: 164 | 165 | ```bash 166 | make lint 167 | ``` 168 | 169 | #### Debugging 170 | 171 | To run an interactive REPL with Bäckerei scoped: 172 | 173 | ```bash 174 | make repl 175 | ``` 176 | 177 | #### Cleaning up 178 | 179 | To remove all build files: 180 | 181 | ```bash 182 | make clean 183 | ``` 184 | 185 | #### Installing 186 | 187 | `~/.local/bin` will need to be on your `$PATH`. 188 | 189 | ```bash 190 | make install 191 | ``` 192 | 193 | ### Licensing 194 | 195 | GPLv3. See [LICENSE](./LICENSE) for full terms. 196 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /app/Config.hs: -------------------------------------------------------------------------------- 1 | module Config where 2 | 3 | import qualified Data.Aeson as A 4 | import Data.Char (isLower, toLower) 5 | import qualified Data.Text as T 6 | import qualified Data.Yaml as Y 7 | import Foundation 8 | import GHC.Generics 9 | import qualified Prelude as P 10 | 11 | data Config = Config { 12 | configBakerAddress :: T.Text, 13 | configHost :: T.Text, 14 | configPort :: Int, 15 | configFromAddress :: T.Text, 16 | configFromAccountName :: T.Text, 17 | configFees :: [(Int, Rational)], 18 | configDatabasePath :: T.Text, 19 | configAccountDatabasePath :: Maybe T.Text, 20 | configClientPath :: T.Text, 21 | configClientConfigFile :: T.Text, 22 | configStartingCycle :: Int, 23 | configCycleLength :: Int, 24 | configSnapshotInterval :: Int, 25 | configPreservedCycles :: Int, 26 | configPayoutDelay :: Int, 27 | configBabylonStartingCycle :: Int, 28 | configPayEstimatedRewards :: Bool, 29 | configTelegram :: Maybe TelegramConfig, 30 | configRiemann :: Maybe RiemannConfig, 31 | configPostPayoutScript :: Maybe T.Text 32 | } deriving (Generic) 33 | 34 | data TelegramConfig = TelegramConfig { 35 | telegramToken :: T.Text, 36 | telegramNotificationChannel :: T.Text 37 | } deriving (Generic) 38 | 39 | data RiemannConfig = RiemannConfig { 40 | riemannHost :: T.Text, 41 | riemannPort :: Int 42 | } deriving (Generic) 43 | 44 | loadConfig ∷ P.FilePath → IO (Maybe Config) 45 | loadConfig = Y.decodeFile 46 | 47 | writeConfig ∷ P.FilePath → Config → IO () 48 | writeConfig = Y.encodeFile 49 | 50 | instance Y.FromJSON Config where 51 | parseJSON = customParseJSON 52 | 53 | instance Y.ToJSON Config where 54 | toJSON = customToJSON 55 | toEncoding = customToEncoding 56 | 57 | instance Y.FromJSON RiemannConfig where 58 | parseJSON = customParseJSON 59 | 60 | instance Y.ToJSON RiemannConfig where 61 | toJSON = customToJSON 62 | toEncoding = customToEncoding 63 | 64 | instance Y.FromJSON TelegramConfig where 65 | parseJSON = customParseJSON 66 | 67 | instance Y.ToJSON TelegramConfig where 68 | toJSON = customToJSON 69 | toEncoding = customToEncoding 70 | 71 | jsonOptions ∷ A.Options 72 | jsonOptions = A.defaultOptions { 73 | A.fieldLabelModifier = (\(h:t) -> toLower h : t) . dropWhile isLower, 74 | A.omitNothingFields = True, 75 | A.sumEncoding = A.ObjectWithSingleField 76 | } 77 | 78 | customParseJSON :: (Generic a, A.GFromJSON A.Zero (Rep a)) => Y.Value -> Y.Parser a 79 | customParseJSON = A.genericParseJSON jsonOptions 80 | 81 | customToJSON :: (Generic a, A.GToJSON A.Zero (Rep a)) => a -> A.Value 82 | customToJSON = A.genericToJSON jsonOptions 83 | 84 | customToEncoding :: (Generic a, A.GToEncoding A.Zero (Rep a)) => a -> A.Encoding 85 | customToEncoding = A.genericToEncoding jsonOptions 86 | 87 | defaultFee :: Rational 88 | defaultFee = 1 / 10 89 | -------------------------------------------------------------------------------- /app/DB.hs: -------------------------------------------------------------------------------- 1 | module DB where 2 | 3 | import qualified Data.Aeson as A 4 | import qualified Data.Aeson.Encode.Pretty as A 5 | import qualified Data.Aeson.Types as A 6 | import qualified Data.ByteString.Lazy as BL 7 | import Data.Char (isLower, toLower) 8 | import qualified Data.Map as M 9 | import qualified Data.Text as T 10 | import qualified Data.Time.Clock as C 11 | import Foundation 12 | import GHC.Generics 13 | import qualified Prelude as P 14 | import qualified System.AtomicWrite.Writer.LazyByteString as AW 15 | import qualified System.Directory as D 16 | 17 | import Backerei.Types (Tezzies) 18 | 19 | withDB :: forall a . P.FilePath -> (Maybe DB -> IO (DB, a)) -> IO a 20 | withDB = withFile 21 | 22 | withDBLoop :: P.FilePath -> (Maybe DB -> IO (DB, (Bool, IO ()))) -> IO () 23 | withDBLoop path func = do 24 | (updated, action) <- withFile path func 25 | action 26 | if updated then withDBLoop path func else return () 27 | 28 | withAccountDB :: forall a . P.FilePath -> (Maybe AccountDB -> IO (AccountDB, a)) -> IO a 29 | withAccountDB = withFile 30 | 31 | mustReadDB :: P.FilePath -> IO DB 32 | mustReadDB path = withFile path $ \case 33 | Nothing -> error "db expected but not found" 34 | Just db -> 35 | return (db, db) 36 | 37 | withFile :: forall a b . (A.ToJSON b, A.FromJSON b) => P.FilePath -> (Maybe b -> IO (b, a)) -> IO a 38 | withFile path func = do 39 | exists <- D.doesFileExist path 40 | (updated, other) <- 41 | if exists then do 42 | prev <- BL.readFile path 43 | case A.decode prev of 44 | Just db -> func db 45 | Nothing -> error "could not decode DB" 46 | else 47 | func Nothing 48 | AW.atomicWriteFile path $ A.encodePretty' prettyConfig updated 49 | return other 50 | 51 | prettyConfig :: A.Config 52 | prettyConfig = A.Config (A.Spaces 4) A.compare A.Generic False 53 | 54 | newtype DB = DB { 55 | dbPayoutsByCycle :: M.Map Int CyclePayout 56 | } deriving (Generic, Show) 57 | 58 | data AccountDB = AccountDB { 59 | accountLastBlockScanned :: Int, 60 | accountTxs :: [AccountTx], 61 | accountVtxs :: [VirtualTx], 62 | accountsPreferred :: [(T.Text, [(Int, Rational)])], 63 | accountsSweep :: [T.Text], 64 | accountHistory :: M.Map Int AccountsState 65 | } deriving (Generic, Show) 66 | 67 | data AccountsState = AccountsState { 68 | stateSnapshotHeight :: Int, 69 | stateTotalBalance :: Tezzies, 70 | statePreferred :: M.Map T.Text AccountCycleState, 71 | stateRemainder :: AccountCycleState, 72 | stateFinalized :: Bool, 73 | statePaid :: Bool, 74 | stateCycleStartTimestamp :: Maybe C.UTCTime, 75 | stateCycleEndTimestamp :: Maybe C.UTCTime 76 | } deriving (Generic, Show) 77 | 78 | data AccountTx = AccountTx { 79 | txOperation :: T.Text, 80 | txAccount :: T.Text, 81 | txKind :: TxKind, 82 | txBlock :: Int, 83 | txAmount :: Tezzies 84 | } deriving (Generic, Show) 85 | 86 | data VirtualTx = VirtualTx { 87 | vtxFrom :: T.Text, 88 | vtxTo :: T.Text, 89 | vtxBlock :: Int, 90 | vtxAmount :: Tezzies 91 | } deriving (Generic, Show) 92 | 93 | data TxKind = Debit | Credit deriving (Generic, Show) 94 | 95 | data AccountCycleState = AccountCycleState { 96 | accountStakingBalance :: Tezzies, 97 | accountSplit :: Rational, 98 | accountEstimatedRewards :: AccountRewards, 99 | accountFinalRewards :: Maybe AccountRewards 100 | } deriving (Generic, Show) 101 | 102 | data AccountRewards = AccountRewards { 103 | rewardsSelf :: Tezzies, 104 | rewardsRevenueShare :: Tezzies, 105 | rewardsTotal :: Tezzies 106 | } deriving (Generic, Show) 107 | 108 | data CyclePayout = CyclePayout { 109 | cycleStakingBalance :: Tezzies, 110 | cycleFee :: Rational, 111 | cycleEstimatedTotalRewards :: Tezzies, 112 | cycleEstimatedBakerRewards :: BakerRewards, 113 | cycleStolenBlocks :: [StolenBlock], 114 | cycleFinalTotalRewards :: Maybe CycleRewards, 115 | cycleFinalBakerRewards :: Maybe BakerRewards, 116 | cycleDelegators :: M.Map T.Text DelegatorPayout 117 | } deriving (Generic, Show) 118 | 119 | data StolenBlock = StolenBlock { 120 | blockLevel :: Int, 121 | blockHash :: T.Text, 122 | blockPriority :: Int, 123 | blockReward :: Tezzies, 124 | blockFees :: Tezzies 125 | } deriving (Generic, Show) 126 | 127 | data CycleRewards = CycleRewards { 128 | rewardsRealized :: Tezzies, 129 | rewardsPaid :: Tezzies, 130 | rewardsRealizedDifference :: Tezzies, 131 | rewardsEstimatedDifference :: Tezzies 132 | } deriving (Generic, Show) 133 | 134 | data BakerRewards = BakerRewards { 135 | bakerBondRewards :: Tezzies, 136 | bakerFeeRewards :: Tezzies, 137 | bakerLooseRewards :: Tezzies, 138 | bakerTotalRewards :: Tezzies 139 | } deriving (Generic, Show) 140 | 141 | data DelegatorPayout = DelegatorPayout { 142 | delegatorBalance :: Tezzies, 143 | delegatorEstimatedRewards :: Tezzies, 144 | delegatorFinalRewards :: Maybe Tezzies, 145 | delegatorPayoutOperationHash :: Maybe T.Text 146 | } deriving (Generic, Show) 147 | 148 | instance A.FromJSON DB where 149 | parseJSON = customParseJSON 150 | 151 | instance A.ToJSON DB where 152 | toJSON = customToJSON 153 | toEncoding = customToEncoding 154 | 155 | instance A.FromJSON AccountDB where 156 | parseJSON = customParseJSON 157 | 158 | instance A.ToJSON AccountDB where 159 | toJSON = customToJSON 160 | toEncoding = customToEncoding 161 | 162 | instance A.FromJSON AccountsState where 163 | parseJSON = customParseJSON 164 | 165 | instance A.ToJSON AccountsState where 166 | toJSON = customToJSON 167 | toEncoding = customToEncoding 168 | 169 | instance A.FromJSON AccountTx where 170 | parseJSON = customParseJSON 171 | 172 | instance A.ToJSON AccountTx where 173 | toJSON = customToJSON 174 | toEncoding = customToEncoding 175 | 176 | instance A.FromJSON VirtualTx where 177 | parseJSON = customParseJSON 178 | 179 | instance A.ToJSON VirtualTx where 180 | toJSON = customToJSON 181 | toEncoding = customToEncoding 182 | 183 | instance A.FromJSON TxKind where 184 | parseJSON = customParseJSON 185 | 186 | instance A.ToJSON TxKind where 187 | toJSON = customToJSON 188 | toEncoding = customToEncoding 189 | 190 | instance A.FromJSON AccountCycleState where 191 | parseJSON = customParseJSON 192 | 193 | instance A.ToJSON AccountCycleState where 194 | toJSON = customToJSON 195 | toEncoding = customToEncoding 196 | 197 | instance A.FromJSON AccountRewards where 198 | parseJSON = customParseJSON 199 | 200 | instance A.ToJSON AccountRewards where 201 | toJSON = customToJSON 202 | toEncoding = customToEncoding 203 | 204 | instance A.FromJSON CyclePayout where 205 | parseJSON = customParseJSON 206 | 207 | instance A.ToJSON CyclePayout where 208 | toJSON = customToJSON 209 | toEncoding = customToEncoding 210 | 211 | instance A.FromJSON BakerRewards where 212 | parseJSON = customParseJSON 213 | 214 | instance A.ToJSON BakerRewards where 215 | toJSON = customToJSON 216 | toEncoding = customToEncoding 217 | 218 | instance A.FromJSON CycleRewards where 219 | parseJSON = customParseJSON 220 | 221 | instance A.ToJSON CycleRewards where 222 | toJSON = customToJSON 223 | toEncoding = customToEncoding 224 | 225 | instance A.FromJSON DelegatorPayout where 226 | parseJSON = customParseJSON 227 | 228 | instance A.ToJSON DelegatorPayout where 229 | toJSON = customToJSON 230 | toEncoding = customToEncoding 231 | 232 | instance A.FromJSON StolenBlock where 233 | parseJSON = customParseJSON 234 | 235 | instance A.ToJSON StolenBlock where 236 | toJSON = customToJSON 237 | toEncoding = customToEncoding 238 | 239 | jsonOptions ∷ A.Options 240 | jsonOptions = A.defaultOptions { 241 | A.fieldLabelModifier = (\(h:t) -> toLower h : t) . dropWhile isLower, 242 | A.constructorTagModifier = \(x:xs) -> toLower x : xs, 243 | A.omitNothingFields = True, 244 | A.sumEncoding = A.ObjectWithSingleField 245 | } 246 | 247 | customParseJSON :: (Generic a, A.GFromJSON A.Zero (Rep a)) => A.Value -> A.Parser a 248 | customParseJSON = A.genericParseJSON jsonOptions 249 | 250 | customToJSON :: (Generic a, A.GToJSON A.Zero (Rep a)) => a -> A.Value 251 | customToJSON = A.genericToJSON jsonOptions 252 | 253 | customToEncoding :: (Generic a, A.GToEncoding A.Zero (Rep a)) => a -> A.Encoding 254 | customToEncoding = A.genericToEncoding jsonOptions 255 | -------------------------------------------------------------------------------- /app/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | module Main where 4 | 5 | import Control.Concurrent 6 | import Control.Monad 7 | import Data.Function (on, (&)) 8 | import qualified Data.Sequence as Seq 9 | import qualified Data.Text as T 10 | import qualified Data.Text.IO as T 11 | import Development.GitRev 12 | import Foundation 13 | import qualified Network.Monitoring.Riemann.Event as Riemann 14 | import qualified Network.Monitoring.Riemann.TCP as Riemann 15 | import Options.Applicative 16 | import qualified Prelude as P 17 | import qualified Servant.Client as TG 18 | import System.Directory 19 | import System.Exit 20 | import System.IO 21 | import qualified Telegram.Bot.API as TG 22 | import Text.PrettyPrint.ANSI.Leijen hiding ((<$>), (<>)) 23 | 24 | import qualified Backerei.RPC as RPC 25 | import qualified Backerei.Types as RPC 26 | 27 | import Config 28 | import Options 29 | import Payout 30 | 31 | main ∷ IO () 32 | main = do 33 | ctx <- context 34 | let opts = info (options ctx <**> helper) (fullDesc <> headerDoc (Just aboutDoc)) 35 | run =<< execParser opts 36 | 37 | context ∷ IO Context 38 | context = Context <$> getHomeDirectory 39 | 40 | run ∷ Options → IO () 41 | run (Options configPath command) = do 42 | hSetBuffering stdout LineBuffering 43 | let withConfig ∷ (Config → IO ()) → IO () 44 | withConfig func = do 45 | maybeConf <- loadConfig configPath 46 | case maybeConf of 47 | Nothing -> do 48 | T.putStrLn ("Error parsing configuration file " <> T.pack configPath) 49 | exitFailure 50 | Just conf -> func conf 51 | case command of 52 | Version -> do 53 | putDoc versionDoc 54 | exitSuccess 55 | Init addr host port from fromName fee dbPath clientPath clientConfigFile startingCycle cycleLength snapshotInterval preservedCycles payoutDelay babylonStartingCycle payEstimatedRewards -> do 56 | let config = Config addr host port from fromName [(startingCycle, fee)] dbPath Nothing clientPath clientConfigFile startingCycle cycleLength snapshotInterval preservedCycles payoutDelay babylonStartingCycle payEstimatedRewards Nothing Nothing Nothing 57 | writeConfig configPath config 58 | exitSuccess 59 | Monitor -> withConfig $ \config -> do 60 | event <- case configRiemann config of 61 | Nothing -> return $ const $ return () 62 | Just (RiemannConfig host port) -> do 63 | conn <- Riemann.tcpConnection (T.unpack host) port 64 | return $ Riemann.sendEvents conn . Seq.singleton 65 | let conf = RPC.Config (configHost config) (configPort config) 66 | baker = configBakerAddress config 67 | waitUntil height = do 68 | let helper prev = do 69 | [head]:_ <- RPC.blocks conf 70 | if Just head == prev then threadDelay (P.round (1e6 :: Double)) >> helper prev else do 71 | header <- RPC.header conf head 72 | event $ Riemann.ok "tezos" & Riemann.metric (RPC.headerLevel header) & Riemann.description ("Hash: " <> T.unpack (RPC.headerHash header)) & Riemann.ttl 360 73 | if RPC.headerLevel header == height then return head else helper (Just head) 74 | helper Nothing 75 | [head]:_ <- RPC.blocks conf 76 | level <- RPC.currentLevel conf head 77 | let cycle = RPC.levelCycle level 78 | T.putStrLn $ T.concat ["Current cycle: ", T.pack $ P.show cycle] 79 | let next cycle = do 80 | T.putStrLn $ T.concat ["Scanning rights for cycle ", T.pack $ P.show cycle, "..."] 81 | baking <- filter ((==) 0 . RPC.bakingPriority) `fmap` RPC.bakingRightsFor conf head baker cycle 82 | endorsing <- RPC.endorsingRightsFor conf head baker cycle 83 | if not (null baking) || not (null endorsing) then return (cycle, baking, endorsing) else next (cycle + 1) 84 | (cycle, baking, endorsing) <- next cycle 85 | T.putStrLn $ T.concat ["Found rights in cycle ", T.pack $ P.show cycle, ": ", T.pack $ P.show $ P.length baking, " blocks to bake (priority 0), ", 86 | T.pack $ P.show $ P.length endorsing, " blocks to endorse."] 87 | let levelToWait (Right e) = RPC.endorsingLevel e + 1 88 | levelToWait (Left b) = RPC.bakingLevel b 89 | allRights = sortBy (compare `on` levelToWait) $ filter (\x -> levelToWait x > RPC.levelLevel level) (fmap Right endorsing <> fmap Left baking) 90 | forM_ allRights $ \right -> do 91 | hash <- waitUntil (levelToWait right) 92 | case right of 93 | Right e -> do 94 | operations <- RPC.operations conf hash 95 | case P.filter ((==) (Just baker) . RPC.opmetadataDelegate . RPC.opcontentsMetadata . P.head . RPC.operationContents) operations of 96 | [] -> event $ Riemann.failure "endorser" & Riemann.metric (RPC.endorsingLevel e) & Riemann.description ("Hash: " <> T.unpack hash) & Riemann.ttl 86400 97 | _ -> event $ Riemann.ok "endorser" & Riemann.metric (RPC.endorsingLevel e) & Riemann.description ("Hash: " <> T.unpack hash) & Riemann.ttl 86400 98 | Left _ -> do 99 | metadata <- RPC.metadata conf hash 100 | if RPC.metadataBaker metadata == baker then 101 | event $ Riemann.ok "baker" & Riemann.metric (levelToWait right) & Riemann.description ("Hash: " <> P.show hash) & Riemann.ttl 86400 102 | else 103 | event $ Riemann.failure "baker" & Riemann.metric (levelToWait right) & Riemann.description ("Stolen by: " P.++ T.unpack (RPC.metadataBaker metadata)) & Riemann.ttl 86400 104 | Payout noDryRun continuous noPassword -> withConfig $ \config -> do 105 | notify <- case configTelegram config of 106 | Nothing -> return T.putStrLn 107 | Just (TelegramConfig token channelNotification) -> do 108 | env <- TG.defaultTelegramClientEnv (TG.Token token) 109 | return (\msg -> do 110 | _ <- TG.runClientM (TG.sendMessage (TG.SendMessageRequest (TG.SomeChatUsername channelNotification) msg Nothing Nothing Nothing Nothing Nothing)) env 111 | T.putStrLn $ T.concat ["Notified ", channelNotification, " with \"", msg, "\""]) 112 | fromPassword <- do 113 | if noPassword then do 114 | return "" 115 | else do 116 | hSetEcho stdin False 117 | System.IO.putStr "Enter source account password: " 118 | hFlush stdout 119 | pass <- getLine 120 | putChar '\n' 121 | hSetEcho stdin True 122 | return pass 123 | payout config noDryRun (case P.length fromPassword of 0 -> Nothing; _ -> Just $ T.pack fromPassword) continuous notify 124 | 125 | aboutDoc ∷ Doc 126 | aboutDoc = mconcat [ 127 | text "Bäckerei – Tooling for the Cryptium Tezos Bäckerei", 128 | line, 129 | text "© 2018-2019 Cryptium Labs • https://cryptium.ch" 130 | ] 131 | 132 | versionDoc ∷ Doc 133 | versionDoc = mconcat [ 134 | aboutDoc, 135 | line, 136 | mconcat ["Prerelease version. This is alpha software.", line], 137 | mconcat ["Built from branch ", white $(gitBranch), " at commit ", red $(gitHash), ".", line] 138 | ] 139 | -------------------------------------------------------------------------------- /app/Options.hs: -------------------------------------------------------------------------------- 1 | module Options where 2 | 3 | import qualified Config 4 | import qualified Data.Text as T 5 | import Foundation 6 | import Options.Applicative 7 | import qualified Prelude as P 8 | 9 | newtype Context = Context { 10 | contextHomeDirectory :: P.FilePath 11 | } 12 | 13 | data Options = Options { 14 | optionsConfigPath :: P.FilePath, 15 | optionsCommand :: Command 16 | } 17 | 18 | data Command = 19 | Version | 20 | Init T.Text T.Text Int T.Text T.Text Rational T.Text T.Text T.Text Int Int Int Int Int Int Bool | 21 | Monitor | 22 | Payout Bool Bool Bool 23 | 24 | options ∷ Context → Parser Options 25 | options ctx = Options <$> configOptions ctx <*> commandOptions ctx 26 | 27 | configOptions ∷ Context → Parser P.FilePath 28 | configOptions ctx = strOption (long "config" <> metavar "FILE" <> help "Path to YAML configuration file" <> showDefault <> value (contextHomeDirectory ctx <> "/.backerei.yaml")) 29 | 30 | commandOptions ∷ Context -> Parser Command 31 | commandOptions ctx = subparser ( 32 | command "version" (info versionOptions (progDesc "Display program version information")) <> 33 | command "init" (info (initOptions ctx) (progDesc "Initialize configuration file")) <> 34 | command "monitor" (info monitorOptions (progDesc "Monitor baking & endorsing status")) <> 35 | command "payout" (info payoutOptions (progDesc "Calculate payouts")) 36 | ) 37 | 38 | versionOptions ∷ Parser Command 39 | versionOptions = pure Version 40 | 41 | initOptions ∷ Context -> Parser Command 42 | initOptions ctx = Init <$> addrOptions <*> hostOptions <*> portOptions <*> fromOptions <*> fromNameOptions <*> feeOptions <*> dbPathOptions ctx <*> clientPathOptions <*> clientConfigFileOptions <*> startingCycleOptions <*> cycleLengthOptions <*> snapshotIntervalOptions <*> preservedCyclesOptions <*> payoutDelayOptions <*> babylonStartingCycleOptions <*> payEstimatedRewards 43 | 44 | addrOptions ∷ Parser T.Text 45 | addrOptions = T.pack <$> strOption (long "tz1" <> metavar "tz1" <> help "tz1 address of baker implicit account") 46 | 47 | hostOptions ∷ Parser T.Text 48 | hostOptions = T.pack <$> strOption (long "host" <> metavar "HOST" <> help "Tezos node RPC hostname" <> showDefault <> value "127.0.0.1") 49 | 50 | portOptions ∷ Parser Int 51 | portOptions = option auto (long "port" <> metavar "PORT" <> help "Tezos node RPC port" <> showDefault <> value 8732) 52 | 53 | fromOptions :: Parser T.Text 54 | fromOptions = T.pack <$> strOption (long "from" <> metavar "FROM" <> help "Address to send payouts from") 55 | 56 | fromNameOptions :: Parser T.Text 57 | fromNameOptions = T.pack <$> strOption (long "from-name" <> metavar "NAME" <> help "Local client alias of the address to send payouts from") 58 | 59 | feeOptions :: Parser Rational 60 | feeOptions = option auto (long "fee" <> metavar "FEE" <> help "Fractional fee taken by baker" <> showDefault <> value Config.defaultFee) 61 | 62 | dbPathOptions :: Context -> Parser T.Text 63 | dbPathOptions ctx = T.pack <$> strOption (long "database-path" <> metavar "DBPATH" <> help "Path to JSON DB" <> showDefault <> value (contextHomeDirectory ctx <> "/.backerei.json")) 64 | 65 | clientPathOptions :: Parser T.Text 66 | clientPathOptions = T.pack <$> strOption (long "client-path" <> metavar "PATH" <> help "Path to 'tezos-client' executable" <> showDefault <> value "/usr/local/bin/tezos-client") 67 | 68 | clientConfigFileOptions :: Parser T.Text 69 | clientConfigFileOptions = T.pack <$> strOption (long "client-config-file" <> metavar "PATH" <> help "Path to 'tezos-client' config file") 70 | 71 | startingCycleOptions :: Parser Int 72 | startingCycleOptions = option auto (long "starting-cycle" <> metavar "CYCLE" <> help "Cycle at which baker became a delegate") 73 | 74 | cycleLengthOptions :: Parser Int 75 | cycleLengthOptions = option auto (long "cycle-length" <> metavar "BLOCKS" <> help "Length of a single cycle in blocks" <> showDefault <> value 4096) 76 | 77 | snapshotIntervalOptions :: Parser Int 78 | snapshotIntervalOptions = option auto (long "snapshot-interval" <> metavar "BLOCKS" <> help "Interval between snapshots in blocks" <> showDefault <> value 256) 79 | 80 | babylonStartingCycleOptions :: Parser Int 81 | babylonStartingCycleOptions = option auto (long "babylon-starting-cycle" <> metavar "CYCLE" <> help "Starting cycle for Babylon upgrade" <> showDefault <> value 160) 82 | 83 | preservedCyclesOptions :: Parser Int 84 | preservedCyclesOptions = option auto (long "preserved-cycles" <> metavar "BLOCKS" <> help "Preserved cycles constant, may be different for alphanet" <> showDefault <> value 5) 85 | 86 | payoutDelayOptions :: Parser Int 87 | payoutDelayOptions = option auto (long "payout-delay" <> metavar "BLOCKS" <> help "Delay in cycles to pay out delegators later or earlier than rewards unlocking" <> showDefault <> value 0) 88 | 89 | payEstimatedRewards :: Parser Bool 90 | payEstimatedRewards = switch (long "pay-estimated-rewards" <> help "Pay out reward estimates instead of realized rewards") 91 | 92 | accountOptions :: Parser T.Text 93 | accountOptions = T.pack <$> strOption (long "account" <> metavar "ACCOUNT" <> help "Account name or KT1 address") 94 | 95 | monitorOptions ∷ Parser Command 96 | monitorOptions = pure Monitor 97 | 98 | payoutOptions ∷ Parser Command 99 | payoutOptions = Payout <$> noDryRunOptions <*> continuousOptions <*> noPasswordOptions 100 | 101 | noDryRunOptions :: Parser Bool 102 | noDryRunOptions = switch (long "no-dry-run" <> help "Really transfer Tezzies") 103 | 104 | continuousOptions :: Parser Bool 105 | continuousOptions = switch (long "continuous" <> help "Run continuously") 106 | 107 | noPasswordOptions :: Parser Bool 108 | noPasswordOptions = switch (long "no-password" <> help "Do not prompt for password, assume unencrypted account") 109 | -------------------------------------------------------------------------------- /app/Payout.hs: -------------------------------------------------------------------------------- 1 | module Payout where 2 | 3 | import Control.Concurrent 4 | import Control.Exception 5 | import Control.Monad 6 | import qualified Data.ByteString.Char8 as B 7 | import qualified Data.Map as M 8 | import Data.Maybe (fromJust) 9 | import qualified Data.Text as T 10 | import qualified Data.Text.IO as T 11 | import Foundation 12 | import Foundation.Collection ((!)) 13 | import qualified Prelude as P 14 | import System.Exit 15 | import qualified System.Posix.Pty as P 16 | import qualified System.Process as P 17 | 18 | import qualified Backerei.Delegation as Delegation 19 | import qualified Backerei.RPC as RPC 20 | import qualified Backerei.Types as RPC 21 | 22 | import Config 23 | import DB 24 | 25 | payout :: Config -> Bool -> Maybe T.Text -> Bool -> (T.Text -> IO ()) -> IO () 26 | payout (Config baker host port from fromName varyingFee databasePath accountDatabasePath clientPath clientConfigFile startingCycle cycleLength snapshotInterval preservedCycles payoutDelay babylonStartingCycle payEstimatedRewards _ _ maybePostPayoutScript) noDryRun fromPassword continuous notify = do 27 | let conf = RPC.Config host port 28 | 29 | isBabylon cycle = cycle >= babylonStartingCycle 30 | 31 | feeForCycle cycle = fromMaybe Config.defaultFee $ 32 | snd . last <$> (nonEmpty $ filter ((>=) cycle . fst) varyingFee) 33 | 34 | maybeUpdateTimestampsForCycle cycle db = do 35 | let history = accountHistory db 36 | case M.lookup cycle history of 37 | Nothing -> return (db, False) 38 | Just state -> do 39 | case stateCycleStartTimestamp state of 40 | Nothing -> do 41 | let startLevel = Delegation.startingBlock cycle cycleLength 42 | hash <- Delegation.blockHashByLevel conf startLevel 43 | header <- RPC.header conf hash 44 | let startTimestamp = RPC.headerTimestamp header 45 | newState = state { stateCycleStartTimestamp = Just startTimestamp } 46 | return (db { accountHistory = M.insert cycle newState history }, True) 47 | Just _ -> do 48 | case stateCycleEndTimestamp state of 49 | Nothing -> do 50 | let endLevel = Delegation.endingBlock cycle cycleLength 51 | hash <- Delegation.blockHashByLevel conf endLevel 52 | header <- RPC.header conf hash 53 | let endTimestamp = RPC.headerTimestamp header 54 | newState = state { stateCycleEndTimestamp = Just endTimestamp } 55 | return (db { accountHistory = M.insert cycle newState history }, True) 56 | Just _ -> return (db, False) 57 | 58 | maybeUpdateTimestamps db = do 59 | currentLevel <- RPC.currentLevel conf RPC.head 60 | let currentCycle = RPC.levelCycle currentLevel 61 | foldFirst db (fmap maybeUpdateTimestampsForCycle [startingCycle .. currentCycle - 1]) 62 | 63 | maybeUpdateEstimatesForCycle cycle db = do 64 | let payouts = dbPayoutsByCycle db 65 | fee = feeForCycle cycle 66 | if M.member cycle payouts then return (db, False) else do 67 | T.putStrLn $ T.concat ["Updating DB with estimates for cycle ", T.pack $ P.show cycle, "..."] 68 | estimatedRewards <- Delegation.estimatedRewards conf cycleLength cycle baker 69 | ((bakerBondReward, bakerFeeReward, bakerLooseReward, bakerTotalReward), calculated, stakingBalance) <- Delegation.calculateRewardsFor conf cycleLength snapshotInterval cycle baker estimatedRewards fee 70 | let bakerRewards = BakerRewards bakerBondReward bakerFeeReward bakerLooseReward bakerTotalReward 71 | delegators = M.fromList $ fmap (\(addr, balance, payout) -> (addr, DelegatorPayout balance payout Nothing Nothing)) calculated 72 | cyclePayout = CyclePayout stakingBalance fee estimatedRewards bakerRewards [] Nothing Nothing delegators 73 | return (db { dbPayoutsByCycle = M.insert cycle cyclePayout payouts }, True) 74 | maybeUpdateEstimates db = do 75 | currentLevel <- RPC.currentLevel conf RPC.head 76 | let currentCycle = RPC.levelCycle currentLevel 77 | knownCycle = currentCycle + preservedCycles 78 | (res, updated) <- foldFirst db (fmap maybeUpdateEstimatesForCycle [startingCycle .. knownCycle]) 79 | return (res, (updated, return ())) 80 | 81 | maybeUpdateActualForCycle cycle db = do 82 | let payouts = dbPayoutsByCycle db 83 | fee = feeForCycle cycle 84 | case M.lookup cycle payouts of 85 | Nothing -> error "should not happen: missed lookup" 86 | Just cyclePayout -> 87 | if isJust (cycleFinalTotalRewards cyclePayout) then 88 | return (db, False) 89 | else do 90 | T.putStrLn $ T.concat ["Updating DB with actual earnings for cycle ", T.pack $ P.show cycle, "..."] 91 | stolen <- Delegation.stolenBlocks conf cycleLength cycle baker 92 | let stolenBlocks = fmap (\(a, b, c, d, e) -> StolenBlock a b c d e) stolen 93 | hash <- Delegation.hashToQuery conf (cycle + 1) cycleLength 94 | frozenBalanceByCycle <- RPC.frozenBalanceByCycle conf hash baker 95 | lostEndorsementRewards <- Delegation.lostEndorsementRewards conf cycleLength cycle baker 96 | T.putStrLn $ T.concat ["Lost endorsement rewards due to other-baker downtime for cycle ", T.pack $ P.show cycle, ": ", T.pack $ P.show lostEndorsementRewards] 97 | lostBakingRewards <- if isBabylon cycle then do 98 | lostRewards <- Delegation.lostBakingRewards conf cycleLength cycle baker 99 | T.putStrLn $ T.concat ["Lost baking rewards due to missing endorsements for cycle ", T.pack $ P.show cycle, ": ", T.pack $ P.show lostRewards] 100 | return lostRewards 101 | else return 0 102 | let thisCycle = filter ((==) cycle . RPC.frozenCycle) frozenBalanceByCycle ! 0 103 | feeRewards = maybe 0 RPC.frozenFees thisCycle 104 | extraRewards = feeRewards P.- lostEndorsementRewards P.- lostBakingRewards 105 | realizedRewards = feeRewards P.+ maybe 0 RPC.frozenRewards thisCycle 106 | estimatedRewards = cycleEstimatedTotalRewards cyclePayout 107 | paidRewards = estimatedRewards P.+ extraRewards 108 | realizedDifference = realizedRewards P.- paidRewards 109 | estimatedDifference = estimatedRewards P.- paidRewards 110 | finalTotalRewards = CycleRewards realizedRewards paidRewards realizedDifference estimatedDifference 111 | ((bakerBondReward, bakerFeeReward, bakerLooseReward, bakerTotalReward), calculated, _) <- Delegation.calculateRewardsFor conf cycleLength snapshotInterval cycle baker paidRewards fee 112 | let bakerRewards = BakerRewards bakerBondReward bakerFeeReward bakerLooseReward bakerTotalReward 113 | estimatedDelegators = cycleDelegators cyclePayout 114 | delegators = M.fromList $ fmap (\(addr, balance, payout) -> (addr, DelegatorPayout balance (delegatorEstimatedRewards $ estimatedDelegators M.! addr) (Just payout) (delegatorPayoutOperationHash $ estimatedDelegators M.! addr))) calculated 115 | return (db { dbPayoutsByCycle = M.insert cycle (cyclePayout { cycleStolenBlocks = stolenBlocks, cycleFinalTotalRewards = Just finalTotalRewards, 116 | cycleFinalBakerRewards = Just bakerRewards, cycleDelegators = delegators }) payouts }, True) 117 | maybeUpdateActual db = do 118 | currentLevel <- RPC.currentLevel conf RPC.head 119 | let currentCycle = RPC.levelCycle currentLevel 120 | knownCycle = currentCycle - 1 121 | (res, updated) <- foldFirst db (fmap maybeUpdateActualForCycle [startingCycle .. knownCycle]) 122 | return (res, (updated, return ())) 123 | 124 | maybePayoutDelegatorsForCycle cycle delegators db = do 125 | let needToPay' = if payEstimatedRewards then P.filter (\(_, delegator) -> case (delegatorPayoutOperationHash delegator, delegatorEstimatedRewards delegator) of (Nothing, amount) | amount > 0 -> True; _ -> False) $ M.toList delegators else P.filter (\(_, delegator) -> case (delegatorPayoutOperationHash delegator, delegatorFinalRewards delegator) of (Nothing, Just amount) | amount > 0 -> True; _ -> False) $ M.toList delegators 126 | needToPay <- (P.map (\(a, b, _) -> (a, b)) . P.filter (\(_, _, r) -> r)) `fmap` P.mapM (\(d, a) -> 127 | if T.take 2 d == "KT" then pure (d, a, True) else RPC.managerKey conf RPC.head d >>= \r -> pure (d, a, r /= Nothing)) needToPay' 128 | let toPay = P.take 100 needToPay 129 | if null toPay then return (db, (False, return ())) else do 130 | forM_ toPay $ \(address, delegator) -> do 131 | if payEstimatedRewards then 132 | T.putStrLn $ T.concat ["For cycle ", T.pack $ P.show cycle, " delegator ", address, " should be paid estimated rewards of ", T.pack $ P.show $ delegatorEstimatedRewards delegator, " XTZ"] 133 | else 134 | T.putStrLn $ T.concat ["For cycle ", T.pack $ P.show cycle, " delegator ", address, " should be paid final rewards of ", T.pack $ P.show $ fromJust (delegatorFinalRewards delegator), " XTZ"] 135 | (updatedDelegators, action) <- 136 | if noDryRun then do 137 | let dests = if payEstimatedRewards then fmap (\(address, delegator) -> (address, delegatorEstimatedRewards delegator)) toPay else fmap (\(address, delegator) -> (address, let Just amount = delegatorFinalRewards delegator in amount)) toPay 138 | hash <- RPC.sendTezzies conf from fromName dests (sign clientPath clientConfigFile fromPassword) 139 | threadDelay 600000000 140 | if length toPay == length needToPay then do 141 | notify $ T.concat ["Payouts for cycle ", T.pack $ P.show cycle, " complete!"] 142 | else return () 143 | let action = if length toPay == length needToPay then case maybePostPayoutScript of Nothing -> return (); Just script -> P.callCommand (T.unpack script) else return () 144 | return (M.union (M.fromList $ fmap (\(address, delegator) -> (address, delegator { delegatorPayoutOperationHash = Just hash })) toPay) delegators, action) 145 | else return (delegators, return ()) 146 | return (db { dbPayoutsByCycle = M.adjust (\c -> c { cycleDelegators = updatedDelegators }) cycle $ dbPayoutsByCycle db }, (noDryRun, action)) 147 | maybePayoutForCycle cycle db = do 148 | let payouts = dbPayoutsByCycle db 149 | case M.lookup cycle payouts of 150 | Nothing -> error "should not happen: missed lookup" 151 | Just cyclePayout -> do 152 | let delegators = cycleDelegators cyclePayout 153 | let total = if payEstimatedRewards then P.sum $ fmap delegatorEstimatedRewards $ P.filter (isNothing . delegatorPayoutOperationHash) $ M.elems delegators else P.sum $ fmap (fromJust . delegatorFinalRewards) $ P.filter (isJust . delegatorFinalRewards) $ P.filter (isNothing . delegatorPayoutOperationHash) $ M.elems delegators 154 | if total == 0 then return (db, (False, return ())) else do 155 | balance <- RPC.balanceAt conf RPC.head from 156 | T.putStrLn $ T.concat ["Total payouts: ", T.pack $ P.show total, ", payout account balance: ", T.pack $ P.show balance] 157 | if balance < total then do 158 | T.putStrLn "Balance less than total required to pay cycle, aborting" 159 | return (db, (False, return ())) 160 | else maybePayoutDelegatorsForCycle cycle delegators db 161 | maybePayout db = do 162 | currentLevel <- RPC.currentLevel conf RPC.head 163 | let currentCycle = RPC.levelCycle currentLevel 164 | unlockedCycle = currentCycle - preservedCycles - payoutDelay - 1 165 | foldFirst3 db (fmap maybePayoutForCycle [startingCycle .. unlockedCycle]) 166 | 167 | balanceAt :: AccountDB -> Int -> T.Text -> RPC.Tezzies 168 | balanceAt db height account = 169 | let txs = P.filter (\tx -> txBlock tx <= height && txAccount tx == account) $ accountTxs db 170 | txb = P.sum $ fmap (\tx -> (case txKind tx of Debit -> -1; Credit -> 1) P.* txAmount tx) txs 171 | vtxs = P.filter (\vtx -> vtxBlock vtx < height && (vtxFrom vtx == account || vtxTo vtx == account)) $ accountVtxs db 172 | vtxb = P.sum $ fmap (\vtx -> (if vtxFrom vtx == account then -1 else 1) P.* vtxAmount vtx) vtxs 173 | in txb P.+ vtxb 174 | 175 | calculateRewards :: BakerRewards -> Maybe (RPC.Tezzies, RPC.Tezzies, RPC.Tezzies, RPC.Tezzies) -> RPC.Tezzies -> RPC.Tezzies -> Rational -> AccountRewards 176 | calculateRewards (BakerRewards estimatedBond _ _ estimatedTotal) finalFees balance totalBalance split = 177 | let fraction = if balance == 0 then 0 else balance P./ totalBalance 178 | bondRewards = estimatedBond 179 | bondNet = fraction P.* bondRewards 180 | feeNet = case finalFees of Just (fees, lostEndorsementRewards, lostBakingRewards, total) -> balance P.* (fees P.- lostEndorsementRewards P.- lostBakingRewards) P./ total; Nothing -> 0 181 | otherRewards = (estimatedTotal P.- estimatedBond) 182 | otherNet = otherRewards P.* fraction P.* P.fromRational split 183 | selfNet = bondNet P.+ feeNet 184 | totalNet = selfNet P.+ otherNet 185 | in AccountRewards selfNet otherNet totalNet 186 | 187 | maybePayoutAccountsForCycle cycle db = do 188 | -- Pay out released rewards (looking up balances) as virtual transactions, then mark cycle paid. 189 | let unlockedCycle = cycle P.- preservedCycles - payoutDelay - 1 190 | if unlockedCycle < startingCycle then return (db, False) else do 191 | let history = accountHistory db 192 | state = history M.! unlockedCycle 193 | if statePaid state then return (db, False) else do 194 | T.putStrLn $ T.concat ["Paying out internal accounts for cycle ", T.pack $ P.show unlockedCycle, "..."] 195 | let cycleStart = cycle P.* cycleLength 196 | makeTx :: (T.Text, AccountCycleState) -> VirtualTx 197 | makeTx (account, AccountCycleState _ _ _ (Just finalRewards)) = VirtualTx "" account cycleStart (rewardsTotal finalRewards) 198 | makeTx _ = error "should not happen: no final rewards" 199 | txs = fmap makeTx (M.toList $ statePreferred state) 200 | newState = state { statePaid = True } 201 | let sweep = accountsSweep db 202 | T.putStrLn $ T.concat ["Sweeping all balances from accounts ", T.intercalate ", " sweep] 203 | let makeTx :: T.Text -> VirtualTx 204 | makeTx account = VirtualTx account "" cycleStart (balanceAt db cycleStart account) 205 | sweepTxs = filter (\vtx -> vtxAmount vtx > 0) $ fmap makeTx sweep 206 | return (db { accountVtxs = accountVtxs db P.++ txs P.++ sweepTxs, accountHistory = M.insert unlockedCycle newState (accountHistory db) }, True) 207 | 208 | maybeFetchAccountEstimatesForCycle mainDB cycle db = do 209 | -- Fetch estimates for future cycle and calculate exact payouts for just-completed cycle. 210 | let knownCycle = cycle + preservedCycles 211 | history = accountHistory db 212 | case M.lookup knownCycle history of 213 | Just _ -> return (db, False) 214 | Nothing -> do 215 | T.putStrLn $ T.concat ["Calculating estimated internal account rewards for cycle ", T.pack $ P.show knownCycle, "..."] 216 | -- Figure out snapshot block for known cycle. 217 | snapshot <- if knownCycle < startingCycle then return 0 else Delegation.snapshotLevel conf knownCycle cycleLength snapshotInterval 218 | snapshotHash <- Delegation.blockHashByLevel conf snapshot 219 | -- Calculate account balances at snapshot block. 220 | snapshotBalance <- if knownCycle < startingCycle then return 0 else RPC.delegateBalanceAt conf snapshotHash baker 221 | frozenRewards <- if knownCycle < startingCycle then return 0 else RPC.totalFrozenRewardsAt conf snapshotHash baker 222 | -- Split estimated rewards accordingly. 223 | let totalBalance = snapshotBalance P.- frozenRewards 224 | cyclePayout = dbPayoutsByCycle mainDB M.! knownCycle 225 | bakerRewards = cycleEstimatedBakerRewards cyclePayout 226 | accounts = fmap (\(account, splits) -> (account, let b = balanceAt db snapshot account in let split = snd $ P.last $ P.filter (\x -> fst x < snapshot) splits in AccountCycleState b split (calculateRewards bakerRewards Nothing b totalBalance split) Nothing)) (accountsPreferred db) 227 | remainderBalance = totalBalance P.- P.sum (fmap (accountStakingBalance . snd) accounts) 228 | remainderRewards = bakerTotalRewards bakerRewards P.- P.sum (fmap (rewardsTotal . accountEstimatedRewards . snd) accounts) 229 | preferred = M.fromList accounts 230 | remainder = AccountCycleState remainderBalance 0 (AccountRewards 0 0 remainderRewards) Nothing 231 | state = AccountsState snapshot totalBalance preferred remainder False False Nothing Nothing 232 | T.putStrLn $ T.concat ["Estimated remainder balance: ", T.pack $ P.show remainderBalance, ", estimated remainder rewards: ", T.pack $ P.show remainderRewards] 233 | return (db { accountHistory = M.insert knownCycle state history }, True) 234 | 235 | maybeFetchAccountActualForCycle mainDB cycle db = do 236 | let finishedCycle = cycle - 1 237 | history = accountHistory db 238 | state = history M.! finishedCycle 239 | if finishedCycle < startingCycle || stateFinalized state then return (db, False) else do 240 | T.putStrLn $ T.concat ["Calculating final internal account rewards for cycle ", T.pack $ P.show finishedCycle, "..."] 241 | snapshot <- Delegation.snapshotLevel conf finishedCycle cycleLength snapshotInterval 242 | snapshotHash <- Delegation.blockHashByLevel conf snapshot 243 | snapshotBalance <- RPC.delegateBalanceAt conf snapshotHash baker 244 | hash <- Delegation.hashToQuery conf (finishedCycle + 2) cycleLength 245 | fees <- RPC.frozenFeesForCycle conf hash baker finishedCycle 246 | lostEndorsementRewards <- Delegation.lostEndorsementRewards conf cycleLength finishedCycle baker 247 | lostBakingRewards <- if isBabylon finishedCycle then Delegation.lostBakingRewards conf cycleLength finishedCycle baker else return 0 248 | T.putStrLn $ T.concat ["Total fees for cycle ", T.pack $ P.show finishedCycle, ": ", T.pack $ P.show fees] 249 | let cyclePayout = dbPayoutsByCycle mainDB M.! finishedCycle 250 | estimatedBakerRewards = cycleEstimatedBakerRewards cyclePayout 251 | Just finalBakerRewards = cycleFinalBakerRewards cyclePayout 252 | totalBalance = stateTotalBalance state 253 | updatedPreferred = fmap (\(account, AccountCycleState balance split estimated Nothing) -> (account, AccountCycleState balance split estimated (Just $ calculateRewards estimatedBakerRewards (Just (fees, lostEndorsementRewards, lostBakingRewards, snapshotBalance)) balance totalBalance split))) $ M.toList $ statePreferred state 254 | remainderRewards = bakerTotalRewards finalBakerRewards P.- P.sum (fmap (rewardsTotal . fromJust . accountFinalRewards . snd) updatedPreferred) 255 | remainder = stateRemainder state 256 | updatedRemainder = remainder { accountFinalRewards = Just $ AccountRewards 0 0 remainderRewards } 257 | updatedState = state { stateFinalized = True, statePreferred = M.fromList updatedPreferred, stateRemainder = updatedRemainder } 258 | T.putStrLn $ T.concat ["Estimated remainder rewards: ", T.pack $ P.show (accountEstimatedRewards remainder), ", final remainder rewards: ", T.pack $ P.show remainderRewards] 259 | return (db { accountHistory = M.insert finishedCycle updatedState history }, True) 260 | 261 | maybePayoutAccountsAndFetchEstimatesForCycle mainDB cycle db = 262 | foldFirst db [maybePayoutAccountsForCycle cycle, maybeFetchAccountEstimatesForCycle mainDB cycle, maybeFetchAccountActualForCycle mainDB cycle] 263 | maybePayoutAccountsAndFetchEstimates mainDB db = do 264 | currentLevel <- RPC.currentLevel conf RPC.head 265 | let currentCycle = RPC.levelCycle currentLevel 266 | foldFirst db (fmap (maybePayoutAccountsAndFetchEstimatesForCycle mainDB) [startingCycle - preservedCycles .. currentCycle]) 267 | 268 | maybeFetchOperationsByLevel level db = do 269 | T.putStrLn $ T.concat ["Scanning operations in level ", T.pack $ P.show level, "..."] 270 | hash <- Delegation.blockHashByLevel conf level 271 | operations <- RPC.operations conf hash 272 | let assoc = P.concatMap (\o -> fmap ((,) (RPC.operationHash o)) (RPC.operationContents o)) operations 273 | matching = P.filter (\(_, contents) -> RPC.opcontentsKind contents == "transaction" && (RPC.opcontentsSource contents == Just baker || RPC.opcontentsDestination contents == Just baker)) assoc 274 | txs <- forM matching $ \(hash, contents) -> do 275 | T.putStrLn $ T.concat ["Enter account name for operation: ", T.pack $ P.show (hash, contents), ":"] 276 | account <- T.getLine 277 | let kind = if RPC.opcontentsSource contents == Just baker then Debit else Credit 278 | return $ AccountTx hash account kind level (let Just a = RPC.opcontentsAmount contents in a) 279 | return (db { accountLastBlockScanned = level, accountTxs = accountTxs db P.++ txs }, True) 280 | maybeFetchOperations db = do 281 | currentLevel <- RPC.currentLevel conf RPC.head 282 | let level = RPC.levelLevel currentLevel 283 | foldFirst db (fmap maybeFetchOperationsByLevel [(accountLastBlockScanned db + 1) .. level]) 284 | 285 | step databasePath db = 286 | case db of 287 | Nothing -> do 288 | T.putStrLn $ T.concat ["Creating new DB in file ", databasePath, "..."] 289 | step databasePath (Just $ DB M.empty) 290 | Just prev -> do 291 | foldFirst3 prev [maybeUpdateEstimates, maybeUpdateActual, maybePayout] 292 | 293 | loop = withDBLoop (T.unpack databasePath) (step databasePath) 294 | 295 | stepAccounts accountDatabasePath db = do 296 | mainDB <- mustReadDB (T.unpack databasePath) 297 | let loop db = 298 | case db of 299 | Nothing -> do 300 | T.putStrLn $ T.concat ["Creating new account DB in file ", accountDatabasePath, "..."] 301 | loop $ Just $ AccountDB (-1) [] [] [] [] M.empty 302 | Just prev -> do 303 | (res, updated) <- foldFirst prev [maybeFetchOperations, maybePayoutAccountsAndFetchEstimates mainDB, maybeUpdateTimestamps] 304 | if updated then loop (Just res) else return (res, ()) 305 | loop db 306 | 307 | loopAccounts path = withAccountDB (T.unpack path) (stepAccounts path) 308 | 309 | let go = do 310 | loop 311 | forM_ accountDatabasePath loopAccounts 312 | when continuous $ do 313 | threadDelay 10000000 314 | go 315 | 316 | go 317 | 318 | waitASecond :: IO () 319 | waitASecond = threadDelay (P.round (1e6 :: Double)) 320 | 321 | try' :: IO a -> IO (Either IOException a) 322 | try' = try 323 | 324 | foldFirst3 :: a -> [a -> IO (a, (Bool, IO ()))] -> IO (a, (Bool, IO ())) 325 | foldFirst3 obj [] = return (obj, (False, return ())) 326 | foldFirst3 obj (act:rest) = do 327 | (new, (updated, other)) <- act obj 328 | if updated then return (new, (updated, other)) else foldFirst3 obj rest 329 | 330 | foldFirst :: a -> [a -> IO (a, Bool)] -> IO (a, Bool) 331 | foldFirst obj [] = return (obj, False) 332 | foldFirst obj (act:rest) = do 333 | (new, updated) <- act obj 334 | if updated then return (new, updated) else foldFirst obj rest 335 | 336 | sign :: T.Text -> T.Text -> Maybe T.Text -> T.Text -> T.Text -> IO T.Text 337 | sign clientPath clientConfigFile fromPassword account what = do 338 | let args = ["-c", clientConfigFile, "sign", "bytes", "0x03" <> what, "for", account] 339 | asText <- do 340 | case fromPassword of 341 | Just pass -> do 342 | T.putStrLn $ T.concat ["Running '", T.intercalate " " (clientPath : args), "' in a pty"] 343 | (pty, handle) <- P.spawnWithPty Nothing True (T.unpack clientPath) (fmap T.unpack args) (80, 80) 344 | waitASecond 345 | P.threadWaitReadPty pty 346 | stderr <- P.readPty pty 347 | P.threadWaitWritePty pty 348 | P.writePty pty (B.pack $ T.unpack $ T.concat [pass, "\n"]) 349 | waitASecond 350 | code <- P.waitForProcess handle 351 | stdout <- P.readPty pty 352 | P.closePty pty 353 | if code /= ExitSuccess then do 354 | T.putStrLn $ T.concat ["Failure: ", T.pack $ P.show (code, stdout, stderr)] 355 | exitFailure 356 | else do 357 | let asText = T.pack $ B.unpack stdout 358 | return $ T.drop 13 $ T.take (T.length asText - 2) asText 359 | Nothing -> do 360 | T.putStrLn $ T.concat ["Running '", T.intercalate " " (clientPath : args), "' in a subprocess"] 361 | result <- try' $ P.createProcess (P.proc (T.unpack clientPath) (fmap T.unpack args)){ P.std_out = P.CreatePipe } 362 | case result of 363 | Left ex -> do 364 | T.putStrLn $ T.concat [ "Subprocess returned an exception: ", T.pack $ P.show ex ] 365 | exitFailure 366 | Right (_, Nothing , _, _) -> do 367 | T.putStrLn "Error: subprocess returned nothing" 368 | exitFailure 369 | Right (_, Just hout, _, _) -> do 370 | T.putStrLn "Success" 371 | asText <- T.hGetContents hout 372 | return $ T.drop 11 $ T.take (T.length asText - 1) asText 373 | T.putStrLn "> output of signature" 374 | T.putStrLn asText 375 | return asText 376 | -------------------------------------------------------------------------------- /default.nix: -------------------------------------------------------------------------------- 1 | { pkgs ? import {} 2 | }: 3 | 4 | let 5 | stack-pkgs = pkgs.callPackage ./nix {}; 6 | posix-pty = stack-pkgs.posix-pty.override (attrs: { util = null; }); 7 | backerei = stack-pkgs.backerei.override (attrs: { posix-pty = posix-pty;}); 8 | in 9 | backerei 10 | -------------------------------------------------------------------------------- /nix/update.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | set -euo pipefail 4 | 5 | cd "${BASH_SOURCE[0]%/*}" 6 | 7 | stack2nix=$(nix-build --no-out-link https://github.com/input-output-hk/stack2nix/archive/8b92e5d5861e609d723d56c2425d6571a2289d75.tar.gz) 8 | 9 | $stack2nix/bin/stack2nix -o default.nix ./.. 10 | rm -f ../backerei.cabal 11 | -------------------------------------------------------------------------------- /package.yaml: -------------------------------------------------------------------------------- 1 | name: backerei 2 | version: 0.1.0.0 3 | github: "cryptiumlabs/backerei" 4 | license: MIT 5 | author: "Cryptium Labs" 6 | maintainer: "cwgoes@cryptium.ch" 7 | copyright: "2018 Cryptium Labs" 8 | 9 | extra-source-files: 10 | - README.md 11 | 12 | # Metadata used when publishing your package 13 | # synopsis: Short description of your package 14 | # category: Web 15 | 16 | # To avoid duplicated efforts in documentation and dealing with the 17 | # complications of embedding Haddock markup inside cabal files, it is 18 | # common to point users to the README.md file. 19 | description: Please see the README on GitHub at 20 | 21 | dependencies: 22 | - base >= 4.7 && < 5 23 | - foundation 24 | - aeson 25 | - text 26 | - containers 27 | - bytestring 28 | - time 29 | 30 | default-extensions: 31 | - NoImplicitPrelude 32 | - OverloadedStrings 33 | - NoMonomorphismRestriction 34 | - RankNTypes 35 | - LambdaCase 36 | - UnicodeSyntax 37 | - GADTs 38 | - ScopedTypeVariables 39 | - DeriveGeneric 40 | - FlexibleContexts 41 | - FlexibleInstances 42 | - DataKinds 43 | - GeneralizedNewtypeDeriving 44 | - MultiWayIf 45 | 46 | ghc-options: 47 | - -ferror-spans 48 | - -Wall 49 | - -fno-warn-orphans 50 | - -fno-warn-name-shadowing 51 | 52 | library: 53 | source-dirs: src 54 | dependencies: 55 | - text 56 | - req 57 | - data-default-class 58 | - vector 59 | - base58string 60 | - base16-bytestring 61 | 62 | executables: 63 | backerei: 64 | main: Main.hs 65 | source-dirs: app 66 | ghc-options: 67 | - -threaded 68 | - -rtsopts 69 | - -with-rtsopts=-N 70 | dependencies: 71 | - backerei 72 | - gitrev 73 | - ansi-wl-pprint 74 | - optparse-applicative 75 | - directory 76 | - yaml 77 | - telegram-bot-simple 78 | - servant-client 79 | - process 80 | - aeson-pretty 81 | - posix-pty 82 | - atomic-write 83 | - hriemann 84 | 85 | tests: 86 | backerei-test: 87 | main: Spec.hs 88 | source-dirs: test 89 | ghc-options: 90 | - -threaded 91 | - -rtsopts 92 | - -with-rtsopts=-N 93 | dependencies: 94 | - backerei 95 | -------------------------------------------------------------------------------- /src/Backerei/Delegation.hs: -------------------------------------------------------------------------------- 1 | module Backerei.Delegation where 2 | 3 | import Control.Applicative 4 | import Control.Monad 5 | import Data.List (zip, delete) 6 | import qualified Data.Text as T 7 | import qualified Data.Text.IO as T 8 | import Foundation 9 | import qualified Prelude as P 10 | 11 | import qualified Backerei.RPC as RPC 12 | import Backerei.Types 13 | 14 | getContributingBalancesFor :: RPC.Config -> Int -> Int -> Int -> T.Text -> IO ([(T.Text, Tezzies)], Tezzies) 15 | getContributingBalancesFor config cycleLength snapshotInterval cycle delegate = do 16 | snapshotBlockHash <- snapshotHash config cycle cycleLength snapshotInterval 17 | delegators <- delete delegate <$> RPC.delegatedContracts config snapshotBlockHash delegate 18 | balances <- mapM (RPC.balanceAt config snapshotBlockHash) delegators 19 | fullBalance <- RPC.delegateBalanceAt config snapshotBlockHash delegate 20 | frozenByCycle <- RPC.frozenBalanceByCycle config snapshotBlockHash delegate 21 | let totalFrozenRewards = foldl' (P.+) 0 (fmap frozenRewards frozenByCycle) 22 | selfBalance = fullBalance P.- totalFrozenRewards 23 | stakingBalance <- RPC.stakingBalanceAt config snapshotBlockHash delegate 24 | when (selfBalance P.+ P.sum balances /= stakingBalance) $ error "should not happen" 25 | return (filter ((<) 0 . snd) ((delegate, selfBalance) : zip delegators balances), stakingBalance) 26 | 27 | snapshotHash :: RPC.Config -> Int -> Int -> Int -> IO T.Text 28 | snapshotHash config cycle cycleLength snapshotInterval = do 29 | hash <- hashToQuery config cycle cycleLength 30 | (CycleInfo _ snapshot) <- RPC.cycleInfo config hash cycle 31 | let blockHeight = snapshotHeight cycle snapshot cycleLength snapshotInterval 32 | blockHashByLevel config blockHeight 33 | 34 | snapshotLevel :: RPC.Config -> Int -> Int -> Int -> IO Int 35 | snapshotLevel config cycle cycleLength snapshotInterval = do 36 | hash <- hashToQuery config cycle cycleLength 37 | CycleInfo _ snapshot <- RPC.cycleInfo config hash cycle 38 | return $ snapshotHeight cycle snapshot cycleLength snapshotInterval 39 | 40 | hashToQuery :: RPC.Config -> Int -> Int -> IO T.Text 41 | hashToQuery config cycle cycleLength = do 42 | (BlockHeader hashHead levelHead _ _) <- RPC.header config RPC.head 43 | currentLevel <- RPC.currentLevel config hashHead 44 | let blocksAgo = cycleLength P.* (levelCycle currentLevel - cycle) 45 | levelToQuery = min (levelHead P.- blocksAgo) levelHead 46 | blockHashByLevel config levelToQuery 47 | 48 | snapshotHeight :: Int -> Int -> Int -> Int -> Int 49 | snapshotHeight cycle snapshot cycleLength snapshotInterval = (cycle - 7) * cycleLength + ((snapshot + 1) * snapshotInterval) 50 | 51 | lostBakingRewards :: RPC.Config -> Int -> Int -> T.Text -> IO Tezzies 52 | lostBakingRewards config cycleLength cycle delegate = do 53 | hash <- hashToQuery config cycle cycleLength 54 | bakingRights <- filter (\r -> bakingPriority r == 0) `fmap` RPC.bakingRightsFor config hash delegate cycle 55 | let bakingReward :: (P.Num a) => a 56 | bakingReward = 40 57 | actualRewards' <- flip mapM bakingRights $ \right -> do 58 | let level = bakingLevel right 59 | hash <- blockHashByLevel config level 60 | header <- RPC.header config hash 61 | metadata <- RPC.metadata config hash 62 | let priority = headerPriority header 63 | update:_ = filter (\u -> updateDelegate u == Just (metadataBaker metadata) && updateKind u == "freezer" && updateCategory u == Just "rewards") (metadataBalanceUpdates metadata) 64 | reward = if priority /= 0 then bakingReward else updateChange update 65 | return reward 66 | let expectedRewards :: Tezzies 67 | expectedRewards = 40 P.* (fromIntegral $ P.length bakingRights) 68 | actualRewards :: Tezzies 69 | actualRewards = P.sum actualRewards' 70 | T.putStrLn $ T.concat ["Expected / actual baking rewards (plus self-baked insurance) for cycle ", T.pack $ P.show cycle, ": ", T.pack $ P.show expectedRewards, " / ", T.pack $ P.show actualRewards] 71 | return (expectedRewards P.- actualRewards) 72 | 73 | lostEndorsementRewards :: RPC.Config -> Int -> Int -> T.Text -> IO Tezzies 74 | lostEndorsementRewards config cycleLength cycle delegate = do 75 | hash <- hashToQuery config cycle cycleLength 76 | endorsingRights <- RPC.endorsingRightsFor config hash delegate cycle 77 | let endorsingReward :: Tezzies 78 | endorsingReward = 40 P./ 32 79 | actualRewards' <- flip mapM endorsingRights $ \right -> do 80 | let level = endorsingLevel right 81 | hash <- blockHashByLevel config level 82 | header <- RPC.header config hash 83 | let baseReward = if headerPriority header == 0 then endorsingReward else (endorsingReward P.* 2 P./ 3) 84 | reward = baseReward P.* (fromIntegral $ P.length $ endorsingSlots right) 85 | return reward 86 | let expectedRewards :: Tezzies 87 | expectedRewards = endorsingReward P.* fromIntegral (P.sum $ fmap (P.length . endorsingSlots) endorsingRights) 88 | actualRewards :: Tezzies 89 | actualRewards = P.sum actualRewards' 90 | T.putStrLn $ T.concat ["Expected / actual endorsement rewards (plus self-baked insurance) for cycle ", T.pack $ P.show cycle, ": ", T.pack $ P.show expectedRewards, " / ", T.pack $ P.show actualRewards] 91 | return (expectedRewards P.- actualRewards) 92 | 93 | startingBlock :: Int -> Int -> Int 94 | startingBlock cycle cycleLength = (cycle * cycleLength) + 1 95 | 96 | endingBlock :: Int -> Int -> Int 97 | endingBlock cycle cycleLength = ((cycle + 1) * cycleLength) 98 | 99 | estimatedRewards :: RPC.Config -> Int -> Int -> T.Text -> IO Tezzies 100 | estimatedRewards config cycleLength cycle delegate = do 101 | hash <- hashToQuery config cycle cycleLength 102 | bakingRights <- filter ((==) 0 . bakingPriority) `fmap` RPC.bakingRightsFor config hash delegate cycle 103 | endorsingRights <- RPC.endorsingRightsFor config hash delegate cycle 104 | let bakingReward :: Tezzies 105 | bakingReward = 40 106 | endorsingReward :: Tezzies 107 | endorsingReward = 40 P./ 32 108 | totalReward :: Tezzies 109 | totalReward = (bakingReward P.* fromIntegral (P.length bakingRights)) P.+ (endorsingReward P.* fromIntegral (P.sum $ fmap (P.length . endorsingSlots) endorsingRights)) 110 | return totalReward 111 | 112 | blockHashByLevel :: RPC.Config -> Int -> IO T.Text 113 | blockHashByLevel config level = do 114 | (BlockHeader hashHead levelHead _ _) <- RPC.header config RPC.head 115 | (BlockHeader hash' level' _ _) <- RPC.header config (T.concat [hashHead, "~", T.pack $ P.show $ levelHead - level]) 116 | when (level /= level') $ error "should not happen: tezos rpc fault, wrong level" 117 | return hash' 118 | 119 | stolenBlocks :: RPC.Config -> Int -> Int -> T.Text -> IO [(Int, T.Text, Int, Tezzies, Tezzies)] 120 | stolenBlocks config cycleLength cycle delegate = do 121 | hash <- hashToQuery config cycle cycleLength 122 | bakingRights <- filter ((<) 0 . bakingPriority) `fmap` RPC.bakingRightsFor config hash delegate cycle 123 | mconcat `fmap` forM bakingRights (\(BakingRight _ priority _ level) -> do 124 | hash <- blockHashByLevel config level 125 | (BlockMetadata _ baker balanceUpdates) <- RPC.metadata config hash 126 | if baker /= delegate then return [] else do 127 | operations <- RPC.operations config hash 128 | let [update] = filter (\u -> updateKind u == "freezer" && updateCategory u == Just "rewards" && updateDelegate u == Just delegate) balanceUpdates 129 | reward = updateChange update 130 | fees = P.sum $ fmap (P.sum . fmap (fromMaybe 0 . opcontentsFee) . operationContents) operations 131 | return [(level, hash, priority, reward, fees)]) 132 | 133 | calculateRewardsFor :: RPC.Config -> Int -> Int -> Int -> T.Text -> Tezzies -> Rational -> IO ((Tezzies, Tezzies, Tezzies, Tezzies), [(T.Text, Tezzies, Tezzies)], Tezzies) 134 | calculateRewardsFor config cycleLength snapshotInterval cycle delegate rewards fee = do 135 | (balances, stakingBalance) <- getContributingBalancesFor config cycleLength snapshotInterval cycle delegate 136 | let totalBalance :: Tezzies 137 | totalBalance = P.sum $ fmap snd balances 138 | feeTz :: Tezzies 139 | feeTz = P.fromRational fee 140 | (_, bakerBalance) = P.head balances 141 | bakerSelfReward = bakerBalance P.* rewards P./ totalBalance 142 | bakerFeeReward = feeTz P.* rewards P.* (totalBalance P.- bakerBalance) P./ totalBalance 143 | delegatorRewards = (\(x, y) -> (x, y, y P.* (1 P.- feeTz) P.* rewards P./ totalBalance)) <$> drop 1 balances 144 | totalDelegatorRewards = P.sum (fmap (\(_, _, r) -> r) delegatorRewards) 145 | {- Leftover from fixed-precision floor rounding. -} 146 | bakerLooseReward = rewards P.- totalDelegatorRewards P.- bakerSelfReward P.- bakerFeeReward 147 | bakerTotalReward = bakerSelfReward P.+ bakerFeeReward P.+ bakerLooseReward 148 | bakerRewards = (bakerSelfReward, bakerFeeReward, bakerLooseReward, bakerTotalReward) 149 | when (bakerTotalReward P.+ totalDelegatorRewards /= rewards) $ error "should not happen: rewards mismatch" 150 | return (bakerRewards, delegatorRewards, stakingBalance) 151 | -------------------------------------------------------------------------------- /src/Backerei/RPC.hs: -------------------------------------------------------------------------------- 1 | module Backerei.RPC where 2 | 3 | import Control.Applicative 4 | import Control.Monad 5 | import qualified Data.Aeson as A 6 | import qualified Data.Base58String.Bitcoin as B 7 | import qualified Data.ByteString.Base16 as B 8 | import qualified Data.ByteString.Char8 as B 9 | import Data.Default.Class 10 | import qualified Data.Map as M 11 | import qualified Data.Text as T 12 | import qualified Data.Vector as V 13 | import Foundation hiding (head) 14 | import qualified Network.HTTP.Req as R 15 | import qualified Prelude as P 16 | 17 | import Backerei.Types 18 | 19 | data Config = Config { 20 | configHost :: T.Text, 21 | configPort :: Int 22 | } 23 | 24 | defaultConfig :: Config 25 | defaultConfig = Config "127.0.0.1" 8732 26 | 27 | head :: T.Text 28 | head = "head" 29 | 30 | currentLevel :: Config -> T.Text -> IO CurrentLevel 31 | currentLevel config hash = get config ["chains", "main", "blocks", hash, "helpers", "current_level"] mempty 32 | 33 | header :: Config -> T.Text -> IO BlockHeader 34 | header config hash = get config ["chains", "main", "blocks", hash, "header"] mempty 35 | 36 | metadata :: Config -> T.Text -> IO BlockMetadata 37 | metadata config hash = get config ["chains", "main", "blocks", hash, "metadata"] mempty 38 | 39 | operations :: Config -> T.Text -> IO [Operation] 40 | operations config hash = P.concat `fmap` (get config ["chains", "main", "blocks", hash, "operations"] mempty :: IO [[Operation]]) 41 | 42 | cycleInfo :: Config -> T.Text -> Int -> IO CycleInfo 43 | cycleInfo config hash cycle = get config ["chains", "main", "blocks", hash, "context", "raw", "json", "cycle", T.pack (P.show cycle)] mempty 44 | 45 | delegatedContracts :: Config -> T.Text -> T.Text -> IO [T.Text] 46 | delegatedContracts config hash delegate = get config ["chains", "main", "blocks", hash, "context", "delegates", delegate, "delegated_contracts"] mempty 47 | 48 | delegatedBalanceAt :: Config -> T.Text -> T.Text -> IO Tezzies 49 | delegatedBalanceAt config hash delegate = get config ["chains", "main", "blocks", hash, "context", "delegates", delegate, "delegated_balance"] mempty 50 | 51 | delegateBalanceAt :: Config -> T.Text -> T.Text -> IO Tezzies 52 | delegateBalanceAt config hash delegate = get config ["chains", "main", "blocks", hash, "context", "delegates", delegate, "balance"] mempty 53 | 54 | frozenBalanceAt :: Config -> T.Text -> T.Text -> IO Tezzies 55 | frozenBalanceAt config hash delegate = get config ["chains", "main", "blocks", hash, "context", "delegates", delegate, "frozen_balance"] mempty 56 | 57 | frozenBalanceByCycle :: Config -> T.Text -> T.Text -> IO [FrozenBalanceByCycle] 58 | frozenBalanceByCycle config hash delegate = get config ["chains", "main", "blocks", hash, "context", "delegates", delegate, "frozen_balance_by_cycle"] mempty 59 | 60 | totalFrozenRewardsAt :: Config -> T.Text -> T.Text -> IO Tezzies 61 | totalFrozenRewardsAt config hash delegate = do 62 | frozenByCycle <- frozenBalanceByCycle config hash delegate 63 | return $ P.sum $ fmap frozenRewards frozenByCycle 64 | 65 | frozenFeesForCycle :: Config -> T.Text -> T.Text -> Int -> IO Tezzies 66 | frozenFeesForCycle config hash delegate cycle = do 67 | frozenByCycle <- frozenBalanceByCycle config hash delegate 68 | return $ P.sum $ frozenFees <$> P.filter ((==) cycle . frozenCycle) frozenByCycle 69 | 70 | stakingBalanceAt :: Config -> T.Text -> T.Text -> IO Tezzies 71 | stakingBalanceAt config hash delegate = get config ["chains", "main", "blocks", hash, "context", "delegates", delegate, "staking_balance"] mempty 72 | 73 | balanceAt :: Config -> T.Text -> T.Text -> IO Tezzies 74 | balanceAt config hash contract = get config ["chains", "main", "blocks", hash, "context", "contracts", contract, "balance"] mempty 75 | 76 | counter :: Config -> T.Text -> T.Text -> IO Integer 77 | counter config hash contract = P.read `fmap` get config ["chains", "main", "blocks", hash, "context", "contracts", contract, "counter"] mempty 78 | 79 | managerKey :: Config -> T.Text -> T.Text -> IO (Maybe T.Text) 80 | managerKey config hash contract = get config ["chains", "main", "blocks", hash, "context", "contracts", contract, "manager_key"] mempty 81 | 82 | bakingRightsFor :: Config -> T.Text -> T.Text -> Int -> IO [BakingRight] 83 | bakingRightsFor config hash delegate cycle = get config ["chains", "main", "blocks", hash, "helpers", "baking_rights"] 84 | ("delegate" R.=: delegate <> "cycle" R.=: cycle) 85 | 86 | endorsingRightsFor :: Config -> T.Text -> T.Text -> Int -> IO [EndorsingRight] 87 | endorsingRightsFor config hash delegate cycle = get config ["chains", "main", "blocks", hash, "helpers", "endorsing_rights"] 88 | ("delegate" R.=: delegate <> "cycle" R.=: cycle) 89 | 90 | block :: Config -> T.Text -> IO A.Value 91 | block config hash = get config ["chains", "main", "blocks", hash] mempty 92 | 93 | blocks :: Config -> IO [[T.Text]] 94 | blocks config = get config ["chains", "main", "blocks"] mempty 95 | 96 | protocols :: Config -> IO [T.Text] 97 | protocols config = get config ["protocols"] mempty 98 | 99 | sendTezzies :: Config -> T.Text -> T.Text -> [(T.Text, Tezzies)] -> (T.Text -> T.Text -> IO T.Text) -> IO T.Text 100 | sendTezzies config from fromName dests sign = do 101 | currentCounter <- counter config head from 102 | let txns = fmap (\((dest, amount), counter) -> A.toJSON $ M.fromList [("kind" :: T.Text, A.String "transaction"), ("amount", A.toJSON amount), ("source", A.toJSON from), 103 | ("destination", A.String dest), ("storage_limit", A.String (if T.take 2 dest == "KT" then "4" else "0")), ("gas_limit", A.String (if T.take 2 dest == "KT" then "1000000" else "16000")), ("fee", A.toJSON $ Tezzies $ (if T.take 2 dest == "KT" then 0.1 else 0.002120)), ("counter", A.toJSON $ P.show counter)]) (P.zip dests [currentCounter + 1 ..]) 104 | (BlockHeader hashHead _ _ _) <- header config head 105 | (BlockMetadata protocolHead _ _) <- metadata config hashHead 106 | let fakeSignature = "edsigtXomBKi5CTRf5cjATJWSyaRvhfYNHqSUGrn4SdbYRcGwQrUGjzEfQDTuqHhuA8b2d8NarZjz8TRf65WkpQmo423BtomS8Q" :: T.Text 107 | runJSON = A.toJSON $ M.fromList [("operation" :: T.Text, A.toJSON $ M.fromList [("branch" :: T.Text, A.String hashHead), ("contents", A.toJSON txns), ("signature", A.toJSON fakeSignature)]), ("chain_id", A.String "NetXdQprcVkpaWU")] 108 | (RunResult contents) <- post config ["chains", "main", "blocks", head, "helpers", "scripts", "run_operation"] mempty runJSON 109 | let succeeded = P.filter ((==) "applied" . opresultStatus . (\(Just x) -> x) . opmetadataOperationResult . opcontentsMetadata) contents 110 | when (P.length succeeded /= P.length dests) $ error $ show ("simulation failure", P.filter ((/=) "applied" . opresultStatus . (\(Just x) -> x) . opmetadataOperationResult . opcontentsMetadata) contents) 111 | let signJSON = A.toJSON $ M.fromList [("branch" :: T.Text, A.String hashHead), ("contents", A.toJSON txns)] 112 | (bytes :: T.Text) <- post config ["chains", "main", "blocks", head, "helpers", "forge", "operations"] mempty signJSON 113 | signature <- sign fromName bytes 114 | let base16Signature = T.pack $ B.unpack $ B.encode $ B.toBytes $ B.fromText signature 115 | stripped = T.drop 10 $ T.take (T.length base16Signature - 8) base16Signature 116 | signedOperation = bytes <> stripped 117 | preapplyJSON = A.toJSON $ V.singleton $ M.fromList [("branch" :: T.Text, A.String hashHead), ("contents", A.toJSON txns), ("signature", A.toJSON signature), ("protocol", A.toJSON protocolHead)] 118 | (_ :: A.Value) <- post config ["chains", "main", "blocks", head, "helpers", "preapply", "operations"] mempty preapplyJSON 119 | post config ["injection", "operation"] mempty signedOperation 120 | 121 | get :: (A.FromJSON a) => Config -> [T.Text] -> R.Option 'R.Http -> IO a 122 | get config path options = R.runReq def $ do 123 | r <- R.req R.GET 124 | (foldl' (R./:) (R.http (configHost config)) path) 125 | R.NoReqBody 126 | R.jsonResponse 127 | (R.port (configPort config) <> R.responseTimeout 600000000 <> options) 128 | return (R.responseBody r) 129 | 130 | post :: (A.ToJSON a, A.FromJSON b) => Config -> [T.Text] -> R.Option 'R.Http -> a -> IO b 131 | post config path options value = R.runReq def $ do 132 | r <- R.req R.POST 133 | (foldl' (R./:) (R.http (configHost config)) path) 134 | (R.ReqBodyJson value) 135 | R.jsonResponse 136 | (R.port (configPort config) <> R.responseTimeout 600000000 <> R.header "Content-Type" "application/json" <> options) 137 | return (R.responseBody r) 138 | -------------------------------------------------------------------------------- /src/Backerei/Types.hs: -------------------------------------------------------------------------------- 1 | module Backerei.Types where 2 | 3 | import qualified Data.Aeson as A 4 | import qualified Data.Aeson.Types as A 5 | import Data.Char 6 | import Data.Fixed 7 | import Data.List (concatMap, zip) 8 | import qualified Data.Text as T 9 | import qualified Data.Time.Clock as C 10 | import Foundation 11 | import GHC.Generics 12 | import qualified Prelude as P 13 | 14 | fst3 :: (a, b, c) -> a 15 | fst3 (x, _, _) = x 16 | 17 | snd3 :: (a, b, c) -> b 18 | snd3 (_, y, _) = y 19 | 20 | thd3 :: (a, b, c) -> c 21 | thd3 (_, _, z) = z 22 | 23 | data XTZ 24 | 25 | instance HasResolution XTZ where 26 | resolution _ = 1000000 27 | 28 | newtype Tezzies = Tezzies { unTezzies :: Fixed XTZ } 29 | deriving (P.Read, P.Num, P.Real, P.RealFrac, P.Fractional, Eq, Ord, Generic) 30 | 31 | instance P.Show Tezzies where 32 | show = P.show . unTezzies 33 | 34 | instance A.FromJSON Tezzies where 35 | parseJSON val = do 36 | result <- A.parseJSON val 37 | let tez = P.read result :: Integer 38 | return (Tezzies (fromIntegral tez P./ 1000000)) 39 | 40 | instance A.ToJSON Tezzies where 41 | toJSON (Tezzies (MkFixed t)) = A.toJSON $ T.pack $ P.show t 42 | 43 | data BlockHeader = BlockHeader { 44 | headerHash :: T.Text, 45 | headerLevel :: Int, 46 | headerPriority :: Int, 47 | headerTimestamp :: C.UTCTime 48 | } deriving (Generic, Show) 49 | 50 | data BlockMetadata = BlockMetadata { 51 | metadataProtocol :: T.Text, 52 | metadataBaker :: T.Text, 53 | metadataBalanceUpdates :: [BalanceUpdate] 54 | } deriving (Generic, Show) 55 | 56 | data BalanceUpdate = BalanceUpdate { 57 | updateKind :: T.Text, 58 | updateCategory :: Maybe T.Text, 59 | updateContract :: Maybe T.Text, 60 | updateDelegate :: Maybe T.Text, 61 | updateLevel :: Maybe Int, 62 | updateChange :: Tezzies 63 | } deriving (Generic, Show) 64 | 65 | data EndorsingRight = EndorsingRight { 66 | endorsingSlots :: [Int], 67 | endorsingDelegate :: T.Text, 68 | endorsingEstimatedTime :: Maybe C.UTCTime, 69 | endorsingLevel :: Int 70 | } deriving (Generic, Show) 71 | 72 | data BakingRight = BakingRight { 73 | bakingDelegate :: T.Text, 74 | bakingPriority :: Int, 75 | bakingEstimatedTime :: Maybe C.UTCTime, 76 | bakingLevel :: Int 77 | } deriving (Generic, Show) 78 | 79 | data CurrentLevel = CurrentLevel { 80 | levelVotingPeriod :: Int, 81 | levelExpectedCommitment :: Bool, 82 | levelLevelPosition :: Int, 83 | levelCyclePosition :: Int, 84 | levelCycle :: Int, 85 | levelLevel :: Int, 86 | levelVotingPeriodPosition :: Int 87 | } deriving (Generic, Show) 88 | 89 | data CycleInfo = CycleInfo { 90 | cycleinfoRandomSeed :: T.Text, 91 | cycleinfoRollSnapshot :: Int 92 | } deriving (Generic, Show) 93 | 94 | newtype RunResult = RunResult { 95 | runresultContents :: [OperationContents] 96 | } deriving (Generic, Show) 97 | 98 | data Operation = Operation { 99 | operationHash :: T.Text, 100 | operationProtocol :: T.Text, 101 | operationBranch :: T.Text, 102 | operationContents :: [OperationContents] 103 | } deriving (Generic, Show) 104 | 105 | data OperationContents = OperationContents { 106 | opcontentsKind :: T.Text, 107 | opcontentsFee :: Maybe Tezzies, 108 | opcontentsLevel :: Maybe Int, 109 | opcontentsMetadata :: OperationMetadata, 110 | opcontentsSource :: Maybe T.Text, 111 | opcontentsDestination :: Maybe T.Text, 112 | opcontentsAmount :: Maybe Tezzies 113 | } deriving (Generic, Show) 114 | 115 | data OperationMetadata = OperationMetadata { 116 | opmetadataDelegate :: Maybe T.Text, 117 | opmetadataOperationResult :: Maybe OperationResult 118 | } deriving (Generic, Show) 119 | 120 | data OperationResult = OperationResult { 121 | opresultStatus :: T.Text, 122 | opresultConsumedGas :: Maybe T.Text 123 | } deriving (Generic, Show) 124 | 125 | data FrozenBalanceByCycle = FrozenBalanceByCycle { 126 | frozenCycle :: Int, 127 | frozenDeposit :: Tezzies, 128 | frozenFees :: Tezzies, 129 | frozenRewards :: Tezzies 130 | } deriving (Generic, Show) 131 | 132 | instance A.FromJSON BlockHeader where 133 | parseJSON = customParseJSON 134 | 135 | instance A.FromJSON BlockMetadata where 136 | parseJSON = customParseJSON 137 | 138 | instance A.FromJSON EndorsingRight where 139 | parseJSON = customParseJSON 140 | 141 | instance A.FromJSON BakingRight where 142 | parseJSON = customParseJSON 143 | 144 | instance A.FromJSON CurrentLevel where 145 | parseJSON = customParseJSON 146 | 147 | instance A.FromJSON CycleInfo where 148 | parseJSON = customParseJSON 149 | 150 | instance A.FromJSON RunResult where 151 | parseJSON = customParseJSON 152 | 153 | instance A.FromJSON Operation where 154 | parseJSON = customParseJSON 155 | 156 | instance A.FromJSON OperationContents where 157 | parseJSON = customParseJSON 158 | 159 | instance A.FromJSON OperationMetadata where 160 | parseJSON = customParseJSON 161 | 162 | instance A.FromJSON OperationResult where 163 | parseJSON = customParseJSON 164 | 165 | instance A.FromJSON FrozenBalanceByCycle where 166 | parseJSON = customParseJSON 167 | 168 | instance A.FromJSON BalanceUpdate where 169 | parseJSON = customParseJSON 170 | 171 | jsonOptions ∷ A.Options 172 | jsonOptions = A.defaultOptions { 173 | A.fieldLabelModifier = concatMap (\(i, c) -> if i > (0 :: Int) && isUpper c then ['_', toLower c] else [toLower c]) . zip [0..] . dropWhile isLower, 174 | A.constructorTagModifier = \(x:xs) -> toLower x : xs, 175 | A.omitNothingFields = True, 176 | A.sumEncoding = A.ObjectWithSingleField 177 | } 178 | 179 | customParseJSON :: (Generic a, A.GFromJSON A.Zero (Rep a)) => A.Value -> A.Parser a 180 | customParseJSON = A.genericParseJSON jsonOptions 181 | 182 | customToJSON :: (Generic a, A.GToJSON A.Zero (Rep a)) => a -> A.Value 183 | customToJSON = A.genericToJSON jsonOptions 184 | 185 | customToEncoding :: (Generic a, A.GToEncoding A.Zero (Rep a)) => a -> A.Encoding 186 | customToEncoding = A.genericToEncoding jsonOptions 187 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-12.17 2 | packages: 3 | - . 4 | extra-deps: 5 | - posix-pty-0.2.1.1 6 | - git: https://github.com/shmish111/hriemann.git 7 | commit: 9526dbc0b07ea37f37f4753177390df10385fe83 8 | - kazura-queue-0.1.0.4@sha256:24c26a38b98c49c6f6448410e8d7499c88be423bba75a204a7f9a8155c5cda41 9 | - unagi-chan-0.4.1.0@sha256:97e08dd9a73462ca284bfd2f904cd471c94e1207c2dd79a59efcc8fe2c93de41 10 | -------------------------------------------------------------------------------- /stack.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/lock_files 5 | 6 | packages: 7 | - completed: 8 | hackage: posix-pty-0.2.1.1@sha256:f1e54f10c49d9f27dba33539391659d2daa4874badc1554ffc6c25b329ef1db6,2161 9 | pantry-tree: 10 | size: 512 11 | sha256: d8901f7c8c42c767092262da42e1ff1911151310f4cd87f1ee278d168121ecee 12 | original: 13 | hackage: posix-pty-0.2.1.1 14 | - completed: 15 | cabal-file: 16 | size: 2546 17 | sha256: 6dffb38e777f9c05495c027b49f15465a18433fbd4f52f6948a817471bc2d26e 18 | name: hriemann 19 | version: 0.3.3.0 20 | git: https://github.com/shmish111/hriemann.git 21 | pantry-tree: 22 | size: 1839 23 | sha256: 3c0e810ae4bb6a25512850cac2d3fd1960384c1cab9d4058351fec6a38de9453 24 | commit: 9526dbc0b07ea37f37f4753177390df10385fe83 25 | original: 26 | git: https://github.com/shmish111/hriemann.git 27 | commit: 9526dbc0b07ea37f37f4753177390df10385fe83 28 | - completed: 29 | hackage: kazura-queue-0.1.0.4@sha256:24c26a38b98c49c6f6448410e8d7499c88be423bba75a204a7f9a8155c5cda41,3919 30 | pantry-tree: 31 | size: 1155 32 | sha256: 0817eb2f335b25a3199f0355035bd95f7daf305124cbc60f50a6c444fbd21334 33 | original: 34 | hackage: kazura-queue-0.1.0.4@sha256:24c26a38b98c49c6f6448410e8d7499c88be423bba75a204a7f9a8155c5cda41 35 | - completed: 36 | hackage: unagi-chan-0.4.1.0@sha256:97e08dd9a73462ca284bfd2f904cd471c94e1207c2dd79a59efcc8fe2c93de41,8641 37 | pantry-tree: 38 | size: 2286 39 | sha256: b39bee11a36a4f9c2bee3a2acc5e1a5052d554601354c1164d81b3b26a15a735 40 | original: 41 | hackage: unagi-chan-0.4.1.0@sha256:97e08dd9a73462ca284bfd2f904cd471c94e1207c2dd79a59efcc8fe2c93de41 42 | snapshots: 43 | - completed: 44 | size: 506303 45 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/12/17.yaml 46 | sha256: ec50e106d49dfb3a709ee9d2c744c941df9848c5559c5f2ca8ca41d4126e2554 47 | original: lts-12.17 48 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | import Foundation 2 | 3 | main ∷ IO () 4 | main = putStrLn "Test suite not yet implemented" 5 | --------------------------------------------------------------------------------