simple-1.0.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.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