Skip to content

Commit 5746421

Browse files
functorafunctora
committed
modern network-bitcoin aeson
1 parent a67f8c3 commit 5746421

File tree

3 files changed

+252
-238
lines changed

3 files changed

+252
-238
lines changed

‎pub/network-bitcoin/network-bitcoin.cabal‎

Lines changed: 78 additions & 74 deletions
Original file line numberDiff line numberDiff line change
@@ -1,91 +1,95 @@
1-
Name: network-bitcoin
2-
Version: 1.9.1
3-
Synopsis: An interface to bitcoind.
4-
Description:
5-
This can be used to send Bitcoins, query balances, etc. It
6-
requires the Bitcoin daemon to be running and accessible via
7-
HTTP.
8-
.
9-
> import Network.Bitcoin
10-
>
11-
> main = do
12-
> client <- getClient "http://127.0.0.1:8332" "user" "password"
13-
> balance <- getBalance client
14-
> putStrLn $ show balance ++ " BTC"
15-
.
16-
To learn more about Bitcoin, see <http://www.bitcoin.org>.
17-
License: BSD3
18-
License-file: LICENSE
19-
Author: Michael Hendricks <[email protected]>
20-
Clark Gaebel <[email protected]>
21-
Maintainer: Matt Wraith <[email protected]>
22-
Homepage: http://github.com/bitnomial/network-bitcoin
23-
Bug-reports: http://github.com/bitnomial/network-bitcoin/issues
24-
Copyright: 2012 Michael Hendricks <[email protected]>
25-
2013 Clark Gaebel <[email protected]>
26-
Stability: experimental
27-
Category: Network
28-
Build-type: Simple
29-
Cabal-version: >=1.8
30-
tested-with: GHC ==8.4.3
1+
name: network-bitcoin
2+
version: 1.9.1
3+
synopsis: An interface to bitcoind.
4+
description:
5+
This can be used to send Bitcoins, query balances, etc. It
6+
requires the Bitcoin daemon to be running and accessible via
7+
HTTP.
8+
.
9+
> import Network.Bitcoin
10+
>
11+
> main = do
12+
> client <- getClient "http://127.0.0.1:8332" "user" "password"
13+
> balance <- getBalance client
14+
> putStrLn $ show balance ++ " BTC"
15+
.
16+
To learn more about Bitcoin, see <http://www.bitcoin.org>.
3117

32-
Library
33-
hs-source-dirs: src
34-
ghc-options: -Wall
18+
license: BSD3
19+
license-file: LICENSE
20+
author:
21+
Michael Hendricks <[email protected]>
22+
Clark Gaebel <[email protected]>
3523

36-
Exposed-modules:
24+
maintainer: Matt Wraith <[email protected]>
25+
homepage: http://github.com/bitnomial/network-bitcoin
26+
bug-reports: http://github.com/bitnomial/network-bitcoin/issues
27+
copyright:
28+
2012 Michael Hendricks <[email protected]>
29+
2013 Clark Gaebel <[email protected]>
30+
31+
stability: experimental
32+
category: Network
33+
build-type: Simple
34+
cabal-version: >=1.8
35+
tested-with: GHC ==8.4.3
36+
37+
library
38+
hs-source-dirs: src
39+
ghc-options: -Wall
40+
exposed-modules:
3741
Network.Bitcoin
3842
Network.Bitcoin.BlockChain
43+
Network.Bitcoin.BtcEnv
44+
Network.Bitcoin.BtcMultiEnv
3945
Network.Bitcoin.Dump
4046
Network.Bitcoin.Internal
4147
Network.Bitcoin.Mining
4248
Network.Bitcoin.Net
4349
Network.Bitcoin.RawTransaction
4450
Network.Bitcoin.Types
4551
Network.Bitcoin.Wallet
46-
Network.Bitcoin.BtcEnv
47-
Network.Bitcoin.BtcMultiEnv
4852

49-
Build-depends:
50-
aeson >= 0.8,
51-
bytestring >= 0.9 && < 0.11,
52-
cookie >= 0.4,
53-
attoparsec >= 0.12,
54-
unordered-containers >= 0.2,
55-
HTTP >= 4000,
56-
http-types >= 0.8.5,
57-
network >= 2.3,
58-
text >= 0.11,
59-
vector >= 0.10,
60-
base == 4.*,
61-
time >= 1.4.2,
62-
http-client >= 0.4.6,
63-
network-uri,
64-
transformers
53+
build-depends:
54+
aeson >=0.8
55+
, attoparsec >=0.12
56+
, base >=4 && <5
57+
, bytestring >=0.9
58+
, cookie >=0.4
59+
, HTTP >=4000
60+
, http-client >=0.4.6
61+
, http-types >=0.8.5
62+
, network >=2.3
63+
, network-uri
64+
, text >=0.11
65+
, time >=1.4.2
66+
, transformers
67+
, unordered-containers >=0.2
68+
, vector >=0.10
6569

66-
Source-repository head
67-
type: git
70+
source-repository head
71+
type: git
6872
location: git://github.com/bitnomial/network-bitcoin.git
6973

70-
Test-suite network-bitcoin-tests
74+
test-suite network-bitcoin-tests
7175
hs-source-dirs: src/Test
72-
main-is: Main.hs
73-
type: exitcode-stdio-1.0
76+
main-is: Main.hs
77+
type: exitcode-stdio-1.0
7478
build-depends:
75-
aeson >= 0.8,
76-
bytestring >= 0.9 && < 0.11,
77-
cookie >= 0.4,
78-
attoparsec >= 0.12,
79-
unordered-containers >= 0.2,
80-
HTTP >= 4000,
81-
http-types >= 0.8.5,
82-
network >= 2.3,
83-
text >= 0.11,
84-
vector >= 0.10,
85-
base == 4.*,
86-
time >= 1.4.2,
87-
QuickCheck >= 2.6,
88-
tasty >= 1.0,
89-
tasty-quickcheck >= 0.10,
90-
http-client >= 0.4.6,
91-
network-bitcoin
79+
aeson >=0.8
80+
, attoparsec >=0.12
81+
, base >=4 && <5
82+
, bytestring >=0.9
83+
, cookie >=0.4
84+
, HTTP >=4000
85+
, http-client >=0.4.6
86+
, http-types >=0.8.5
87+
, network >=2.3
88+
, network-bitcoin
89+
, QuickCheck >=2.6
90+
, tasty >=1.0
91+
, tasty-quickcheck >=0.10
92+
, text >=0.11
93+
, time >=1.4.2
94+
, unordered-containers >=0.2
95+
, vector >=0.10

‎pub/network-bitcoin/src/Network/Bitcoin/Internal.hs‎

Lines changed: 90 additions & 70 deletions
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,6 @@
11
{-# LANGUAGE OverloadedStrings #-}
22
{-# OPTIONS_GHC -Wall #-}
3+
34
-- | The API exposed in this module should be considered unstable, and is
45
-- subject to change between minor revisions.
56
--
@@ -11,33 +12,36 @@
1112
-- module is guaranteed to be stable.
1213
--
1314
-- If only d changes, then there were no user-facing code changes made.
14-
module Network.Bitcoin.Internal ( module Network.Bitcoin.Types
15-
, Text, Vector
16-
, FromJSON(..)
17-
, callApi
18-
, getClient
19-
, Nil(..)
20-
, NilOrArray(..)
21-
, tj
22-
, tjm
23-
, tja
24-
, AddrAddress(..)
25-
, BitcoinRpcResponse(..)
26-
) where
27-
28-
import Control.Exception
29-
import Control.Monad
30-
import Control.Applicative
31-
import Data.Aeson
32-
import qualified Data.ByteString as BS
33-
import Data.Maybe
34-
import Data.Text (Text)
35-
import Data.Vector (Vector)
36-
import qualified Data.Vector as V
37-
import Network.Bitcoin.Types
38-
import Network.HTTP.Client
39-
import Network.HTTP.Types.Header
40-
15+
module Network.Bitcoin.Internal
16+
( module Network.Bitcoin.Types,
17+
Text,
18+
Vector,
19+
FromJSON (..),
20+
callApi,
21+
getClient,
22+
Nil (..),
23+
NilOrArray (..),
24+
tj,
25+
tjm,
26+
tja,
27+
AddrAddress (..),
28+
BitcoinRpcResponse (..),
29+
)
30+
where
31+
32+
import Control.Applicative
33+
import Control.Exception
34+
import Control.Monad
35+
import Data.Aeson
36+
import qualified Data.Aeson.Key as AK
37+
import qualified Data.ByteString as BS
38+
import Data.Maybe
39+
import Data.Text (Text)
40+
import Data.Vector (Vector)
41+
import qualified Data.Vector as V
42+
import Network.Bitcoin.Types
43+
import Network.HTTP.Client
44+
import Network.HTTP.Types.Header
4145

4246
-- | RPC calls return an error object. It can either be empty; or have an
4347
-- error message + error code.
@@ -56,7 +60,7 @@ data BitcoinRpcResponse a
5660
| BitcoinRpcResult a
5761
deriving (Show, Read, Ord, Eq)
5862

59-
instance FromJSON a => FromJSON (BitcoinRpcResponse a) where
63+
instance (FromJSON a) => FromJSON (BitcoinRpcResponse a) where
6064
parseJSON (Object v) =
6165
(BitcoinRpcError <$> v .: "error")
6266
<|> (BitcoinRpcResult <$> v .: "result")
@@ -68,19 +72,26 @@ instance FromJSON a => FromJSON (BitcoinRpcResponse a) where
6872
-- Client encloses a Manager (from http-client) that re-uses
6973
-- connections for requests, so long as the same Client is
7074
-- is used for each call.
71-
getClient :: String
72-
-> BS.ByteString
73-
-> BS.ByteString
74-
-> IO Client
75+
getClient ::
76+
String ->
77+
BS.ByteString ->
78+
BS.ByteString ->
79+
IO Client
7580
getClient url user pass = do
76-
url' <- parseUrlThrow url
77-
mgr <- newManager defaultManagerSettings
78-
let baseReq = setRequestIgnoreStatus $ applyBasicAuth user pass url'
79-
{ method = "POST"
80-
, requestHeaders = [(hContentType, "application/json")] }
81-
return $ \r -> do
82-
resp <- httpLbs (baseReq { requestBody = RequestBodyLBS r }) mgr
83-
return $ responseBody resp
81+
url' <- parseUrlThrow url
82+
mgr <- newManager defaultManagerSettings
83+
let baseReq =
84+
setRequestIgnoreStatus $
85+
applyBasicAuth
86+
user
87+
pass
88+
url'
89+
{ method = "POST",
90+
requestHeaders = [(hContentType, "application/json")]
91+
}
92+
return $ \r -> do
93+
resp <- httpLbs (baseReq {requestBody = RequestBodyLBS r}) mgr
94+
return $ responseBody resp
8495

8596
-- | 'callApi' is a low-level interface for making authenticated API
8697
-- calls to a Bitcoin daemon. The first argument specifies
@@ -94,54 +105,60 @@ getClient url user pass = do
94105
-- callApi client "getblockhash" [tj 0]
95106
--
96107
-- On error, throws a 'BitcoinException'.
97-
callApi :: FromJSON v
98-
=> Client -- ^ RPC client for bitcoind
99-
-> Text -- ^ command name
100-
-> [Value] -- ^ command arguments
101-
-> IO v
108+
callApi ::
109+
(FromJSON v) =>
110+
-- | RPC client for bitcoind
111+
Client ->
112+
-- | command name
113+
Text ->
114+
-- | command arguments
115+
[Value] ->
116+
IO v
102117
callApi client cmd params = readVal =<< client jsonRpcReqBody
103-
where
104-
readVal bs = do
105-
case decode' bs of
106-
Just (BitcoinRpcResult r)
107-
-> return r
108-
Just (BitcoinRpcError (BitcoinRpcFailure code msg))
109-
-> throw $ BitcoinApiError code msg
110-
Nothing
111-
-> throw $ BitcoinResultTypeError bs
112-
jsonRpcReqBody =
113-
encode $ object [ "jsonrpc" .= ("2.0" :: Text)
114-
, "method" .= cmd
115-
, "params" .= params
116-
, "id" .= (1 :: Int)
117-
]
118+
where
119+
readVal bs = do
120+
case decode' bs of
121+
Just (BitcoinRpcResult r) ->
122+
return r
123+
Just (BitcoinRpcError (BitcoinRpcFailure code msg)) ->
124+
throw $ BitcoinApiError code msg
125+
Nothing ->
126+
throw $ BitcoinResultTypeError bs
127+
jsonRpcReqBody =
128+
encode $
129+
object
130+
[ "jsonrpc" .= ("2.0" :: Text),
131+
"method" .= cmd,
132+
"params" .= params,
133+
"id" .= (1 :: Int)
134+
]
118135
{-# INLINE callApi #-}
119136

120137
-- | Used to allow "null" to decode to a tuple.
121-
newtype Nil = Nil { unNil :: () }
138+
newtype Nil = Nil {unNil :: ()}
122139

123140
instance FromJSON Nil where
124-
parseJSON Null = return $ Nil ()
125-
parseJSON x = fail $ "\"null\" was expected, but " ++ show x ++ " was recieved."
141+
parseJSON Null = return $ Nil ()
142+
parseJSON x = fail $ "\"null\" was expected, but " ++ show x ++ " was recieved."
126143

127144
-- | Used to parse "null" or [HexString]
128145
newtype NilOrArray = NilOrArray {unArr :: Maybe [HexString]}
129146

130147
instance FromJSON NilOrArray where
131-
parseJSON Null = return $ NilOrArray Nothing
132-
parseJSON a@(Array _) = NilOrArray <$> parseJSON a
133-
parseJSON x = fail $ "Expected \"null\" or array, but " ++ show x ++ " was recieved."
148+
parseJSON Null = return $ NilOrArray Nothing
149+
parseJSON a@(Array _) = NilOrArray <$> parseJSON a
150+
parseJSON x = fail $ "Expected \"null\" or array, but " ++ show x ++ " was recieved."
134151

135152
-- | A handy shortcut for toJSON, because I'm lazy.
136-
tj :: ToJSON a => a -> Value
153+
tj :: (ToJSON a) => a -> Value
137154
tj = toJSON
138155
{-# INLINE tj #-}
139156

140-
tjm :: ToJSON a => a -> Maybe a -> Value
157+
tjm :: (ToJSON a) => a -> Maybe a -> Value
141158
tjm d m = tj $ fromMaybe d m
142159
{-# INLINE tjm #-}
143160

144-
tja :: ToJSON a => Maybe a -> [Value]
161+
tja :: (ToJSON a) => Maybe a -> [Value]
145162
tja = maybe [] (pure . tj)
146163
{-# INLINE tja #-}
147164

@@ -151,4 +168,7 @@ tja = maybe [] (pure . tj)
151168
newtype AddrAddress = AA (Vector (Address, BTC))
152169

153170
instance ToJSON AddrAddress where
154-
toJSON (AA vec) = object . V.toList $ uncurry (.=) <$> vec
171+
toJSON (AA vec) =
172+
object
173+
. V.toList
174+
$ fmap (\(k, v) -> AK.fromText k .= v) vec

0 commit comments

Comments
 (0)