haskoin-wallet 0.4.0 → 0.4.1
raw patch · 11 files changed
+518/−51 lines, 11 filesdep ~HUnitdep ~QuickCheckdep ~aesonnew-component:exe:example-inproc-wallet-server
Dependency ranges changed: HUnit, QuickCheck, aeson, aeson-pretty, data-default, directory, esqueleto, monad-logger, persistent, persistent-sqlite, persistent-template, stm-conduit
Files
- Network/Haskoin/Wallet/Accounts.hs +14/−0
- Network/Haskoin/Wallet/Client.hs +3/−0
- Network/Haskoin/Wallet/Client/Commands.hs +99/−14
- Network/Haskoin/Wallet/Client/PrettyJson.hs +23/−0
- Network/Haskoin/Wallet/Server.hs +33/−17
- Network/Haskoin/Wallet/Server/Handler.hs +33/−1
- Network/Haskoin/Wallet/Types.hs +4/−0
- Network/Haskoin/Wallet/Types/BlockInfo.hs +77/−0
- config/help +3/−0
- examples/embedded-inproc-wallet-server/Main.hs +183/−0
- haskoin-wallet.cabal +46/−19
Network/Haskoin/Wallet/Accounts.hs view
@@ -19,6 +19,7 @@ , addresses , addressList , unusedAddresses+, lookupByPubKey , addressCount , setAddrLabel , addressPrvKey@@ -372,6 +373,19 @@ lim cnt | listReverse = min lim' (gap - listOffset) | otherwise = min lim' (cnt - off cnt - gap) order = if listReverse then desc else asc++lookupByPubKey :: (MonadIO m, MonadThrow m)+ => Entity Account -- ^ Account Entity+ -> PubKeyC -- ^ Pubkey of interest+ -> AddressType -- ^ Address type+ -> SqlPersistT m [WalletAddr]+lookupByPubKey (Entity ai _) key addrType =+ fmap (map entityVal) $ select $ from $ \x -> do+ where_ ( x ^. WalletAddrAccount ==. val ai+ &&. x ^. WalletAddrType ==. val addrType+ &&. x ^. WalletAddrKey ==. val (Just key)+ )+ return x -- | Add a label to an address. setAddrLabel :: (MonadIO m, MonadThrow m)
Network/Haskoin/Wallet/Client.hs view
@@ -190,10 +190,12 @@ "accounts" : page -> cmdAccounts page "rename" : name : new : [] -> cmdRenameAcc name new "list" : name : page -> cmdList name page+ "pubkeys" : name : page -> cmdPubKeys name page "unused" : name : page -> cmdUnused name page "label" : name : index : label : [] -> cmdLabel name index label "txs" : name : page -> cmdTxs name page "addrtxs" : name : index : page -> cmdAddrTxs name index page+ "getindex" : name : key : [] -> cmdKeyIndex name key "genaddrs" : name : i : [] -> cmdGenAddrs name i "send" : name : add : amnt : [] -> cmdSend name add amnt "sendmany" : name : xs -> cmdSendMany name xs@@ -212,6 +214,7 @@ "decodetx" : [] -> cmdDecodeTx "status" : [] -> cmdStatus "keypair" : [] -> cmdKeyPair+ "blockinfo" : hashes -> cmdBlockInfo hashes "version" : [] -> cmdVersion "help" : [] -> liftIO $ forM_ usage (hPutStrLn stderr) [] -> liftIO $ forM_ usage (hPutStrLn stderr)
Network/Haskoin/Wallet/Client/Commands.hs view
@@ -8,10 +8,12 @@ , cmdRenameAcc , cmdAccounts , cmdList+, cmdPubKeys , cmdUnused , cmdLabel , cmdTxs , cmdAddrTxs+, cmdKeyIndex , cmdGenAddrs , cmdSend , cmdSendMany@@ -25,6 +27,7 @@ , cmdDecodeTx , cmdVersion , cmdStatus+, cmdBlockInfo , cmdMonitor , cmdSync , cmdKeyPair@@ -44,11 +47,9 @@ decode, eitherDecode, object, toJSON, (.=)) import qualified Data.Aeson as Aeson (encode)-import qualified Data.Aeson.Encode.Pretty as JSON (Config (..),- defConfig,- encodePretty') import qualified Data.ByteString.Char8 as B8 (hPutStrLn, putStrLn, unwords)+import Data.String (fromString) import Data.List (intercalate, intersperse) import Data.Maybe (fromMaybe, isJust, isNothing, listToMaybe, maybeToList)@@ -59,6 +60,7 @@ import Data.Text (Text, pack, splitOn, unpack) import Data.Word (Word32, Word64) import qualified Data.Yaml as YAML (encode)+import qualified Data.Time.Format as Time import Network.Haskoin.Block import Network.Haskoin.Constants import Network.Haskoin.Crypto@@ -69,6 +71,7 @@ import Network.Haskoin.Wallet.Server import Network.Haskoin.Wallet.Settings import Network.Haskoin.Wallet.Types+import qualified Network.Haskoin.Wallet.Client.PrettyJson as JSON import qualified System.Console.Haskeline as Haskeline import System.IO (stderr) import System.ZMQ4 (KeyFormat (..), Req (..),@@ -276,15 +279,24 @@ pages m c | m `mod` c == 0 = m `div` c | otherwise = m `div` c + 1 -cmdList :: String -> [String] -> Handler ()-cmdList name ls = do+listJsonAddrs :: (JsonAddr -> String)+ -> String+ -> [String]+ -> Handler ()+listJsonAddrs showFunc name ls = do t <- R.asks configAddrType m <- R.asks configMinConf o <- R.asks configOffline let page = fromMaybe 1 $ listToMaybe ls >>= readMaybe f = GetAddressesR (pack name) t m o- listAction page f $ \as -> forM_ as (liftIO . putStrLn . printAddress)+ listAction page f $ \as -> forM_ as (liftIO . putStrLn . showFunc) +cmdList :: String -> [String] -> Handler ()+cmdList = listJsonAddrs printAddress++cmdPubKeys :: String -> [String] -> Handler ()+cmdPubKeys = listJsonAddrs printPubKey+ cmdUnused :: String -> [String] -> Handler () cmdUnused name ls = do t <- R.asks configAddrType@@ -345,6 +357,21 @@ where index = fromMaybe (error "Could not read index") $ readMaybe i +cmdKeyIndex :: String -> String -> Handler ()+cmdKeyIndex name k = do+ t <- R.asks configAddrType+ resE <- sendZmq $ GetIndexR (pack name) (fromString k) t+ handleResponse resE $ \res -> case res of+ [] -> liftIO $ putStrLn "No matching pubkeys found"+ lst -> liftIO $ putStrLn $ unlines $ -- Two or more pubkeys with the same index is extremely improbable. But let's print it out if it happens.+ map (\adr -> showLine (jsonAddrIndex adr, jsonAddrKey adr)) lst+ where+ showLine :: (KeyIndex, Maybe PubKeyC) -> String+ showLine (idx,k') = unwords [ show (idx :: KeyIndex), ":", showPubKey k' ]+ showPubKey = maybe "<no pubkey available>" (jsonStr2Str . toJSON)+ jsonStr2Str (String t) = cs t+ jsonStr2Str _ = ""+ cmdGenAddrs :: String -> String -> Handler () cmdGenAddrs name i = do t <- R.asks configAddrType@@ -508,7 +535,7 @@ _ -> YAML.encode $ val tx where val = encodeTxJSON- jsn = JSON.encodePretty' JSON.defConfig{ JSON.confIndent = 2 } . val+ jsn = JSON.encodePretty . val cmdVersion :: Handler () cmdVersion = liftIO $ do@@ -528,13 +555,31 @@ B8.putStrLn $ B8.unwords [ "public :", rvalue pub ] B8.putStrLn $ B8.unwords [ "private:", rvalue sec ] +cmdBlockInfo :: [String] -> Handler ()+cmdBlockInfo headers = do+ -- Show best block if no arguments are provided+ hashL <- if null headers then+ -- Fetch best block hash from status msg, and return as list+ (: []) . parseRes <$> sendZmq (PostNodeR NodeActionStatus)+ else+ return (map fromString headers)+ sendZmq (GetBlockInfoR hashL) >>=+ \resE -> handleResponse resE (liftIO . printResults)+ where+ printResults :: [BlockInfo] -> IO ()+ printResults = mapM_ $ putStrLn . unlines . printBlockInfo+ parseRes :: Either String (WalletResponse NodeStatus) -> BlockHash+ parseRes = nodeStatusBestHeader . fromMaybe+ (error "No response to NodeActionStatus msg") . parseResponse++ {- Helpers -} handleNotif :: OutputFormat -> Either String Notif -> IO () handleNotif _ (Left e) = error e handleNotif fmt (Right notif) = case fmt of OutputJSON -> formatStr $ cs $- JSON.encodePretty' JSON.defConfig{ JSON.confIndent = 2 } notif+ JSON.encodePretty notif OutputYAML -> do putStrLn "---" formatStr $ cs $ YAML.encode notif@@ -542,20 +587,26 @@ OutputNormal -> putStrLn $ printNotif notif +parseResponse+ :: Either String (WalletResponse a)+ -> Maybe a+parseResponse resE = case resE of+ Right (ResponseValid resM) -> resM+ Right (ResponseError err) -> error $ unpack err+ Left err -> error err+ handleResponse :: (FromJSON a, ToJSON a) => Either String (WalletResponse a) -> (a -> Handler ()) -> Handler ()-handleResponse resE handle = case resE of- Right (ResponseValid (Just a)) -> formatOutput a =<< R.asks configFormat- Right (ResponseValid Nothing) -> return ()- Right (ResponseError err) -> error $ unpack err- Left err -> error err+handleResponse resE handle = case parseResponse resE of+ Just a -> formatOutput a =<< R.asks configFormat+ Nothing -> return () where formatOutput a format = case format of OutputJSON -> liftIO . formatStr $ cs $- JSON.encodePretty' JSON.defConfig{ JSON.confIndent = 2 } a+ JSON.encodePretty a OutputYAML -> liftIO . formatStr $ cs $ YAML.encode a OutputNormal -> handle a @@ -693,6 +744,11 @@ , "address-base58" .= (cs (addrToBase58 a) :: Text) ] ]+ DataCarrier bs -> object+ [ "op_return" .= object+ [ "data" .= (cs $ encodeHex bs :: Text)+ ]+ ] encodeSigJSON :: TxSignature -> Value encodeSigJSON ts@(TxSignature _ sh) = object@@ -766,6 +822,16 @@ where bal = fromMaybe (error "Could not get address balance") jsonAddrBalance +printPubKey :: JsonAddr -> String+printPubKey JsonAddr{..} = unwords $+ [ show jsonAddrIndex, ":", showPubKey jsonAddrKey ]+ +++ [ "(" ++ unpack jsonAddrLabel ++ ")" | not (null $ unpack jsonAddrLabel) ]+ where+ showPubKey = maybe "<no pubkey available>" (jsonStr2Str . toJSON)+ jsonStr2Str (String t) = cs t+ jsonStr2Str _ = "" -- It totally is a String though+ printNotif :: Notif -> String printNotif (NotifTx tx) = printTx Nothing tx printNotif (NotifBlock b) = printBlock b@@ -883,3 +949,22 @@ ] ++ [ " Logs : " | verbose ] ++ [ " - " ++ msg | msg <- fromMaybe [] peerStatusLog, verbose]++printBlockInfo :: BlockInfo -> [String]+printBlockInfo BlockInfo{..} =+ [ "Block Height : " ++ show blockInfoHeight+ , "Block Hash : " ++ cs (blockHashToHex blockInfoHash)+ , "Block Timestamp : " ++ formatUTCTime blockInfoTimestamp+ , "Previous Block : " ++ cs (blockHashToHex blockInfoPrevBlock)+ , "Merkle Root : " ++ cs blockInfoMerkleRoot+ , "Block Version : " ++ "0x" ++ cs (encodeHex versionData)+ , "Block Difficulty : " ++ show (blockDiff blockInfoBits)+ , "Chain Work : " ++ show blockInfoChainWork+ ]+ where+ blockDiff :: Word32 -> Double+ blockDiff target = getTarget (blockBits genesisHeader) / getTarget target+ getTarget = fromIntegral . decodeCompact+ versionData = integerToBS (fromIntegral blockInfoVersion)+ formatUTCTime = Time.formatTime Time.defaultTimeLocale+ "%Y-%m-%d %H:%M:%S (UTC)"
+ Network/Haskoin/Wallet/Client/PrettyJson.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE CPP #-}+module Network.Haskoin.Wallet.Client.PrettyJson+( encodePretty )+where++import qualified Data.ByteString.Lazy as BL+import Data.Aeson (ToJSON)+import Data.Aeson.Encode.Pretty as Export (Config (..),+ defConfig,+ encodePretty')++-- aeson-pretty 0.8.0 introduces a new way to specify indentation+#if MIN_VERSION_aeson_pretty(0,8,0)+import Data.Aeson.Encode.Pretty as Export (Indent(..))+jsonIndent :: Indent+jsonIndent = Spaces 2+#else+jsonIndent :: Int+jsonIndent = 2+#endif++encodePretty :: ToJSON a => a -> BL.ByteString+encodePretty = encodePretty' defConfig{ confIndent = jsonIndent }
Network/Haskoin/Wallet/Server.hs view
@@ -3,6 +3,7 @@ module Network.Haskoin.Wallet.Server ( runSPVServer , stopSPVServer+, runSPVServerWithContext ) where import Control.Concurrent.Async.Lifted (async, link,@@ -91,7 +92,26 @@ rnf (M.elems eventNewAddrs) runSPVServer :: Config -> IO ()-runSPVServer cfg = maybeDetach cfg $ run $ do -- start the server process+runSPVServer cfg = maybeDetach cfg $ -- start the server process+ withContext (run . runSPVServerWithContext cfg)+ where+ -- Setup logging monads+ run = runResourceT . runLogging+ runLogging = runStdoutLoggingT . filterLogger logFilter+ logFilter _ level = level >= configLogLevel cfg++-- |Run the server, and use the specifed ZeroMQ context.+-- Useful if you want to communicate with the server using+-- the "inproc" ZeroMQ transport, where a shared context is+-- required.+runSPVServerWithContext :: ( MonadLoggerIO m+ , MonadBaseControl IO m+ , MonadBase IO m+ , MonadThrow m+ , MonadResource m+ )+ => Config -> Context -> m ()+runSPVServerWithContext cfg ctx = do -- Initialize the database -- Check the operation mode of the server. pool <- initDatabase cfg@@ -101,7 +121,7 @@ -- In this mode, we do not launch an SPV node. We only accept -- client requests through the ZMQ API. SPVOffline ->- runWalletApp $ HandlerSession cfg pool Nothing notif+ runWalletApp ctx $ HandlerSession cfg pool Nothing notif -- In this mode, we launch the client ZMQ API and we sync the -- wallet database with an SPV node. SPVOnline -> do@@ -121,20 +141,16 @@ -- Re-broadcast pending transactions , runNodeT (broadcastPendingTxs pool) node -- Run the ZMQ API server- , runWalletApp session+ , runWalletApp ctx session ] mapM_ link as- _ <- waitAnyCancel as- return ()+ (_,r) <- waitAnyCancel as+ return r where spv pool = do -- Get our bloom filter (bloom, elems, _) <- runDBPool getBloomFilter pool startSPVNode hosts bloom elems- -- Setup logging monads- run = runResourceT . runLogging- runLogging = runStdoutLoggingT . filterLogger logFilter- logFilter _ level = level >= configLogLevel cfg -- Bitcoin nodes to connect to nodes = fromMaybe (error $ "BTC nodes for " ++ networkName ++ " not found")@@ -335,10 +351,9 @@ , MonadThrow m , MonadResource m )- => HandlerSession -> m ()-runWalletApp session = do- na <- async $ liftBaseOpDiscard withContext $ \ctx ->- liftBaseOpDiscard (withSocket ctx Pub) $ \sock -> do+ => Context -> HandlerSession -> m ()+runWalletApp ctx session = do+ na <- async $ liftBaseOpDiscard (withSocket ctx Pub) $ \sock -> do liftIO $ setLinger (restrict (0 :: Int)) sock setupCrypto ctx sock liftIO $ bind sock $ configBindNotif $ handlerConfig session@@ -352,8 +367,7 @@ ("{" <> cs jsonTxAccount <> "}", cs $ encode x) in liftIO $ sendMulti sock $ typ :| [pay] link na- liftBaseOpDiscard withContext $ \ctx ->- liftBaseOpDiscard (withSocket ctx Rep) $ \sock -> do+ liftBaseOpDiscard (withSocket ctx Rep) $ \sock -> do liftIO $ setLinger (restrict (0 :: Int)) sock setupCrypto ctx sock liftIO $ bind sock $ configBind $ handlerConfig session@@ -367,14 +381,14 @@ where setupCrypto :: (MonadLoggerIO m, MonadBaseControl IO m) => Context -> Socket a -> m ()- setupCrypto ctx sock = do+ setupCrypto ctx' sock = do when (isJust serverKeyM) $ liftIO $ do let k = fromJust $ configServerKey $ handlerConfig session setCurveServer True sock setCurveSecretKey TextFormat k sock when (isJust clientKeyPubM) $ do k <- z85Decode (fromJust clientKeyPubM)- void $ async $ runZapAuth ctx k+ void $ async $ runZapAuth ctx' k cfg = handlerConfig session serverKeyM = configServerKey cfg clientKeyPubM = configClientKeyPub cfg@@ -442,6 +456,7 @@ GetAddressesR n t m o p -> getAddressesR n t m o p GetAddressesUnusedR n t p -> getAddressesUnusedR n t p GetAddressR n i t m o -> getAddressR n i t m o+ GetIndexR n k t -> getIndexR n k t PutAddressR n i t l -> putAddressR n i t l PostAddressesR n i t -> postAddressesR n i t GetTxsR n p -> getTxsR n p@@ -457,3 +472,4 @@ GetSyncHeightR a n b -> getSyncR a (Left n) b GetPendingR a p -> getPendingR a p GetDeadR a p -> getDeadR a p+ GetBlockInfoR l -> getBlockInfoR l
Network/Haskoin/Wallet/Server/Handler.hs view
@@ -8,7 +8,7 @@ import Control.Concurrent.STM.TBMChan (TBMChan) import Control.Exception (SomeException (..), tryJust)-import Control.Monad (liftM, unless, when)+import Control.Monad (liftM, forM, unless, when) import Control.Monad.Base (MonadBase) import Control.Monad.Catch (MonadThrow, throwM) import Control.Monad.Logger (MonadLoggerIO, logError,@@ -23,6 +23,7 @@ import Data.String.Conversions (cs) import Data.Text (Text, pack, unpack) import Data.Word (Word32)+import Data.Maybe (catMaybes) import Database.Esqueleto (Entity (..), SqlPersistT) import Database.Persist.Sql (ConnectionPool, SqlPersistM,@@ -41,6 +42,7 @@ import Network.Haskoin.Wallet.Settings import Network.Haskoin.Wallet.Transaction import Network.Haskoin.Wallet.Types+import Network.Haskoin.Wallet.Types.BlockInfo (fromNodeBlock) type Handler m = ReaderT HandlerSession m @@ -252,6 +254,26 @@ _ -> (entityVal addrE, Nothing) return $ Just $ toJSON $ toJsonAddr addr balM +getIndexR :: (MonadLoggerIO m, MonadBaseControl IO m, MonadThrow m)+ => AccountName+ -> PubKeyC+ -> AddressType+ -> Handler m (Maybe Value)+getIndexR name key addrType = do+ $(logInfo) $ format $ unlines+ [ "getIndexR"+ , " Account name: " ++ unpack name+ , " Key : " ++ show key+ , " Address type: " ++ show addrType+ ]+ addrLst <- runDB $ do+ accE <- getAccount name+ lookupByPubKey accE key addrType+ let hello = map (`toJsonAddr` Nothing) addrLst+ liftIO $ putStrLn $ show hello+ liftIO $ print $ toJSON $ hello+ return $ Just $ toJSON $ hello+ putAddressR :: (MonadLoggerIO m, MonadBaseControl IO m, MonadThrow m) => AccountName -> KeyIndex@@ -548,6 +570,16 @@ showBlock = case blockE of Left e -> show e Right b -> cs $ blockHashToHex b++getBlockInfoR :: (MonadThrow m, MonadLoggerIO m, MonadBaseControl IO m)+ => [BlockHash]+ -> Handler m (Maybe Value)+getBlockInfoR headerLst = do+ lstMaybeBlk <- forM headerLst (runNode . runSqlNodeT . getBlockByHash)+ return $ toJSON <$> Just (handleRes lstMaybeBlk)+ where+ handleRes :: [Maybe NodeBlock] -> [BlockInfo]+ handleRes = map fromNodeBlock . catMaybes {- Helpers -}
Network/Haskoin/Wallet/Types.hs view
@@ -35,6 +35,7 @@ , JsonSyncBlock(..) , JsonBlock(..) , Notif(..)+, BlockInfo(..) -- Helper Types , WalletException(..)@@ -98,6 +99,7 @@ import Network.Haskoin.Transaction import Network.Haskoin.Util import Network.Haskoin.Wallet.Database+import Network.Haskoin.Wallet.Types.BlockInfo type AccountName = Text @@ -334,6 +336,7 @@ | GetAddressesR !AccountName !AddressType !Word32 !Bool !ListRequest | GetAddressesUnusedR !AccountName !AddressType !ListRequest | GetAddressR !AccountName !KeyIndex !AddressType !Word32 !Bool+ | GetIndexR !AccountName !PubKeyC !AddressType | PutAddressR !AccountName !KeyIndex !AddressType !AddressLabel | PostAddressesR !AccountName !KeyIndex !AddressType | GetTxsR !AccountName !ListRequest@@ -349,6 +352,7 @@ | GetSyncHeightR !AccountName !BlockHeight !ListRequest | GetPendingR !AccountName !ListRequest | GetDeadR !AccountName !ListRequest+ | GetBlockInfoR ![BlockHash] -- TODO: Set omitEmptyContents on aeson-0.9 $(deriveJSON
+ Network/Haskoin/Wallet/Types/BlockInfo.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE TemplateHaskell #-}+module Network.Haskoin.Wallet.Types.BlockInfo+(+ BlockInfo(..)+, JsonHash256+, fromNodeBlock+)+where++import Data.String.Conversions (cs, ConvertibleStrings(..))+import Data.Maybe (fromMaybe)+import Data.Aeson.TH (deriveJSON)+import Data.Word (Word32)+import Data.Time (UTCTime)+import Data.ByteString (ByteString)+import Data.Time.Clock.POSIX (posixSecondsToUTCTime)+import Data.Aeson (FromJSON, ToJSON, Value (String),+ parseJSON, toJSON, withText)++import Network.Haskoin.Block+import Network.Haskoin.Node.HeaderTree+import Network.Haskoin.Crypto+import Network.Haskoin.Util+++newtype JsonHash256 = JsonHash256 { jsonGetHash256 :: Hash256 }+ deriving (Eq, Show)++jsonHashToHex :: JsonHash256 -> ByteString+jsonHashToHex = blockHashToHex . BlockHash . jsonGetHash256++instance ToJSON JsonHash256 where+ toJSON = String . cs . jsonHashToHex++instance FromJSON JsonHash256 where+ parseJSON = withText "JsonHash256" $+ return . JsonHash256 . getBlockHash <$>+ fromMaybe (error "Invalid 256 bit hash") .+ hexToBlockHash . cs++instance ConvertibleStrings JsonHash256 String where+ convertString = cs . jsonHashToHex++data BlockInfo = BlockInfo+ { blockInfoHash :: !BlockHash+ , blockInfoHeight :: !BlockHeight+ , blockInfoVersion :: !Word32+ , blockInfoTimestamp :: !UTCTime+ , blockInfoPrevBlock :: !BlockHash+ , blockInfoMerkleRoot :: !JsonHash256+ , blockInfoBits :: !Word32+ , blockInfoNonce :: !Word32+ , blockInfoChain :: !Word32+ , blockInfoChainWork :: !Double+ } deriving (Eq, Show)++$(deriveJSON (dropFieldLabel 9) ''BlockInfo)++fromNodeBlock :: NodeBlock -> BlockInfo+fromNodeBlock nb =+ BlockInfo+ { blockInfoHash = headerHash header+ , blockInfoVersion = blockVersion header+ , blockInfoPrevBlock = prevBlock header+ , blockInfoNonce = bhNonce header+ , blockInfoBits = blockBits header+ , blockInfoMerkleRoot = JsonHash256 $ merkleRoot header+ , blockInfoTimestamp = utcTimestamp+ , blockInfoChainWork = nodeWork nb+ , blockInfoHeight = nodeHeight nb+ , blockInfoChain = nodeChain nb+ }+ where+ header = nodeHeader nb+ utcTimestamp = posixSecondsToUTCTime . realToFrac .+ blockTimestamp $ header+
config/help view
@@ -16,9 +16,11 @@ Address commands: list acc [page] [-c pagesize] [-r] Display addresses by page+ pubkeys acc [page] [-c pagesize] [-r] Display address public keys unused acc [page] [-c pagesize] [-r] Display unused addresses label acc index label Set the label of an address addrtxs acc index [page] [-c pagesize] Display txs related to an address+ getindex acc key Get key index by pubkey genaddrs acc index [--internal] Generate addresses up to this index Transaction commands:@@ -43,6 +45,7 @@ rescan [timestamp] Rescan the wallet keypair Get curve key pair for ØMQ auth monitor [account] Monitor events (no account: blocks)+ blockinfo [hash1] [hash2] [...] Get block header information by hash Other commands: version Display version information
+ examples/embedded-inproc-wallet-server/Main.hs view
@@ -0,0 +1,183 @@+module Main where++import Network.Haskoin.Wallet (Config(..),+ WalletRequest(..), WalletResponse(..),+ AddressType(..), OutputFormat(..),+ SPVMode(..), NodeAction(..))++import Network.Haskoin.Wallet.Server (runSPVServerWithContext)+import Network.Haskoin.Wallet.Internals (BTCNode(..), Notif(..))+import qualified Network.Haskoin.Node.STM as Node++import Data.String.Conversions (cs)+import qualified System.ZMQ4 as ZMQ+import qualified Control.Monad.Logger as Log+import qualified Data.HashMap.Strict as HM+import qualified Database.Persist.Sqlite as DB+import qualified Control.Monad.Trans.Resource as Resource+import qualified Data.Aeson as JSON+import qualified Control.Concurrent as Con+import qualified Data.Aeson.Encode.Pretty as PrettyJSON+import qualified Control.Monad as M+import qualified Control.Exception as Except+++databaseConf :: DB.SqliteConf+databaseConf = DB.SqliteConf "/tmp/tmpdb" 1++cmdSocket :: String+cmdSocket = "inproc://cmd"++notifSocket :: String+notifSocket = "inproc://notif"+++-- |Simple example app that embeds a haskoin-wallet server.+-- Start wallet server + notification thread, and execute Status command when pressing ENTER+main :: IO ()+main = ZMQ.withContext $ \ctx -> do+ -- Server+ putStrLn "Starting server..."+ _ <- Con.forkIO $ runWallet walletServerConf ctx+ -- Notify thread+ putStrLn "Starting notification thread..."+ _ <- Con.forkIO $ notifyThread ctx notifyHandler+ -- Status loop+ M.forever $ do+ putStrLn "Press ENTER to get server status..."+ _ <- getLine+ cmdGetStatus ctx >>= printStatusJSON+ where+ printStatusJSON = putStrLn . cs . PrettyJSON.encodePretty+ notifyHandler notif =+ putStrLn $ "NOTIFY: New block: " ++ cs (PrettyJSON.encodePretty notif)++-- |Run haskoin-wallet using the specified ZeroMQ Context,+-- and log to stderr.+runWallet :: Config -> ZMQ.Context -> IO ()+runWallet cfg ctx = run $ runSPVServerWithContext cfg ctx+ where run = Resource.runResourceT . runLogging+ runLogging = Log.runStderrLoggingT . Log.filterLogger logFilter+ logFilter _ l = l >= configLogLevel cfg++cmdGetStatus :: ZMQ.Context -> IO Node.NodeStatus+cmdGetStatus ctx =+ sendCmdOrFail (PostNodeR NodeActionStatus) ctx >>=+ \res -> case res of+ Nothing -> error "ERROR: Status command: no response."+ Just status -> return status++sendCmdOrFail :: (JSON.FromJSON a, JSON.ToJSON a)+ => WalletRequest+ -> ZMQ.Context+ -> IO (Maybe a)+sendCmdOrFail cmd ctx =+ sendCmd cmd ctx >>=+ either error return >>=+ \res -> case res of+ ResponseError e -> error $ "ERROR: Send cmd, ResponseError: " ++ cs e+ ResponseValid r -> return r++sendCmd :: (JSON.FromJSON a, JSON.ToJSON a)+ => WalletRequest+ -> ZMQ.Context+ -> IO (Either String (WalletResponse a))+sendCmd req ctx =+ ZMQ.withSocket ctx ZMQ.Req $ \sock -> do+ ZMQ.setLinger (ZMQ.restrict (0 :: Int)) sock+ ZMQ.connect sock cmdSocket+ ZMQ.send sock [] (cs $ JSON.encode req)+ JSON.eitherDecode . cs <$> ZMQ.receive sock++-- |Connect to notify socket, subscribe to new blocks,+-- and execute the supplied handler for each new block as it arrives.+notifyThread :: ZMQ.Context -> (Notif -> IO ()) -> IO ()+notifyThread ctx handler = waitAndCatch $+ ZMQ.withSocket ctx ZMQ.Sub $ \sock -> do+ ZMQ.setLinger (ZMQ.restrict (0 :: Int)) sock+ ZMQ.connect sock notifSocket+ ZMQ.subscribe sock "[block]"+ putStrLn "NOTIFY: Connected. Subscribed to new blocks."+ M.forever $ do+ [_,m] <- ZMQ.receiveMulti sock+ notif <- either failOnErr return $ JSON.eitherDecode (cs m)+ handler notif+ where+ failOnErr = fail . ("NOTIFY: ERROR: recv failed: " ++)+ waitAndCatch ioa = Con.threadDelay 10000 >> ioa `Except.finally` waitAndCatch ioa++btcNodes :: [BTCNode]+btcNodes =+ [ BTCNode "dnsseed.bluematt.me" 8333+ , BTCNode "dnsseed.bitcoin.dashjr.org" 8333+ , BTCNode "dnsseed.bluematt.me" 8333+ , BTCNode "seed.bitcoinstats.com" 8333+ , BTCNode "seed.bitcoin.jonasschnelli.ch" 8333+ , BTCNode "seed.bitcoin.sipa.be" 8333+ , BTCNode "seed.bitnodes.io" 8333+ , BTCNode "seed.btcc.com" 8333+ ]++walletServerConf :: Config+walletServerConf = Config+ { configCount = 100+ -- ^ Output size of commands+ , configMinConf = 6+ -- ^ Minimum number of confirmations+ , configSignTx = True+ -- ^ Sign transactions+ , configFee = 50000+ -- ^ Fee to pay per 1000 bytes when creating new transactions+ , configRcptFee = False+ -- ^ Recipient pays fee (dangerous, no config file setting)+ , configAddrType = AddressExternal+ -- ^ Return internal instead of external addresses+ , configOffline = False+ -- ^ Display the balance including offline transactions+ , configReversePaging = False+ -- ^ Use reverse paging for displaying addresses and transactions+ , configPath = Nothing+ -- ^ Derivation path when creating account+ , configFormat = OutputNormal+ -- ^ How to format the command-line results+ , configConnect = cmdSocket+ -- ^ ZeroMQ socket to connect to (location of the server)+ , configConnectNotif = notifSocket+ -- ^ ZeroMQ socket to connect for notifications+ , configDetach = False+ -- ^ Detach server when launched from command-line+ , configFile = ""+ -- ^ Configuration file+ , configTestnet = False+ -- ^ Use Testnet3 network+ , configDir = ""+ -- ^ Working directory+ , configBind = cmdSocket+ -- ^ Bind address for the ZeroMQ socket+ , configBindNotif = notifSocket+ -- ^ Bind address for ZeroMQ notifications+ , configBTCNodes = HM.fromList [ ( "prodnet", btcNodes ) ]+ -- ^ Trusted Bitcoin full nodes to connect to+ , configMode = SPVOnline+ -- ^ Operation mode of the SPV node.+ , configBloomFP = 0.00001+ -- ^ False positive rate for the bloom filter.+ , configDatabase = HM.fromList [ ( "prodnet", databaseConf ) ]+ -- ^ Database configuration+ , configLogFile = ""+ -- ^ Log file+ , configPidFile = ""+ -- ^ PID File+ , configLogLevel = Log.LevelInfo+ -- ^ Log level+ , configVerbose = True+ -- ^ Verbose+ , configServerKey = Nothing+ -- ^ Server key for authentication and encryption (server config)+ , configServerKeyPub = Nothing+ -- ^ Server public key for authentication and encryption (client config)+ , configClientKey = Nothing+ -- ^ Client key for authentication and encryption (client config)+ , configClientKeyPub = Nothing+ -- ^ Client public key for authentication and encryption+ }
haskoin-wallet.cabal view
@@ -1,5 +1,5 @@ name: haskoin-wallet-version: 0.4.0+version: 0.4.1 synopsis: Implementation of a Bitcoin SPV Wallet with BIP32 and multisig support. description:@@ -10,11 +10,11 @@ command-line tool called "hw" which is also provided in this package. homepage: http://github.com/haskoin/haskoin bug-reports: http://github.com/haskoin/haskoin/issues-tested-with: GHC==7.10.3, GHC==7.10.2, GHC==7.10.1+tested-with: GHC==8.0.2 license: PublicDomain license-file: UNLICENSE-author: Philippe Laprade-maintainer: plaprade+hackage@gmail.com+author: Philippe Laprade, Jean-Pierre Rupp+maintainer: xenog@protonmail.com category: Bitcoin, Finance, Network build-type: Simple cabal-version: >= 1.9.2@@ -37,11 +37,13 @@ Network.Haskoin.Wallet.Internals other-modules: Network.Haskoin.Wallet.Types+ Network.Haskoin.Wallet.Types.BlockInfo Network.Haskoin.Wallet.Accounts Network.Haskoin.Wallet.Transaction Network.Haskoin.Wallet.Block Network.Haskoin.Wallet.Server.Handler Network.Haskoin.Wallet.Client.Commands+ Network.Haskoin.Wallet.Client.PrettyJson Network.Haskoin.Wallet.Database extensions: TemplateHaskell@@ -57,19 +59,19 @@ RecordWildCards GeneralizedNewtypeDeriving - build-depends: aeson >= 0.7 && < 0.12- , aeson-pretty >= 0.7 && < 0.8+ build-depends: aeson >= 0.7 && < 1.1+ , aeson-pretty >= 0.7 && < 0.9 , base >= 4.8 && < 5 , bytestring >= 0.10 && < 0.11 , cereal >= 0.5 && < 0.6 , containers >= 0.5 && < 0.6 , conduit >= 1.2 && < 1.3 , deepseq >= 1.4 && < 1.5- , data-default >= 0.5 && < 0.6- , directory >= 1.2 && < 1.3+ , data-default >= 0.5 && < 0.8+ , directory >= 1.2 && < 1.4 , daemons >= 0.2 && < 0.3 , exceptions >= 0.6 && < 0.9- , esqueleto >= 2.4 && < 2.5+ , esqueleto >= 2.4 && < 2.6 , file-embed >= 0.0 && < 0.1 , filepath >= 1.4 && < 1.5 , haskeline@@ -80,15 +82,15 @@ , monad-logger >= 0.3.13 && < 0.4 , monad-control >= 1.0 && < 1.1 , mtl >= 2.1 && < 2.3- , persistent >= 2.2 && < 2.3- , persistent-template >= 2.1 && < 2.2- , persistent-sqlite >= 2.2 && < 2.3+ , persistent >= 2.2 && < 2.7+ , persistent-template >= 2.1 && < 2.6+ , persistent-sqlite >= 2.2 && < 2.7 , resourcet >= 1.1 && < 1.2 , semigroups , split >= 0.2 && < 0.3 , stm >= 2.4 && < 2.5 , stm-chans >= 3.0 && < 3.1- , stm-conduit >= 2.6 && < 2.9+ , stm-conduit >= 2.6 && < 3.1 , string-conversions >= 0.4 && < 0.5 , text >= 0.11 && < 1.3 , time >= 1.5 && < 1.7@@ -123,23 +125,23 @@ extensions: RecordWildCards OverloadedStrings - build-depends: aeson >= 0.7 && < 0.12+ build-depends: aeson >= 0.7 && < 1.1 , base >= 4.8 && < 5 , bytestring >= 0.10 && < 0.11 , containers >= 0.5 && < 0.6- , directory >= 1.2 && < 1.3+ , directory >= 1.2 && < 1.4 , haskoin-core >= 0.3 && < 0.5 , haskoin-node >= 0.3 && < 0.5 , haskoin-wallet , monad-logger >= 0.3 && < 0.4 , mtl >= 2.1 && < 2.3- , persistent >= 2.2 && < 2.3- , persistent-sqlite >= 2.2 && < 2.3+ , persistent >= 2.2 && < 2.7+ , persistent-sqlite >= 2.2 && < 2.7 , resourcet >= 1.1 && < 1.2 , text >= 0.11 && < 1.3 , unordered-containers >= 0.2 && < 0.3- , HUnit >= 1.2 && < 1.4- , QuickCheck >= 2.8 && < 2.9+ , HUnit >= 1.2 && < 1.6+ , QuickCheck >= 2.8 && < 2.10 , stm >= 2.4 && < 2.5 , stm-chans >= 3.0 && < 3.1 , string-conversions >= 0.4 && < 0.5@@ -150,3 +152,28 @@ hs-source-dirs: tests ghc-options: -Wall +executable example-inproc-wallet-server+ if flag(library-only)+ Buildable: False++ main-is: Main.hs+ hs-source-dirs: examples/embedded-inproc-wallet-server/+ extensions: OverloadedStrings++ ghc-options: -Wall+ -O3+ -threaded+ -rtsopts+ -with-rtsopts=-N4++ build-depends: base >= 4.8 && < 5+ , aeson >= 0.7 && < 1.1+ , aeson-pretty >= 0.7 && < 0.9+ , haskoin-node >= 0.3 && < 0.5+ , haskoin-wallet+ , monad-logger >= 0.3 && < 0.4+ , persistent-sqlite >= 2.2 && < 2.7+ , resourcet >= 1.1 && < 1.2+ , unordered-containers >= 0.2 && < 0.3+ , string-conversions >= 0.4 && < 0.5+ , zeromq4-haskell >= 0.6 && < 0.7