{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
module Network.Haskoin.Store.Data where
import Conduit
import Data.Aeson as A
import Data.ByteString (ByteString)
import qualified Data.ByteString as B
import Data.Hashable
import Data.Int
import Data.Maybe
import Data.Serialize as S
import Data.String.Conversions
import Data.Time.Clock.System
import Data.Word
import GHC.Generics
import Haskoin
import Network.Socket (SockAddr)
import UnliftIO.Exception
type UnixTime = Int64
newtype InitException = IncorrectVersion Word32
deriving (Show, Read, Eq, Ord, Exception)
class StoreRead r m where
isInitialized :: r -> m (Either InitException Bool)
getBestBlock :: r -> m (Maybe BlockHash)
getBlocksAtHeight :: r -> BlockHeight -> m [BlockHash]
getBlock :: r -> BlockHash -> m (Maybe BlockData)
getTransaction :: r -> TxHash -> m (Maybe Transaction)
getBalance :: r -> Address -> m Balance
class StoreStream r m where
getMempool :: r -> ConduitT () (PreciseUnixTime, TxHash) m ()
getAddressUnspents :: r -> Address -> ConduitT () Unspent m ()
getAddressTxs :: r -> Address -> ConduitT () AddressTx m ()
class StoreWrite w m where
setInit :: w -> m ()
setBest :: w -> BlockHash -> m ()
insertBlock :: w -> BlockData -> m ()
insertAtHeight :: w -> BlockHash -> BlockHeight -> m ()
insertTx :: w -> Transaction -> m ()
setBalance :: w -> Balance -> m ()
insertAddrTx :: w -> AddressTx -> m ()
removeAddrTx :: w -> AddressTx -> m ()
insertAddrUnspent :: w -> Address -> Unspent -> m ()
removeAddrUnspent :: w -> Address -> Unspent -> m ()
insertMempoolTx :: w -> TxHash -> PreciseUnixTime -> m ()
deleteMempoolTx :: w -> TxHash -> PreciseUnixTime -> m ()
newtype PreciseUnixTime = PreciseUnixTime Word64
deriving (Show, Eq, Read, Generic, Ord, Hashable, Serialize)
preciseUnixTime :: SystemTime -> PreciseUnixTime
preciseUnixTime s =
PreciseUnixTime . fromIntegral $
(systemSeconds s * 1000) +
(fromIntegral (systemNanoseconds s) `div` (1000 * 1000))
instance ToJSON PreciseUnixTime where
toJSON (PreciseUnixTime w) = toJSON w
toEncoding (PreciseUnixTime w) = toEncoding w
data BlockRef
= BlockRef { blockRefHeight :: !BlockHeight
, blockRefPos :: !Word32
}
| MemRef { memRefTime :: !PreciseUnixTime }
deriving (Show, Read, Eq, Ord, Generic, Serialize, Hashable)
blockRefPairs :: A.KeyValue kv => BlockRef -> [kv]
blockRefPairs BlockRef {blockRefHeight = h, blockRefPos = p} =
["height" .= h, "position" .= p]
blockRefPairs MemRef {memRefTime = t} = ["mempool" .= t]
confirmed :: BlockRef -> Bool
confirmed BlockRef {} = True
confirmed MemRef {} = False
instance ToJSON BlockRef where
toJSON = object . blockRefPairs
toEncoding = pairs . mconcat . blockRefPairs
data AddressTx = AddressTx
{ addressTxAddress :: !Address
, addressTxBlock :: !BlockRef
, addressTxHash :: !TxHash
} deriving (Show, Eq, Ord, Generic, Serialize, Hashable)
addressTxPairs :: A.KeyValue kv => Network -> AddressTx -> [kv]
addressTxPairs net atx =
[ "address" .= addrToJSON net (addressTxAddress atx)
, "txid" .= addressTxHash atx
, "block" .= addressTxBlock atx
]
addressTxToJSON :: Network -> AddressTx -> Value
addressTxToJSON net = object . addressTxPairs net
addressTxToEncoding :: Network -> AddressTx -> Encoding
addressTxToEncoding net = pairs . mconcat . addressTxPairs net
data Balance = Balance
{ balanceAddress :: !Address
, balanceAmount :: !Word64
, balanceZero :: !Int64
, balanceCount :: !Word64
} deriving (Show, Read, Eq, Ord, Generic, Serialize, Hashable)
balancePairs :: A.KeyValue kv => Network -> Balance -> [kv]
balancePairs net ab =
[ "address" .= addrToJSON net (balanceAddress ab)
, "confirmed" .= balanceAmount ab
, "unconfirmed" .= balanceZero ab
, "utxo" .= balanceCount ab
]
balanceToJSON :: Network -> Balance -> Value
balanceToJSON net = object . balancePairs net
balanceToEncoding :: Network -> Balance -> Encoding
balanceToEncoding net = pairs . mconcat . balancePairs net
data Unspent = Unspent
{ unspentBlock :: !BlockRef
, unspentAmount :: !Word64
, unspentScript :: !ByteString
, unspentPoint :: !OutPoint
} deriving (Show, Eq, Ord, Generic, Serialize, Hashable)
unspentPairs :: A.KeyValue kv => Network -> Unspent -> [kv]
unspentPairs net u =
[ "address" .=
eitherToMaybe (addrToJSON net <$> scriptToAddressBS (unspentScript u))
, "block" .= unspentBlock u
, "txid" .= outPointHash (unspentPoint u)
, "index" .= outPointIndex (unspentPoint u)
, "pkscript" .= String (encodeHex (unspentScript u))
, "value" .= unspentAmount u
]
unspentToJSON :: Network -> Unspent -> Value
unspentToJSON net = object . unspentPairs net
unspentToEncoding :: Network -> Unspent -> Encoding
unspentToEncoding net = pairs . mconcat . unspentPairs net
data BlockData = BlockData
{ blockDataHeight :: !BlockHeight
, blockDataMainChain :: !Bool
, blockDataWork :: !BlockWork
, blockDataHeader :: !BlockHeader
, blockDataSize :: !Word32
, blockDataTxs :: ![TxHash]
} deriving (Show, Read, Eq, Ord, Generic, Serialize, Hashable)
blockDataPairs :: A.KeyValue kv => BlockData -> [kv]
blockDataPairs bv =
[ "hash" .= headerHash (blockDataHeader bv)
, "height" .= blockDataHeight bv
, "mainchain" .= blockDataMainChain bv
, "previous" .= prevBlock (blockDataHeader bv)
, "time" .= blockTimestamp (blockDataHeader bv)
, "version" .= blockVersion (blockDataHeader bv)
, "bits" .= blockBits (blockDataHeader bv)
, "nonce" .= bhNonce (blockDataHeader bv)
, "size" .= blockDataSize bv
, "tx" .= blockDataTxs bv
]
instance ToJSON BlockData where
toJSON = object . blockDataPairs
toEncoding = pairs . mconcat . blockDataPairs
data Input
= Coinbase { inputPoint :: !OutPoint
, inputSequence :: !Word32
, inputSigScript :: !ByteString
, inputWitness :: !(Maybe WitnessStack)
}
| Input { inputPoint :: !OutPoint
, inputSequence :: !Word32
, inputSigScript :: !ByteString
, inputPkScript :: !ByteString
, inputAmount :: !Word64
, inputWitness :: !(Maybe WitnessStack)
}
deriving (Show, Read, Eq, Ord, Generic, Serialize, Hashable)
isCoinbase :: Input -> Bool
isCoinbase Coinbase {} = True
isCoinbase Input {} = False
inputPairs :: A.KeyValue kv => Network -> Input -> [kv]
inputPairs net Input { inputPoint = OutPoint oph opi
, inputSequence = sq
, inputSigScript = ss
, inputPkScript = ps
, inputAmount = val
, inputWitness = wit
} =
[ "coinbase" .= False
, "txid" .= oph
, "output" .= opi
, "sigscript" .= String (encodeHex ss)
, "sequence" .= sq
, "pkscript" .= String (encodeHex ps)
, "value" .= val
, "address" .= eitherToMaybe (addrToJSON net <$> scriptToAddressBS ps)
] ++
["witness" .= fmap (map encodeHex) wit | getSegWit net]
inputPairs net Coinbase { inputPoint = OutPoint oph opi
, inputSequence = sq
, inputSigScript = ss
, inputWitness = wit
} =
[ "coinbase" .= False
, "txid" .= oph
, "output" .= opi
, "sigscript" .= String (encodeHex ss)
, "sequence" .= sq
, "pkscript" .= Null
, "value" .= Null
, "address" .= Null
] ++
["witness" .= fmap (map encodeHex) wit | getSegWit net]
inputToJSON :: Network -> Input -> Value
inputToJSON net = object . inputPairs net
inputToEncoding :: Network -> Input -> Encoding
inputToEncoding net = pairs . mconcat . inputPairs net
data Spender = Spender
{ spenderHash :: !TxHash
, spenderIndex :: !Word32
} deriving (Show, Read, Eq, Ord, Generic, Serialize, Hashable)
spenderPairs :: A.KeyValue kv => Spender -> [kv]
spenderPairs n =
["txid" .= spenderHash n, "input" .= spenderIndex n]
instance ToJSON Spender where
toJSON = object . spenderPairs
toEncoding = pairs . mconcat . spenderPairs
data Output = Output
{ outputAmount :: !Word64
, outputScript :: !ByteString
, outputSpender :: !(Maybe Spender)
} deriving (Show, Read, Eq, Ord, Generic, Serialize, Hashable)
outputPairs :: A.KeyValue kv => Network -> Output -> [kv]
outputPairs net d =
[ "address" .=
eitherToMaybe (addrToJSON net <$> scriptToAddressBS (outputScript d))
, "pkscript" .= String (encodeHex (outputScript d))
, "value" .= outputAmount d
, "spent" .= isJust (outputSpender d)
] ++
["spender" .= outputSpender d | isJust (outputSpender d)]
outputToJSON :: Network -> Output -> Value
outputToJSON net = object . outputPairs net
outputToEncoding :: Network -> Output -> Encoding
outputToEncoding net = pairs . mconcat . outputPairs net
data Transaction = Transaction
{ transactionBlock :: !BlockRef
, transactionVersion :: !Word32
, transactionLockTime :: !Word32
, transactionFee :: !Word64
, transactionInputs :: ![Input]
, transactionOutputs :: ![Output]
, transactionDeleted :: !Bool
, transactionRBF :: !Bool
} deriving (Show, Eq, Ord, Generic, Hashable, Serialize)
transactionData :: Transaction -> Tx
transactionData t =
Tx
{ txVersion = transactionVersion t
, txIn = map i (transactionInputs t)
, txOut = map o (transactionOutputs t)
, txWitness = mapMaybe inputWitness (transactionInputs t)
, txLockTime = transactionLockTime t
}
where
i Coinbase {inputPoint = p, inputSequence = q, inputSigScript = s} =
TxIn {prevOutput = p, scriptInput = s, txInSequence = q}
i Input {inputPoint = p, inputSequence = q, inputSigScript = s} =
TxIn {prevOutput = p, scriptInput = s, txInSequence = q}
o Output {outputAmount = v, outputScript = s} =
TxOut {outValue = v, scriptOutput = s}
transactionPairs :: A.KeyValue kv => Network -> Transaction -> [kv]
transactionPairs net dtx =
[ "txid" .= txHash (transactionData dtx)
, "size" .= B.length (S.encode (transactionData dtx))
, "version" .= transactionVersion dtx
, "locktime" .= transactionLockTime dtx
, "fee" .= transactionFee dtx
, "inputs" .= map (object . inputPairs net) (transactionInputs dtx)
, "outputs" .= map (object . outputPairs net) (transactionOutputs dtx)
, "block" .= transactionBlock dtx
, "deleted" .= transactionDeleted dtx
] ++
["rbf" .= transactionRBF dtx | getReplaceByFee net]
transactionToJSON :: Network -> Transaction -> Value
transactionToJSON net = object . transactionPairs net
transactionToEncoding :: Network -> Transaction -> Encoding
transactionToEncoding net = pairs . mconcat . transactionPairs net
data PeerInformation
= PeerInformation { peerUserAgent :: !ByteString
, peerAddress :: !SockAddr
, peerVersion :: !Word32
, peerServices :: !Word64
, peerRelay :: !Bool
}
deriving (Show, Eq, Ord, Generic)
peerInformationPairs :: A.KeyValue kv => PeerInformation -> [kv]
peerInformationPairs p =
[ "useragent" .= String (cs (peerUserAgent p))
, "address" .= String (cs (show (peerAddress p)))
, "version" .= peerVersion p
, "services" .= peerServices p
, "relay" .= peerRelay p
]
instance ToJSON PeerInformation where
toJSON = object . peerInformationPairs
toEncoding = pairs . mconcat . peerInformationPairs