{-# 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