duplo-1.8.0: src/CLI.hs
{-# LANGUAGE ScopedTypeVariables #-}
module Main where
import Control.Applicative ((<$>))
import Control.Exception (Exception, catch, handle,
throw)
import qualified Control.Lens as LS
import Control.Lens.Operators
import Control.Monad (unless, void, when)
import Data.ByteString.Base64 (decode)
import Data.ByteString.Char8 (pack, unpack)
import Data.List.Utils (replace)
import Data.Maybe (fromMaybe)
import Development.Duplo (build)
import qualified Development.Duplo.Component as CM
import Development.Duplo.Server (serve)
import qualified Development.Duplo.Types.AppInfo as AI
import qualified Development.Duplo.Types.Builder as TB
import qualified Development.Duplo.Types.Config as TC
import qualified Development.Duplo.Types.Options as OP
import Development.Duplo.Utilities (errorPrintSetter, logStatus)
import Development.Duplo.Watcher (watch)
import Development.Shake (ShakeException (..), cmd)
import Development.Shake.FilePath ((</>))
import qualified Filesystem.Path
import GHC.Conc (forkIO)
import qualified GHC.IO
import System.Console.GetOpt (ArgDescr (..), ArgOrder (..),
OptDescr (..), getOpt)
import System.Directory (createDirectoryIfMissing,
doesFileExist,
getCurrentDirectory)
import System.Environment (getArgs, getExecutablePath,
lookupEnv)
import System.FilePath.Posix (takeDirectory)
import System.Process (createProcess, proc,
waitForProcess)
main :: IO ()
main = do
-- Command-line arguments
args <- getArgs
let (cmdName:cmdArgs) =
if not (null args)
-- Normal case (with command name)
then args
-- Edge cases (with nothing provided)
else [""]
-- Deal with options
let (actions, nonOptions, errors) = getOpt Permute OP.options args
options <- foldl (>>=) (return OP.defaultOptions) actions
-- Port for running dev server
port <- fmap read $ fromMaybe "8888" <$> lookupEnv "PORT"
-- Environment - e.g. dev, staging, production
duploEnvMB <- lookupEnv "DUPLO_ENV"
-- Build mode, for dependency selection
duploMode <- fromMaybe "" <$> lookupEnv "DUPLO_MODE"
-- Application parameter
duploIn <- fromMaybe "" <$> lookupEnv "DUPLO_IN"
-- Current working directory
cwd <- getCurrentDirectory
-- Duplo directory, assuming this is a build cabal executable (i.e.
-- `./dist/build/duplo/duplo`)
duploPath <- fmap ((</> "../../../") . takeDirectory) getExecutablePath
-- Base64 decode
let duploInDecoded = case decode $ pack duploIn of
Left _ -> ""
Right input -> unpack input
-- Paths to various relevant directories
let nodeModulesPath = duploPath </> "node_modules/.bin/"
let utilPath = duploPath </> "util/"
let distPath = duploPath </> "dist/build/"
let miscPath = duploPath </> "etc/"
let defaultsPath = miscPath </> "static/"
let appPath = cwd </> "app/"
let devPath = cwd </> "dev/"
let testPath = cwd </> "tests/"
let assetsPath = appPath </> "assets/"
let depsPath = cwd </> "components/"
let targetPath = cwd </> "public/"
-- Extract environment
let duploEnv = case cmdName of
-- `build` is a special case. It takes `production` as the
-- default.
"build" -> fromMaybe "production" duploEnvMB
-- `dev` is the default.
_ -> fromMaybe "development" duploEnvMB
-- Internal command translation
let (cmdNameTranslated, bumpLevel, buildMode, toWatch) =
case cmdName of
"info" -> ( "version" , "" , duploEnv , False )
"ver" -> ( "version" , "" , duploEnv , False )
"new" -> ( "init" , "" , duploEnv , False )
"bump" -> ( "bump" , "patch" , duploEnv , False )
"release" -> ( "bump" , "patch" , duploEnv , False )
"patch" -> ( "bump" , "patch" , duploEnv , False )
"minor" -> ( "bump" , "minor" , duploEnv , False )
"major" -> ( "bump" , "major" , duploEnv , False )
"dev" -> ( "build" , "" , "development" , True )
"live" -> ( "build" , "" , "production" , True )
"production" -> ( "build" , "" , "production" , True )
"build" -> ( "build" , "" , duploEnv , False )
"test" -> ( "test" , "" , "test" , False )
_ -> ( cmdName , "" , duploEnv , False )
-- Certain flags turn into commands.
let cmdNameWithFlags = if OP.optVersion options
then "version"
else cmdNameTranslated
-- Display version either via command or option. We need to do this
-- before any `readManifest` as it throws an error when there isn't one,
-- as it should.
when (cmdNameWithFlags == "version") $ do
let command = utilPath </> "display-version.sh"
let process = createProcess $ proc command [duploPath]
-- Run the command.
(_, _, _, handle) <- process
-- Remember to do it synchronously.
void $ waitForProcess handle
-- We only care about exceptions thrown by the builder.
let ignoreManifestError' (e :: TB.BuilderException) = case e of
-- Only when missing manifest
TB.MissingManifestException _ -> return ""
-- Re-throw other builder exceptions.
_ -> throw e
-- Helper function to ignore exceptions, only for this stage, before
-- Shake is run.
let ignoreManifestError io = catch io ignoreManifestError'
-- Gather information about this project
appName <- ignoreManifestError $ fmap AI.name CM.readManifest
appVersion <- ignoreManifestError $ fmap AI.version CM.readManifest
appId <- ignoreManifestError $ fmap CM.appId CM.readManifest
-- Get all dependencies' names in dash-ified form
dependencies <- CM.getDependencies $ case duploMode of
"" -> Nothing
a -> Just a
let depIds = fmap (replace "/" "-") dependencies
-- Display additional information when verbose.
when (OP.optVerbose options) $
-- More info about where we are
putStr $ "\n"
++ ">> Current Directory\n"
++ "Application name : "
++ appName ++ "\n"
++ "Application version : "
++ appVersion ++ "\n"
++ "Component.IO repo ID : "
++ appId ++ "\n"
++ "Current working directory : "
++ cwd ++ "\n"
++ "duplo is installed at : "
++ duploPath ++ "\n"
-- Report back what's given for confirmation.
++ "\n"
++ ">> Environment Variables\n"
++ "DUPLO_ENV (runtime environment) : "
++ duploEnv ++ "\n"
++ "DUPLO_MODE (build mode) : "
++ duploMode ++ "\n"
++ "DUPLO_IN (app parameters) : "
++ duploInDecoded ++ "\n"
-- Construct environment
let buildConfig = TC.BuildConfig
{ TC._appName = appName
, TC._appVersion = appVersion
, TC._appId = appId
, TC._cwd = cwd
, TC._duploPath = duploPath
, TC._env = duploEnv
, TC._mode = duploMode
, TC._nodejsPath = nodeModulesPath
, TC._dist = distPath
, TC._input = duploIn
, TC._utilPath = utilPath
, TC._miscPath = miscPath
, TC._defaultsPath = defaultsPath
, TC._appPath = appPath
, TC._devPath = devPath
, TC._testPath = testPath
, TC._assetsPath = assetsPath
, TC._depsPath = depsPath
, TC._targetPath = targetPath
, TC._bumpLevel = bumpLevel
, TC._port = port
, TC._dependencies = depIds
, TC._buildMode = buildMode
}
-- If there is a Makefile, run that as well, with the environment as the
-- target (e.g. `duplo dev` would run `make development` and `duplo build` would
-- run `make production`).
makefileExists <- doesFileExist $ cwd </> "Makefile"
when makefileExists $ void $ createProcess $ proc "make" [duploEnv]
-- Construct the Shake command.
let shake' = build cmdNameWithFlags cmdArgs buildConfig options
let shake = shake' `catch` handleExc
-- We should start with a clean slate.
let noCleanActions = [ "clean", "bump", "init", "version" ]
unless (cmdNameWithFlags `elem` noCleanActions) $ build "clean" [] buildConfig options
-- Watch or just build.
unless toWatch shake
when toWatch $ do
-- Start a local server.
_ <- forkIO $ serve port
-- Only watch the dev and the app directories. We're not watching the
-- dependency directory because it triggers a race condition with
-- componentjs.
let targetDirs = [devPath, appPath]
-- Make sure we have these directories to watch.
mapM_ (createDirectoryIfMissing True) targetDirs
-- Watch for file changes.
watch shake targetDirs
-- | Handle all errors.
handleExc (e :: ShakeException) = do
putStr $ show e
logStatus errorPrintSetter "Build failed"
putStrLn ""