diff --git a/yesod/Options.hs b/yesod/Options.hs new file mode 100644 index 00000000..9bedbf08 --- /dev/null +++ b/yesod/Options.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +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 +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 +-- +-- 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 + 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)] +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 b@(BindP {}) = b + +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..3d6548ea 100755 --- a/yesod/main.hs +++ b/yesod/main.hs @@ -1,10 +1,11 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskell #-} +import Control.Lens hiding (value) 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 +14,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 @@ -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,33 +61,42 @@ data Command = Init | Version deriving (Show, Eq) -type Environment = [(String, String)] +makeLenses ''Options +makeLenses ''Command + +cabalCommand :: Options -> String +cabalCommand mopt + | mopt^.optCabalPgm == CabalDev = "cabal-dev" + | otherwise = "cabal" + main :: IO () main = do - env <- getEnvironment - o <- execParser (optParser' env) + 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' :: 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 +107,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 +122,21 @@ 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'") + <*> many ( strOption ( long "ignore" <> short 'i' <> metavar "DIR" + <> help "ignore file changes in DIR" ) + ) + <*> extraCabalArgs extraCabalArgs :: Parser [String] extraCabalArgs = many (strOption ( long "extra-cabal-arg" <> short 'e' <> metavar "ARG" @@ -138,12 +147,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 5a93cb88..df0c4f2c 100644 --- a/yesod/yesod.cabal +++ b/yesod/yesod.cabal @@ -133,6 +133,8 @@ executable yesod , yaml >= 0.8 && < 0.9 , 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 @@ -144,7 +146,7 @@ executable yesod Keter AddHandler Paths_yesod - + Options source-repository head type: git