diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for electrs-client + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/electrs-client.cabal b/electrs-client.cabal new file mode 100644 --- /dev/null +++ b/electrs-client.cabal @@ -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 +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 , Artem Markov +maintainer: 21it <21it@tuta.io>, Mikhail Prushinskiy , Artem Markov +copyright: 2022 Yolo +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 diff --git a/src/ElectrsClient/Client.hs b/src/ElectrsClient/Client.hs new file mode 100644 --- /dev/null +++ b/src/ElectrsClient/Client.hs @@ -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 diff --git a/src/ElectrsClient/Data/Env.hs b/src/ElectrsClient/Data/Env.hs new file mode 100644 --- /dev/null +++ b/src/ElectrsClient/Data/Env.hs @@ -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 "" diff --git a/src/ElectrsClient/Helper.hs b/src/ElectrsClient/Helper.hs new file mode 100644 --- /dev/null +++ b/src/ElectrsClient/Helper.hs @@ -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 diff --git a/src/ElectrsClient/Import/External.hs b/src/ElectrsClient/Import/External.hs new file mode 100644 --- /dev/null +++ b/src/ElectrsClient/Import/External.hs @@ -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, + ) diff --git a/src/ElectrsClient/Rpc.hs b/src/ElectrsClient/Rpc.hs new file mode 100644 --- /dev/null +++ b/src/ElectrsClient/Rpc.hs @@ -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 diff --git a/src/ElectrsClient/RpcRequest.hs b/src/ElectrsClient/RpcRequest.hs new file mode 100644 --- /dev/null +++ b/src/ElectrsClient/RpcRequest.hs @@ -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" diff --git a/src/ElectrsClient/RpcResponse.hs b/src/ElectrsClient/RpcResponse.hs new file mode 100644 --- /dev/null +++ b/src/ElectrsClient/RpcResponse.hs @@ -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) diff --git a/src/ElectrsClient/Type.hs b/src/ElectrsClient/Type.hs new file mode 100644 --- /dev/null +++ b/src/ElectrsClient/Type.hs @@ -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 + ) diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -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 diff --git a/test/RpcSpec.hs b/test/RpcSpec.hs new file mode 100644 --- /dev/null +++ b/test/RpcSpec.hs @@ -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" diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,2 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-} +{-# OPTIONS_GHC -Wno-missing-export-lists #-}