diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -4,6 +4,13 @@ The format is based on [Keep a Changelog](http://keepachangelog.com/en/1.0.0/) and this project adheres to [Semantic Versioning](http://semver.org/spec/v2.0.0.html) +## 0.47.0 +### Added +- Support for legacy block endpoints. + +### Changed +- Serialization now uses bytes library and does interleaved IO. + ## 0.46.6 ### Added - Allow comma-separated values in multiaddr. diff --git a/haskoin-store.cabal b/haskoin-store.cabal --- a/haskoin-store.cabal +++ b/haskoin-store.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: c9231999d6058fee01e8adfa56ad32d150d2330330fcbcb42670bbfc4dab72f3 +-- hash: 936d1c352473fe70b8f245dc68fdf18244c111477e0489bfdcf6e6443727962f name: haskoin-store -version: 0.46.6 +version: 0.47.0 synopsis: Storage and index for Bitcoin and Bitcoin Cash description: Please see the README on GitHub at category: Bitcoin, Finance, Network @@ -47,6 +47,8 @@ aeson >=1.4.7.1 , aeson-pretty >=0.8.8 , base >=4.9 && <5 + , base16 >=0.3.0 + , bytes >=0.17 , bytestring >=0.10.10.0 , cereal >=0.5.8.1 , conduit >=1.3.2 @@ -59,7 +61,7 @@ , hashable >=1.3.0.0 , haskoin-core >=0.19.0 , haskoin-node >=0.17.0 - , haskoin-store-data ==0.46.6 + , haskoin-store-data ==0.47.0 , hedis >=0.12.13 , http-types >=0.12.3 , lens >=4.18.1 @@ -95,6 +97,8 @@ aeson >=1.4.7.1 , aeson-pretty >=0.8.8 , base >=4.9 && <5 + , base16 >=0.3.0 + , bytes >=0.17 , bytestring >=0.10.10.0 , cereal >=0.5.8.1 , conduit >=1.3.2 @@ -109,7 +113,7 @@ , haskoin-core >=0.19.0 , haskoin-node >=0.17.0 , haskoin-store - , haskoin-store-data ==0.46.6 + , haskoin-store-data ==0.47.0 , hedis >=0.12.13 , http-types >=0.12.3 , lens >=4.18.1 @@ -150,7 +154,9 @@ , aeson >=1.4.7.1 , aeson-pretty >=0.8.8 , base >=4.9 && <5 + , base16 >=0.3.0 , base64 >=0.4.1 + , bytes >=0.17 , bytestring >=0.10.10.0 , cereal >=0.5.8.1 , conduit >=1.3.2 @@ -164,7 +170,7 @@ , haskoin-core >=0.19.0 , haskoin-node >=0.17.0 , haskoin-store - , haskoin-store-data ==0.46.6 + , haskoin-store-data ==0.47.0 , hedis >=0.12.13 , hspec >=2.7.1 , http-types >=0.12.3 diff --git a/src/Haskoin/Store/Cache.hs b/src/Haskoin/Store/Cache.hs --- a/src/Haskoin/Store/Cache.hs +++ b/src/Haskoin/Store/Cache.hs @@ -36,7 +36,6 @@ import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT) import Data.Bits (shift, (.&.), (.|.)) import Data.ByteString (ByteString) -import qualified Data.ByteString.Short as BSS import Data.Default (def) import Data.Either (rights) import Data.HashMap.Strict (HashMap) @@ -281,8 +280,7 @@ either (const Nothing) (\a -> Just (a, u)) - (scriptToAddressBS - (BSS.fromShort (unspentScript u)))) + (scriptToAddressBS (unspentScript u))) uns xpubutxo = mapMaybe diff --git a/src/Haskoin/Store/Database/Types.hs b/src/Haskoin/Store/Database/Types.hs --- a/src/Haskoin/Store/Database/Types.hs +++ b/src/Haskoin/Store/Database/Types.hs @@ -31,8 +31,6 @@ (.|.)) import Data.ByteString (ByteString) import qualified Data.ByteString as BS -import Data.ByteString.Short (ShortByteString) -import qualified Data.ByteString.Short as BSS import Data.Default (Default (..)) import Data.Either (fromRight) import Data.Hashable (Hashable) @@ -227,7 +225,7 @@ Unspent { unspentBlock = addrOutKeyB b , unspentAmount = outValAmount v - , unspentScript = BSS.toShort (outValScript v) + , unspentScript = outValScript v , unspentPoint = addrOutKeyP b , unspentAddress = eitherToMaybe (scriptToAddressBS (outValScript v)) } @@ -386,7 +384,7 @@ data UnspentVal = UnspentVal { unspentValBlock :: !BlockRef , unspentValAmount :: !Word64 - , unspentValScript :: !ShortByteString + , unspentValScript :: !ByteString } deriving (Show, Read, Eq, Ord, Generic, Hashable, Serialize, NFData) unspentToVal :: Unspent -> (OutPoint, UnspentVal) @@ -409,5 +407,5 @@ , unspentPoint = p , unspentAmount = v , unspentScript = s - , unspentAddress = eitherToMaybe (scriptToAddressBS (BSS.fromShort s)) + , unspentAddress = eitherToMaybe (scriptToAddressBS s) } diff --git a/src/Haskoin/Store/Database/Writer.hs b/src/Haskoin/Store/Database/Writer.hs --- a/src/Haskoin/Store/Database/Writer.hs +++ b/src/Haskoin/Store/Database/Writer.hs @@ -6,7 +6,6 @@ import Control.Monad.Reader (ReaderT (..)) import qualified Control.Monad.Reader as R -import qualified Data.ByteString.Short as B.Short import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as M import Data.List (sortOn) @@ -346,7 +345,7 @@ insertAddrUnspentH a u db = let k = (a, unspentBlock u, unspentPoint u) v = OutVal { outValAmount = unspentAmount u - , outValScript = B.Short.fromShort (unspentScript u) + , outValScript = unspentScript u } in db { hAddrOut = M.insert k (Just v) (hAddrOut db) } diff --git a/src/Haskoin/Store/Logic.hs b/src/Haskoin/Store/Logic.hs --- a/src/Haskoin/Store/Logic.hs +++ b/src/Haskoin/Store/Logic.hs @@ -25,7 +25,6 @@ import Control.Monad.Logger (MonadLoggerIO (..), logDebugS, logErrorS) import qualified Data.ByteString as B -import qualified Data.ByteString.Short as B.Short import Data.Either (rights) import Data.Function (on) import qualified Data.IntMap.Strict as I @@ -277,7 +276,7 @@ , txDataTime = tt } where - mkprv u = Prev (B.Short.fromShort (unspentScript u)) (unspentAmount u) + mkprv u = Prev (unspentScript u) (unspentAmount u) ps = I.fromList $ zip [0 ..] $ map mkprv us importTx @@ -335,7 +334,7 @@ { unspentBlock = new , unspentPoint = op , unspentAmount = outValue o - , unspentScript = B.Short.toShort pk + , unspentScript = pk , unspentAddress = ma } forM_ ma $ replace_addr_unspent pk @@ -346,7 +345,7 @@ { unspentBlock = old , unspentPoint = op , unspentAmount = outValue o - , unspentScript = B.Short.toShort pk + , unspentScript = pk , unspentAddress = Just a } insertAddrUnspent @@ -355,7 +354,7 @@ { unspentBlock = new , unspentPoint = op , unspentAmount = outValue o - , unspentScript = B.Short.toShort pk + , unspentScript = pk , unspentAddress = Just a } decreaseBalance (confirmed old) a (outValue o) @@ -550,7 +549,7 @@ v | add = (+ outValue o) | otherwise = subtract (outValue o) ma = eitherToMaybe (scriptToAddressBS (scriptOutput o)) - u = Unspent { unspentScript = B.Short.toShort (scriptOutput o) + u = Unspent { unspentScript = scriptOutput o , unspentBlock = br , unspentPoint = op , unspentAmount = outValue o @@ -587,7 +586,7 @@ Nothing -> error $ "Could not find UTXO to spend: " <> show op deleteUnspent op insertSpender op (Spender th ix) - let pk = B.Short.fromShort (unspentScript u) + let pk = unspentScript u forM_ (scriptToAddressBS pk) $ \a -> do decreaseBalance (confirmed (unspentBlock u)) @@ -609,7 +608,7 @@ m = eitherToMaybe (scriptToAddressBS (scriptOutput o)) u = Unspent { unspentAmount = outValue o , unspentBlock = txDataBlock t - , unspentScript = B.Short.toShort (scriptOutput o) + , unspentScript = scriptOutput o , unspentPoint = op , unspentAddress = m } diff --git a/src/Haskoin/Store/Web.hs b/src/Haskoin/Store/Web.hs --- a/src/Haskoin/Store/Web.hs +++ b/src/Haskoin/Store/Web.hs @@ -39,8 +39,11 @@ import Data.ByteString.Builder (lazyByteString) import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy.Char8 as C -import Data.ByteString.Short (fromShort) +import Data.Bytes.Get +import Data.Bytes.Put +import Data.Bytes.Serial import Data.Char (isSpace) +import qualified Data.ByteString.Lazy.Base16 as BL16 import Data.Default (Default (..)) import Data.Function (on, (&)) import Data.HashMap.Strict (HashMap) @@ -54,7 +57,6 @@ isJust, listToMaybe, mapMaybe, maybeToList) import Data.Proxy (Proxy (..)) -import Data.Serialize as Serialize import qualified Data.Set as Set import Data.String (fromString) import Data.String.Conversions (cs) @@ -100,6 +102,7 @@ import Network.Wai.Handler.Warp (defaultSettings, setHost, setPort) import qualified Network.Wreq as Wreq +import System.IO.Unsafe (unsafeInterleaveIO) import qualified System.Metrics as Metrics import qualified System.Metrics.Counter as Metrics (Counter) import qualified System.Metrics.Counter as Metrics.Counter @@ -110,7 +113,8 @@ askRunInIO, atomically, bracket, bracket_, handleAny, liftIO, newTVarIO, readTVarIO, timeout, - withAsync, writeTVar) + withAsync, withRunInIO, + writeTVar) import UnliftIO.Concurrent (threadDelay) import Web.Scotty.Internal.Types (ActionT) import Web.Scotty.Trans (Parsable) @@ -426,7 +430,6 @@ errStatus UserError{} = status400 errStatus StringError{} = status400 errStatus ServerError = status500 -errStatus BlockTooLarge = status403 errStatus TxIndexConflict{} = status409 defHandler :: Monad m => Except -> WebT m () @@ -636,6 +639,7 @@ S.post "/blockchain/unspent" scottyBinfoUnspent S.get "/blockchain/unspent" scottyBinfoUnspent S.get "/blockchain/rawtx/:txid" scottyBinfoTx + S.get "/blockchain/rawblock/:block" scottyBinfoBlock where json_list f net = toJSONList . map (f net) @@ -686,13 +690,13 @@ S.raw (encodingToLazyByteString e) protoSerial - :: Serialize a + :: Serial a => SerialAs -> (a -> Encoding) -> (a -> Value) -> a -> L.ByteString -protoSerial SerialAsBinary _ _ = runPutLazy . put +protoSerial SerialAsBinary _ _ = runPutL . serialize protoSerial SerialAsJSON f _ = encodingToLazyByteString . f protoSerial SerialAsPrettyJSON _ g = encodePretty' defConfig {confTrailingNewline = True} . g @@ -754,22 +758,19 @@ (MonadUnliftIO m, MonadLoggerIO m) => H.BlockHash -> WebT m H.Block getRawBlock h = do b <- maybe (raise blockErrors ThingNotFound) return =<< getBlock h - refuseLargeBlock blockErrors b - toRawBlock b + lift (toRawBlock b) -toRawBlock :: (Monad m, StoreReadBase m) => BlockData -> m H.Block +toRawBlock :: (MonadUnliftIO m, StoreReadBase m) => BlockData -> m H.Block toRawBlock b = do let ths = blockDataTxs b - txs <- map transactionData . catMaybes <$> mapM getTransaction ths + txs <- mapM f ths return H.Block {H.blockHeader = blockDataHeader b, H.blockTxns = txs} - -refuseLargeBlock :: MonadIO m - => (WebMetrics -> ErrorCounter) - -> BlockData - -> WebT m () -refuseLargeBlock metric BlockData {blockDataTxs = txs} = do - WebLimits {maxLimitFull = f} <- lift $ asks (webMaxLimits . webConfig) - when (length txs > fromIntegral f) $ raise metric BlockTooLarge + where + f x = withRunInIO $ \run -> + unsafeInterleaveIO . run $ + getTransaction x >>= \case + Nothing -> undefined + Just t -> return $ transactionData t -- GET BlockBest / BlockBestRaw -- @@ -860,8 +861,7 @@ ch <- lift $ asks (storeChain . webStore . webConfig) m <- blockAtOrBefore ch t b <- maybe (raise blockErrors ThingNotFound) return m - refuseLargeBlock blockErrors b - RawResult <$> toRawBlock b + RawResult <$> lift (toRawBlock b) scottyBlockMTPRaw :: (MonadUnliftIO m, MonadLoggerIO m) => GetBlockMTPRaw -> WebT m (RawResult H.Block) @@ -870,8 +870,7 @@ ch <- lift $ asks (storeChain . webStore . webConfig) m <- blockAtOrAfterMTP ch t b <- maybe (raise blockErrors ThingNotFound) return m - refuseLargeBlock blockErrors b - RawResult <$> toRawBlock b + RawResult <$> lift (toRawBlock b) -- GET Transactions -- @@ -899,16 +898,25 @@ -> WebT m (RawResultList Tx) scottyTxsRaw (GetTxsRaw txids) = withMetrics txResponseTime (length txids) $ do - txs <- catMaybes <$> mapM getTransaction (nub txids) + txs <- catMaybes <$> mapM f (nub txids) return $ RawResultList $ transactionData <$> txs + where + f x = lift $ withRunInIO $ \run -> + unsafeInterleaveIO . run $ + getTransaction x getTxsBlock :: (MonadUnliftIO m, MonadLoggerIO m) => H.BlockHash -> WebT m [Transaction] getTxsBlock h = do b <- maybe (raise txErrors ThingNotFound) return =<< getBlock h - refuseLargeBlock txErrors b - catMaybes <$> mapM getTransaction (blockDataTxs b) + mapM f (blockDataTxs b) + where + f x = lift $ withRunInIO $ \run -> + unsafeInterleaveIO . run $ + getTransaction x >>= \case + Nothing -> undefined + Just t -> return t scottyTxsBlock :: (MonadUnliftIO m, MonadLoggerIO m) => GetTxsBlock -> WebT m [Transaction] @@ -1292,7 +1300,7 @@ hash = outPointHash unspentPoint idx = outPointIndex unspentPoint val = unspentAmount - script = fromShort unspentScript + script = unspentScript txi = encodeBinfoTxId numtxid hash in BinfoUnspent { getBinfoUnspentHash = hash @@ -1503,7 +1511,7 @@ let f StoreCoinbase{} = False f StoreInput{inputAddress = Nothing} = False f StoreInput{inputAddress = Just a} = a `HashSet.member` s - g StoreOutput{outputAddress = m} = case m of + g StoreOutput{outputAddr = m} = case m of Nothing -> False Just a -> a `HashSet.member` s i = any f (transactionInputs t) @@ -1549,31 +1557,67 @@ | otherwise = 0 received _ = 0 +getBinfoHex :: Monad m => WebT m Bool +getBinfoHex = + (== ("hex" :: Text)) <$> + S.param "format" `S.rescue` const (return "json") + +scottyBinfoBlock :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () +scottyBinfoBlock = + getNumTxId >>= \numtxid -> + getBinfoHex >>= \hex -> + withMetrics rawBlockResponseTime 1 $ + S.param "block" >>= \case + BinfoBlockHash bh -> go numtxid hex bh + BinfoBlockIndex i -> + getBlocksAtHeight i >>= \case + [] -> raise blockErrors ThingNotFound + bh:_ -> go numtxid hex bh + where + get_tx th = + withRunInIO $ \run -> + unsafeInterleaveIO $ + run $ fromJust <$> getTransaction th + go numtxid hex bh = + getBlock bh >>= \case + Nothing -> raise blockErrors ThingNotFound + Just b -> do + txs <- lift $ mapM get_tx (blockDataTxs b) + nxt <- getBlocksAtHeight (blockDataHeight b + 1) + if hex + then do + let x = H.Block (blockDataHeader b) (map transactionData txs) + setHeaders + S.text . encodeHexLazy . runPutL $ serialize x + else do + let btxs = map (toBinfoTxSimple numtxid) txs + y = toBinfoBlock b btxs nxt + setHeaders + net <- lift $ asks (storeNetwork . webStore . webConfig) + streamEncoding $ binfoBlockToEncoding net y + scottyBinfoTx :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () scottyBinfoTx = getNumTxId >>= \numtxid -> + getBinfoHex >>= \hex -> S.param "txid" >>= \txid -> - withMetrics rawtxResponseTime 1 $ go numtxid txid + withMetrics rawtxResponseTime 1 $ + let f (BinfoTxIdHash h) = maybeToList <$> getTransaction h + f (BinfoTxIdIndex i) = getNumTransaction i + in f txid >>= \case + [] -> raise rawtxErrors ThingNotFound + [t] -> if hex then hx t else js numtxid t + ts -> + let tids = map (txHash . transactionData) ts + in raise rawtxErrors (TxIndexConflict tids) where - get_format = S.param "format" `S.rescue` const (return ("json" :: Text)) js numtxid t = do net <- lift $ asks (storeNetwork . webStore . webConfig) setHeaders streamEncoding $ binfoTxToEncoding net $ toBinfoTxSimple numtxid t - hex t = do + hx t = do setHeaders - S.text . TL.fromStrict . encodeHex . encode $ transactionData t - go numtxid txid = - let f (BinfoTxIdHash h) = maybeToList <$> getTransaction h - f (BinfoTxIdIndex i) = getNumTransaction i - in f txid >>= \case - [] -> raise rawtxErrors ThingNotFound - [t] -> get_format >>= \case - "hex" -> hex t - _ -> js numtxid t - ts -> - let tids = map (txHash . transactionData) ts - in raise rawtxErrors (TxIndexConflict tids) + S.text . encodeHexLazy . runPutL . serialize $ transactionData t -- GET Network Information -- @@ -1736,15 +1780,15 @@ resM <- paramOptional `S.rescue` const (return Nothing) maybe S.next return resM -parseBody :: (MonadIO m, Serialize a) => WebT m a +parseBody :: (MonadIO m, Serial a) => WebT m a parseBody = do b <- S.body - case hex b <|> bin (L.toStrict b) of - Nothing -> raise_ $ UserError "Failed to parse request body" - Just x -> return x + case hex b <> bin b of + Left _ -> raise_ $ UserError "Failed to parse request body" + Right x -> return x where - bin = eitherToMaybe . Serialize.decode - hex = bin <=< decodeHex . cs . C.filter (not . isSpace) + bin = runGetL deserialize + hex = bin <=< BL16.decodeBase16 . C.filter (not . isSpace) parseOffset :: MonadIO m => WebT m OffsetParam parseOffset = do