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