Settings.hs

module Network.Haskoin.Wallet.Settings
( SPVMode(..)
, OutputFormat(..)
, Config(..)
) where

import Control.Monad (forM, mzero)
import Control.Exception (throw)
import Control.Monad.Logger (LogLevel(..))

import Data.Default (Default, def)
import Data.FileEmbed (embedFile)
import Data.Yaml (decodeEither')
import Data.Word (Word32, Word64)
import Data.HashMap.Strict (HashMap)
import qualified Data.Traversable as V (mapM)
import qualified Data.ByteString as BS (ByteString)
import qualified Data.Text as T (Text)
import Data.Aeson
    ( Value(..)
    , FromJSON
    , parseJSON
    , withObject
    , (.:), (.:?), (.!=)
    )

import Network.Haskoin.Wallet.Database
import Network.Haskoin.Wallet.Types

data SPVMode = SPVOnline | SPVOffline
    deriving (Eq, Show, Read)

data OutputFormat
    = OutputNormal
    | OutputJSON
    | OutputYAML

data Config = Config
    { configKeyRing       :: !T.Text
    -- ^ Keyring to use in commands
    , configCount         :: !Word32
    -- ^ Output size of commands
    , configMinConf       :: !Word32
    -- ^ Minimum number of confirmations
    , configSignTx        :: !Bool
    -- ^ Sign transactions
    , configFee           :: !Word64
    -- ^ Fee to pay per 1000 bytes when creating new transactions
    , configRcptFee       :: !Bool
    -- ^ Recipient pays fee (dangerous, no config file setting)
    , configAddrType      :: !AddressType
    -- ^ Return internal instead of external addresses
    , configOffline       :: !Bool
    -- ^ Display the balance including offline transactions
    , configReversePaging :: !Bool
    -- ^ Use reverse paging for displaying addresses and transactions
    , configPass          :: !(Maybe T.Text)
    -- ^ Passphrase to use when creating new keyrings (bip39 mnemonic)
    , configFormat        :: !OutputFormat
    -- ^ How to format the command-line results
    , configConnect       :: !String
    -- ^ ZeroMQ socket to connect to (location of the server)
    , configDetach        :: !Bool
    -- ^ Detach server when launched from command-line
    , configFile          :: !FilePath
    -- ^ Configuration file
    , configTestnet       :: !Bool
    -- ^ Use Testnet3 network
    , configDir           :: !FilePath
    -- ^ Working directory
    , configBind          :: !String
    -- ^ Bind address for the zeromq socket
    , configBTCNodes      :: !(HashMap T.Text [(String, Int)])
    -- ^ Trusted Bitcoin full nodes to connect to
    , configMode          :: !SPVMode
    -- ^ Operation mode of the SPV node.
    , configBloomFP       :: !Double
    -- ^ False positive rate for the bloom filter.
    , configDatabase      :: !(HashMap T.Text DatabaseConfType)
    -- ^ Database configuration
    , configLogFile       :: !FilePath
    -- ^ Log file
    , configPidFile       :: !FilePath
    -- ^ PID File
    , configLogLevel      :: !LogLevel
    -- ^ Log level
    , configVerbose       :: !Bool
    -- ^ Verbose
    }

configBS :: BS.ByteString
configBS = $(embedFile "config/config.yml")

instance Default Config where
    def = either throw id $ decodeEither' configBS

instance FromJSON Config where
    parseJSON = withObject "Config" $ \o -> do
        let configRcptFee    = False
            configFile       = "config.yml"
            configPass       = Nothing
        configKeyRing        <- o .:? "keyring-name"
                                  .!= configKeyRing def
        configCount          <- o .:? "output-size"
                                  .!= configCount def
        configMinConf        <- o .:? "minimum-confirmations"
                                  .!= configMinConf def
        configSignTx         <- o .:? "sign-transactions"
                                  .!= configSignTx def
        configFee            <- o .:? "transaction-fee"
                                  .!= configFee def
        configAddrType <- k =<< o .:? "address-type"
        configOffline        <- o .:? "offline"
                                  .!= configOffline def
        configReversePaging  <- o .:? "reverse-paging"
                                  .!= configReversePaging def
        configFormat   <- f =<< o .:? "display-format"
        configConnect        <- o .:? "connect-uri"
                                  .!= configConnect def
        configDetach         <- o .:? "detach-server"
                                  .!= configDetach def
        configTestnet        <- o .:? "use-testnet"
                                  .!= configTestnet def
        configDir            <- o .:? "work-dir"
                                  .!= configDir def
        configBind           <- o .:? "bind-socket"
                                  .!= configBind def
        configBTCNodes <- g =<< o .:? "bitcoin-full-nodes"
        configMode     <- h =<< o .:? "server-mode"
        configBloomFP        <- o .:? "bloom-false-positive"
                                  .!= configBloomFP def
        configDatabase <- i =<< o .:? "database"
        configLogFile        <- o .:? "log-file"
                                  .!= configLogFile def
        configPidFile        <- o .:? "pid-file"
                                  .!= configPidFile def
        configLogLevel <- j =<< o .:? "log-level"
        configVerbose        <- o .:? "verbose"
                                  .!= configVerbose def
        return Config {..}
      where
        f format = case format of
            Just (String "normal") -> return OutputNormal
            Just (String "json")   -> return OutputJSON
            Just (String "yaml")   -> return OutputYAML
            Just _                 -> mzero
            Nothing                -> return $ configFormat def
        g (Just x) = flip (withObject "btcnodesobj") x $ V.mapM $ \a -> do
            ls <- parseJSON a
            forM ls $ withObject "bitcoinnode" $ \o ->
                (,) <$> (o .: "host") <*> (o .: "port")
        g Nothing = return $ configBTCNodes def
        h mode = case mode of
            Just (String "online")  -> return SPVOnline
            Just (String "offline") -> return SPVOffline
            Just _                  -> mzero
            Nothing                 -> return $ configMode def
        i (Just x) = flip (withObject "databases") x $ V.mapM .
            withObject "database" $ \v -> v .: databaseEngine
        i Nothing = return $ configDatabase def
        j level = case level of
            Just (String "debug") -> return LevelDebug
            Just (String "info")  -> return LevelInfo
            Just (String "warn")  -> return LevelWarn
            Just (String "error") -> return LevelError
            Just _                -> mzero
            Nothing               -> return $ configLogLevel def
        k addrtype = case addrtype of
            Just (String "internal") -> return AddressInternal
            Just (String "external") -> return AddressExternal
            Just _                   -> mzero
            Nothing                  -> return $ configAddrType def