haskoin-store 0.46.6 → 0.47.0

raw patch · 7 files changed

+122/−71 lines, 7 filesdep +base16dep +bytesdep ~haskoin-store-dataPVP ok

version bump matches the API change (PVP)

Dependencies added: base16, bytes

Dependency ranges changed: haskoin-store-data

API changes (from Hackage documentation)

Files

• CHANGELOG.md +7/−0
• haskoin-store.cabal +11/−5
• src/Haskoin/Store/Cache.hs +1/−3
• src/Haskoin/Store/Database/Types.hs +3/−5
• src/Haskoin/Store/Database/Writer.hs +1/−2
• src/Haskoin/Store/Logic.hs +7/−8
• src/Haskoin/Store/Web.hs +92/−48

@@ -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.

@@ -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 <https://github.com/haskoin/haskoin-store#readme> 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

@@ -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

@@ -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)         }

@@ -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) } 

@@ -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                     }

@@ -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