{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
module Network.Haskoin.Store.Data where
import Conduit
import Control.Monad.Trans.Maybe
import Data.Aeson as A
import Data.ByteString (ByteString)
import qualified Data.ByteString as B
import Data.ByteString.Short (ShortByteString)
import qualified Data.ByteString.Short as B.Short
import Data.Hashable
import Data.Int
import qualified Data.IntMap as I
import Data.IntMap.Strict (IntMap)
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 Applicative m => UnspentWrite u m where
addUnspent :: u -> Unspent -> m ()
delUnspent :: u -> OutPoint -> m ()
pruneUnspent :: u -> m ()
pruneUnspent _ = pure ()
class UnspentRead u m where
getUnspent :: u -> OutPoint -> m (Maybe Unspent)
class Applicative m => BalanceWrite b m where
setBalance :: b -> Balance -> m ()
pruneBalance :: b -> m ()
pruneBalance _ = pure ()
class BalanceRead b m where
getBalance :: b -> Address -> m (Maybe Balance)
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)
getTxData :: r -> TxHash -> m (Maybe TxData)
getSpenders :: r -> TxHash -> m (IntMap Spender)
getSpender :: r -> OutPoint -> m (Maybe Spender)
getTransaction ::
(Monad m, StoreRead r m) => r -> TxHash -> m (Maybe Transaction)
getTransaction r h = runMaybeT $ do
d <- MaybeT $ getTxData r h
sm <- lift $ getSpenders r h
return $ toTransaction d sm
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 -> TxData -> m ()
insertSpender :: w -> OutPoint -> Spender -> m ()
deleteSpender :: w -> OutPoint -> 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 :: !Word64
, 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
, unspentPoint :: !OutPoint
, unspentAmount :: !Word64
, unspentScript :: !ShortByteString
} deriving (Show, Eq, Ord, Generic, Hashable)
instance Serialize Unspent where
put u = do
put $ unspentBlock u
put $ unspentPoint u
put $ unspentAmount u
put $ B.Short.length (unspentScript u)
putShortByteString $ unspentScript u
get =
Unspent <$> get <*> get <*> get <*> (getShortByteString =<< get)
unspentPairs :: A.KeyValue kv => Network -> Unspent -> [kv]
unspentPairs net u =
[ "address" .=
eitherToMaybe
(addrToJSON net <$>
scriptToAddressBS (B.Short.fromShort (unspentScript u)))
, "block" .= unspentBlock u
, "txid" .= outPointHash (unspentPoint u)
, "index" .= outPointIndex (unspentPoint u)
, "pkscript" .= String (encodeHex (B.Short.fromShort (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 Prev = Prev
{ prevScript :: !ByteString
, prevAmount :: !Word64
} deriving (Show, Eq, Ord, Generic, Hashable, Serialize)
toInput :: TxIn -> Maybe Prev -> Maybe WitnessStack -> Input
toInput i Nothing w =
Coinbase
{ inputPoint = prevOutput i
, inputSequence = txInSequence i
, inputSigScript = scriptInput i
, inputWitness = w
}
toInput i (Just p) w =
Input
{ inputPoint = prevOutput i
, inputSequence = txInSequence i
, inputSigScript = scriptInput i
, inputPkScript = prevScript p
, inputAmount = prevAmount p
, inputWitness = w
}
toOutput :: TxOut -> Maybe Spender -> Output
toOutput o s =
Output
{ outputAmount = outValue o
, outputScript = scriptOutput o
, outputSpender = s
}
data TxData = TxData
{ txDataBlock :: !BlockRef
, txData :: !Tx
, txDataPrevs :: !(IntMap Prev)
, txDataDeleted :: !Bool
, txDataRBF :: Bool
} deriving (Show, Eq, Ord, Generic, Serialize)
toTransaction :: TxData -> IntMap Spender -> Transaction
toTransaction t sm =
Transaction
{ transactionBlock = txDataBlock t
, transactionVersion = txVersion (txData t)
, transactionLockTime = txLockTime (txData t)
, transactionInputs = ins
, transactionOutputs = outs
, transactionDeleted = txDataDeleted t
, transactionRBF = txDataRBF t
}
where
ws =
take (length (txIn (txData t))) $
map Just (txWitness (txData t)) <> repeat Nothing
f n i = toInput i (I.lookup n (txDataPrevs t)) (ws !! n)
ins = zipWith f [0 ..] (txIn (txData t))
g n o = toOutput o (I.lookup n sm)
outs = zipWith g [0 ..] (txOut (txData t))
fromTransaction :: Transaction -> (TxData, IntMap Spender)
fromTransaction t = (d, sm)
where
d =
TxData
{ txDataBlock = transactionBlock t
, txData = transactionData t
, txDataPrevs = ps
, txDataDeleted = transactionDeleted t
, txDataRBF = transactionRBF t
}
f _ Coinbase {} = Nothing
f n Input {inputPkScript = s, inputAmount = v} =
Just (n, Prev {prevScript = s, prevAmount = v})
ps = I.fromList . catMaybes $ zipWith f [0 ..] (transactionInputs t)
g _ Output {outputSpender = Nothing} = Nothing
g n Output {outputSpender = Just s} = Just (n, s)
sm = I.fromList . catMaybes $ zipWith g [0 ..] (transactionOutputs t)
data Transaction = Transaction
{ transactionBlock :: !BlockRef
, transactionVersion :: !Word32
, transactionLockTime :: !Word32
, 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" .=
if all isCoinbase (transactionInputs dtx)
then 0
else sum (map inputAmount (transactionInputs dtx)) -
sum (map outputAmount (transactionOutputs 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
data XPubTx = XPubTx
{ xPubTxPath :: ![KeyIndex]
, xPubTx :: !AddressTx
} deriving (Show, Eq, Generic)
xPubTxPairs :: A.KeyValue kv => Network -> XPubTx -> [kv]
xPubTxPairs net XPubTx {xPubTxPath = p, xPubTx = tx} =
[ "path" .= p
, "tx" .= addressTxToJSON net tx
]
xPubTxToJSON :: Network -> XPubTx -> Value
xPubTxToJSON net = object . xPubTxPairs net
xPubTxToEncoding :: Network -> XPubTx -> Encoding
xPubTxToEncoding net = pairs . mconcat . xPubTxPairs net
data XPubBal = XPubBal
{ xPubBalPath :: ![KeyIndex]
, xPubBal :: !Balance
} deriving (Show, Eq, Generic)
xPubBalPairs :: A.KeyValue kv => Network -> XPubBal -> [kv]
xPubBalPairs net XPubBal {xPubBalPath = p, xPubBal = b} =
[ "path" .= p
, "balance" .= balanceToJSON net b
]
xPubBalToJSON :: Network -> XPubBal -> Value
xPubBalToJSON net = object . xPubBalPairs net
xPubBalToEncoding :: Network -> XPubBal -> Encoding
xPubBalToEncoding net = pairs . mconcat . xPubBalPairs net
data XPubUnspent = XPubUnspent
{ xPubUnspentPath :: ![KeyIndex]
, xPubUnspent :: !Unspent
} deriving (Show, Eq, Generic)
xPubUnspentPairs :: A.KeyValue kv => Network -> XPubUnspent -> [kv]
xPubUnspentPairs net XPubUnspent { xPubUnspentPath = p
, xPubUnspent = u
} =
[ "path" .= p
, "unspent" .= unspentToJSON net u
]
xPubUnspentToJSON :: Network -> XPubUnspent -> Value
xPubUnspentToJSON net = object . xPubUnspentPairs net
xPubUnspentToEncoding :: Network -> XPubUnspent -> Encoding
xPubUnspentToEncoding net = pairs . mconcat . xPubUnspentPairs net