haskoin-store 0.16.5 → 0.16.6
raw patch · 5 files changed
+269/−212 lines, 5 filesdep +waidep −uuid
Dependencies added: wai
Dependencies removed: uuid
Files
- app/Main.hs +1/−1
- haskoin-store.cabal +6/−5
- src/Network/Haskoin/Store/Data.hs +141/−56
- src/Network/Haskoin/Store/Web.hs +73/−150
- test/Network/Haskoin/Store/DataSpec.hs +48/−0
app/Main.hs view
@@ -214,7 +214,7 @@ where l _ lvl | deb = True- | otherwise = LevelWarn <= lvl+ | otherwise = LevelInfo <= lvl clear = case cd of Nothing -> return ()
haskoin-store.cabal view
@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 545948e0c4f4a34a7d6185ca86f13515e6f723853f2722c630202699fa2bf266+-- hash: 2b80cfe38cf9c795efc07f40baf79adabae03baf6e15dcaa6c752ae6fdfad488 name: haskoin-store-version: 0.16.5+version: 0.16.6 synopsis: Storage and index for Bitcoin and Bitcoin Cash description: Store blocks, transactions, and balances for Bitcoin or Bitcoin Cash, and make that information via REST API. category: Bitcoin, Finance, Network@@ -72,7 +72,7 @@ , transformers , unliftio , unordered-containers- , uuid+ , wai default-language: Haskell2010 executable haskoin-store@@ -112,7 +112,7 @@ , transformers , unliftio , unordered-containers- , uuid+ , wai default-language: Haskell2010 test-suite haskoin-store-test@@ -120,6 +120,7 @@ main-is: Spec.hs other-modules: Haskoin.StoreSpec+ Network.Haskoin.Store.DataSpec Paths_haskoin_store hs-source-dirs: test@@ -153,6 +154,6 @@ , transformers , unliftio , unordered-containers- , uuid+ , wai default-language: Haskell2010 build-tool-depends: hspec-discover:hspec-discover
src/Network/Haskoin/Store/Data.hs view
@@ -1,8 +1,10 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-}+ module Network.Haskoin.Store.Data where import Conduit@@ -33,7 +35,7 @@ import Database.RocksDB (DB, ReadOptions) import GHC.Generics import Haskoin as H-import Network.Socket (SockAddr)+import Network.Socket (SockAddr (SockAddrUnix)) import Paths_haskoin_store as P import UnliftIO import UnliftIO.Exception@@ -130,6 +132,7 @@ instance BinSerial TxHash where binSerial _ = put+ binDeserial _ = get instance BinSerial Address where binSerial net a =@@ -137,11 +140,23 @@ Nothing -> put B.empty Just x -> put $ T.encodeUtf8 x + binDeserial net = do+ bs <- get+ guard (not (B.null bs))+ t <- case T.decodeUtf8' bs of+ Left _ -> mzero+ Right v -> return v+ case stringToAddr net t of+ Nothing -> mzero+ Just x -> return x+ class BinSerial a where binSerial :: Network -> Putter a+ binDeserial :: Network -> Get a instance BinSerial a => BinSerial [a] where binSerial net = putListOf (binSerial net)+ binDeserial net = getListOf (binDeserial net) -- | Reference to a block where a transaction is stored. data BlockRef@@ -182,6 +197,12 @@ putWord8 0x01 putWord64be t + binDeserial _ = getWord8 >>=+ \case+ 0x00 -> BlockRef <$> getWord32be <*> getWord32be+ 0x01 -> MemRef <$> getUnixTime+ _ -> fail "Expected fst byte to be 0x00 or 0x01"+ -- | JSON serialization for 'BlockRef'. blockRefPairs :: A.KeyValue kv => BlockRef -> [kv] blockRefPairs BlockRef {blockRefHeight = h, blockRefPos = p} =@@ -220,10 +241,12 @@ jsonValue _ = toJSON instance BinSerial BlockTx where- binSerial net BlockTx { blockTxBlock = b, blockTxHash = h }= do+ binSerial net BlockTx { blockTxBlock = b, blockTxHash = h } = do binSerial net b- put h+ binSerial net h + binDeserial net = BlockTx <$> binDeserial net <*> binDeserial net+ -- | Address balance information. data Balance = Balance { balanceAddress :: !Address@@ -276,6 +299,15 @@ putWord64be c putWord64be t + binDeserial net =+ Balance <$> binDeserial net+ <*> getWord64be+ <*> getWord64be+ <*> getWord64be+ <*> getWord64be+ <*> getWord64be++ -- | Unspent output. data Unspent = Unspent { unspentBlock :: !BlockRef@@ -330,8 +362,15 @@ binSerial net b put p putWord64be v- put $ B.Short.fromShort s+ put s + binDeserial net =+ Unspent+ <$> binDeserial net+ <*> get+ <*> getWord64be+ <*> get+ -- | Database value for a block entry. data BlockData = BlockData { blockDataHeight :: !BlockHeight@@ -388,6 +427,7 @@ instance BinSerial BlockData where binSerial _ BlockData { blockDataHeight = e , blockDataMainChain = m+ , blockDataWork = w , blockDataHeader = h , blockDataSize = z , blockDataWeight = g@@ -399,6 +439,7 @@ put m putWord32be e put h+ put w putWord32be z putWord32be g putWord64be o@@ -406,6 +447,18 @@ putWord64be y put t + binDeserial _ = do+ m <- get+ e <- getWord32be+ h <- get+ w <- get+ z <- getWord32be+ g <- getWord32be+ o <- getWord64be+ f <- getWord64be+ y <- getWord64be+ t <- get+ return $ BlockData e m w h z g t o f y -- | Input information. data StoreInput@@ -480,33 +533,6 @@ inputToEncoding :: Network -> StoreInput -> Encoding inputToEncoding net = pairs . mconcat . inputPairs net -instance BinSerial StoreInput where- binSerial net i = do- put $- case i of- StoreCoinbase {} -> True- StoreInput {} -> False- put $ inputPoint i- putWord32be $ inputSequence i- put $ inputSigScript i- put $ inputWitness i- let a =- case i of- StoreCoinbase {} -> Nothing- StoreInput {inputPkScript = s} ->- eitherToMaybe (scriptToAddressBS s)- case a of- Nothing -> put B.empty- Just x -> binSerial net x- putWord64be $- case i of- StoreCoinbase {} -> 0- StoreInput {inputAmount = v} -> v- put $- case i of- StoreCoinbase {} -> B.empty- StoreInput {inputPkScript = s} -> s- -- | Information about input spending output. data Spender = Spender { spenderHash :: !TxHash@@ -590,6 +616,33 @@ , txDataTime :: !Word64 } deriving (Show, Eq, Ord, Generic, Serialize) +instance BinSerial TxData where+ binSerial _ TxData+ { txDataBlock = br+ , txData = tx+ , txDataPrevs = dp+ , txDataDeleted = dd+ , txDataRBF = dr+ , txDataTime = t+ } = do+ put br+ put tx+ put dp+ put dd+ put dr+ putWord64be t++ binDeserial _ = do br <- get+ tx <- get+ dp <- get+ dd <- get+ dr <- get+ TxData br tx dp dd dr <$> getWord64be++instance Serialize a => BinSerial (IntMap a) where+ binSerial _ = put+ binDeserial _ = get+ toTransaction :: TxData -> IntMap Spender -> Transaction toTransaction t sm = Transaction@@ -704,24 +757,16 @@ jsonValue = transactionToJSON instance BinSerial Transaction where- binSerial net Transaction { transactionBlock = b- , transactionVersion = v- , transactionLockTime = l- , transactionInputs = is- , transactionOutputs = os- , transactionDeleted = d- , transactionRBF = r- , transactionTime = t- } = do- binSerial net b- putWord32be v- putWord32be l- put d- put r- putWord64be t- put is- put os+ binSerial net tx = do+ let (txd, sp) = fromTransaction tx+ binSerial net txd+ binSerial net sp + binDeserial net = do+ txd <- binDeserial net+ sp <- binDeserial net+ return $ toTransaction txd sp+ -- | Information about a connected peer. data PeerInformation = PeerInformation { peerUserAgent :: !ByteString@@ -763,11 +808,17 @@ , peerRelay = b } = do putWord32be v- putWord64be s put b- put $ show a put u+ put $ NetworkAddress s a + binDeserial _ = do+ v <- getWord32be+ b <- get+ u <- get+ NetworkAddress { naServices = s, naAddress = a } <- get+ return $ PeerInformation u a v s b+ -- | Address balances for an extended public key. data XPubBal = XPubBal { xPubBalPath :: ![KeyIndex]@@ -795,6 +846,10 @@ binSerial net XPubBal {xPubBalPath = p, xPubBal = b} = do put p binSerial net b+ binDeserial net = do+ p <- get+ b <- binDeserial net+ return $ XPubBal p b -- | Unspent transaction for extended public key. data XPubUnspent = XPubUnspent@@ -826,6 +881,11 @@ put p binSerial net u + binDeserial net = do+ p <- get+ u <- binDeserial net+ return $ XPubUnspent p u+ data XPubSummary = XPubSummary { xPubSummaryReceived :: !Word64@@ -880,13 +940,27 @@ put z put ext put ch- putWord64be (fromIntegral $ M.size ps)- forM_ (M.toList ps) $ \(a, p) -> do- binSerial net a- put p- putWord64be (fromIntegral $ length ts)- forM_ ts $ binSerial net+ put (map (first (runPut . binSerial net)) (M.toList ps))+ put $ map (runPut . binSerial net) ts + binDeserial net = do+ r <- get+ c <- get+ z <- get+ ext <- get+ ch <- get+ ps <- get+ let xs = map (first (runGet (binDeserial net))) ps+ ys <- forM xs $ \(k, v) -> case k of+ Right a -> return (a, v)+ Left _ -> mzero+ ts <- get+ let txs = map (runGet (binDeserial net)) ts+ tys <- forM txs $ \case+ Right a -> return a+ Left _ -> mzero+ return $ XPubSummary r c z ext ch (M.fromList ys) tys+ data HealthCheck = HealthCheck { healthHeaderBest :: !(Maybe BlockHash) , healthHeaderHeight :: !(Maybe BlockHeight)@@ -938,6 +1012,8 @@ put ok put synced + binDeserial _ = HealthCheck <$> get <*> get <*> get <*> get <*> get <*> get <*> get <*> get+ data Event = EventBlock BlockHash | EventTx TxHash@@ -955,6 +1031,13 @@ binSerial _ (EventBlock bh) = putWord8 0x00 >> put bh binSerial _ (EventTx th) = putWord8 0x01 >> put th + binDeserial _ = getWord8 >>=+ \case+ 0x00-> EventBlock <$> get+ 0x01 -> EventTx <$> get+ _ -> fail "Expected fst byte to be 0x00 or 0x01"++ newtype TxAfterHeight = TxAfterHeight { txAfterHeight :: Maybe Bool } deriving (Show, Eq, Generic)@@ -968,6 +1051,7 @@ instance BinSerial TxAfterHeight where binSerial _ TxAfterHeight {txAfterHeight = a} = put a+ binDeserial _ = TxAfterHeight <$> get newtype TxId = TxId TxHash deriving (Show, Eq, Generic) @@ -980,6 +1064,7 @@ instance BinSerial TxId where binSerial _ (TxId th) = put th+ binDeserial _ = TxId <$> get data StartFrom = StartBlock !BlockHeight !BlockPos
src/Network/Haskoin/Store/Web.hs view
@@ -5,6 +5,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-}+ module Network.Haskoin.Store.Web where import Conduit hiding (runResourceT) import Control.Applicative ((<|>))@@ -34,8 +35,7 @@ import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.Text.Lazy as T.Lazy-import Data.UUID (UUID)-import Data.UUID.V4+import Data.Time.Clock import Data.Version import Data.Word (Word32) import Database.RocksDB as R@@ -45,6 +45,7 @@ import Network.Haskoin.Store.Data.Cached import Network.Haskoin.Store.Messages import Network.HTTP.Types+import Network.Wai import NQE import qualified Paths_haskoin_store as P import Text.Read (readMaybe)@@ -56,19 +57,19 @@ type WebT m = ActionT Except (ReaderT LayeredDB m) data Except- = ThingNotFound UUID- | ServerError UUID- | BadRequest UUID- | UserError UUID String+ = ThingNotFound+ | ServerError+ | BadRequest+ | UserError String | StringError String deriving Eq instance Show Except where- show (ThingNotFound u) = "not found"- show (ServerError u) = "you made me kill a unicorn"- show (BadRequest u) = "bad request"- show (UserError u s) = s- show (StringError s) = "you killed the dragon with your bare hands"+ show ThingNotFound = "not found"+ show ServerError = "you made me kill a unicorn"+ show BadRequest = "bad request"+ show (UserError s) = s+ show (StringError s) = "you killed the dragon with your bare hands" instance Exception Except @@ -84,7 +85,20 @@ jsonValue _ = toJSON instance BinSerial Except where- binSerial _ = Serialize.put . T.encodeUtf8 . T.pack . show+ binSerial _ ex =+ case ex of+ ThingNotFound -> putWord8 0+ ServerError -> putWord8 1+ BadRequest -> putWord8 2+ UserError s -> putWord8 3 >> Serialize.put s+ StringError s -> putWord8 4 >> Serialize.put s+ binDeserial _ =+ getWord8 >>= \case+ 0 -> return ThingNotFound+ 1 -> return ServerError+ 2 -> return BadRequest+ 3 -> UserError <$> Serialize.get+ 4 -> StringError <$> Serialize.get data WebConfig = WebConfig@@ -131,22 +145,21 @@ defHandler net e = do proto <- setupBin case e of- ThingNotFound _ -> status status404- BadRequest _ -> status status400- UserError _ _ -> status status400- StringError _ -> status status400- ServerError _ -> status status500+ ThingNotFound -> status status404+ BadRequest -> status status400+ UserError _ -> status status400+ StringError _ -> status status400+ ServerError -> status status500 protoSerial net proto e maybeSerial :: (Monad m, JsonSerial a, BinSerial a) => Network- -> UUID -> Bool -- ^ binary -> Maybe a -> WebT m ()-maybeSerial _ u _ Nothing = raise $ ThingNotFound u-maybeSerial net _ proto (Just x) = S.raw $ serialAny net proto x+maybeSerial _ _ Nothing = raise ThingNotFound+maybeSerial net proto (Just x) = S.raw $ serialAny net proto x protoSerial :: (Monad m, JsonSerial a, BinSerial a)@@ -159,8 +172,6 @@ scottyBestBlock :: MonadLoggerIO m => Network -> WebT m () scottyBestBlock net = do cors- (i, u) <- uuid- $(logDebugS) i "Get best block" n <- parseNoTx proto <- setupBin res <-@@ -168,32 +179,24 @@ h <- MaybeT getBestBlock b <- MaybeT $ getBlock h return $ pruneTx n b- $(logDebugS) i $- "Response block hash: " <>- maybe "[none]" (blockHashToHex . headerHash . blockDataHeader) res- maybeSerial net u proto res+ maybeSerial net proto res scottyBlock :: MonadLoggerIO m => Network -> WebT m () scottyBlock net = do cors block <- param "block"- (i, u) <- uuid- $(logDebugS) i $ "Get block: " <> blockHashToHex block n <- parseNoTx proto <- setupBin res <- runMaybeT $ do b <- MaybeT $ getBlock block return $ pruneTx n b- $(logDebugS) i $ maybe "Block not found" (const "Block found") res- maybeSerial net u proto res+ maybeSerial net proto res scottyBlockHeight :: MonadLoggerIO m => Network -> WebT m () scottyBlockHeight net = do cors height <- param "height"- (i, u) <- uuid- $(logDebugS) i $ "Get blocks at height: " <> cs (show height) n <- parseNoTx proto <- setupBin res <-@@ -203,15 +206,12 @@ runMaybeT $ do b <- MaybeT $ getBlock h return $ pruneTx n b- $(logDebugS) i $ "Blocks returned: " <> cs (show (length res)) protoSerial net proto res scottyBlockHeights :: MonadLoggerIO m => Network -> WebT m () scottyBlockHeights net = do cors heights <- param "heights"- (i, u) <- uuid- $(logDebugS) i $ "Get blocks at multiple heights: " <> cs (show heights) n <- parseNoTx proto <- setupBin bs <- concat <$> mapM getBlocksAtHeight (nub heights)@@ -220,15 +220,12 @@ runMaybeT $ do b <- MaybeT $ getBlock bh return $ pruneTx n b- $(logDebugS) i $ "Blocks returned: " <> cs (show (length res)) protoSerial net proto res scottyBlocks :: MonadLoggerIO m => Network -> WebT m () scottyBlocks net = do cors blocks <- param "blocks"- (i, u) <- uuid- $(logDebugS) i $ "Get multiple blocks: " <> cs (show blocks) n <- parseNoTx proto <- setupBin res <-@@ -236,49 +233,35 @@ runMaybeT $ do b <- MaybeT $ getBlock bh return $ pruneTx n b- $(logDebugS) i $ "Blocks returned: " <> cs (show (length res)) protoSerial net proto res scottyMempool :: (MonadLoggerIO m, MonadUnliftIO m) => Network -> WebT m () scottyMempool net = do cors (l, s) <- parseLimits- (i, u) <- uuid proto <- setupBin db <- askDB- $(logDebugS) i "Get mempool" stream $ \io flush' -> do runResourceT . withLayeredDB db $ runConduit $ getMempoolLimit l s .| streamAny net proto io flush'- $(logDebugS) i "Mempool streaming complete" scottyTransaction :: MonadLoggerIO m => Network -> WebT m () scottyTransaction net = do cors txid <- param "txid"- (i, u) <- uuid- $(logDebugS) i $ "Get transaction: " <> txHashToHex txid proto <- setupBin res <- getTransaction txid- case res of- Nothing -> $(logDebugS) i "Transaction not found"- Just _ -> $(logDebugS) i "Transaction found"- maybeSerial net u proto res+ maybeSerial net proto res scottyRawTransaction :: MonadLoggerIO m => Bool -> WebT m () scottyRawTransaction hex = do cors txid <- param "txid"- (i, u) <- uuid- $(logDebugS) i $ "Get raw transaction: " <> txHashToHex txid res <- getTransaction txid case res of- Nothing -> do- $(logDebugS) i "Transaction not found"- raise $ ThingNotFound u+ Nothing -> raise ThingNotFound Just x -> do- $(logDebugS) i "Transaction found" if hex then text . cs . encodeHex . Serialize.encode $ transactionData x@@ -291,16 +274,8 @@ cors txid <- param "txid" height <- param "height"- (i, _) <- uuid- $(logDebugS) i $- "Is transaction " <> txHashToHex txid <> "after height" <>- cs (show height) <> "?" proto <- setupBin res <- cbAfterHeight 10000 height txid- case txAfterHeight res of- Nothing -> $(logDebugS) i $ "Could not find out"- Just False -> $(logDebugS) i "No"- Just True -> $(logDebugS) i "Yes" protoSerial net proto res scottyTransactions :: MonadLoggerIO m => Network -> WebT m ()@@ -308,20 +283,14 @@ cors txids <- param "txids" proto <- setupBin- (i, _) <- uuid- $(logDebugS) i $ "Get transactions: " <> cs (show txids) res <- catMaybes <$> mapM getTransaction (nub txids)- $(logDebugS) i $ "Transactions returned: " <> cs (show (length res)) protoSerial net proto res scottyRawTransactions :: MonadLoggerIO m => Bool -> WebT m () scottyRawTransactions hex = do cors txids <- param "txids"- (i, _) <- uuid- $(logDebugS) i $ "Get raw transactions: " <> cs (show txids) res <- catMaybes <$> mapM getTransaction (nub txids)- $(logDebugS) i $ "Transactions returned: " <> cs (show (length res)) if hex then S.json $ map (encodeHex . Serialize.encode . transactionData) res else do@@ -335,14 +304,10 @@ a <- parseAddress net (l, s) <- parseLimits proto <- setupBin- (i, _) <- uuid- $(logDebugS) i $- "Get transactions for address: " <> fromMaybe "???" (addrToString net a) db <- askDB stream $ \io flush' -> do runResourceT . withLayeredDB db . runConduit $ f proto l s a io flush'- $(logDebugS) i "Streamed transactions" where f proto l s a io | full = getAddressTxsFull l s a .| streamAny net proto io@@ -355,15 +320,10 @@ as <- parseAddresses net (l, s) <- parseLimits proto <- setupBin- (i, _) <- uuid- $(logDebugS) i $- "Get transactions for addresses: [" <>- T.intercalate "," (map (fromMaybe "???" . addrToString net) as) <> "]" db <- askDB stream $ \io flush' -> do runResourceT . withLayeredDB db . runConduit $ f proto l s as io flush'- $(logDebugS) i "Streamed transactions" where f proto l s as io | full = getAddressesTxsFull l s as .| streamAny net proto io@@ -374,9 +334,6 @@ scottyAddressUnspent net = do cors a <- parseAddress net- (i, _) <- uuid- $(logDebugS) i $- "Get UTXO for address: " <> fromMaybe "???" (addrToString net a) (l, s) <- parseLimits proto <- setupBin db <- askDB@@ -384,7 +341,6 @@ runResourceT . withLayeredDB db . runConduit $ getAddressUnspentsLimit l s a .| streamAny net proto io flush'- $(logDebugS) i "Streamed UTXO" scottyAddressesUnspent :: (MonadLoggerIO m, MonadUnliftIO m) => Network -> WebT m ()@@ -392,26 +348,18 @@ cors as <- parseAddresses net (l, s) <- parseLimits- (i, _) <- uuid- $(logDebugS) i $- "Get UTXO for addresses: [" <>- T.intercalate "," (map (fromMaybe "???" . addrToString net) as) <> "]" proto <- setupBin db <- askDB stream $ \io flush' -> do runResourceT . withLayeredDB db . runConduit $ getAddressesUnspentsLimit l s as .| streamAny net proto io flush'- $(logDebugS) i "Streamed UTXO" scottyAddressBalance :: MonadLoggerIO m => Network -> WebT m () scottyAddressBalance net = do cors a <- parseAddress net proto <- setupBin- (i, _) <- uuid- $(logDebugS) i $- "Get balance for address: " <> fromMaybe "???" (addrToString net a) res <- getBalance a >>= \case Just b -> return b@@ -425,7 +373,6 @@ , balanceTxCount = 0 , balanceTotalReceived = 0 }- $(logDebugS) i "Returned balance" protoSerial net proto res scottyAddressesBalances :: MonadLoggerIO m => Network -> WebT m ()@@ -433,11 +380,6 @@ cors as <- parseAddresses net proto <- setupBin- (i, _) <- uuid- $(logDebugS) i $- "Get UTXO for addresses: [" <>- T.intercalate "," (map (fromMaybe "???" . addrToString net) as) <>- "]" let f a Nothing = Balance { balanceAddress = a@@ -449,7 +391,6 @@ } f _ (Just b) = b res <- mapM (\a -> f a <$> getBalance a) as- $(logDebugS) i $ "Returned balances: " <> cs (show (length res)) protoSerial net proto res scottyXpubBalances :: (MonadUnliftIO m, MonadLoggerIO m) => Network -> WebT m ()@@ -457,11 +398,8 @@ cors xpub <- parseXpub net proto <- setupBin- (i, _) <- uuid- $(logDebugS) i $ "Get balances for xpub: " <> xPubExport net xpub db <- askDB res <- liftIO . runResourceT . withLayeredDB db $ xpubBals xpub- $(logDebugS) i $ "Returned balances: " <> cs (show (length res)) protoSerial net proto res scottyXpubTxs ::@@ -471,14 +409,11 @@ x <- parseXpub net (l, s) <- parseLimits proto <- setupBin- (i, _) <- uuid- $(logDebugS) i $ "Get transactions for xpub: " <> xPubExport net x db <- askDB bs <- liftIO . runResourceT . withLayeredDB db $ xpubBals x stream $ \io flush' -> do runResourceT . withLayeredDB db . runConduit $ f proto l s bs io flush'- $(logDebugS) i "Streamed balances" where f proto l s bs io | full =@@ -494,26 +429,20 @@ x <- parseXpub net proto <- setupBin (l, s) <- parseLimits- (i, _) <- uuid- $(logDebugS) i $ "Get UTXO for xpub: " <> xPubExport net x db <- askDB stream $ \io flush' -> do runResourceT . withLayeredDB db . runConduit $ xpubUnspentLimit net l s x .| streamAny net proto io flush'- $(logDebugS) i "Streamed UTXO" scottyXpubSummary :: (MonadLoggerIO m, MonadUnliftIO m) => Network -> WebT m () scottyXpubSummary net = do cors x <- parseXpub net (l, s) <- parseLimits- (i, _) <- uuid- $(logDebugS) i $ "Get summary for xpub: " <> xPubExport net x proto <- setupBin db <- askDB res <- liftIO . runResourceT . withLayeredDB db $ xpubSummary l s x- $(logDebugS) i "Returning summary" protoSerial net proto res scottyPostTx ::@@ -526,22 +455,15 @@ cors proto <- setupBin b <- body- (i, u) <- uuid- $(logDebugS) i "Received transaction to publish" let bin = eitherToMaybe . Serialize.decode hex = bin <=< decodeHex . cs . C.filter (not . isSpace) tx <- case hex b <|> bin (L.toStrict b) of- Nothing -> do- $(logDebugS) i "Decode tx fail"- raise $ UserError u "decode tx fail"- Just x -> do- $(logDebugS) i $ "Transaction id: " <> txHashToHex (txHash x)- return x+ Nothing -> raise $ UserError "decode tx fail"+ Just x -> return x lift (publishTx net pub st tx) >>= \case Right () -> do protoSerial net proto (TxId (txHash tx))- $(logDebugS) i "Success publishing transaction" Left e -> do case e of PubNoPeers -> status status500@@ -549,25 +471,18 @@ PubPeerDisconnected -> status status500 PubNotFound -> status status500 PubReject _ -> status status400- protoSerial net proto (UserError u (show e))- $(logWarnS) i $- "Could not publish: " <> txHashToHex (txHash tx) <> ": " <>- cs (show e)+ protoSerial net proto (UserError (show e)) finish scottyDbStats :: MonadLoggerIO m => WebT m () scottyDbStats = do cors- (i, _) <- uuid- $(logDebugS) i "Get DB stats" LayeredDB {layeredDB = BlockDB {blockDB = db}} <- askDB stats <- lift (getProperty db Stats) case stats of Nothing -> do- $(logWarnS) i "Could not get stats" text "Could not get stats" Just txt -> do- $(logDebugS) i "Returning stats" text $ cs txt scottyEvents ::@@ -577,9 +492,7 @@ -> WebT m () scottyEvents net pub = do cors- (i, _) <- uuid proto <- setupBin- $(logDebugS) i "Streaming events..." stream $ \io flush' -> withSubscription pub $ \sub -> forever $@@ -599,16 +512,12 @@ then mempty else "\n" in io (lazyByteString bs)- $(logDebugS) i "Finished streaming events" scottyPeers :: MonadLoggerIO m => Network -> Store -> WebT m () scottyPeers net st = do cors proto <- setupBin- (i, _) <- uuid- $(logDebugS) i "Get peer information" ps <- getPeersInformation (storeManager st)- $(logDebugS) i $ "Returned peers: " <> cs (show (length ps)) protoSerial net proto ps scottyHealth ::@@ -616,14 +525,8 @@ scottyHealth net st = do cors proto <- setupBin- (i, _) <- uuid- $(logDebugS) i "Get health information" h <- lift $ healthCheck net (storeManager st) (storeChain st)- if not (healthOK h) || not (healthSynced h)- then do- $(logDebugS) i "Not healthy"- status status503- else $(logDebugS) i "Healthy"+ when (not (healthOK h) || not (healthSynced h)) $ status status503 protoSerial net proto h runWeb :: (MonadLoggerIO m, MonadUnliftIO m) => WebConfig -> m ()@@ -634,7 +537,9 @@ , webPublisher = pub } = do runner <- askRunInIO+ l <- logIt scottyT port (runner . withLayeredDB db) $ do+ middleware l defaultHandler (defHandler net) S.get "/block/best" $ scottyBestBlock net S.get "/block/:block" $ scottyBlock net@@ -667,10 +572,7 @@ S.get "/events" $ scottyEvents net pub S.get "/peers" $ scottyPeers net st S.get "/health" $ scottyHealth net st- notFound $ do- (i, u) <- uuid- $(logDebugS) i "Requested resource not found"- raise (ThingNotFound u)+ notFound $ raise ThingNotFound parseLimits :: (ScottyError e, Monad m) => ActionT e m (Maybe Word32, StartFrom) parseLimits = do@@ -780,7 +682,7 @@ h <- MaybeT getBestBlock MaybeT $ getBlock h p <- timeout (5 * 1000 * 1000) $ managerGetPeers mgr- let k = isNothing n || isNothing b || maybe False (not . null) p+ let k = isNothing n || isNothing b || maybe False (not . Data.List.null) p s = isJust $ do x <- n@@ -1141,10 +1043,31 @@ | h' == txHash tx -> return $ Right () _ -> g p s -uuid :: MonadLoggerIO m => WebT m (Text, UUID)-uuid = do- u <- liftIO nextRandom- r <- request- let t = "Web<" <> cs (show u) <> ">"- $(logDebugS) t $ cs (show r)- return (t, u)+logIt :: (MonadLoggerIO m, MonadUnliftIO m) => m Middleware+logIt = do+ runner <- askRunInIO+ return $ \app req respond -> do+ t1 <- getCurrentTime+ app req $ \res -> do+ t2 <- getCurrentTime+ let d = diffUTCTime t2 t1+ s = responseStatus res+ runner $+ $(logInfoS) "Web" $+ fmtReq req <> " [" <> fmtStatus s <> " / " <> fmtDiff d <> "]"+ respond res++fmtReq :: Request -> Text+fmtReq req =+ let method = requestMethod req+ version = httpVersion req+ path = rawPathInfo req+ query = rawQueryString req+ in T.decodeUtf8 $+ method <> " " <> path <> query <> " " <> cs (show version)++fmtDiff :: NominalDiffTime -> Text+fmtDiff d = cs (show (round (d * 1000) :: Integer)) <> " ms"++fmtStatus :: Status -> Text+fmtStatus s = cs (show (statusCode s)) <> " " <> cs (statusMessage s)
+ test/Network/Haskoin/Store/DataSpec.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.Haskoin.Store.DataSpec+ ( spec+ ) where++import Control.Monad+import Control.Monad.Logger+import Control.Monad.Trans+import Data.Either+import Data.Maybe+import Data.Serialize+import qualified Data.Text as T+import Haskoin+import Haskoin.Node+import Haskoin.Store+import NQE+import Test.Hspec++spec :: Spec+spec = do+ let net = btc++ describe "Test TxHash serialization" $+ it "serializes tx" $ do+ let tx = TxHash "0666939fb16533c8e5ebaf6052bb8c90d27ee53fe6035bb763de5253e0b1cd44"+ testSerial net tx++ describe "Test Address serialization" $+ it "serialize address" $ do+ let addr = fromJust $ stringToAddr net "1DtDAYYTWRoiXvHRjARwVhjCUnNTk1XfXw"+ testSerial net addr++ describe "Test serialization of a list of addresses" $+ it "serialize addresses" $ do+ let addr1 = fromJust $ stringToAddr net "1DtDAYYTWRoiXvHRjARwVhjCUnNTk1XfXw"+ addr2 = fromJust $ stringToAddr net "1GhnssnwRZwWKbHQXJRFpQfkfvE6hDG2KF"+ expected = toAddrList net ["1DtDAYYTWRoiXvHRjARwVhjCUnNTk1XfXw", "1GhnssnwRZwWKbHQXJRFpQfkfvE6hDG2KF"]+ testSerial net expected++toAddrList :: Network -> [T.Text] -> [Address]+toAddrList net = map (fromJust . stringToAddr net)++testSerial :: (Eq a, Show a, BinSerial a) => Network -> a -> Expectation+testSerial net input =+ let raw = runPut $ binSerial net input+ deser = runGet (binDeserial net) raw+ in deser `shouldBe` Right input