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