yesod-bin 1.4.8 → 1.4.9
raw patch · 7 files changed
+111/−50 lines, 7 filesdep +deepseq
Dependencies added: deepseq
Files
- ChangeLog.md +4/−0
- Devel.hs +4/−1
- Scaffolding/Scaffolder.hs +85/−40
- input/project_name.cg +4/−0
- input/welcome.cg +0/−3
- main.hs +12/−5
- yesod-bin.cabal +2/−1
ChangeLog.md view
@@ -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
Devel.hs view
@@ -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
Scaffolding/Scaffolder.hs view
@@ -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)
+ input/project_name.cg view
@@ -0,0 +1,4 @@++What do you want to call your project? We'll use this for the cabal name.++Project name:
input/welcome.cg view
@@ -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:
main.hs view
@@ -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
yesod-bin.cabal view
@@ -1,5 +1,5 @@ name: yesod-bin-version: 1.4.8+version: 1.4.9 license: MIT license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>@@ -88,6 +88,7 @@ , streaming-commons , warp-tls >= 3.0.1 , async+ , deepseq ghc-options: -Wall -threaded -rtsopts main-is: main.hs