diff --git a/yesod-bin/Scaffolding/Scaffolder.hs b/yesod-bin/Scaffolding/Scaffolder.hs index ec2d1da2..2fadfd1f 100644 --- a/yesod-bin/Scaffolding/Scaffolder.hs +++ b/yesod-bin/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 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 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 @@ prompt f = do hFlush stdout prompt f +data BackendInput = BIUrl + | BIBackend Backend + | BIUndefined + deriving (Generic) + +instance NFData BackendInput + data Backend = Sqlite | Postgresql | PostgresqlFay @@ -36,7 +47,9 @@ data Backend = Sqlite | 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 @@ -44,6 +57,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 +69,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") @@ -66,43 +91,63 @@ backendBS Simple = $(embedFile "hsfiles/simple.hsfiles") 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 +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) - puts $ renderTextUrl undefined $(textFile "input/database.cg") + 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 - ebackend' <- prompt $ \s -> if s == "url" then Just (Left ()) else fmap Right $ readBackend s + 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 - ebackend <- - case ebackend' of - Left () -> do - puts "Please enter the URL: " - fmap Left $ prompt parseUrl - Right backend -> return $ Right backend + requestUrl = do + puts "Please enter the URL: " + fmap Left $ prompt parseUrl - putStrLn "That's it! I'm creating your files now..." - - 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 - - let projectnameReplacer = if isBare - then LT.replace "cd PROJECTNAME && " "" - else LT.replace "PROJECTNAME" (LT.pack project) - - 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/yesod-bin/input/project_name.cg b/yesod-bin/input/project_name.cg new file mode 100644 index 00000000..f5f25e85 --- /dev/null +++ b/yesod-bin/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/yesod-bin/input/welcome.cg b/yesod-bin/input/welcome.cg index efff79c0..ab9e1d8e 100644 --- a/yesod-bin/input/welcome.cg +++ b/yesod-bin/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/yesod-bin/main.hs b/yesod-bin/main.hs index a241c262..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 } +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 -> scaffold bare + Init{..} -> scaffold _initBare _initName _initDatabase HsFiles -> mkHsFile Configure -> cabal ["configure"] Build es -> touch' >> cabal ("build":es) @@ -136,8 +136,7 @@ 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 (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")) @@ -160,6 +159,14 @@ optParser = Options (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 <$> switch ( long "nobuild" <> short 'n' <> help "Skip rebuilding" ) diff --git a/yesod-bin/yesod-bin.cabal b/yesod-bin/yesod-bin.cabal index 434080ec..d9f036ee 100644 --- a/yesod-bin/yesod-bin.cabal +++ b/yesod-bin/yesod-bin.cabal @@ -88,6 +88,7 @@ executable yesod , streaming-commons , warp-tls >= 3.0.1 , async + , deepseq ghc-options: -Wall -threaded -rtsopts main-is: main.hs