module Network.Haskoin.Wallet.Settings
( SPVMode(..)
, OutputFormat(..)
, Config(..)
) where
import Control.Monad (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, unionWith)
import Data.String.Conversions (cs)
import Data.ByteString (ByteString)
import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8)
import Data.Aeson
( Value(..), FromJSON, ToJSON
, parseJSON, toJSON, withObject
, (.:)
)
import Network.Haskoin.Crypto
import Network.Haskoin.Wallet.Database
import Network.Haskoin.Wallet.Types
import Data.Restricted (Restricted, Div5)
import System.ZMQ4 (toRestricted)
data SPVMode = SPVOnline | SPVOffline
deriving (Eq, Show, Read)
newtype LogLevelJSON = LogLevelJSON LogLevel
deriving (Eq, Show, Read)
data OutputFormat
= OutputNormal
| OutputJSON
| OutputYAML
data Config = Config
{ configCount :: !Word32
, configMinConf :: !Word32
, configSignTx :: !Bool
, configFee :: !Word64
, configRcptFee :: !Bool
, configAddrType :: !AddressType
, configOffline :: !Bool
, configReversePaging :: !Bool
, configPath :: !(Maybe HardPath)
, configFormat :: !OutputFormat
, configConnect :: !String
, configConnectNotif :: !String
, configDetach :: !Bool
, configFile :: !FilePath
, configTestnet :: !Bool
, configDir :: !FilePath
, configBind :: !String
, configBindNotif :: !String
, configBTCNodes :: !(HashMap Text [BTCNode])
, configMode :: !SPVMode
, configBloomFP :: !Double
, configDatabase :: !(HashMap Text DatabaseConfType)
, configLogFile :: !FilePath
, configPidFile :: !FilePath
, configLogLevel :: !LogLevel
, configVerbose :: !Bool
, configServerKey :: !(Maybe (Restricted Div5 ByteString))
, configServerKeyPub :: !(Maybe (Restricted Div5 ByteString))
, configClientKey :: !(Maybe (Restricted Div5 ByteString))
, configClientKeyPub :: !(Maybe (Restricted Div5 ByteString))
}
configBS :: ByteString
configBS = $(embedFile "config/config.yml")
instance ToJSON OutputFormat where
toJSON OutputNormal = String "normal"
toJSON OutputJSON = String "json"
toJSON OutputYAML = String "yaml"
instance FromJSON OutputFormat where
parseJSON (String "normal") = return OutputNormal
parseJSON (String "json") = return OutputJSON
parseJSON (String "yaml") = return OutputYAML
parseJSON _ = mzero
instance ToJSON SPVMode where
toJSON SPVOnline = String "online"
toJSON SPVOffline = String "offline"
instance FromJSON SPVMode where
parseJSON (String "online") = return SPVOnline
parseJSON (String "offline") = return SPVOffline
parseJSON _ = mzero
instance ToJSON LogLevelJSON where
toJSON (LogLevelJSON LevelDebug) = String "debug"
toJSON (LogLevelJSON LevelInfo) = String "info"
toJSON (LogLevelJSON LevelWarn) = String "warn"
toJSON (LogLevelJSON LevelError) = String "error"
toJSON (LogLevelJSON (LevelOther t)) = String t
instance FromJSON LogLevelJSON where
parseJSON (String "debug") = return $ LogLevelJSON LevelDebug
parseJSON (String "info") = return $ LogLevelJSON LevelInfo
parseJSON (String "warn") = return $ LogLevelJSON LevelWarn
parseJSON (String "error") = return $ LogLevelJSON LevelError
parseJSON (String x) = return $ LogLevelJSON (LevelOther x)
parseJSON _ = mzero
instance Default Config where
def = either throw id $ decodeEither' "{}"
instance FromJSON Config where
parseJSON = withObject "config" $ \o' -> do
let defValue = either throw id $ decodeEither' configBS
(Object o) = mergeValues defValue (Object o')
configPath = Nothing
configFile <- o .: "config-file"
configRcptFee <- o .: "recipient-fee"
configCount <- o .: "output-size"
configMinConf <- o .: "minimum-confirmations"
configSignTx <- o .: "sign-transactions"
configFee <- o .: "transaction-fee"
configAddrType <- o .: "address-type"
configOffline <- o .: "offline"
configReversePaging <- o .: "reverse-paging"
configFormat <- o .: "display-format"
configConnect <- o .: "connect-uri"
configConnectNotif <- o .: "connect-uri-notif"
configDetach <- o .: "detach-server"
configTestnet <- o .: "use-testnet"
configDir <- o .: "work-dir"
configBind <- o .: "bind-socket"
configBindNotif <- o .: "bind-socket-notif"
configBTCNodes <- o .: "bitcoin-full-nodes"
configMode <- o .: "server-mode"
configBloomFP <- o .: "bloom-false-positive"
configLogFile <- o .: "log-file"
configPidFile <- o .: "pid-file"
LogLevelJSON configLogLevel <- o .: "log-level"
configVerbose <- o .: "verbose"
configDatabase <- o .: "database"
configServerKey <- getKey o "server-key"
configServerKeyPub <- getKey o "server-key-public"
configClientKey <- getKey o "client-key"
configClientKeyPub <- getKey o "client-key-public"
return Config {..}
where
getKey o i = o .: i >>= \kM ->
case kM of
Nothing -> return Nothing
Just k ->
case toRestricted $ encodeUtf8 k of
Just k' -> return $ Just k'
Nothing -> fail $ "Invalid " ++ cs k
mergeValues :: Value -> Value -> Value
mergeValues (Object d) (Object c) = Object (unionWith mergeValues d c)
mergeValues _ c = c