diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -17,8 +17,11 @@ If "cabal" sounds more familiar: -1. `cabal install alex`. This must be run globally. -2. `cabal install duplo`. This can be run in a sandbox. +```sh +$ git clone git@github.com:pixbi/duplo.git +$ cd duplo +$ cabal install +``` ## Usage diff --git a/duplo.cabal b/duplo.cabal --- a/duplo.cabal +++ b/duplo.cabal @@ -1,31 +1,86 @@ -name: duplo -version: 1.6.6 -synopsis: Frontend development build tool -description: Intuitive, simple building blocks for building composable, completely self-managed web applications -license: MIT -license-file: LICENSE -author: Kenneth Kan -maintainer: ken@pixbi.com -category: Web -build-type: Simple -extra-source-files: README.md -cabal-version: >=1.10 +name: duplo +version: 1.6.9 +synopsis: Frontend development build tool +description: Intuitive, simple building blocks for building composable, completely self-managed web applications +license: MIT +license-file: LICENSE +author: Kenneth Kan +maintainer: ken@pixbi.com +category: Web +build-type: Simple +extra-source-files: README.md tests/Tests.hs +cabal-version: >=1.10 source-repository head - type: git - location: https://github.com/pixbi/duplo.git + type: git + location: https://github.com/pixbi/duplo.git +library + ghc-options : -Wall + hs-source-dirs : src + default-language : Haskell2010 + default-extensions : OverloadedStrings + exposed-modules : Development.Duplo + , Development.Duplo.Component + , Development.Duplo.FileList + , Development.Duplo.Files + , Development.Duplo.Git + , Development.Duplo.JavaScript.Order + , Development.Duplo.Markups + , Development.Duplo.Scripts + , Development.Duplo.Server + , Development.Duplo.Static + , Development.Duplo.Styles + , Development.Duplo.Types.AppInfo + , Development.Duplo.Types.Builder + , Development.Duplo.Types.Config + , Development.Duplo.Types.JavaScript + , Development.Duplo.Types.Options + , Development.Duplo.Utilities + , Development.Duplo.Watcher + build-depends : base == 4.7.* + , aeson == 0.8.* + , aeson-pretty == 0.7.* + , ansi-terminal == 0.5.* + , bytestring == 0.10.* + , containers == 0.5.* + , directory == 1.2.* + , executable-path == 0.0.* + , filepath == 1.3.* + , filepather == 0.3.* + , fsnotify == 0.1.* + , http-types == 0.8.* + , language-javascript == 0.5.* + , lens == 4.5.* + , mtl == 2.2.* + , regex-compat == 0.95.* + , scotty == 0.9.* + , shake == 0.14.* + , system-fileio == 0.3.* + , text == 1.1.* + , text-format == 0.3.* + , transformers == 0.4.* + , unordered-containers == 0.2.* + , utf8-string == 0.3.* + , wai == 3.0.* + , warp == 3.0.* + executable duplo - main-is : Duplo.hs + main-is : CLI.hs + ghc-options : -rtsopts + hs-source-dirs : src + default-language : Haskell2010 + default-extensions : OverloadedStrings build-depends : base == 4.7.* - , MissingH == 1.3.* , aeson == 0.8.* + , aeson == 0.8.* , aeson-pretty == 0.7.* + , ansi-terminal == 0.5.* , base64-bytestring == 1.0.* , bytestring == 0.10.* , containers == 0.5.* , directory == 1.2.* - , executable-path == 0.0.* + , duplo == 1.6.* , filepath == 1.3.* , filepather == 0.3.* , fsnotify == 0.1.* @@ -37,16 +92,20 @@ , regex-compat == 0.95.* , scotty == 0.9.* , shake == 0.14.* - , system-fileio == 0.3.* , system-filepath == 0.4.* , text == 1.1.* + , text-format == 0.3.* , transformers == 0.4.* , unordered-containers == 0.2.* - , utf8-string == 0.3.* , wai == 3.0.* , warp == 3.0.* - , ansi-terminal == 0.5.* - , text-format == 0.3.* - hs-source-dirs : src/ - default-language : Haskell2010 - default-extensions : OverloadedStrings + +test-suite tests + main-is : Tests.hs + ghc-options : -Wall + hs-source-dirs : tests + default-language : Haskell2010 + type : exitcode-stdio-1.0 + build-depends : base + , duplo + , hspec == 2.1.* diff --git a/src/CLI.hs b/src/CLI.hs new file mode 100644 --- /dev/null +++ b/src/CLI.hs @@ -0,0 +1,228 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +module Main where + +import Control.Applicative ((<$>)) +import Control.Exception (catch, handle, throw, Exception) +import Control.Lens.Operators +import Control.Monad (void, when, unless) +import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT) +import Data.ByteString.Base64 (decode) +import Data.ByteString.Char8 (pack, unpack) +import Data.Maybe (fromMaybe) +import Development.Duplo (build) +import Development.Duplo.Server (serve) +import Development.Duplo.Utilities (logStatus, errorPrintSetter, replace) +import Development.Duplo.Watcher (watch) +import Development.Shake (cmd, ShakeException(..)) +import Development.Shake.FilePath (()) +import GHC.Conc (forkIO) +import System.Console.GetOpt (getOpt, OptDescr(..), ArgDescr(..), ArgOrder(..)) +import System.Directory (getCurrentDirectory, createDirectoryIfMissing, doesFileExist) +import System.Environment (lookupEnv, getArgs, getExecutablePath) +import System.FilePath.Posix (takeDirectory) +import System.Process (proc, createProcess, waitForProcess) +import qualified Control.Lens +import qualified Development.Duplo.Component as CM +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 qualified Filesystem.Path +import qualified GHC.IO + +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 "test/" + 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 + -- By default, `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" -> ( "build" , "" , "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 + + -- We may need custom builds with mode + let depManifestPath = cwd "component.json" + 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 + + -- 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 "" diff --git a/src/Development/Duplo.hs b/src/Development/Duplo.hs new file mode 100644 --- /dev/null +++ b/src/Development/Duplo.hs @@ -0,0 +1,143 @@ +module Development.Duplo where + +import Control.Exception (throw) +import Control.Lens hiding (Action) +import Control.Monad (void, when, unless) +import Control.Monad.Except (runExceptT) +import Development.Duplo.Git as Git +import Development.Duplo.Markups as Markups +import Development.Duplo.Scripts as Scripts +import Development.Duplo.Static as Static +import Development.Duplo.Styles as Styles +import Development.Duplo.Utilities (logStatus, headerPrintSetter, successPrintSetter, createStdEnv) +import Development.Shake +import Development.Shake.FilePath (()) +import System.Console.GetOpt (OptDescr(..), ArgDescr(..)) +import System.IO (readFile) +import qualified Development.Duplo.Component as CM +import qualified Development.Duplo.Types.AppInfo as AI +import qualified Development.Duplo.Types.Builder as BD +import qualified Development.Duplo.Types.Config as TC +import qualified Development.Duplo.Types.Options as OP +import qualified Development.Shake as DS + +shakeOpts = shakeOptions { shakeThreads = 4 } + +build :: String -> [String] -> TC.BuildConfig -> OP.Options -> IO () +build cmdName cmdArgs config options = shake shakeOpts $ do + let headerPrinter = liftIO . logStatus headerPrintSetter + let successPrinter = liftIO . logStatus successPrintSetter + + let port = config ^. TC.port + let cwd = config ^. TC.cwd + let utilPath = config ^. TC.utilPath + let miscPath = config ^. TC.miscPath + let targetPath = config ^. TC.targetPath + let bumpLevel = config ^. TC.bumpLevel + let appName = config ^. TC.appName + let appVersion = config ^. TC.appVersion + let appId = config ^. TC.appId + let duploPath = config ^. TC.duploPath + + -- What to build and each action's related action + let targetScript = targetPath "index.js" + let targetStyle = targetPath "index.css" + let targetMarkup = targetPath "index.html" + targetScript *> (void . runExceptT . Scripts.build config) + targetStyle *> (void . runExceptT . Styles.build config) + targetMarkup *> (void . runExceptT . Markups.build config) + + -- Manually bootstrap Shake + action $ do + -- Keep a list of commands so we can check before we call Shake, + -- which doesn't allow us to change the error message when an action + -- isn't found. + let actions = [ "static" + , "clean" + , "build" + , "bump" + , "init" + , "version" + ] + + -- Default to help + let cmdName' = if cmdName `elem` actions then cmdName else "help" + -- Call command + need [cmdName'] + + -- Trailing space + putNormal "" + + -- Handling static assets + Static.qualify config &?> Static.build config + + "static" ~> Static.deps config + + -- Install dependencies. + "deps" ~> do + liftIO $ logStatus headerPrintSetter "Installing dependencies" + + envOpt <- createStdEnv config + + command_ [envOpt] (utilPath "install-deps.sh") [] + + "clean" ~> do + -- Clean only when the target is there. + needCleaning <- doesDirectoryExist targetPath + when needCleaning $ liftIO $ removeFiles targetPath ["//*"] + + successPrinter "Clean completed" + + "build" ~> do + -- Always rebuild if we're building for production. + unless (TC.isInDev config) $ need ["clean"] + + -- Make sure all static files and dependencies are there. + need ["static", "deps"] + -- Then compile, in parallel. + need [targetScript, targetStyle, targetMarkup] + + successPrinter "Build completed" + + when (TC.isInTest config) $ need ["test"] + + "bump" ~> do + (oldVersion, newVersion) <- Git.commit config bumpLevel + + successPrinter $ "Bumped version from " ++ oldVersion ++ " to " ++ newVersion + + "init" ~> do + let user = cmdArgs ^. element 0 + let repo = cmdArgs ^. element 1 + let name = user ++ "/" ++ repo + let src = miscPath "boilerplate/" + let dest = cwd ++ "/" + + -- Check prerequisites + when (null user) $ throw BD.MissingGithubUserException + when (null repo) $ throw BD.MissingGithubRepoException + + headerPrinter $ "Creating new duplo project " ++ name + + -- Initialize with boilerplate + command_ [] (utilPath "init-boilerplate.sh") [src, dest] + + -- Update fields + appInfo <- liftIO CM.readManifest + let newAppInfo = appInfo { AI.name = repo + , AI.repo = name + } + -- Commit app info + liftIO $ CM.writeManifest newAppInfo + + -- Initalize git + command_ [] (utilPath "init-git.sh") [name] + + successPrinter $ "Project created at " ++ dest + + "test" ~> command_ [] (utilPath "run-test.sh") [duploPath] + + -- Version should have already been displayed if requested + "version" ~> return () + + "help" ~> liftIO (readFile (miscPath "help.txt") >>= putStr) diff --git a/src/Development/Duplo/Component.hs b/src/Development/Duplo/Component.hs new file mode 100644 --- /dev/null +++ b/src/Development/Duplo/Component.hs @@ -0,0 +1,145 @@ +{-# LANGUAGE TupleSections #-} + +module Development.Duplo.Component where + +import Control.Applicative ((<$>), (<*>)) +import Control.Exception (throw) +import Control.Monad (when, liftM) +import Control.Monad.Trans.Class (lift) +import Data.Aeson (encode, decode) +import Data.Aeson.Encode.Pretty (encodePretty) +import Data.ByteString.Lazy.Char8 (ByteString) +import Data.HashMap.Lazy (empty, keys, lookup) +import Data.List (isPrefixOf) +import Data.Map (fromList) +import Data.Maybe (fromJust, fromMaybe) +import Data.Text (breakOn) +import Development.Duplo.Types.AppInfo (AppInfo(..)) +import Development.Shake hiding (doesFileExist, getDirectoryContents, doesDirectoryExist) +import Development.Shake.FilePath (()) +import Prelude hiding (lookup) +import System.Directory (doesFileExist, doesDirectoryExist, getDirectoryContents, getCurrentDirectory) +import System.FilePath.FilePather.FilterPredicate (filterPredicate) +import System.FilePath.FilePather.Find (findp) +import System.FilePath.FilePather.RecursePredicate (recursePredicate) +import System.FilePath.Posix (makeRelative, dropExtension, splitDirectories, equalFilePath, takeFileName, dropTrailingPathSeparator) +import qualified Data.ByteString.Lazy.Char8 as BS (unpack, pack) +import qualified Data.Text as T (unpack, pack) +import qualified Development.Duplo.Types.AppInfo as AI +import qualified Development.Duplo.Types.Builder as BD + +type Version = (String, String) + +-- | Each application must have a `component.json` +manifestName = "component.json" + +readManifest :: IO AppInfo +readManifest = do + exists <- doesFileExist manifestName + + if exists + then readManifest' manifestName + else throw $ BD.MissingManifestException manifestName + +readManifest' :: FilePath -> IO AppInfo +readManifest' path = do + manifest <- readFile path + let maybeAppInfo = decode (BS.pack manifest) :: Maybe AppInfo + + case maybeAppInfo of + Nothing -> throw $ BD.MalformedManifestException path + Just a -> return a + +writeManifest :: AppInfo -> IO () +writeManifest = writeFile manifestName . BS.unpack . encodePretty + +-- | Get the app's Component.IO ID +appId :: AppInfo -> String +appId appInfo = parseRepoInfo $ splitDirectories $ AI.repo appInfo + +-- | Parse the repo info into an app ID +parseRepoInfo :: [String] -> String +parseRepoInfo (owner : appRepo : _) = owner ++ "-" ++ appRepo +parseRepoInfo _ = "" + +-- | Given a possible component ID, return the user and the repo +-- constituents +parseComponentId :: String -> Either String (String, String) +parseComponentId cId + | repoL > 0 = Right (T.unpack user, T.unpack repo) + | otherwise = Left $ "No component ID found with " ++ cId + where + (user, repo) = breakOn (T.pack "-") (T.pack cId) + repoL = length $ T.unpack repo + +-- | Given a path, find all the `component.json` and return a JSON string +extractCompVersions :: FilePath -> IO String +extractCompVersions path = do + -- Get all the relevant paths + paths <- getAllManifestPaths path + -- Construct the pipeline + let toVersion path = appInfoToVersion . decodeManifest path . BS.pack + let takeVersion path = liftM (toVersion path) (readFile path) + -- Go through it + manifests <- mapM takeVersion paths + -- Marshalling + return $ BS.unpack $ encode $ fromList manifests + +-- | Given a path and the file content that the path points to, return the +-- manifest in `AppInfo` form. +decodeManifest :: FilePath -> ByteString -> AppInfo +decodeManifest path content = fromMaybe whenNothing decodedContent + where + whenNothing = throw $ BD.MalformedManifestException path + decodedContent = decode content :: Maybe AppInfo + +appInfoToVersion :: AppInfo -> Version +appInfoToVersion appInfo = (AI.name appInfo, AI.version appInfo) + +-- | Given a path, find all the `component.json`s +getAllManifestPaths :: FilePath -> IO [FilePath] +getAllManifestPaths root = allPaths + where + -- Filter for `component.json`. + matchName path t = takeFileName path == takeFileName manifestName + filterP = filterPredicate matchName + -- We only care about the root directory and the `components/` directory. + componentsPath = dropTrailingPathSeparator $ root "components/" + proceed absPath = equalFilePath root absPath + || componentsPath `isPrefixOf` absPath + recurseP = recursePredicate proceed + -- Collect the paths here. + allPaths = findp filterP recurseP root + +-- | Get the component dependency list by providing a mode, or not. +getDependencies :: Maybe String -> IO [FilePath] +-- | Simply get all dependencies if no mode is provided. +getDependencies Nothing = do + cwd <- getCurrentDirectory + let depDir = cwd "components/" + depDirExists <- doesDirectoryExist depDir + let filterRegular = fmap $ filter isRegularFile + + filterRegular $ + if depDirExists + then getDirectoryContents depDir + else return [] +-- | Only select the named dependencies. +getDependencies (Just mode) = do + fullDeps <- fmap AI.dependencies readManifest + depModes <- fmap AI.modes readManifest + getDependencies' fullDeps $ case depModes of + Just d -> lookup mode d + Nothing -> Nothing + +-- | Helper function to get the selected dependency list given the full +-- dependency list, all modes, and the target mode to select the list by. +getDependencies' :: AI.Dependencies -> Maybe [String] -> IO [FilePath] +-- If somehow there isn't a mode defined, switch over to `Nothing`. +getDependencies' deps Nothing = getDependencies Nothing +-- If there is something, fetch only those dependencies. +getDependencies' deps (Just modeDeps) = return modeDeps + +-- | Regular file != *nix-style hidden file +isRegularFile :: FilePath -> Bool +isRegularFile = not . isPrefixOf "." diff --git a/src/Development/Duplo/FileList.hs b/src/Development/Duplo/FileList.hs new file mode 100644 --- /dev/null +++ b/src/Development/Duplo/FileList.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Development.Duplo.FileList where + +import Control.Lens hiding (Action) +import Control.Lens.TH (makeLenses) +import Control.Monad (liftM, msum) +import Data.Maybe (Maybe(..), catMaybes) +import Development.Shake +import Development.Shake.FilePath (()) +import System.FilePath.Posix (makeRelative) + +data File = File { _filePath :: FilePath + , _fileBase :: FilePath + } deriving (Show) +type Copy = (FilePath, FilePath) + +defaultFile :: File +defaultFile = File { _filePath = "" + , _fileBase = "" + } + +makeLenses ''File + +-- | Given a base and a list of relative paths, transform into file objects +makeFiles :: FilePath -> [FilePath] -> [File] +makeFiles = fmap . makeFile + +-- | Given a base and a relative path, return a file record containing the +-- absolute path with the base +makeFile :: FilePath -> FilePath -> File +makeFile base relPath = + setPath absPath + where + constructor = defaultFile { _fileBase = base } + absPath = base relPath + setPath = (constructor &) . (filePath .~) + +-- | Collapse lists of possible files and return the first file that exists +-- for each list +collapseFileLists :: [[File]] -> Action [File] +collapseFileLists = liftM catMaybes . mapM collapseFileList + +-- | Given a list of possible files, reduce to a file that exists, or +-- nothing +collapseFileList :: [File] -> Action (Maybe File) +collapseFileList = liftM msum . mapM collapseFile + +-- | Given a file, return itself if it exists +collapseFile :: File -> Action (Maybe File) +collapseFile file = do + let path = file ^. filePath + doesExist <- doesFileExist path + + return $ if doesExist then Just file else Nothing + +-- | Given an output path and a list of file objects, convert all files +-- objects to copy pairs. See `toCopy` for more information. +toCopies :: FilePath -> [File] -> [Copy] +toCopies base = fmap $ toCopy base + +-- | Given an output path and a file object, return a copy pair whose to +-- path is relative to the output path in the same way as the provided file +-- object's path is relative to its base. +toCopy :: FilePath -> File -> Copy +toCopy targetBase file = + (from, to) + where + path = file ^. filePath + base = file ^. fileBase + relPath = makeRelative base path + from = path + to = targetBase relPath diff --git a/src/Development/Duplo/Files.hs b/src/Development/Duplo/Files.hs new file mode 100644 --- /dev/null +++ b/src/Development/Duplo/Files.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Development.Duplo.Files where + +import Control.Exception (throw) +import Control.Lens hiding (Action) +import Control.Lens.TH (makeLenses) +import Control.Monad.Except (ExceptT(..), runExceptT) +import Control.Monad.Trans.Class (lift) +import Data.List (intercalate) +import Data.Text (split, pack, unpack) +import Development.Duplo.Component (appId) +import Development.Shake hiding (readFile) +import Prelude hiding (readFile) +import System.FilePath.Posix (makeRelative, splitDirectories, joinPath) +import qualified Development.Duplo.Component as CM +import qualified Development.Duplo.Types.Builder as BD + +type FileName = String +type FileContent = String +type ComponentId = String +data File = File { _filePath :: FilePath + , _fileDir :: FilePath + , _fileName :: FileName + , _componentId :: ComponentId + , _fileContent :: String + -- Is this part of the root project? + , _isRoot :: Bool + } deriving (Show) + +pseudoFile = File { _filePath = "" + , _fileDir = "" + , _fileName = "" + , _componentId = "" + , _fileContent = "" + , _isRoot = False + } + +makeLenses ''File + +readFile :: FilePath -> FilePath -> ExceptT String Action File +readFile cwd path = do + let (fileDir, fileName) = parseFilePath path + fileContent <- lift $ readFile' path + appInfo <- liftIO CM.readManifest + let appId' = appId appInfo + let componentId = parseComponentId cwd appId' fileDir + let isRoot = componentId == appId' + return $ File path fileDir fileName componentId fileContent isRoot + +parseFilePath :: FilePath -> (FilePath, FileName) +parseFilePath path = (fileDir, fileName) + where + segments = splitDirectories path + segLength = length segments + dirLength = segLength - 1 + fileDir = joinPath $ take dirLength segments + fileName = segments !! dirLength + +-- | Given a default component ID (usually the ID of the project on which +-- duplo is run) and the file path, deduce the component ID of a particular +-- file +parseComponentId :: FilePath -> ComponentId -> FilePath -> ComponentId +parseComponentId cwd defaultId path = + let + relPath = makeRelative cwd path + segments = splitDirectories relPath + in + case segments of + ("components" : appId : xs) -> appId + _ -> defaultId diff --git a/src/Development/Duplo/Git.hs b/src/Development/Duplo/Git.hs new file mode 100644 --- /dev/null +++ b/src/Development/Duplo/Git.hs @@ -0,0 +1,129 @@ +module Development.Duplo.Git where + +import Control.Applicative ((<$>)) +import Control.Lens hiding (Action, Level) +import Control.Monad.Except (runExceptT) +import Data.List (intercalate, filter) +import Data.Text (unpack, pack, splitOn) +import Development.Shake +import Development.Shake.FilePath (()) +import System.FilePath.Posix (makeRelative) +import qualified Development.Duplo.Component as CM +import qualified Development.Duplo.Types.AppInfo as AI +import qualified Development.Duplo.Types.Config as TC + +type Level = String +type Version = String +type Subversion = String +type FileExtension = String + +-- We use Semantic Versioning protocol +versionLength :: Int +versionLength = 3 + +-- | Commit to git and bump version for current project +commit :: TC.BuildConfig + -> Level + -> Action (Version, Version) +commit config level = do + let utilPath = config ^. TC.utilPath + appInfo <- liftIO CM.readManifest + let version = AI.version appInfo + let cwd = config ^. TC.cwd + let manifest = cwd "component.json" + + -- First stash any outstanding change + command_ [] "git" ["stash"] + -- Then make sure we're on master + command_ [] "git" ["checkout", "master"] + + -- Increment version according to level + let newVersion = incrementVersion level version + -- Update app info + let appInfo' = updateVersion appInfo newVersion + -- Update registered file list with Component.IO + appInfo'' <- updateFileRegistry config appInfo' + -- Commit app info + liftIO $ CM.writeManifest appInfo'' + + -- Commit with the version + command_ [] (utilPath "commit.sh") [newVersion] + + return (version, newVersion) + +-- | Bump a version, given a bump type +incrementVersion :: Version + -> Level + -> Version +incrementVersion level version = + intercalate "." $ incrementSubversion expanded index + where + expanded = unpack <$> splitOn (pack ".") (pack version) + index = case level of + "major" -> 0 + "minor" -> 1 + "patch" -> 2 + +-- | Given a version component, increment it. +incrementSubversion :: [Subversion] -> Int -> [Subversion] +incrementSubversion version index = + resetVer + where + oldPart = version ^. element index + oldPart' = read oldPart :: Int + newPart = oldPart' + 1 + newPart' = show newPart :: String + -- Increment target subversion + incrVer = version & element index .~ newPart' + -- Reset other + resetVer = resetSubversion incrVer (index + 1) versionLength + +-- | Reset a version component. The reset cascades up to the max subversion +-- index. +resetSubversion :: [Subversion] -> Int -> Int -> [Subversion] +resetSubversion version index max + | index <= max = let newVersion = resetSubversion version (index + 1) max + in newVersion & element index .~ "0" + | otherwise = version + +updateVersion :: AI.AppInfo -> Version -> AI.AppInfo +updateVersion manifest version = manifest { AI.version = version } + +-- | Read from the given directory and update the app manifest object. +updateFileRegistry :: TC.BuildConfig -> AI.AppInfo -> Action AI.AppInfo +updateFileRegistry config appInfo = do + let cwd = config ^. TC.cwd + let utilPath = config ^. TC.utilPath + let appPath = cwd "app" + let assetPath = appPath "assets" + let imagePath = assetPath "images" + let fontPath = assetPath "fonts" + + -- Helper functions + let find path pttrn = command [] (utilPath "find.sh") [path, pttrn] + let split = fmap unpack . splitOn "\n" . pack + let makeRelative' = makeRelative cwd + let filterNames = filter ((> 0) . length) + let prepareFileList = filterNames . fmap (makeRelative cwd) . split + + -- Collect eligible files + Stdout scripts <- find appPath "*.js" + Stdout styles <- find appPath "*.styl" + Stdout markups <- find appPath "*.jade" + Stdout images <- find imagePath "*" + Stdout fonts <- find fontPath "*" + + -- Convert to arrays and make relative to cwd + let scripts' = prepareFileList scripts + let styles' = prepareFileList styles + let markups' = prepareFileList markups + let images' = prepareFileList images + let fonts' = prepareFileList fonts + + -- Update manifest + return appInfo { AI.images = images' + , AI.scripts = scripts' + , AI.styles = styles' + , AI.templates = markups' + , AI.fonts = fonts' + } diff --git a/src/Development/Duplo/JavaScript/Order.hs b/src/Development/Duplo/JavaScript/Order.hs new file mode 100644 --- /dev/null +++ b/src/Development/Duplo/JavaScript/Order.hs @@ -0,0 +1,146 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Development.Duplo.JavaScript.Order where + +import Control.Applicative ((<$>)) +import Control.Exception (throw) +import Control.Lens (makeLenses, ix) +import Control.Lens.Operators +import Control.Monad (liftM, when, void) +import Control.Monad.State.Lazy (get, put, state, execState) +import Control.Monad.Writer.Lazy (Writer, tell, runWriter) +import Data.Function (on) +import Data.List (findIndex, sortBy, nubBy) +import Data.Maybe (isJust, fromJust, fromMaybe) +import Development.Duplo.Types.JavaScript +import Language.JavaScript.Parser (JSNode(..), Node(..), TokenPosn(..)) + +makeLenses ''Module + +-- | Reorder modules within the root node. +order :: JSNode -> JSNode +order jsNode = + -- Append the modules, in its rightful order, to all the non-applicable + -- nodes. + NN $ JSSourceElementsTop $ naNodes ++ aNodesWithSep + where + -- For hygiene + separator = NT (JSLiteral ";") (TokenPn 0 0 0) [] + -- The "normal" output is the filtered non-applicable nodes and the + -- written-to nodes are of course the extracted ones. + (naNodes, aNodes) = runWriter $ extract jsNode + -- Reorder modules + orderedANodes = _node <$> reorder aNodes + -- Insert separators + aNodesWithSep = concat $ fmap (\n -> [n, separator]) orderedANodes + +-- | Extract AMD modules to logger for re-ordering and the rest to output. +extract :: JSNode -> Writer [Module] [JSNode] +-- Go through all elements at top-level. +extract (NN (JSSourceElementsTop jsElements)) = mapM extract' jsElements +-- Impossible scenario +extract element = throw $ LanguageJavaScriptException element + +extract' :: JSNode -> Writer [Module] JSNode +-- We are looking for a `define`! +extract' jsNode@(NN (JSExpression (NT (JSIdentifier "define") _ _:args:_))) = do + -- Save the module for processing. + tell [makeModule jsNode args] + -- Just return an empty string in place of the module. + return $ NT (JSIdentifier "") (TokenPn 0 0 0) [] +-- Just pass everything else through. +extract' jsNode = return jsNode + +-- | Turn a node into a module. + -- The root expression node +makeModule :: JSNode + -- The argument node + -> JSNode + -- The created module + -> Module +makeModule rootNode argNode = + Module moduleName deps rootNode Nothing + where + -- Extract the terminating nodes that are arguments. + (NN (JSArguments _ argNTs _)) = argNode + -- A simple pattern matching for the module declaration works, it + -- always follows this pattern. + (nameNT:_:depsNT:_) = argNTs + -- Extract the name, always first argument. + (NT (JSStringLiteral _ moduleName) _ _) = nameNT + -- Extract the module dependencies, always the third argument (second + -- being the comma separator). + (NN (JSArrayLiteral _ depsNodes _)) = depsNT + -- Only take the strings. + deps = map fromJust $ filter isJust $ map stringLiteralNT depsNodes + +-- | Given a JSNode, return just the string literal, or nothing +stringLiteralNT :: JSNode -> Maybe String +stringLiteralNT (NT (JSStringLiteral _ string) _ _) = Just string +stringLiteralNT _ = Nothing + +-- | Reorder all the applicable modules +reorder :: [Module] -> [Module] +reorder mods = nubbed + where + -- Score all the modules + scored = execState computeScores mods + -- Filter out initial modules that may have a score of `Nothing` + filtered = filter withScore scored + -- Sort by score + sorted = sortBy byDepScore filtered + -- Deduplicate, keeping the higher score ones + nubbed = reverse $ nubBy ((==) `on` _name) $ reverse sorted + +withScore :: Module -> Bool +withScore aMod = case _score aMod of + Just _ -> True + Nothing -> False + +byDepScore :: Module -> Module -> Ordering +byDepScore a b = compare (_score a) (_score b) + +-- | Given a module list, find all the dependency scores of the constituent +-- modules. +computeScores :: OrderedModules [DepScore] +computeScores = do + mods <- get + -- Put the modules in state to be re-ordered as well as extract the + -- names by placing it in the State as values. + mapM (getDepScore []) $ fmap _name mods + +-- | Given a module name, get its score. +getDepScore :: [ModuleName] -> ModuleName -> OrderedModules DepScore +getDepScore history modName = do + -- We go nuclear when there's circular dependency. + let history' = modName : history + -- Display the duplicate module if it's in the recorded modules + void $ when (modName `elem` history) + $ throw $ CircularDependencyException $ reverse history' + -- Take out the modules. + mods <- get + -- Assume module exist, as it should at this point. + let maybeIndex = findIndex ((modName ==) . _name) mods + let index = fromMaybe (throw $ ModuleNotFoundException modName) maybeIndex + -- Get the actual module. + let aMod = fromJust $ mods ^? ix index + -- The dependency list + let modDeps = _dependencies aMod + -- If there is a score, use it; otherwise, obviously go get it. + depScore <- case _score aMod of + -- Re-wrap with the score as the result. + Just modScore -> state $ const (modScore, mods) + -- Go through the dependencies' individual scores. + Nothing -> getDepScore' history' modDeps + -- Update the score. + let newMod = aMod & score .~ Just depScore + -- TODO: somehow can't get Lens to work. Doing the old fashion way. + let newMods = take index mods ++ [newMod] ++ drop (index + 1) mods + put newMods + -- Return the sscore. + return depScore + +-- | Get a module's dependency score given its dependencies. +getDepScore' :: [ModuleName] -> [ModuleName] -> OrderedModules DepScore +getDepScore' history modNames = + liftM ((1 +) . sum) $ mapM (getDepScore history) modNames diff --git a/src/Development/Duplo/Markups.hs b/src/Development/Duplo/Markups.hs new file mode 100644 --- /dev/null +++ b/src/Development/Duplo/Markups.hs @@ -0,0 +1,164 @@ +module Development.Duplo.Markups where + +import Control.Applicative ((<$>)) +import Control.Exception (throw) +import Control.Lens hiding (Action) +import Control.Monad.Trans.Class (lift) +import Data.Maybe (fromMaybe) +import Development.Duplo.Component (parseComponentId) +import Development.Duplo.FileList (collapseFileList, makeFile) +import Development.Duplo.Files (File(..), filePath, fileDir, fileName, componentId, fileContent, isRoot, ComponentId) +import Development.Duplo.Utilities (logStatus, headerPrintSetter, expandPaths, compile, createIntermediaryDirectories, CompiledContent, expandDeps, replace) +import Development.Shake +import Development.Shake.FilePath (()) +import System.Directory (findFile) +import System.FilePath.Posix (makeRelative, splitDirectories, joinPath) +import qualified Development.Duplo.FileList as FileList (filePath) +import qualified Development.Duplo.Types.Builder as BD +import qualified Development.Duplo.Types.Config as TC + +build :: TC.BuildConfig + -> FilePath + -> CompiledContent () +build config out = do + liftIO $ logStatus headerPrintSetter "Building markups" + -- TODO: using Jade's include system means that all files are loaded by + -- the Jade compiler and Shake has no visibility into file state. We + -- cannot cache anything that is Jade. Perhaps we could compile the Jade + -- ourselves? + lift alwaysRerun + + let cwd = config ^. TC.cwd + let env = config ^. TC.env + let buildMode = config ^. TC.buildMode + let utilPath = config ^. TC.utilPath + let devPath = config ^. TC.devPath + let appPath = config ^. TC.appPath + let testPath = config ^. TC.testPath + let duploPath = config ^. TC.duploPath + let assetsPath = config ^. TC.assetsPath + let targetPath = config ^. TC.targetPath + let defaultsPath = config ^. TC.defaultsPath + let refTagsPath = defaultsPath "head.html" + let devAssetsPath = devPath "assets" + let devCodePath = devPath "modules/index" + let depIds = config ^. TC.dependencies + let inTest = TC.isInTest config + + -- Preconditions + lift $ createIntermediaryDirectories devCodePath + + -- Expand all paths + let depExpander id = [ "components" id "app/modules/index" ] + let expanded = expandDeps depIds depExpander + let allPaths = "app/modules/index" : expanded + let absPaths = case buildMode of + "developmoent" -> [ devCodePath ] + "test" -> [ targetPath "vendor/mocha" ] + _ -> [] + ++ map (cwd ) allPaths + + -- Merge both types of paths + paths <- lift $ expandPaths cwd ".jade" absPaths [] + + -- Compiler details + let compiler = utilPath "markups-compile.sh" + let preCompile files = return $ fmap (rewriteIncludes cwd files) files + + -- Compile content + compiled <- compile config compiler [] paths preCompile return + + -- Pull index page from either dev, assets, or default otherwise, in that + -- order. + let possibleSources = [ devPath, appPath, defaultsPath ] + -- We know at least one would satisfy because there's always one in + -- the default path + Just indexFile <- liftIO $ findFile possibleSources "index.jade" + + -- Compile the index file + compiledIndex <- compile config compiler [] [indexFile] preCompile return + + -- Inject compiled code into the index + let indexWithMarkup = replace "" ("" ++ compiled) compiledIndex + + -- Inject CSS/JS references + refTagsInTest <- lift $ readFile' $ duploPath "etc/test/head.html" + let indexWithTestRefs = + if inTest + then replace "" (refTagsInTest ++ "") indexWithMarkup + else indexWithMarkup + + refTags <- lift $ readFile' refTagsPath + let indexWithRefs = replace "" (refTags ++ "") indexWithTestRefs + + -- Path to the minifier + let minifier = utilPath "markups-minify.sh" + -- Minify it + let postMinify _ = return indexWithRefs + minified <- compile config minifier [] paths return postMinify + + -- Write it to disk + lift $ writeFileChanged out minified + +-- | Rewrite paths to external files (i.e. include statements) because Jade +-- doesn't accept more than one path to look up includes. It is passed all +-- the files to be compiled and a file whose include statements are to be +-- rewritten. + -- The current working directory +rewriteIncludes :: FilePath + -- All the files to be compiled + -> [File] + -- The current file + -> File + -- The same file with include statements rewritten + -> File +rewriteIncludes cwd files file = + file & fileContent .~ rewritten + where + path = file ^. filePath + dir = file ^. fileDir + name = file ^. fileName + id = file ^. componentId + content = file ^. fileContent + isRoot' = file ^. isRoot + defaultId = if isRoot' then "" else id + content' = Prelude.lines content + rewritten' = fmap (rewriteInclude defaultId) content' + rewritten = Prelude.unlines rewritten' + +-- | Given a component ID and a content line, rewrite if it is an include +-- statement to be relative to project root +rewriteInclude :: ComponentId -> String -> String +rewriteInclude defaultId line = + let + -- Find how many spaces precede the line + padLength = length $ takeWhile (' ' ==) line + padding = replicate padLength ' ' + -- The statement in tokens + tokens = words line + -- Further tokenize the tokens as paths + tokenPaths = fmap splitDirectories tokens + in + case tokenPaths of + -- Deconstruct an include statement + (("include":_) : fullPath@(prefix:relPath) : _) -> + padding ++ "include " ++ resolvedPath + where + -- We need to figure out which component's name to use to prefix + -- the include path. Also get the path prefix in case we're using + -- the default ID. + (compName, relPathBase) = case parseComponentId prefix of + -- There is a component ID. + Right (user, repo) -> (prefix, "") + -- Use default component ID + -- otherwise. + Left _ -> (defaultId, prefix) + resolvedPath = if not (null compName) + -- It's referring to a file inside a component. + then "components" compName "app/modules" + relPathBase joinPath relPath + -- It's not referring to a file at the top-level. + else "app/modules" joinPath fullPath + + -- If it's not an include statement, just pass it thru + _ -> line diff --git a/src/Development/Duplo/Scripts.hs b/src/Development/Duplo/Scripts.hs new file mode 100644 --- /dev/null +++ b/src/Development/Duplo/Scripts.hs @@ -0,0 +1,169 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +module Development.Duplo.Scripts where + +import Control.Applicative ((<*>), (<$>)) +import Control.Exception (throw, SomeException(..)) +import Control.Lens hiding (Action) +import Control.Monad (filterM) +import Control.Monad.Trans.Class (lift) +import Data.Function (on) +import Data.List (intercalate, nubBy) +import Data.Text.Format (left) +import Data.Text.Lazy (Text, pack, unpack, replace, splitOn) +import Data.Text.Lazy.Builder (toLazyText) +import Development.Duplo.Component (extractCompVersions) +import Development.Duplo.Files (File(..), pseudoFile) +import Development.Duplo.JavaScript.Order (order) +import Development.Duplo.Types.JavaScript +import Development.Duplo.Utilities (logStatus, headerPrintSetter, expandPaths, compile, createIntermediaryDirectories, CompiledContent, expandDeps) +import Development.Shake +import Development.Shake.FilePath (()) +import Language.JavaScript.Parser.SrcLocation (TokenPosn(..)) +import Text.Regex (mkRegex, matchRegex) +import qualified Development.Duplo.Types.Config as TC +import qualified Language.JavaScript.Parser as JS + +-- | How many lines to display around the source of error (both ways). +errorDisplayRange :: Int +errorDisplayRange = 20 + +-- | Build scripts + -- The environment +build :: TC.BuildConfig + -- The output file + -> FilePath + -- Doesn't need anything in return + -> CompiledContent () +build config out = do + liftIO $ logStatus headerPrintSetter "Building scripts" + + let cwd = config ^. TC.cwd + let util = config ^. TC.utilPath + let env = config ^. TC.env + let buildMode = config ^. TC.buildMode + let input = config ^. TC.input + let devPath = config ^. TC.devPath + let depsPath = config ^. TC.depsPath + let devCodePath = devPath "modules/index.js" + let depIds = config ^. TC.dependencies + let inDev = TC.isInDev config + let inTest = TC.isInTest config + + -- Preconditions + lift $ createIntermediaryDirectories devCodePath + + -- These paths don't need to be expanded. + let staticPaths = case buildMode of + "development" -> [ "dev/index" ] + "test" -> [ "test/index" ] + _ -> [] + ++ [ "app/index" ] + + -- These paths need to be expanded by Shake. + let depsToExpand id = [ "components/" ++ id ++ "/app/modules" ] + -- Compile dev files in dev mode as well, taking precendence. + let dynamicPaths = case buildMode of + "development" -> [ "dev/modules" ] + "test" -> [ "test/modules" ] + _ -> [] + -- Then normal scripts + ++ [ "app/modules" ] + -- Build list only for dependencies. + ++ expandDeps depIds depsToExpand + + -- Merge both types of paths + paths <- lift $ expandPaths cwd ".js" staticPaths dynamicPaths + + -- Make sure we hvae at least something + let duploIn = if not (null input) then input else "" + + -- Figure out each component's version + compVers <- liftIO $ extractCompVersions cwd + + -- Inject global/environment variables + let envVars = "var DUPLO_ENV = '" ++ env ++ "';\n" + -- Decode and parse in runtime to avoid having to deal with + -- escaping. + ++ "var DUPLO_IN = JSON.parse(window.atob('" ++ duploIn ++ "') || '{}' );\n" + ++ "var DUPLO_VERSIONS = " ++ compVers ++ ";\n" + + -- Configure the compiler + let compiler = (util ) $ if inDev || inTest + then "scripts-dev.sh" + else "scripts-optimize.sh" + + -- Create a pseudo file that contains the environment variables and + -- prepend the file. + let pre = return . (:) (pseudoFile { _fileContent = envVars }) + -- Reorder modules and print as string + let prepareJs = JS.renderToString . order + + let post content = return + -- Handle error + $ either (handleParseError content) prepareJs + -- Parse + $ JS.parse content "" + + -- Build it + compiled <- compile config compiler [] paths pre post + + -- Write it to disk + lift $ writeFileChanged out compiled + +-- | Given the original content as string and an error message that is +-- produced by `language-javascript` parser, throw an error. +handleParseError :: String -> String -> String +handleParseError content e = exception + where + linedContent = fmap unpack $ splitOn "\n" $ pack content + lineCount = length linedContent + lineNum = readParseError e + -- Display surrounding lines + -- Construct a list of target line numbers + lineRange = take errorDisplayRange + -- Turn into infinite list + $ iterate (+ 1) + -- Position the starting point + $ lineNum - errorDisplayRange `div` 2 + showBadLine' = showBadLine linedContent lineNum + -- Keep the line number in the possible domain. + keepInRange = max 0 . min lineCount + badLines = fmap (showBadLine' . keepInRange) lineRange + -- Make sure we de-duplicate the lines. + dedupe = nubBy ((==) `on` fst) + -- Extract just the lines for display. + badLinesDeduped = map snd $ dedupe badLines + -- Construct the exception. + exception = throw + ShakeException { shakeExceptionTarget = "" + , shakeExceptionStack = [] + , shakeExceptionInner = SomeException + $ ParseException + badLinesDeduped + } + +-- | Given a file's lines, its line number, and the "target" line number +-- that caused the parse error, format it for human-readable output. +showBadLine :: [String] -> LineNumber -> LineNumber -> (LineNumber, String) +showBadLine allLines badLineNum lineNum = (lineNum, line') + where + line = allLines !! lineNum + -- Natural numbering for humans + toString = unpack . toLazyText + lineNum' = toString $ left 4 ' ' $ lineNum + 1 + marker = if lineNum == badLineNum + then ">> " ++ lineNum' + else " " ++ lineNum' + line' = marker ++ " | " ++ line + +-- | Because the parser's error isn't readable, we need to use RegExp to +-- extract what we need for debugging. +readParseError :: String -> LineNumber +readParseError e = + case match of + Just m -> (read $ head m) :: Int + Nothing -> throw $ InternalParserException e + where + regex = mkRegex "TokenPn [0-9]+ ([0-9]+) [0-9]+" + match = matchRegex regex e diff --git a/src/Development/Duplo/Server.hs b/src/Development/Duplo/Server.hs new file mode 100644 --- /dev/null +++ b/src/Development/Duplo/Server.hs @@ -0,0 +1,74 @@ +module Development.Duplo.Server where + +import Control.Monad.Trans (liftIO) +import Data.List (intercalate) +import Data.Text (Text) +import Data.Text.Lazy (Text) +import Network.HTTP.Types (status200) +import Network.Wai (pathInfo) +import Network.Wai.Handler.Warp (Port) +import System.Directory (doesFileExist) +import System.Environment (getArgs) +import System.FilePath.Posix (takeExtension) +import Web.Scotty +import qualified Data.Text as T +import qualified Data.Text.Lazy as LT + +serve :: Port -> IO () +serve port = do + putStrLn $ "\n>> Starting server on port " ++ show port + scotty port serve' + +serve' :: ScottyM () +serve' = + -- Always match because we're checking for files, not routes + notFound $ do + path <- fmap (intercalate "/" . fmap T.unpack . pathInfo) request + -- Setting root + let path' = "public/" ++ path + exists <- liftIO $ doesFileExist path' + + status status200 + + if exists + then normalFile path' + else returnDefault path' + +normalFile :: FilePath -> ActionM () +normalFile path = do + let contentType = guessType path + file path + setHeader "Content-Type" $ LT.pack contentType + +-- | Return a default file depending on file type. Return the default HTML +-- file otherwise. +returnDefault :: FilePath -> ActionM () +returnDefault path = do + let extension = takeExtension path + + file $ case extension of + ".css" -> "public/index.css" + ".js" -> "public/index.js" + _ -> "public/index.html" + + setHeader "Content-Type" $ case extension of + ".css" -> "text/css" + ".js" -> "text/javascript" + _ -> "text/html" + +-- | "Guess" the content type from the path's file type +guessType :: String -> String +guessType path = case takeExtension path of + ".htm" -> "text/html" + ".html" -> "text/html" + ".css" -> "text/css" + ".js" -> "application/x-javascript" + ".png" -> "image/png" + ".jpeg" -> "image/jpeg" + ".jpg" -> "image/jpeg" + ".woff" -> "application/font-woff" + ".ttf" -> "application/font-ttf" + ".eot" -> "application/vnd.ms-fontobject" + ".otf" -> "application/font-otf" + ".svg" -> "image/svg+xml" + otherwise -> "application/octet-stream" diff --git a/src/Development/Duplo/Static.hs b/src/Development/Duplo/Static.hs new file mode 100644 --- /dev/null +++ b/src/Development/Duplo/Static.hs @@ -0,0 +1,149 @@ +module Development.Duplo.Static where + +import Control.Applicative ((<$>)) +import Control.Lens hiding (Action) +import Control.Monad (zipWithM_, filterM) +import Data.List (transpose, nub) +import Development.Duplo.FileList (makeFile, makeFiles, toCopies, collapseFileLists, Copy) +import Development.Duplo.Utilities (logStatus, headerPrintSetter, createIntermediaryDirectories, createPathDirectories, getDirectoryFiles) +import Development.Shake hiding (getDirectoryFiles) +import Development.Shake.FilePath (()) +import System.FilePath.Posix (splitExtension, splitDirectories, makeRelative) +import qualified Development.Duplo.FileList as FileList (filePath) +import qualified Development.Duplo.Types.Config as TC + +build :: TC.BuildConfig + -> [FilePath] + -> Action () +build config outs = do + let targetPath = config ^. TC.targetPath + let assetsPath = config ^. TC.assetsPath + let depsPath = config ^. TC.depsPath + let devPath = config ^. TC.devPath + let devAssetPath = devPath "assets" + let testAssetPath = config ^. TC.duploPath "etc/test" + + -- Convert to relative paths for copying + let filesRel = fmap (makeRelative targetPath) outs + -- Look in assets directory + let assetFiles = makeFiles assetsPath filesRel + -- Look in components' asset directories as well + depAssetDirs <- getDirectoryDirs depsPath + -- Assets are relative to their own asset directories + let depAssetPaths = [ base dep src "assets" + | src <- ["app"] + , base <- [depsPath] + , dep <- depAssetDirs + ] + -- Make the actual file records with the asset directory as the base + let depAssetFiles = [ makeFile base file + | base <- depAssetPaths + , file <- filesRel + ] + -- Look in the dev directory as well + let devFiles = makeFiles devAssetPath filesRel + -- Look in the test directory as well + let testFiles = makeFiles testAssetPath filesRel + + -- Combine matching files into lists each pointing to its corresponding + -- output file. Note that this is in order of precedence. + let possibleFiles = transpose [devFiles, testFiles, assetFiles, depAssetFiles] + -- Each file list collapses into a path that exists + cleanedFiles <- collapseFileLists possibleFiles + + -- Path to output index + let targetIndex = targetPath "index.html" + -- Is it index in the target output directory? + let isTargetIndex file = targetIndex /= file ^. FileList.filePath + -- Ignore index as it's handling by the markup action + let filesLessIndex = filter isTargetIndex cleanedFiles + + -- We need to take the files and turn it into from/to pair + let (froms, tos) = unzip $ toCopies targetPath filesLessIndex + + -- Log + let repeat' = replicate $ length froms + let messages = transpose [ repeat' "Copying " + , froms + , repeat' " to " + , tos + ] + mapM_ (putNormal . concat) messages + + -- Make sure the intermediary directories exist + mapM_ createIntermediaryDirectories tos + + -- Copy all files + zipWithM_ copyFileChanged froms tos + +-- | Build dependency list for static files +deps :: TC.BuildConfig + -> Action () +deps config = do + liftIO $ logStatus headerPrintSetter "Copying static files" + + let assetsPath = config ^. TC.assetsPath + let depsPath = config ^. TC.depsPath + let targetPath = config ^. TC.targetPath + let devPath = config ^. TC.devPath + let devAssetsPath = devPath "assets/" + let testAssetsPath = config ^. TC.duploPath "etc/test" + + -- Make sure all these directories exist + createPathDirectories [assetsPath, depsPath, targetPath, devAssetsPath] + + -- We want all asset files + assetFiles <- getDirectoryFiles assetsPath ["//*"] + -- ... including those of dependencies + depAssetFiles <- getDepAssets depsPath + -- Add dev files to the mix, if we're in dev mode + devFiles' <- getDirectoryFiles devAssetsPath ["//*"] + let devFiles = if TC.isInDev config then devFiles' else [] + -- Add test files to the mix, if we're in test mode + testFiles' <- getDirectoryFiles testAssetsPath ["vendor//*"] + let testFiles = if TC.isInTest config then testFiles' else [] + -- Mix them together + let allFiles = nub $ concat [depAssetFiles, assetFiles, devFiles, testFiles] + -- We do NOT want index + let files = filter ("index.html" /=) allFiles + + let getExt = snd . splitExtension + let getFilename = last . splitDirectories + let firstFilenameChar = head . getFilename + -- Only visible files (UNIX-style with leading dot) + let onlyVisible = filter (('.' /=) . firstFilenameChar) + let staticFiles = onlyVisible files + -- Map to output equivalents + let filesOut = fmap (targetPath ++) staticFiles + + -- Declare dependencies + need filesOut + +qualify :: TC.BuildConfig + -> FilePath + -> Maybe [FilePath] +qualify config path = + if targetPath ?== path + then Just [path] + else Nothing + where + targetPath = config ^. TC.targetPath ++ "/*" + +-- | Given where the dependencies are, return a list of assets relative to +-- their own containing components +getDepAssets :: FilePath -> Action [FilePath] +getDepAssets depsPath = do + -- Get all dependencies' root directories. + depNames <- getDirectoryDirs depsPath + -- In this context, everything is relative to the asset directory. + let depAssetDirs = fmap ((depsPath ) . ( "app/assets")) depNames + -- See if there are even assets. + applicableDeps <- filterM doesDirectoryExist depAssetDirs + + -- Fetch each depednecy's asset files + let assets = [ getDirectoryFiles dep ["//*"] + | dep <- applicableDeps + ] + + -- Return the flatten version of all asset files + concat <$> sequence assets diff --git a/src/Development/Duplo/Styles.hs b/src/Development/Duplo/Styles.hs new file mode 100644 --- /dev/null +++ b/src/Development/Duplo/Styles.hs @@ -0,0 +1,58 @@ +module Development.Duplo.Styles where + +import Control.Lens hiding (Action) +import Control.Monad.Trans.Class (lift) +import Development.Duplo.Utilities (logStatus, headerPrintSetter, expandPaths, compile, createIntermediaryDirectories, CompiledContent, expandDeps) +import Development.Shake +import Development.Shake.FilePath (()) +import qualified Development.Duplo.Types.Config as TC + +build :: TC.BuildConfig + -> FilePath + -> CompiledContent () +build config out = do + liftIO $ logStatus headerPrintSetter "Building styles" + + let cwd = config ^. TC.cwd + let utilPath = config ^. TC.utilPath + let devPath = config ^. TC.devPath + let devCodePath = devPath "modules/index.styl" + let depIds = config ^. TC.dependencies + let expandDeps' = expandDeps depIds + + -- Preconditions + lift $ createIntermediaryDirectories devCodePath + + -- These paths don't need to be expanded + let expandDepsStatic id = [ "components/" ++ id ++ "/app/styl/variables" + , "components/" ++ id ++ "/app/styl/keyframes" + , "components/" ++ id ++ "/app/styl/fonts" + , "components/" ++ id ++ "/app/styl/reset" + , "components/" ++ id ++ "/app/styl/main" + ] + let staticPaths = [ "app/styl/variables" + , "app/styl/keyframes" + , "app/styl/fonts" + , "app/styl/reset" + , "app/styl/main" + ] + ++ expandDeps' expandDepsStatic + + -- These paths need to be expanded by Shake + let expandDepsDynamic id = [ "components/" ++ id ++ "/app/modules" ] + let dynamicPaths = [ "app/modules" ] + ++ expandDeps' expandDepsDynamic + -- Compile dev files in dev mode as well. + ++ [ "dev/modules" | TC.isInDev config ] + + -- Merge both types of paths + paths <- lift $ expandPaths cwd ".styl" staticPaths dynamicPaths + + -- Path to the compiler + let compiler = utilPath "styles.sh" + + -- Compile it + compiled <- compile config compiler [] paths return return + + -- Write it to disk + lift $ writeFileChanged out compiled diff --git a/src/Development/Duplo/Types/AppInfo.hs b/src/Development/Duplo/Types/AppInfo.hs new file mode 100644 --- /dev/null +++ b/src/Development/Duplo/Types/AppInfo.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Development.Duplo.Types.AppInfo where + +import Data.Aeson (FromJSON, ToJSON) +import Data.HashMap.Strict (HashMap, empty) +import GHC.Generics (Generic) + +type Dependencies = HashMap String String +type Modes = HashMap String [String] + +-- | App information extracted from `component.json` +data AppInfo = AppInfo + { name :: String + , repo :: String + , version :: String + , dependencies :: Dependencies + , modes :: Maybe Modes + , images :: [String] + , scripts :: [String] + , styles :: [String] + , templates :: [String] + , fonts :: [String] + } deriving + ( Show + , Generic + ) + +defaultAppInfo = AppInfo + { name = "" + , repo = "" + , version = "" + , dependencies = empty + , modes = Nothing + , images = [] + , scripts = [] + , styles = [] + , templates = [] + , fonts = [] + } + +instance FromJSON AppInfo +instance ToJSON AppInfo diff --git a/src/Development/Duplo/Types/Builder.hs b/src/Development/Duplo/Types/Builder.hs new file mode 100644 --- /dev/null +++ b/src/Development/Duplo/Types/Builder.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE DeriveDataTypeable #-} + +module Development.Duplo.Types.Builder where + +import Control.Exception (Exception) +import Data.Typeable (Typeable) + +data BuilderException = MissingGithubUserException + | MissingGithubRepoException + | MalformedManifestException String + | MissingManifestException String + deriving (Typeable) + +instance Exception BuilderException + +instance Show BuilderException where + show MissingGithubUserException = + "There must be a GitHub user." + show MissingGithubRepoException = + "There must be a GitHub repo." + show (MalformedManifestException path) = + "The manifest file `" ++ path ++ "` is not a valid duplo JSON." + show (MissingManifestException path) = + "`" ++ path ++ "` is expected at the current location." diff --git a/src/Development/Duplo/Types/Config.hs b/src/Development/Duplo/Types/Config.hs new file mode 100644 --- /dev/null +++ b/src/Development/Duplo/Types/Config.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Development.Duplo.Types.Config where + +import Control.Lens hiding (Action) +import Control.Lens.TH (makeLenses) +import Development.Shake +import Network.Wai.Handler.Warp (Port) + +data BuildConfig = BuildConfig { _appName :: String + , _appVersion :: String + , _appId :: String + , _cwd :: String + , _duploPath :: FilePath + -- The "environment" that can be queried at + -- runtime. + , _env :: String + -- Instruct duplo what to build. + , _mode :: String + , _dist :: FilePath + , _input :: String + , _utilPath :: FilePath + , _nodejsPath :: FilePath + , _miscPath :: FilePath + , _defaultsPath :: FilePath + , _appPath :: FilePath + , _devPath :: FilePath + , _testPath :: FilePath + , _assetsPath :: FilePath + , _depsPath :: FilePath + , _targetPath :: FilePath + , _bumpLevel :: String + , _port :: Port + , _dependencies :: [String] + -- `dev`, `test`, or otherwise. Only + -- concerns duplo. + , _buildMode :: String + } deriving (Show) + +makeLenses ''BuildConfig + +isInDev :: BuildConfig -> Bool +isInDev config = config ^. buildMode == "development" + +isInTest :: BuildConfig -> Bool +isInTest config = config ^. buildMode == "test" diff --git a/src/Development/Duplo/Types/JavaScript.hs b/src/Development/Duplo/Types/JavaScript.hs new file mode 100644 --- /dev/null +++ b/src/Development/Duplo/Types/JavaScript.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE DeriveDataTypeable #-} + +module Development.Duplo.Types.JavaScript where + +import Control.Exception (Exception) +import Control.Monad.State.Lazy (State) +import Data.List (intercalate) +import Data.Typeable (Typeable) +import Language.JavaScript.Parser (JSNode(..)) + +data JSCompilerException = ModuleNotFoundException ModuleName + | CircularDependencyException [ModuleName] + | ParseException [String] + -- When the compiler itself is buggy + | InternalParserException String + -- When language-javascript somehow produces + -- a malformed AST + | LanguageJavaScriptException JSNode + deriving (Typeable) + +instance Exception JSCompilerException + +instance Show JSCompilerException where + show (ParseException e) = + "You have some syntax error in your JavaScript:\n" ++ unlines e + show (CircularDependencyException names) = + "Your module dependencies form a cycle:\n" ++ intercalate " => " names + show (ModuleNotFoundException name) = + "The module \"" ++ name ++ "\" is not found." + show (InternalParserException e) = + "Uh oh. The parser itself is misbehaving: " ++ e + show (LanguageJavaScriptException element) = + "language-javascript is not parsing the file correctly:\n" ++ show element + +type LineNumber = Int +type ModuleName = String +type DepScore = Int +-- A module consists of its name, its dependencies by names, and the node +-- itself. +data Module = Module + { _name :: ModuleName + , _dependencies :: [ModuleName] + , _node :: JSNode + , _score :: Maybe DepScore + } deriving (Show) + +type OrderedModules = State [Module] diff --git a/src/Development/Duplo/Types/Options.hs b/src/Development/Duplo/Types/Options.hs new file mode 100644 --- /dev/null +++ b/src/Development/Duplo/Types/Options.hs @@ -0,0 +1,22 @@ +module Development.Duplo.Types.Options where + +import System.Console.GetOpt (OptDescr(..), ArgDescr(..)) + +data Options = Options { optVerbose :: Bool + , optVersion :: Bool + } + +defaultOptions :: Options +defaultOptions = Options { optVerbose = False + , optVersion = False + } + +options :: [ OptDescr (Options -> IO Options) + ] +options = [ Option "v" ["version"] + (NoArg $ \opt -> return opt { optVersion = True }) + "Display version" + , Option "V" ["verbose"] + (NoArg $ \opt -> return opt { optVerbose = True }) + "Run chattily" + ] diff --git a/src/Development/Duplo/Utilities.hs b/src/Development/Duplo/Utilities.hs new file mode 100644 --- /dev/null +++ b/src/Development/Duplo/Utilities.hs @@ -0,0 +1,222 @@ +module Development.Duplo.Utilities where + +import Control.Applicative ((<$>)) +import Control.Lens.Operators +import Control.Monad (filterM, zipWithM) +import Control.Monad.Except (ExceptT(..), runExceptT) +import Control.Monad.IO.Class (MonadIO) +import Control.Monad.Trans.Class (lift) +import Data.List (intercalate, isSuffixOf) +import Development.Duplo.Files (readFile, File(..), fileContent) +import Development.Shake (CmdOption(..)) +import Development.Shake.FilePath (()) +import Prelude hiding (readFile) +import System.Console.ANSI (setSGR, SGR(..), ConsoleLayer(..), ColorIntensity(..), Color(..)) +import System.FilePath.Posix (joinPath, splitPath) +import qualified Control.Lens as CL +import qualified Data.Text as T +import qualified Development.Duplo.Component as CM +import qualified Development.Duplo.Types.AppInfo as AI +import qualified Development.Duplo.Types.Config as TC +import qualified Development.Shake as DS + +type CompiledContent = ExceptT String DS.Action +type FileProcessor = [File] -> CompiledContent [File] +type StringProcessor = String -> CompiledContent String + +-- | Construct a file pattern by providing a base directory and an +-- extension. +makePattern :: FilePath -> String -> FilePath +makePattern base extension = base ++ "//*" ++ extension + +-- | Construct and return the given base directory and extension whose base +-- directory exists. +makeValidPattern :: FilePath -> String -> DS.Action [FilePath] +makeValidPattern base extension = do + exists <- DS.doesDirectoryExist base + let ptrn = makePattern base extension + return [ ptrn | exists ] + +-- | Splice a list of base directories and their corresponding extensions +-- for a list of file patterns. +makeFilePatterns :: [FilePath] -> [String] -> DS.Action [DS.FilePattern] +makeFilePatterns bases exts = do + patternList <- zipWithM makeValidPattern bases exts + let concat = foldl1 (++) + -- Avoid infinite list. + let patterns = if null patternList + then return [] + else concat patternList + return patterns + +-- | Given a working directory and a list of patterns, expand all the +-- paths, in order. +getDirectoryFilesInOrder :: FilePath -> String -> [DS.FilePattern] -> DS.Action [FilePath] +getDirectoryFilesInOrder base extension patterns = do + -- We need to terminate the infinite list. + let listSize = length patterns + -- Make extension a list of itself. + let exts = replicate listSize extension + -- Turn file patterns into absolute patterns. + let absPatterns = fmap (base ) patterns + -- Make sure we get all valid file patterns for dynamic paths. + validPatterns <- makeFilePatterns absPatterns exts + -- Remove the prefix that was needed for file pattern construction. + let relPatterns = fmap (drop (length base + 1)) validPatterns + -- We need to turn all elements into lists for each to be run independently. + let patternLists = fmap (replicate 1) relPatterns + -- Curry the function that gets the files given a list of paths. + let getFiles = getDirectoryFiles base + -- Map over the list monadically to get the paths in order. + allFiles <- mapM getFiles patternLists + -- Re-package the contents into the list of paths that we've wanted. + let files = concat $ filter (not . null) allFiles + -- We're all set + return files + +-- | Given the path to a compiler, parameters to the compiler, a list of +-- paths of to-be-compiled files, the output file path, and a processing +-- function, do the following: +-- +-- * reads all the to-be-compiled files +-- * calls the processor with the list of files to perform any +-- pre-processing +-- * concatenates all files +-- * passes the concatenated string to the compiler +-- * returns the compiled content +compile :: TC.BuildConfig + -- The path to the compilation command + -> FilePath + -- The parameters passed to the compilation command + -> [String] + -- Files to be compiled + -> [FilePath] + -- The processing lambda: it is handed with a list of files. + -> FileProcessor + -- The postpcessing lambda: it is handed with all content + -- concatenated. + -> StringProcessor + -- The compiled content + -> CompiledContent String +compile config compiler params paths preprocess postprocess = do + mapM_ (lift . DS.putNormal . ("Including " ++)) paths + + let cwd = config ^. TC.cwd + + -- Construct files + files <- mapM (readFile cwd) paths + + -- Pass to processor for specific manipulation + processed <- preprocess files + + -- We only care about the content from this point on + let contents = fmap (^. fileContent) processed + + -- Trailing newline is significant in case of empty Stylus + let concatenated = intercalate "\n" contents ++ "\n" + + -- Send string over to post-processor in case of any manipulation before + -- handing off to the compiler. Add trailing newline for hygiene. + postprocessed <- (++ "\n") <$> postprocess concatenated + + -- Paths should be available as environment variables + envOpt <- createStdEnv config + + lift $ DS.putNormal $ "Compiling with: " + ++ compiler + ++ " " + ++ unwords params + -- Pass it through the compiler + DS.Stdout compiled <- + lift $ DS.command [DS.Stdin postprocessed, envOpt] compiler params + + -- The output + return compiled + +-- | Given a list of static and a list of dynamic paths, return a list of +-- all paths, resolved to absolute paths. +expandPaths :: FilePath -> String -> [FilePath] -> [FilePath] -> DS.Action [FilePath] +expandPaths cwd extension staticPaths dynamicPaths = do + let expandStatic = map (\p -> cwd p ++ extension) + let expandDynamic = map (cwd ) + staticExpanded <- filterM DS.doesFileExist $ expandStatic staticPaths + dynamicExpanded <- getDirectoryFilesInOrder cwd extension dynamicPaths + return $ staticExpanded ++ expandDynamic dynamicExpanded + +-- | Given a list of paths, make sure all intermediary directories are +-- there. +createPathDirectories :: [FilePath] -> DS.Action () +createPathDirectories paths = do + let mkdir dir = DS.command_ [] "mkdir" ["-p", dir] + existing <- filterM (fmap not . DS.doesDirectoryExist) paths + mapM_ mkdir existing + +-- | Create all the directories within a path if they do not exist. Note +-- that the last segment is assumed to be the file and therefore not +-- created. +createIntermediaryDirectories :: String -> DS.Action () +createIntermediaryDirectories path = + DS.command_ [] "mkdir" ["-p", dir] + where + dir = joinPath $ init $ splitPath path + +-- | Return a list of dynamic paths given a list of dependency ID and +-- a function to expand one ID into a list of paths. +expandDeps :: [String] -> (String -> [FilePath]) -> [FilePath] +expandDeps deps expander = concat $ fmap expander deps + +-- | Shake hangs when the path given to `getDirectoryFiles` doesn't exist. +-- This is a safe version of that. +getDirectoryFiles :: FilePath -> [DS.FilePattern] -> DS.Action [FilePath] +getDirectoryFiles base patterns = do + exist <- DS.doesDirectoryExist base + if exist + then DS.getDirectoryFiles base patterns + else return [] + +-- | Error printer: white text over red background. +errorPrintSetter :: IO () +errorPrintSetter = setSGR [ SetColor Background Vivid Red + , SetColor Foreground Vivid White + ] + +-- | Header printer: blue text +headerPrintSetter :: IO () +headerPrintSetter = setSGR [ SetColor Foreground Vivid Magenta ] + +-- | Success printer: white text over green background +successPrintSetter :: IO () +successPrintSetter = setSGR [ SetColor Background Vivid Green + , SetColor Foreground Vivid White + ] + +-- | Log a message with a provided print configuration setter. +logStatus :: IO () -> String -> IO () +logStatus printSetter message = do + printSetter + putStr $ "\n>> " ++ message + setSGR [Reset] + putStrLn "" + +-- | Put together common (i.e. standard) environment variables. +createStdEnv :: MonadIO m => TC.BuildConfig -> m CmdOption +createStdEnv config = do + let cwd = config ^. TC.cwd + let util = config ^. TC.utilPath + let nodejs = config ^. TC.nodejsPath + let misc = config ^. TC.miscPath + + DS.addEnv [ ("DUPLO_UTIL", util) + , ("DUPLO_NODEJS", nodejs) + , ("DUPLO_CWD", cwd) + , ("DUPLO_MISC", misc) + ] + +-- | Like `Data.Text.replace`, but for strings +replace :: String -> String -> String -> String +replace needle replacement haystack = replaced + where + needle' = T.pack needle + replacement' = T.pack replacement + haystack' = T.pack haystack + replaced = T.unpack $ T.replace needle' replacement' haystack' diff --git a/src/Development/Duplo/Watcher.hs b/src/Development/Duplo/Watcher.hs new file mode 100644 --- /dev/null +++ b/src/Development/Duplo/Watcher.hs @@ -0,0 +1,71 @@ +module Development.Duplo.Watcher where + +import Control.Concurrent (threadDelay, forkIO, forkFinally, ThreadId(..), killThread) +import Control.Concurrent.Chan (Chan, newChan, readChan, getChanContents) +import Control.Exception (try) +import Control.Monad (forever, void, when, unless) +import Data.Foldable (forM_) +import Data.IORef (newIORef, readIORef, writeIORef, IORef) +import Data.Maybe (isJust, fromJust) +import Data.String (fromString) +import System.FSNotify (withManagerConf, watchTreeChan, WatchConfig(..), Debounce(..), Action, Event) +import System.FilePath.Posix (FilePath) + +-- | Given some paths to watch and something to do, watch every 100ms +-- without debouncing but would interrupt the action when there is a new +-- event. +watch :: IO () -> [FilePath] -> IO () +watch onChange paths = do + let watchConfig = WatchConfig { confDebounce = NoDebounce + , confPollInterval = 100000 + , confUsePolling = False + } + + -- We need a variable to store the currently executing handler. + tidVar <- newIORef (Nothing :: Maybe ThreadId) + + -- We need a channel to prevent race condition when an event is + -- triggered on multiple paths. + chan <- newChan :: IO (Chan Event) + -- Make it a stream + let chanStream = getChanContents chan + + -- The handler needs special treatment capturing IO exceptions. The + -- policy is simply to drop all exceptions because we have a lot of + -- incoming requests. + let exceptionHandler _ = return () + let handler = forkFinally onChange exceptionHandler + + -- Curry `handleEvent` to stay DRY + let handleEvent' = handleEvent tidVar handler + + -- Make sure we handle the event with a channel to avoid race + -- condition. + forkIO $ chanStream >>= mapM_ (handleEvent' . Just) + + -- Start watching + withManagerConf watchConfig $ \manager -> do + let paths' = fmap fromString paths + let always = const True + let watch' p = watchTreeChan manager p always chan + + -- Always start an initial round + void $ handleEvent' Nothing + + -- Watch for changes + mapM_ watch' paths' + + -- Hibernate, for a year! + forever $ threadDelay $ 1000000 * 60 * 60 * 24 * 365 + +-- | Interrupt the given thread and re-perform the action. +handleEvent :: IORef (Maybe ThreadId) -> IO ThreadId -> Maybe Event -> IO () +handleEvent tidVar handler _ = do + tid <- readIORef tidVar + -- Kill existing thread + forM_ tid killThread + + -- Perform action + newTid <- handler + -- Save thread ID + writeIORef tidVar $ Just newTid diff --git a/src/Duplo.hs b/src/Duplo.hs deleted file mode 100644 --- a/src/Duplo.hs +++ /dev/null @@ -1,227 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} - -import Control.Applicative ((<$>)) -import Control.Exception (catch, handle, throw, Exception) -import Control.Lens.Operators -import Control.Monad (void, when, unless) -import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT) -import Data.ByteString.Base64 (decode) -import Data.ByteString.Char8 (pack, unpack) -import Data.Maybe (fromMaybe) -import Data.String.Utils (replace) -import Development.Duplo.Server (serve) -import Development.Duplo.Shake (shakeMain) -import Development.Duplo.Utilities (logStatus, errorPrintSetter) -import Development.Duplo.Watcher (watch) -import Development.Shake (cmd, ShakeException(..)) -import Development.Shake.FilePath (()) -import GHC.Conc (forkIO) -import System.Console.GetOpt (getOpt, OptDescr(..), ArgDescr(..), ArgOrder(..)) -import System.Directory (getCurrentDirectory, createDirectoryIfMissing, doesFileExist) -import System.Environment (lookupEnv, getArgs, getExecutablePath) -import System.FilePath.Posix (takeDirectory) -import System.Process (proc, createProcess, waitForProcess) -import qualified Control.Lens -import qualified Development.Duplo.Component as CM -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 qualified Filesystem.Path -import qualified GHC.IO - -main = do - -- Command-line arguments - args <- getArgs - - let (cmdName:cmdArgs) = - if (length args > 0) - -- 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 "test/" - 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" -> maybe "production" id duploEnvMB - -- By default, `dev` is the default. - _ -> maybe "development" id 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" -> ( "build" , "" , "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 - - -- We may need custom builds with mode - let depManifestPath = cwd "component.json" - 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" - if makefileExists - then (createProcess $ proc "make" [duploEnv]) >> return () - else return () - - -- Construct the Shake command. - let shake' = shakeMain cmdNameWithFlags cmdArgs buildConfig options - let shake = shake' `catch` handleExc - - -- 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 "" diff --git a/tests/Tests.hs b/tests/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/Tests.hs @@ -0,0 +1,13 @@ +module Main where + +import Development.Duplo.Types.AppInfo +import Test.Hspec +import qualified Development.Duplo.Component as DC + +main :: IO () +main = hspec $ + describe "Component support" $ + it "extracts component ID" $ do + let appInfo = defaultAppInfo { repo = "pixbi/duplo" } + let appId = DC.appId appInfo + appId `shouldBe` "pixbi-duplo"