diff --git a/yesod-bin/AddHandler.hs b/yesod-bin/AddHandler.hs index 1d6d15cc..59da880e 100644 --- a/yesod-bin/AddHandler.hs +++ b/yesod-bin/AddHandler.hs @@ -2,61 +2,106 @@ module AddHandler (addHandler) where import Prelude hiding (readFile) -import System.IO (hFlush, stdout) -import Data.Char (isLower, toLower, isSpace) -import Data.List (isPrefixOf, isSuffixOf, stripPrefix) +import System.IO (hFlush, stdout) +import Data.Char (isLower, toLower, isSpace) +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 () -addHandler = do - allFiles <- getDirectoryContents "." - cabal <- - case filter (".cabal" `isSuffixOf`) allFiles of - [x] -> return x - [] -> error "No cabal file found" - _ -> error "Too many cabal files found" +cmdLineArgsError :: String +cmdLineArgsError = "You have to specify a route name if you want to add handler with command line arguments." +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 - [] -> error "No name entered. Quitting ..." - c:_ - | isLower c -> do - putStrLn "Name must start with an upper case letter" - routeInput - | otherwise -> do - -- Check that the handler file doesn't already exist - let handlerFile = concat ["Handler/", name, ".hs"] - 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) + checked <- checkRoute name + case checked of + Left err@EmptyRoute -> (error . show) err + Left err@RouteCaseError -> print err >> routeInput + Left err@(RouteExists _) -> do + print err + putStrLn "Try another name or leave blank to exit" + routeInput + Right p -> return p - (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 = diff --git a/yesod-bin/main.hs b/yesod-bin/main.hs index 968c52c5..8ecfca70 100755 --- a/yesod-bin/main.hs +++ b/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) - (progDesc "Add a new handler and module to the project")) + <> command "add-handler" (info addHandlerOptions + (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