diff --git a/yesod-bin/Scaffolding/Scaffolder.hs b/yesod-bin/Scaffolding/Scaffolder.hs index c46e8c38..80da3fa2 100644 --- a/yesod-bin/Scaffolding/Scaffolder.hs +++ b/yesod-bin/Scaffolding/Scaffolder.hs @@ -1,6 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} -module Scaffolding.Scaffolder (scaffold) where +module Scaffolding.Scaffolder (scaffold, backendOptions) where import Control.Arrow ((&&&)) import qualified Data.ByteString.Char8 as S @@ -14,8 +14,9 @@ import qualified Data.Text.Lazy.IO as TLIO import Text.ProjectTemplate (unpackTemplate, receiveFS) import System.IO import Text.Shakespeare.Text (renderTextUrl, textFile) -import Network.HTTP.Conduit (withManager, http, parseUrl, responseBody) -import Data.Maybe (isJust) +import Network.HTTP.Conduit (Request, withManager, http, parseUrl, responseBody) +import Data.Maybe (isJust, fromJust) +import Data.List (intercalate) import Distribution.Text (simpleParse) import Distribution.Package (PackageName) @@ -44,6 +45,9 @@ 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,8 +57,17 @@ showBackend MongoDB = "mongo" 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") @@ -68,23 +81,14 @@ backendBS Minimal = $(embedFile "hsfiles/minimal.hsfiles") validPackageName :: String -> Bool 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 appName = do +scaffold isBare appName database = do puts $ renderTextUrl undefined $(textFile "input/welcome.cg") project <- projectName appName - - 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 + ebackend <- projectDatabase database putStrLn "That's it! I'm creating your files now..." @@ -105,18 +109,29 @@ scaffold isBare appName = do TLIO.putStr $ projectnameReplacer $ renderTextUrl undefined $(textFile "input/done.cg") +projectDatabase :: Maybe String -- ^ database + -> IO (Either Request Backend) +projectDatabase Nothing = 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 () -> do + puts "Please enter the URL: " + fmap Left $ prompt parseUrl + Right backend -> return $ Right backend +projectDatabase (Just db) + | "url" == db = do + puts "Please enter the URL: " + fmap Left $ prompt parseUrl + | isJust parsedDB = return $ Right (fromJust parsedDB) + | otherwise = error "Invalid value for --database option." + where + parsedDB = readBackend inputBackend db + projectName :: Maybe String -- ^ application name -> IO String -projectName appName = case appName of - Nothing -> askForProjectName - Just name -> - if validPackageName name - then return name - else do - putStr "Given application name is not valid, please choose another one" - hFlush stdout - askForProjectName - where - askForProjectName = do - puts $ renderTextUrl undefined $(textFile "input/project_name.cg") - prompt $ \s -> if validPackageName s then Just s else Nothing +projectName Nothing = do + puts $ renderTextUrl undefined $(textFile "input/project_name.cg") + prompt $ \s -> if validPackageName s then Just s else Nothing +projectName (Just name) | validPackageName name = return name + | otherwise = error "Invalid value for --name option." diff --git a/yesod-bin/main.hs b/yesod-bin/main.hs index b48c5ec6..b8169131 100755 --- a/yesod-bin/main.hs +++ b/yesod-bin/main.hs @@ -13,7 +13,7 @@ import Devel (DevelOpts (..), devel, DevelTermOpt(..) 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 @@ data Options = Options } deriving (Show, Eq) -data Command = Init { _initBare :: Bool, _initName :: Maybe String } +data Command = Init { _initBare :: Bool, _initName :: Maybe String, _initDatabase :: Maybe String } | HsFiles | Configure | Build { buildExtraArgs :: [String] } @@ -99,7 +99,7 @@ main = do ] optParser' let cabal = rawSystem' (cabalCommand o) case optCommand o of - Init bare name -> scaffold bare name + Init{..} -> scaffold _initBare _initName _initDatabase HsFiles -> mkHsFile Configure -> cabal ["configure"] Build es -> touch' >> cabal ("build":es) @@ -164,6 +164,8 @@ 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