{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Network.Haskoin.Store.Types where
import Control.Applicative
import Control.Exception
import Control.Monad.Reader
import Data.Aeson as A
import Data.ByteString (ByteString)
import qualified Data.ByteString as B
import Data.Function
import Data.Int
import Data.Maybe
import Data.Serialize as S
import Data.String.Conversions
import Data.Word
import Database.RocksDB (DB)
import Database.RocksDB.Query as R
import Haskoin
import Haskoin.Node
import NQE
data TxException
= DoubleSpend
| OverSpend
| OrphanTx
| NonStandard
| LowFee
| Dust
| NoPeers
| InvalidTx
| CouldNotImport
| PeerIsGone
| AlreadyImported
| PublishTimeout
| PeerRejectOther
| NotAtHeight
deriving (Eq)
instance Show TxException where
show InvalidTx = "invalid"
show DoubleSpend = "double-spend"
show OverSpend = "not enough funds"
show OrphanTx = "orphan"
show AlreadyImported = "already imported"
show NoPeers = "no peers"
show NonStandard = "non-standard"
show LowFee = "low fee"
show Dust = "dust"
show PeerIsGone = "peer disconnected"
show CouldNotImport = "could not import"
show PublishTimeout = "publish timeout"
show PeerRejectOther = "peer rejected for unknown reason"
show NotAtHeight = "not at height"
instance Exception TxException
newtype NewTx = NewTx
{ newTx :: Tx
} deriving (Show, Eq, Ord)
data BlockConfig = BlockConfig
{ blockConfMailbox :: !BlockStore
, blockConfManager :: !Manager
, blockConfChain :: !Chain
, blockConfListener :: !(Listen StoreEvent)
, blockConfDB :: !DB
, blockConfNet :: !Network
}
data StoreEvent
= BestBlock !BlockHash
| MempoolNew !TxHash
| TxException !TxHash
!TxException
| PeerConnected !Peer
| PeerDisconnected !Peer
| PeerPong !Peer
!Word64
data BlockMessage
= BlockChainNew !BlockNode
| BlockPeerConnect !Peer
| BlockPeerDisconnect !Peer
| BlockReceived !Peer
!Block
| BlockNotReceived !Peer
!BlockHash
| TxReceived !Peer
!Tx
| TxAvailable !Peer
![TxHash]
| TxPublished !Tx
| PongReceived !Peer
!Word64
type BlockStore = Inbox BlockMessage
data AddrTxKey
= AddrTxKey { addrTxKey :: !Address
, addrTxHeight :: !(Maybe BlockHeight)
, addrTxPos :: !(Maybe Word32)
, addrTxHash :: !TxHash }
| ShortAddrTxKey { addrTxKey :: !Address }
| ShortAddrTxKeyHeight { addrTxKey :: !Address
, addrTxHeight :: !(Maybe BlockHeight)}
deriving (Show, Eq)
data AddrOutKey
= AddrOutKey { addrOutputAddress :: !Address
, addrOutputHeight :: !(Maybe BlockHeight)
, addrOutputPos :: !(Maybe Word32)
, addrOutPoint :: !OutPoint }
| ShortAddrOutKey { addrOutputAddress :: !Address }
| ShortAddrOutKeyHeight { addrOutputAddress :: !Address
, addrOutputHeight :: !(Maybe BlockHeight) }
deriving (Show, Eq)
instance Ord AddrOutKey where
compare = compare `on` f
where
f AddrOutKey {..} =
( fromMaybe maxBound addrOutputHeight
, fromMaybe maxBound addrOutputPos
, outPointIndex addrOutPoint)
f _ = undefined
data BlockValue = BlockValue
{ blockValueHeight :: !BlockHeight
, blockValueWork :: !BlockWork
, blockValueHeader :: !BlockHeader
, blockValueSize :: !Word32
, blockValueTxs :: ![TxHash]
} deriving (Show, Eq, Ord)
data BlockRef = BlockRef
{ blockRefHash :: !BlockHash
, blockRefHeight :: !BlockHeight
, blockRefPos :: !Word32
} deriving (Show, Eq)
instance Ord BlockRef where
compare = compare `on` f
where
f BlockRef {..} = (blockRefHeight, blockRefPos)
data DetailedTx = DetailedTx
{ detailedTxData :: !Tx
, detailedTxFee :: !Word64
, detailedTxInputs :: ![DetailedInput]
, detailedTxOutputs :: ![DetailedOutput]
, detailedTxBlock :: !(Maybe BlockRef)
} deriving (Show, Eq)
data DetailedInput
= DetailedCoinbase { detInOutPoint :: !OutPoint
, detInSequence :: !Word32
, detInSigScript :: !ByteString
, detInNetwork :: !Network
}
| DetailedInput { detInOutPoint :: !OutPoint
, detInSequence :: !Word32
, detInSigScript :: !ByteString
, detInPkScript :: !ByteString
, detInValue :: !Word64
, detInBlock :: !(Maybe BlockRef)
, detInNetwork :: !Network
}
deriving (Show, Eq)
data PeerInformation
= PeerInformation { userAgent :: !ByteString
, address :: !ByteString
, connected :: !Bool
, version :: !Word32
, services :: !Word64
, relay :: !Bool
, block :: !BlockHash
, height :: !BlockHeight
, nonceLocal :: !Word64
, nonceRemote :: !Word64
}
deriving (Show, Eq)
isCoinbase :: DetailedInput -> Bool
isCoinbase DetailedCoinbase {} = True
isCoinbase _ = False
data DetailedOutput = DetailedOutput
{ detOutValue :: !Word64
, detOutScript :: !ByteString
, detOutSpender :: !(Maybe Spender)
, detOutNetwork :: !Network
} deriving (Show, Eq)
data AddressBalance = AddressBalance
{ addressBalAddress :: !Address
, addressBalConfirmed :: !Word64
, addressBalUnconfirmed :: !Int64
, addressUtxoCount :: !Word64
} deriving (Show, Eq)
data TxRecord = TxRecord
{ txValueBlock :: !(Maybe BlockRef)
, txValue :: !Tx
, txValuePrevOuts :: [(OutPoint, PrevOut)]
} deriving (Show, Eq, Ord)
newtype OutputKey = OutputKey
{ outPoint :: OutPoint
} deriving (Show, Eq, Ord)
data PrevOut = PrevOut
{ prevOutValue :: !Word64
, prevOutBlock :: !(Maybe BlockRef)
, prevOutScript :: !ByteString
} deriving (Show, Eq, Ord)
data Output = Output
{ outputValue :: !Word64
, outBlock :: !(Maybe BlockRef)
, outScript :: !ByteString
, outSpender :: !(Maybe Spender)
} deriving (Show, Eq, Ord)
outputToPrevOut :: Output -> PrevOut
outputToPrevOut Output {..} =
PrevOut
{ prevOutValue = outputValue
, prevOutBlock = outBlock
, prevOutScript = outScript
}
prevOutToOutput :: PrevOut -> Output
prevOutToOutput PrevOut {..} =
Output
{ outputValue = prevOutValue
, outBlock = prevOutBlock
, outScript = prevOutScript
, outSpender = Nothing
}
data Spender = Spender
{ spenderHash :: !TxHash
, spenderIndex :: !Word32
, spenderBlock :: !(Maybe BlockRef)
} deriving (Show, Eq, Ord)
data MultiTxKey
= MultiTxKey !TxKey
| MultiTxOutKey !OutputKey
| ShortMultiTxKey !TxHash
deriving (Show, Eq, Ord)
data MultiTxValue
= MultiTx !TxRecord
| MultiTxOutput !Output
deriving (Show, Eq, Ord)
newtype TxKey =
TxKey TxHash
deriving (Show, Eq, Ord)
data MempoolKey
= MempoolKey TxHash
| ShortMempoolKey
deriving (Show, Eq, Ord)
data OrphanKey
= OrphanKey TxHash
| ShortOrphanKey
deriving (Show, Eq, Ord)
newtype BlockKey =
BlockKey BlockHash
deriving (Show, Eq, Ord)
newtype HeightKey =
HeightKey BlockHeight
deriving (Show, Eq, Ord)
newtype BalanceKey = BalanceKey
{ balanceAddress :: Address
} deriving (Show, Eq)
data Balance = Balance
{ balanceValue :: !Word64
, balanceUnconfirmed :: !Int64
, balanceUtxoCount :: !Word64
} deriving (Show, Eq, Ord)
emptyBalance :: Balance
emptyBalance =
Balance
{ balanceValue = 0
, balanceUnconfirmed = 0
, balanceUtxoCount = 0
}
data BestBlockKey = BestBlockKey deriving (Show, Eq, Ord)
data AddrOutput = AddrOutput
{ addrOutputKey :: !AddrOutKey
, addrOutput :: !Output
} deriving (Eq, Show)
instance Ord AddrOutput where
compare = compare `on` addrOutputKey
newtype StoreAddress = StoreAddress Address
deriving (Show, Eq)
instance Key BestBlockKey
instance Key BlockKey
instance Key TxKey
instance Key OutputKey
instance Key MultiTxKey
instance Key HeightKey
instance Key BalanceKey
instance Key AddrTxKey
instance Key AddrOutKey
instance Key MempoolKey
instance Key OrphanKey
instance R.KeyValue BestBlockKey BlockHash
instance R.KeyValue BlockKey BlockValue
instance R.KeyValue TxKey TxRecord
instance R.KeyValue AddrOutKey Output
instance R.KeyValue MultiTxKey MultiTxValue
instance R.KeyValue HeightKey BlockHash
instance R.KeyValue BalanceKey Balance
instance R.KeyValue AddrTxKey ()
instance R.KeyValue OutputKey Output
instance R.KeyValue MempoolKey ()
instance R.KeyValue OrphanKey Tx
instance Serialize MempoolKey where
put (MempoolKey h) = do
putWord8 0x07
put h
put ShortMempoolKey = putWord8 0x07
get = do
guard . (== 0x07) =<< getWord8
MempoolKey <$> get
instance Serialize OrphanKey where
put (OrphanKey h) = do
putWord8 0x08
put h
put ShortOrphanKey = putWord8 0x08
get = do
guard . (== 0x08) =<< getWord8
OrphanKey <$> get
instance Serialize BalanceKey where
put BalanceKey {..} = do
putWord8 0x04
put (StoreAddress balanceAddress)
get = do
guard . (== 0x04) =<< getWord8
StoreAddress balanceAddress <- get
return BalanceKey {..}
instance Serialize Balance where
put Balance {..} = do
put balanceValue
put balanceUnconfirmed
put balanceUtxoCount
get = do
balanceValue <- get
balanceUnconfirmed <- get
balanceUtxoCount <- get
return Balance {..}
instance Serialize AddrTxKey where
put AddrTxKey {..} = do
putWord8 0x05
put $ StoreAddress addrTxKey
put (maybe 0 (maxBound -) addrTxHeight)
put (maybe 0 (maxBound -) addrTxPos)
put addrTxHash
put ShortAddrTxKey {..} = do
putWord8 0x05
put $ StoreAddress addrTxKey
put ShortAddrTxKeyHeight {..} = do
putWord8 0x05
put $ StoreAddress addrTxKey
put (maybe 0 (maxBound -) addrTxHeight)
get = do
guard . (== 0x05) =<< getWord8
StoreAddress addrTxKey <- get
h <- (maxBound -) <$> get
let addrTxHeight
| h == 0 = Nothing
| otherwise = Just h
p <- (maxBound -) <$> get
let addrTxPos
| p == 0 = Nothing
| otherwise = Just p
addrTxHash <- get
return AddrTxKey {..}
addrKeyStart :: Address -> Put
addrKeyStart a = put (StoreAddress a)
instance Serialize AddrOutKey where
put AddrOutKey {..} = do
putWord8 0x06
put $ StoreAddress addrOutputAddress
put (maybe 0 (maxBound -) addrOutputHeight)
put (maybe 0 (maxBound -) addrOutputPos)
put addrOutPoint
put ShortAddrOutKey {..} = do
putWord8 0x06
put $ StoreAddress addrOutputAddress
put ShortAddrOutKeyHeight {..} = do
putWord8 0x06
put $ StoreAddress addrOutputAddress
put (maybe 0 (maxBound -) addrOutputHeight)
get = do
guard . (== 0x06) =<< getWord8
StoreAddress addrOutputAddress <- get
record addrOutputAddress
where
record addrOutputAddress = do
h <- (maxBound -) <$> get
let addrOutputHeight | h == 0 = Nothing
| otherwise = Just h
p <- (maxBound -) <$> get
let addrOutputPos | p == 0 = Nothing
| otherwise = Just p
addrOutPoint <- get
return AddrOutKey {..}
instance Serialize MultiTxKey where
put (MultiTxKey k) = put k
put (MultiTxOutKey k) = put k
put (ShortMultiTxKey k) = putWord8 0x02 >> put k
get = MultiTxKey <$> get <|> MultiTxOutKey <$> get
instance Serialize MultiTxValue where
put (MultiTx v) = put v
put (MultiTxOutput v) = put v
get = MultiTx <$> get <|> MultiTxOutput <$> get
instance Serialize Spender where
put Spender {..} = do
put spenderHash
put spenderIndex
put spenderBlock
get = do
spenderHash <- get
spenderIndex <- get
spenderBlock <- get
return Spender {..}
instance Serialize OutputKey where
put OutputKey {..} = do
putWord8 0x02
put (outPointHash outPoint)
putWord8 0x01
put (outPointIndex outPoint)
get = do
guard . (== 0x02) =<< getWord8
outPointHash <- get
guard . (== 0x01) =<< getWord8
outPointIndex <- get
let outPoint = OutPoint {..}
return OutputKey {..}
instance Serialize PrevOut where
put PrevOut {..} = do
put prevOutValue
put prevOutBlock
put (B.length prevOutScript)
putByteString prevOutScript
get = do
prevOutValue <- get
prevOutBlock <- get
prevOutScript <- getByteString =<< get
return PrevOut {..}
instance Serialize Output where
put Output {..} = do
putWord8 0x01
put outputValue
put outBlock
put outScript
put outSpender
get = do
guard . (== 0x01) =<< getWord8
outputValue <- get
outBlock <- get
outScript <- get
outSpender <- get
return Output {..}
instance Serialize BlockRef where
put BlockRef {..} = do
put blockRefHash
put blockRefHeight
put blockRefPos
get = do
blockRefHash <- get
blockRefHeight <- get
blockRefPos <- get
return BlockRef {..}
instance Serialize TxRecord where
put TxRecord {..} = do
putWord8 0x00
put txValueBlock
put txValue
put txValuePrevOuts
get = do
guard . (== 0x00) =<< getWord8
txValueBlock <- get
txValue <- get
txValuePrevOuts <- get
return TxRecord {..}
instance Serialize BestBlockKey where
put BestBlockKey = put (B.replicate 32 0x00)
get = do
guard . (== B.replicate 32 0x00) =<< getBytes 32
return BestBlockKey
instance Serialize BlockValue where
put BlockValue {..} = do
put blockValueHeight
put blockValueWork
put blockValueHeader
put blockValueSize
put blockValueTxs
get = do
blockValueHeight <- get
blockValueWork <- get
blockValueHeader <- get
blockValueSize <- get
blockValueTxs <- get
return BlockValue {..}
netByte :: Network -> Word8
netByte net | net == btc = 0x00
| net == btcTest = 0x01
| net == btcRegTest = 0x02
| net == bch = 0x04
| net == bchTest = 0x05
| net == bchRegTest = 0x06
| otherwise = 0xff
byteNet :: Word8 -> Maybe Network
byteNet 0x00 = Just btc
byteNet 0x01 = Just btcTest
byteNet 0x02 = Just btcRegTest
byteNet 0x04 = Just bch
byteNet 0x05 = Just bchTest
byteNet 0x06 = Just bchRegTest
byteNet _ = Nothing
getByteNet :: Get Network
getByteNet =
byteNet <$> getWord8 >>= \case
Nothing -> fail "Could not decode network byte"
Just net -> return net
instance Serialize StoreAddress where
put (StoreAddress addr) =
case addr of
PubKeyAddress h net -> do
putWord8 0x01
putWord8 (netByte net)
put h
ScriptAddress h net -> do
putWord8 0x02
putWord8 (netByte net)
put h
WitnessPubKeyAddress h net -> do
putWord8 0x03
putWord8 (netByte net)
put h
WitnessScriptAddress h net -> do
putWord8 0x04
putWord8 (netByte net)
put h
get = fmap StoreAddress $ pk <|> sa <|> wa <|> ws
where
pk = do
guard . (== 0x01) =<< getWord8
net <- getByteNet
h <- get
return (PubKeyAddress h net)
sa = do
guard . (== 0x02) =<< getWord8
net <- getByteNet
h <- get
return (ScriptAddress h net)
wa = do
guard . (== 0x03) =<< getWord8
net <- getByteNet
h <- get
return (WitnessPubKeyAddress h net)
ws = do
guard . (== 0x04) =<< getWord8
net <- getByteNet
h <- get
return (WitnessScriptAddress h net)
blockValuePairs :: A.KeyValue kv => BlockValue -> [kv]
blockValuePairs BlockValue {..} =
[ "hash" .= headerHash blockValueHeader
, "height" .= blockValueHeight
, "previous" .= prevBlock blockValueHeader
, "time" .= blockTimestamp blockValueHeader
, "version" .= blockVersion blockValueHeader
, "bits" .= blockBits blockValueHeader
, "nonce" .= bhNonce blockValueHeader
, "size" .= blockValueSize
, "tx" .= blockValueTxs
]
instance ToJSON BlockValue where
toJSON = object . blockValuePairs
toEncoding = pairs . mconcat . blockValuePairs
instance ToJSON Spender where
toJSON = object . spenderPairs
toEncoding = pairs . mconcat . spenderPairs
blockRefPairs :: A.KeyValue kv => BlockRef -> [kv]
blockRefPairs BlockRef {..} =
[ "hash" .= blockRefHash
, "height" .= blockRefHeight
, "position" .= blockRefPos
]
spenderPairs :: A.KeyValue kv => Spender -> [kv]
spenderPairs Spender {..} =
["txid" .= spenderHash, "input" .= spenderIndex, "block" .= spenderBlock]
detailedOutputPairs :: A.KeyValue kv => DetailedOutput -> [kv]
detailedOutputPairs DetailedOutput {..} =
[ "address" .= scriptToAddressBS detOutNetwork detOutScript
, "pkscript" .= String (cs (encodeHex detOutScript))
, "value" .= detOutValue
, "spent" .= isJust detOutSpender
, "spender" .= detOutSpender
]
instance ToJSON DetailedOutput where
toJSON = object . detailedOutputPairs
toEncoding = pairs . mconcat . detailedOutputPairs
peerInformationPairs :: A.KeyValue kv => PeerInformation -> [kv]
peerInformationPairs PeerInformation {..} =
[ "useragent" .= String (cs userAgent)
, "address" .= String (cs address)
, "connected" .= connected
, "version" .= version
, "services" .= services
, "relay" .= relay
, "block" .= block
, "height" .= height
, "noncelocal" .= nonceLocal
, "nonceremote" .= nonceRemote
]
instance ToJSON PeerInformation where
toJSON = object . peerInformationPairs
toEncoding = pairs . mconcat . peerInformationPairs
detailedInputPairs :: A.KeyValue kv => DetailedInput -> [kv]
detailedInputPairs DetailedInput {..} =
[ "txid" .= outPointHash detInOutPoint
, "output" .= outPointIndex detInOutPoint
, "coinbase" .= False
, "sequence" .= detInSequence
, "sigscript" .= String (cs (encodeHex detInSigScript))
, "pkscript" .= String (cs (encodeHex detInPkScript))
, "address" .= scriptToAddressBS detInNetwork detInPkScript
, "value" .= detInValue
, "block" .= detInBlock
]
detailedInputPairs DetailedCoinbase {..} =
[ "txid" .= outPointHash detInOutPoint
, "output" .= outPointIndex detInOutPoint
, "coinbase" .= True
, "sequence" .= detInSequence
, "sigscript" .= String (cs (encodeHex detInSigScript))
, "pkscript" .= Null
, "address" .= Null
, "value" .= Null
, "block" .= Null
]
instance ToJSON DetailedInput where
toJSON = object . detailedInputPairs
toEncoding = pairs . mconcat . detailedInputPairs
detailedTxPairs :: A.KeyValue kv => DetailedTx -> [kv]
detailedTxPairs DetailedTx {..} =
[ "txid" .= txHash detailedTxData
, "size" .= B.length (S.encode detailedTxData)
, "version" .= txVersion detailedTxData
, "locktime" .= txLockTime detailedTxData
, "fee" .= detailedTxFee
, "inputs" .= detailedTxInputs
, "outputs" .= detailedTxOutputs
, "hex" .= String (cs (encodeHex (S.encode detailedTxData)))
, "block" .= detailedTxBlock
]
instance ToJSON DetailedTx where
toJSON = object . detailedTxPairs
toEncoding = pairs . mconcat . detailedTxPairs
instance ToJSON BlockRef where
toJSON = object . blockRefPairs
toEncoding = pairs . mconcat . blockRefPairs
addrOutputPairs :: A.KeyValue kv => AddrOutput -> [kv]
addrOutputPairs AddrOutput {..} =
[ "address" .= addrOutputAddress
, "txid" .= outPointHash addrOutPoint
, "index" .= outPointIndex addrOutPoint
, "block" .= outBlock
, "output" .= dout
]
where
Output {..} = addrOutput
AddrOutKey {..} = addrOutputKey
dout =
DetailedOutput
{ detOutValue = outputValue
, detOutScript = outScript
, detOutSpender = outSpender
, detOutNetwork = getAddrNet addrOutputAddress
}
instance ToJSON AddrOutput where
toJSON = object . addrOutputPairs
toEncoding = pairs . mconcat . addrOutputPairs
addressBalancePairs :: A.KeyValue kv => AddressBalance -> [kv]
addressBalancePairs AddressBalance {..} =
[ "address" .= addressBalAddress
, "confirmed" .= addressBalConfirmed
, "unconfirmed" .= addressBalUnconfirmed
, "utxo" .= addressUtxoCount
]
instance FromJSON NewTx where
parseJSON = withObject "transaction" $ \v -> NewTx <$> v .: "transaction"
instance ToJSON AddressBalance where
toJSON = object . addressBalancePairs
toEncoding = pairs . mconcat . addressBalancePairs
instance Serialize HeightKey where
put (HeightKey height) = do
putWord8 0x03
put (maxBound - height)
put height
get = do
guard . (== 0x03) =<< getWord8
iheight <- get
return (HeightKey (maxBound - iheight))
instance Serialize BlockKey where
put (BlockKey hash) = do
putWord8 0x01
put hash
get = do
guard . (== 0x01) =<< getWord8
BlockKey <$> get
instance Serialize TxKey where
put (TxKey hash) = do
putWord8 0x02
put hash
putWord8 0x00
get = do
guard . (== 0x02) =<< getWord8
hash <- get
guard . (== 0x00) =<< getWord8
return (TxKey hash)
data StoreConfig = StoreConfig
{ storeConfMaxPeers :: !Int
, storeConfInitPeers :: ![HostPort]
, storeConfDiscover :: !Bool
, storeConfDB :: !DB
, storeConfNetwork :: !Network
}
data Store = Store
{ storeManager :: !Manager
, storeChain :: !Chain
, storeBlock :: !BlockStore
, storePublisher :: !(Publisher StoreEvent)
}