{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}

module Main where

import Control.Applicative ((<|>))
import Control.Arrow (second)
import Control.Monad (when)
import Control.Monad.Logger
  ( LogLevel (..),
    filterLogger,
    logInfoS,
    runStderrLoggingT,
  )
import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT)
import Data.Char (toLower)
import Data.Default (Default (..))
import Data.List (intercalate)
import Data.Maybe (fromMaybe)
import Data.String.Conversions (cs)
import qualified Data.Text as T
import Data.Word (Word32)
import Haskoin
  ( Network (..),
    allNets,
    bch,
    bchRegTest,
    bchTest,
    bchTest4,
    btc,
    btcRegTest,
    btcTest,
    eitherToMaybe,
  )
import Haskoin.Node (withConnection)
import Haskoin.Store
  ( StoreConfig (..),
    WebConfig (..),
    WebLimits (..),
    WebTimeouts (..),
    runWeb,
    withStore,
  )
import Haskoin.Store.Stats (withStats)
import Options.Applicative
  ( Parser,
    auto,
    eitherReader,
    execParser,
    flag,
    fullDesc,
    header,
    help,
    helper,
    info,
    long,
    many,
    metavar,
    option,
    progDesc,
    short,
    showDefault,
    strOption,
    switch,
    value,
  )
import System.Exit (exitSuccess)
import System.FilePath ((</>))
import System.IO.Unsafe (unsafePerformIO)
import Text.Read (readMaybe)
import UnliftIO (MonadIO)
import UnliftIO.Directory
  ( createDirectoryIfMissing,
    getAppUserDataDirectory,
  )
import UnliftIO.Environment (lookupEnv)

version :: String

#ifdef CURRENT_PACKAGE_VERSION
version = CURRENT_PACKAGE_VERSION
#else
version = "Unavailable"
#endif

data Config = Config
  { configDir :: !FilePath,
    configHost :: !String,
    configPort :: !Int,
    configNetwork :: !String,
    configDiscover :: !Bool,
    configPeers :: ![(String, Maybe Int)],
    configVersion :: !Bool,
    configDebug :: !Bool,
    configMaxPending :: !Int,
    configWebLimits :: !WebLimits,
    configWebTimeouts :: !WebTimeouts,
    configRedis :: !Bool,
    configRedisURL :: !String,
    configRedisMin :: !Int,
    configRedisMax :: !Integer,
    configWipeMempool :: !Bool,
    configNoMempool :: !Bool,
    configSyncMempool :: !Bool,
    configPeerTimeout :: !Int,
    configPeerMaxLife :: !Int,
    configMaxPeers :: !Int,
    configMaxDiff :: !Int,
    configCacheRetryDelay :: !Int,
    configStatsd :: !Bool,
    configStatsdHost :: !String,
    configStatsdPort :: !Int,
    configStatsdPrefix :: !String,
    configWebPriceGet :: !Int,
    configWebTickerURL :: !String,
    configWebHistoryURL :: !String,
    configWebNoBlockchain :: !Bool,
    configWebNoSlow :: !Bool
  }

instance Default Config where
  def =
    Config
      { configDir = defDirectory,
        configHost = defHost,
        configPort = defPort,
        configNetwork = defNetwork,
        configDiscover = defDiscover,
        configPeers = defPeers,
        configVersion = False,
        configDebug = defDebug,
        configMaxPending = defMaxPending,
        configWebLimits = defWebLimits,
        configWebTimeouts = defWebTimeouts,
        configRedis = defRedis,
        configRedisURL = defRedisURL,
        configRedisMin = defRedisMin,
        configRedisMax = defRedisMax,
        configWipeMempool = defWipeMempool,
        configNoMempool = defNoMempool,
        configSyncMempool = defSyncMempool,
        configPeerTimeout = defPeerTimeout,
        configPeerMaxLife = defPeerMaxLife,
        configMaxPeers = defMaxPeers,
        configMaxDiff = defMaxDiff,
        configCacheRetryDelay = defCacheRetryDelay,
        configStatsd = defStatsd,
        configStatsdHost = defStatsdHost,
        configStatsdPort = defStatsdPort,
        configStatsdPrefix = defStatsdPrefix,
        configWebPriceGet = defWebPriceGet,
        configWebTickerURL = defWebTickerURL,
        configWebHistoryURL = defWebHistoryURL,
        configWebNoBlockchain = defWebNoBlockchain,
        configWebNoSlow = defWebNoSlow
      }

defEnv :: MonadIO m => String -> a -> (String -> Maybe a) -> m a
defEnv e d p = do
  ms <- lookupEnv e
  return $ fromMaybe d $ p =<< ms

defCacheRetryDelay :: Int
defCacheRetryDelay =
  unsafePerformIO $
    defEnv "CACHE_RETRY_DELAY" 100000 readMaybe
{-# NOINLINE defCacheRetryDelay #-}

defMaxPending :: Int
defMaxPending =
  unsafePerformIO $
    defEnv "MAX_PENDING_TXS" 100 readMaybe
{-# NOINLINE defMaxPending #-}

defMaxPeers :: Int
defMaxPeers =
  unsafePerformIO $
    defEnv "MAX_PEERS" 20 readMaybe
{-# NOINLINE defMaxPeers #-}

defDirectory :: FilePath
defDirectory = unsafePerformIO $ do
  d <- getAppUserDataDirectory "haskoin-store"
  defEnv "DIR" d pure
{-# NOINLINE defDirectory #-}

defHost :: String
defHost =
  unsafePerformIO $
    defEnv "HOST" "*" pure
{-# NOINLINE defHost #-}

defPort :: Int
defPort =
  unsafePerformIO $
    defEnv "PORT" 3000 readMaybe
{-# NOINLINE defPort #-}

defNetwork :: String
defNetwork =
  unsafePerformIO $
    defEnv "NET" "bch" pure
{-# NOINLINE defNetwork #-}

defRedisMin :: Int
defRedisMin =
  unsafePerformIO $
    defEnv "CACHE_MIN" 100 readMaybe
{-# NOINLINE defRedisMin #-}

defRedis :: Bool
defRedis =
  unsafePerformIO $
    defEnv "CACHE" False parseBool
{-# NOINLINE defRedis #-}

defSyncMempool :: Bool
defSyncMempool =
  unsafePerformIO $
    defEnv "SYNC_MEMPOOL" False parseBool
{-# NOINLINE defSyncMempool #-}

defDiscover :: Bool
defDiscover =
  unsafePerformIO $
    defEnv "DISCOVER" False parseBool
{-# NOINLINE defDiscover #-}

defPeers :: [(String, Maybe Int)]
defPeers =
  unsafePerformIO $
    defEnv "PEER" [] (mapM (eitherToMaybe . peerReader) . words)
{-# NOINLINE defPeers #-}

defDebug :: Bool
defDebug =
  unsafePerformIO $
    defEnv "DEBUG" False parseBool
{-# NOINLINE defDebug #-}

defWebLimits :: WebLimits
defWebLimits = unsafePerformIO $ do
  max_limit <- defEnv "MAX_LIMIT" (maxLimitCount def) readMaybe
  max_full <- defEnv "MAX_FULL" (maxLimitFull def) readMaybe
  max_offset <- defEnv "MAX_OFFSET" (maxLimitOffset def) readMaybe
  def_limit <- defEnv "DEF_LIMIT" (maxLimitDefault def) readMaybe
  max_gap <- defEnv "MAX_GAP" (maxLimitGap def) readMaybe
  init_gap <- defEnv "INIT_GAP" (maxLimitInitialGap def) readMaybe
  max_body <- defEnv "MAX_BODY" (maxLimitBody def) readMaybe
  max_timeout <- defEnv "MAX_TIMEOUT" (maxLimitTimeout def) readMaybe
  return
    WebLimits
      { maxLimitCount = max_limit,
        maxLimitFull = max_full,
        maxLimitOffset = max_offset,
        maxLimitDefault = def_limit,
        maxLimitGap = max_gap,
        maxLimitInitialGap = init_gap,
        maxLimitBody = max_body,
        maxLimitTimeout = max_timeout
      }
{-# NOINLINE defWebLimits #-}

defWebNoBlockchain :: Bool
defWebNoBlockchain =
  unsafePerformIO $
    defEnv "NO_BLOCKCHAIN" False parseBool
{-# NOINLINE defWebNoBlockchain #-}

defWebNoSlow :: Bool
defWebNoSlow =
  unsafePerformIO $
    defEnv "NO_SLOW" False parseBool
{-# NOINLINE defWebNoSlow #-}

defWebTimeouts :: WebTimeouts
defWebTimeouts = unsafePerformIO $ do
  block_timeout <- defEnv "BLOCK_TIMEOUT" (blockTimeout def) readMaybe
  tx_timeout <- defEnv "TX_TIMEOUT" (txTimeout def) readMaybe
  return
    WebTimeouts
      { txTimeout = tx_timeout,
        blockTimeout = block_timeout
      }
{-# NOINLINE defWebTimeouts #-}

defWipeMempool :: Bool
defWipeMempool =
  unsafePerformIO $
    defEnv "WIPE_MEMPOOL" False parseBool
{-# NOINLINE defWipeMempool #-}

defNoMempool :: Bool
defNoMempool =
  unsafePerformIO $
    defEnv "NO_MEMPOOL" False parseBool
{-# NOINLINE defNoMempool #-}

defRedisURL :: String
defRedisURL =
  unsafePerformIO $
    defEnv "REDIS" "" pure
{-# NOINLINE defRedisURL #-}

defRedisMax :: Integer
defRedisMax =
  unsafePerformIO $
    defEnv "CACHE_KEYS" 100000000 readMaybe
{-# NOINLINE defRedisMax #-}

defPeerTimeout :: Int
defPeerTimeout =
  unsafePerformIO $
    defEnv "PEER_TIMEOUT" 120 readMaybe
{-# NOINLINE defPeerTimeout #-}

defPeerMaxLife :: Int
defPeerMaxLife =
  unsafePerformIO $
    defEnv "PEER_MAX_LIFE" (48 * 3600) readMaybe
{-# NOINLINE defPeerMaxLife #-}

defMaxDiff :: Int
defMaxDiff =
  unsafePerformIO $
    defEnv "MAX_DIFF" 2 readMaybe
{-# NOINLINE defMaxDiff #-}

defStatsd :: Bool
defStatsd =
  unsafePerformIO $
    defEnv "STATSD" False parseBool
{-# NOINLINE defStatsd #-}

defStatsdHost :: String
defStatsdHost =
  unsafePerformIO $
    defEnv "STATSD_HOST" "localhost" pure
{-# NOINLINE defStatsdHost #-}

defStatsdPort :: Int
defStatsdPort =
  unsafePerformIO $
    defEnv "STATSD_PORT" 8125 readMaybe
{-# NOINLINE defStatsdPort #-}

defWebPriceGet :: Int
defWebPriceGet =
  unsafePerformIO $
    defEnv "WEB_PRICE_GET" (90 * 1000 * 1000) readMaybe
{-# NOINLINE defWebPriceGet #-}

defWebTickerURL :: String
defWebTickerURL =
  unsafePerformIO $
    defEnv "PRICE_TICKER_URL" "https://api.blockchain.info/ticker" pure
{-# NOINLINE defWebTickerURL #-}

defWebHistoryURL :: String
defWebHistoryURL =
  unsafePerformIO $
    defEnv "PRICE_HISTORY_URL" "https://api.blockchain.info/price/index-series" pure
{-# NOINLINE defWebHistoryURL #-}

defStatsdPrefix :: String
defStatsdPrefix =
  unsafePerformIO $
    runMaybeT go >>= \case
      Nothing -> return "haskoin_store"
      Just x -> return x
  where
    go = prefix <|> nomad
    prefix = MaybeT $ lookupEnv "STATSD_PREFIX"
    nomad = do
      task <- MaybeT $ lookupEnv "NOMAD_TASK_NAME"
      service <- MaybeT $ lookupEnv "NOMAD_ALLOC_INDEX"
      return $ "app." <> task <> "." <> service
{-# NOINLINE defStatsdPrefix #-}

netNames :: String
netNames = intercalate "|" (map getNetworkName allNets)

parseBool :: String -> Maybe Bool
parseBool str = case map toLower str of
  "yes" -> Just True
  "true" -> Just True
  "on" -> Just True
  "1" -> Just True
  "no" -> Just False
  "false" -> Just False
  "off" -> Just False
  "0" -> Just False
  _ -> Nothing

config :: Parser Config
config = do
  configDir <-
    strOption $
      metavar "PATH"
        <> long "dir"
        <> short 'd'
        <> help "Data directory"
        <> showDefault
        <> value (configDir def)
  configHost <-
    strOption $
      metavar "HOST"
        <> long "host"
        <> help "Host to bind"
        <> showDefault
        <> value (configHost def)
  configPort <-
    option auto $
      metavar "INT"
        <> long "port"
        <> help "REST API listening port"
        <> showDefault
        <> value (configPort def)
  configNetwork <-
    strOption $
      metavar netNames
        <> long "net"
        <> short 'n'
        <> help "Network to connect to"
        <> showDefault
        <> value (configNetwork def)
  configDiscover <-
    flag (configDiscover def) True $
      long "discover"
        <> help "Peer discovery"
  configPeers <-
    fmap (mappend defPeers) $
      many $
        option (eitherReader peerReader) $
          metavar "HOST"
            <> long "peer"
            <> short 'p'
            <> help "Network peer (as many as required)"
  configMaxPeers <-
    option auto $
      metavar "INT"
        <> long "max-peers"
        <> help "Do not connect to more than this many peers"
        <> showDefault
        <> value (configMaxPeers def)
  configVersion <-
    switch $
      long "version"
        <> short 'v'
        <> help "Show version"
  configDebug <-
    flag (configDebug def) True $
      long "debug"
        <> help "Show debug messages"
  maxLimitCount <-
    option auto $
      metavar "INT"
        <> long "max-limit"
        <> help "Hard limit for simple listings (0 = inf)"
        <> showDefault
        <> value (maxLimitCount (configWebLimits def))
  maxLimitFull <-
    option auto $
      metavar "INT"
        <> long "max-full"
        <> help "Hard limit for full listings (0 = inf)"
        <> showDefault
        <> value (maxLimitFull (configWebLimits def))
  maxLimitOffset <-
    option auto $
      metavar "INT"
        <> long "max-offset"
        <> help "Hard limit for offsets (0 = inf)"
        <> showDefault
        <> value (maxLimitOffset (configWebLimits def))
  maxLimitDefault <-
    option auto $
      metavar "INT"
        <> long "def-limit"
        <> help "Soft default limit (0 = inf)"
        <> showDefault
        <> value (maxLimitDefault (configWebLimits def))
  maxLimitGap <-
    option auto $
      metavar "INT"
        <> long "max-gap"
        <> help "Max gap for xpub queries"
        <> showDefault
        <> value (maxLimitGap (configWebLimits def))
  maxLimitInitialGap <-
    option auto $
      metavar "INT"
        <> long "init-gap"
        <> help "Max gap for empty xpub"
        <> showDefault
        <> value (maxLimitInitialGap (configWebLimits def))
  maxLimitBody <-
    option auto $
      metavar "BYTES"
        <> long "max-body"
        <> help "Maximum request body size"
        <> showDefault
        <> value (maxLimitBody (configWebLimits def))
  maxLimitTimeout <-
    option auto $
      metavar "SECONDS"
        <> long "max-timeout"
        <> help "Web request timeout"
        <> showDefault
        <> value (maxLimitTimeout (configWebLimits def))
  blockTimeout <-
    option auto $
      metavar "SECONDS"
        <> long "block-timeout"
        <> help "Last block mined health timeout"
        <> showDefault
        <> value (blockTimeout (configWebTimeouts def))
  txTimeout <-
    option auto $
      metavar "SECONDS"
        <> long "tx-timeout"
        <> help "Last tx recived health timeout"
        <> showDefault
        <> value (txTimeout (configWebTimeouts def))
  configPeerTimeout <-
    option auto $
      metavar "SECONDS"
        <> long "peer-timeout"
        <> help "Unresponsive peer timeout"
        <> showDefault
        <> value (configPeerTimeout def)
  configPeerMaxLife <-
    option auto $
      metavar "SECONDS"
        <> long "peer-max-life"
        <> help "Disconnect peers older than this"
        <> showDefault
        <> value (configPeerMaxLife def)
  configMaxPending <-
    option auto $
      metavar "INT"
        <> long "max-pending-txs"
        <> help "Maximum pending txs to fail health check"
        <> showDefault
        <> value (configMaxPending def)
  configRedis <-
    flag (configRedis def) True $
      long "cache"
        <> help "Redis cache for extended public keys"
  configRedisURL <-
    strOption $
      metavar "URL"
        <> long "redis"
        <> help "URL for Redis cache"
        <> value (configRedisURL def)
  configRedisMin <-
    option auto $
      metavar "INT"
        <> long "cache-min"
        <> help "Minimum used xpub addresses to cache"
        <> showDefault
        <> value (configRedisMin def)
  configRedisMax <-
    option auto $
      metavar "INT"
        <> long "cache-keys"
        <> help "Maximum number of keys in Redis xpub cache"
        <> showDefault
        <> value (configRedisMax def)
  configCacheRetryDelay <-
    option auto $
      metavar "MICROSECONDS"
        <> long "cache-retry-delay"
        <> help "Delay to retry getting cache lock to index xpub"
        <> showDefault
        <> value (configCacheRetryDelay def)
  configNoMempool <-
    flag (configNoMempool def) True $
      long "no-mempool"
        <> help "Do not index new mempool transactions"
  configWipeMempool <-
    flag (configWipeMempool def) True $
      long "wipe-mempool"
        <> help "Wipe mempool at start"
  configSyncMempool <-
    flag (configSyncMempool def) True $
      long "sync-mempool"
        <> help "Sync mempool from peers"
  configMaxDiff <-
    option auto $
      metavar "INT"
        <> long "max-diff"
        <> help "Maximum difference between headers and blocks"
        <> showDefault
        <> value (configMaxDiff def)
  configStatsd <-
    flag (configStatsd def) True $
      long "statsd"
        <> help "Enable statsd metrics"
  configStatsdHost <-
    strOption $
      metavar "HOST"
        <> long "statsd-host"
        <> help "Host to send statsd metrics"
        <> showDefault
        <> value (configStatsdHost def)
  configStatsdPort <-
    option auto $
      metavar "PORT"
        <> long "statsd-port"
        <> help "Port to send statsd metrics"
        <> showDefault
        <> value (configStatsdPort def)
  configStatsdPrefix <-
    strOption $
      metavar "PREFIX"
        <> long "statsd-prefix"
        <> help "Prefix for statsd metrics"
        <> showDefault
        <> value (configStatsdPrefix def)
  configWebPriceGet <-
    option auto $
      metavar "MICROSECONDS"
        <> long "web-price-get"
        <> help "How often to retrieve price information"
        <> showDefault
        <> value (configWebPriceGet def)
  configWebNoBlockchain <-
    flag (configWebNoBlockchain def) False $
      long "no-blockchain"
        <> help "Disable Blockchain.info compatibility layer"
  configWebTickerURL <-
    strOption $
      metavar "URL"
        <> long "price-ticker-url"
        <> help "Blockchain.info price ticker URL"
        <> showDefault
        <> value (configWebTickerURL def)
  configWebHistoryURL <-
    strOption $
      metavar "URL"
        <> long "price-history-url"
        <> help "Blockchain.info price history URL"
        <> showDefault
        <> value (configWebHistoryURL def)
  configWebNoSlow <-
    flag (configWebNoSlow def) False $
      long "no-slow"
        <> help "Disable non-scalable API calls (recommend also --no-blockchain)"
  pure
    Config
      { configWebLimits = WebLimits {..},
        configWebTimeouts = WebTimeouts {..},
        ..
      }

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 bchTest4 = Right bchTest4
  | s == getNetworkName bchRegTest = Right bchRegTest
  | otherwise = Left "Network name invalid"

peerReader :: String -> Either String (String, Maybe Int)
peerReader 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)

main :: IO ()
main = do
  conf <- execParser opts
  when (configVersion conf) $ do
    putStrLn version
    exitSuccess
  if null (configPeers conf) && not (configDiscover conf)
    then run conf {configDiscover = True}
    else run conf
  where
    opts =
      info (helper <*> config) $
        fullDesc
          <> progDesc "Bitcoin (BCH & BTC) block chain index with HTTP API"
          <> Options.Applicative.header
            ("haskoin-store version " <> version)

run :: Config -> IO ()
run
  Config
    { configHost = host,
      configPort = port,
      configNetwork = net_str,
      configDiscover = disc,
      configPeers = peers,
      configDir = db_dir,
      configDebug = deb,
      configMaxPending = pend,
      configWebLimits = limits,
      configWebTimeouts = tos,
      configRedis = redis,
      configRedisURL = redisurl,
      configRedisMin = cachemin,
      configRedisMax = redismax,
      configWipeMempool = wipemempool,
      configPeerTimeout = peertimeout,
      configPeerMaxLife = peerlife,
      configMaxPeers = maxpeers,
      configMaxDiff = maxdiff,
      configNoMempool = nomem,
      configSyncMempool = syncmem,
      configCacheRetryDelay = cretrydelay,
      configStatsd = statsd,
      configStatsdHost = statsdhost,
      configStatsdPort = statsdport,
      configStatsdPrefix = statsdpfx,
      configWebPriceGet = wpget,
      configWebTickerURL = wturl,
      configWebHistoryURL = whurl,
      configWebNoSlow = no_slow,
      configWebNoBlockchain = no_blockchain
    } =
    runStderrLoggingT . filterLogger l . with_stats $ \stats -> do
      net <- case networkReader net_str of
        Right n -> return n
        Left e -> error e
      $(logInfoS) "Main" $
        "Creating working directory if not found: " <> cs (wd net)
      createDirectoryIfMissing True (wd net)
      let scfg =
            StoreConfig
              { storeConfMaxPeers = maxpeers,
                storeConfInitPeers =
                  map (second (fromMaybe (getDefaultPort net))) peers,
                storeConfDiscover = disc,
                storeConfDB = wd net </> "db",
                storeConfNetwork = net,
                storeConfCache =
                  if redis
                    then Just redisurl
                    else Nothing,
                storeConfGap = maxLimitGap limits,
                storeConfInitialGap = maxLimitInitialGap limits,
                storeConfCacheMin = cachemin,
                storeConfMaxKeys = redismax,
                storeConfWipeMempool = wipemempool,
                storeConfNoMempool = nomem,
                storeConfSyncMempool = syncmem,
                storeConfPeerTimeout = fromIntegral peertimeout,
                storeConfPeerMaxLife = fromIntegral peerlife,
                storeConfConnect = withConnection,
                storeConfCacheRetryDelay = cretrydelay,
                storeConfStats = stats
              }
      withStore scfg $ \st ->
        runWeb
          WebConfig
            { webHost = host,
              webPort = port,
              webStore = st,
              webMaxLimits = limits,
              webTimeouts = tos,
              webMaxPending = pend,
              webVersion = version,
              webMaxDiff = maxdiff,
              webNoMempool = nomem,
              webStats = stats,
              webPriceGet = wpget,
              webTickerURL = wturl,
              webHistoryURL = whurl,
              webSlow = not no_slow,
              webBlockchain = not no_blockchain
            }
    where
      with_stats go
        | statsd = do
          $(logInfoS) "Main" $
            "Sending stats to " <> T.pack statsdhost
              <> ":"
              <> cs (show statsdport)
              <> " with prefix: "
              <> T.pack statsdpfx
          withStats
            (T.pack statsdhost)
            statsdport
            (T.pack statsdpfx)
            (go . Just)
        | otherwise = go Nothing
      l _ lvl
        | deb = True
        | otherwise = LevelInfo <= lvl
      wd net = db_dir </> getNetworkName net