From 067a21c60f498cd2c870399ae8bcca3f9fc831ac Mon Sep 17 00:00:00 2001 From: Ilya Smelkov Date: Sat, 9 May 2015 00:04:04 +0300 Subject: [PATCH 1/4] yesod init accepts app name --- yesod-bin/Scaffolding/Scaffolder.hs | 26 ++++++++++++++++++++------ yesod-bin/input/project_name.cg | 4 ++++ yesod-bin/input/welcome.cg | 3 --- yesod-bin/main.hs | 13 +++++++++---- 4 files changed, 33 insertions(+), 13 deletions(-) create mode 100644 yesod-bin/input/project_name.cg diff --git a/yesod-bin/Scaffolding/Scaffolder.hs b/yesod-bin/Scaffolding/Scaffolder.hs index ec2d1da2..c46e8c38 100644 --- a/yesod-bin/Scaffolding/Scaffolder.hs +++ b/yesod-bin/Scaffolding/Scaffolder.hs @@ -66,16 +66,14 @@ 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? + -> Maybe String -- ^ application name -> IO () -scaffold isBare = do +scaffold isBare appName = do puts $ renderTextUrl undefined $(textFile "input/welcome.cg") - project <- prompt $ \s -> - if validPackageName s && s /= "test" - then Just s - else Nothing + project <- projectName appName puts $ renderTextUrl undefined $(textFile "input/database.cg") @@ -106,3 +104,19 @@ scaffold isBare = do else LT.replace "PROJECTNAME" (LT.pack project) TLIO.putStr $ projectnameReplacer $ renderTextUrl undefined $(textFile "input/done.cg") + +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 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..b48c5ec6 100755 --- a/yesod-bin/main.hs +++ b/yesod-bin/main.hs @@ -41,7 +41,7 @@ data Options = Options } deriving (Show, Eq) -data Command = Init { _initBare :: Bool } +data Command = Init { _initBare :: Bool, _initName :: 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 bare name -> scaffold bare name 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,12 @@ 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") + keterOptions :: Parser Command keterOptions = Keter <$> switch ( long "nobuild" <> short 'n' <> help "Skip rebuilding" ) From ce268e451d2e9c64ff31853996ddc76b877da4a4 Mon Sep 17 00:00:00 2001 From: Ilya Smelkov Date: Sat, 9 May 2015 18:08:11 +0300 Subject: [PATCH 2/4] yesod init accepts database --- yesod-bin/Scaffolding/Scaffolder.hs | 77 +++++++++++++++++------------ yesod-bin/main.hs | 8 +-- 2 files changed, 51 insertions(+), 34 deletions(-) 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 From 50f0859e1318de765fefdfb7be0a546ba3a20b4f Mon Sep 17 00:00:00 2001 From: Ilya Smelkov Date: Sun, 10 May 2015 21:27:00 +0300 Subject: [PATCH 3/4] Validate input params before processing --- yesod-bin/Scaffolding/Scaffolder.hs | 103 +++++++++++++++------------- yesod-bin/yesod-bin.cabal | 1 + 2 files changed, 58 insertions(+), 46 deletions(-) diff --git a/yesod-bin/Scaffolding/Scaffolder.hs b/yesod-bin/Scaffolding/Scaffolder.hs index 80da3fa2..b0232043 100644 --- a/yesod-bin/Scaffolding/Scaffolder.hs +++ b/yesod-bin/Scaffolding/Scaffolder.hs @@ -5,7 +5,8 @@ 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 Data.String (fromString) import qualified Data.Text as T @@ -15,7 +16,7 @@ import Text.ProjectTemplate (unpackTemplate, receiveFS) import System.IO import Text.Shakespeare.Text (renderTextUrl, textFile) import Network.HTTP.Conduit (Request, withManager, http, parseUrl, responseBody) -import Data.Maybe (isJust, fromJust) +import Data.Maybe (isJust) import Data.List (intercalate) import Distribution.Text (simpleParse) import Distribution.Package (PackageName) @@ -30,6 +31,12 @@ prompt f = do hFlush stdout prompt f +data BackendInput = BIUrl + | BIBackend Backend + | BIUndefined + +instance NFData BackendInput + data Backend = Sqlite | Postgresql | PostgresqlFay @@ -85,53 +92,57 @@ scaffold :: Bool -- ^ bare directory instead of a new subdirectory? -> Maybe String -- ^ application name -> Maybe String -- ^ database -> IO () -scaffold isBare appName database = do - puts $ renderTextUrl undefined $(textFile "input/welcome.cg") - project <- projectName appName - ebackend <- projectDatabase database +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) - - 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 + requestUrl = 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 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." + 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/yesod-bin.cabal b/yesod-bin/yesod-bin.cabal index 8a32e974..dc266010 100644 --- a/yesod-bin/yesod-bin.cabal +++ b/yesod-bin/yesod-bin.cabal @@ -90,6 +90,7 @@ executable yesod , streaming-commons , warp-tls >= 3.0.1 , async + , deepseq ghc-options: -Wall -threaded -rtsopts main-is: main.hs From 3af842656771675d2bb7812b01e6adce55495b36 Mon Sep 17 00:00:00 2001 From: Ilya Smelkov Date: Wed, 13 May 2015 17:18:15 +0300 Subject: [PATCH 4/4] Add Generic typeclass to BackendInput and Backend --- yesod-bin/Scaffolding/Scaffolder.hs | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/yesod-bin/Scaffolding/Scaffolder.hs b/yesod-bin/Scaffolding/Scaffolder.hs index b0232043..2fadfd1f 100644 --- a/yesod-bin/Scaffolding/Scaffolder.hs +++ b/yesod-bin/Scaffolding/Scaffolder.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE TemplateHaskell #-} module Scaffolding.Scaffolder (scaffold, backendOptions) where @@ -8,6 +9,7 @@ import Data.Conduit (yield, ($$), ($$+-)) 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 @@ -34,6 +36,7 @@ prompt f = do data BackendInput = BIUrl | BIBackend Backend | BIUndefined + deriving (Generic) instance NFData BackendInput @@ -44,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