module Network.Haskoin.Wallet.Store
(
cmdInit
, cmdNewAcc
, cmdNewMS
, cmdAddKeys
, cmdAccInfo
, cmdListAcc
, cmdDumpKeys
, cmdList
, cmdGenAddrs
, cmdGenWithLabel
, cmdLabel
, cmdWIF
, cmdBalance
, cmdBalances
, cmdCoins
, cmdAllCoins
, cmdImportTx
, cmdRemoveTx
, cmdListTx
, cmdSend
, cmdSendMany
, cmdSignTx
, cmdDecodeTx
, cmdBuildRawTx
, cmdSignRawTx
) where
import Control.Applicative ((<$>))
import Control.Monad (when)
import Control.Monad.Trans (liftIO)
import Control.Monad.Trans.Either (EitherT, left)
import Data.Time (getCurrentTime)
import Data.Yaml
( Value (Null)
, object
, (.=)
, toJSON
)
import Data.Maybe (isJust, fromJust)
import Data.List (sortBy)
import qualified Data.Aeson as Json (decode)
import qualified Data.Text as T (pack)
import Database.Persist
( PersistStore
, PersistUnique
, PersistQuery
, PersistMonadBackend
, Entity(..)
, entityVal
, entityKey
, get
, getBy
, selectList
, insert_
, replace
, count
, (<=.), (==.)
, SelectOpt( Asc, OffsetBy, LimitTo )
)
import Database.Persist.Sqlite (SqlBackend)
import Network.Haskoin.Wallet.Keys
import Network.Haskoin.Wallet.Manager
import Network.Haskoin.Wallet.TxBuilder
import Network.Haskoin.Wallet.Store.DbAccount
import Network.Haskoin.Wallet.Store.DbAddress
import Network.Haskoin.Wallet.Store.DbCoin
import Network.Haskoin.Wallet.Store.DbTx
import Network.Haskoin.Wallet.Store.Util
import Network.Haskoin.Script
import Network.Haskoin.Protocol
import Network.Haskoin.Crypto
import Network.Haskoin.Util
import Network.Haskoin.Util.BuildMonad
cmdInit :: PersistUnique m
=> String
-> EitherT String m Value
cmdInit seed
| null seed = left "cmdInit: seed can not be empty"
| otherwise = do
time <- liftIO getCurrentTime
master <- liftMaybe err $ makeMasterKey $ stringToBS seed
let str = xPrvExport $ masterKey master
prev <- getBy $ UniqueWalletName "main"
when (isJust prev) $ left
"cmdInit: Wallet is already initialized"
insert_ $ DbWallet "main" "full" str (1) time
return Null
where
err = "cmdInit: Invalid master key generated from seed"
cmdNewAcc :: (PersistUnique m, PersistQuery m)
=> String
-> EitherT String m Value
cmdNewAcc name = do
acc <- dbNewAcc name
dbSetGap name 30 False
dbSetGap name 30 True
return $ yamlAcc acc
cmdNewMS :: (PersistUnique m, PersistQuery m)
=> String
-> Int
-> Int
-> [XPubKey]
-> EitherT String m Value
cmdNewMS name m n mskeys = do
acc <- dbNewMS name m n mskeys
when (length (dbAccountMsKeys acc) == n 1) $ do
dbSetGap name 30 False
dbSetGap name 30 True
return $ yamlAcc acc
cmdAddKeys :: (PersistUnique m, PersistQuery m)
=> AccountName
-> [XPubKey]
-> EitherT String m Value
cmdAddKeys name keys = do
acc <- dbAddKeys name keys
let n = fromJust $ dbAccountMsTotal acc
when (length (dbAccountMsKeys acc) == n 1) $ do
dbSetGap name 30 False
dbSetGap name 30 True
return $ yamlAcc acc
cmdAccInfo :: PersistUnique m
=> AccountName
-> EitherT String m Value
cmdAccInfo name = yamlAcc . entityVal <$> dbGetAcc name
cmdListAcc :: PersistQuery m
=> EitherT String m Value
cmdListAcc = toJSON . (map (yamlAcc . entityVal)) <$> selectList [] []
cmdDumpKeys :: PersistUnique m
=> AccountName
-> EitherT String m Value
cmdDumpKeys name = do
(Entity _ acc) <- dbGetAcc name
w <- liftMaybe walErr =<< (get $ dbAccountWallet acc)
let keyM = loadMasterKey =<< (xPrvImport $ dbWalletMaster w)
master <- liftMaybe keyErr keyM
prv <- liftMaybe prvErr $
accPrvKey master (fromIntegral $ dbAccountIndex acc)
let prvKey = getAccPrvKey prv
pubKey = deriveXPubKey prvKey
ms | isMSAcc acc = ["MSKeys" .= (toJSON $ dbAccountMsKeys acc)]
| otherwise = []
return $ object $
[ "Account" .= yamlAcc acc
, "PubKey" .= xPubExport pubKey
, "PrvKey" .= xPrvExport prvKey
] ++ ms
where keyErr = "cmdDumpKeys: Could not decode master key"
prvErr = "cmdDumpKeys: Could not derive account private key"
walErr = "cmdDumpKeys: Could not find account wallet"
cmdList :: (PersistUnique m, PersistQuery m)
=> AccountName
-> Int
-> Int
-> EitherT String m Value
cmdList name pageNum resPerPage
| pageNum < 0 = left $
unwords ["cmdList: Invalid page number", show pageNum]
| resPerPage < 1 = left $
unwords ["cmdList: Invalid results per page",show resPerPage]
| otherwise = do
(Entity ai acc) <- dbGetAcc name
addrCount <- count
[ DbAddressAccount ==. ai
, DbAddressInternal ==. False
, DbAddressIndex <=. dbAccountExtIndex acc
]
let maxPage = max 1 $ (addrCount + resPerPage 1) `div` resPerPage
page | pageNum == 0 = maxPage
| otherwise = pageNum
when (page > maxPage) $ left "cmdList: Page number too high"
addrs <- selectList [ DbAddressAccount ==. ai
, DbAddressInternal ==. False
, DbAddressIndex <=. dbAccountExtIndex acc
]
[ Asc DbAddressId
, LimitTo resPerPage
, OffsetBy $ (page 1) * resPerPage
]
return $ yamlAddrList (map entityVal addrs) page resPerPage addrCount
cmdGenAddrs :: (PersistUnique m, PersistQuery m)
=> AccountName
-> Int
-> EitherT String m Value
cmdGenAddrs name c = cmdGenWithLabel name (replicate c "")
cmdGenWithLabel :: (PersistUnique m, PersistQuery m)
=> AccountName
-> [String]
-> EitherT String m Value
cmdGenWithLabel name labels = do
addrs <- dbGenAddrs name labels False
return $ toJSON $ map yamlAddr addrs
cmdLabel :: PersistUnique m
=> AccountName
-> Int
-> String
-> EitherT String m Value
cmdLabel name key label = do
(Entity ai acc) <- dbGetAcc name
(Entity i add) <- liftMaybe keyErr =<<
(getBy $ UniqueAddressKey ai key False)
when (dbAddressIndex add > dbAccountExtIndex acc) $ left keyErr
let newAddr = add{dbAddressLabel = label}
replace i newAddr
return $ yamlAddr newAddr
where
keyErr = unwords ["cmdLabel: Key",show key,"does not exist"]
cmdWIF :: PersistUnique m
=> AccountName
-> Int
-> EitherT String m Value
cmdWIF name key = do
(Entity _ w) <- dbGetWallet "main"
(Entity ai acc) <- dbGetAcc name
(Entity _ add) <- liftMaybe keyErr =<<
(getBy $ UniqueAddressKey ai key False)
when (dbAddressIndex add > dbAccountExtIndex acc) $ left keyErr
mst <- liftMaybe mstErr $ loadMasterKey =<< xPrvImport (dbWalletMaster w)
aKey <- liftMaybe prvErr $ accPrvKey mst $ fromIntegral $ dbAccountIndex acc
let index = fromIntegral $ dbAddressIndex add
addrPrvKey <- liftMaybe addErr $ extPrvKey aKey index
let prvKey = xPrvKey $ getAddrPrvKey addrPrvKey
return $ object [ "WIF" .= T.pack (toWIF prvKey) ]
where
keyErr = unwords ["cmdWIF: Key",show key,"does not exist"]
mstErr = "cmdWIF: Could not load master key"
prvErr = "cmdWIF: Invalid account derivation index"
addErr = "cmdWIF: Invalid address derivation index"
cmdBalance :: (PersistUnique m, PersistQuery m)
=> AccountName
-> EitherT String m Value
cmdBalance name = do
acc <- dbGetAcc name
balance <- dbBalance acc
return $ object [ "Balance" .= toJSON balance ]
cmdBalances :: PersistQuery m
=> EitherT String m Value
cmdBalances = do
accs <- selectList [] []
bals <- mapM dbBalance accs
return $ toJSON $ map f $ zip accs bals
where
f (acc,b) = object
[ "Account" .= (dbAccountName $ entityVal acc)
, "Balance" .= b
]
cmdCoins :: ( PersistQuery m, PersistUnique m
, PersistMonadBackend m ~ SqlBackend
)
=> AccountName
-> EitherT String m Value
cmdCoins name = do
(Entity ai _) <- dbGetAcc name
coins <- dbCoins ai
return $ toJSON $ map yamlCoin coins
cmdAllCoins :: ( PersistQuery m, PersistUnique m
, PersistMonadBackend m ~ SqlBackend
)
=> EitherT String m Value
cmdAllCoins = do
accs <- selectList [] []
coins <- mapM (dbCoins . entityKey) accs
return $ toJSON $ map g $ zip accs coins
where
g (acc,cs) = object
[ "Account" .= (dbAccountName $ entityVal acc)
, "Coins" .= (toJSON $ map yamlCoin cs)
]
cmdImportTx :: ( PersistQuery m, PersistUnique m
, PersistMonadBackend m ~ SqlBackend
)
=> Tx
-> EitherT String m Value
cmdImportTx tx = do
accTx <- dbImportTx tx
return $ toJSON $ map yamlTx $ sortBy f accTx
where
f a b = (dbTxCreated a) `compare` (dbTxCreated b)
cmdRemoveTx :: PersistQuery m
=> String
-> EitherT String m Value
cmdRemoveTx tid = do
removed <- dbRemoveTx tid
return $ toJSON removed
cmdListTx :: (PersistQuery m, PersistUnique m)
=> AccountName
-> EitherT String m Value
cmdListTx name = do
(Entity ai _) <- dbGetAcc name
txs <- selectList [ DbTxAccount ==. ai
]
[ Asc DbTxCreated ]
return $ toJSON $ map (yamlTx . entityVal) txs
cmdSend :: ( PersistQuery m, PersistUnique m
, PersistMonadBackend m ~ SqlBackend
)
=> AccountName
-> String
-> Int
-> Int
-> EitherT String m Value
cmdSend name a v fee = do
(tx,complete) <- dbSendTx name [(a,fromIntegral v)] (fromIntegral fee)
return $ object [ "Tx" .= (toJSON $ bsToHex $ encode' tx)
, "Complete" .= complete
]
cmdSendMany :: ( PersistQuery m, PersistUnique m
, PersistMonadBackend m ~ SqlBackend
)
=> AccountName
-> [(String,Int)]
-> Int
-> EitherT String m Value
cmdSendMany name dests fee = do
(tx,complete) <- dbSendTx name dests' (fromIntegral fee)
return $ object [ "Tx" .= (toJSON $ bsToHex $ encode' tx)
, "Complete" .= complete
]
where dests' = map (\(a,b) -> (a,fromIntegral b)) dests
cmdSignTx :: PersistUnique m
=> AccountName
-> Tx
-> SigHash
-> EitherT String m Value
cmdSignTx name tx sh = do
(newTx,complete) <- dbSignTx name tx sh
return $ object
[ (T.pack "Tx") .= (toJSON $ bsToHex $ encode' newTx)
, (T.pack "Complete") .= complete
]
cmdDecodeTx :: Monad m
=> String
-> EitherT String m Value
cmdDecodeTx str = do
tx <- liftMaybe txErr $ decodeToMaybe =<< (hexToBS str)
return $ toJSON (tx :: Tx)
where txErr = "cmdDecodeTx: Could not decode transaction"
cmdBuildRawTx :: Monad m
=> String
-> String
-> EitherT String m Value
cmdBuildRawTx i o = do
(RawTxOutPoints ops) <- liftMaybe opErr $
Json.decode $ toLazyBS $ stringToBS i
(RawTxDests dests) <- liftMaybe dsErr $
Json.decode $ toLazyBS $ stringToBS o
tx <- liftEither $ buildAddrTx ops dests
return $ object [ (T.pack "Tx") .= (bsToHex $ encode' tx) ]
where
opErr = "cmdBuildRawTx: Could not parse OutPoints"
dsErr = "cmdBuildRawTx: Could not parse recipients"
cmdSignRawTx :: Monad m
=> Tx
-> String
-> String
-> SigHash
-> EitherT String m Value
cmdSignRawTx tx strSigi strKeys sh = do
(RawSigInput fs) <- liftMaybe sigiErr $
Json.decode $ toLazyBS $ stringToBS strSigi
(RawPrvKey keys) <- liftMaybe keysErr $
Json.decode $ toLazyBS $ stringToBS strKeys
let sigTx = detSignTx tx (map (\f -> f sh) fs) keys
bsTx <- liftEither $ buildToEither sigTx
return $ object [ (T.pack "Tx") .= (toJSON $ bsToHex $ encode' bsTx)
, (T.pack "Complete") .= isComplete sigTx
]
where
sigiErr = "cmdSignRawTx: Could not parse parent transaction data"
keysErr = "cmdSignRawTx: Could not parse private keys (WIF)"