diff --git a/Network/Haskoin/Wallet/Accounts.hs b/Network/Haskoin/Wallet/Accounts.hs --- a/Network/Haskoin/Wallet/Accounts.hs +++ b/Network/Haskoin/Wallet/Accounts.hs @@ -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) diff --git a/Network/Haskoin/Wallet/Client.hs b/Network/Haskoin/Wallet/Client.hs --- a/Network/Haskoin/Wallet/Client.hs +++ b/Network/Haskoin/Wallet/Client.hs @@ -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) diff --git a/Network/Haskoin/Wallet/Client/Commands.hs b/Network/Haskoin/Wallet/Client/Commands.hs --- a/Network/Haskoin/Wallet/Client/Commands.hs +++ b/Network/Haskoin/Wallet/Client/Commands.hs @@ -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 "" (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 "" (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)" diff --git a/Network/Haskoin/Wallet/Client/PrettyJson.hs b/Network/Haskoin/Wallet/Client/PrettyJson.hs new file mode 100644 --- /dev/null +++ b/Network/Haskoin/Wallet/Client/PrettyJson.hs @@ -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 } diff --git a/Network/Haskoin/Wallet/Server.hs b/Network/Haskoin/Wallet/Server.hs --- a/Network/Haskoin/Wallet/Server.hs +++ b/Network/Haskoin/Wallet/Server.hs @@ -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 diff --git a/Network/Haskoin/Wallet/Server/Handler.hs b/Network/Haskoin/Wallet/Server/Handler.hs --- a/Network/Haskoin/Wallet/Server/Handler.hs +++ b/Network/Haskoin/Wallet/Server/Handler.hs @@ -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 -} diff --git a/Network/Haskoin/Wallet/Types.hs b/Network/Haskoin/Wallet/Types.hs --- a/Network/Haskoin/Wallet/Types.hs +++ b/Network/Haskoin/Wallet/Types.hs @@ -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 diff --git a/Network/Haskoin/Wallet/Types/BlockInfo.hs b/Network/Haskoin/Wallet/Types/BlockInfo.hs new file mode 100644 --- /dev/null +++ b/Network/Haskoin/Wallet/Types/BlockInfo.hs @@ -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 + diff --git a/config/help b/config/help --- a/config/help +++ b/config/help @@ -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 diff --git a/examples/embedded-inproc-wallet-server/Main.hs b/examples/embedded-inproc-wallet-server/Main.hs new file mode 100644 --- /dev/null +++ b/examples/embedded-inproc-wallet-server/Main.hs @@ -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 + } diff --git a/haskoin-wallet.cabal b/haskoin-wallet.cabal --- a/haskoin-wallet.cabal +++ b/haskoin-wallet.cabal @@ -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