haskell-opentimestamps (empty) → 0.5.5.0

raw patch · 57 files changed

+3763/−0 lines, 57 filesdep +QuickCheckdep +aesondep +basebinary-added

Dependencies added: QuickCheck, aeson, base, base16-bytestring, binary, bitcoind-rpc, bytes, bytestring, cereal, containers, cryptonite, directory, filepath, haskell-opentimestamps, haskoin-core, hspec, http-client, http-conduit, memory, mtl, process, random, servant, text, time

Files

CHANGELOG.md +29/−0
LICENSE +217/−0
Makefile +69/−0
README.md +16/−0
cabal.project +19/−0
cabal.project.freeze +231/−0
examples/README.md +8/−0
examples/bad-stamp.txt +2/−0
examples/bad-stamp.txt.ots binary
examples/bitcoin.pdf.ots binary
examples/different-blockchains.txt +1/−0
examples/different-blockchains.txt.ots binary
examples/empty +0/−0
examples/empty.ots binary
examples/hello-world.txt +1/−0
examples/hello-world.txt.ots binary
examples/incomplete.txt +1/−0
examples/incomplete.txt.ots binary
examples/invalid/README.md +3/−0
examples/invalid/bad-major-version.ots binary
examples/invalid/exceeds-max-msg-length.ots binary
examples/invalid/invalid-file-digest-type.ots binary
examples/known-and-unknown-notary.txt +2/−0
examples/known-and-unknown-notary.txt.ots binary
examples/merkle1.txt +2/−0
examples/merkle1.txt.ots binary
examples/merkle2.txt +2/−0
examples/merkle2.txt.ots binary
examples/merkle3.txt +2/−0
examples/merkle3.txt.ots binary
examples/sha1/README.md +21/−0
examples/sha1/a binary
examples/sha1/a-or-b.ots binary
examples/sha1/b binary
examples/two-calendars.txt +1/−0
examples/two-calendars.txt.ots binary
examples/unknown-notary.txt +1/−0
examples/unknown-notary.txt.ots binary
haskell-opentimestamps.cabal +134/−0
package.yaml +132/−0
src/OpenTimestamps.hs +150/−0
src/OpenTimestamps/Attestation.hs +104/−0
src/OpenTimestamps/Config.hs +73/−0
src/OpenTimestamps/DetachedTimestampFile.hs +138/−0
src/OpenTimestamps/Op.hs +101/−0
src/OpenTimestamps/Prune.hs +167/−0
src/OpenTimestamps/Stamp.hs +173/−0
src/OpenTimestamps/Timestamp.hs +379/−0
src/OpenTimestamps/Types.hs +19/−0
src/OpenTimestamps/Upgrade.hs +213/−0
src/OpenTimestamps/VarInt.hs +64/−0
src/OpenTimestamps/Verify.hs +219/−0
test/Arbitrary.hs +132/−0
test/PruneSpec.hs +252/−0
test/Spec.hs +474/−0
test/UpgradeSpec.hs +103/−0
test/VerifySpec.hs +108/−0

+ CHANGELOG.md view

@@ -0,0 +1,29 @@+0.1.0.0, released 2025-09-04+    Initial version (work in progress)++0.2.0.0, released 2025-09-12+    Removed umbrella project (this library is now standalone)++0.3.0.0, released 2025-09-12+    Updated version in package.yaml++0.4.0.0, released 2025-09-17+    Updated version USER-AGENT too.++0.5.0.0, released 2025-11-27+    Add haddock comments++0.5.1.0, released 2025-11-27+    Add haddock module headers++0.5.2.0, released 2025-11-28+    Add package upper bounds++0.5.3.0, released 2025-11-28+    Revise README++0.5.4.0, released 2025-11-28+    Add notes on tests++0.5.5.0, released 2025-11-28+    Bump cabal freeze

+ LICENSE view

@@ -0,0 +1,217 @@+Copyright A.H.M. (Mari) Donkers 2025.++Licensed under either of:++* BSD-3-Clause license (https://opensource.org/licenses/BSD-3-Clause)+* Apache License, version 2.0 (https://opensource.org/licenses/Apache-2.0)++As a user, you may use this code under either license, at your option.+++---------------------------------------------------------------------+BSD 3-Clause License+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Neil Mitchell nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+++---------------------------------------------------------------------+Apache License+Version 2.0, January 2004+<http://www.apache.org/licenses/>++Terms and Conditions for use, reproduction, and distribution+1. Definitions+"License" shall mean the terms and conditions for use, reproduction,+and distribution as defined by Sections 1 through 9 of this document.++"Licensor" shall mean the copyright owner or entity authorized by the+copyright owner that is granting the License.++"Legal Entity" shall mean the union of the acting entity and all+other entities that control, are controlled by, or are under common+control with that entity. For the purposes of this definition,+"control" means (i) the power, direct or indirect, to cause the+direction or management of such entity, whether by contract or+otherwise, or (ii) ownership of fifty percent (50%) or more of the+outstanding shares, or (iii) beneficial ownership of such entity.++"You" (or "Your") shall mean an individual or Legal Entity exercising+permissions granted by this License.++"Source" form shall mean the preferred form for making modifications,+including but not limited to software source code, documentation+source, and configuration files.++"Object" form shall mean any form resulting from mechanical+transformation or translation of a Source form, including but not+limited to compiled object code, generated documentation, and+conversions to other media types.++"Work" shall mean the work of authorship, whether in Source or Object+form, made available under the License, as indicated by a copyright+notice that is included in or attached to the work).++"Derivative Works" shall mean any work, whether in Source or Object+form, that is based on (or derived from) the Work and for which the+editorial revisions, annotations, elaborations, or other+modifications represent, as a whole, an original work of authorship.+For the purposes of this License, Derivative Works shall not include+works that remain separable from, or merely link (or bind by name) to+the interfaces of, the Work and Derivative Works thereof.++"Contribution" shall mean any work of authorship, including the+original version of the Work and any modifications or additions to+that Work or Derivative Works thereof, that is intentionally+submitted to Licensor for inclusion in the Work by the copyright+owner or by an individual or Legal Entity authorized to submit on+behalf of the copyright owner. For the purposes of this definition,+"submitted" means any form of electronic, verbal, or written+communication sent to the Licensor or its representatives, including+but not limited to communication on electronic mailing lists, source+code control systems, and issue tracking systems that are managed by,+or on behalf of, the Licensor for the purpose of discussing and+improving the Work, but excluding communication that is conspicuously+marked or otherwise designated in writing by the copyright owner as+"Not a Contribution."++"Contributor" shall mean Licensor and any individual or Legal Entity+on behalf of whom a Contribution has been received by Licensor and+subsequently incorporated within the Work.++2. Grant of Copyright License+Subject to the terms and conditions of this License, each Contributor+hereby grants to You a perpetual, worldwide, non-exclusive,+no-charge, royalty-free, irrevocable copyright license to reproduce,+prepare Derivative Works of, publicly display, publicly perform,+sublicense, and distribute the Work and such Derivative Works in+Source or Object form.++3. Grant of Patent License+Subject to the terms and conditions of this License, each Contributor+hereby grants to You a perpetual, worldwide, non-exclusive,+no-charge, royalty-free, irrevocable (except as stated in this+section) patent license to make, have made, use, offer to sell, sell,+import, and otherwise transfer the Work, where such license applies+only to those patent claims licensable by such Contributor that are+necessarily infringed by their Contribution(s) alone or by+combination of their Contribution(s) with the Work to which such+Contribution(s) was submitted. If You institute patent litigation+against any entity (including a cross-claim or counterclaim in a+lawsuit) alleging that the Work or a Contribution incorporated within+the Work constitutes direct or contributory patent infringement, then+any patent licenses granted to You under this License for that Work+shall terminate as of the date such litigation is filed.++4. Redistribution+You may reproduce and distribute copies of the Work or Derivative+Works thereof in any medium, with or without modifications, and in+Source or Object form, provided that You meet the following+conditions:++(a) You must give any other recipients of the Work or Derivative+Works a copy of this License; and+(b) You must cause any modified files to carry prominent notices+stating that You changed the files; and+(c) You must retain, in the Source form of any Derivative Works that+You distribute, all copyright, patent, trademark, and attribution+notices from the Source form of the Work, excluding those notices+that do not pertain to any part of the Derivative Works; and+(d) If the Work includes a "NOTICE" text file as part of its+distribution, then any Derivative Works that You distribute must+include a readable copy of the attribution notices contained within+such NOTICE file, excluding those notices that do not pertain to any+part of the Derivative Works, in at least one of the following+places: within a NOTICE text file distributed as part of the+Derivative Works; within the Source form or documentation, if+provided along with the Derivative Works; or, within a display+generated by the Derivative Works, if and wherever such third-party+notices normally appear. The contents of the NOTICE file are for+informational purposes only and do not modify the License. You may+add Your own attribution notices within Derivative Works that You+distribute, alongside or as an addendum to the NOTICE text from the+Work, provided that such additional attribution notices cannot be+construed as modifying the License.+You may add Your own copyright statement to Your modifications and+may provide additional or different license terms and conditions for+use, reproduction, or distribution of Your modifications, or for any+such Derivative Works as a whole, provided Your use, reproduction,+and distribution of the Work otherwise complies with the conditions+stated in this License.++5. Submission of Contributions+Unless You explicitly state otherwise, any Contribution intentionally+submitted for inclusion in the Work by You to the Licensor shall be+under the terms and conditions of this License, without any+additional terms or conditions. Notwithstanding the above, nothing+herein shall supersede or modify the terms of any separate license+agreement you may have executed with Licensor regarding such+Contributions.++6. Trademarks+This License does not grant permission to use the trade names,+trademarks, service marks, or product names of the Licensor, except+as required for reasonable and customary use in describing the origin+of the Work and reproducing the content of the NOTICE file.++7. Disclaimer of Warranty+Unless required by applicable law or agreed to in writing, Licensor+provides the Work (and each Contributor provides its Contributions)+on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND,+either express or implied, including, without limitation, any+warranties or conditions of TITLE, NON-INFRINGEMENT, MERCHANTABILITY,+or FITNESS FOR A PARTICULAR PURPOSE. You are solely responsible for+determining the appropriateness of using or redistributing the Work+and assume any risks associated with Your exercise of permissions+under this License.++8. Limitation of Liability+In no event and under no legal theory, whether in tort (including+negligence), contract, or otherwise, unless required by applicable+law (such as deliberate and grossly negligent acts) or agreed to in+writing, shall any Contributor be liable to You for damages,+including any direct, indirect, special, incidental, or consequential+damages of any character arising as a result of this License or out+of the use or inability to use the Work (including but not limited to+damages for loss of goodwill, work stoppage, computer failure or+malfunction, or any and all other commercial damages or losses), even+if such Contributor has been advised of the possibility of such+damages.++9. Accepting Warranty or Additional Liability+While redistributing the Work or Derivative Works thereof, You may+choose to offer, and charge a fee for, acceptance of support,+warranty, indemnity, or other liability obligations and/or rights+consistent with this License. However, in accepting such obligations,+You may act only on Your own behalf and on Your sole responsibility,+not on behalf of any other Contributor, and only if You agree to+indemnify, defend, and hold each Contributor harmless for any+liability incurred by, or claims asserted against, such Contributor+by reason of your accepting any such warranty or additional+liability.

+ Makefile view

@@ -0,0 +1,69 @@+PROJECT=haskell-opentimestamps++.PHONY: help+help: ## print make targets+	@grep -E '^[a-zA-Z_-]+:.*?## .*$$' $(MAKEFILE_LIST) | sort | awk 'BEGIN {FS = ":.*?## "}; {printf "\033[36m%-30s\033[0m %s\n", $$1, $$2}'++package: package.yaml+	hpack++.PHONY: freeze+freeze:  ## Freeze dependencies+	cabal freeze++.PHONY: clean+clean:   ## Clean project+	cabal clean++.PHONY: build+build:  package ## Build project+	cabal build --enable-tests++.PHONY: repl+repl:   package ## Repl with project pre-loaded+	cabal repl $(PROJECT)++.PHONY: format+format:   ## Format Haskell source code+	fourmolu -i `ag -l --haskell`++.PHONY: lint+lint:   ## Lint Haskell source code+	hlint `ag -l --haskell`++.PHONY: ls+ls:     ## get path of executable+	cabal ls-bin $(PROJECT)++.PHONY: run+run:    package ## run the project with cabal+	cabal run++.PHONY: test+test:   package ## runs the unit test project+	cabal test $(PROJECT)-test --enable-tests --test-show-details=direct++.PHONY: check+check:  ## runs cabal check+	cabal check++.PHONY: sdist+sdist:  ## generate a distribution tarball+	cabal sdist++# HOOGLE="http://localhost:4040" emacs &+.PHONY: edit+edit:   ## Start editor+	emacs &++# https://blog.ssanj.net/posts/2019-10-19-running-hoogle-locally-for-haskell-dev.html+.PHONY: hoogledb+hoogledb: ## Create local Hoogle database+	cabal-hoogle generate+	# stack hoogle -- generate --local++# https://blog.ssanj.net/posts/2019-10-19-running-hoogle-locally-for-haskell-dev.html+.PHONY: hoogle+hoogle: ## Run local Hoogle server+	cabal-hoogle run -- server --local --port 4040+	# stack hoogle -- server --local --port=4040

+ README.md view

@@ -0,0 +1,16 @@+This is a Haskell library for working with OpenTimestamps. OpenTimestamps is a protocol for creating and verifying timestamps for digital files, which can be used to prove that a file existed at a certain point in time.++The library provides functionality for:++*   **Stamping:** Creating new timestamps for files by submitting their hashes to a network of calendar servers.+*   **Information:** Extracting information from timestamp files.+*   **Pruning:** Pruning existing timestamps.+*   **Upgrading:** Upgrade remote calendar timestamps to be locally verifiable.+*   **Verification:** Verifying the integrity and validity of existing timestamps.++The project has a number of dependencies, including `cryptonite` for cryptographic operations, `http-client` for making requests to calendar servers and `haskoin-code` and `bitcoin-rpc` to make RPC-calls to a locally running 'blocksonly' pruned Bitcoin node, which is required for **Verification**.++Also you will need to have a `libsecp256k1` package (Debian: `libsecp256k1-dev`) installed on your Linux distribution (beware: it needs to be < 0.7.x because of deprecated functions in `0.7.x`).++Notes on tests:+* At least one of the tests requires a running local bitcoin node (pruned node is fine).

+ cabal.project view

@@ -0,0 +1,19 @@+packages: .++-- source-repository-package+--   type: git+--   location: https://github.com/jprupp/haskoin-core+--   branch: master++source-repository-package+  type: git+  location: https://github.com/bitnomial/bitcoin-compact-filters+  -- branch: master+  tag: 7ae4d9bec8a5275db579e34e3cadb86c0f0461e9++source-repository-package+  type: git+  location: https://github.com/bitnomial/bitcoind-rpc+  -- branch: master+  tag: 16d664e05c232800aa6bc4f63c372c6f3e0e5d39+  subdir: bitcoind-rpc

+ cabal.project.freeze view

@@ -0,0 +1,231 @@+active-repositories: hackage.haskell.org:merge+constraints: any.Cabal ==3.10.3.0,+             any.Cabal-syntax ==3.10.3.0,+             any.HUnit ==1.6.2.0,+             any.OneTuple ==0.4.2,+             any.QuickCheck ==2.16.0.0,+             QuickCheck -old-random +templatehaskell,+             any.StateVar ==1.2.2,+             any.adjunctions ==4.4.3,+             any.aeson ==2.2.3.0,+             aeson +ordered-keymap,+             any.ansi-terminal ==1.1.3,+             ansi-terminal -example,+             any.ansi-terminal-types ==1.1.3,+             any.appar ==0.1.8,+             any.array ==0.5.8.0,+             any.asn1-encoding ==0.9.6,+             any.asn1-parse ==0.9.5,+             any.asn1-types ==0.3.4,+             any.assoc ==1.1.1,+             assoc -tagged,+             any.async ==2.2.5,+             async -bench,+             any.attoparsec ==0.14.4,+             attoparsec -developer,+             any.attoparsec-aeson ==2.2.2.0,+             any.base ==4.18.3.0,+             any.base-compat ==0.14.1,+             any.base-orphans ==0.9.3,+             any.base16 ==1.0,+             any.base16-bytestring ==1.0.2.0,+             any.base64 ==1.0,+             any.base64-bytestring ==1.2.1.0,+             any.basement ==0.0.16,+             any.bifunctors ==5.6.2,+             bifunctors +tagged,+             any.binary ==0.8.9.1,+             any.binary-orphans ==1.0.5,+             any.bitcoin-compact-filters ==0.1.1,+             any.bitcoind-rpc ==0.3.1.0,+             any.bitvec ==1.1.5.0,+             bitvec +simd,+             any.blaze-builder ==0.4.4.1,+             any.boring ==0.2.2,+             boring +tagged,+             any.byteorder ==1.0.4,+             any.bytes ==0.17.4,+             any.bytestring ==0.11.5.4,+             any.call-stack ==0.4.0,+             any.case-insensitive ==1.2.1.0,+             any.cborg ==0.2.10.0,+             cborg +optimize-gmp,+             any.cereal ==0.5.8.3,+             cereal -bytestring-builder,+             any.character-ps ==0.1,+             any.colour ==2.3.6,+             any.comonad ==5.0.9,+             comonad +containers +distributive +indexed-traversable,+             any.conduit ==1.3.6.1,+             any.conduit-extra ==1.3.8,+             any.constraints ==0.14.2,+             any.containers ==0.6.7,+             any.contravariant ==1.5.5,+             contravariant +semigroups +statevar +tagged,+             any.cookie ==0.5.1,+             any.crypton ==1.0.4,+             crypton -check_alignment +integer-gmp -old_toolchain_inliner +support_aesni +support_deepseq +support_pclmuldq +support_rdrand -support_sse +use_target_attributes,+             any.crypton-connection ==0.4.5,+             any.crypton-socks ==0.6.2,+             crypton-socks -example +network-3-0-0-0,+             any.crypton-x509 ==1.7.7,+             any.crypton-x509-store ==1.6.12,+             any.crypton-x509-system ==1.6.7,+             any.crypton-x509-validation ==1.6.14,+             any.cryptonite ==0.30,+             cryptonite -check_alignment +integer-gmp -old_toolchain_inliner +support_aesni +support_deepseq -support_pclmuldq +support_rdrand -support_sse +use_target_attributes,+             any.data-default ==0.8.0.1,+             any.data-default-class ==0.2.0.0,+             any.data-fix ==0.3.4,+             any.dec ==0.0.6,+             any.deepseq ==1.4.8.1,+             any.directory ==1.3.8.5,+             any.distributive ==0.6.2.1,+             distributive +semigroups +tagged,+             any.dlist ==1.0,+             dlist -werror,+             any.ech-config ==0.0.1,+             ech-config -devel,+             any.entropy ==0.4.1.11,+             entropy -donotgetentropy,+             any.exceptions ==0.10.7,+             any.filepath ==1.4.301.0,+             any.free ==5.2,+             any.generically ==0.1.1,+             any.generics-sop ==0.5.1.4,+             any.ghc-bignum ==1.3,+             any.ghc-boot-th ==9.6.7,+             any.ghc-prim ==0.10.0,+             any.half ==0.3.3,+             any.hashable ==1.5.0.0,+             hashable -arch-native -random-initial-seed,+             any.haskell-lexer ==1.2.1,+             any.haskoin-core ==1.2.2,+             any.hourglass ==0.2.12,+             any.hpke ==0.0.0,+             any.hsc2hs ==0.68.10,+             hsc2hs -in-ghc-tree,+             any.hspec ==2.11.14,+             any.hspec-core ==2.11.14,+             any.hspec-discover ==2.11.14,+             any.hspec-expectations ==0.8.4,+             any.http-api-data ==0.6.2,+             http-api-data -use-text-show,+             any.http-client ==0.7.19,+             http-client +network-uri,+             any.http-client-tls ==0.3.6.4,+             any.http-conduit ==2.3.9.1,+             http-conduit +aeson,+             any.http-media ==0.8.1.1,+             any.http-types ==0.12.4,+             any.indexed-traversable ==0.1.4,+             any.indexed-traversable-instances ==0.1.2,+             any.integer-conversion ==0.1.1,+             any.integer-gmp ==1.1,+             any.integer-logarithms ==1.0.4,+             integer-logarithms -check-bounds +integer-gmp,+             any.invariant ==0.6.4,+             any.iproute ==1.7.15,+             any.kan-extensions ==5.2.7,+             any.memory ==0.18.0,+             memory +support_bytestring +support_deepseq,+             any.mime-types ==0.1.2.0,+             any.mmorph ==1.2.1,+             any.monad-control ==1.0.3.1,+             any.mono-traversable ==1.0.21.0,+             any.mtl ==2.3.1,+             any.murmur3 ==1.0.6,+             any.network ==3.2.8.0,+             network -devel,+             any.network-byte-order ==0.1.7,+             any.network-uri ==2.6.4.2,+             any.old-locale ==1.0.0.7,+             any.old-time ==1.1.0.4,+             any.optparse-applicative ==0.19.0.0,+             optparse-applicative +process,+             any.os-string ==2.0.8,+             any.parsec ==3.1.16.1,+             any.pem ==0.2.4,+             any.pretty ==1.1.3.6,+             any.prettyprinter ==1.7.1,+             prettyprinter -buildreadme +text,+             any.prettyprinter-ansi-terminal ==1.1.3,+             any.primitive ==0.9.1.0,+             any.process ==1.6.19.0,+             any.profunctors ==5.6.3,+             any.quickcheck-io ==0.2.0,+             any.random ==1.3.1,+             any.resourcet ==1.3.0,+             any.rts ==1.0.2,+             any.safe ==0.3.21,+             any.scientific ==0.3.8.0,+             scientific -integer-simple,+             any.secp256k1-haskell ==1.4.6,+             any.semialign ==1.3.1,+             semialign +semigroupoids,+             any.semigroupoids ==6.0.1,+             semigroupoids +comonad +containers +contravariant +distributive +tagged +unordered-containers,+             any.semigroups ==0.20,+             semigroups +binary +bytestring -bytestring-builder +containers +deepseq +hashable +tagged +template-haskell +text +transformers +unordered-containers,+             any.serialise ==0.2.6.1,+             serialise +newtime15,+             any.servant ==0.20.3.0,+             any.servant-client ==0.20.3.0,+             any.servant-client-core ==0.20.3.0,+             any.servant-jsonrpc ==1.2.0,+             any.servant-jsonrpc-client ==1.2.0,+             any.singleton-bool ==0.1.8,+             any.some ==1.0.6,+             some +newtype-unsafe,+             any.sop-core ==0.5.0.2,+             any.split ==0.2.5,+             any.splitmix ==0.1.3.1,+             splitmix -optimised-mixer,+             any.stm ==2.5.1.0,+             any.streaming-commons ==0.2.3.1,+             streaming-commons -use-bytestring-builder,+             any.strict ==0.5.1,+             any.string-conversions ==0.4.0.1,+             any.tagged ==0.8.9,+             tagged +deepseq +transformers,+             any.tasty ==1.5.3,+             tasty +unix,+             any.template-haskell ==2.20.0.0,+             any.text ==2.0.2,+             any.text-iso8601 ==0.1.1,+             any.text-short ==0.1.6,+             text-short -asserts,+             any.tf-random ==0.5,+             any.th-abstraction ==0.7.1.0,+             any.th-compat ==0.1.6,+             any.these ==1.2.1,+             any.time ==1.12.2,+             any.time-compat ==1.9.8,+             any.tls ==2.1.13,+             tls -devel,+             any.transformers ==0.6.1.0,+             any.transformers-base ==0.4.6,+             transformers-base +orphaninstances,+             any.transformers-compat ==0.7.2,+             transformers-compat -five +five-three -four +generic-deriving +mtl -three -two,+             any.typed-process ==0.2.13.0,+             any.unix ==2.8.6.0,+             any.unix-time ==0.4.17,+             any.unliftio-core ==0.2.1.0,+             any.unordered-containers ==0.2.20.1,+             unordered-containers -debug,+             any.utf8-string ==1.0.2,+             any.uuid-types ==1.0.6,+             any.vault ==0.3.1.5,+             vault +useghc,+             any.vector ==0.13.2.0,+             vector +boundschecks -internalchecks -unsafechecks -wall,+             any.vector-algorithms ==0.9.1.0,+             vector-algorithms +bench +boundschecks -internalchecks -llvm -unsafechecks,+             any.vector-stream ==0.1.0.1,+             any.void ==0.7.3,+             void -safe,+             any.witherable ==0.5,+             any.zlib ==0.7.1.1,+             zlib -bundled-c-zlib +non-blocking-ffi +pkg-config+index-state: hackage.haskell.org 2025-11-28T11:50:55Z

+ examples/README.md view

@@ -0,0 +1,8 @@+# Example Timestamps++This directory contains various example timestamps. Every timestamp proof file+in this directory is at least syntactically valid. Although for some of them,+the timestamp proofs can't actually be validated.++Examples of proof files that are outright invalid are in the 'invalid'+directory.

+ examples/bad-stamp.txt view

@@ -0,0 +1,2 @@+The timestamp on this file is well-formatted, but will fail Bitcoin block+header validation.

+ examples/bad-stamp.txt.ots view

binary file changed (absent → 688 bytes)

+ examples/bitcoin.pdf.ots view

binary file changed (absent → 1746 bytes)

+ examples/different-blockchains.txt view

@@ -0,0 +1,1 @@+This file is stamped on two different blockchains

+ examples/different-blockchains.txt.ots view

binary file changed (absent → 1705 bytes)

+ examples/empty view

+ examples/empty.ots view

binary file changed (absent → 3812 bytes)

+ examples/hello-world.txt view

@@ -0,0 +1,1 @@+Hello World!

+ examples/hello-world.txt.ots view

binary file changed (absent → 688 bytes)

+ examples/incomplete.txt view

@@ -0,0 +1,1 @@+The timestamp on this file is incomplete, and can be upgraded.

+ examples/incomplete.txt.ots view

binary file changed (absent → 175 bytes)

+ examples/invalid/README.md view

@@ -0,0 +1,3 @@+# Invalid OTS Proof File Examples++These proof files are all invalid in a different way.

+ examples/invalid/bad-major-version.ots view

binary file changed (absent → 221 bytes)

+ examples/invalid/exceeds-max-msg-length.ots view

binary file changed (absent → 263 bytes)

+ examples/invalid/invalid-file-digest-type.ots view

binary file changed (absent → 221 bytes)

+ examples/known-and-unknown-notary.txt view

@@ -0,0 +1,2 @@+This file's timestamp has two attestations, one from a known notary, and one+from an unknown notary.

+ examples/known-and-unknown-notary.txt.ots view

binary file changed (absent → 265 bytes)

+ examples/merkle1.txt view

@@ -0,0 +1,2 @@+This file is one of three different files that have been timestamped together+with a single merkle tree. (1/3)

+ examples/merkle1.txt.ots view

binary file changed (absent → 335 bytes)

+ examples/merkle2.txt view

@@ -0,0 +1,2 @@+This file is one of three different files that have been timestamped together+with a single merkle tree. (2/3)

+ examples/merkle2.txt.ots view

binary file changed (absent → 335 bytes)

+ examples/merkle3.txt view

@@ -0,0 +1,2 @@+This file is one of three different files that have been timestamped together+with a single merkle tree. (3/3)

+ examples/merkle3.txt.ots view

binary file changed (absent → 300 bytes)

+ examples/sha1/README.md view

@@ -0,0 +1,21 @@+# SHA1 Collision Example++This is an example of a [SHA1 collision](https://shattered.io/), in conjunction+with a timestamp proof. The two files `a` and `b` differ:++```+$ diff a b+Binary files a and b differ+```++...yet the same OTS proof can be used to validate either file:++```+$ ots verify -f a a_or_b.ots+Success! Bitcoin attests data existed as of Wed May 17 21:45:45 2017 EDT+$ ots verify -f b a_or_b.ots+Success! Bitcoin attests data existed as of Wed May 17 21:45:45 2017 EDT+```++This is actually fine, because [SHA1 is still good enough for+timestamping](https://petertodd.org/2017/sha1-and-opentimestamps-proofs).

+ examples/sha1/a view

binary file changed (absent → 320 bytes)

+ examples/sha1/a-or-b.ots view

binary file changed (absent → 1287 bytes)

+ examples/sha1/b view

binary file changed (absent → 320 bytes)

+ examples/two-calendars.txt view

@@ -0,0 +1,1 @@+This file has an (incomplete) timestamp with two different calendars.

+ examples/two-calendars.txt.ots view

binary file changed (absent → 265 bytes)

+ examples/unknown-notary.txt view

@@ -0,0 +1,1 @@+This file's timestamp has a single attestation from an unknown notary.

+ examples/unknown-notary.txt.ots view

binary file changed (absent → 175 bytes)

+ haskell-opentimestamps.cabal view

@@ -0,0 +1,134 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.38.2.+--+-- see: https://github.com/sol/hpack++name:           haskell-opentimestamps+version:        0.5.5.0+synopsis:       Haskell implementation of OpenTimestamps+description:    Please see the README on Codeberg at <https://codeberg.org/photonsphere/haskell-opentimestamps#readme>+category:       Bitcoin, Finance, Network, Cryptography+author:         A.H.M. (Mari) Donkers+maintainer:     a.h.m.donkers@photonsphere.org+copyright:      2025 A.H.M. (Mari) Donkers+license:        BSD3+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    LICENSE+    README.md+    CHANGELOG.md+    package.yaml+    cabal.project+    cabal.project.freeze+    Makefile+    examples/invalid/README.md+    examples/invalid/bad-major-version.ots+    examples/invalid/exceeds-max-msg-length.ots+    examples/invalid/invalid-file-digest-type.ots+    examples/sha1/README.md+    examples/sha1/a+    examples/sha1/a-or-b.ots+    examples/sha1/b+    examples/README.md+    examples/bad-stamp.txt+    examples/bad-stamp.txt.ots+    examples/bitcoin.pdf.ots+    examples/different-blockchains.txt+    examples/different-blockchains.txt.ots+    examples/empty+    examples/empty.ots+    examples/hello-world.txt+    examples/hello-world.txt.ots+    examples/incomplete.txt+    examples/incomplete.txt.ots+    examples/known-and-unknown-notary.txt+    examples/known-and-unknown-notary.txt.ots+    examples/merkle1.txt+    examples/merkle1.txt.ots+    examples/merkle2.txt+    examples/merkle2.txt.ots+    examples/merkle3.txt+    examples/merkle3.txt.ots+    examples/two-calendars.txt+    examples/two-calendars.txt.ots+    examples/unknown-notary.txt+    examples/unknown-notary.txt.ots++source-repository head+  type: git+  location: https://codeberg.org/photonsphere/haskell-opentimestamps++library+  exposed-modules:+      OpenTimestamps+      OpenTimestamps.Attestation+      OpenTimestamps.Config+      OpenTimestamps.DetachedTimestampFile+      OpenTimestamps.Op+      OpenTimestamps.Stamp+      OpenTimestamps.Timestamp+      OpenTimestamps.VarInt+      OpenTimestamps.Upgrade+      OpenTimestamps.Prune+      OpenTimestamps.Verify+  other-modules:+      OpenTimestamps.Types+      Paths_haskell_opentimestamps+  hs-source-dirs:+      src+  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints+  build-depends:+      aeson >=2.0 && <3+    , base >=4.7 && <5+    , base16-bytestring >=1.0 && <2+    , binary >=0.8 && <1+    , bitcoind-rpc >=0.3 && <1+    , bytes >=0.17 && <1+    , bytestring >=0.10 && <1+    , cereal >=0.5 && <1+    , containers >=0.6 && <1+    , cryptonite >=0.25 && <1+    , filepath >=1.4 && <2+    , haskoin-core >=1.0 && <2+    , http-client >=0.7 && <1+    , http-conduit >=2.3 && <3+    , memory >=0.15 && <1+    , mtl >=2.2 && <3+    , servant >=0.20 && <1+    , text >=2.0 && <3+    , time >=1.8 && <2+  default-language: Haskell2010++test-suite haskell-opentimestamps-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Arbitrary+      PruneSpec+      VerifySpec+      UpgradeSpec+  hs-source-dirs:+      test+  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N -main-is Spec+  build-depends:+      QuickCheck+    , base+    , base16-bytestring+    , binary+    , bitcoind-rpc+    , bytes+    , bytestring+    , containers+    , directory+    , filepath+    , haskell-opentimestamps+    , haskoin-core+    , hspec+    , memory+    , process+    , random+    , text+    , time+  default-language: Haskell2010

+ package.yaml view

@@ -0,0 +1,132 @@+name:                haskell-opentimestamps+version:             0.5.5.0+license:             BSD3+#x-license:           BSD-3-Clause OR Apache-2.0+git:                 "https://codeberg.org/photonsphere/haskell-opentimestamps"+author:              "A.H.M. (Mari) Donkers"+maintainer:          "a.h.m.donkers@photonsphere.org"+copyright:           "2025 A.H.M. (Mari) Donkers"+category:            Bitcoin, Finance, Network, Cryptography+synopsis:            Haskell implementation of OpenTimestamps++extra-source-files:+- LICENSE+- README.md+- CHANGELOG.md+- package.yaml+- cabal.project+- cabal.project.freeze+- Makefile+- examples/invalid/README.md+- examples/invalid/bad-major-version.ots+- examples/invalid/exceeds-max-msg-length.ots+- examples/invalid/invalid-file-digest-type.ots+- examples/sha1/README.md+- examples/sha1/a+- examples/sha1/a-or-b.ots+- examples/sha1/b+- examples/README.md+- examples/bad-stamp.txt+- examples/bad-stamp.txt.ots+- examples/bitcoin.pdf.ots+- examples/different-blockchains.txt+- examples/different-blockchains.txt.ots+- examples/empty+- examples/empty.ots+- examples/hello-world.txt+- examples/hello-world.txt.ots+- examples/incomplete.txt+- examples/incomplete.txt.ots+- examples/known-and-unknown-notary.txt+- examples/known-and-unknown-notary.txt.ots+- examples/merkle1.txt+- examples/merkle1.txt.ots+- examples/merkle2.txt+- examples/merkle2.txt.ots+- examples/merkle3.txt+- examples/merkle3.txt.ots+- examples/two-calendars.txt+- examples/two-calendars.txt.ots+- examples/unknown-notary.txt+- examples/unknown-notary.txt.ots++description:         Please see the README on Codeberg at <https://codeberg.org/photonsphere/haskell-opentimestamps#readme>++ghc-options:+- -Wall+- -Wcompat+- -Widentities+- -Wincomplete-record-updates+- -Wincomplete-uni-patterns+- -Wmissing-export-lists+- -Wmissing-home-modules+- -Wpartial-fields+- -Wredundant-constraints++library:+  source-dirs: src+  exposed-modules:+    - OpenTimestamps+    - OpenTimestamps.Attestation+    - OpenTimestamps.Config+    - OpenTimestamps.DetachedTimestampFile+    - OpenTimestamps.Op+    - OpenTimestamps.Stamp+    - OpenTimestamps.Timestamp+    - OpenTimestamps.VarInt+    - OpenTimestamps.Upgrade+    - OpenTimestamps.Prune+    - OpenTimestamps.Verify+  dependencies:+    - aeson >= 2.0 && < 3+    - base >= 4.7 && < 5+    - base16-bytestring >= 1.0 && < 2+    - binary >= 0.8 && < 1+    - bitcoind-rpc >= 0.3 && < 1+    - bytes >= 0.17 && < 1+    - bytestring >= 0.10 && < 1+    - containers >= 0.6 && < 1+    - cryptonite >= 0.25 && < 1+    - filepath >= 1.4 && < 2+    - http-client >= 0.7 && < 1+    - http-conduit >= 2.3 && < 3+    - memory >= 0.15 && < 1+    - mtl >= 2.2 && < 3+    - text >= 2.0 && < 3+    - servant >= 0.20 && < 1+    - haskoin-core >= 1.0 && < 2+    - time >= 1.8 && < 2+    - cereal >= 0.5 && < 1++tests:+  haskell-opentimestamps-test:+    main:                Spec+    source-dirs:         test+    other-modules:+    - Arbitrary+    - PruneSpec+    - VerifySpec+    - UpgradeSpec+    ghc-options:+    - -threaded+    - -rtsopts+    - -with-rtsopts=-N+    dependencies:+    - QuickCheck+    - base+    - base16-bytestring+    - binary+    - bitcoind-rpc+    - bytes+    - bytestring+    - containers+    - directory+    - filepath+    - haskell-opentimestamps+    - haskoin-core+    - hspec+    - text+    - process+    - random+    - time+    - memory

+ src/OpenTimestamps.hs view

@@ -0,0 +1,150 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++{- | Main OpenTimestamps library module.++This module provides the primary API for OpenTimestamps functionality,+including timestamp creation, verification, upgrading, and pruning.+It re-exports functions from specialized modules for convenience.+-}+module OpenTimestamps+  ( info+  , prune+  , stamp+  , upgrade+  , verify+  , module OpenTimestamps.DetachedTimestampFile+  , module OpenTimestamps.Prune+  , module OpenTimestamps.Stamp+  , module OpenTimestamps.Verify+  )+where++import Data.Function ((&))+import qualified Data.Text as T+import Data.Time.Clock (UTCTime)+import OpenTimestamps.Attestation+  ( Attestation+  , isBitcoinAttestation+  , isLitecoinAttestation+  , isPending+  , isUnknownAttestation+  )+import OpenTimestamps.DetachedTimestampFile+  ( DetachedTimestampFile+  , deserialize+  , serialize+  , timestamp+  )+import OpenTimestamps.Prune (pruneTimestamp)+import OpenTimestamps.Stamp+  ( StampResult (..)+  , TimestampError (..)+  , stampDigest+  )+import OpenTimestamps.Types (OTsByteStream, OTsBytes)+import OpenTimestamps.Upgrade (upgradeTimestamp)+import OpenTimestamps.Verify+  ( BitcoinConfig+  , VerificationError (OtherVerificationError)+  , verifyDetachedTimestampFile+  )++-- | Helper to parse string arguments into attestation predicates.+parseAttestationArgs :: [String] -> [Attestation -> Bool]+parseAttestationArgs = map parseArg+  where+    parseArg "btc" = isBitcoinAttestation+    parseArg "ltc" = isLitecoinAttestation+    parseArg "unknown" = isUnknownAttestation+    parseArg "pending:*" = isPending+    parseArg s | "pending:" `T.isPrefixOf` T.pack s = isPending -- TODO: Refine to match specific URI+    parseArg _ = const False -- Default for unrecognised arguments++-- | Deserialize and display information about a timestamp file.+info ::+  OTsByteStream ->+  Either String DetachedTimestampFile+info = deserialize++-- | Create a timestamp by submitting a digest to calendar servers.+stamp ::+  [String] ->+  OTsBytes ->+  IO StampResult+stamp+  urls+  digest = do+    stampDigest urls digest++-- | Prune a timestamp by removing suboptimal attestations and empty branches.+prune ::+  [String] ->+  [String] ->+  OTsByteStream ->+  IO (Either String OTsByteStream)+prune+  verifyArgs+  discardArgs+  otsFileContent = do+    case deserialize otsFileContent of+      Left err -> pure $ Left $ "Failed to deserialize OTS file: " ++ err+      Right dtfs -> do+        let initialTimestamp = timestamp dtfs+        let _attestationsToVerify = parseAttestationArgs verifyArgs+        let _predicatesToDiscard = parseAttestationArgs discardArgs+        -- TODO Implement the additional prune parameters+        -- (attestationsToVerify, predicatesToDiscard and initialTimestamp)+        let prunedTimestamp = pruneTimestamp initialTimestamp+        let prunedDtfs = dtfs {timestamp = prunedTimestamp}+        pure $+          prunedDtfs+            & serialize+            & Right++-- | Upgrade a timestamp by fetching additional attestations from calendar servers.+upgrade ::+  [String] ->+  OTsByteStream ->+  IO (Either String OTsByteStream)+upgrade+  urls+  otsFileContent = do+    case deserialize otsFileContent of+      Left err -> pure $ Left $ "Failed to deserialize OTS file: " ++ err+      Right dtfs -> do+        let initialTimestamp = timestamp dtfs+        let calendarUrls = map T.pack urls+        eUpgradedTimestamp <-+          upgradeTimestamp calendarUrls initialTimestamp+        case eUpgradedTimestamp of+          Left err -> pure $ Left err+          Right upgradedTimestamp -> do+            let upgradedDtfs = dtfs {timestamp = upgradedTimestamp}+            upgradedDtfs+              & serialize+              & Right+              & pure++-- | Verify a timestamp against Bitcoin blockchain.+verify ::+  BitcoinConfig ->+  [String] ->+  OTsByteStream ->+  OTsBytes ->+  IO (Either VerificationError (Int, UTCTime))+verify+  bitcoinConfig+  urls+  otsFileContent+  targetDigest = do+    case deserialize otsFileContent of+      Left err ->+        pure $+          "Failed to deserialize OTS file: " ++ err+            & OtherVerificationError+            & Left+      Right dtfs -> do+        let calendarUrls = map T.pack urls+        verifyDetachedTimestampFile bitcoinConfig calendarUrls dtfs targetDigest

+ src/OpenTimestamps/Attestation.hs view

@@ -0,0 +1,104 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wno-partial-fields #-}++{- | Attestation types and functions for OpenTimestamps.++This module provides data types and functions for working with+different types of attestations that can be attached to timestamps,+including Bitcoin attestations, pending attestations, and unknown attestations.+-}+module OpenTimestamps.Attestation+  ( Attestation (..)+  , isPending+  , isBitcoinAttestation+  , isLitecoinAttestation+  , isUnknownAttestation+  , bitcoinTag+  , pendingTag+  , getAttestation+  , putAttestation+  ) where++import Data.Binary.Get (Get, getByteString, runGetOrFail)+import Data.Binary.Put (Put, putByteString, runPut)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BSL+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import Data.Word (Word32)+import OpenTimestamps.Config as Config+import OpenTimestamps.VarInt++{- | Attestation types that can be attached to timestamps.++Bitcoin attestations contain the block height at which the commitment+was confirmed. Pending attestations contain a URI for a calendar+service. Unknown attestations are used for future extensibility.+-}+data Attestation where+  Bitcoin :: {height' :: Word32} -> Attestation+  Pending :: {uri' :: T.Text} -> Attestation+  Unknown ::+    {tag' :: BS.ByteString, data' :: BS.ByteString} ->+    Attestation+  deriving (Eq, Show, Ord)++-- | Check if an attestation is a pending attestation.+isPending :: Attestation -> Bool+isPending (Pending _) = True+isPending _ = False++-- | Check if an attestation is a Bitcoin attestation.+isBitcoinAttestation :: Attestation -> Bool+isBitcoinAttestation (Bitcoin _) = True+isBitcoinAttestation _ = False++{- | Check if an attestation is a Litecoin attestation.+Currently always returns False as Litecoin attestations are not implemented.+-}+isLitecoinAttestation :: Attestation -> Bool+isLitecoinAttestation _ = False -- Placeholder, as Litecoin is not in Attestation yet++-- | Check if an attestation is an unknown attestation.+isUnknownAttestation :: Attestation -> Bool+isUnknownAttestation (Unknown _ _) = True+isUnknownAttestation _ = False++-- | Tag byte sequence identifying Bitcoin attestations.+bitcoinTag :: BS.ByteString+bitcoinTag = "\x05\x88\x96\x0d\x73\xd7\x19\x01"++-- | Tag byte sequence identifying pending attestations.+pendingTag :: BS.ByteString+pendingTag = "\x83\xdf\xe3\x0d\x2e\xf9\x0c\x8e"++-- | Deserialize an attestation from binary format.+getAttestation :: Get Attestation+getAttestation = do+  tag <- getByteString 8+  len <- getVarInt+  payload <- getByteString len+  if tag == bitcoinTag+    then case runGetOrFail getVarInt (BSL.fromStrict payload) of+      Left (_, _, err) -> fail $ "Bitcoin attestation deserialization error: " ++ err+      Right (_, _, h) -> pure $ Bitcoin (fromIntegral h)+    else+      if tag == pendingTag+        then case runGetOrFail (getVarBytes Config.attestationMaxVarBytesLength 0) (BSL.fromStrict payload) of+          Left (_, _, err) -> fail $ "Pending attestation deserialization error: " ++ err+          Right (_, _, uriBs) -> pure $ Pending (TE.decodeUtf8 uriBs)+        else+          pure $ Unknown tag payload++-- | Serialize an attestation to binary format.+putAttestation :: Attestation -> Put+putAttestation att = do+  let (tag, payloadPut) = case att of+        Bitcoin h -> (bitcoinTag, putVarInt (fromIntegral h))+        Pending u -> (pendingTag, putVarBytes (TE.encodeUtf8 u))+        Unknown t d -> (t, putByteString d)++  putByteString tag+  let payloadBS = BSL.toStrict (runPut payloadPut)+  putVarBytes payloadBS

+ src/OpenTimestamps/Config.hs view

@@ -0,0 +1,73 @@+{-# LANGUAGE OverloadedStrings #-}++{- | Configuration constants and settings for OpenTimestamps.++This module contains all the configuration values used throughout+the OpenTimestamps library, including HTTP settings, timeouts,+file format constants, and operational limits.+-}+module OpenTimestamps.Config+  ( accept+  , apiUrlDigest+  , apiUrlTimeStamp+  , contentType+  , userAgent+  , bitcoinRpcTimeoutMicroseconds+  , upgradeMaxIterations+  , maxTimestampMessageLength+  , opMaxVarBytesLength+  , attestationMaxVarBytesLength+  , detachedTimestampFileMagic+  , detachedTimestampFileVersion+  ) where++import Data.ByteString (ByteString)+import Data.Word (Word8)++-- | Accept string for HTTP requests.+accept :: ByteString+accept = "application/vnd.opentimestamps.v1"++-- | Content-Type string for HTTP requests.+contentType :: ByteString+contentType = "application/octet-stream"++-- | User-Agent string for HTTP requests.+userAgent :: ByteString+userAgent = "Haskell-OpenTimestamps-Client/0.5.5.0"++-- | URL string for digest HTTP requests.+apiUrlDigest :: String+apiUrlDigest = "/digest"++-- | URL string for timestamp HTTP requests.+apiUrlTimeStamp :: String+apiUrlTimeStamp = "/timestamp/"++-- | Timeout for Bitcoin RPC requests in microseconds (180 seconds).+bitcoinRpcTimeoutMicroseconds :: Int+bitcoinRpcTimeoutMicroseconds = 180 * 1000 * 1000++-- | Maximum number of iterations for the upgrade process.+upgradeMaxIterations :: Int+upgradeMaxIterations = 10++-- | Maximum length for Timestamp message byte strings in Timestamp.hs.+maxTimestampMessageLength :: Int+maxTimestampMessageLength = 4096++-- | Maximum length for variable-length byte strings in Op.hs (Append/Prepend).+opMaxVarBytesLength :: Int+opMaxVarBytesLength = 4096++-- | Maximum length for variable-length byte strings in Attestation.hs (Pending).+attestationMaxVarBytesLength :: Int+attestationMaxVarBytesLength = 8192++-- | Magic string for detached timestamp files.+detachedTimestampFileMagic :: ByteString+detachedTimestampFileMagic = "\x00OpenTimestamps\x00\x00Proof\x00\xbf\x89\xe2\xe8\x84\xe8\x92\x94"++-- | Version for detached timestamp files.+detachedTimestampFileVersion :: Word8+detachedTimestampFileVersion = 1

+ src/OpenTimestamps/DetachedTimestampFile.hs view

@@ -0,0 +1,138 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE OverloadedStrings #-}++{- | Detached timestamp file handling for OpenTimestamps.++This module provides functionality for working with detached timestamp+files (.ots format), including serialization, deserialization,+and digest type handling for different hash algorithms.+-}+module OpenTimestamps.DetachedTimestampFile+  ( DetachedTimestampFile (..)+  , DigestType (..)+  , digestLen+  , fromTag+  , toTag+  , serialize+  , deserialize+  ) where++import Control.Monad (unless)+import Data.Binary.Get+  ( Get+  , getByteString+  , getWord8+  , runGetOrFail+  )+import Data.Binary.Put (Put, putByteString, putWord8, runPut)+import qualified Data.ByteString as BS+import Data.Word (Word8)+import OpenTimestamps.Config as Config+import qualified OpenTimestamps.Timestamp as TS+import OpenTimestamps.Types (OTsByteStream)+import OpenTimestamps.VarInt (getVarInt, putVarInt)++-- | Magic bytes that every proof must start with+magic :: BS.ByteString+magic = Config.detachedTimestampFileMagic++-- | Major version of timestamp files+version :: Int+version = fromIntegral Config.detachedTimestampFileVersion++{- | Structure representing a detached timestamp file.++Contains the hash function used to create the document digest+and the timestamp proving when that digest existed.+-}+data DetachedTimestampFile where+  DetachedTimestampFile ::+    { digestType :: DigestType+    , timestamp :: TS.Timestamp+    } ->+    DetachedTimestampFile+  deriving (Eq, Show)++-- | Type of hash function used to produce the document digest.+data DigestType where+  DSha1 :: DigestType+  DSha256 :: DigestType+  DRipemd160 :: DigestType+  deriving (Eq, Show, Ord)++-- | Interpret a one-byte tag as a digest type.+fromTag :: Word8 -> Either String DigestType+fromTag 0x02 = Right DSha1+fromTag 0x03 = Right DRipemd160+fromTag 0x08 = Right DSha256+fromTag x = Left ("BadDigestTag: " ++ show x)++-- | Serialize a digest type to its one-byte tag.+toTag :: DigestType -> Word8+toTag DSha1 = 0x02+toTag DSha256 = 0x08+toTag DRipemd160 = 0x03++-- | The length, in bytes, that a digest with this hash function will be.+digestLen :: DigestType -> Int+digestLen DSha1 = 20+digestLen DSha256 = 32+digestLen DRipemd160 = 20++-- | Read magic number and verify it matches the expected format.+readMagic :: Get ()+readMagic = do+  m <- getByteString (BS.length magic)+  unless (m == magic) $+    fail $+      "Bad magic:\nAPI:\t " ++ show m ++ "\nmagic:\t " ++ show magic ++ ")"++-- | Read version number and verify it matches the expected format.+readVersion :: Get ()+readVersion = do+  v <- getVarInt+  unless (v == version) $ fail ("Bad version: " ++ show v)++-- | Deserialize a detached timestamp file from binary format.+getDetachedTimestampFile :: Get DetachedTimestampFile+getDetachedTimestampFile = do+  readMagic+  readVersion+  tag <- getWord8+  digestType' <- case fromTag tag of+    Left err -> fail err+    Right dt -> pure dt+  let len = digestLen digestType'+  digest <- getByteString len+  ts <- TS.deserialize digest+  pure $ DetachedTimestampFile digestType' ts++-- | Deserialize a detached timestamp file from a byte stream.+deserialize ::+  OTsByteStream ->+  Either String DetachedTimestampFile+deserialize bs = case runGetOrFail getDetachedTimestampFile bs of+  Left (_, _, err) -> Left err+  Right (_, _, val) -> Right val++-- | Write the magic bytes to the output.+putMagic :: Put+putMagic = putByteString magic++-- | Write the version number to the output.+putVersion :: Put+putVersion = putVarInt version++-- | Serialize a detached timestamp file to binary format.+putDetachedTimestampFile :: DetachedTimestampFile -> Put+putDetachedTimestampFile dtf = do+  putMagic+  putVersion+  putWord8 $ toTag dtf.digestType+  putByteString $ TS.timestampMsg dtf.timestamp+  TS.putTimestamp dtf.timestamp++-- | Serialize a detached timestamp file to a byte stream.+serialize :: DetachedTimestampFile -> OTsByteStream+serialize = runPut . putDetachedTimestampFile

+ src/OpenTimestamps/Op.hs view

@@ -0,0 +1,101 @@+{-# LANGUAGE GADTs #-}++{- | Operations that can be applied in timestamp proofs.++This module defines all supported operations that can be used to+transform data in timestamp proofs, including cryptographic hash+functions, data transformations, and byte manipulation operations.+-}+module OpenTimestamps.Op+  ( Op (..)+  , execute+  , getOp+  , opToTag+  , putOp+  ) where++import Crypto.Hash+  ( Digest+  , Keccak_256 (Keccak_256)+  , RIPEMD160 (RIPEMD160)+  , SHA1 (SHA1)+  , SHA256 (SHA256)+  , hashWith+  )+import Data.Binary.Get (Get)+import Data.Binary.Put (Put, putWord8)+import qualified Data.ByteArray as BA+import qualified Data.ByteString as BS+import qualified Data.ByteString.Base16 as B16+import Data.Word (Word8)+import OpenTimestamps.Config as Config+import OpenTimestamps.VarInt (getVarBytes, putVarBytes)++{- | All the types of operations supported in timestamp operations.++Hash operations apply cryptographic hash functions to the input.+Transform operations modify the data format or byte order.+Append/Prepend operations concatenate additional bytes.+-}+data Op where+  Sha1 :: Op+  Sha256 :: Op+  Ripemd160 :: Op+  Keccak256 :: Op+  Hexlify :: Op+  Reverse :: Op+  Append :: BS.ByteString -> Op+  Prepend :: BS.ByteString -> Op+  deriving (Eq, Show, Ord)++-- | Execute an operation on the given data.+execute :: Op -> BS.ByteString -> BS.ByteString+execute op input = case op of+  Sha1 -> digestToBS (hashWith SHA1 input)+  Sha256 -> digestToBS (hashWith SHA256 input)+  Ripemd160 -> digestToBS (hashWith RIPEMD160 input)+  Keccak256 -> digestToBS (hashWith Keccak_256 input)+  Hexlify -> B16.encode input+  Reverse -> BA.reverse input+  Append bs -> input <> bs+  Prepend bs -> bs <> input++-- | Convert a cryptographic digest to a ByteString.+digestToBS :: Digest a -> BS.ByteString+digestToBS = BA.convert++-- | Deserialize an operation from its tag byte.+getOp :: Word8 -> Get Op+getOp tag = case tag of+  0x02 -> pure Sha1+  0x08 -> pure Sha256+  0x03 -> pure Ripemd160+  0x67 -> pure Keccak256+  0xf3 -> pure Hexlify+  0xf2 -> pure Reverse+  0xf0 -> Append <$> getVarBytes Config.opMaxVarBytesLength 0+  0xf1 -> Prepend <$> getVarBytes Config.opMaxVarBytesLength 0+  x -> fail ("BadOpTag: " ++ show x)++-- | Convert an operation to its tag byte.+opToTag :: Op -> Word8+opToTag Sha1 = 0x02+opToTag Sha256 = 0x08+opToTag Ripemd160 = 0x03+opToTag Keccak256 = 0x67+opToTag Hexlify = 0xf3+opToTag Reverse = 0xf2+opToTag (Append _) = 0xf0+opToTag (Prepend _) = 0xf1++-- | Serialize an operation to binary format.+putOp :: Op -> Put+putOp op = case op of+  Sha1 -> putWord8 0x02+  Sha256 -> putWord8 0x08+  Ripemd160 -> putWord8 0x03+  Hexlify -> putWord8 0xf3+  Keccak256 -> putWord8 0x67+  Reverse -> putWord8 0xf2+  Append bs -> putWord8 0xf0 >> putVarBytes bs+  Prepend bs -> putWord8 0xf1 >> putVarBytes bs

+ src/OpenTimestamps/Prune.hs view

@@ -0,0 +1,167 @@+{-# LANGUAGE OverloadedRecordDot #-}+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}++{-# HLINT ignore "Use tuple-section" #-}++{- | Timestamp pruning functionality for OpenTimestamps.++This module provides functions to prune timestamp trees by removing+suboptimal attestations and empty branches while preserving+the most valuable verification paths.+-}+module OpenTimestamps.Prune+  ( pruneTimestamp+  ) where++import qualified Data.ByteString as BS+import Data.List (foldl1')+import qualified Data.Map.Strict as Map+import Data.Maybe (catMaybes)+import qualified Data.Set as Set+import OpenTimestamps.Attestation+  ( Attestation (..)+  , isBitcoinAttestation+  )+import OpenTimestamps.Op (Op (Append, Prepend))+import OpenTimestamps.Timestamp (Timestamp (..))++{- | Compare Bitcoin attestations to select the best one.++Criteria: lowest height, then lowest depth.+-}+compareBitcoinAttestations ::+  (Attestation, Int, BS.ByteString) ->+  (Attestation, Int, BS.ByteString) ->+  (Attestation, Int, BS.ByteString)+compareBitcoinAttestations+  currentBest@(Bitcoin h1, depth1, _)+  (Bitcoin h2, depth2, msg2) =+    case compare h1 h2 of+      LT -> currentBest+      GT -> (Bitcoin h2, depth2, msg2)+      EQ ->+        if depth1 < depth2+          then currentBest+          else (Bitcoin h2, depth2, msg2)+compareBitcoinAttestations _ _ = error "Should only compare Bitcoin attestations"++-- | Calculates the length added by an operation for depth adjustment.+opLength :: Op -> Int+opLength (Append bs) = BS.length bs+opLength (Prepend bs) = BS.length bs+opLength _ = 0 -- Other ops don't have arguments that add to length++{- | Recursively prunes a sub-timestamp and adjusts the depth of its+best Bitcoin attestation.+-}+processSubTimestampAndAdjustDepth ::+  Op -> Timestamp -> (Timestamp, Maybe (Attestation, Int, BS.ByteString))+processSubTimestampAndAdjustDepth op subTs =+  let (prunedSubTs, mSubBestAttWithMsg) = pruneAttestations subTs+      mAdjustedSubBestAtt =+        fmap+          ( \(att, depth, msg) ->+              (att, depth + 1 + opLength op, msg)+          )+          mSubBestAttWithMsg+   in (prunedSubTs, mAdjustedSubBestAtt)++{- | Collects all Bitcoin attestations from the current timestamp and+its sub-timestamps.+-}+collectAllBitcoinAttestations ::+  Timestamp ->+  [Maybe (Attestation, Int, BS.ByteString)] ->+  Set.Set (Attestation, Int, BS.ByteString)+collectAllBitcoinAttestations ts subBestAttestations =+  let currentBitcoinAttestations =+        Set.map (\att -> (att, 0, ts.timestampMsg)) $+          Set.filter isBitcoinAttestation ts.attestations+   in currentBitcoinAttestations+        `Set.union` Set.fromList (catMaybes subBestAttestations)++-- | Selects the single best Bitcoin attestation from a set, if any exist.+selectBestBitcoinAttestation ::+  Set.Set (Attestation, Int, BS.ByteString) ->+  Maybe (Attestation, Int, BS.ByteString)+selectBestBitcoinAttestation allBitcoinAttestations =+  if Set.null allBitcoinAttestations+    then Nothing+    else+      Just $+        foldl1'+          compareBitcoinAttestations+          (Set.toList allBitcoinAttestations)++{- | Recursively prunes attestations, keeping only the optimal Bitcoin+attestation (lowest height) and all non-Bitcoin attestations. Returns+the pruned timestamp, the optimal Bitcoin attestation found in its+subtree, and its depth. The depth is calculated as the number of+operations from the root of the subtree to the attestation.+-}+pruneAttestations :: Timestamp -> (Timestamp, Maybe (Attestation, Int, BS.ByteString))+pruneAttestations ts = (newTs, mBestAttestationWithMsg)+  where+    -- Recursively prune sub-timestamps and collect their best attestations+    -- and adjusted depths.+    (prunedOpsList, subBestAttestations) =+      unzip $+        Map.elems $+          Map.mapWithKey processSubTimestampAndAdjustDepth ts.ops++    prunedOpsMap = Map.fromList $ zip (Map.keys ts.ops) prunedOpsList++    -- Collect all Bitcoin attestations from the current node and sub-nodes.+    allBitcoinAttestations = collectAllBitcoinAttestations ts subBestAttestations++    -- Determine the single best Bitcoin attestation for this subtree.+    mBestAttestationWithMsg = selectBestBitcoinAttestation allBitcoinAttestations++    -- All Bitcoin attestations at this node are removed.+    newAttestations = Set.filter (not . isBitcoinAttestation) ts.attestations++    newTs = ts {attestations = newAttestations, ops = prunedOpsMap}++-- | Prune empty branches from the timestamp tree. Returns (pruned timestamp, changed flag).+pruneTree :: Timestamp -> (Timestamp, Bool)+pruneTree ts = (ts {ops = newOps}, changed)+  where+    (newOps, changedOps) = Map.foldlWithKey' foldFn (Map.empty, False) ts.ops+    foldFn (accOps, accChanged) op subTs =+      let (prunedSubTs, subChanged) = pruneTree subTs+       in if Set.null prunedSubTs.attestations && Map.null prunedSubTs.ops+            then (accOps, accChanged || subChanged || True) -- branch is empty, remove it+            else (Map.insert op prunedSubTs accOps, accChanged || subChanged)+    changed =+      changedOps+        || ( Set.null ts.attestations+               && Map.null newOps+               && not (Set.null ts.attestations && Map.null ts.ops)+           )++{- | Reinserts the globally best Bitcoin attestation into the pruned+timestamp at the correct message.+-}+reinsertBestBitcoinAttestation :: Attestation -> BS.ByteString -> Timestamp -> Timestamp+reinsertBestBitcoinAttestation att targetMsg currentTs+  | timestampMsg currentTs == targetMsg =+      currentTs {attestations = Set.insert att currentTs.attestations}+  | otherwise =+      currentTs+        { ops =+            Map.map+              (reinsertBestBitcoinAttestation att targetMsg)+              currentTs.ops+        }++{- | Prune a timestamp by discarding suboptimal attestations and+removing empty branches.+-}+pruneTimestamp :: Timestamp -> Timestamp+pruneTimestamp initialTs =+  let (tsWithoutBitcoins, mGlobalBestAttestationWithMsg) = pruneAttestations initialTs+      tsWithBestAttReinserted = case mGlobalBestAttestationWithMsg of+        Nothing -> tsWithoutBitcoins+        Just (globalBestAtt, _, globalBestMsg) ->+          reinsertBestBitcoinAttestation globalBestAtt globalBestMsg tsWithoutBitcoins+   in fst (pruneTree tsWithBestAttReinserted)

+ src/OpenTimestamps/Stamp.hs view

@@ -0,0 +1,173 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++{- | Timestamp stamping functionality for OpenTimestamps.++This module provides functions to create timestamps by submitting+digests to calendar servers and handling the results,+including error handling and timestamp file creation.+-}+module OpenTimestamps.Stamp+  ( TimestampError (..)+  , StampResult (..)+  , stampDigest+  ) where++import Control.Exception (SomeException, try)+import Crypto.Hash (SHA256 (SHA256), hashWith)+import qualified Crypto.Random.Entropy as R+import Data.Binary.Get (runGetOrFail)+import qualified Data.ByteArray as BA+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy.Char8 as BSL+import Data.Either (lefts, rights)+import Data.Function ((&))+import qualified Data.Map.Strict as Map+import qualified Data.Set as Set+import Network.HTTP.Client (Request (..), RequestBody (..), Response (..))+import Network.HTTP.Simple+  ( getResponseBody+  , getResponseStatusCode+  , httpLBS+  , parseRequest+  , setRequestBody+  , setRequestHeader+  , setRequestMethod+  )+import OpenTimestamps.Config as Config+import qualified OpenTimestamps.DetachedTimestampFile as DTSF+import qualified OpenTimestamps.Op as Op+import qualified OpenTimestamps.Timestamp as TS+import OpenTimestamps.Types (OTsBytes)++-- | Error type for timestamp operations.+data TimestampError where+  TimestampError ::+    { errorDigest :: BS.ByteString+    , errorUrl :: String+    , errorMessage :: String+    } ->+    TimestampError+  deriving (Show, Eq)++-- | Result of a stamping operation containing any errors and the timestamp file.+data StampResult where+  StampResult ::+    { srErrors :: [TimestampError]+    , srTimestampFile :: Maybe DTSF.DetachedTimestampFile+    } ->+    StampResult+  deriving (Show)++-- | Send a timestamp request to a calendar server.+timeStampRequest ::+  BS.ByteString ->+  String ->+  Request ->+  IO (Either TimestampError TS.Timestamp)+timeStampRequest digest url request = do+  let postRequest =+        request+          & setRequestMethod "POST"+          & setRequestHeader "User-Agent" [Config.userAgent]+          & setRequestHeader "Accept" [Config.accept]+          & setRequestHeader "Content-Type" [Config.contentType]+          & setRequestBody (RequestBodyBS digest)+  eResponse <-+    try (httpLBS postRequest) ::+      IO (Either SomeException (Response BSL.ByteString))+  case eResponse of+    Left ex -> do+      let errMsg = "HTTP request failed: " ++ show ex+      pure $ Left $ TimestampError digest url errMsg+    Right response -> do+      let body = getResponseBody response+      if getResponseStatusCode response == 200+        then do+          case runGetOrFail (TS.deserialize digest) body of+            Left err -> do+              let errMsg = "Deserialization failed: " ++ show err+              pure $ Left $ TimestampError digest url errMsg+            Right (_, _, newTimestamp) -> do+              pure $ Right newTimestamp+        else do+          let errMsg =+                "Server returned HTTP "+                  ++ show (getResponseStatusCode response)+                  ++ ": "+                  ++ show body+          pure $ Left $ TimestampError digest url errMsg++{- | Stamp a digest by submitting it to calendar servers.++Takes a list of calendar server URLs and a digest to timestamp.+Returns a StampResult containing any errors and the timestamp file.+-}+stampDigest ::+  [String] ->+  OTsBytes ->+  IO StampResult+stampDigest+  urls+  originalDigest = do+    -- 1. Generate a random nonce (16 bytes)+    nonce <- R.getEntropy 16++    -- 2. Append nonce to the original digest+    let appendedDigest = originalDigest <> nonce++    -- 3. Hash the result of the append operation+    let submissionDigest = BA.convert (hashWith SHA256 appendedDigest)++    -- 4. Submit the new digest to the calendar servers+    allResults <- mapM (getTimestamp submissionDigest) urls+    let timestamps = rights allResults+    let errors = lefts allResults++    if null timestamps+      then+        pure $+          StampResult+            { srErrors = errors+            , srTimestampFile = Nothing+            }+      else do+        -- 5. Merge the proofs from the servers+        let serverTimestamp = foldl1 (\ts1 ts2 -> fst (TS.merge ts1 ts2)) timestamps++        -- 6. Construct the final timestamp with the correct structure+        let finalTimestamp =+              TS.Timestamp+                { TS.timestampMsg = originalDigest+                , TS.attestations = Set.empty+                , TS.ops =+                    Map.singleton (Op.Append nonce) $+                      TS.Timestamp+                        { TS.timestampMsg = appendedDigest+                        , TS.attestations = Set.empty+                        , TS.ops = Map.singleton Op.Sha256 serverTimestamp+                        }+                }++        -- 7. Create the final .ots file+        let newOtsFile = DTSF.DetachedTimestampFile DTSF.DSha256 finalTimestamp+        pure $+          StampResult+            { srErrors = errors+            , srTimestampFile = Just newOtsFile+            }+    where+      -- \| Get a timestamp from a specific calendar server.+      getTimestamp ::+        BS.ByteString ->+        String ->+        IO (Either TimestampError TS.Timestamp)+      getTimestamp digest' url' = do+        let url = url' ++ Config.apiUrlDigest+        eRequest <- try (parseRequest url) :: IO (Either SomeException Request)+        case eRequest of+          Left ex -> do+            let errMsg = "Error parsing request: " ++ show ex+            pure $ Left $ TimestampError digest' url errMsg+          Right request -> timeStampRequest digest' url' request

+ src/OpenTimestamps/Timestamp.hs view

@@ -0,0 +1,379 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedRecordDot #-}++{- | Core timestamp functionality for OpenTimestamps.++This module provides the main Timestamp data type and functions for+creating, manipulating, serializing, and verifying timestamps,+including operations, attestations, and Merkle tree calculations.+-}+module OpenTimestamps.Timestamp+  ( Timestamp (..)+  , serialize+  , deserialize+  , printHex+  , putTimestamp+  , merge+  , isTimestampComplete+  , getPendingAttestationsWithMsgs+  , getAttestations+  , getMerkleRoot+  , printTimestamp+  ) where++import Control.Monad (unless, when)+import Crypto.Hash (Digest, SHA256 (SHA256), hashWith)+import Data.Binary.Get (Get, getWord8, isEmpty)+import Data.Binary.Put (Put, putWord8, runPut)+import qualified Data.ByteArray as BA+import qualified Data.ByteString as BS+import qualified Data.Map.Strict as Map+import Data.Serialize (decode)+import qualified Data.Set as Set+import Haskoin.Transaction (Tx)+import OpenTimestamps.Attestation+  ( Attestation (..)+  , getAttestation+  , putAttestation+  )+import OpenTimestamps.Config as Config+import OpenTimestamps.Op+  ( Op (..)+  , execute+  , getOp+  , putOp+  )++import Data.ByteString.Builder (byteStringHex, toLazyByteString)+import Data.Text.Lazy (unpack)+import Data.Text.Lazy.Builder (Builder, fromLazyText, fromString, toLazyText)+import Data.Text.Lazy.Builder.Int (decimal)+import Data.Text.Lazy.Encoding (decodeUtf8)+import OpenTimestamps.Types (OTsByteStream, OTsBytes)++{- | Main structure representing a timestamp.++Contains the message being timestamped, any attestations proving when+it existed, and operations that transform the message to reach attestations.+-}+data Timestamp where+  Timestamp ::+    { timestampMsg :: BS.ByteString+    , attestations :: Set.Set Attestation+    , ops :: Map.Map Op Timestamp+    } ->+    Timestamp+  deriving (Eq, Show, Ord)++-- | Extract transaction ID from raw transaction bytes.+getTxId :: BS.ByteString -> Builder+getTxId rawTx =+  let firstHash = hashWith SHA256 rawTx+      secondHash = hashWith SHA256 (firstHash :: Digest SHA256)+      reversedHash =+        BA.reverse+          (BA.convert (secondHash :: Digest SHA256) :: BS.ByteString)+   in fromLazyText+        . decodeUtf8+        . toLazyByteString+        . byteStringHex+        $ reversedHash++-- | Check if a timestamp is complete (i.e., has a Bitcoin attestation).+isTimestampComplete :: Timestamp -> Bool+isTimestampComplete ts =+  any isBitcoinAttestation (Set.toList ts.attestations)+    || any isTimestampComplete (Map.elems (ops ts))+  where+    isBitcoinAttestation (Bitcoin _) = True+    isBitcoinAttestation _ = False++-- | Get all pending attestations along with their corresponding message digests.+getPendingAttestationsWithMsgs :: Timestamp -> [(BS.ByteString, Attestation)]+getPendingAttestationsWithMsgs ts =+  let directPending =+        [ (timestampMsg ts, att)+        | att@(Pending _) <- Set.toList ts.attestations+        ]+      recursivePending =+        concatMap+          (getPendingAttestationsWithMsgs . snd)+          (Map.toList (ops ts))+   in directPending ++ recursivePending++-- | Get all attestations from a timestamp and its sub-timestamps.+getAttestations :: Timestamp -> [Attestation]+getAttestations ts =+  Set.toAscList ts.attestations+    ++ concatMap (getAttestations . snd) (Map.toAscList (ops ts))++-- | Add all operations and attestations from another timestamp to this one.+merge :: Timestamp -> Timestamp -> (Timestamp, Bool)+merge ts1 ts2 =+  let -- Attestations+      currentAtts = ts1.attestations+      otherAtts = ts2.attestations+      newlyAddedAtts = otherAtts `Set.difference` currentAtts+      mergedAtts = currentAtts `Set.union` otherAtts+      attsChanged = not (Set.null newlyAddedAtts)++      -- Operations+      currentOps = ops ts1+      otherOps = ops ts2++      -- Merge operations and track if any sub-timestamp changed+      (finalOps, opsChanged) =+        Map.foldlWithKey'+          mergeOp+          (currentOps, False)+          otherOps+        where+          mergeOp (accOps, accChanged) op otherSubTs =+            case Map.lookup op accOps of+              Just currentSubTs ->+                let (mergedSubTs, subChanged) = merge currentSubTs otherSubTs+                 in (Map.insert op mergedSubTs accOps, accChanged || subChanged)+              Nothing ->+                -- If op from otherOps is not in accOps, it's a new op, so it's a change+                (Map.insert op otherSubTs accOps, True)++      overallChanged = attsChanged || opsChanged+   in ( ts1+          { attestations = mergedAtts+          , ops = finalOps+          }+      , overallChanged+      )++-- | Deserialize a timestamp from binary format.+deserialize :: OTsBytes -> Get Timestamp+deserialize startMsg = do+  unless (BS.length startMsg < Config.maxTimestampMessageLength) $+    fail "Message too long"++  let mergeTimestamps ts1 ts2 = fst (merge ts1 ts2)++  let doTagOrAttestation tag =+        if tag == 0x00+          then do+            attestation <- getAttestation+            pure $ Timestamp startMsg (Set.singleton attestation) Map.empty+          else do+            op <- getOp tag+            let result = execute op startMsg+            stamp <- deserialize result+            pure $ Timestamp startMsg Set.empty (Map.singleton op stamp)++  let parseRemainingParts currentAcc = do+        isEnd <- isEmpty+        if isEnd+          then pure currentAcc+          else do+            tag <- getWord8+            if tag == 0xff+              then do+                innerTag <- getWord8+                part <- doTagOrAttestation innerTag+                parseRemainingParts (mergeTimestamps currentAcc part)+              else do+                -- This is the last part (already read its tag).+                part <- doTagOrAttestation tag+                pure (mergeTimestamps currentAcc part)++  -- A timestamp serialization is a sequence of forked items followed+  -- by a final item. Or it can be just a single item.+  tag <- getWord8+  if tag /= 0xff+    then do+      -- It's a single, non-forked timestamp+      doTagOrAttestation tag+    else do+      -- It's a forked timestamp. The first real tag follows the 0xff.+      firstTag <- getWord8+      firstPart <- doTagOrAttestation firstTag+      parseRemainingParts firstPart++-- | Serialize a timestamp to binary format.+serialize :: Timestamp -> OTsByteStream+serialize = runPut . putTimestamp++-- | Serialize a timestamp to binary format.+putTimestamp :: Timestamp -> Put+putTimestamp ts = do+  let sortedAtts = Set.toAscList ts.attestations+  let sortedOps = Map.toAscList (ops ts)++  when (null sortedAtts && null sortedOps) $ error "An empty timestamp can't be serialized"++  when (length sortedAtts > 1) $ do+    mapM_+      ( \att -> do+          putWord8 0xff+          putWord8 0x00+          putAttestation att+      )+      (take (length sortedAtts - 1) sortedAtts)++  case (null sortedOps, null sortedAtts) of+    (True, True) -> pure () -- Already handled by initial check+    (True, False) -> do+      -- Only attestations, no ops+      putWord8 0x00+      putAttestation (last sortedAtts)+    (False, True) -> do+      -- Only ops, no attestations+      let allButLastOp = take (length sortedOps - 1) sortedOps+      mapM_+        ( \(op, subTs) -> do+            putWord8 0xff+            putOp op+            putTimestamp subTs+        )+        allButLastOp+      let (lastOp, lastSubTs) = last sortedOps+      putOp lastOp+      putTimestamp lastSubTs+    (False, False) -> do+      -- Both ops and attestations+      putWord8 0xff+      putWord8 0x00+      putAttestation (last sortedAtts)++      let allButLastOp = take (length sortedOps - 1) sortedOps+      mapM_+        ( \(op, subTs) -> do+            putWord8 0xff+            putOp op+            putTimestamp subTs+        )+        allButLastOp+      let (lastOp, lastSubTs) = last sortedOps+      putOp lastOp+      putTimestamp lastSubTs++{- | Recursively applies all operations to the initial message to+compute final Merkle root.+-}+getMerkleRoot :: Timestamp -> BS.ByteString+getMerkleRoot ts =+  case Map.lookupMin (ops ts) of+    Nothing -> ts.timestampMsg+    Just (_, subTs) -> getMerkleRoot subTs++-- | Format a ByteString as hexadecimal.+formatHexDirect :: BS.ByteString -> Builder+formatHexDirect =+  fromLazyText+    . decodeUtf8+    . toLazyByteString+    . byteStringHex++-- | Format a digest as hexadecimal (reversed byte order).+formatDigest :: BS.ByteString -> Builder+formatDigest =+  fromLazyText+    . decodeUtf8+    . toLazyByteString+    . byteStringHex+    . BA.reverse++-- | Convert a ByteString to a hexadecimal string.+printHex :: BS.ByteString -> String+printHex bs = unpack . toLazyText $ formatHexDirect bs++-- | Convert an operation to a string representation.+printOp ::+  Op ->+  Builder+printOp op = case op of+  Append bs -> fromString "append " <> formatHexDirect bs+  Prepend bs -> fromString "prepend " <> formatHexDirect bs+  Sha1 -> fromString "sha1"+  Sha256 -> fromString "sha256"+  Ripemd160 -> fromString "ripemd160"+  Keccak256 -> fromString "keccak256"+  Hexlify -> fromString "hexlify"+  Reverse -> fromString "reverse"++-- | Print an operation with an arrow and indentation.+printOpWithArrow ::+  Int ->+  Timestamp ->+  (Op, Timestamp) ->+  Builder+printOpWithArrow indent parentTs (op, subTs) =+  let prefix = fromString (replicate indent ' ')+      opStr = printOp op+      txIdBuilder = case (decode (timestampMsg parentTs) :: Either String Tx) of+        Right _ ->+          let txId = getTxId (timestampMsg parentTs)+           in prefix <> fromString "* Transaction id " <> txId <> fromString "\n"+        Left _ -> mempty+   in txIdBuilder+        <> prefix+        <> fromString " -> "+        <> opStr+        <> fromString "\n"+        <> printTimestampBuilder (indent + 4) subTs++-- | Convert an attestation to a string representation.+printAttestation ::+  Int ->+  Timestamp ->+  Attestation ->+  Builder+printAttestation indent ts att =+  let prefix = fromString (replicate indent ' ')+   in case att of+        Bitcoin blockHeight ->+          prefix+            <> fromString "verify BitcoinBlockHeaderAttestation("+            <> decimal blockHeight+            <> fromString ")\n"+            <> prefix+            <> fromString "# Bitcoin block merkle root "+            <> formatDigest (getMerkleRoot ts)+            <> fromString "\n"+        Pending uri ->+          prefix+            <> fromString "verify PendingAttestation("+            <> fromString (show uri)+            <> fromString ")\n"+        Unknown w bs ->+          prefix+            <> fromString "unknown_attestation "+            <> formatHexDirect w+            <> fromString " "+            <> formatHexDirect bs+            <> fromString "\n"++-- | Build a string representation of a timestamp.+printTimestampBuilder :: Int -> Timestamp -> Builder+printTimestampBuilder indent ts =+  let attsBuilder =+        foldMap+          (printAttestation indent ts)+          (Set.toAscList (attestations ts))+      opsList = Map.toAscList (ops ts)+   in attsBuilder <> case opsList of+        [] -> mempty+        [(op, subTs)] ->+          let prefix = fromString (replicate indent ' ')+              opStr = printOp op+              txIdBuilder = case (decode (timestampMsg ts) :: Either String Tx) of+                Right _ ->+                  let txId = getTxId (timestampMsg ts)+                   in prefix <> fromString "# Transaction id " <> txId <> fromString "\n"+                Left _ -> mempty+           in txIdBuilder+                <> prefix+                <> opStr+                <> fromString "\n"+                <> printTimestampBuilder indent subTs+        _ -> foldMap (printOpWithArrow indent ts) opsList++-- | Convert a timestamp to a string representation with indentation.+printTimestamp :: Int -> Timestamp -> String+printTimestamp indent ts =+  unpack . toLazyText $+    printTimestampBuilder indent ts

+ src/OpenTimestamps/Types.hs view

@@ -0,0 +1,19 @@+{- | Type definitions for OpenTimestamps.++This module provides type aliases used throughout the OpenTimestamps+library for strict and lazy ByteStrings, ensuring consistent+naming and usage across all modules.+-}+module OpenTimestamps.Types+  ( OTsBytes+  , OTsByteStream+  ) where++import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy.Char8 as BSL++-- | Strict ByteString used for OpenTimestamps operations.+type OTsBytes = BS.ByteString++-- | Lazy ByteString used for OpenTimestamps streaming operations.+type OTsByteStream = BSL.ByteString

+ src/OpenTimestamps/Upgrade.hs view

@@ -0,0 +1,213 @@+{-# LANGUAGE OverloadedStrings #-}++{- | Timestamp upgrade functionality for OpenTimestamps.++This module provides functions to upgrade incomplete timestamps+by fetching additional attestations from calendar servers+and merging them into existing timestamp structures.+-}+module OpenTimestamps.Upgrade+  ( fetchTimestampFromCalendar+  , mergeIntoSubTimestamp+  , upgradeTimestamp+  ) where++import Control.Exception as E (SomeException, try)+import Control.Monad (foldM)+import Data.Binary.Get (runGetOrFail)+import qualified Data.ByteString.Base16 as B16+import qualified Data.ByteString.Lazy as BSL+import Data.Either (rights)+import Data.Function ((&))+import qualified Data.Map.Strict as Map+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import Network.HTTP.Client (Request, Response)+import Network.HTTP.Simple+  ( getResponseBody+  , getResponseStatusCode+  , httpLBS+  , parseRequest+  , setRequestHeader+  , setRequestMethod+  )+import OpenTimestamps.Attestation (Attestation (..))+import OpenTimestamps.Config as Config+import OpenTimestamps.Prune ()+import OpenTimestamps.Timestamp+  ( Timestamp (..)+  , deserialize+  , getPendingAttestationsWithMsgs+  , isTimestampComplete+  , merge+  )+import OpenTimestamps.Types (OTsBytes)++-- | Fetch an upgraded timestamp from a calendar server.+fetchTimestampFromCalendar ::+  T.Text ->+  OTsBytes ->+  IO (Either String Timestamp)+fetchTimestampFromCalendar+  calendarUrl+  msg = do+    let hexMsg = TE.decodeUtf8 $ B16.encode msg+    let fullUrl = T.unpack calendarUrl ++ Config.apiUrlTimeStamp ++ T.unpack hexMsg+    putStrLn $ "Fetching from: " ++ fullUrl+    eRequest <- try (parseRequest fullUrl) :: IO (Either SomeException Request)+    case eRequest of+      Left ex -> do+        let errMsg = "Error parsing request: " ++ show ex+        putStrLn $ "Request error: " ++ errMsg+        pure $ Left errMsg+      Right request -> do+        let getRequest =+              request+                & setRequestMethod "GET"+                & setRequestHeader "User-Agent" [Config.userAgent]+                & setRequestHeader "Accept" [Config.accept]+        eResponse <- try (httpLBS getRequest) :: IO (Either SomeException (Response BSL.ByteString))+        case eResponse of+          Left ex -> do+            let errMsg = "HTTP request failed: " ++ show ex+            putStrLn $ "HTTP error: " ++ errMsg+            pure $ Left errMsg+          Right response -> do+            let statusCode = getResponseStatusCode response+            let body = getResponseBody response+            putStrLn $ "Response status: " ++ show statusCode+            if statusCode == 200+              then do+                case runGetOrFail (deserialize msg) body of+                  Left (_, _, err) -> do+                    let errMsg = "Deserialization error: " ++ err+                    putStrLn $ "Deserialization error: " ++ errMsg+                    pure $ Left errMsg+                  Right (_, _, ts) -> do+                    putStrLn "Successfully deserialized timestamp."+                    pure $ Right ts+              else+                if statusCode == 404+                  then do+                    putStrLn "Commitment not found on calendar."+                    pure $ Left "Commitment not found on calendar."+                  else do+                    let errMsg = "Server returned HTTP " ++ show statusCode ++ ": " ++ show body+                    putStrLn $ "Server error: " ++ errMsg+                    pure $ Left errMsg++{- | Merge an upgraded timestamp into the existing timestamp tree at+the correct location.+-}+mergeIntoSubTimestamp ::+  OTsBytes ->+  Timestamp ->+  Timestamp ->+  (Timestamp, Bool)+mergeIntoSubTimestamp+  targetMsg+  currentTs+  newTs+    | timestampMsg currentTs == targetMsg = merge currentTs newTs+    | otherwise =+        let (opsChanged, updatedOps) =+              Map.mapAccumWithKey+                ( \changedAcc _op subTs ->+                    let (mergedSubTs, subChanged) =+                          mergeIntoSubTimestamp+                            targetMsg+                            subTs+                            newTs+                     in (changedAcc || subChanged, mergedSubTs)+                )+                False+                (ops currentTs)+         in (currentTs {ops = updatedOps}, opsChanged)++{- | Process a single pending attestation, attempting to fetch+upgrades and merge them.+-}+processSinglePendingAttestation ::+  [T.Text] ->+  (Timestamp, Bool) ->+  (OTsBytes, Attestation) ->+  IO (Timestamp, Bool)+processSinglePendingAttestation+  calendarUrls+  (accTs, accFoundNew)+  (msg, att) = case att of+    Pending uri -> do+      let urlsToTry = if null calendarUrls then [uri] else calendarUrls+      putStrLn $+        "  Attempting to fetch for message "+          ++ show (B16.encode msg)+          ++ " from "+          ++ show urlsToTry+      upgradedTsM <- mapM (`fetchTimestampFromCalendar` msg) urlsToTry+      let successfulUpgrades = rights upgradedTsM+      if null successfulUpgrades+        then do+          putStrLn "  No successful upgrades from calendars."+          pure (accTs, accFoundNew)+        else do+          putStrLn $+            "  Successfully fetched "+              ++ show (length successfulUpgrades)+              ++ " upgrades."++          let (mergedTsForThisAtt, changedInThisAtt) =+                foldl+                  ( \(tsAcc, changedAcc) upgradedTs ->+                      let (resTs, resChanged) = mergeIntoSubTimestamp msg tsAcc upgradedTs+                       in (resTs, changedAcc || resChanged)+                  )+                  (accTs, False)+                  successfulUpgrades+          pure (mergedTsForThisAtt, changedInThisAtt)+    _ -> pure (accTs, accFoundNew)++{- | Attempt to upgrade an incomplete timestamp to make it verifiable.+Returns upgraded timestamp.+-}+upgradeTimestamp ::+  [T.Text] ->+  Timestamp ->+  IO (Either String Timestamp)+upgradeTimestamp+  calendarUrls+  initialTs = do+    upgrade 0 calendarUrls initialTs+    where+      -- TODO Safeguard against infinite loops (?) Practical nesting (?)+      -- appears to be around 3 deep, in actual examples)+      maxIterations = Config.upgradeMaxIterations+      -- \| Recursively upgrade a timestamp with iteration limit.+      upgrade :: Int -> [T.Text] -> Timestamp -> IO (Either String Timestamp)+      upgrade iterationCount currentCalendarUrls currentTs+        | isTimestampComplete currentTs = do+            putStrLn $ "Upgrade complete after " ++ show iterationCount ++ " iterations."+            pure $ Right currentTs+        | iterationCount >= maxIterations = do+            putStrLn $ "Upgrade stopped after " ++ show maxIterations ++ " iterations (max iterations reached)."+            pure $ Right currentTs+        | otherwise = do+            putStrLn $ "Upgrade iteration: " ++ show (iterationCount + 1)+            let pendingAtts = getPendingAttestationsWithMsgs currentTs+            putStrLn $ "Found " ++ show (length pendingAtts) ++ " pending attestations."+            if null pendingAtts+              then do+                putStrLn "No pending attestations found, stopping upgrade."+                pure $ Left "No pending attestations"+              else do+                (newlyMergedTs, foundNewAttestations) <-+                  foldM+                    (processSinglePendingAttestation currentCalendarUrls)+                    (currentTs, False)+                    pendingAtts+                if foundNewAttestations+                  then do+                    putStrLn "New attestations found, continuing upgrade."+                    upgrade (iterationCount + 1) currentCalendarUrls newlyMergedTs+                  else do+                    putStrLn "No new attestations found."+                    pure $ Left "No attestations merged"

+ src/OpenTimestamps/VarInt.hs view

@@ -0,0 +1,64 @@+{- | Variable-length integer encoding for OpenTimestamps.++This module provides functions for reading and writing variable-length+integers and byte arrays as used in the OpenTimestamps protocol.+-}+module OpenTimestamps.VarInt+  ( getVarBytes+  , putVarBytes+  , getVarInt+  , putVarInt+  ) where++import Data.Binary.Get+  ( Get+  , getByteString+  , getWord8+  )+import Data.Binary.Put (Put, putByteString, putWord8)+import Data.Bits (shiftL, shiftR, (.&.), (.|.))+import qualified Data.ByteString as BS++-- | Read variable-length bytes with length limits.+getVarBytes :: Int -> Int -> Get BS.ByteString+getVarBytes maxLen minLen = do+  len <- getVarInt+  if len > maxLen+    then fail $ "varbytes max length exceeded; " ++ show len ++ " > " ++ show maxLen+    else+      if len < minLen+        then fail $ "varbytes min length not met; " ++ show len ++ " < " ++ show minLen+        else getByteString len++-- | Read a variable-length integer.+getVarInt :: Get Int+getVarInt = getVarInt' 0 0+  where+    -- \| Helper function to recursively read variable-length integer.+    getVarInt' acc shift = do+      byte <- getWord8+      let val = fromIntegral (byte .&. 0x7f)+      let newAcc = acc .|. (val `shiftL` shift)+      if (byte .&. 0x80) == 0+        then pure newAcc+        else getVarInt' newAcc (shift + 7)++-- | Write variable-length bytes with length prefix.+putVarBytes :: BS.ByteString -> Put+putVarBytes bs = do+  putVarInt (BS.length bs)+  putByteString bs++-- | Write a variable-length integer.+putVarInt :: Int -> Put+putVarInt n+  | n == 0 = putWord8 0x00+  | otherwise = putVarInt' n+  where+    -- \| Helper function to recursively write variable-length integer.+    putVarInt' i = do+      let byte = fromIntegral (i .&. 0x7f)+      let rest = i `shiftR` 7+      if rest > 0+        then putWord8 (byte .|. 0x80) >> putVarInt' rest+        else putWord8 byte

+ src/OpenTimestamps/Verify.hs view

@@ -0,0 +1,219 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE OverloadedStrings #-}++{- | Timestamp verification functionality for OpenTimestamps.++This module provides functions to verify timestamps against+Bitcoin blockchain, including error handling, Bitcoin node+communication, and detached timestamp file verification.+-}+module OpenTimestamps.Verify+  ( VerificationError (..)+  , BitcoinConfig (..)+  , verifyDetachedTimestampFile+  ) where++import Bitcoin.Core.RPC+  ( BitcoindException (..)+  , BlockHeader (..)+  , getBlockHash+  , getBlockHeader+  , runBitcoind+  )+import Control.Exception (Exception)+import Control.Monad.IO.Class (liftIO)+import Data.Binary.Put (runPut)+import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BS8+import Data.ByteString.Lazy (toStrict)+import Data.Bytes.Serial (serialize)+import Data.Function ((&))+import qualified Data.Text as T+import Data.Time.Clock (UTCTime)+import Data.Word (Word32)+import Network.HTTP.Client+  ( Manager+  , defaultManagerSettings+  , managerResponseTimeout+  , newManager+  , responseTimeoutMicro+  )+import OpenTimestamps.Attestation (Attestation (..))+import OpenTimestamps.Config as Config+import OpenTimestamps.DetachedTimestampFile+  ( DetachedTimestampFile (..)+  , timestamp+  )+import OpenTimestamps.Timestamp+  ( Timestamp (..)+  , getAttestations+  , getMerkleRoot+  , isTimestampComplete+  )+import OpenTimestamps.Types (OTsBytes)+import OpenTimestamps.Upgrade (upgradeTimestamp)+import Servant.API (BasicAuthData (..))+import System.IO (hPutStrLn, stderr)++-- | Custom error type for verification failures.+data VerificationError where+  DigestMismatch :: VerificationError+  MerkleRootMismatch :: VerificationError+  IncorrectBlockHeight :: VerificationError+  BitcoinNodeError :: String -> VerificationError+  AttestationVerificationFailed :: String -> VerificationError+  NoVerifiableAttestation :: VerificationError+  OtherVerificationError :: String -> VerificationError+  deriving (Show, Eq)++instance Exception VerificationError++-- | Configuration for connecting to a Bitcoin node.+data BitcoinConfig where+  BitcoinConfig ::+    { bitcoinHost :: String+    , bitcoinPort :: Int+    , bitcoinUser :: String+    , bitcoinPass :: String+    } ->+    BitcoinConfig+  deriving (Show, Eq)++-- | Fetches a Bitcoin block header by height using the bitcoind-rpc client.+fetchBlockHeader ::+  Manager ->+  BitcoinConfig ->+  Int ->+  IO (Either VerificationError BlockHeader)+fetchBlockHeader+  manager+  config+  height = do+    let authData =+          BasicAuthData+            (BS8.pack config.bitcoinUser)+            (BS8.pack config.bitcoinPass)+    eResult <- liftIO $+      runBitcoind manager config.bitcoinHost config.bitcoinPort authData $ do+        blockHash <- getBlockHash (fromIntegral height)+        getBlockHeader blockHash+    case eResult of+      Left (ClientException err) ->+        "Bitcoin RPC client error: " ++ show err+          & BitcoinNodeError+          & Left+          & pure+      Left (RpcException msg) ->+        "Bitcoin RPC error: " ++ msg+          & BitcoinNodeError+          & Left+          & pure+      Left (DecodingError err) ->+        "Bitcoin RPC decoding error: " ++ err+          & BitcoinNodeError+          & Left+          & pure+      Right blockHeader ->+        pure $ Right blockHeader++{- | Verify a BitcoinBlockHeaderAttestation against a Bitcoin block+header. Beware: Bitcoin RPC uses 'little-endian' and OpenTimestamps+uses 'big-endian' (hence `BS.reverse`).+-}+verifyBitcoinBlockHeaderAttestation ::+  ByteString ->+  Word32 ->+  BlockHeader ->+  Either VerificationError (Int, UTCTime)+verifyBitcoinBlockHeaderAttestation+  commitment+  height+  blockHeader+    | BS.length commitment /= 32 =+        Left+          ( AttestationVerificationFailed+              ("Expected commitment with length 32 bytes; got " ++ show (BS.length commitment) ++ " bytes")+          )+    | commitment /= BS.reverse (toStrict (runPut (serialize (blockHeaderMerkleRoot blockHeader)))) =+        Left MerkleRootMismatch+    | height /= blockHeaderHeight blockHeader =+        Left IncorrectBlockHeight+    | otherwise =+        Right (fromIntegral height, blockHeaderTime blockHeader)++-- | Verify a Timestamp by upgrading it and checking its attestations.+verifyTimestamp ::+  BitcoinConfig ->+  [T.Text] ->+  Timestamp ->+  IO (Either VerificationError (Int, UTCTime))+verifyTimestamp+  bitcoinConfig+  calendarUrls+  initialTs = do+    let managerSettings =+          defaultManagerSettings+            { managerResponseTimeout =+                responseTimeoutMicro Config.bitcoinRpcTimeoutMicroseconds -- TODO hardcoded...+            }+    manager <- newManager managerSettings+    eUpgradedTs <- upgradeTimestamp calendarUrls initialTs+    case eUpgradedTs of+      -- TODO This is not neccesarilily a fail... (e.g. temporarily unreachable calendar servers)+      Left err -> do+        hPutStrLn stderr err+        -- pure $ Left (OtherVerificationError err)+        verifyTimestamp' manager initialTs+      Right upgradedTs -> verifyTimestamp' manager upgradedTs+    where+      -- \| Check if an attestation is a Bitcoin block header attestation.+      isBitcoinBlockHeaderAttestation (Bitcoin _) = True+      isBitcoinBlockHeaderAttestation _ = False+      verifyTimestamp' m ts = do+        if not (isTimestampComplete ts)+          then+            pure $ Left NoVerifiableAttestation+          else do+            let atts = getAttestations ts+            -- Prioritize BitcoinBlockHeaderAttestation for verification+            case filter isBitcoinBlockHeaderAttestation atts of+              [] -> pure $ Left NoVerifiableAttestation+              (Bitcoin height : _) -> do+                eBlockHeader <- fetchBlockHeader m bitcoinConfig (fromIntegral height)+                print $ "eBlockHeader: " ++ show eBlockHeader+                case eBlockHeader of+                  Left err ->+                    pure $ Left err+                  Right blockHeader ->+                    let actualMerkleRoot = getMerkleRoot ts+                     in case verifyBitcoinBlockHeaderAttestation+                          actualMerkleRoot+                          height+                          blockHeader of+                          Left err ->+                            pure $ Left err+                          Right (blockHeight, attestedTime) ->+                            pure $ Right (blockHeight, attestedTime)+              _ -> pure $ Left NoVerifiableAttestation++-- | Verify a DetachedTimestampFile.+verifyDetachedTimestampFile ::+  BitcoinConfig ->+  [T.Text] ->+  DetachedTimestampFile ->+  OTsBytes ->+  IO (Either VerificationError (Int, UTCTime))+verifyDetachedTimestampFile+  bitcoinConfig+  calendarUrls+  dtf+  targetDigest = do+    let fileDigest = timestampMsg dtf.timestamp+    let ts = dtf.timestamp+    if fileDigest /= targetDigest+      then+        pure $ Left DigestMismatch+      else+        verifyTimestamp bitcoinConfig calendarUrls ts

+ test/Arbitrary.hs view

@@ -0,0 +1,132 @@+{-# LANGUAGE GADTs #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Arbitrary+  ( Arbitrary (..),+    arbitrarySizedByteString+  ) where++import Bitcoin.Core.RPC (BlockHeader (..))+import qualified Data.ByteString as BS+import qualified Data.Map.Strict as Map+import qualified Data.Set as Set+import Data.Time.Clock.POSIX (posixSecondsToUTCTime)+import Data.Word (Word32)+import Haskoin.Block.Common (BlockHash (..))+import Haskoin.Crypto.Hash (sha256)+import OpenTimestamps.Attestation (Attestation (..))+import OpenTimestamps.DetachedTimestampFile+  ( DetachedTimestampFile (..)+  , DigestType (..)+  )+import OpenTimestamps.Op+import OpenTimestamps.Timestamp (Timestamp (..))+import Test.QuickCheck+  ( Arbitrary (..)+  , Gen+  , choose+  , elements+  , listOf+  , oneof+  , resize+  , sized+  , vectorOf+  )+import qualified Data.Text as T++instance Arbitrary Op where+  arbitrary =+    oneof+      [ pure Sha1+      , pure Sha256+      , pure Ripemd160+      , pure Keccak256+      , pure Hexlify+      , pure Reverse+      , Append <$> arbitraryBS+      , Prepend <$> arbitraryBS+      ]+    where+      arbitraryBS :: Gen BS.ByteString+      arbitraryBS = BS.pack <$> vectorOf 10 arbitrary++instance Arbitrary Attestation where+  arbitrary =+    oneof+      [ Bitcoin <$> arbitrary+      , Pending . T.pack <$> listOf (elements ['a'..'z'])+      , Unknown <$> arbitrarySizedByteString (1, 8) <*> arbitrarySizedByteString (0, 32)+      ]++instance Arbitrary Timestamp where+  arbitrary = sized arbitraryTimestamp+    where+      arbitraryTimestamp :: Int -> Gen Timestamp+      arbitraryTimestamp n+        | n <= 0 =+            Timestamp+              <$> arbitrarySizedByteString (1, 32)+              <*> (Set.fromList <$> listOf arbitrary)+              <*> pure Map.empty+        | otherwise =+            oneof+              [ Timestamp+                  <$> arbitrarySizedByteString (1, 32)+                  <*> (Set.fromList <$> listOf arbitrary)+                  <*> pure Map.empty+              , Timestamp+                  <$> arbitrarySizedByteString (1, 32)+                  <*> (Set.fromList <$> listOf arbitrary)+                  <*> (Map.fromList <$> listOf ((,) <$> arbitrary <*> resize (n `div` 2) (arbitraryTimestamp (n `div` 2))))+              ]++instance Arbitrary DetachedTimestampFile where+  arbitrary = do+    digestType' <- arbitrary+    timestamp' <- arbitrary+    pure $ DetachedTimestampFile+      { digestType = digestType'+      , timestamp = timestamp'+      }++instance Arbitrary DigestType where+  arbitrary = elements [DSha256, DSha1, DRipemd160]++instance Arbitrary BlockHash where+  arbitrary = BlockHash . sha256 <$> arbitrarySizedByteString (32, 32)++instance Arbitrary BlockHeader where+  arbitrary = do+    hash <- arbitrary+    confs <- choose (0 :: Word32, 1000 :: Word32)+    height <- choose (0 :: Word32, 1000000 :: Word32)+    merkleRoot <- sha256 <$> arbitrarySizedByteString (32, 32)+    time <- posixSecondsToUTCTime . fromIntegral <$> (choose (0, 2147483647) :: Gen Word32)+    medianTime <- posixSecondsToUTCTime . fromIntegral <$> (choose (0, 2147483647) :: Gen Word32)+    nonce <- arbitrary+    difficulty <- arbitrary+    txCount <- choose (0 :: Int, 10000 :: Int)+    prevHash <- oneof [pure Nothing, Just <$> arbitrary]+    nextHash <- oneof [pure Nothing, Just <$> arbitrary]+    pure $ BlockHeader+      { blockHeaderHash = hash+      , blockHeaderConfs = confs+      , blockHeaderHeight = height+      , blockHeaderMerkleRoot = merkleRoot+      , blockHeaderTime = time+      , blockHeaderMedianTime = medianTime+      , blockHeaderNonce = nonce+      , blockHeaderDifficulty = difficulty+      , blockHeaderTxCount = txCount+      , blockHeaderPrevHash = prevHash+      , blockHeaderNextHash = nextHash+      }++instance Arbitrary BS.ByteString where+  arbitrary = arbitrarySizedByteString (1, 32)++-- | Helper to generate a ByteString of a specific size range.+arbitrarySizedByteString :: (Int, Int) -> Gen BS.ByteString+arbitrarySizedByteString (minSize, maxSize) = do+  size <- choose (minSize, maxSize)+  BS.pack <$> vectorOf size arbitrary

+ test/PruneSpec.hs view

@@ -0,0 +1,252 @@+{-# LANGUAGE OverloadedStrings #-}++module PruneSpec (spec) where++import Arbitrary ()+import qualified Data.Map.Strict as Map+import qualified Data.Set as Set+import OpenTimestamps.Attestation (Attestation (Bitcoin, Pending))+import OpenTimestamps.Op (Op (Append, Prepend, Sha256))+import OpenTimestamps.Prune (pruneTimestamp)+import OpenTimestamps.Timestamp (Timestamp (..), getAttestations, isTimestampComplete)+import Test.Hspec+import Test.QuickCheck++spec :: Spec+spec = describe "OpenTimestamps.Prune" $ do+  it "prunes a simple timestamp with redundant Bitcoin attestations" $ do+    let initialTs =+          Timestamp+            { timestampMsg = "msg1"+            , attestations = Set.fromList [Bitcoin 100, Bitcoin 200, Pending "http://example.com"]+            , ops = Map.empty+            }+    let expectedTs =+          Timestamp+            { timestampMsg = "msg1"+            , attestations = Set.fromList [Bitcoin 100, Pending "http://example.com"]+            , ops = Map.empty+            }+    pruneTimestamp initialTs `shouldBe` expectedTs++  it "prunes a timestamp with redundant Bitcoin attestations in sub-timestamps" $ do+    let subTs1 =+          Timestamp+            { timestampMsg = "subMsg1"+            , attestations = Set.fromList [Bitcoin 300, Pending "http://calendar1.org"]+            , ops = Map.empty+            }+    let subTs2 =+          Timestamp+            { timestampMsg = "subMsg2"+            , attestations = Set.fromList [Bitcoin 100, Pending "http://calendar2.org"]+            , ops = Map.empty+            }+    let initialTs =+          Timestamp+            { timestampMsg = "msg1"+            , attestations = Set.fromList [Bitcoin 200]+            , ops = Map.fromList [(Sha256, subTs1), (Append "data", subTs2)]+            }+    let expectedTs =+          Timestamp+            { timestampMsg = "msg1"+            , attestations = Set.fromList [] -- Bitcoin 200 is suboptimal, removed+            , ops =+                Map.fromList+                  [+                    ( Sha256+                    , Timestamp+                        { timestampMsg = "subMsg1"+                        , attestations = Set.fromList [Pending "http://calendar1.org"]+                        , ops = Map.empty+                        }+                    )+                  ,+                    ( Append "data"+                    , Timestamp+                        { timestampMsg = "subMsg2"+                        , attestations = Set.fromList [Bitcoin 100, Pending "http://calendar2.org"]+                        , ops = Map.empty+                        }+                    )+                  ]+            }+    pruneTimestamp initialTs `shouldBe` expectedTs++  it "prunes a timestamp with empty branches" $ do+    let emptyTs =+          Timestamp+            { timestampMsg = "emptyMsg"+            , attestations = Set.empty+            , ops = Map.empty+            }+    let subTs =+          Timestamp+            { timestampMsg = "subMsg"+            , attestations = Set.fromList [Pending "http://calendar.org"]+            , ops = Map.singleton Sha256 emptyTs+            }+    let initialTs =+          Timestamp+            { timestampMsg = "msg1"+            , attestations = Set.empty+            , ops = Map.singleton (Append "data") subTs+            }+    let expectedTs =+          Timestamp+            { timestampMsg = "msg1"+            , attestations = Set.empty+            , ops =+                Map.singleton+                  (Append "data")+                  ( Timestamp+                      { timestampMsg = "subMsg"+                      , attestations = Set.fromList [Pending "http://calendar.org"]+                      , ops = Map.empty -- EmptyTs should be pruned+                      }+                  )+            }+    pruneTimestamp initialTs `shouldBe` expectedTs++  it "prunes a complex timestamp with multiple redundant Bitcoin attestations and empty branches" $ do+    let subSubTs1 =+          Timestamp+            { timestampMsg = "subSubMsg1"+            , attestations = Set.fromList [Bitcoin 500]+            , ops = Map.empty+            }+    let subSubTs2 =+          Timestamp+            { timestampMsg = "subSubMsg2"+            , attestations = Set.fromList [Bitcoin 50]+            , ops = Map.empty+            }+    let subTs1 =+          Timestamp+            { timestampMsg = "subMsg1"+            , attestations = Set.fromList [Bitcoin 400, Pending "http://cal1.org"]+            , ops = Map.singleton Sha256 subSubTs1+            }+    let subTs2 =+          Timestamp+            { timestampMsg = "subMsg2"+            , attestations = Set.fromList [Pending "http://cal2.org"]+            , ops = Map.singleton (Prepend "prefix") subSubTs2+            }+    let initialTs =+          Timestamp+            { timestampMsg = "msg1"+            , attestations = Set.fromList [Bitcoin 1000, Pending "http://cal0.org"]+            , ops = Map.fromList [(Append "data1", subTs1), (Append "data2", subTs2)]+            }+    let expectedTs =+          Timestamp+            { timestampMsg = "msg1"+            , attestations = Set.fromList [Pending "http://cal0.org"]+            , ops =+                Map.fromList+                  [+                    ( Append "data1"+                    , Timestamp+                        { timestampMsg = "subMsg1"+                        , attestations = Set.fromList [Pending "http://cal1.org"]+                        , ops = Map.empty -- Sha256 op and subSubTs1 removed+                        }+                    )+                  ,+                    ( Append "data2"+                    , Timestamp+                        { timestampMsg = "subMsg2"+                        , attestations = Set.fromList [Pending "http://cal2.org"]+                        , ops =+                            Map.fromList+                              [+                                ( Prepend "prefix"+                                , Timestamp+                                    { timestampMsg = "subSubMsg2"+                                    , attestations = Set.fromList [Bitcoin 50]+                                    , ops = Map.empty+                                    }+                                )+                              ]+                        }+                    )+                  ]+            }+    pruneTimestamp initialTs `shouldBe` expectedTs++  it "prunes a timestamp with Bitcoin attestations of same height but different depths" $ do+    let subTs =+          Timestamp+            { timestampMsg = "subMsg"+            , attestations = Set.fromList [Bitcoin 100, Pending "http://calendar.org"]+            , ops = Map.empty+            }+    let initialTs =+          Timestamp+            { timestampMsg = "msg1"+            , attestations = Set.fromList [Bitcoin 100]+            , ops = Map.singleton Sha256 subTs+            }+    let expectedTs =+          Timestamp+            { timestampMsg = "msg1"+            , attestations = Set.fromList [Bitcoin 100] -- This Bitcoin 100 is at depth 0, better than subMsg's Bitcoin 100 at depth 1+            , ops =+                Map.singleton+                  Sha256+                  ( Timestamp+                      { timestampMsg = "subMsg"+                      , attestations = Set.fromList [Pending "http://calendar.org"]+                      , ops = Map.empty+                      }+                  )+            }+    pruneTimestamp initialTs `shouldBe` expectedTs++  it "prunes a timestamp with no Bitcoin attestations" $ do+    let subTs =+          Timestamp+            { timestampMsg = "subMsg"+            , attestations = Set.fromList [Pending "http://calendar.org"]+            , ops = Map.empty+            }+    let initialTs =+          Timestamp+            { timestampMsg = "msg1"+            , attestations = Set.fromList [Pending "http://example.com"]+            , ops = Map.singleton Sha256 subTs+            }+    let expectedTs =+          Timestamp+            { timestampMsg = "msg1"+            , attestations = Set.fromList [Pending "http://example.com"]+            , ops = Map.singleton Sha256 subTs+            }+    pruneTimestamp initialTs `shouldBe` expectedTs++  describe "pruneTimestamp properties" $ do+    it "preserves completeness" $+      quickCheck propPrunePreservesCompleteness+    it "reduces size appropriately" $+      quickCheck propPruneReducesSize+    it "is idempotent" $+      quickCheck propPruneIdempotent++-- | Pruning should preserve timestamp completeness+propPrunePreservesCompleteness :: Timestamp -> Bool+propPrunePreservesCompleteness ts =+  isTimestampComplete (pruneTimestamp ts) == isTimestampComplete ts++-- | Pruning should reduce or maintain the number of attestations+propPruneReducesSize :: Timestamp -> Bool+propPruneReducesSize ts =+  let originalAtts = getAttestations ts+      prunedAtts = getAttestations (pruneTimestamp ts)+   in length prunedAtts <= length originalAtts++-- | Pruning should be idempotent+propPruneIdempotent :: Timestamp -> Bool+propPruneIdempotent ts =+  pruneTimestamp (pruneTimestamp ts) == pruneTimestamp ts

+ test/Spec.hs view

@@ -0,0 +1,474 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}++{-# HLINT ignore "Use lambda-case" #-}++module Spec (main) where++import qualified PruneSpec+import qualified UpgradeSpec+import qualified VerifySpec++import Arbitrary ()+import Data.Binary.Get (runGet, runGetOrFail)+import Data.Binary.Put (runPut)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Base16 as B16+import qualified Data.ByteString.Char8 as BSC+import qualified Data.ByteString.Lazy as BSL+import Data.List (isPrefixOf)+import qualified Data.Map.Strict as Map+import qualified Data.Set as Set+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import qualified OpenTimestamps as OTS+import OpenTimestamps.Attestation (Attestation (..))+import OpenTimestamps.DetachedTimestampFile+  ( DetachedTimestampFile+  )+import qualified OpenTimestamps.DetachedTimestampFile as DTSF+  ( deserialize+  , digestLen+  , digestType+  , serialize+  , timestamp+  )+import OpenTimestamps.Op as Op+  ( Op (Append, Hexlify, Keccak256, Prepend, Reverse, Ripemd160, Sha1, Sha256)+  , execute+  , getOp+  , opToTag+  , putOp+  )+import OpenTimestamps.Timestamp as TS+  ( Timestamp (..)+  , deserialize+  , getAttestations+  , getMerkleRoot+  , getPendingAttestationsWithMsgs+  , isTimestampComplete+  , merge+  , serialize+  )+import qualified OpenTimestamps.Upgrade as Upgrade+import System.FilePath ((</>))+import System.Random (newStdGen, randomRs)+import Test.Hspec+  ( Spec+  , describe+  , expectationFailure+  , hspec+  , it+  , shouldBe+  , shouldSatisfy+  )+import Test.QuickCheck+  ( quickCheck+  )++main :: IO ()+main = hspec spec++{-+calendarUrls :: [String]+calendarUrls =+  [ "https://a.pool.opentimestamps.org"+  , "https://b.pool.opentimestamps.org"+  , "https://a.pool.eternitywall.com"+  , "https://ots.btc.catallaxy.com"+  ]+-}++spec :: Spec+spec = do+  let examplesDir = "examples"+  describe "stamp" $ do+    it "creates a timestamp with the correct structure" $ do+      let originalDigest = "\x00\x01\x02\x03\x04\x05\x06\x07\x08\x09\x0a\x0b\x0c\x0d\x0e\x0f"+      let nonce = "\x10\x11\x12\x13\x14\x15\x16\x17\x18\x19\x1a\x1b\x1c\x1d\x1e\x1f"+      let appendedDigest = originalDigest <> nonce+      let submissionDigest = "\x20\x21\x22\x23\x24\x25\x26\x27\x28\x29\x2a\x2b\x2c\x2d\x2e\x2f"++      let serverTimestamp = TS.Timestamp {TS.timestampMsg = submissionDigest, TS.attestations = mempty, TS.ops = mempty}++      let expectedTimestamp =+            TS.Timestamp+              { TS.timestampMsg = originalDigest+              , TS.attestations = mempty+              , TS.ops =+                  Map.singleton (Op.Append nonce) $+                    TS.Timestamp+                      { TS.timestampMsg = appendedDigest+                      , TS.attestations = mempty+                      , TS.ops = Map.singleton Op.Sha256 serverTimestamp+                      }+              }++      TS.timestampMsg expectedTimestamp `shouldBe` originalDigest++      case Map.toList (TS.ops expectedTimestamp) of+        [(Op.Append nonce', intermediateTimestamp)] -> do+          nonce' `shouldBe` nonce+          TS.timestampMsg intermediateTimestamp `shouldBe` appendedDigest+          case Map.toList (TS.ops intermediateTimestamp) of+            [(Op.Sha256, finalTimestamp)] -> do+              TS.timestampMsg finalTimestamp `shouldBe` submissionDigest+            _ -> expectationFailure "Expected a Sha256 operation"+        _ -> expectationFailure "Expected an Append operation"++    it "stamps random content and verifies the resulting OTS file using internal info" $ do+      -- Generate random content+      gen <- newStdGen+      let randomBytes = BSC.pack $ take 32 $ randomRs ('a', 'z') gen+      let randomContent = BSL.fromStrict randomBytes++      -- Stamp the random content+      let calendarUrl = "https://a.pool.opentimestamps.org"+      stampResult <- OTS.stamp [calendarUrl] (BSL.toStrict randomContent)++      -- Verify no errors and a timestamp file is returned+      OTS.srErrors stampResult `shouldBe` []+      OTS.srTimestampFile stampResult+        `shouldSatisfy` (\x -> case x of Just _ -> True; Nothing -> False)++      -- Extract and serialize the DetachedTimestampFile+      case OTS.srTimestampFile stampResult of+        Just otsFile -> do+          let serializedOts = DTSF.serialize otsFile+          let infoResult = OTS.info serializedOts+          infoResult `shouldSatisfy` either (const False) (const True)+        Nothing -> expectationFailure "No timestamp file returned by stamp operation"+  describe "OpenTimestamps.Op" $ do+    it "can be round-tripped" $+      quickCheck propRoundtripOp+    it "hash operations are idempotent" $+      quickCheck propHashIdempotent+    it "operations compose consistently" $+      quickCheck propOpComposition+    it "length is preserved for non-appending operations" $+      quickCheck propLengthPreservation++  describe "OpenTimestamps.Timestamp" $ do+    it "serialization is round-trip" $+      quickCheck propTimestampRoundTrip+    it "serialization is deterministic" $+      quickCheck propSerializationDeterministic+    it "message is preserved through serialization" $+      quickCheck propMessagePreservation+    it "merge is idempotent" $+      quickCheck propMergeIdempotent+    it "merge is commutative" $+      quickCheck propMergeCommutative+    it "merge accumulates attestations" $+      quickCheck propMergeAttestationAccumulation+    it "merkle root is consistent with operations" $+      quickCheck propMerkleRootConsistency+    it "merkle root is deterministic" $+      quickCheck propMerkleRootDeterministic+    it "completeness depends only on Bitcoin attestations" $+      quickCheck propCompletenessBitcoinDetection+    it "completeness propagates from sub-timestamps" $+      quickCheck propCompletenessNested++  describe "OpenTimestamps.DetachedTimestampFile" $ do+    it "serialization is round-trip" $+      quickCheck propDetachedFileRoundTrip+    it "digest type consistency" $+      quickCheck propDigestTypeConsistency++  describe "OpenTimestamps.Attestation" $ do+    it "collection is complete" $+      quickCheck propAttestationCollectionComplete+    it "collection has no duplicates" $+      quickCheck propAttestationCollectionUnique+    it "pending attestations are correctly filtered" $+      quickCheck propPendingAttestationFiltering+    it "all attestation types are handled" $+      quickCheck propAttestationTypeDistribution++  describe "OpenTimestamps" $ do+    let otsFiles =+          [ "bad-stamp.txt.ots"+          , "bitcoin.pdf.ots"+          , "different-blockchains.txt.ots"+          , "empty.ots"+          , "hello-world.txt.ots"+          , "incomplete.txt.ots"+          , "invalid/bad-major-version.ots"+          , "invalid/exceeds-max-msg-length.ots"+          , "invalid/invalid-file-digest-type.ots"+          , "known-and-unknown-notary.txt.ots"+          , "merkle1.txt.ots"+          , "merkle2.txt.ots"+          , "merkle3.txt.ots"+          , "sha1/a-or-b.ots"+          , "two-calendars.txt.ots"+          , "unknown-notary.txt.ots"+          ]+    mapM_+      ( \otsFile ->+          it ("info parses " ++ otsFile) $ do+            otsFileContent <- BSL.readFile (examplesDir </> otsFile)+            let result = OTS.info otsFileContent+            if "invalid/" `isPrefixOf` otsFile+              then result `shouldSatisfy` either (const True) (const False)+              else result `shouldSatisfy` either (const False) (const True)+      )+      otsFiles++  describe "upgrade" $ do+    it "upgrades an incomplete example timestamp from a calendar" $ do+      let otsFile = examplesDir </> "incomplete.txt.ots"+      otsFileContent <- BSL.readFile otsFile+      -- let calendarUrl = "https://alice.btc.calendar.opentimestamps.org"+      -- result <- OTS.upgrade calendarUrls otsFileContent+      -- result <- OTS.upgrade [calendarUrl] otsFileContent+      result <- OTS.upgrade [] otsFileContent+      case result of+        Left err -> expectationFailure $ "Upgrade failed: " ++ err+        Right upgradedOtsContent -> do+          let deserializedResult = OTS.info upgradedOtsContent+          case deserializedResult of+            Left err -> expectationFailure $ "Failed to deserialize upgraded OTS: " ++ err+            Right dtfs -> do+              TS.isTimestampComplete (DTSF.timestamp dtfs) `shouldBe` True+              putStrLn $ "\nLength of example upgradedOtsContent: " ++ show (BSL.length upgradedOtsContent)+              putStrLn $+                "First 100 bytes of example upgradedOtsContent: " ++ show (BSL.take 100 upgradedOtsContent)++  describe "fetchTimestampFromCalendar" $ do+    it "fetches a complete timestamp to upgrade from a calendar" $ do+      let calendarUrl = "https://alice.btc.calendar.opentimestamps.org"+      let msgHex = "57cfa5c46716df9bd9e83595bce439c58108d8fcc1678f30d4c6731c3f1fa6c79ed712c66fb1ac8d4e4eb0e7"+      let msg = case B16.decode $ TE.encodeUtf8 msgHex of+            Left err -> error $ "Failed to decode hex: " ++ err+            Right bs -> bs+      result <- Upgrade.fetchTimestampFromCalendar (T.pack calendarUrl) msg+      case result of+        Left err -> expectationFailure $ "fetchTimestampFromCalendar failed: " ++ err+        Right ts ->+          TS.isTimestampComplete ts `shouldBe` True++  PruneSpec.spec+  UpgradeSpec.spec+  VerifySpec.spec++propRoundtripOp :: Op -> Bool+propRoundtripOp op =+  let serialized = runPut (putOp op)+      tag = opToTag op+      deserialized = runGet (getOp tag) (BSL.drop 1 serialized)+   in deserialized == op++-- | Hash operations should be idempotent (applying twice gives same result)+propHashIdempotent :: Op -> BS.ByteString -> Bool+propHashIdempotent op input =+  case op of+    Sha1 -> execute op (execute op input) == execute op input+    Sha256 -> execute op (execute op input) == execute op input+    Ripemd160 -> execute op (execute op input) == execute op input+    Keccak256 -> execute op (execute op input) == execute op input+    _ -> True -- Skip non-hash operations++-- | Operations should compose consistently+propOpComposition :: Op -> Op -> BS.ByteString -> Bool+propOpComposition op1 op2 input =+  let result1 = execute op2 (execute op1 input)+      result2 = execute op1 (execute op2 input)+   in -- For commutative operations, results should be the same+      -- For non-commutative, we just check they're both valid+      case (op1, op2) of+        (Reverse, Reverse) -> result1 == result2 -- Double reverse should be identity+        (Append _, Prepend _) -> True -- Different append/prepend order gives different results+        (Prepend _, Append _) -> True -- Different append/prepend order gives different results+        _ -> BS.length result1 == BS.length result2 -- Same length for same type operations++-- | Length preservation for operations that shouldn't change length+propLengthPreservation :: Op -> BS.ByteString -> Bool+propLengthPreservation op input =+  case op of+    Sha1 -> BS.length (execute op input) == 20 -- SHA1 produces 20 bytes+    Sha256 -> BS.length (execute op input) == 32 -- SHA256 produces 32 bytes+    Ripemd160 -> BS.length (execute op input) == 20 -- RIPEMD160 produces 20 bytes+    Keccak256 -> BS.length (execute op input) == 32 -- Keccak256 produces 32 bytes+    Hexlify -> BS.length (execute op input) == BS.length input * 2 -- Hexlify doubles length+    Reverse -> BS.length (execute op input) == BS.length input -- Reverse preserves length+    Append bs -> BS.length (execute op input) == BS.length input + BS.length bs -- Append adds length+    Prepend bs -> BS.length (execute op input) == BS.length input + BS.length bs -- Prepend adds length++-- | Check if a timestamp tree contains any empty timestamps+hasEmptyTimestamps :: Timestamp -> Bool+hasEmptyTimestamps ts =+  (Set.null (TS.attestations ts) && Map.null (TS.ops ts))+    || any hasEmptyTimestamps (Map.elems (TS.ops ts))++-- | Timestamp serialization round-trip property+propTimestampRoundTrip :: Timestamp -> Bool+propTimestampRoundTrip ts =+  -- Skip timestamps that contain empty sub-timestamps+  hasEmptyTimestamps ts+    || ( let serialized = TS.serialize ts+             deserialized = TS.deserialize (TS.timestampMsg ts)+          in case runGetOrFail deserialized serialized of+               Left _ -> False+               Right (_, _, result) -> result == ts+       )++-- | Serialization should be deterministic (same timestamp always serializes the same way)+propSerializationDeterministic :: Timestamp -> Bool+propSerializationDeterministic ts =+  -- Skip timestamps that contain empty sub-timestamps+  hasEmptyTimestamps ts+    || ( let ser1 = TS.serialize ts+             ser2 = TS.serialize ts+          in ser1 == ser2+       )++-- | The root message should be preserved through serialization cycles+propMessagePreservation :: Timestamp -> Bool+propMessagePreservation ts =+  -- Skip timestamps that contain empty sub-timestamps+  hasEmptyTimestamps ts+    || ( let serialized = TS.serialize ts+             deserialized = TS.deserialize (TS.timestampMsg ts)+          in case runGetOrFail deserialized serialized of+               Left _ -> False+               Right (_, _, result) ->+                 TS.timestampMsg result == TS.timestampMsg ts+       )++-- | Merge operation should be idempotent+propMergeIdempotent :: Timestamp -> Bool+propMergeIdempotent ts =+  let (merged, changed) = TS.merge ts ts+   in merged == ts && not changed++-- | Merge operation should be commutative+propMergeCommutative :: Timestamp -> Timestamp -> Bool+propMergeCommutative ts1 ts2 =+  let (merged1, _) = TS.merge ts1 ts2+      (merged2, _) = TS.merge ts2 ts1+   in merged1 == merged2++-- | Merge should accumulate all unique attestations+propMergeAttestationAccumulation :: Timestamp -> Timestamp -> Bool+propMergeAttestationAccumulation ts1 ts2 =+  let (merged, _) = TS.merge ts1 ts2+      originalAtts = Set.union (TS.attestations ts1) (TS.attestations ts2)+   in TS.attestations merged == originalAtts++-- | DetachedTimestampFile serialization round-trip property+propDetachedFileRoundTrip :: DetachedTimestampFile -> Bool+propDetachedFileRoundTrip dtf =+  -- Skip files with empty timestamps that can't be serialized+  hasEmptyTimestamps (DTSF.timestamp dtf)+    || let serialized = DTSF.serialize dtf+           deserialized = DTSF.deserialize serialized+        in case deserialized of+             Left _ -> False+             Right result -> result == dtf++-- | Digest type should be consistent with message length+propDigestTypeConsistency :: DetachedTimestampFile -> Bool+propDigestTypeConsistency dtf =+  let msg = TS.timestampMsg (DTSF.timestamp dtf)+      expectedLen = DTSF.digestLen (DTSF.digestType dtf)+   in BS.length msg == expectedLen++-- | Merkle root should be consistent with timestamp operations+propMerkleRootConsistency :: Timestamp -> Bool+propMerkleRootConsistency ts =+  -- Skip empty timestamps+  -- The merkle root should be the result of applying all operations to the root message+  -- For now, just check that it's deterministic for the same timestamp+  hasEmptyTimestamps ts || (getMerkleRoot ts == getMerkleRoot ts)++-- | Merkle root should be deterministic for identical timestamps+propMerkleRootDeterministic :: Timestamp -> Bool+propMerkleRootDeterministic ts =+  -- Skip empty timestamps+  hasEmptyTimestamps ts || (getMerkleRoot ts == getMerkleRoot ts)++-- | Completeness should depend only on Bitcoin attestations+propCompletenessBitcoinDetection :: Timestamp -> Bool+propCompletenessBitcoinDetection ts =+  -- Skip empty timestamps+  hasEmptyTimestamps ts+    || (isTimestampComplete ts == any isBitcoinAttestation (getAttestations ts))+  where+    isBitcoinAttestation (Bitcoin _) = True+    isBitcoinAttestation _ = False++-- | Completeness should propagate from sub-timestamps+propCompletenessNested :: Timestamp -> Bool+propCompletenessNested ts =+  -- Skip empty timestamps+  -- A timestamp is complete if any sub-timestamp is complete+  hasEmptyTimestamps ts+    || (isTimestampComplete ts == any isTimestampComplete (ts : allSubTimestamps ts))+  where+    allSubTimestamps t = concatMap (allSubTimestamps . snd) (Map.toList (TS.ops t))++-- | All attestations in the tree are collected+propAttestationCollectionComplete :: Timestamp -> Bool+propAttestationCollectionComplete ts =+  -- Skip empty timestamps+  hasEmptyTimestamps ts+    || let collected = getAttestations ts+           allAtts = collectAllAttestations ts+        in length collected == length allAtts+             && all (`elem` collected) allAtts++-- | No duplicate attestations in collection+propAttestationCollectionUnique :: Timestamp -> Bool+propAttestationCollectionUnique ts =+  let collected = getAttestations ts+      deduplicated = Set.toList $ Set.fromList collected+   in length collected == length deduplicated++-- | Pending attestations are correctly filtered and paired+propPendingAttestationFiltering :: Timestamp -> Bool+propPendingAttestationFiltering ts =+  let pendingPairs = getPendingAttestationsWithMsgs ts+      allAtts = getAttestations ts+      pendingAtts = filter isPending allAtts+   in length pendingPairs == length pendingAtts+        && all+          ( \(msg, att) ->+              isPending att+                && any (\ts' -> TS.timestampMsg ts' == msg) (allTimestamps ts)+          )+          pendingPairs++-- | All attestation types are handled+propAttestationTypeDistribution :: Timestamp -> Bool+propAttestationTypeDistribution ts =+  let allAtts = getAttestations ts+      hasBitcoin = any isBitcoin allAtts+      hasPending = any isPending allAtts+      hasUnknown = any isUnknown allAtts+   in -- At least one type should be present if there are attestations+      (null allAtts || (hasBitcoin || hasPending || hasUnknown))++-- Helper functions for attestation property tests++-- | Recursively collect all attestations from timestamp tree+collectAllAttestations :: Timestamp -> [Attestation]+collectAllAttestations ts =+  Set.toList (TS.attestations ts)+    ++ concatMap (collectAllAttestations . snd) (Map.toList $ TS.ops ts)++-- | Get all timestamps in the tree+allTimestamps :: Timestamp -> [Timestamp]+allTimestamps ts = ts : concatMap (allTimestamps . snd) (Map.toList $ TS.ops ts)++-- | Type predicates+isBitcoin, isPending, isUnknown :: Attestation -> Bool+isBitcoin (Bitcoin _) = True+isBitcoin _ = False+isPending (Pending _) = True+isPending _ = False+isUnknown (Unknown _ _) = True+isUnknown _ = False

+ test/UpgradeSpec.hs view

@@ -0,0 +1,103 @@+{-# LANGUAGE OverloadedStrings #-}++module UpgradeSpec (spec) where++import Arbitrary ()+import Control.Applicative (Alternative ((<|>)))+import qualified Data.ByteString as BS+import qualified Data.Map.Strict as Map+import Data.Maybe (fromMaybe)+import qualified Data.Set as Set+import OpenTimestamps.Attestation (Attestation (Unknown))+import OpenTimestamps.Op ()+import OpenTimestamps.Timestamp (Timestamp (..), merge)+import OpenTimestamps.Upgrade (mergeIntoSubTimestamp)+import Test.Hspec (Spec, describe, it, shouldBe)+import Test.QuickCheck+  ( Arbitrary (arbitrary)+  , Gen+  , Testable (property)+  , discard+  , elements+  , forAll+  , suchThat+  )++getAllMessages :: Timestamp -> Set.Set BS.ByteString+getAllMessages ts = Set.insert (timestampMsg ts) (foldMap getAllMessages (Map.elems (ops ts)))++genTargetMsgInTimestamp :: Timestamp -> Gen BS.ByteString+genTargetMsgInTimestamp ts = do+  let allMsgs = getAllMessages ts+  if Set.null allMsgs+    then arbitrary -- Should not happen with valid Timestamp generation, but as a fallback+    else elements (Set.toList allMsgs)++findTimestamp :: BS.ByteString -> Timestamp -> Maybe Timestamp+findTimestamp target ts+  | timestampMsg ts == target = Just ts+  | otherwise =+      foldr+        ( \(_op, subTs) acc ->+            findTimestamp target subTs <|> acc+        )+        Nothing+        (Map.toList (ops ts))++spec :: Spec+spec = do+  describe "mergeIntoSubTimestamp" $ do+    it "returns True if targetMsg is found and merged with new information" $ property $ \currentTs ->+      forAll (genTargetMsgInTimestamp currentTs) $ \targetMsg ->+        forAll arbitrary $ \newAtt ->+          -- Ensure newAtt is not already in the sub-timestamp at targetMsg+          let subTs = fromMaybe currentTs (findTimestamp targetMsg currentTs) -- Fallback+              uniqueAtt = if Set.member newAtt (attestations subTs) then Unknown "" "" else newAtt+              newTs = Timestamp targetMsg (Set.singleton uniqueAtt) Map.empty+              (_, changed) = mergeIntoSubTimestamp targetMsg currentTs newTs+           in changed `shouldBe` True++    it "returns False if targetMsg is not found" $ property $ \currentTs newTs ->+      forAll (suchThat arbitrary (\msg -> not (Set.member msg (getAllMessages currentTs)))) $ \targetMsg ->+        let (_, changed) = mergeIntoSubTimestamp targetMsg currentTs newTs+         in changed `shouldBe` False++    it "merges correctly when targetMsg matches root" $ property $ \currentTs newTs ->+      let targetMsg = timestampMsg currentTs+          (mergedTs, _) = mergeIntoSubTimestamp targetMsg currentTs newTs+       in do+            mergedTs `shouldBe` fst (merge currentTs newTs)+            pure ()++    it "preserves structure for unaffected parts" $ property $ \currentTs newTs ->+      forAll (genTargetMsgInTimestamp currentTs) $ \targetMsg ->+        if targetMsg == timestampMsg currentTs+          then discard -- Covered by "merges correctly when targetMsg matches root"+          else+            let (mergedTs, _) = mergeIntoSubTimestamp targetMsg currentTs newTs+             in do+                  timestampMsg mergedTs `shouldBe` timestampMsg currentTs+                  attestations mergedTs `shouldBe` attestations currentTs++{- TODO This fails intermittently, disable for now & investigate later+it "returns False for changed flag if newTs adds no new information at target" $ property $ \currentTs ->+  forAll (genTargetMsgInTimestamp currentTs) $ \targetMsg ->+    -- Ensure targetMsg is unique in currentTs for this test+    let allMsgs = getAllMessages currentTs+        countTargetMsg = length $ filter (== targetMsg) (Set.toList allMsgs)+     in if countTargetMsg > 1+          then discard+          else case findTimestamp targetMsg currentTs of+            Just subTsToMerge -> do+              -- Verify `merge` itself is idempotent for identical timestamps+              let (mergedSelf, selfChanged) = merge subTsToMerge subTsToMerge+              selfChanged `shouldBe` False+              mergedSelf `shouldBe` subTsToMerge++              -- Now, for the overall mergeIntoSubTimestamp:+              -- If the sub-timestamp at targetMsg is merged with an identical one,+              -- the overall 'changed' flag should be False.+              let (_, overallChanged) = mergeIntoSubTimestamp targetMsg currentTs subTsToMerge+              overallChanged `shouldBe` False+            Nothing -> discard -- Should not happen with genTargetMsgInTimestamp+-}

+ test/VerifySpec.hs view

@@ -0,0 +1,108 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}++module VerifySpec (spec) where++import qualified Data.ByteString as BS+import qualified Data.ByteString.Base16 as B16+import qualified Data.ByteString.Char8 as BS8+import qualified Data.ByteString.Lazy as BSL+import qualified Data.Text as T+import qualified Data.Text.IO as TIO+import Data.Time.Format (defaultTimeLocale, formatTime)+import Data.Time.LocalTime (TimeZone (..), utcToZonedTime)+import qualified OpenTimestamps.DetachedTimestampFile as DTSF+import OpenTimestamps.Verify+  ( BitcoinConfig (..)+  , verifyDetachedTimestampFile+  )+import System.Directory (doesFileExist, getHomeDirectory)+import System.FilePath ((</>))+import System.IO (hPutStrLn, stderr)+import Test.Hspec+  ( Spec+  , describe+  , expectationFailure+  , it+  , shouldSatisfy+  )++-- | RPC credentials for Bitcoin node+data RPCCredentials where+  RPCCredentials ::+    { rpcUser :: T.Text+    , rpcPassword :: T.Text+    } ->+    RPCCredentials+  deriving (Show, Eq)++-- | Reads RPC credentials from a Bitcoin cookie file+readCookieFile :: FilePath -> IO (Maybe RPCCredentials)+readCookieFile path = do+  exists <- doesFileExist path+  if exists+    then do+      content <- TIO.readFile path+      case T.splitOn (T.pack ":") content of+        [user, pass] -> pure $ Just $ RPCCredentials user pass+        _ -> pure Nothing+    else do+      hPutStrLn stderr $ "Cookie file not found at: " ++ path+      pure Nothing++getBitcoinConfig :: IO BitcoinConfig+getBitcoinConfig = do+  homeDir <- getHomeDirectory+  let cookieFilePath = homeDir </> ".bitcoin" </> ".cookie"+  mrpcc <- readCookieFile cookieFilePath+  config <- case mrpcc of+    Nothing -> do+      hPutStrLn+        stderr+        "Error: Bitcoin cookie file not found. A local Bitcoin node is required for this test to work."+      hPutStrLn stderr $ "Expected cookie file at: " ++ cookieFilePath+      pure $+        BitcoinConfig+          { bitcoinHost = "localhost"+          , bitcoinPort = 8332+          , bitcoinUser = "testuser"+          , bitcoinPass = "testpass"+          }+    Just rpcc ->+      pure $+        BitcoinConfig+          { bitcoinHost = "localhost"+          , bitcoinPort = 8332+          , bitcoinUser = T.unpack $ rpcUser rpcc+          , bitcoinPass = T.unpack $ rpcPassword rpcc+          }+  putStrLn $ "Using Bitcoin Config: " ++ show config+  pure config++spec :: Spec+spec = describe "OpenTimestamps.Verify" $ do+  describe "verifyDetachedTimestampFile with incomplete.txt.ots" $ do+    it "should indicate verify success for incomplete.txt.ots" $ do+      otsFileContent <- BS.readFile "examples/incomplete.txt.ots"+      let dtsfEither = DTSF.deserialize (BSL.fromStrict otsFileContent)+      case dtsfEither of+        Left err -> expectationFailure $ "Failed to deserialize OTS file: " ++ err+        Right dtsf -> do+          let fileHash = B16.decodeLenient (BS8.pack "05c4f616a8e5310d19d938cfd769864d7f4ccdc2ca8b479b10af83564b097af9")+          let calendarUrls = [] -- No calendar URLs needed for this test+          bitcoinConfig <- getBitcoinConfig++          result <- verifyDetachedTimestampFile bitcoinConfig calendarUrls dtsf fileHash+          case result of+            Right (blockHeight, utcTime) -> do+              -- TODO Hardcoded CEST (UTC+2), so -2 hours from UTC+              let zonedTime = utcToZonedTime (TimeZone (-(1 * 60 * 4)) False "CEST") utcTime+              let formattedTime = formatTime defaultTimeLocale "%Y-%m-%d %H:%M:%S %Z" zonedTime+              putStrLn $+                "Success! Bitcoin block " ++ show blockHeight ++ " attests existence as of " ++ formattedTime+            _ -> putStrLn "Failed"+          result+            `shouldSatisfy` ( \case+                                Right _ -> True+                                _ -> False+                            )