Validate input params before processing

yesod-bin/Scaffolding/Scaffolder.hs

@@ -6,6 +6,7 @@ import           Control.Arrow         ((&&&))
 import qualified Data.ByteString.Char8 as S
 import           Data.Conduit          (yield, ($$), ($$+-))
 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
+  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)
+
+    requestMissing :: (Maybe String, BackendInput) -> IO (String, Either Request Backend)
+    requestMissing (name, database) = do
         puts $ renderTextUrl undefined $(textFile "input/welcome.cg")
-    project <- projectName appName
+        project <- maybe promptName return name
-    ebackend <- projectDatabase database
+        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
 
+        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
+
+        requestUrl = do
+            puts "Please enter the URL:  "
+            fmap Left $ prompt parseUrl
+
+    unpack :: (String, Either Request Backend) -> IO ()
+    unpack (project, ebackend) = do
         putStrLn "That's it! I'm creating your files now..."
-
-    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
-
+        TLIO.putStr $ projectnameReplacer $ renderTextUrl undefined $(textFile "input/done.cg")
-    let projectnameReplacer = if isBare
+      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)
-
-    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 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."

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