From 976abcbb914e4d208e708cc27da2d87773470fdd Mon Sep 17 00:00:00 2001 From: Luite Stegeman Date: Tue, 30 Oct 2012 19:14:09 +0100 Subject: [PATCH 1/2] allow user to set default value for command line options with env vars or config file --- yesod/Options.hs | 73 +++++++++++++++++++++++++++++++++++++++++++++++ yesod/main.hs | 49 +++++++++++++------------------ yesod/yesod.cabal | 3 +- 3 files changed, 95 insertions(+), 30 deletions(-) create mode 100644 yesod/Options.hs diff --git a/yesod/Options.hs b/yesod/Options.hs new file mode 100644 index 00000000..3a6c06dd --- /dev/null +++ b/yesod/Options.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Options (injectDefaults) where + +import Control.Applicative +import qualified Control.Exception as E +import Control.Monad +import Data.Char (isAlphaNum, isSpace, toLower) +import Data.List.Split (splitOn) +import qualified Data.Map as M +import Data.Maybe (catMaybes) +import Data.Monoid +import Options.Applicative +import Options.Applicative.Types +import System.Directory +import System.Environment +import System.FilePath (()) + +-- | inject defaults from either files or environments +-- in order of priority: +-- 1. command line arguments: --long-option=value +-- 2. environment variables: PREFIX_COMMAND_LONGOPTION=value +-- 3. $HOME/.prefix/config: prefix.command.longoption=value +injectDefaults :: String -> ParserInfo a -> IO (ParserInfo a) +injectDefaults prefix parser = do + e <- getEnvironment + config <- (readFile . ( "config") =<< getAppUserDataDirectory prefix) + `E.catch` \(_::E.SomeException) -> return "" + let env = M.fromList . filter ((==[prefix]) . take 1 . fst) $ + configLines config <> -- config first + map (\(k,v) -> (splitOn "_" $ map toLower k, v)) e -- env vars override config + print env + return $ parser { infoParser = injectDefaultP env [prefix] (infoParser parser) } + +-- | really simple key/value file reader: x.y = z -> (["x","y"],"z") +configLines :: String -> [([String], String)] +configLines = catMaybes . map (mkLine . takeWhile (/='#')) . lines + where + trim = let f = reverse . dropWhile isSpace in f . f + mkLine l | (k, ('=':v)) <- break (=='=') l = Just (splitOn "." (trim k), trim v) + | otherwise = Nothing + +-- | inject the environment into the parser +-- the map contains the paths with the value that's passed into the reader if the +-- command line parser gives no result +injectDefaultP :: M.Map [String] String -> [String] -> Parser a -> Parser a +injectDefaultP _env _path n@(NilP{}) = n +injectDefaultP env path p@(OptP o) + | (Option (CmdReader cmds f) props) <- o = + let cmdMap = M.fromList (map (\c -> (c, mkCmd c)) cmds) + mkCmd cmd = + let (Just parseri) = f cmd + in parseri { infoParser = injectDefaultP env (path ++ [normalizeName cmd]) (infoParser parseri) } + in OptP (Option (CmdReader cmds (`M.lookup` cmdMap)) props) + | (Option (OptReader names (CReader _ rdr)) _) <- o = + p <|> maybe empty pure (msum $ map (rdr <=< getEnvValue env path) names) + | (Option (FlagReader names a) _) <- o = + p <|> if any ((==Just "1") . getEnvValue env path) names then pure a else empty + | otherwise = p +injectDefaultP env path (MultP p1 p2) = + MultP (injectDefaultP env path p1) (injectDefaultP env path p2) +injectDefaultP env path (AltP p1 p2) = + AltP (injectDefaultP env path p1) (injectDefaultP env path p2) +injectDefaultP env path (BindP p1 f) = + BindP (injectDefaultP env path p1) (\a -> injectDefaultP env path (f a)) + +getEnvValue :: M.Map [String] String -> [String] -> OptName -> Maybe String +getEnvValue env path (OptLong l) = M.lookup (path ++ [normalizeName l]) env +getEnvValue _ _ _ = Nothing + +normalizeName :: String -> String +normalizeName = map toLower . filter isAlphaNum diff --git a/yesod/main.hs b/yesod/main.hs index 24b78bcc..6e902170 100755 --- a/yesod/main.hs +++ b/yesod/main.hs @@ -4,7 +4,6 @@ import Control.Monad (unless) import Data.Monoid import Data.Version (showVersion) import Options.Applicative -import System.Environment (getEnvironment) import System.Exit (ExitCode (ExitSuccess), exitWith) import System.Process (rawSystem) @@ -13,6 +12,7 @@ import Yesod.Core (yesodVersion) import AddHandler (addHandler) import Devel (DevelOpts (..), devel) import Keter (keter) +import Options (injectDefaults) import qualified Paths_yesod import Scaffolding.Scaffolder @@ -63,12 +63,10 @@ data Command = Init | Version deriving (Show, Eq) -type Environment = [(String, String)] - main :: IO () main = do - env <- getEnvironment - o <- execParser (optParser' env) + o <- execParser =<< injectDefaults "yesod" optParser' + print o let cabal xs = rawSystem' (cabalCommand o) xs case optCommand o of Init -> scaffold @@ -85,11 +83,11 @@ main = do cabal ["build"] cabal ["test"] -optParser' :: Environment -> ParserInfo Options -optParser' env = info (helper <*> optParser env) ( fullDesc <> header "Yesod Web Framework command line utility" ) +optParser' :: ParserInfo Options +optParser' = info (helper <*> optParser) ( fullDesc <> header "Yesod Web Framework command line utility" ) -optParser :: Environment -> Parser Options -optParser env = Options +optParser :: Parser Options +optParser = Options <$> flag Cabal CabalDev ( long "dev" <> short 'd' <> help "use cabal-dev" ) <*> switch ( long "verbose" <> short 'v' <> help "More verbose output" ) <*> subparser ( command "init" (info (pure Init) @@ -100,7 +98,7 @@ optParser env = Options (progDesc $ "Build project (performs TH dependency analysis)" ++ windowsWarning)) <> command "touch" (info (pure Touch) (progDesc $ "Touch any files with altered TH dependencies but do not build" ++ windowsWarning)) - <> command "devel" (info (develOptions env) + <> command "devel" (info develOptions (progDesc "Run project with the devel server")) <> command "test" (info (pure Test) (progDesc "Build and run the integration tests")) @@ -115,19 +113,18 @@ optParser env = Options keterOptions :: Parser Command keterOptions = Keter <$> switch ( long "nobuild" <> short 'n' <> help "Skip rebuilding" ) -develOptions :: Environment -> Parser Command -develOptions env = Devel <$> switch ( long "disable-api" <> short 'd' - <> help "Disable fast GHC API rebuilding") - <*> optStr ( long "success-hook" <> short 's' <> metavar "COMMAND" - <> help "Run COMMAND after rebuild succeeds") - <*> optStr ( long "failure-hook" <> short 'f' <> metavar "COMMAND" - <> help "Run COMMAND when rebuild fails") - <*> option ( long "event-timeout" <> short 't' <> value (-1) <> metavar "N" - <> help "Force rescan of files every N seconds" ) - - <*> optStrEnv env "CABAL_BUILDDIR" ( long "builddir" <> short 'b' - <> help "Set custom cabal build directory, default `dist' or the CABAL_BUILDDIR environment variable") - <*> extraCabalArgs +develOptions :: Parser Command +develOptions = Devel <$> switch ( long "disable-api" <> short 'd' + <> help "Disable fast GHC API rebuilding") + <*> optStr ( long "success-hook" <> short 's' <> metavar "COMMAND" + <> help "Run COMMAND after rebuild succeeds") + <*> optStr ( long "failure-hook" <> short 'f' <> metavar "COMMAND" + <> help "Run COMMAND when rebuild fails") + <*> option ( long "event-timeout" <> short 't' <> value (-1) <> metavar "N" + <> help "Force rescan of files every N seconds" ) + <*> optStr ( long "builddir" <> short 'b' + <> help "Set custom cabal build directory, default `dist'") + <*> extraCabalArgs extraCabalArgs :: Parser [String] extraCabalArgs = many (strOption ( long "extra-cabal-arg" <> short 'e' <> metavar "ARG" @@ -138,12 +135,6 @@ extraCabalArgs = many (strOption ( long "extra-cabal-arg" <> short 'e' <> metava optStr :: Mod OptionFields (Maybe String) -> Parser (Maybe String) optStr m = nullOption $ value Nothing <> reader (Just . str) <> m -optStrEnv :: Environment - -> String - -> Mod OptionFields (Maybe String) - -> Parser (Maybe String) -optStrEnv env v m = nullOption $ value (lookup v env) <> reader (Just . str) <> m - -- | Like @rawSystem@, but exits if it receives a non-success result. rawSystem' :: String -> [String] -> IO () rawSystem' x y = do diff --git a/yesod/yesod.cabal b/yesod/yesod.cabal index 784d369c..d7eb8069 100644 --- a/yesod/yesod.cabal +++ b/yesod/yesod.cabal @@ -132,6 +132,7 @@ executable yesod , yaml >= 0.8 && < 0.9 , optparse-applicative >= 0.4 && < 0.5 , fsnotify >= 0.0 && < 0.1 + , split >= 0.2 && < 0.3 ghc-options: -Wall -threaded main-is: main.hs @@ -143,7 +144,7 @@ executable yesod Keter AddHandler Paths_yesod - + Options source-repository head type: git From 54abbc861833eab22a855bef3417ea358c5afd27 Mon Sep 17 00:00:00 2001 From: Luite Stegeman Date: Fri, 2 Nov 2012 01:07:08 +0100 Subject: [PATCH 2/2] fix handling of parameters that may occur multiple times --- yesod/Options.hs | 30 +++++++++++++++++++----- yesod/main.hs | 60 ++++++++++++++++++++++++++++------------------- yesod/yesod.cabal | 1 + 3 files changed, 61 insertions(+), 30 deletions(-) diff --git a/yesod/Options.hs b/yesod/Options.hs index 3a6c06dd..9bedbf08 100644 --- a/yesod/Options.hs +++ b/yesod/Options.hs @@ -5,12 +5,15 @@ module Options (injectDefaults) where import Control.Applicative import qualified Control.Exception as E +import Control.Lens import Control.Monad import Data.Char (isAlphaNum, isSpace, toLower) +import Data.List (foldl') import Data.List.Split (splitOn) import qualified Data.Map as M import Data.Maybe (catMaybes) import Data.Monoid +import Data.Monoid.Lens import Options.Applicative import Options.Applicative.Types import System.Directory @@ -22,16 +25,31 @@ import System.FilePath (()) -- 1. command line arguments: --long-option=value -- 2. environment variables: PREFIX_COMMAND_LONGOPTION=value -- 3. $HOME/.prefix/config: prefix.command.longoption=value -injectDefaults :: String -> ParserInfo a -> IO (ParserInfo a) -injectDefaults prefix parser = do +-- +-- note: this automatically injects values for standard options and flags +-- (also inside subcommands), but not for more complex parsers that use BindP +-- (like `many'). As a workaround a single special case is supported, +-- for `many' arguments that generate a list of strings. + +injectDefaults :: String -- ^ prefix, program name + -> [(String, Setting a a [String] [String])] -- ^ append extra options for arguments that are lists of strings + -> ParserInfo a -- ^ original parsers + -> IO (ParserInfo a) +injectDefaults prefix lenses parser = do e <- getEnvironment config <- (readFile . ( "config") =<< getAppUserDataDirectory prefix) `E.catch` \(_::E.SomeException) -> return "" let env = M.fromList . filter ((==[prefix]) . take 1 . fst) $ configLines config <> -- config first map (\(k,v) -> (splitOn "_" $ map toLower k, v)) e -- env vars override config - print env - return $ parser { infoParser = injectDefaultP env [prefix] (infoParser parser) } + p' = parser { infoParser = injectDefaultP env [prefix] (infoParser parser) } + return $ foldl' (\p (key,l) -> fmap (updateA env key l) p) p' lenses + +updateA :: M.Map [String] String -> String -> Setting a a [String] [String] -> a -> a +updateA env key upd a = + case M.lookup (splitOn "." key) env of + Nothing -> a + Just v -> upd <>~ (splitOn ":" v) $ a -- | really simple key/value file reader: x.y = z -> (["x","y"],"z") configLines :: String -> [([String], String)] @@ -62,8 +80,7 @@ injectDefaultP env path (MultP p1 p2) = MultP (injectDefaultP env path p1) (injectDefaultP env path p2) injectDefaultP env path (AltP p1 p2) = AltP (injectDefaultP env path p1) (injectDefaultP env path p2) -injectDefaultP env path (BindP p1 f) = - BindP (injectDefaultP env path p1) (\a -> injectDefaultP env path (f a)) +injectDefaultP _env _path b@(BindP {}) = b getEnvValue :: M.Map [String] String -> [String] -> OptName -> Maybe String getEnvValue env path (OptLong l) = M.lookup (path ++ [normalizeName l]) env @@ -71,3 +88,4 @@ getEnvValue _ _ _ = Nothing normalizeName :: String -> String normalizeName = map toLower . filter isAlphaNum + diff --git a/yesod/main.hs b/yesod/main.hs index 6e902170..3d6548ea 100755 --- a/yesod/main.hs +++ b/yesod/main.hs @@ -1,5 +1,7 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskell #-} +import Control.Lens hiding (value) import Control.Monad (unless) import Data.Monoid import Data.Version (showVersion) @@ -32,17 +34,12 @@ windowsWarning :: String windowsWarning = " (does not work on Windows)" #endif -cabalCommand :: Options -> String -cabalCommand mopt - | optCabalPgm mopt == CabalDev = "cabal-dev" - | otherwise = "cabal" - data CabalPgm = Cabal | CabalDev deriving (Show, Eq) data Options = Options - { optCabalPgm :: CabalPgm - , optVerbose :: Bool - , optCommand :: Command + { _optCabalPgm :: CabalPgm + , _optVerbose :: Bool + , _optCommand :: Command } deriving (Show, Eq) @@ -55,6 +52,7 @@ data Command = Init , _develFailHook :: Maybe String , _develRescan :: Int , _develBuildDir :: Maybe String + , _develIgnore :: [String] , _develExtraArgs :: [String] } | Test @@ -63,25 +61,36 @@ data Command = Init | Version deriving (Show, Eq) +makeLenses ''Options +makeLenses ''Command + +cabalCommand :: Options -> String +cabalCommand mopt + | mopt^.optCabalPgm == CabalDev = "cabal-dev" + | otherwise = "cabal" + + main :: IO () main = do - o <- execParser =<< injectDefaults "yesod" optParser' + o <- execParser =<< injectDefaults "yesod" [ ("yesod.devel.extracabalarg" , optCommand . develExtraArgs) + , ("yesod.devel.ignore" , optCommand . develIgnore) + ] optParser' print o let cabal xs = rawSystem' (cabalCommand o) xs - case optCommand o of - Init -> scaffold - Configure -> cabal ["configure"] - Build es -> touch' >> cabal ("build":es) - Touch -> touch' - Devel da s f r b es -> devel (DevelOpts (optCabalPgm o == CabalDev) da (optVerbose o) r s f b) es - Keter noRebuild -> keter (cabalCommand o) noRebuild - Version -> do putStrLn ("yesod-core version:" ++ yesodVersion) - putStrLn ("yesod version:" ++ showVersion Paths_yesod.version) - AddHandler -> addHandler - Test -> do touch' - cabal ["configure", "--enable-tests", "-flibrary-only"] - cabal ["build"] - cabal ["test"] + case o^.optCommand of + Init -> scaffold + Configure -> cabal ["configure"] + Build es -> touch' >> cabal ("build":es) + Touch -> touch' + Devel da s f r b ign es -> devel (DevelOpts (o^.optCabalPgm == CabalDev) da (o^.optVerbose) r s f b) es + Keter noRebuild -> keter (cabalCommand o) noRebuild + Version -> do putStrLn ("yesod-core version:" ++ yesodVersion) + putStrLn ("yesod version:" ++ showVersion Paths_yesod.version) + AddHandler -> addHandler + Test -> do touch' + cabal ["configure", "--enable-tests", "-flibrary-only"] + cabal ["build"] + cabal ["test"] optParser' :: ParserInfo Options optParser' = info (helper <*> optParser) ( fullDesc <> header "Yesod Web Framework command line utility" ) @@ -124,6 +133,9 @@ develOptions = Devel <$> switch ( long "disable-api" <> short 'd' <> help "Force rescan of files every N seconds" ) <*> optStr ( long "builddir" <> short 'b' <> help "Set custom cabal build directory, default `dist'") + <*> many ( strOption ( long "ignore" <> short 'i' <> metavar "DIR" + <> help "ignore file changes in DIR" ) + ) <*> extraCabalArgs extraCabalArgs :: Parser [String] diff --git a/yesod/yesod.cabal b/yesod/yesod.cabal index d7eb8069..5324f027 100644 --- a/yesod/yesod.cabal +++ b/yesod/yesod.cabal @@ -133,6 +133,7 @@ executable yesod , optparse-applicative >= 0.4 && < 0.5 , fsnotify >= 0.0 && < 0.1 , split >= 0.2 && < 0.3 + , lens >= 3.1 && < 4 ghc-options: -Wall -threaded main-is: main.hs