packages feed

electrs-client (empty) → 0.1.0.0

raw patch · 15 files changed

+702/−0 lines, 15 filesdep +GenericPrettydep +SHAdep +aesonsetup-changed

Dependencies added: GenericPretty, SHA, aeson, base, bytestring, electrs-client, envparse, generic-pretty-instances, hex-text, hspec, network, network-bitcoin, text, transformers, unbounded-delays, universum, unliftio

Files

+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for electrs-client++## 0.1.0.0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Yolo (c) 2022++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Yolo nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ electrs-client.cabal view
@@ -0,0 +1,122 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.34.7.+--+-- see: https://github.com/sol/hpack++name:                electrs-client+version:             0.1.0.0+synopsis:            Electrs client library for Haskell+description:         You can find documentation at <https://hackage.haskell.org/package/electrs-client>+category:            Electrs, Bitcoin, Finance, Network, Payments+homepage:            https://github.com/coingaming/src+bug-reports:         https://github.com/coingaming/src/issues+license:             BSD3+license-file:        LICENSE+build-type:          Simple+author:              21it <21it@tuta.io>, Mikhail Prushinskiy <mprushinsky@gmail.com>, Artem Markov <drownbes@gmail.com>+maintainer:          21it <21it@tuta.io>, Mikhail Prushinskiy <mprushinsky@gmail.com>, Artem Markov <drownbes@gmail.com>+copyright:           2022 Yolo <hello@coingaming.io>+extra-source-files:+    CHANGELOG.md++source-repository head+  type: git+  location: https://github.com/coingaming/src++library+  exposed-modules:+      ElectrsClient.Client+      ElectrsClient.Data.Env+      ElectrsClient.Helper+      ElectrsClient.Import.External+      ElectrsClient.Rpc+      ElectrsClient.RpcRequest+      ElectrsClient.RpcResponse+      ElectrsClient.Type+  other-modules:+      Paths_electrs_client+  hs-source-dirs:+      src+  default-extensions:+      NoImplicitPrelude+      MultiParamTypeClasses+      LambdaCase+      OverloadedStrings+      ScopedTypeVariables+      DeriveGeneric+      GeneralizedNewtypeDeriving+      TupleSections+      DataKinds+      DerivingStrategies+      KindSignatures+      FlexibleContexts+      FlexibleInstances+      StrictData+      TypeFamilies+      TypeOperators+      StandaloneDeriving+      DerivingVia+      ExistentialQuantification+      InstanceSigs+  ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-missing-export-lists -fwarn-tabs+  build-depends:+      GenericPretty+    , SHA+    , aeson >=1.4 && <1.6+    , base >=4.7 && <5+    , bytestring+    , envparse+    , generic-pretty-instances+    , hex-text+    , network+    , network-bitcoin+    , text+    , transformers+    , unbounded-delays+    , universum+    , unliftio+  if impl(ghc >= 8.10.7)+    ghc-options: -Wno-missing-safe-haskell-mode -Wno-prepositive-qualified-module -fenable-th-splice-warnings -fprint-potential-instances+  default-language: Haskell2010++test-suite electrs-client-test+  type: exitcode-stdio-1.0+  main-is: Main.hs+  other-modules:+      RpcSpec+      Spec+      Paths_electrs_client+  hs-source-dirs:+      test+  default-extensions:+      NoImplicitPrelude+      MultiParamTypeClasses+      LambdaCase+      OverloadedStrings+      ScopedTypeVariables+      DeriveGeneric+      GeneralizedNewtypeDeriving+      TupleSections+      DataKinds+      DerivingStrategies+      KindSignatures+      FlexibleContexts+      FlexibleInstances+      StrictData+      TypeFamilies+      TypeOperators+      StandaloneDeriving+      DerivingVia+      ExistentialQuantification+      InstanceSigs+  ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-missing-export-lists -O2 -optc-O3 -funfolding-use-threshold=16 -threaded -rtsopts -with-rtsopts=-N -optl-fuse-ld=gold+  ld-options: -fuse-ld=gold+  build-depends:+      base+    , electrs-client+    , hspec+    , network-bitcoin+  if impl(ghc >= 8.10.7)+    ghc-options: -Wno-missing-safe-haskell-mode -Wno-prepositive-qualified-module -fenable-th-splice-warnings -fprint-potential-instances+  default-language: Haskell2010
+ src/ElectrsClient/Client.hs view
@@ -0,0 +1,60 @@+module ElectrsClient.Client+  ( send,+  )+where++import ElectrsClient.Data.Env+import ElectrsClient.Import.External+import ElectrsClient.Type+import Network.Socket+import Network.Socket.ByteString (recv, sendAll)+import qualified UnliftIO.Exception as E++send ::+  ( MonadUnliftIO m+  ) =>+  ByteString ->+  ElectrsEnv ->+  m (Either RpcError ByteString)+send req env = do+  liftIO $+    runTCPClient+      (unpack $ electrsEnvHost env)+      (unpack $ electrsEnvPort env)+      $ \s -> do+        sendAll s $ req <> "\n"+        Right <$> recv s 1024++runTCPClient ::+  ( MonadUnliftIO m+  ) =>+  HostName ->+  ServiceName ->+  (Socket -> m (Either RpcError ByteString)) ->+  m (Either RpcError ByteString)+runTCPClient host port client = withRunInIO $ \x -> do+  addr <- resolve+  case addr of+    Left err -> pure $ Left err+    Right addr0 -> do+      withSocketsDo $ do+        x $+          E.bracket+            (open addr0)+            (liftIO . close)+            client+  where+    resolve :: (MonadUnliftIO m) => m (Either RpcError AddrInfo)+    resolve = do+      liftIO $+        maybeToRight RpcNoAddress+          . safeHead+          <$> getAddrInfo Nothing (Just host) (Just port)+    open :: (MonadUnliftIO m) => AddrInfo -> m Socket+    open addr =+      E.bracketOnError+        (liftIO $ openSocket addr)+        (liftIO . close)+        $ \sock -> do+          _ <- liftIO $ connect sock $ addrAddress addr+          pure sock
+ src/ElectrsClient/Data/Env.hs view
@@ -0,0 +1,91 @@+{-# LANGUAGE OverloadedStrings #-}++module ElectrsClient.Data.Env+  ( ElectrsEnv (..),+    BitcoindEnv (..),+    Env (..),+    RawConfig (..),+    readRawConfig,+    parseFromJSON,+  )+where++import Data.Aeson (withObject, (.:))+import qualified Data.Aeson as A (decode)+import Data.ByteString.Lazy.Char8 as C8L (pack)+import ElectrsClient.Import.External+import qualified Env as E+  ( Error (..),+    Mod,+    Var,+    header,+    help,+    keep,+    nonempty,+    parse,+    var,+  )+import Network.Bitcoin as Btc++data ElectrsEnv = ElectrsEnv+  { electrsEnvPort :: Text,+    electrsEnvHost :: Text+  }+  deriving stock (Generic)++instance FromJSON ElectrsEnv where+  parseJSON =+    withObject+      "ElectrsEnv"+      ( \x ->+          ElectrsEnv+            <$> x .: "port"+            <*> x .: "host"+      )++data BitcoindEnv = BitcoindEnv+  { bitcoindEnvHost :: Text,+    bitcoindEnvUsername :: Text,+    bitcoindEnvPassword :: Text+  }+  deriving stock (Generic)++instance FromJSON BitcoindEnv where+  parseJSON =+    withObject+      "BitcoindEnv"+      ( \x ->+          BitcoindEnv+            <$> x .: "host"+            <*> x .: "username"+            <*> x .: "password"+      )++data Env = Env+  { envElectrs :: ElectrsEnv,+    envBtc :: Btc.Client+  }++data RawConfig = RawConfig+  { rawConfigElectrsEnv :: ElectrsEnv,+    rawConfigBtcEnv :: BitcoindEnv+  }++parseFromJSON :: (FromJSON a) => String -> Either E.Error a+parseFromJSON =+  maybe+    (Left $ E.UnreadError "parseFromJSON failed")+    Right+    . A.decode+    . C8L.pack++readRawConfig :: IO RawConfig+readRawConfig =+  E.parse (E.header "ElectrsClient") $+    RawConfig+      <$> E.var (parseFromJSON <=< E.nonempty) "LSP_ELECTRS_ENV" opts+      <*> E.var (parseFromJSON <=< E.nonempty) "LSP_BITCOIND_ENV" opts++opts :: E.Mod E.Var a+opts =+  E.keep <> E.help ""
+ src/ElectrsClient/Helper.hs view
@@ -0,0 +1,56 @@+module ElectrsClient.Helper+  ( waitTillLastBlockProcessedT,+    waitTillLastBlockProcessed,+  )+where++import qualified Control.Concurrent.Thread.Delay as Delay (delay)+import qualified Data.ByteString.Lazy as BS+import qualified Data.Digest.Pure.SHA as SHA+  ( bytestringDigest,+    sha256,+  )+import ElectrsClient.Data.Env+import ElectrsClient.Import.External+import ElectrsClient.Rpc as Rpc+import ElectrsClient.Type+import Network.Bitcoin (Client, getBlockCount, getBlockHash)+import qualified Text.Hex as TH++waitTillLastBlockProcessed ::+  ( MonadUnliftIO m+  ) =>+  Client ->+  ElectrsEnv ->+  Natural ->+  m (Either RpcError ())+waitTillLastBlockProcessed c e =+  runExceptT . waitTillLastBlockProcessedT c e++waitTillLastBlockProcessedT ::+  ( MonadUnliftIO m+  ) =>+  Client ->+  ElectrsEnv ->+  Natural ->+  ExceptT RpcError m ()+waitTillLastBlockProcessedT _ _ 0 =+  throwE CannotSyncBlockchain+waitTillLastBlockProcessedT client env decr = do+  liftIO $ Delay.delay 300+  bHeight <- liftIO $ getBlockCount client+  bHash <- liftIO $ getBlockHash client bHeight+  bHeader <- ExceptT $ Rpc.blockHeader env $ BlkHeight $ fromInteger bHeight+  if (doubleSha256AndReverse <$> TH.decodeHex (coerce bHeader))+    == TH.decodeHex (coerce $ Rpc.BlockHeader bHash)+    then return ()+    else waitTillLastBlockProcessedT client env (decr - 1)+  where+    doubleSha256AndReverse =+      BS.toStrict+        . BS.reverse+        . SHA.bytestringDigest+        . SHA.sha256+        . SHA.bytestringDigest+        . SHA.sha256+        . BS.fromStrict
+ src/ElectrsClient/Import/External.hs view
@@ -0,0 +1,46 @@+module ElectrsClient.Import.External+  ( module X,+  )+where++import Control.Monad.Trans.Except as X+  ( catchE,+    except,+    throwE,+    withExceptT,+  )+import Data.Aeson as X+  ( FromJSON (..),+    FromJSONKey (..),+    Options (..),+    ToJSON,+    camelTo2,+    defaultOptions,+    fromJSON,+    genericParseJSON,+  )+import Data.Coerce as X (coerce)+import Data.Text as X (pack, unpack)+import Text.PrettyPrint.GenericPretty as X (Out (..))+import Text.PrettyPrint.GenericPretty.Instance as X ()+import Universum as X hiding+  ( atomically,+    bracket,+    finally,+    on,+    print,+    set,+    show,+    state,+    swap,+  )+import UnliftIO as X+  ( MonadUnliftIO (..),+    UnliftIO (..),+    askRunInIO,+    bracket,+    finally,+    race,+    withRunInIO,+    withUnliftIO,+  )
+ src/ElectrsClient/Rpc.hs view
@@ -0,0 +1,129 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++module ElectrsClient.Rpc+  ( getBalance,+    version,+    blockHeader,+    Balance (..),+    ScriptHash (..),+    BlockHeader (..),+  )+where++import Data.Aeson (decode, encode, withObject, (.:))+import qualified Data.ByteString.Lazy as BS+import qualified Data.Digest.Pure.SHA as SHA+import ElectrsClient.Client as Client+import ElectrsClient.Data.Env+import ElectrsClient.Import.External+import ElectrsClient.RpcRequest as Req+import ElectrsClient.RpcResponse as Resp+import ElectrsClient.Type+import qualified Network.Bitcoin.Wallet as BtcW+import qualified Text.Hex as TH++newtype ScriptHash = ScriptHash Text+  deriving stock (Generic)++newtype BlockHeader = BlockHeader Text+  deriving newtype (Eq)+  deriving stock (Generic)++instance Out BlockHeader++newtype MSat = MSat Word64+  deriving newtype+    ( Eq,+      Num,+      Ord,+      FromJSON,+      Show,+      Read+    )+  deriving stock+    ( Generic+    )++instance Out MSat++data Balance = Balance+  { confirmed :: MSat,+    unconfirmed :: MSat+  }+  deriving stock (Generic, Show)++getBalanceFromSat :: MSat -> MSat -> Balance+getBalanceFromSat c u = Balance (c * 1000) (u * 1000)++instance FromJSON Balance where+  parseJSON = withObject "Balance" $ \v ->+    getBalanceFromSat+      <$> v .: "confirmed"+      <*> v .: "unconfirmed"++instance ToJSON ScriptHash++instance FromJSON BlockHeader++instance Out Balance++callRpc :: (MonadUnliftIO m, ToJSON req, FromJSON resp) => Method -> req -> ElectrsEnv -> m (Either RpcError resp)+callRpc m r env = do+  let request =+        RpcRequest+          { Req.id = 0,+            Req.jsonrpc = "2.0",+            Req.method = m,+            Req.params = r+          }+  msgReply <- Client.send (lazyEncode request) env+  pure $ join $ second (second result . lazyDecode) msgReply+  where+    lazyDecode :: FromJSON resp => ByteString -> Either RpcError resp+    lazyDecode = maybeToRight RpcJsonDecodeError . decode . BS.fromStrict+    lazyEncode :: ToJSON req => RpcRequest req -> ByteString+    lazyEncode = BS.toStrict . encode++version :: MonadUnliftIO m => ElectrsEnv -> () -> m (Either RpcError [Text])+version env () = callRpc Version ["" :: Text, "1.4" :: Text] env++getBalance :: MonadUnliftIO m => ElectrsEnv -> BitcoindEnv -> Either (OnChainAddress a) ScriptHash -> m (Either RpcError Balance)+getBalance env _ (Right scriptHash) = callRpc GetBalance [scriptHash] env+getBalance env bEnv (Left address) = do+  scrHash <- getScriptHash bEnv address+  case scrHash of+    Right sh -> getBalance env bEnv (Right sh)+    Left _ -> pure $ Left (OtherError "Getting ScriptHash error")++blockHeader :: MonadUnliftIO m => ElectrsEnv -> BlkHeight -> m (Either RpcError BlockHeader)+blockHeader env bh = callRpc GetBlockHeader [bh] env++getScriptHash :: (MonadUnliftIO m) => BitcoindEnv -> OnChainAddress a -> m (Either RpcError ScriptHash)+getScriptHash bEnv addr = runExceptT $ do+  btcClient <-+    liftIO $+      BtcW.getClient+        (unpack $ bitcoindEnvHost bEnv)+        (encodeUtf8 $ bitcoindEnvUsername bEnv)+        (encodeUtf8 $ bitcoindEnvPassword bEnv)++  BtcW.AddrInfo _ sp _ _ <- liftIO $ BtcW.getAddrInfo btcClient (coerce addr)+  decodeSp sp+  where+    decodeSp :: (MonadUnliftIO m) => BtcW.ScrPubKey -> ExceptT RpcError m ScriptHash+    decodeSp =+      ExceptT+        . pure+        . second sha256AndReverse+        . maybeToRight RpcHexDecodeError+        . TH.decodeHex+        . coerce+    sha256AndReverse =+      ScriptHash+        . TH.encodeHex+        . BS.toStrict+        . BS.reverse+        . SHA.bytestringDigest+        . SHA.sha256+        . BS.fromStrict
+ src/ElectrsClient/RpcRequest.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE OverloadedStrings #-}++module ElectrsClient.RpcRequest+  ( RpcRequest (..),+    Method (..),+  )+where++import Data.Aeson (ToJSON (toJSON), Value (String))+import ElectrsClient.Import.External++data RpcRequest a = RpcRequest+  { id :: Integer,+    jsonrpc :: Text,+    method :: Method,+    params :: a+  }+  deriving stock (Generic, Show)++instance ToJSON a => ToJSON (RpcRequest a)++data Method+  = GetBalance+  | Version+  | GetBlockHeader+  deriving stock (Generic, Show)++instance ToJSON Method where+  toJSON GetBalance = String "blockchain.scripthash.get_balance"+  toJSON Version = String "server.version"+  toJSON GetBlockHeader = String "blockchain.block.header"
+ src/ElectrsClient/RpcResponse.hs view
@@ -0,0 +1,15 @@+module ElectrsClient.RpcResponse+  ( RpcResponse (..),+  )+where++import ElectrsClient.Import.External++data RpcResponse a = RpcResponse+  { id :: Integer,+    jsonrpc :: Text,+    result :: a+  }+  deriving stock (Generic, Show)++instance FromJSON a => FromJSON (RpcResponse a)
+ src/ElectrsClient/Type.hs view
@@ -0,0 +1,57 @@+module ElectrsClient.Type+  ( RpcError (..),+    OnChainAddress (..),+    BlkHeight (..),+  )+where++import ElectrsClient.Import.External++data RpcError+  = RpcNoAddress+  | RpcJsonDecodeError+  | RpcHexDecodeError+  | CannotSyncBlockchain+  | OtherError Text+  deriving stock+    ( Eq,+      Generic,+      Show+    )++newtype OnChainAddress (mrel :: MoneyRelation)+  = OnChainAddress Text+  deriving newtype+    ( Eq,+      Ord,+      Show,+      Read+    )+  deriving stock+    ( Generic+    )++data MoneyRelation+  = Fund+  | Refund+  | Gain+  | Loss+  deriving stock+    ( Eq,+      Ord,+      Show,+      Generic+    )++newtype BlkHeight+  = BlkHeight Word64+  deriving stock+    ( Eq,+      Ord,+      Show,+      Generic+    )+  deriving newtype+    ( Num,+      ToJSON+    )
+ test/Main.hs view
@@ -0,0 +1,17 @@+module Main+  ( main,+  )+where++import ElectrsClient.Import.External+import qualified Spec+import Test.Hspec.Formatters+import Test.Hspec.Runner++main :: IO ()+main = do+  hspecWith+    defaultConfig+      { configFormatter = Just progress+      }+    Spec.spec
+ test/RpcSpec.hs view
@@ -0,0 +1,39 @@+module RpcSpec+  ( spec,+  )+where++import ElectrsClient.Data.Env+import ElectrsClient.Helper+import ElectrsClient.Import.External+import ElectrsClient.Rpc as Rpc+import ElectrsClient.Type+import Network.Bitcoin+import Test.Hspec++spec :: Spec+spec = do+  it "Version" $ do+    rc <- liftIO readRawConfig+    let env = rawConfigElectrsEnv rc+    ver <- Rpc.version env ()+    ver `shouldSatisfy` isRight+  it "Get Balance" $ do+    elecBal <- do+      rc <- liftIO readRawConfig+      let env = rawConfigElectrsEnv rc+      let btcdEnv = rawConfigBtcEnv rc+      btcClient <-+        liftIO $+          getClient+            (unpack . bitcoindEnvHost $ btcdEnv)+            (encodeUtf8 . bitcoindEnvUsername $ btcdEnv)+            (encodeUtf8 . bitcoindEnvPassword $ btcdEnv)+      addr <- liftIO $ getNewAddress btcClient Nothing+      _ <- liftIO $ generateToAddress btcClient 3 addr Nothing+      _ <- runExceptT $ waitTillLastBlockProcessedT btcClient env 100+      Rpc.getBalance env btcdEnv (Left $ OnChainAddress addr)+    elecBal `shouldSatisfy` isRight+    case elecBal of+      Right bal -> confirmed bal `shouldSatisfy` (> 0)+      Left _ -> error "Error getting balance"
+ test/Spec.hs view
@@ -0,0 +1,2 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-}+{-# OPTIONS_GHC -Wno-missing-export-lists #-}