{-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-} -- | The `smpl` utility for helping a user setup a Simple web project. module Main (main) where import Prelude hiding (writeFile, FilePath, all) import Control.Monad (when) import Data.Aeson import Data.Char import qualified Data.ByteString.Char8 as S8 import qualified Data.Text.Encoding as T import Data.Version import System.Console.CmdArgs import System.Directory import System.FilePath import System.Environment (getEnvironment) import System.SetEnv (setEnv) import System.Exit import System.Process import Web.Simple.Templates.Language import Paths_simple data Smpl = Server { port :: Int , moduleName :: String } | Create { appDir :: FilePath , includeTemplates :: Bool , includePostgresql :: Bool , includeSessions :: Bool , includeAll :: Bool } deriving (Show, Data, Typeable) main :: IO () main = do setEnv "ENV" "development" myenv <- getEnvironment let myport = maybe 3000 read $ lookup "PORT" myenv let develModes = modes [ Server { port = myport &= typ "PORT" , moduleName = "Application" &= typ "MODULE" &= explicit &= name "module" } &= auto &= help "Run a development server" &= details [ "You must have wai-handler-devel installed " ++ "to run this command"] , Create { appDir = "" &= argPos 0 &= typ "app_dir" , includeTemplates = False &= help "include templates" &= explicit &= name "templates" &= groupname "Plugins" , includePostgresql = False &= help "include postgresql-orm" &= explicit &= name "postgresql" , includeSessions = False &= help "include cookie-based sessions" &= explicit &= name "sessions" , includeAll = False &= help ("include templates, cookie-based " ++ "sessions and postgresql") &= explicit &= name "all"} &= help "Create a new application in app_dir"] smpl <- cmdArgsRun $ cmdArgsMode $ develModes &= (summary $ "Simple web framework " ++ (showVersion version)) case smpl of Server p m -> do exitCode <- rawSystem "wai-handler-devel" [show p, m, "app"] case exitCode of ExitFailure 127 -> do putStrLn "You must install wai-handler devel first" exitWith $ ExitFailure 1 _ -> exitWith exitCode Create dir tmpls pg sess all -> createApplication dir (all || tmpls) (all || sess) (all || pg) humanize :: String -> String humanize = capitalize where go [] = [] go ('_':xs) = ' ':(capitalize xs) go (x:xs) = x:(go xs) capitalize [] = [] capitalize x@('_':_) = go x capitalize (x:xs) = (toUpper x):(go xs) moduleCase :: String -> String moduleCase = capitalize where go [] = [] go ('_':xs) = capitalize xs go (x:xs) = x:(go xs) capitalize [] = [] capitalize ('_':xs) = go xs capitalize (x:xs) = (toUpper x):(go xs) createApplication :: FilePath -> Bool -> Bool -> Bool -> IO () createApplication dir tmpls sessions postgresql = do let myAppName = takeBaseName $ dropTrailingPathSeparator dir modName = moduleCase myAppName mappings = object [ "appname" .= myAppName , "name" .= humanize myAppName , "module" .= modName , "include_templates" .= tmpls , "include_sessions" .= sessions , "include_postgresql" .= postgresql] createDirectory dir createDirectory $ dir modName copyTemplate ("template" "Main_hs.tmpl") (dir "Main.hs") mappings copyTemplate ("template" "Application_hs.tmpl") (dir "Application.hs") mappings copyTemplate ("template" "package_cabal.tmpl") (dir myAppName ++ ".cabal") mappings copyTemplate ("template" "Common_hs.tmpl") (dir modName "Common.hs") mappings when postgresql $ do createDirectory $ dir "db" createDirectory $ dir "db" "migrations" when tmpls $ do createDirectory $ dir "views" createDirectory $ dir "layouts" copyTemplate ("template" "main_html.tmpl") (dir "layouts" "main.html") mappings copyTemplate ("template" "index_html.tmpl") (dir "views" "index.html") mappings copyTemplate :: FilePath -> FilePath -> Value -> IO () copyTemplate orig target mappings = do etmpl <- compileTemplate <$> T.decodeUtf8 <$> (S8.readFile =<< getDataFileName orig) case etmpl of Left err -> fail err Right tmpl -> S8.writeFile target $ T.encodeUtf8 $ renderTemplate tmpl mempty mappings