diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,7 @@ +## 1.4.9 + +* Command line options for `yesod init` [#986](https://github.com/yesodweb/yesod/pull/986) + ## 1.4.8 * Drop system-filepath diff --git a/Devel.hs b/Devel.hs --- a/Devel.hs +++ b/Devel.hs @@ -191,7 +191,10 @@ putStrLn $ "If you wish to test https capabilities, you should set the following variable:" putStrLn $ " export APPROOT=https://127.0.0.1:" ++ show (develTlsPort opts) putStrLn "" - loop (race_ httpProxy httpsProxy) `Ex.onException` exitFailure + loop (race_ httpProxy httpsProxy) `Ex.catch` \e -> do + print (e :: Ex.SomeException) + exitFailure + Ex.throwIO e -- heh, just for good measure where loop proxies = forever $ do void proxies diff --git a/Scaffolding/Scaffolder.hs b/Scaffolding/Scaffolder.hs --- a/Scaffolding/Scaffolder.hs +++ b/Scaffolding/Scaffolder.hs @@ -1,12 +1,15 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE TemplateHaskell #-} -module Scaffolding.Scaffolder (scaffold) where +module Scaffolding.Scaffolder (scaffold, backendOptions) where import Control.Arrow ((&&&)) import qualified Data.ByteString.Char8 as S import Data.Conduit (yield, ($$), ($$+-)) -import Control.Monad.Trans.Resource (runResourceT) +import Control.Monad.Trans.Resource (runResourceT) +import Control.DeepSeq (($!!), NFData) import Data.FileEmbed (embedFile) +import GHC.Generics (Generic) import Data.String (fromString) import qualified Data.Text as T import qualified Data.Text.Lazy as LT @@ -14,8 +17,9 @@ import Text.ProjectTemplate (unpackTemplate, receiveFS) import System.IO import Text.Shakespeare.Text (renderTextUrl, textFile) -import Network.HTTP.Conduit (withManager, http, parseUrl, responseBody) +import Network.HTTP.Conduit (Request, withManager, http, parseUrl, responseBody) import Data.Maybe (isJust) +import Data.List (intercalate) import Distribution.Text (simpleParse) import Distribution.Package (PackageName) @@ -29,6 +33,13 @@ hFlush stdout prompt f +data BackendInput = BIUrl + | BIBackend Backend + | BIUndefined + deriving (Generic) + +instance NFData BackendInput + data Backend = Sqlite | Postgresql | PostgresqlFay @@ -36,14 +47,19 @@ | MongoDB | Simple | Minimal - deriving (Eq, Read, Show, Enum, Bounded) + deriving (Eq, Read, Show, Enum, Bounded, Generic) +instance NFData Backend + puts :: LT.Text -> IO () puts s = TLIO.putStr (LT.init s) >> hFlush stdout backends :: [Backend] backends = [minBound .. maxBound] +backendOptions :: String +backendOptions = intercalate "/" (map inputBackend backends) + showBackend :: Backend -> String showBackend Sqlite = "s" showBackend Postgresql = "p" @@ -53,9 +69,18 @@ showBackend Simple = "simple" showBackend Minimal = "mini" -readBackend :: String -> Maybe Backend -readBackend s = lookup s $ map (showBackend &&& id) backends +inputBackend :: Backend -> String +inputBackend Sqlite = "sqlite" +inputBackend Postgresql = "postgresql" +inputBackend PostgresqlFay = "postgresql_fay" +inputBackend Mysql = "mysql" +inputBackend MongoDB = "mongo" +inputBackend Simple = "simple" +inputBackend Minimal = "mini" +readBackend :: (Backend -> String) -> String -> Maybe Backend +readBackend f s = lookup s $ map (f &&& id) backends + backendBS :: Backend -> S.ByteString backendBS Sqlite = $(embedFile "hsfiles/sqlite.hsfiles") backendBS Postgresql = $(embedFile "hsfiles/postgres.hsfiles") @@ -66,43 +91,63 @@ backendBS Minimal = $(embedFile "hsfiles/minimal.hsfiles") validPackageName :: String -> Bool -validPackageName s = isJust (simpleParse s :: Maybe PackageName) +validPackageName s = isJust (simpleParse s :: Maybe PackageName) && s /= "test" -scaffold :: Bool -- ^ bare directory instead of a new subdirectory? +scaffold :: Bool -- ^ bare directory instead of a new subdirectory? + -> Maybe String -- ^ application name + -> Maybe String -- ^ database -> IO () -scaffold isBare = do - puts $ renderTextUrl undefined $(textFile "input/welcome.cg") - project <- prompt $ \s -> - if validPackageName s && s /= "test" - then Just s - else Nothing - - puts $ renderTextUrl undefined $(textFile "input/database.cg") - - ebackend' <- prompt $ \s -> if s == "url" then Just (Left ()) else fmap Right $ readBackend s - - ebackend <- - case ebackend' of - Left () -> do - puts "Please enter the URL: " - fmap Left $ prompt parseUrl - Right backend -> return $ Right backend +scaffold isBare appName appDatabase = (requestMissing $!! validatedInput) >>= unpack + where + validatedInput :: (Maybe String, BackendInput) + validatedInput = (name, db) + where + name = fmap (\ s -> if validPackageName s then s else error "Invalid value for --name option.") appName + db = maybe BIUndefined validateDB appDatabase + where + validateDB "url" = BIUrl + validateDB s = maybe (error "Invalid value for --database option.") BIBackend (readBackend inputBackend s) - putStrLn "That's it! I'm creating your files now..." + requestMissing :: (Maybe String, BackendInput) -> IO (String, Either Request Backend) + requestMissing (name, database) = do + puts $ renderTextUrl undefined $(textFile "input/welcome.cg") + project <- maybe promptName return name + ebackend <- backend database + return (project, ebackend) + where + promptName = do + puts $ renderTextUrl undefined $(textFile "input/project_name.cg") + prompt $ \s -> if validPackageName s then Just s else Nothing - let sink = unpackTemplate - (receiveFS $ if isBare then "." else fromString project) - ( T.replace "PROJECTNAME" (T.pack project) - . T.replace "PROJECTNAME_LOWER" (T.toLower $ T.pack project) - ) - case ebackend of - Left req -> withManager $ \m -> do - res <- http req m - responseBody res $$+- sink - Right backend -> runResourceT $ yield (backendBS backend) $$ sink + backend :: BackendInput -> IO (Either Request Backend) + backend (BIBackend back) = return $ Right back + backend BIUndefined = do + puts $ renderTextUrl undefined $(textFile "input/database.cg") + ebackend' <- prompt $ \s -> if s == "url" then Just (Left ()) else fmap Right $ readBackend showBackend s + case ebackend' of + Left () -> requestUrl + Right back -> return $ Right back + backend BIUrl = requestUrl - let projectnameReplacer = if isBare - then LT.replace "cd PROJECTNAME && " "" - else LT.replace "PROJECTNAME" (LT.pack project) + requestUrl = do + puts "Please enter the URL: " + fmap Left $ prompt parseUrl - TLIO.putStr $ projectnameReplacer $ renderTextUrl undefined $(textFile "input/done.cg") + unpack :: (String, Either Request Backend) -> IO () + unpack (project, ebackend) = do + putStrLn "That's it! I'm creating your files now..." + case ebackend of + Left req -> withManager $ \m -> do + res <- http req m + responseBody res $$+- sink + Right backend -> runResourceT $ yield (backendBS backend) $$ sink + TLIO.putStr $ projectnameReplacer $ renderTextUrl undefined $(textFile "input/done.cg") + where + sink = unpackTemplate + (receiveFS $ if isBare then "." else fromString project) + ( T.replace "PROJECTNAME" (T.pack project) + . T.replace "PROJECTNAME_LOWER" (T.toLower $ T.pack project) + ) + projectnameReplacer = if isBare + then LT.replace "cd PROJECTNAME && " "" + else LT.replace "PROJECTNAME" (LT.pack project) diff --git a/input/project_name.cg b/input/project_name.cg new file mode 100644 --- /dev/null +++ b/input/project_name.cg @@ -0,0 +1,4 @@ + +What do you want to call your project? We'll use this for the cabal name. + +Project name: diff --git a/input/welcome.cg b/input/welcome.cg --- a/input/welcome.cg +++ b/input/welcome.cg @@ -1,6 +1,3 @@ Welcome to the Yesod scaffolder. I'm going to be creating a skeleton Yesod project for you. -What do you want to call your project? We'll use this for the cabal name. - -Project name: diff --git a/main.hs b/main.hs --- a/main.hs +++ b/main.hs @@ -13,7 +13,7 @@ import Keter (keter) import Options (injectDefaults) import qualified Paths_yesod_bin -import Scaffolding.Scaffolder +import Scaffolding.Scaffolder (scaffold, backendOptions) import HsFile (mkHsFile) #ifndef WINDOWS @@ -41,7 +41,7 @@ } deriving (Show, Eq) -data Command = Init { _initBare :: Bool } +data Command = Init { _initBare :: Bool, _initName :: Maybe String, _initDatabase :: Maybe String } | HsFiles | Configure | Build { buildExtraArgs :: [String] } @@ -99,7 +99,7 @@ ] optParser' let cabal = rawSystem' (cabalCommand o) case optCommand o of - Init bare -> scaffold bare + Init{..} -> scaffold _initBare _initName _initDatabase HsFiles -> mkHsFile Configure -> cabal ["configure"] Build es -> touch' >> cabal ("build":es) @@ -136,8 +136,7 @@ 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 (Init <$> (switch (long "bare" <> help "Create files in current folder"))) + <*> subparser ( command "init" (info initOptions (progDesc "Scaffold a new site")) <> command "hsfiles" (info (pure HsFiles) (progDesc "Create a hsfiles file for the current folder")) @@ -159,6 +158,14 @@ <> command "version" (info (pure Version) (progDesc "Print the version of Yesod")) ) + +initOptions :: Parser Command +initOptions = Init + <$> switch (long "bare" <> help "Create files in current folder") + <*> optStr (long "name" <> short 'n' <> metavar "APP_NAME" + <> help "Set the application name") + <*> optStr (long "database" <> short 'd' <> metavar "DATABASE" + <> help ("Preconfigure for selected database (options: " ++ backendOptions ++ ")")) keterOptions :: Parser Command keterOptions = Keter diff --git a/yesod-bin.cabal b/yesod-bin.cabal --- a/yesod-bin.cabal +++ b/yesod-bin.cabal @@ -1,5 +1,5 @@ name: yesod-bin -version: 1.4.8 +version: 1.4.9 license: MIT license-file: LICENSE author: Michael Snoyman @@ -88,6 +88,7 @@ , streaming-commons , warp-tls >= 3.0.1 , async + , deepseq ghc-options: -Wall -threaded -rtsopts main-is: main.hs