{-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# OPTIONS_GHC -fno-warn-orphans #-} import Conduit import Control.Arrow import Control.Concurrent.NQE import Control.Exception import Control.Monad import Control.Monad.Logger import Data.Aeson (ToJSON (..), Value (..), encode, object, (.=)) import Data.Bits import Data.ByteString.Builder (lazyByteString) import Data.Function import Data.List import Data.Maybe import Data.String.Conversions import qualified Data.Text as T import Data.Version import Database.RocksDB hiding (get) import Haskoin import Network.Haskoin.Node import Network.Haskoin.Store import Network.HTTP.Types import Options.Applicative import Paths_haskoin_store as P import System.Directory import System.Exit import System.FilePath import System.IO.Unsafe import Text.Read (readMaybe) import UnliftIO import Web.Scotty.Trans data OptConfig = OptConfig { optConfigDir :: !(Maybe FilePath) , optConfigPort :: !(Maybe Int) , optConfigNetwork :: !(Maybe Network) , optConfigDiscover :: !(Maybe Bool) , optConfigPeers :: !(Maybe [(Host, Maybe Port)]) , optConfigMaxReqs :: !(Maybe Int) , optConfigVersion :: !Bool } data Config = Config { configDir :: !FilePath , configPort :: !Int , configNetwork :: !Network , configDiscover :: !Bool , configPeers :: ![(Host, Maybe Port)] , configMaxReqs :: !Int } maxUriArgs :: Int maxUriArgs = 500 maxPubSubQueue :: Int maxPubSubQueue = 10000 defMaxReqs :: Int defMaxReqs = 10000 defPort :: Int defPort = 3000 defNetwork :: Network defNetwork = btc defDiscovery :: Bool defDiscovery = False defPeers :: [(Host, Maybe Port)] defPeers = [] optToConfig :: OptConfig -> Config optToConfig OptConfig {..} = Config { configDir = fromMaybe myDirectory optConfigDir , configPort = fromMaybe defPort optConfigPort , configNetwork = fromMaybe defNetwork optConfigNetwork , configDiscover = fromMaybe defDiscovery optConfigDiscover , configPeers = fromMaybe defPeers optConfigPeers , configMaxReqs = fromMaybe defMaxReqs optConfigMaxReqs } instance Parsable BlockHash where parseParam = maybe (Left "could not decode block hash") Right . hexToBlockHash . cs instance Parsable TxHash where parseParam = maybe (Left "could not decode tx hash") Right . hexToTxHash . cs data Except = ThingNotFound | ServerError | BadRequest | UserError String | OutOfBounds | StringError String deriving (Show, Eq) instance Exception Except instance ScottyError Except where stringError = StringError showError = cs . show instance ToJSON Except where toJSON ThingNotFound = object ["error" .= String "not found"] toJSON BadRequest = object ["error" .= String "bad request"] toJSON ServerError = object ["error" .= String "you made me kill a unicorn"] toJSON OutOfBounds = object ["error" .= String "too many elements requested"] toJSON (StringError _) = object ["error" .= String "you made me kill a unicorn"] toJSON (UserError s) = object ["error" .= s] data JsonEvent = JsonEventTx TxHash | JsonEventBlock BlockHash deriving (Eq, Show) instance ToJSON JsonEvent where toJSON (JsonEventTx tx_hash) = object ["type" .= String "tx", "id" .= tx_hash] toJSON (JsonEventBlock block_hash) = object ["type" .= String "block", "id" .= block_hash] netNames :: String netNames = intercalate "|" $ map getNetworkName allNets config :: Parser OptConfig config = do optConfigDir <- optional . option str $ metavar "DIR" <> long "dir" <> short 'd' <> help ("Data directory (default: " <> myDirectory <> ")") optConfigPort <- optional . option auto $ metavar "PORT" <> long "port" <> short 'p' <> help ("Port to listen (default: " <> show defPort <> ")") optConfigNetwork <- optional . option (eitherReader networkReader) $ metavar "NETWORK" <> long "network" <> short 'n' <> help ("Network: " <> netNames <> " (default: " <> net <> ")") optConfigDiscover <- optional . switch $ long "discover" <> help "Enable peer discovery" optConfigPeers <- optional . option (eitherReader peerReader) $ metavar "PEERS" <> long "peers" <> help "Network peers (i.e. localhost,peer.example.com:8333)" optConfigMaxReqs <- optional . option auto $ metavar "MAXREQ" <> long "maxreq" <> help ("Maximum returned entries (default:" <> show defMaxReqs <> ")") optConfigVersion <- switch $ long "version" <> short 'v' <> help "Show version" return OptConfig {..} where net = getNetworkName defNetwork networkReader :: String -> Either String Network networkReader s | s == getNetworkName btc = Right btc | s == getNetworkName btcTest = Right btcTest | s == getNetworkName btcRegTest = Right btcRegTest | s == getNetworkName bch = Right bch | s == getNetworkName bchTest = Right bchTest | s == getNetworkName bchRegTest = Right bchRegTest | otherwise = Left "Network name invalid" peerReader :: String -> Either String [(Host, Maybe Port)] peerReader = mapM hp . ls where hp s = do let (host, p) = span (/= ':') s when (null host) (Left "Peer name or address not defined") port <- case p of [] -> return Nothing ':':p' -> case readMaybe p' of Nothing -> Left "Peer port number cannot be read" Just n -> return (Just n) _ -> Left "Peer information could not be parsed" return (host, port) ls = map T.unpack . T.split (== ',') . T.pack defHandler :: Monad m => Except -> ActionT Except m () defHandler ServerError = json ServerError defHandler OutOfBounds = status status413 >> json OutOfBounds defHandler ThingNotFound = status status404 >> json ThingNotFound defHandler BadRequest = status status400 >> json BadRequest defHandler (UserError s) = status status400 >> json (UserError s) defHandler e = status status400 >> json e maybeJSON :: (Monad m, ToJSON a) => Maybe a -> ActionT Except m () maybeJSON Nothing = raise ThingNotFound maybeJSON (Just x) = json x myDirectory :: FilePath myDirectory = unsafePerformIO $ getAppUserDataDirectory "haskoin-store" {-# NOINLINE myDirectory #-} main :: IO () main = runStderrLoggingT $ do opt <- liftIO (execParser opts) when (optConfigVersion opt) . liftIO $ do putStrLn $ showVersion P.version exitSuccess let conf = optToConfig opt when (null (configPeers conf) && not (configDiscover conf)) . liftIO $ die "Specify: --discover | --peers PEER,..." let net = configNetwork conf b <- Inbox <$> newTQueueIO s <- Inbox <$> newTQueueIO let wdir = configDir conf getNetworkName net liftIO $ createDirectoryIfMissing True wdir db <- open (wdir "blocks") defaultOptions { createIfMissing = True , compression = SnappyCompression , maxOpenFiles = -1 , writeBufferSize = 2 `shift` 30 } mgr <- Inbox <$> newTQueueIO pub <- Inbox <$> newTQueueIO ch <- Inbox <$> newTQueueIO supervisor KillAll s [runWeb conf pub mgr ch b db, runStore conf pub mgr ch b db] where opts = info (helper <*> config) $ fullDesc <> progDesc "Blockchain store and API" <> Options.Applicative.header ("haskoin-store version " <> showVersion P.version) testLength :: Monad m => Int -> ActionT Except m () testLength l = when (l <= 0 || l > maxUriArgs) (raise OutOfBounds) runWeb :: (MonadUnliftIO m, MonadLoggerIO m) => Config -> Publisher Inbox TBQueue StoreEvent -> Manager -> Chain -> BlockStore -> DB -> m () runWeb conf pub mgr ch bl db = do l <- askLoggerIO scottyT (configPort conf) (runner l) $ do defaultHandler defHandler get "/block/best" $ getBestBlock db Nothing >>= json get "/block/:block" $ do block <- param "block" getBlock block db Nothing >>= maybeJSON get "/block/height/:height" $ do height <- param "height" getBlockAtHeight height db Nothing >>= maybeJSON get "/block/heights" $ do heights <- param "heights" testLength (length heights) getBlocksAtHeights heights db Nothing >>= json get "/blocks" $ do blocks <- param "blocks" testLength (length blocks) getBlocks blocks db Nothing >>= json get "/mempool" $ lift (getMempool db Nothing) >>= json get "/transaction/:txid" $ do txid <- param "txid" lift (getTx net txid db Nothing) >>= maybeJSON get "/transactions" $ do txids <- param "txids" testLength (length txids) lift (getTxs net txids db Nothing) >>= json get "/address/:address/outputs" $ do address <- parse_address height <- parse_height x <- parse_max lift (addrTxsMax db x height address) >>= json get "/address/outputs" $ do addresses <- parse_addresses height <- parse_height x <- parse_max lift (addrsTxsMax db x height addresses) >>= json get "/address/:address/unspent" $ do address <- parse_address height <- parse_height x <- parse_max lift (addrUnspentMax db x height address) >>= json get "/address/unspent" $ do addresses <- parse_addresses height <- parse_height x <- parse_max lift (addrsUnspentMax db x height addresses) >>= json get "/address/:address/balance" $ do address <- parse_address getBalance address db Nothing >>= json get "/address/balances" $ do addresses <- parse_addresses getBalances addresses db Nothing >>= json post "/transactions" $ do NewTx tx <- jsonData lift (publishTx net pub mgr ch db bl tx) >>= \case Left PublishTimeout -> do status status500 json (UserError (show PublishTimeout)) Left e -> do status status400 json (UserError (show e)) Right j -> json j get "/dbstats" $ getProperty db Stats >>= text . cs . fromJust get "/events" $ do setHeader "Content-Type" "application/x-json-stream" stream $ \io flush -> withBoundedPubSub maxPubSubQueue pub $ \sub -> forever $ flush >> receive sub >>= \case BestBlock block_hash -> do let bs = encode (JsonEventBlock block_hash) <> "\n" io (lazyByteString bs) MempoolNew tx_hash -> do let bs = encode (JsonEventTx tx_hash) <> "\n" io (lazyByteString bs) _ -> return () notFound $ raise ThingNotFound where parse_address = do address <- param "address" case stringToAddr net address of Nothing -> next Just a -> return a parse_addresses = do addresses <- param "addresses" let as = mapMaybe (stringToAddr net) addresses if length as == length addresses then testLength (length as) >> return as else next parse_max = do x <- param "max" `rescue` const (return (configMaxReqs conf)) when (x < 1 || x > configMaxReqs conf) (raise OutOfBounds) return x parse_height = (Just <$> param "height") `rescue` const (return Nothing) net = configNetwork conf runner f l = do u <- askUnliftIO unliftIO u (runLoggingT l f) runStore :: (MonadLoggerIO m, MonadUnliftIO m) => Config -> Publisher Inbox TBQueue StoreEvent -> Manager -> Chain -> BlockStore -> DB -> m () runStore conf pub mgr ch b db = do s <- Inbox <$> newTQueueIO let net = configNetwork conf cfg = StoreConfig { storeConfBlocks = b , storeConfSupervisor = s , storeConfChain = ch , storeConfManager = mgr , storeConfPublisher = pub , storeConfMaxPeers = 20 , storeConfInitPeers = map (second (fromMaybe (getDefaultPort net))) (configPeers conf) , storeConfDiscover = configDiscover conf , storeConfDB = db , storeConfNetwork = net } store cfg addrTxsMax :: MonadUnliftIO m => DB -> Int -> Maybe BlockHeight -> Address -> m [AddrOutput] addrTxsMax db c h = addrsTxsMax db c h . (: []) addrsTxsMax :: MonadUnliftIO m => DB -> Int -> Maybe BlockHeight -> [Address] -> m [AddrOutput] addrsTxsMax db c h as = runResourceT $ runConduit $ getAddrsOutputs as h db Nothing .| capRecords f c .| sinkList where f = (==) `on` g g AddrOutput {..} = (addrOutputAddress addrOutputKey, blockRefHash <$> outBlock addrOutput) addrUnspentMax :: MonadUnliftIO m => DB -> Int -> Maybe BlockHeight -> Address -> m [AddrOutput] addrUnspentMax db c h = addrsUnspentMax db c h . (: []) addrsUnspentMax :: MonadUnliftIO m => DB -> Int -> Maybe BlockHeight -> [Address] -> m [AddrOutput] addrsUnspentMax db c h as = runResourceT $ runConduit $ getUnspents as h db Nothing .| capRecords f c .| sinkList where f = (==) `on` g g AddrOutput {..} = (addrOutputAddress addrOutputKey, blockRefHash <$> outBlock addrOutput) capRecords :: Monad m => (a -> a -> Bool) -> Int -> ConduitT a a m () capRecords f c = void $ mapAccumWhileC go (Nothing, c) where go x (acc, n) | n > 0 = Right ((Just x, n - 1), x) | otherwise = case acc of Nothing -> Left (Just x, n - 1) Just y -> if f x y then Right ((Just x, n - 1), x) else Left (Just x, n - 1)