Merge branch 'yesod_init_args' of https://github.com/triplepointfive/yesod

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
+inputBackend :: Backend -> String
-readBackend s = lookup s $ map (showBackend &&& id) backends
+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
+scaffold isBare appName appDatabase = (requestMissing $!! validatedInput) >>= unpack
-    puts $ renderTextUrl undefined $(textFile "input/welcome.cg")
+  where
-    project <- prompt $ \s ->
+    validatedInput :: (Maybe String, BackendInput)
-        if validPackageName s && s /= "test"
+    validatedInput = (name, db)
-            then Just s
+      where
-            else Nothing
+        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 <-
+        requestUrl = do
-        case ebackend' of
+            puts "Please enter the URL:  "
-            Left () -> do
+            fmap Left $ prompt parseUrl
-                puts "Please enter the URL:  "
-                fmap Left $ prompt parseUrl
-            Right backend -> return $ Right backend
 
-    putStrLn "That's it! I'm creating your files now..."
+    unpack :: (String, Either Request Backend) -> IO ()
-
+    unpack (project, ebackend) = do
-    let sink = unpackTemplate
+        putStrLn "That's it! I'm creating your files now..."
-                (receiveFS $ if isBare then "." else fromString project)
+        case ebackend of
-                ( T.replace "PROJECTNAME" (T.pack project)
+            Left req -> withManager $ \m -> do
-                . T.replace "PROJECTNAME_LOWER" (T.toLower $ T.pack project)
+                res <- http req m
-                )
+                responseBody res $$+- sink
-    case ebackend of
+            Right backend -> runResourceT $ yield (backendBS backend) $$ sink
-        Left req -> withManager $ \m -> do
+        TLIO.putStr $ projectnameReplacer $ renderTextUrl undefined $(textFile "input/done.cg")
-            res <- http req m
+      where
-            responseBody res $$+- sink
+        sink = unpackTemplate
-        Right backend -> runResourceT $ yield (backendBS backend) $$ sink
+                 (receiveFS $ if isBare then "." else fromString project)
-
+                 ( T.replace "PROJECTNAME" (T.pack project)
-    let projectnameReplacer = if isBare
+                 . T.replace "PROJECTNAME_LOWER" (T.toLower $ T.pack project)
-                                then LT.replace "cd PROJECTNAME && " ""
+                 )
-                                else LT.replace "PROJECTNAME" (LT.pack project)
+        projectnameReplacer = if isBare
-
+                              then LT.replace "cd PROJECTNAME && " ""
-    TLIO.putStr $ projectnameReplacer $ renderTextUrl undefined $(textFile "input/done.cg")
+                              else LT.replace "PROJECTNAME" (LT.pack project)

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: 

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: 

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"
+        <*> subparser ( command "init"         (info initOptions
-                            (info (Init <$> (switch (long "bare" <> help "Create files in current folder")))
                             (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" )

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