Validate input params before processing

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
+scaffold isBare appName appDatabase = (requestMissing $!! validatedInput) >>= unpack
-    puts $ renderTextUrl undefined $(textFile "input/welcome.cg")
+  where
-    project <- projectName appName
+    validatedInput :: (Maybe String, BackendInput)
-    ebackend <- projectDatabase database
+    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
+        backend :: BackendInput -> IO (Either Request Backend)
-                (receiveFS $ if isBare then "." else fromString project)
+        backend (BIBackend back) = return $ Right back
-                ( T.replace "PROJECTNAME" (T.pack project)
+        backend BIUndefined      = do
-                . T.replace "PROJECTNAME_LOWER" (T.toLower $ T.pack project)
+            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
+            case ebackend' of
-        Left req -> withManager $ \m -> do
+                Left ()    -> requestUrl
-            res <- http req m
+                Right back -> return $ Right back
-            responseBody res $$+- sink
+        backend BIUrl            = requestUrl
-        Right backend -> runResourceT $ yield (backendBS backend) $$ sink
 
-    let projectnameReplacer = if isBare
+        requestUrl = do
-                                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
             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
+    unpack :: (String, Either Request Backend) -> IO ()
-            -> IO String
+    unpack (project, ebackend) = do
-projectName Nothing = do
+        putStrLn "That's it! I'm creating your files now..."
-    puts $ renderTextUrl undefined $(textFile "input/project_name.cg")
+        case ebackend of
-    prompt $ \s -> if validPackageName s then Just s else Nothing
+            Left req -> withManager $ \m -> do
-projectName (Just name) | validPackageName name = return name
+                res <- http req m
-                        | otherwise             = error "Invalid value for --name option."
+                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)

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