simple-0.7.0: src/smpl.hs

{-# 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.Applicative
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.Monoid (mempty)
import Data.Version
import System.Console.CmdArgs
import System.Directory
import System.FilePath
import System.Environment
import System.Exit
import System.SetEnv
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