{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
module OpenTimestampsClient
( info
, prune
, stamp
, upgrade
, verify
) where
import Control.Monad (unless, when)
import Crypto.Hash (SHA256 (SHA256), hashWith)
import qualified Data.ByteArray as BA
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy.Char8 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 as OT
import qualified OpenTimestamps.DetachedTimestampFile as DTSF
import OpenTimestamps.Timestamp (printHex, printTimestamp, timestampMsg)
import qualified OpenTimestamps.Verify as Verify
import System.Directory (doesFileExist, renameFile)
import System.FilePath (addExtension, stripExtension, takeDirectory)
import System.IO (hClose, hPutStrLn, stderr)
import System.IO.Temp (withTempFile)
data RPCCredentials where
RPCCredentials ::
{rpcUser :: T.Text, rpcPassword :: T.Text} ->
RPCCredentials
deriving (Show, Eq)
readCookieFile :: FilePath -> IO (Maybe RPCCredentials)
readCookieFile path = do
exists <- doesFileExist path
if exists
then do
content <- TIO.readFile path
case T.splitOn ":" content of
[user, pass] -> return $ Just $ RPCCredentials user pass
_ -> return Nothing
else do
hPutStrLn stderr $ "Cookie file not found at: " ++ path
return Nothing
info :: FilePath -> IO ()
info path =
processStream =<< BSL.readFile path
where
processStream otsFileContent = case DTSF.deserialize otsFileContent of
Left err ->
putStrLn $ "Error deserializing: " ++ show err
Right dtfs -> do
putStrLn $
"File sha256 hash: "
++ printHex
( timestampMsg
(DTSF.timestamp dtfs)
)
putStrLn "Timestamp:"
putStrLn $ printTimestamp 0 (DTSF.timestamp dtfs)
prune :: Bool -> FilePath -> [String] -> [String] -> IO ()
prune verbose path verifyArgs discardArgs = do
when verbose $ putStrLn $ "Reading timestamp file: " ++ path
otsFileContent <- BSL.readFile path
when verbose $ putStrLn $ "Pruning timestamp: " ++ path
result <- OT.prune verifyArgs discardArgs otsFileContent
case result of
Left err -> do
hPutStrLn stderr $ "Error pruning timestamp: " ++ err
Right newOtsContent -> do
let dir = takeDirectory path
let tmpFileName = path ++ ".tmp"
tmpExists <- doesFileExist tmpFileName
when tmpExists $
fail $
"Intermediate temporary file " ++ tmpFileName ++ " already exists"
let bakFileName = path ++ ".bak"
bakExists <- doesFileExist bakFileName
when bakExists $
fail $
"Backup file " ++ bakFileName ++ " already exists"
withTempFile
dir
tmpFileName
( \tempPath tempHandle -> do
BSL.hPutStr tempHandle newOtsContent
hClose tempHandle
renameFile path bakFileName
renameFile tempPath path
putStrLn $ "Timestamp pruned and saved to " ++ path
)
stamp :: Bool -> [FilePath] -> [String] -> IO ()
stamp verbose paths calendarUrls = do
mapM_ stampOne paths
where
stampOne path = do
let newOtsPath = addExtension path ".ots"
exists <- doesFileExist newOtsPath
when exists $
fail $
"Failed to create timestamp '" ++ newOtsPath ++ "' (file already exists)."
when verbose $ putStrLn $ "Reading content of: " ++ path
content <- BS.readFile path
-- TODO Use OpenTimestamps library function (t.b.d.) with type.
let digest = BA.convert (hashWith SHA256 content)
when verbose $ putStrLn $ "Stamping: " ++ path
sr <- OT.stamp calendarUrls digest
-- TODO Nicer error formatting.
let errors = OT.srErrors sr
if verbose
then mapM_ print errors
else
unless (null errors) $
hPutStrLn stderr "There were calender servers with errors (use global option -v for details)"
case OT.srTimestampFile sr of
Nothing -> hPutStrLn stderr "No timestamps could be retrieved"
Just dtsf -> do
let dtfsNew = OT.serialize dtsf
BSL.writeFile newOtsPath dtfsNew
putStrLn $ "Timestamp saved to " ++ newOtsPath
upgrade :: Bool -> FilePath -> IO ()
upgrade verbose path = do
when verbose $ putStrLn $ "Reading timestamp file: " ++ path
otsFileContent <- BSL.readFile path
when verbose $ putStrLn $ "Upgrading timestamp: " ++ path
-- TODO The `[]` is for calendarUrls (what to do with them?)
result <- OT.upgrade [] otsFileContent
case result of
Left err -> do
hPutStrLn stderr $ "Error upgrading timestamp: " ++ err
Right newOtsContent -> do
let dir = takeDirectory path
let tmpFileName = path ++ ".tmp"
tmpExists <- doesFileExist tmpFileName
when tmpExists $ fail $ "Intermediate temporary file " ++ tmpFileName ++ " already exists"
let bakFileName = path ++ ".bak"
bakExists <- doesFileExist bakFileName
when bakExists $ fail $ "Backup file " ++ bakFileName ++ " already exists"
withTempFile
dir
tmpFileName
( \tempPath tempHandle -> do
BSL.hPutStr tempHandle newOtsContent
hClose tempHandle
renameFile path bakFileName
renameFile tempPath path
putStrLn $ "Timestamp upgraded and saved to " ++ path
)
verify :: Bool -> FilePath -> IO ()
verify verbose path = do
let cookieFilePath = "/home/mdo/.bitcoin/.cookie"
mrpcc <- readCookieFile cookieFilePath
let bitcoinConfig = case mrpcc of
Nothing ->
Verify.BitcoinConfig
{ Verify.bitcoinHost = "localhost"
, Verify.bitcoinPort = 8332
, Verify.bitcoinUser = "bitcoin"
, Verify.bitcoinPass = "bitcoinpass"
}
Just rpcc ->
Verify.BitcoinConfig
{ Verify.bitcoinHost = "localhost"
, Verify.bitcoinPort = 8332
, Verify.bitcoinUser = T.unpack $ rpcUser rpcc
, Verify.bitcoinPass = T.unpack $ rpcPassword rpcc
}
print $ "Cookiefile path: " ++ cookieFilePath
-- print $ "User: " ++ Verify.bitcoinUser bitcoinConfig
-- print $ "Password: " ++ Verify.bitcoinPass bitcoinConfig
case stripExtension ".ots" path of
Nothing -> hPutStrLn stderr $ "Not a timestamp? " ++ path
Just srcPath -> do
content <- BS.readFile srcPath
let digest = BA.convert (hashWith SHA256 content)
when verbose $ putStrLn $ "Reading timestamp file: " ++ path
otsFileContent <- BSL.readFile path
when verbose $ putStrLn $ "Verifying timestamp: " ++ path
-- TODO The `[]` is for calendarUrls (what to do with them?)
result <- OT.verify bitcoinConfig [] otsFileContent digest
case result of
Right (blockHeight, utcTime) -> do
let zonedTime = utcToZonedTime (TimeZone (-(1 * 60 * 4)) False "CEST") utcTime -- TODO Assuming CEST is UTC+2, so -2 hours from UTC
let formattedTime = formatTime defaultTimeLocale "%Y-%m-%d %H:%M:%S %Z" zonedTime
putStrLn $
"Success! Bitcoin block " ++ show blockHeight ++ " attests existence as of " ++ formattedTime
Left err -> putStrLn $ "Failed " ++ show err