{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Network.ZRE.Config where

import System.Environment
import System.Directory
import System.FilePath.Posix
import qualified Data.ByteString.Char8 as B

import Network.ZRE.Types

import Data.Default (def)
import qualified Data.Either
import qualified Data.Foldable

import Options.Applicative
import Network.ZRE.Options

import qualified Data.Text
import qualified Data.Attoparsec.Text

trueStr :: Data.Attoparsec.Text.Parser Bool
trueStr :: Parser Bool
trueStr = Bool -> Text -> Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True (Text -> Bool) -> Parser Text Text -> Parser Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (
    [Parser Text Text] -> Parser Text Text
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
Data.Foldable.asum
  ([Parser Text Text] -> Parser Text Text)
-> ([Text] -> [Parser Text Text]) -> [Text] -> Parser Text Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Parser Text Text) -> [Text] -> [Parser Text Text]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Parser Text Text
Data.Attoparsec.Text.string ([Text] -> Parser Text Text) -> [Text] -> Parser Text Text
forall a b. (a -> b) -> a -> b
$ [ Text
"true", Text
"t", Text
"yes", Text
"y" ]
  )

falseStr :: Data.Attoparsec.Text.Parser Bool
falseStr :: Parser Bool
falseStr =  Bool -> Text -> Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False (Text -> Bool) -> Parser Text Text -> Parser Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (
    [Parser Text Text] -> Parser Text Text
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
Data.Foldable.asum
  ([Parser Text Text] -> Parser Text Text)
-> ([Text] -> [Parser Text Text]) -> [Text] -> Parser Text Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Parser Text Text) -> [Text] -> [Parser Text Text]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Parser Text Text
Data.Attoparsec.Text.string ([Text] -> Parser Text Text) -> [Text] -> Parser Text Text
forall a b. (a -> b) -> a -> b
$ [ Text
"false" , Text
"f" , Text
"no" , Text
"n" ]
  )

iniFileToArgs :: [String] -> String -> [String]
iniFileToArgs :: [String] -> String -> [String]
iniFileToArgs [String]
sections String
file =
    ((String, String) -> [String]) -> [(String, String)] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(String
k, String
v) -> [String
"--" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
k] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (if String
v String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
"" then [String
v] else []))
  ([(String, String)] -> [String])
-> ([String] -> [(String, String)]) -> [String] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String, Text) -> (String, String))
-> [(String, Text)] -> [(String, String)]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> String
Data.Text.unpack (Text -> String) -> (String, Text) -> (String, String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>)
  ([(String, Text)] -> [(String, String)])
-> ([String] -> [(String, Text)]) -> [String] -> [(String, String)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String, Text) -> (String, Text))
-> [(String, Text)] -> [(String, Text)]
forall a b. (a -> b) -> [a] -> [b]
map (\(String
k, Text
v) -> if Either String Bool -> Bool
forall a b. Either a b -> Bool
Data.Either.isRight (Either String Bool -> Bool) -> Either String Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Parser Bool -> Text -> Either String Bool
forall a. Parser a -> Text -> Either String a
Data.Attoparsec.Text.parseOnly (Parser Bool
trueStr) Text
v then (String
k, Text
"") else (String
k, Text
v)) -- fix --flag true -> --flag
  ([(String, Text)] -> [(String, Text)])
-> ([String] -> [(String, Text)]) -> [String] -> [(String, Text)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String, Text) -> Bool) -> [(String, Text)] -> [(String, Text)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(String
_, Text
v) -> case Parser Bool -> Text -> Either String Bool
forall a. Parser a -> Text -> Either String a
Data.Attoparsec.Text.parseOnly (Parser Bool
trueStr Parser Bool -> Parser Bool -> Parser Bool
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Bool
falseStr) Text
v of
      Left String
_e -> Bool
True
      Right Bool
b -> Bool
b)
  ([(String, Text)] -> [(String, Text)])
-> ([String] -> [(String, Text)]) -> [String] -> [(String, Text)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String, String) -> (String, Text))
-> [(String, String)] -> [(String, Text)]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Text
Data.Text.pack (String -> Text) -> (String, String) -> (String, Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>)
  ([(String, String)] -> [(String, Text)])
-> ([String] -> [(String, String)]) -> [String] -> [(String, Text)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> (String, String)) -> [String] -> [(String, String)]
forall a b. (a -> b) -> [a] -> [b]
map (\String
x ->
          let t :: String -> String
t = (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile ((Char -> String -> Bool) -> String -> Char -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem (String -> Char -> Bool) -> String -> Char -> Bool
forall a b. (a -> b) -> a -> b
$ Char
'-'Char -> String -> String
forall a. a -> [a] -> [a]
:[Char
'a'..Char
'z'])
          in (String -> String
t String
x, (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ') (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
1 (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'=') String
x)
        )
  ([String] -> [(String, String)])
-> ([String] -> [String]) -> [String] -> [(String, String)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String, [String]) -> [String])
-> [(String, [String])] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(String
_section, [String]
fields) -> [String]
fields)
  ([(String, [String])] -> [String])
-> ([String] -> [(String, [String])]) -> [String] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String, [String]) -> Bool)
-> [(String, [String])] -> [(String, [String])]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(String
section, [String]
_fields) -> String
section String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
sections)
  ([(String, [String])] -> [(String, [String])])
-> ([String] -> [(String, [String])])
-> [String]
-> [(String, [String])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [(String, [String])]
groupBySections
  ([String] -> [(String, [String])])
-> ([String] -> [String]) -> [String] -> [(String, [String])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(Char
x:String
_xs) -> Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'#') -- comments
  ([String] -> [String])
-> ([String] -> [String]) -> [String] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/=String
"") -- empty
  ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ String -> [String]
lines String
file

-- transform [ "[zre]", "debug = false" "gossip=localhost:31337" "[zrecat]" "bufsize = 300"
-- to
-- [("zre", ["debug=false", "gossip=localhost:31337"]), ("zrecat", ["bufsize=300"])]
groupBySections :: [String] -> [(String, [String])]
groupBySections :: [String] -> [(String, [String])]
groupBySections [String]
lines' = [String] -> [(String, [String])]
go [String]
lines'
  where
    go :: [String] -> [(String, [String])]
go [] = []
    go ((Char
x:String
xs):[String]
ls) | Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'[' = ((Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile ((Char -> String -> Bool) -> String -> Char -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem (String -> Char -> Bool) -> String -> Char -> Bool
forall a b. (a -> b) -> a -> b
$ Char
'-'Char -> String -> String
forall a. a -> [a] -> [a]
:[Char
'a'..Char
'z']) String
xs, [String] -> [String]
keyVals [String]
ls)(String, [String]) -> [(String, [String])] -> [(String, [String])]
forall a. a -> [a] -> [a]
:[String] -> [(String, [String])]
go [String]
ls
    go (String
_l:[String]
ls)     | Bool
otherwise = [String] -> [(String, [String])]
go [String]
ls
    keyVals :: [String] -> [String]
keyVals [] = []
    keyVals [String]
ls = (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (\(Char
x:String
_) -> Char
'[' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
x) [String]
ls

-- | Override config value from new iff it differs to default value
--
-- This could be done with `gzipWithT` and Generics
overrideNonDefault :: ZRECfg -> ZRECfg -> ZRECfg
overrideNonDefault :: ZRECfg -> ZRECfg -> ZRECfg
overrideNonDefault ZRECfg
orig ZRECfg
new = ZRECfg :: ByteString
-> Int
-> Int
-> Int
-> Int
-> [ByteString]
-> Endpoint
-> Maybe Endpoint
-> Bool
-> ZRECfg
ZRECfg {
    zreNamed :: ByteString
zreNamed         = ByteString -> ByteString -> ByteString -> ByteString
forall a. Eq a => a -> a -> a -> a
ovr (ZRECfg -> ByteString
zreNamed ZRECfg
orig)         (ZRECfg -> ByteString
zreNamed ZRECfg
new)         (ZRECfg -> ByteString
zreNamed ZRECfg
forall a. Default a => a
def)
  , zreQuietPeriod :: Int
zreQuietPeriod   = Int -> Int -> Int -> Int
forall a. Eq a => a -> a -> a -> a
ovr (ZRECfg -> Int
zreQuietPeriod ZRECfg
orig)   (ZRECfg -> Int
zreQuietPeriod ZRECfg
new)   (ZRECfg -> Int
zreQuietPeriod ZRECfg
forall a. Default a => a
def)
  , zreQuietPingRate :: Int
zreQuietPingRate = Int -> Int -> Int -> Int
forall a. Eq a => a -> a -> a -> a
ovr (ZRECfg -> Int
zreQuietPingRate ZRECfg
orig) (ZRECfg -> Int
zreQuietPingRate ZRECfg
new) (ZRECfg -> Int
zreQuietPingRate ZRECfg
forall a. Default a => a
def)
  , zreDeadPeriod :: Int
zreDeadPeriod    = Int -> Int -> Int -> Int
forall a. Eq a => a -> a -> a -> a
ovr (ZRECfg -> Int
zreDeadPeriod ZRECfg
orig)    (ZRECfg -> Int
zreDeadPeriod ZRECfg
new)    (ZRECfg -> Int
zreDeadPeriod ZRECfg
forall a. Default a => a
def)
  , zreBeaconPeriod :: Int
zreBeaconPeriod  = Int -> Int -> Int -> Int
forall a. Eq a => a -> a -> a -> a
ovr (ZRECfg -> Int
zreBeaconPeriod ZRECfg
orig)  (ZRECfg -> Int
zreBeaconPeriod ZRECfg
new)  (ZRECfg -> Int
zreBeaconPeriod ZRECfg
forall a. Default a => a
def)
  , zreInterfaces :: [ByteString]
zreInterfaces    = [ByteString] -> [ByteString] -> [ByteString] -> [ByteString]
forall a. Eq a => a -> a -> a -> a
ovr (ZRECfg -> [ByteString]
zreInterfaces ZRECfg
orig)    (ZRECfg -> [ByteString]
zreInterfaces ZRECfg
new)    (ZRECfg -> [ByteString]
zreInterfaces ZRECfg
forall a. Default a => a
def)
  , zreMCast :: Endpoint
zreMCast         = Endpoint -> Endpoint -> Endpoint -> Endpoint
forall a. Eq a => a -> a -> a -> a
ovr (ZRECfg -> Endpoint
zreMCast ZRECfg
orig)         (ZRECfg -> Endpoint
zreMCast ZRECfg
new)         (ZRECfg -> Endpoint
zreMCast ZRECfg
forall a. Default a => a
def)
  , zreZGossip :: Maybe Endpoint
zreZGossip       = Maybe Endpoint
-> Maybe Endpoint -> Maybe Endpoint -> Maybe Endpoint
forall a. Eq a => a -> a -> a -> a
ovr (ZRECfg -> Maybe Endpoint
zreZGossip ZRECfg
orig)       (ZRECfg -> Maybe Endpoint
zreZGossip ZRECfg
new)       (ZRECfg -> Maybe Endpoint
zreZGossip ZRECfg
forall a. Default a => a
def)
  , zreDbg :: Bool
zreDbg           = Bool -> Bool -> Bool -> Bool
forall a. Eq a => a -> a -> a -> a
ovr (ZRECfg -> Bool
zreDbg ZRECfg
orig)           (ZRECfg -> Bool
zreDbg ZRECfg
new)           (ZRECfg -> Bool
zreDbg ZRECfg
forall a. Default a => a
def)
  }
  where
    ovr :: (Eq a) => a -> a -> a -> a
    ovr :: a -> a -> a -> a
ovr a
_o a
n a
d | a
n a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
d = a
n
    ovr a
o a
_n a
_d | Bool
otherwise = a
o

parseZRECfg :: String -> FilePath -> IO (Either String ZRECfg)
parseZRECfg :: String -> String -> IO (Either String ZRECfg)
parseZRECfg String
exeName String
fpath = do
  Bool
isFile <- String -> IO Bool
doesFileExist String
fpath
  case Bool
isFile of
    Bool
False -> Either String ZRECfg -> IO (Either String ZRECfg)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String ZRECfg -> IO (Either String ZRECfg))
-> Either String ZRECfg -> IO (Either String ZRECfg)
forall a b. (a -> b) -> a -> b
$ String -> Either String ZRECfg
forall a b. a -> Either a b
Left String
"No such file"
    Bool
True -> do
      String
f <- String -> IO String
readFile String
fpath
      let cfg :: ParserResult ZRECfg
cfg = ParserPrefs -> ParserInfo ZRECfg -> [String] -> ParserResult ZRECfg
forall a. ParserPrefs -> ParserInfo a -> [String] -> ParserResult a
execParserPure ParserPrefs
defaultPrefs ParserInfo ZRECfg
opts ([String] -> String -> [String]
iniFileToArgs [String
"zre", String
exeName] String
f)
      case ParserResult ZRECfg
cfg of
        -- we always fail when one of the configs fails to parse
        Failure ParserFailure ParserHelp
e -> String -> IO (Either String ZRECfg)
forall a. HasCallStack => String -> a
error (String -> IO (Either String ZRECfg))
-> String -> IO (Either String ZRECfg)
forall a b. (a -> b) -> a -> b
$ (String, ExitCode) -> String
forall a b. (a, b) -> a
fst ((String, ExitCode) -> String) -> (String, ExitCode) -> String
forall a b. (a -> b) -> a -> b
$ ParserFailure ParserHelp -> String -> (String, ExitCode)
renderFailure ParserFailure ParserHelp
e String
""
        Success ZRECfg
cfg' -> Either String ZRECfg -> IO (Either String ZRECfg)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String ZRECfg -> IO (Either String ZRECfg))
-> Either String ZRECfg -> IO (Either String ZRECfg)
forall a b. (a -> b) -> a -> b
$ ZRECfg -> Either String ZRECfg
forall a b. b -> Either a b
Right (ZRECfg -> Either String ZRECfg) -> ZRECfg -> Either String ZRECfg
forall a b. (a -> b) -> a -> b
$ ZRECfg
cfg'
        CompletionInvoked CompletionResult
_ -> String -> IO (Either String ZRECfg)
forall a. HasCallStack => String -> a
error String
"No completion"
  where
    opts :: ParserInfo ZRECfg
opts = Parser ZRECfg -> InfoMod ZRECfg -> ParserInfo ZRECfg
forall a. Parser a -> InfoMod a -> ParserInfo a
info (Parser ZRECfg
parseOptions Parser ZRECfg -> Parser (ZRECfg -> ZRECfg) -> Parser ZRECfg
forall (f :: * -> *) a b. Applicative f => f a -> f (a -> b) -> f b
<**> Parser (ZRECfg -> ZRECfg)
forall a. Parser (a -> a)
helper)
      ( InfoMod ZRECfg
forall a. InfoMod a
fullDesc
     InfoMod ZRECfg -> InfoMod ZRECfg -> InfoMod ZRECfg
forall a. Semigroup a => a -> a -> a
<> String -> InfoMod ZRECfg
forall a. String -> InfoMod a
progDesc String
"ZRE"
     InfoMod ZRECfg -> InfoMod ZRECfg -> InfoMod ZRECfg
forall a. Semigroup a => a -> a -> a
<> String -> InfoMod ZRECfg
forall a. String -> InfoMod a
header String
"zre tools" )

-- The order is
-- * path of @ZRECFG@ env iff set
-- * @/etc/zre.conf@
-- * @~/.zre.conf@
-- * @default@
--
-- This also tries to parse subsection for zre programs according to their
-- name and construct correct command line for these so we can do
--
-- @[zrecat]@
-- @bufsize = 1024@
--
-- If @ZRENAME@ env var is set, it overrides name field in the result config.
envZRECfg :: String -> IO (ZRECfg)
envZRECfg :: String -> IO ZRECfg
envZRECfg String
exeName = do
  Maybe String
menv  <- String -> IO (Maybe String)
lookupEnv String
"ZRECFG"
  Maybe String
mname <- String -> IO (Maybe String)
lookupEnv String
"ZRENAME"

  String
hom <- IO String
getHomeDirectory

  ZRECfg
cfg <- [IO (Either String ZRECfg)] -> IO ZRECfg
forall (m :: * -> *) a b. Monad m => [m (Either a b)] -> m b
asumOneConfig [
      IO (Either String ZRECfg)
-> (String -> IO (Either String ZRECfg))
-> Maybe String
-> IO (Either String ZRECfg)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Either String ZRECfg -> IO (Either String ZRECfg)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String ZRECfg -> IO (Either String ZRECfg))
-> Either String ZRECfg -> IO (Either String ZRECfg)
forall a b. (a -> b) -> a -> b
$ String -> Either String ZRECfg
forall a b. a -> Either a b
Left String
"No ZRECFG env") (String -> String -> IO (Either String ZRECfg)
parseZRECfg String
exeName) Maybe String
menv
    , String -> String -> IO (Either String ZRECfg)
parseZRECfg String
exeName String
"/etc/zre.conf"
    , String -> String -> IO (Either String ZRECfg)
parseZRECfg String
exeName (String -> IO (Either String ZRECfg))
-> String -> IO (Either String ZRECfg)
forall a b. (a -> b) -> a -> b
$ String
hom String -> String -> String
</> String
".zre.conf"
    , Either String ZRECfg -> IO (Either String ZRECfg)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String ZRECfg -> IO (Either String ZRECfg))
-> Either String ZRECfg -> IO (Either String ZRECfg)
forall a b. (a -> b) -> a -> b
$ ZRECfg -> Either String ZRECfg
forall a b. b -> Either a b
Right ZRECfg
forall a. Default a => a
def
    ]
  ZRECfg -> IO ZRECfg
forall (m :: * -> *) a. Monad m => a -> m a
return (ZRECfg -> IO ZRECfg) -> ZRECfg -> IO ZRECfg
forall a b. (a -> b) -> a -> b
$ ZRECfg -> Maybe String -> ZRECfg
maybeUpdateName ZRECfg
cfg Maybe String
mname
  where
    maybeUpdateName :: ZRECfg -> Maybe String -> ZRECfg
maybeUpdateName ZRECfg
cfg Maybe String
mname = ZRECfg -> (String -> ZRECfg) -> Maybe String -> ZRECfg
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ZRECfg
cfg (\String
x -> ZRECfg
cfg { zreNamed :: ByteString
zreNamed = String -> ByteString
B.pack String
x}) Maybe String
mname
    asumOneConfig :: [m (Either a b)] -> m b
asumOneConfig [] = String -> m b
forall a. HasCallStack => String -> a
error String
"Can't happen"
    asumOneConfig (m (Either a b)
x:[m (Either a b)]
xs) = m (Either a b)
x m (Either a b) -> (Either a b -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Either a b
y -> case Either a b
y of
      Left a
_e -> [m (Either a b)] -> m b
asumOneConfig [m (Either a b)]
xs
      Right b
cfg -> b -> m b
forall (m :: * -> *) a. Monad m => a -> m a
return (b -> m b) -> b -> m b
forall a b. (a -> b) -> a -> b
$ b
cfg