diff --git a/snaplet-purescript.cabal b/snaplet-purescript.cabal --- a/snaplet-purescript.cabal +++ b/snaplet-purescript.cabal @@ -1,5 +1,5 @@ name: snaplet-purescript -version: 0.4.1.0 +version: 0.5.1.0 synopsis: Automatic (re)compilation of purescript projects description: Automatic (re)compilation of purescript projects license: MIT @@ -19,6 +19,7 @@ Snap.Snaplet.PureScript other-modules: Snap.Snaplet.PureScript.Internal + Snap.Snaplet.PureScript.Hooks Paths_snaplet_purescript build-depends: base >=4.6 && < 5.1, snap-core < 1.0.0.0, diff --git a/src/Snap/Snaplet/PureScript.hs b/src/Snap/Snaplet/PureScript.hs --- a/src/Snap/Snaplet/PureScript.hs +++ b/src/Snap/Snaplet/PureScript.hs @@ -12,7 +12,6 @@ import Control.Monad import Control.Monad.IO.Class import Control.Monad.State.Strict -import Data.Char import Data.Configurator as Cfg import Data.Monoid import Data.String @@ -23,6 +22,7 @@ import Shelly hiding (get) import Snap.Core import Snap.Snaplet +import Snap.Snaplet.PureScript.Hooks import Snap.Snaplet.PureScript.Internal import Snap.Snaplet.PureScript.Internal as Internals (PureScript) import Text.Printf @@ -33,58 +33,67 @@ -- | Snaplet initialization initPurs :: SnapletInit b PureScript initPurs = makeSnaplet "purs" description (Just dataDir) $ do - config <- getSnapletUserConfig env <- getEnvironment + + destDir <- getDestDir + shelly $ verbosely $ chdir (fromText destDir) $ do + let envCfg = fromText $ destDir <> T.pack ("/" <> env <> ".cfg") + echo $ "Checking existance of " <> toTextIgnore envCfg + envCfgExists <- test_f envCfg + unless envCfgExists $ do + touchfile envCfg + writefile envCfg envCfgTemplate + + config <- getSnapletUserConfig + hooks <- liftIO $ getHooks config + shelly $ verbosely $ chdir (fromText destDir) $ preInitHook hooks + outDir <- liftIO (lookupDefault "js" config "buildDir") verbosity <- liftIO (lookupDefault Verbose config "verbosity") bndl <- liftIO (lookupDefault True config "bundle") bundleName <- liftIO (lookupDefault "app.js" config "bundleName") - modules <- liftIO (lookupDefault mempty config "modules") - pulpPath <- findOrInstallPulp =<< liftIO (Cfg.lookup config "pulpPath") + modules <- liftIO (lookupDefault ["Main"] config "modules") + psPath <- liftIO (lookupDefault mempty config "pureScriptPath") + pulpPath <- findOrInstallPulp psPath =<< liftIO (Cfg.lookup config "pulpPath") psaOpts <- liftIO (lookupDefault mempty config "psaOpts") permissive <- liftIO (lookupDefault False config "permissiveInit") cm <- getCompilationFlavour - destDir <- getDestDir bowerfile <- fromText <$> getBowerFile - let envCfg = fromText $ destDir <> T.pack ("/" <> env <> ".cfg") -- If they do not exist, create the required directories - purs <- shelly $ verbosely $ do - mapM_ mkdir_p [fromText outDir] + purs <- shelly $ verbosely $ chdir (fromText destDir) $ do + mkdir_p (fromText outDir) bowerFileExists <- test_f bowerfile - envCfgExists <- test_f envCfg echo $ "Checking existance of " <> toTextIgnore bowerfile unless bowerFileExists $ do - chdir (fromText destDir) $ run_ (fromString $ getPulpPath pulpPath) ["init"] - echo $ "Checking existance of " <> toTextIgnore envCfg - - let purs = PureScript { - pursCompilationMode = cm - , pursVerbosity = verbosity - , pursBundle = bndl - , pursBundleName = bundleName - , pursPulpPath = pulpPath - , pursPsaOpts = psaOpts - , pursPermissiveInit = permissive - , pursPwdDir = destDir - , pursOutputDir = outDir - , pursModules = modules - } + run_ (fromString $ getPulpPath pulpPath) ["init"] - unless envCfgExists $ do - touchfile envCfg - writefile envCfg (envCfgTemplate purs) - return purs + return PureScript { + pursCompilationMode = cm + , pursVerbosity = verbosity + , pursBundle = bndl + , pursBundleName = bundleName + , pursPulpPath = pulpPath + , pursPsPath = psPath + , pursPsaOpts = psaOpts + , pursPermissiveInit = permissive + , pursPwdDir = destDir + , pursOutputDir = outDir + , pursModules = modules + , pursHooks = hooks + } - -- compile at least once, regardless of the CompilationMode. + -- compile at least once, unless `CompileNever` was passed. -- NOTE: We ignore the ouput of this first compilation -- if we are running in a 'permissive' mode, to avoid having the entire -- web service to grind to an halt in case our Purs does not compile. - res <- build purs - _ <- bundle purs - case res of - CompilationFailed reason -> unless permissive (fail (T.unpack reason)) - CompilationSucceeded -> return () + unless (cm == CompileNever) $ do + res <- build purs + _ <- bundle purs + case res of + CompilationFailed reason -> unless permissive (fail (T.unpack reason)) + CompilationSucceeded -> return () + shelly $ verbosely $ chdir (fromText destDir) $ postInitHook hooks return purs where description = "Automatic (re)compilation of PureScript projects" @@ -122,9 +131,12 @@ build :: MonadIO m => PureScript -> m CompilationOutput build PureScript{..} = shV $ errExit False $ do chdir (fromText pursPwdDir) $ do - let args = ["build", "-o", pursOutputDir] <> pursPsaOpts + prependToPath (fromText pursPsPath) + preBuildHook pursHooks + let args = ["build", "-o", pursPwdDir <> "/" <> pursOutputDir] <> pursPsaOpts run_ (fromString . getPulpPath $ pursPulpPath) args eC <- lastExitCode + preBuildHook pursHooks case (eC == 0) of True -> return CompilationSucceeded False -> CompilationFailed <$> lastStderr @@ -133,15 +145,18 @@ bundle :: MonadIO m => PureScript -> m CompilationOutput bundle PureScript{..} = liftIO $ shelly $ verbosely $ errExit False $ chdir (fromText pursPwdDir) $ do + prependToPath (fromText pursPsPath) let bundlePath = pursOutputDir <> "/" <> pursBundleName case pursBundle of False -> return CompilationSucceeded True -> do + preBundleHook pursHooks rm_rf (fromText bundlePath) let modules = T.intercalate " -m " pursModules echo $ "Bundling everything in " <> bundlePath res <- run "psc-bundle" (["js/**/*.js", "-m"] <> (T.words modules) <> ["-o", bundlePath, "-n", "PS"]) + postBundleHook pursHooks eC <- lastExitCode case (eC == 0) of True -> return CompilationSucceeded @@ -152,7 +167,8 @@ compileWithMode = do mode <- gets pursCompilationMode case mode of - CompileOnce -> return CompilationSucceeded + CompileNever -> return CompilationSucceeded + CompileOnce -> return CompilationSucceeded CompileAlways -> do workDir <- gets pursPwdDir pursLog $ "Compiling Purescript project at " <> T.unpack workDir @@ -163,7 +179,8 @@ bundleWithMode _ = do mode <- gets pursCompilationMode case mode of - CompileOnce -> return CompilationSucceeded + CompileOnce -> return CompilationSucceeded + CompileNever -> return CompilationSucceeded CompileAlways -> do workDir <- gets pursPwdDir pursLog $ "Bundling Purescript project at " <> T.unpack workDir @@ -183,41 +200,59 @@ |] (T.unpack js) -------------------------------------------------------------------------------- -envCfgTemplate :: PureScript -> T.Text -envCfgTemplate PureScript{..} = T.pack $ printf [r| - # Choose one between 'Verbose' and 'Quiet' - # - verbosity = "%s" - # - # Choose one between 'CompileOnce' and 'CompileAlways' - # - compilationMode = "%s" - # - # Whether bundle everything in a fat app - # - bundle = %s - # - # The path to a specific, user-provided version of Pulp. - # Leave it uncommented if you plan to use the globally-installed one or you - # are OK with snaplet-purescript installing it for you. - # - # pulpPath = "" - # - # Extra options to pass to https://github.com/natefaubion/purescript-psa, - # if available. - psaOpts = [] - # - permissiveInit = false - # Be lenient towards compilation errors in case the `pursInit` function - # initial compilation fails. Useful in devel mode to avoid your web server - # to not start at all when you are debugging your PS. - # - # The name of the output bundle - bundleName = "%s" - # - # The list of modules you want to compile under the PS namespace (bundle only) - modules = [] -|] (show pursVerbosity) - (show pursCompilationMode) - (map toLower $ show pursBundle) - (T.unpack pursBundleName) +envCfgTemplate :: T.Text +envCfgTemplate = T.pack [r| +# Choose one between 'Verbose' and 'Quiet' +# +verbosity = "Verbose" +# +# Choose one between 'CompileOnce' and 'CompileAlways' +# +compilationMode = "CompileAlways" +# +# Whether bundle everything in a fat app +# +bundle = true +# +# The path to a specific directory containing the purescript toolchain. +# Example: snaplet/purs/node_modules/purescript/vendor. +# Leave it uncommented if you plan to use the globally-installed one. +# +# pureScriptPath = "" +# +# The path to a specific, user-provided version of Pulp. +# Leave it uncommented if you plan to use the globally-installed one or you +# are OK with snaplet-purescript installing it for you. +# +# pulpPath = "" +# +# Extra options to pass to https://github.com/natefaubion/purescript-psa, +# if available. +psaOpts = [] +# +permissiveInit = false +# Be lenient towards compilation errors in case the `pursInit` function +# initial compilation fails. Useful in devel mode to avoid your web server +# to not start at all when you are debugging your PS. +# +# The name of the output bundle +bundleName = "app.js" +# +# The list of modules you want to compile under the PS namespace (bundle only) +# Adding 'Main' will make sure you will have something like PS.Main.main in +# your generated JS. +modules = ["Main"] +# +# Hooks - They are a way to invoke certain action during the snaplet lifecycle. +# They accept a shell command where the first token is the command itself, +# the rest are the parameters for the command. The entire hook section or each +# individual hook can be omitted. +hooks { + preInit = "echo 'hello'" + postInit = "" + preBuild = "" + postBuild = "" + preBundle = "" + postBundle = "" +} +|] diff --git a/src/Snap/Snaplet/PureScript/Hooks.hs b/src/Snap/Snaplet/PureScript/Hooks.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/PureScript/Hooks.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE OverloadedStrings #-} +module Snap.Snaplet.PureScript.Hooks ( + getHooks + , Hook + , Hooks(..) + ) where + +import Data.Configurator +import Data.Configurator.Types (Config) +import qualified Data.Text as T +import Shelly + +-------------------------------------------------------------------------------- +type Hook = Sh () + +-------------------------------------------------------------------------------- +data Hooks = Hooks { + preInitHook :: Hook + , postInitHook :: Hook + , preBuildHook :: Hook + , postBuildHook :: Hook + , preBundleHook :: Hook + , postBundleHook :: Hook + } + +instance Show Hooks where + show _ = "<>" + +-------------------------------------------------------------------------------- +noOpHook :: Hook +noOpHook = return () + +-------------------------------------------------------------------------------- +mkHook :: T.Text -> Hook +mkHook "" = noOpHook +mkHook t = case T.words t of + [] -> noOpHook + (x:args) -> run_ (fromText x) args + +-------------------------------------------------------------------------------- +getHooks :: Config -> IO Hooks +getHooks cfg = + Hooks <$> (mkHook <$> lookupDefault "" cfg "hooks.preInit") + <*> (mkHook <$> lookupDefault "" cfg "hooks.postInit") + <*> (mkHook <$> lookupDefault "" cfg "hooks.preBuild") + <*> (mkHook <$> lookupDefault "" cfg "hooks.postBuild") + <*> (mkHook <$> lookupDefault "" cfg "hooks.preBundle") + <*> (mkHook <$> lookupDefault "" cfg "hooks.postBundle") diff --git a/src/Snap/Snaplet/PureScript/Internal.hs b/src/Snap/Snaplet/PureScript/Internal.hs --- a/src/Snap/Snaplet/PureScript/Internal.hs +++ b/src/Snap/Snaplet/PureScript/Internal.hs @@ -13,6 +13,7 @@ , getDestDir , getBowerFile , getAbsoluteOutputDir + , prependToPath , findOrInstallPulp , shV , shS @@ -28,14 +29,17 @@ import Data.String import Data.String.Conv import qualified Data.Text as T +import qualified Shelly as Sh import Shelly hiding (FilePath) import Snap +import Snap.Snaplet.PureScript.Hooks (Hooks) import Text.Read hiding (String) -------------------------------------------------------------------------------- data CompilationMode = CompileOnce | CompileAlways - deriving (Show, Read) + | CompileNever + deriving (Show, Eq, Read) instance Configured CompilationMode where convert (String t) = readMaybe . T.unpack $ t @@ -72,12 +76,15 @@ , pursBundleName :: !T.Text -- ^ The name for your bundled output. , pursPulpPath :: !PulpPath - -- ^ The absolute path to the path executable. This can be user-provided + -- ^ The absolute path to a `pulp` executable. This can be user-provided -- or inferred automatically by this snaplet. + , pursPsPath :: !T.Text + -- ^ The absolute path to the directory containing the PureScript toolchain. + -- If not specified, this snaplet will use the globally installed PureScript. , pursPsaOpts :: [T.Text] -- ^ Extra options to pass to https://github.com/natefaubion/purescript-psa, -- if available. - , pursPermissiveInit :: Bool + , pursPermissiveInit :: !Bool -- ^ Be lenient towards compilation errors in case the `pursInit` function -- initial compilation fails. Useful in devel mode to avoid your web server -- to not start at all when you are debugging your PS. @@ -86,7 +93,9 @@ , pursOutputDir :: !T.Text , pursModules :: ![T.Text] -- ^ Where to store compilation artifacts (defaults to /js) - } + , pursHooks :: Hooks + -- ^ Hooks to run at different times during the program execution + } deriving Show -------------------------------------------------------------------------------- devFlagEnabled :: Bool @@ -106,16 +115,17 @@ shV = liftIO . shelly . verbosely . escaping False -------------------------------------------------------------------------------- -findOrInstallPulp :: Maybe PulpPath +findOrInstallPulp :: T.Text + -> Maybe PulpPath -> (Monad (m b v), MonadIO (m b v), MonadSnaplet m) => m b v PulpPath -findOrInstallPulp mbP = do +findOrInstallPulp psPath mbP = do let p = fromMaybe (PulpPath "pulp") mbP - installed <- shS (pulpInstalled p) + installed <- shS (pulpInstalled psPath p) case installed of True -> return p False -> shS $ do - echo "Pulp not found, installing it for you..." + echo "Pulp not found, installing it locally for you..." installPulp >> whichPulp -------------------------------------------------------------------------------- @@ -123,16 +133,27 @@ whichPulp = PulpPath . toS . T.strip <$> shS (run "which" ["pulp"]) -------------------------------------------------------------------------------- +-- | add the filepath onto the PATH env variable +prependToPath :: Sh.FilePath -> Sh () +prependToPath fp = do + tp <- toTextWarn fp + pe <- get_env_text "PATH" + setenv "PATH" $ tp <> T.singleton ':' <> pe + +-------------------------------------------------------------------------------- installPulp :: MonadIO m => m () -installPulp = shS $ run_ "npm" ["install", "-g", "pulp"] +installPulp = shS $ run_ "npm" ["install", "pulp"] -------------------------------------------------------------------------------- -pulpInstalled :: PulpPath -> Sh Bool -pulpInstalled (PulpPath pp) = errExit False $ silently $ do - check `catchany_sh` \(_ :: SomeException) -> return False +pulpInstalled :: T.Text -> PulpPath -> Sh Bool +pulpInstalled psPath (PulpPath pp) = errExit False $ verbosely $ do + check `catchany_sh` \(e :: SomeException) -> do + echo (toS . show $ e) + return False where check = do - run_ (fromString pp) ["version"] + prependToPath (fromText psPath) + run_ (fromString pp) ["--version"] eC <- lastExitCode return $ case eC of 0 -> True @@ -140,9 +161,12 @@ _ -> False -------------------------------------------------------------------------------- --- | Returns the 'CompilationMode' the Snaplet should be using. --- It will default to 'CompileAlways' if your Snap app was compiled with --- -fdevelopment or the environment is "devel", 'CompileOnce' otherwise. +-- | Returns the `CompilationMode` the Snaplet should be using. +-- It will default to `CompileAlways` if your Snap app was compiled with +-- -fdevelopment or the environment is "devel", `CompileOnce` otherwise. +-- Consider using `CompileNever` if you do not want this snaplet to build +-- your .js bundle on the fly, for example if you have frozen its content and +-- you want to serve it straigth away in production. getCompilationFlavour :: Initializer b v CompilationMode getCompilationFlavour = do -- Any input for the user have highest priority