Skip to content

Commit

Permalink
Configuration merges with default
Browse files Browse the repository at this point in the history
  • Loading branch information
Jean-Pierre Rupp committed Dec 30, 2015
1 parent 1547dc1 commit 463a561
Show file tree
Hide file tree
Showing 2 changed files with 56 additions and 74 deletions.
125 changes: 51 additions & 74 deletions haskoin-wallet/Network/Haskoin/Wallet/Settings.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -12,17 +12,11 @@ import Data.Default (Default, def)
import Data.FileEmbed (embedFile)
import Data.Yaml (decodeEither')
import Data.Word (Word32, Word64)
import Data.HashMap.Strict (HashMap)
import Data.HashMap.Strict (HashMap, unionWith)
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 Data.Aeson (Value(..), FromJSON, parseJSON, withObject, (.:))

import Network.Haskoin.Wallet.Database
import Network.Haskoin.Wallet.Types
Expand Down Expand Up @@ -92,82 +86,65 @@ configBS :: BS.ByteString
configBS = $(embedFile "config/config.yml")

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

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
parseJSON = withObject "config" $ \o' -> do
let defValue = either throw id $ decodeEither' configBS
(Object o) = mergeValues defValue (Object o')
configPass = Nothing -- Command-line only setting
configFile <- o .: "config-file" -- Command-line or compile-time only
configRcptFee <- o .: "recipient-fee"
configKeyRing <- o .: "keyring-name"
configCount <- o .: "output-size"
configMinConf <- o .: "minimum-confirmations"
configSignTx <- o .: "sign-transactions"
configFee <- o .: "transaction-fee"
configAddrType <- k =<< o .: "address-type"
configOffline <- o .: "offline"
configReversePaging <- o .: "reverse-paging"
configFormat <- f =<< o .: "display-format"
configConnect <- o .: "connect-uri"
configDetach <- o .: "detach-server"
configTestnet <- o .: "use-testnet"
configDir <- o .: "work-dir"
configBind <- o .: "bind-socket"
configBTCNodes <- g =<< o .: "bitcoin-full-nodes"
configMode <- h =<< o .: "server-mode"
configBloomFP <- o .: "bloom-false-positive"
configDatabase <- i =<< o .: "database"
configLogFile <- o .: "log-file"
configPidFile <- o .: "pid-file"
configLogLevel <- j =<< o .: "log-level"
configVerbose <- o .: "verbose"
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
String "normal" -> return OutputNormal
String "json" -> return OutputJSON
String "yaml" -> return OutputYAML
_ -> mzero
g 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 .
String "online" -> return SPVOnline
String "offline" -> return SPVOffline
_ -> mzero
i 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
String "debug" -> return LevelDebug
String "info" -> return LevelInfo
String "warn" -> return LevelWarn
String "error" -> return LevelError
_ -> mzero
k addrtype = case addrtype of
Just (String "internal") -> return AddressInternal
Just (String "external") -> return AddressExternal
Just _ -> mzero
Nothing -> return $ configAddrType def
String "internal" -> return AddressInternal
String "external" -> return AddressExternal
_ -> mzero

mergeValues :: Value -> Value -> Value
mergeValues (Object d) (Object c) = Object (unionWith mergeValues d c)
mergeValues _ c = c
5 changes: 5 additions & 0 deletions haskoin-wallet/config/config.yml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -118,3 +118,8 @@ log-level: info
# Print verbose
verbose: false

# Recipient pays transaction fee. DANGEROUS.
recipient-fee: false

# Configuration file name. Only set at compile time.
config-file: config.yml

0 comments on commit 463a561

Please sign in to comment.