module Config.Dyre.Options
( removeDyreOptions
, withDyreOptions
, customOptions
, getDenyReconf
, getForceReconf
, getDebug
, getMasterBinary
, getStatePersist
) where
import Data.List (isPrefixOf)
import Data.Maybe (fromJust)
import System.IO.Storage (withStore, putValue, getValue, getDefaultValue)
import System.Environment (getArgs, getProgName, withArgs)
import System.Environment.Executable (getExecutablePath)
import Config.Dyre.Params
removeDyreOptions :: [String] -> [String]
removeDyreOptions :: [String] -> [String]
removeDyreOptions = (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter ((String -> Bool) -> [String] -> [String])
-> (String -> Bool) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String -> Bool
forall a. Eq a => [[a]] -> [a] -> Bool
prefixElem [String]
dyreArgs
where prefixElem :: [[a]] -> [a] -> Bool
prefixElem xs :: [[a]]
xs = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or ([Bool] -> Bool) -> ([a] -> [Bool]) -> [a] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([a] -> Bool) -> [a] -> Bool) -> [[a] -> Bool] -> [[a]] -> [Bool]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith ([a] -> Bool) -> [a] -> Bool
forall a b. (a -> b) -> a -> b
($) (([a] -> [a] -> Bool) -> [[a]] -> [[a] -> Bool]
forall a b. (a -> b) -> [a] -> [b]
map [a] -> [a] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf [[a]]
xs) ([[a]] -> [Bool]) -> ([a] -> [[a]]) -> [a] -> [Bool]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> [[a]]
forall a. a -> [a]
repeat
withDyreOptions :: Params c -> IO a -> IO a
withDyreOptions :: Params c -> IO a -> IO a
withDyreOptions Params{configCheck :: forall cfgType. Params cfgType -> Bool
configCheck = Bool
check} action :: IO a
action = String -> IO a -> IO a
forall a. String -> IO a -> IO a
withStore "dyre" (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ do
[String]
args <- IO [String]
getArgs
String
this <- if Bool
check then IO String
getExecutablePath else IO String
getProgName
String -> String -> String -> IO ()
forall a. Typeable a => String -> String -> a -> IO ()
putValue "dyre" "masterBinary" String
this
[String] -> String -> String -> IO ()
storeFlag [String]
args "--dyre-master-binary=" "masterBinary"
[String] -> String -> String -> IO ()
storeFlag [String]
args "--dyre-state-persist=" "persistState"
String -> String -> Bool -> IO ()
forall a. Typeable a => String -> String -> a -> IO ()
putValue "dyre" "forceReconf" (Bool -> IO ()) -> Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ "--force-reconf" String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
args
String -> String -> Bool -> IO ()
forall a. Typeable a => String -> String -> a -> IO ()
putValue "dyre" "denyReconf" (Bool -> IO ()) -> Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ "--deny-reconf" String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
args
String -> String -> Bool -> IO ()
forall a. Typeable a => String -> String -> a -> IO ()
putValue "dyre" "debugMode" (Bool -> IO ()) -> Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ "--dyre-debug" String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
args
[String] -> IO a -> IO a
forall a. [String] -> IO a -> IO a
withArgs ([String] -> [String]
removeDyreOptions [String]
args) IO a
action
getForceReconf :: IO Bool
getForceReconf :: IO Bool
getForceReconf = String -> String -> Bool -> IO Bool
forall a. Typeable a => String -> String -> a -> IO a
getDefaultValue "dyre" "forceReconf" Bool
False
getDenyReconf :: IO Bool
getDenyReconf :: IO Bool
getDenyReconf = String -> String -> Bool -> IO Bool
forall a. Typeable a => String -> String -> a -> IO a
getDefaultValue "dyre" "denyReconf" Bool
False
getDebug :: IO Bool
getDebug :: IO Bool
getDebug = String -> String -> Bool -> IO Bool
forall a. Typeable a => String -> String -> a -> IO a
getDefaultValue "dyre" "debugMode" Bool
False
getMasterBinary :: IO (Maybe String)
getMasterBinary :: IO (Maybe String)
getMasterBinary = String -> String -> IO (Maybe String)
forall a. Typeable a => String -> String -> IO (Maybe a)
getValue "dyre" "masterBinary"
getStatePersist :: IO (Maybe String)
getStatePersist :: IO (Maybe String)
getStatePersist = String -> String -> IO (Maybe String)
forall a. Typeable a => String -> String -> IO (Maybe a)
getValue "dyre" "persistState"
customOptions :: Maybe [String] -> IO [String]
customOptions :: Maybe [String] -> IO [String]
customOptions otherArgs :: Maybe [String]
otherArgs = do
Maybe String
masterPath <- IO (Maybe String)
getMasterBinary
Maybe String
stateFile <- IO (Maybe String)
getStatePersist
Bool
debugMode <- IO Bool
getDebug
[String]
mainArgs <- case Maybe [String]
otherArgs of
Nothing -> IO [String]
getArgs
Just oa :: [String]
oa -> [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return [String]
oa
let args :: [String]
args = [String]
mainArgs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ ((String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$
[ if Bool
debugMode then "--dyre-debug" else ""
, case Maybe String
stateFile of
Nothing -> ""
Just sf :: String
sf -> "--dyre-state-persist=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
sf
, "--dyre-master-binary=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Maybe String -> String
forall a. HasCallStack => Maybe a -> a
fromJust Maybe String
masterPath
])
[String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return [String]
args
storeFlag :: [String] -> String -> String -> IO ()
storeFlag :: [String] -> String -> String -> IO ()
storeFlag args :: [String]
args flag :: String
flag name :: String
name
| [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
match = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool
otherwise = String -> String -> String -> IO ()
forall a. Typeable a => String -> String -> a -> IO ()
putValue "dyre" String
name (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> String -> String
forall a. Int -> [a] -> [a]
drop (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
flag) ([String] -> String
forall a. [a] -> a
head [String]
match)
where match :: [String]
match = (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf String
flag) [String]
args
dyreArgs :: [String]
dyreArgs :: [String]
dyreArgs = [ "--force-reconf", "--deny-reconf"
, "--dyre-state-persist", "--dyre-debug"
, "--dyre-master-binary" ]