{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
module Network.Haskoin.Wallet.Server.Handler where
import Control.Arrow (first)
import Control.Concurrent.STM.TBMChan (TBMChan)
import Control.Exception (SomeException (..),
tryJust)
import Control.Monad (liftM, forM, unless, when)
import Control.Monad.Base (MonadBase)
import Control.Monad.Catch (MonadThrow, throwM)
import Control.Monad.Logger (MonadLoggerIO, logError,
logInfo)
import Control.Monad.Reader (ReaderT, asks, runReaderT)
import Control.Monad.Trans (MonadIO, lift, liftIO)
import Control.Monad.Trans.Control (MonadBaseControl)
import Control.Monad.Trans.Resource (MonadResource)
import Data.Aeson (Value (..), toJSON)
import qualified Data.Map.Strict as M (elems, fromList,
intersectionWith)
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,
runSqlPersistMPool,
runSqlPool)
import Network.Haskoin.Block
import Network.Haskoin.Crypto
import Network.Haskoin.Node.BlockChain
import Network.Haskoin.Node.HeaderTree
import Network.Haskoin.Node.Peer
import Network.Haskoin.Node.STM
import Network.Haskoin.Transaction
import Network.Haskoin.Wallet.Accounts
import Network.Haskoin.Wallet.Block
import Network.Haskoin.Wallet.Model
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
data HandlerSession = HandlerSession
{ handlerConfig :: !Config
, handlerPool :: !ConnectionPool
, handlerNodeState :: !(Maybe SharedNodeState)
, handlerNotifChan :: !(TBMChan Notif)
}
runHandler :: Monad m => Handler m a -> HandlerSession -> m a
runHandler = runReaderT
runDB :: MonadBaseControl IO m => SqlPersistT m a -> Handler m a
runDB action = asks handlerPool >>= lift . runDBPool action
runDBPool :: MonadBaseControl IO m => SqlPersistT m a -> ConnectionPool -> m a
runDBPool = runSqlPool
tryDBPool :: MonadLoggerIO m => ConnectionPool -> SqlPersistM a -> m (Maybe a)
tryDBPool pool action = do
resE <- liftIO $ tryJust f $ runSqlPersistMPool action pool
case resE of
Right res -> return $ Just res
Left err -> do
$(logError) $ pack $ unwords [ "A database error occured:", err]
return Nothing
where
f (SomeException e) = Just $ show e
runNode :: MonadIO m => NodeT m a -> Handler m a
runNode action = do
nodeStateM <- asks handlerNodeState
case nodeStateM of
Just nodeState -> lift $ runNodeT action nodeState
_ -> error "runNode: No node state available"
getAccountsR :: ( MonadLoggerIO m
, MonadBaseControl IO m
, MonadBase IO m
, MonadThrow m
, MonadResource m
)
=> ListRequest
-> Handler m (Maybe Value)
getAccountsR lq@ListRequest{..} = do
$(logInfo) $ format $ unlines
[ "GetAccountsR"
, " Offset : " ++ show listOffset
, " Limit : " ++ show listLimit
, " Reversed : " ++ show listReverse
]
(accs, cnt) <- runDB $ accounts lq
return $ Just $ toJSON $ ListResult (map (toJsonAccount Nothing) accs) cnt
postAccountsR
:: (MonadResource m, MonadThrow m, MonadLoggerIO m, MonadBaseControl IO m)
=> NewAccount -> Handler m (Maybe Value)
postAccountsR newAcc@NewAccount{..} = do
$(logInfo) $ format $ unlines
[ "PostAccountsR"
, " Account name: " ++ unpack newAccountName
, " Account type: " ++ show newAccountType
]
(Entity _ newAcc', mnemonicM) <- runDB $ newAccount newAcc
whenOnline $ when (isCompleteAccount newAcc') updateNodeFilter
return $ Just $ toJSON $ toJsonAccount mnemonicM newAcc'
postAccountRenameR
:: (MonadResource m, MonadThrow m, MonadLoggerIO m, MonadBaseControl IO m)
=> AccountName -> AccountName -> Handler m (Maybe Value)
postAccountRenameR oldName newName = do
$(logInfo) $ format $ unlines
[ "PostAccountRenameR"
, " Account name: " ++ unpack oldName
, " New name : " ++ unpack newName
]
newAcc <- runDB $ do
accE <- getAccount oldName
renameAccount accE newName
return $ Just $ toJSON $ toJsonAccount Nothing newAcc
getAccountR :: (MonadLoggerIO m, MonadBaseControl IO m, MonadThrow m)
=> AccountName -> Handler m (Maybe Value)
getAccountR name = do
$(logInfo) $ format $ unlines
[ "GetAccountR"
, " Account name: " ++ unpack name
]
Entity _ acc <- runDB $ getAccount name
return $ Just $ toJSON $ toJsonAccount Nothing acc
postAccountKeysR
:: (MonadResource m, MonadThrow m, MonadLoggerIO m, MonadBaseControl IO m)
=> AccountName -> [XPubKey] -> Handler m (Maybe Value)
postAccountKeysR name keys = do
$(logInfo) $ format $ unlines
[ "PostAccountKeysR"
, " Account name: " ++ unpack name
, " Key count : " ++ show (length keys)
]
newAcc <- runDB $ do
accE <- getAccount name
addAccountKeys accE keys
whenOnline $ when (isCompleteAccount newAcc) updateNodeFilter
return $ Just $ toJSON $ toJsonAccount Nothing newAcc
postAccountGapR :: ( MonadLoggerIO m
, MonadBaseControl IO m
, MonadBase IO m
, MonadThrow m
, MonadResource m
)
=> AccountName -> SetAccountGap
-> Handler m (Maybe Value)
postAccountGapR name (SetAccountGap gap) = do
$(logInfo) $ format $ unlines
[ "PostAccountGapR"
, " Account name: " ++ unpack name
, " New gap size: " ++ show gap
]
Entity _ newAcc <- runDB $ do
accE <- getAccount name
setAccountGap accE gap
whenOnline updateNodeFilter
return $ Just $ toJSON $ toJsonAccount Nothing newAcc
getAddressesR :: (MonadLoggerIO m, MonadBaseControl IO m, MonadThrow m)
=> AccountName
-> AddressType
-> Word32
-> Bool
-> ListRequest
-> Handler m (Maybe Value)
getAddressesR name addrType minConf offline listReq = do
$(logInfo) $ format $ unlines
[ "GetAddressesR"
, " Account name: " ++ unpack name
, " Address type: " ++ show addrType
, " Start index : " ++ show (listOffset listReq)
, " Reversed : " ++ show (listReverse listReq)
, " MinConf : " ++ show minConf
, " Offline : " ++ show offline
]
(res, bals, cnt) <- runDB $ do
accE <- getAccount name
(res, cnt) <- addressList accE addrType listReq
case res of
[] -> return (res, [], cnt)
_ -> do
let is = map walletAddrIndex res
(iMin, iMax) = (minimum is, maximum is)
bals <- addressBalances accE iMin iMax addrType minConf offline
return (res, bals, cnt)
let g (addr, bal) = toJsonAddr addr (Just bal)
addrBals = map g $ M.elems $ joinAddrs res bals
return $ Just $ toJSON $ ListResult addrBals cnt
where
joinAddrs addrs bals =
let f addr = (walletAddrIndex addr, addr)
in M.intersectionWith (,) (M.fromList $ map f addrs) (M.fromList bals)
getAddressesUnusedR
:: (MonadLoggerIO m, MonadBaseControl IO m, MonadThrow m)
=> AccountName -> AddressType -> ListRequest -> Handler m (Maybe Value)
getAddressesUnusedR name addrType lq@ListRequest{..} = do
$(logInfo) $ format $ unlines
[ "GetAddressesUnusedR"
, " Account name: " ++ unpack name
, " Address type: " ++ show addrType
, " Offset : " ++ show listOffset
, " Limit : " ++ show listLimit
, " Reversed : " ++ show listReverse
]
(addrs, cnt) <- runDB $ do
accE <- getAccount name
unusedAddresses accE addrType lq
return $ Just $ toJSON $ ListResult (map (`toJsonAddr` Nothing) addrs) cnt
getAddressR :: (MonadLoggerIO m, MonadBaseControl IO m, MonadThrow m)
=> AccountName -> KeyIndex -> AddressType
-> Word32 -> Bool
-> Handler m (Maybe Value)
getAddressR name i addrType minConf offline = do
$(logInfo) $ format $ unlines
[ "GetAddressR"
, " Account name: " ++ unpack name
, " Index : " ++ show i
, " Address type: " ++ show addrType
]
(addr, balM) <- runDB $ do
accE <- getAccount name
addrE <- getAddress accE addrType i
bals <- addressBalances accE i i addrType minConf offline
return $ case bals of
((_,bal):_) -> (entityVal addrE, Just bal)
_ -> (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
-> AddressType
-> AddressLabel
-> Handler m (Maybe Value)
putAddressR name i addrType (AddressLabel label) = do
$(logInfo) $ format $ unlines
[ "PutAddressR"
, " Account name: " ++ unpack name
, " Index : " ++ show i
, " Label : " ++ unpack label
]
newAddr <- runDB $ do
accE <- getAccount name
setAddrLabel accE i addrType label
return $ Just $ toJSON $ toJsonAddr newAddr Nothing
postAddressesR :: ( MonadLoggerIO m
, MonadBaseControl IO m
, MonadThrow m
, MonadBase IO m
, MonadResource m
)
=> AccountName
-> KeyIndex
-> AddressType
-> Handler m (Maybe Value)
postAddressesR name i addrType = do
$(logInfo) $ format $ unlines
[ "PostAddressesR"
, " Account name: " ++ unpack name
, " Index : " ++ show i
]
cnt <- runDB $ do
accE <- getAccount name
generateAddrs accE addrType i
whenOnline updateNodeFilter
return $ Just $ toJSON cnt
getTxs :: (MonadLoggerIO m, MonadBaseControl IO m, MonadThrow m)
=> AccountName
-> ListRequest
-> String
-> (AccountId -> ListRequest -> SqlPersistT m ([WalletTx], Word32))
-> Handler m (Maybe Value)
getTxs name lq@ListRequest{..} cmd f = do
$(logInfo) $ format $ unlines
[ cmd
, " Account name: " ++ unpack name
, " Offset : " ++ show listOffset
, " Limit : " ++ show listLimit
, " Reversed : " ++ show listReverse
]
(res, cnt, bb) <- runDB $ do
Entity ai _ <- getAccount name
bb <- walletBestBlock
(res, cnt) <- f ai lq
return (res, cnt, bb)
return $ Just $ toJSON $ ListResult (map (g bb) res) cnt
where
g bb = toJsonTx name (Just bb)
getTxsR :: (MonadLoggerIO m, MonadBaseControl IO m, MonadThrow m)
=> AccountName -> ListRequest -> Handler m (Maybe Value)
getTxsR name lq = getTxs name lq "GetTxsR" (txs Nothing)
getPendingR :: (MonadLoggerIO m, MonadBaseControl IO m, MonadThrow m)
=> AccountName -> ListRequest -> Handler m (Maybe Value)
getPendingR name lq = getTxs name lq "GetPendingR" (txs (Just TxPending))
getDeadR :: (MonadLoggerIO m, MonadBaseControl IO m, MonadThrow m)
=> AccountName -> ListRequest -> Handler m (Maybe Value)
getDeadR name lq = getTxs name lq "GetDeadR" (txs (Just TxDead))
getAddrTxsR :: (MonadLoggerIO m, MonadBaseControl IO m, MonadThrow m)
=> AccountName -> KeyIndex -> AddressType -> ListRequest
-> Handler m (Maybe Value)
getAddrTxsR name index addrType lq@ListRequest{..} = do
$(logInfo) $ format $ unlines
[ "GetAddrTxsR"
, " Account name : " ++ unpack name
, " Address index: " ++ show index
, " Address type : " ++ show addrType
, " Offset : " ++ show listOffset
, " Limit : " ++ show listLimit
, " Reversed : " ++ show listReverse
]
(res, cnt, bb) <- runDB $ do
accE <- getAccount name
addrE <- getAddress accE addrType index
bb <- walletBestBlock
(res, cnt) <- addrTxs accE addrE lq
return (res, cnt, bb)
return $ Just $ toJSON $ ListResult (map (f bb) res) cnt
where
f bb = toJsonTx name (Just bb)
postTxsR :: ( MonadLoggerIO m, MonadBaseControl IO m, MonadBase IO m
, MonadThrow m, MonadResource m
)
=> AccountName -> Maybe XPrvKey -> TxAction -> Handler m (Maybe Value)
postTxsR name masterM action = do
(accE@(Entity ai _), bb) <- runDB $ do
accE <- getAccount name
bb <- walletBestBlock
return (accE, bb)
notif <- asks handlerNotifChan
(txRes, newAddrs) <- case action of
CreateTx rs fee minconf rcptFee sign -> do
$(logInfo) $ format $ unlines
[ "PostTxsR CreateTx"
, " Account name: " ++ unpack name
, " Recipients : " ++ show (map (first addrToBase58) rs)
, " Fee : " ++ show fee
, " Minconf : " ++ show minconf
, " Rcpt. Fee : " ++ show rcptFee
, " Sign : " ++ show sign
]
runDB $ createWalletTx
accE (Just notif) masterM rs fee minconf rcptFee sign
ImportTx tx -> do
$(logInfo) $ format $ unlines
[ "PostTxsR ImportTx"
, " Account name: " ++ unpack name
, " TxId : " ++ cs (txHashToHex (txHash tx))
]
runDB $ do
(res, newAddrs) <- importTx tx (Just notif) ai
case filter ((== ai) . walletTxAccount) res of
(txRes:_) -> return (txRes, newAddrs)
_ -> throwM $ WalletException
"Could not import the transaction"
SignTx txid -> do
$(logInfo) $ format $ unlines
[ "PostTxsR SignTx"
, " Account name: " ++ unpack name
, " TxId : " ++ cs (txHashToHex txid)
]
runDB $ do
(res, newAddrs) <- signAccountTx accE (Just notif) masterM txid
case filter ((== ai) . walletTxAccount) res of
(txRes:_) -> return (txRes, newAddrs)
_ -> throwM $ WalletException
"Could not import the transaction"
whenOnline $ do
unless (null newAddrs) updateNodeFilter
when (walletTxConfidence txRes == TxPending) $
runNode $ broadcastTxs [walletTxHash txRes]
return $ Just $ toJSON $ toJsonTx name (Just bb) txRes
getTxR :: (MonadLoggerIO m, MonadBaseControl IO m, MonadThrow m)
=> AccountName -> TxHash -> Handler m (Maybe Value)
getTxR name txid = do
$(logInfo) $ format $ unlines
[ "GetTxR"
, " Account name: " ++ unpack name
, " TxId : " ++ cs (txHashToHex txid)
]
(res, bb) <- runDB $ do
Entity ai _ <- getAccount name
bb <- walletBestBlock
res <- getAccountTx ai txid
return (res, bb)
return $ Just $ toJSON $ toJsonTx name (Just bb) res
deleteTxIdR :: (MonadLoggerIO m, MonadThrow m, MonadBaseControl IO m)
=> TxHash -> Handler m (Maybe Value)
deleteTxIdR txid = do
$(logInfo) $ format $ unlines
[ "DeleteTxR"
, " TxId: " ++ cs (txHashToHex txid)
]
runDB $ deleteTx txid
return Nothing
getBalanceR :: (MonadLoggerIO m, MonadBaseControl IO m, MonadThrow m)
=> AccountName -> Word32 -> Bool
-> Handler m (Maybe Value)
getBalanceR name minconf offline = do
$(logInfo) $ format $ unlines
[ "GetBalanceR"
, " Account name: " ++ unpack name
, " Minconf : " ++ show minconf
, " Offline : " ++ show offline
]
bal <- runDB $ do
Entity ai _ <- getAccount name
accountBalance ai minconf offline
return $ Just $ toJSON bal
getOfflineTxR :: ( MonadLoggerIO m, MonadBaseControl IO m
, MonadBase IO m, MonadThrow m, MonadResource m
)
=> AccountName -> TxHash -> Handler m (Maybe Value)
getOfflineTxR accountName txid = do
$(logInfo) $ format $ unlines
[ "GetOfflineTxR"
, " Account name: " ++ unpack accountName
, " TxId : " ++ cs (txHashToHex txid)
]
(dat, _) <- runDB $ do
Entity ai _ <- getAccount accountName
getOfflineTxData ai txid
return $ Just $ toJSON dat
postOfflineTxR :: ( MonadLoggerIO m, MonadBaseControl IO m
, MonadBase IO m, MonadThrow m, MonadResource m
)
=> AccountName
-> Maybe XPrvKey
-> Tx
-> [CoinSignData]
-> Handler m (Maybe Value)
postOfflineTxR accountName masterM tx signData = do
$(logInfo) $ format $ unlines
[ "PostTxsR SignOfflineTx"
, " Account name: " ++ unpack accountName
, " TxId : " ++ cs (txHashToHex (txHash tx))
]
Entity _ acc <- runDB $ getAccount accountName
let signedTx = signOfflineTx acc masterM tx signData
complete = verifyStdTx signedTx $ map toDat signData
toDat CoinSignData{..} = (coinSignScriptOutput, coinSignOutPoint)
return $ Just $ toJSON $ TxCompleteRes signedTx complete
postNodeR :: (MonadLoggerIO m, MonadBaseControl IO m, MonadThrow m)
=> NodeAction -> Handler m (Maybe Value)
postNodeR action = case action of
NodeActionRescan tM -> do
t <- case tM of
Just t -> return $ adjustFCTime t
Nothing -> do
timeM <- runDB firstAddrTime
maybe err (return . adjustFCTime) timeM
$(logInfo) $ format $ unlines
[ "NodeR Rescan"
, " Timestamp: " ++ show t
]
whenOnline $ do
runDB resetRescan
runNode $ atomicallyNodeT $ rescanTs t
return $ Just $ toJSON $ RescanRes t
NodeActionStatus -> do
status <- runNode $ atomicallyNodeT nodeStatus
return $ Just $ toJSON status
where
err = throwM $ WalletException
"No keys have been generated in the wallet"
getSyncR :: (MonadThrow m, MonadLoggerIO m, MonadBaseControl IO m)
=> AccountName
-> Either BlockHeight BlockHash
-> ListRequest
-> Handler m (Maybe Value)
getSyncR acc blockE lq@ListRequest{..} = runDB $ do
$(logInfo) $ format $ unlines
[ "GetSyncR"
, " Account name: " ++ cs acc
, " Block : " ++ showBlock
, " Offset : " ++ show listOffset
, " Limit : " ++ show listLimit
, " Reversed : " ++ show listReverse
]
ListResult nodes cnt <- mainChain blockE lq
case nodes of
[] -> return $ Just $ toJSON $ ListResult ([] :: [()]) cnt
b:_ -> do
Entity ai _ <- getAccount acc
ts <- accTxsFromBlock ai (nodeBlockHeight b)
(fromIntegral $ length nodes)
let bts = blockTxs nodes ts
return $ Just $ toJSON $ ListResult (map f bts) cnt
where
f (block, txs') = JsonSyncBlock
{ jsonSyncBlockHash = nodeHash block
, jsonSyncBlockHeight = nodeBlockHeight block
, jsonSyncBlockPrev = nodePrev block
, jsonSyncBlockTxs = map (toJsonTx acc Nothing) txs'
}
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
whenOnline :: Monad m => Handler m () -> Handler m ()
whenOnline handler = do
mode <- configMode `liftM` asks handlerConfig
when (mode == SPVOnline) handler
updateNodeFilter
:: (MonadBaseControl IO m, MonadLoggerIO m, MonadThrow m)
=> Handler m ()
updateNodeFilter = do
$(logInfo) $ format "Sending a new bloom filter"
(bloom, elems, _) <- runDB getBloomFilter
runNode $ atomicallyNodeT $ sendBloomFilter bloom elems
adjustFCTime :: Timestamp -> Timestamp
adjustFCTime ts = fromInteger $ max 0 $ toInteger ts - 86400 * 7
format :: String -> Text
format str = pack $ "[ZeroMQ] " ++ str