Added command-line args option to yesod-bin add-handler (resolves #892)

yesod-bin/AddHandler.hs

@@ -2,61 +2,106 @@
 module AddHandler (addHandler) where
 
 import Prelude hiding (readFile)
-import System.IO (hFlush, stdout)
+import System.IO  (hFlush, stdout)
-import Data.Char (isLower, toLower, isSpace)
+import Data.Char  (isLower, toLower, isSpace)
-import Data.List (isPrefixOf, isSuffixOf, stripPrefix)
+import Data.List  (isPrefixOf, isSuffixOf, stripPrefix)
+import Data.Maybe (fromMaybe)
 import qualified Data.Text as T
 import qualified Data.Text.IO as TIO
 import System.Directory (getDirectoryContents, doesFileExist)
 
+data RouteError = EmptyRoute
+                | RouteCaseError
+                | RouteExists FilePath
+                deriving Eq
+
+instance Show RouteError where
+    show EmptyRoute         = "No name entered. Quitting ..."
+    show RouteCaseError     = "Name must start with an upper case letter"
+    show (RouteExists file) = "File already exists: " ++ file
+
 -- strict readFile
 readFile :: FilePath -> IO String
 readFile = fmap T.unpack . TIO.readFile
 
-addHandler :: IO ()
+cmdLineArgsError :: String
-addHandler = do
+cmdLineArgsError = "You have to specify a route name if you want to add handler with command line arguments."
-    allFiles <- getDirectoryContents "."
-    cabal <-
-        case filter (".cabal" `isSuffixOf`) allFiles of
-            [x] -> return x
-            [] -> error "No cabal file found"
-            _ -> error "Too many cabal files found"
 
+addHandler :: Maybe String -> Maybe String -> [String] -> IO ()
+addHandler (Just route) pat met = do
+    cabal <- getCabal
+    checked <- checkRoute route
+    let routePair = case checked of
+          Left err@EmptyRoute -> (error . show) err
+          Left err@RouteCaseError -> (error . show) err
+          Left err@(RouteExists _) -> (error . show) err
+          Right p -> p
+
+    addHandlerFiles cabal routePair pattern methods
+  where
+    pattern = fromMaybe "" pat -- pattern defaults to ""
+    methods = unwords met      -- methods default to none
+
+addHandler Nothing (Just _) _ = error cmdLineArgsError
+addHandler Nothing _ (_:_)    = error cmdLineArgsError
+addHandler _ _ _ = addHandlerInteractive
+
+addHandlerInteractive :: IO ()
+addHandlerInteractive = do
+    cabal <- getCabal
     let routeInput = do
         putStr "Name of route (without trailing R): "
         hFlush stdout
         name <- getLine
-        case name of
+        checked <- checkRoute name
-            [] -> error "No name entered. Quitting ..."
+        case checked of
-            c:_
+            Left err@EmptyRoute -> (error . show) err
-                | isLower c -> do
+            Left err@RouteCaseError -> print err >> routeInput
-                    putStrLn "Name must start with an upper case letter"
+            Left err@(RouteExists _) -> do
-                    routeInput
+              print err
-                | otherwise -> do
+              putStrLn "Try another name or leave blank to exit"
-                    -- Check that the handler file doesn't already exist
+              routeInput
-                    let handlerFile = concat ["Handler/", name, ".hs"]
+            Right p -> return p
-                    exists <- doesFileExist handlerFile
-                    if exists
-                        then do
-                            putStrLn $ "File already exists: " ++ show handlerFile
-                            putStrLn "Try another name or leave blank to exit"
-                            routeInput
-                        else return (name, handlerFile)
 
-    (name, handlerFile) <- routeInput
+    routePair <- routeInput
     putStr "Enter route pattern (ex: /entry/#EntryId): "
     hFlush stdout
     pattern <- getLine
     putStr "Enter space-separated list of methods (ex: GET POST): "
     hFlush stdout
     methods <- getLine
+    addHandlerFiles cabal routePair pattern methods
 
-    let modify fp f = readFile fp >>= writeFile fp . f
+addHandlerFiles :: FilePath -> (String, FilePath) -> String -> String -> IO ()
-
+addHandlerFiles cabal (name, handlerFile) pattern methods = do
     modify "Application.hs" $ fixApp name
     modify cabal $ fixCabal name
     modify "config/routes" $ fixRoutes name pattern methods
     writeFile handlerFile $ mkHandler name pattern methods
+  where
+    modify fp f = readFile fp >>= writeFile fp . f
+
+getCabal :: IO FilePath
+getCabal = do
+    allFiles <- getDirectoryContents "."
+    case filter (".cabal" `isSuffixOf`) allFiles of
+        [x] -> return x
+        [] -> error "No cabal file found"
+        _ -> error "Too many cabal files found"
+
+checkRoute :: String -> IO (Either RouteError (String, FilePath))
+checkRoute name =
+    case name of
+        [] -> return $ Left EmptyRoute
+        c:_
+            | isLower c -> return $ Left RouteCaseError
+            | otherwise -> do
+                -- Check that the handler file doesn't already exist
+                let handlerFile = concat ["Handler/", name, ".hs"]
+                exists <- doesFileExist handlerFile
+                if exists
+                    then (return . Left . RouteExists) handlerFile
+                    else return $ Right (name, handlerFile)
 
 fixApp :: String -> String -> String
 fixApp name =

yesod-bin/main.hs

@@ -60,6 +60,10 @@ data Command = Init { _initBare :: Bool }
                      }
              | Test
              | AddHandler
+                    { addHandlerRoute   :: Maybe String
+                    , addHandlerPattern :: Maybe String
+                    , addHandlerMethods :: [String]
+                    }
              | Keter
                     { _keterNoRebuild :: Bool
                     , _keterNoCopyTo  :: Bool
@@ -101,7 +105,7 @@ main = do
     Touch           -> touch'
     Keter{..}       -> keter (cabalCommand o) _keterNoRebuild _keterNoCopyTo
     Version         -> putStrLn ("yesod-bin version: " ++ showVersion Paths_yesod_bin.version)
-    AddHandler      -> addHandler
+    AddHandler{..}  -> addHandler addHandlerRoute addHandlerPattern addHandlerMethods
     Test            -> cabalTest cabal
     Devel{..}       -> devel (DevelOpts
                               (optCabalPgm o == CabalDev) _develDisableApi (optVerbose o)
@@ -138,8 +142,9 @@ optParser = Options
                             (progDesc "Run project with the devel server"))
                       <> command "test"      (info (pure Test)
                             (progDesc "Build and run the integration tests"))
-                      <> command "add-handler" (info (pure AddHandler)
+                      <> command "add-handler" (info addHandlerOptions
-                            (progDesc "Add a new handler and module to the project"))
+                            (progDesc ("Add a new handler and module to the project."
+                            ++ " Interactively asks for input if you do not specify arguments.")))
                       <> command "keter"       (info keterOptions
                             (progDesc "Build a keter bundle"))
                       <> command "version"     (info (pure Version)
@@ -185,6 +190,16 @@ extraCabalArgs = many (strOption ( long "extra-cabal-arg" <> short 'e' <> metava
                                    <> help "pass extra argument ARG to cabal")
                       )
 
+addHandlerOptions :: Parser Command
+addHandlerOptions = AddHandler
+    <$> optStr ( long "route" <> short 'r' <> metavar "ROUTE"
+           <> help "Name of route (without trailing R). Required.")
+    <*> optStr ( long "pattern" <> short 'p' <> metavar "PATTERN"
+           <> help "Route pattern (ex: /entry/#EntryId). Defaults to \"\".")
+    <*> many (strOption ( long "method" <> short 'm' <> metavar "METHOD"
+                 <> help "Takes one method. Use this multiple times to add multiple methods. Defaults to none.")
+             )
+
 -- | Optional @String@ argument
 optStr :: Mod OptionFields (Maybe String) -> Parser (Maybe String)
 optStr m = option (Just <$> str) $ value Nothing <> m