duplo 1.6.6 → 1.6.9
raw patch · 23 files changed
+2125/−253 lines, 23 filesdep +duplodep +hspecdep −MissingHdep ~base
Dependencies added: duplo, hspec
Dependencies removed: MissingH
Dependency ranges changed: base
Files
- README.md +5/−2
- duplo.cabal +83/−24
- src/CLI.hs +228/−0
- src/Development/Duplo.hs +143/−0
- src/Development/Duplo/Component.hs +145/−0
- src/Development/Duplo/FileList.hs +73/−0
- src/Development/Duplo/Files.hs +71/−0
- src/Development/Duplo/Git.hs +129/−0
- src/Development/Duplo/JavaScript/Order.hs +146/−0
- src/Development/Duplo/Markups.hs +164/−0
- src/Development/Duplo/Scripts.hs +169/−0
- src/Development/Duplo/Server.hs +74/−0
- src/Development/Duplo/Static.hs +149/−0
- src/Development/Duplo/Styles.hs +58/−0
- src/Development/Duplo/Types/AppInfo.hs +43/−0
- src/Development/Duplo/Types/Builder.hs +24/−0
- src/Development/Duplo/Types/Config.hs +46/−0
- src/Development/Duplo/Types/JavaScript.hs +47/−0
- src/Development/Duplo/Types/Options.hs +22/−0
- src/Development/Duplo/Utilities.hs +222/−0
- src/Development/Duplo/Watcher.hs +71/−0
- src/Duplo.hs +0/−227
- tests/Tests.hs +13/−0
README.md view
@@ -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
duplo.cabal view
@@ -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.*
+ src/CLI.hs view
@@ -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 ""
+ src/Development/Duplo.hs view
@@ -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)
+ src/Development/Duplo/Component.hs view
@@ -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 "."
+ src/Development/Duplo/FileList.hs view
@@ -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
+ src/Development/Duplo/Files.hs view
@@ -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
+ src/Development/Duplo/Git.hs view
@@ -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'+ }
+ src/Development/Duplo/JavaScript/Order.hs view
@@ -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
+ src/Development/Duplo/Markups.hs view
@@ -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 "<body>" ("<body>" ++ compiled) compiledIndex++ -- Inject CSS/JS references+ refTagsInTest <- lift $ readFile' $ duploPath </> "etc/test/head.html"+ let indexWithTestRefs =+ if inTest+ then replace "</head>" (refTagsInTest ++ "</head>") indexWithMarkup+ else indexWithMarkup++ refTags <- lift $ readFile' refTagsPath+ let indexWithRefs = replace "</head>" (refTags ++ "</head>") 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
+ src/Development/Duplo/Scripts.hs view
@@ -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
+ src/Development/Duplo/Server.hs view
@@ -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"
+ src/Development/Duplo/Static.hs view
@@ -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
+ src/Development/Duplo/Styles.hs view
@@ -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
+ src/Development/Duplo/Types/AppInfo.hs view
@@ -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
+ src/Development/Duplo/Types/Builder.hs view
@@ -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."
+ src/Development/Duplo/Types/Config.hs view
@@ -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"
+ src/Development/Duplo/Types/JavaScript.hs view
@@ -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]
+ src/Development/Duplo/Types/Options.hs view
@@ -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"+ ]
+ src/Development/Duplo/Utilities.hs view
@@ -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'
+ src/Development/Duplo/Watcher.hs view
@@ -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
− src/Duplo.hs
@@ -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 ""
+ tests/Tests.hs view
@@ -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"