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