module Config.Dyre.Options
( removeDyreOptions
, withDyreOptions
, customOptions
, getDenyReconf
, getForceReconf
, getDebug
, getMasterBinary
, getStatePersist
) where
import Data.List (isPrefixOf)
import Data.Maybe (fromMaybe)
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 :: [[Char]] -> [[Char]]
removeDyreOptions = ([Char] -> Bool) -> [[Char]] -> [[Char]]
forall a. (a -> Bool) -> [a] -> [a]
filter (([Char] -> Bool) -> [[Char]] -> [[Char]])
-> ([Char] -> Bool) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Bool -> Bool) -> ([Char] -> Bool) -> [Char] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Char]] -> [Char] -> Bool
forall {a}. Eq a => [[a]] -> [a] -> Bool
prefixElem [[Char]]
dyreArgs
where prefixElem :: [[a]] -> [a] -> Bool
prefixElem [[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 r -> IO a -> IO a
withDyreOptions :: forall c r a. Params c r -> IO a -> IO a
withDyreOptions Params{configCheck :: forall cfgType a. Params cfgType a -> Bool
configCheck = Bool
check} IO a
action = [Char] -> IO a -> IO a
forall a. [Char] -> IO a -> IO a
withStore [Char]
"dyre" (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ do
[[Char]]
args <- IO [[Char]]
getArgs
[Char]
this <- if Bool
check then IO [Char]
getExecutablePath else IO [Char]
getProgName
[Char] -> [Char] -> [Char] -> IO ()
forall a. Typeable a => [Char] -> [Char] -> a -> IO ()
putValue [Char]
"dyre" [Char]
"masterBinary" [Char]
this
[[Char]] -> [Char] -> [Char] -> IO ()
storeFlag [[Char]]
args [Char]
"--dyre-master-binary=" [Char]
"masterBinary"
[[Char]] -> [Char] -> [Char] -> IO ()
storeFlag [[Char]]
args [Char]
"--dyre-state-persist=" [Char]
"persistState"
[Char] -> [Char] -> Bool -> IO ()
forall a. Typeable a => [Char] -> [Char] -> a -> IO ()
putValue [Char]
"dyre" [Char]
"forceReconf" (Bool -> IO ()) -> Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"--force-reconf" [Char] -> [[Char]] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [[Char]]
args
[Char] -> [Char] -> Bool -> IO ()
forall a. Typeable a => [Char] -> [Char] -> a -> IO ()
putValue [Char]
"dyre" [Char]
"denyReconf" (Bool -> IO ()) -> Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"--deny-reconf" [Char] -> [[Char]] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [[Char]]
args
[Char] -> [Char] -> Bool -> IO ()
forall a. Typeable a => [Char] -> [Char] -> a -> IO ()
putValue [Char]
"dyre" [Char]
"debugMode" (Bool -> IO ()) -> Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"--dyre-debug" [Char] -> [[Char]] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [[Char]]
args
[[Char]] -> IO a -> IO a
forall a. [[Char]] -> IO a -> IO a
withArgs ([[Char]] -> [[Char]]
removeDyreOptions [[Char]]
args) IO a
action
getForceReconf :: IO Bool
getForceReconf :: IO Bool
getForceReconf = [Char] -> [Char] -> Bool -> IO Bool
forall a. Typeable a => [Char] -> [Char] -> a -> IO a
getDefaultValue [Char]
"dyre" [Char]
"forceReconf" Bool
False
getDenyReconf :: IO Bool
getDenyReconf :: IO Bool
getDenyReconf = [Char] -> [Char] -> Bool -> IO Bool
forall a. Typeable a => [Char] -> [Char] -> a -> IO a
getDefaultValue [Char]
"dyre" [Char]
"denyReconf" Bool
False
getDebug :: IO Bool
getDebug :: IO Bool
getDebug = [Char] -> [Char] -> Bool -> IO Bool
forall a. Typeable a => [Char] -> [Char] -> a -> IO a
getDefaultValue [Char]
"dyre" [Char]
"debugMode" Bool
False
getMasterBinary :: IO (Maybe String)
getMasterBinary :: IO (Maybe [Char])
getMasterBinary = [Char] -> [Char] -> IO (Maybe [Char])
forall a. Typeable a => [Char] -> [Char] -> IO (Maybe a)
getValue [Char]
"dyre" [Char]
"masterBinary"
getStatePersist :: IO (Maybe String)
getStatePersist :: IO (Maybe [Char])
getStatePersist = [Char] -> [Char] -> IO (Maybe [Char])
forall a. Typeable a => [Char] -> [Char] -> IO (Maybe a)
getValue [Char]
"dyre" [Char]
"persistState"
customOptions :: Maybe [String] -> IO [String]
customOptions :: Maybe [[Char]] -> IO [[Char]]
customOptions Maybe [[Char]]
otherArgs = do
Maybe [Char]
masterPath <- IO (Maybe [Char])
getMasterBinary
Maybe [Char]
stateFile <- IO (Maybe [Char])
getStatePersist
Bool
debugMode <- IO Bool
getDebug
[[Char]]
mainArgs <- IO [[Char]]
-> ([[Char]] -> IO [[Char]]) -> Maybe [[Char]] -> IO [[Char]]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO [[Char]]
getArgs [[Char]] -> IO [[Char]]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe [[Char]]
otherArgs
[[Char]] -> IO [[Char]]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([[Char]] -> IO [[Char]]) -> [[Char]] -> IO [[Char]]
forall a b. (a -> b) -> a -> b
$ [[Char]]
mainArgs [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[[Char]]] -> [[Char]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ [[Char]
"--dyre-debug" | Bool
debugMode]
, [[Char]
"--dyre-state-persist=" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
sf | Just [Char]
sf <- [Maybe [Char]
stateFile]]
, [ [Char]
"--dyre-master-binary="
[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> Maybe [Char] -> [Char]
forall a. a -> Maybe a -> a
fromMaybe ([Char] -> [Char]
forall a. HasCallStack => [Char] -> a
error [Char]
"'dyre' data-store doesn't exist (in Config.Dyre.Options.customOptions)") Maybe [Char]
masterPath]
]
storeFlag :: [String] -> String -> String -> IO ()
storeFlag :: [[Char]] -> [Char] -> [Char] -> IO ()
storeFlag [[Char]]
args [Char]
flag [Char]
name
| [[Char]] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Char]]
match = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool
otherwise = [Char] -> [Char] -> [Char] -> IO ()
forall a. Typeable a => [Char] -> [Char] -> a -> IO ()
putValue [Char]
"dyre" [Char]
name ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> [Char] -> [Char]
forall a. Int -> [a] -> [a]
drop ([Char] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
flag) ([[Char]] -> [Char]
forall a. HasCallStack => [a] -> a
head [[Char]]
match)
where match :: [[Char]]
match = ([Char] -> Bool) -> [[Char]] -> [[Char]]
forall a. (a -> Bool) -> [a] -> [a]
filter ([Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf [Char]
flag) [[Char]]
args
dyreArgs :: [String]
dyreArgs :: [[Char]]
dyreArgs = [ [Char]
"--force-reconf", [Char]
"--deny-reconf"
, [Char]
"--dyre-state-persist", [Char]
"--dyre-debug"
, [Char]
"--dyre-master-binary" ]