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.0.0 +version: 0.4.1.0 synopsis: Automatic (re)compilation of purescript projects description: Automatic (re)compilation of purescript projects license: MIT @@ -20,16 +20,16 @@ other-modules: Snap.Snaplet.PureScript.Internal Paths_snaplet_purescript - build-depends: - base >=4.6 && < 5.0, - snap-core < 1.0.0.0, - snap < 1.0.0.0, - raw-strings-qq >= 1.0.2, - text > 0.11 && < 1.4.0.0, - mtl < 2.5, - transformers, - configurator >= 0.2.0.0, - shelly >= 0.4.1 && < 1.7 + build-depends: base >=4.6 && < 5.1, + snap-core < 1.0.0.0, + snap < 1.0.0.0, + raw-strings-qq >= 1.0.2, + string-conv, + text > 0.11 && < 1.4.0.0, + mtl, + transformers, + configurator >= 0.2.0.0, + shelly >= 0.4.1 hs-source-dirs: src default-language: Haskell2010 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 @@ -9,25 +9,26 @@ , module Internals ) where -import Prelude hiding (FilePath) -import Control.Monad.IO.Class -import Control.Exception (SomeException) -import Snap.Core -import Snap.Snaplet -import Data.Char import Control.Monad +import Control.Monad.IO.Class import Control.Monad.State.Strict -import Paths_snaplet_purescript -import Shelly hiding (get) -import Text.Printf +import Data.Char +import Data.Configurator as Cfg import Data.Monoid -import Data.Configurator -import qualified Data.Text.Encoding as TE +import Data.String import qualified Data.Text as T -import Snap.Snaplet.PureScript.Internal as Internals (PureScript) +import qualified Data.Text.Encoding as TE +import Paths_snaplet_purescript +import Prelude hiding (FilePath) +import Shelly hiding (get) +import Snap.Core +import Snap.Snaplet import Snap.Snaplet.PureScript.Internal +import Snap.Snaplet.PureScript.Internal as Internals (PureScript) +import Text.Printf import Text.RawString.QQ + -------------------------------------------------------------------------------- -- | Snaplet initialization initPurs :: SnapletInit b PureScript @@ -38,10 +39,12 @@ 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") + modules <- liftIO (lookupDefault mempty config "modules") + pulpPath <- findOrInstallPulp =<< liftIO (Cfg.lookup config "pulpPath") + psaOpts <- liftIO (lookupDefault mempty config "psaOpts") + permissive <- liftIO (lookupDefault False config "permissiveInit") cm <- getCompilationFlavour destDir <- getDestDir - let buildDir = destDir <> "/" <> outDir bowerfile <- fromText <$> getBowerFile let envCfg = fromText $ destDir <> T.pack ("/" <> env <> ".cfg") -- If they do not exist, create the required directories @@ -49,14 +52,9 @@ mapM_ mkdir_p [fromText outDir] bowerFileExists <- test_f bowerfile envCfgExists <- test_f envCfg - unlessM (pulpInstalled (fromText destDir)) $ do - liftIO $ do - putStrLn $ T.unpack $ "Local pulp not found in " <> destDir <> ", installing it for you..." - installPulp (fromText destDir) - putStrLn $ "Pulp installed." echo $ "Checking existance of " <> toTextIgnore bowerfile unless bowerFileExists $ do - chdir (fromText destDir) $ run_ "pulp" ["init"] + chdir (fromText destDir) $ run_ (fromString $ getPulpPath pulpPath) ["init"] echo $ "Checking existance of " <> toTextIgnore envCfg let purs = PureScript { @@ -64,6 +62,9 @@ , pursVerbosity = verbosity , pursBundle = bndl , pursBundleName = bundleName + , pursPulpPath = pulpPath + , pursPsaOpts = psaOpts + , pursPermissiveInit = permissive , pursPwdDir = destDir , pursOutputDir = outDir , pursModules = modules @@ -75,13 +76,13 @@ return purs -- compile at least once, regardless of the CompilationMode. - -- NOTE: We might want to ignore the ouput of this first compilation + -- 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 -> fail (T.unpack reason) + CompilationFailed reason -> unless permissive (fail (T.unpack reason)) CompilationSucceeded -> return () return purs @@ -96,24 +97,6 @@ unless (verb == Quiet) (liftIO $ putStrLn $ "snaplet-purescript: " <> l) -------------------------------------------------------------------------------- -pulpInstalled :: FilePath -> Sh Bool -pulpInstalled dir = errExit False $ silently $ chdir dir $ do - check `catchany_sh` \(_ :: SomeException) -> return False - where - check = do - run_ "pulp" [] - eC <- lastExitCode - return $ case eC of - 0 -> True - 1 -> True - _ -> False - --------------------------------------------------------------------------------- -installPulp :: MonadIO m => FilePath -> m () -installPulp dir = liftIO $ shelly $ silently $ chdir dir $ do - run_ "npm" ["install", "-g", "pulp"] - --------------------------------------------------------------------------------- pursServe :: Handler b PureScript () pursServe = do (_, requestedJs) <- (fmap (T.takeWhile (/= '?')) . T.breakOn "/" . T.drop 1 . TE.decodeUtf8 . rqURI) <$> getRequest @@ -122,29 +105,29 @@ _ -> do pursLog $ "Requested file: " <> T.unpack requestedJs modifyResponse . setContentType $ "text/javascript;charset=utf-8" - pwdDir <- getDestDir outDir <- getAbsoluteOutputDir let fulljsPath = outDir <> requestedJs pursLog $ "Serving " <> T.unpack (fulljsPath) - compMode <- gets pursCompilationMode res <- compileWithMode _ <- bundleWithMode (T.drop 1 requestedJs) case res of - CompilationFailed reason -> writeText reason + CompilationFailed reason -> do + let curatedOutput = T.replace "\"" "\\\"" . T.replace "\n" "\\n" $ reason + writeText $ "(function() { console.log(\"" <> curatedOutput <> "\"); })();" CompilationSucceeded -> (shelly $ silently $ readfile (fromText fulljsPath)) >>= writeText -------------------------------------------------------------------------------- -- | Build the project (without bundling it). build :: MonadIO m => PureScript -> m CompilationOutput -build PureScript{..} = - liftIO $ shelly $ verbosely $ errExit False $ - chdir (fromText pursPwdDir) $ do - res <- run "pulp" ["build", "-o", pursOutputDir] - eC <- lastExitCode - case (eC == 0) of - True -> return CompilationSucceeded - False -> return $ CompilationFailed res +build PureScript{..} = shV $ errExit False $ do + chdir (fromText pursPwdDir) $ do + let args = ["build", "-o", pursOutputDir] <> pursPsaOpts + run_ (fromString . getPulpPath $ pursPulpPath) args + eC <- lastExitCode + case (eC == 0) of + True -> return CompilationSucceeded + False -> CompilationFailed <$> lastStderr -------------------------------------------------------------------------------- bundle :: MonadIO m => PureScript -> m CompilationOutput @@ -177,14 +160,13 @@ -------------------------------------------------------------------------------- bundleWithMode :: T.Text -> Handler b PureScript CompilationOutput -bundleWithMode artifactName = do +bundleWithMode _ = do mode <- gets pursCompilationMode case mode of CompileOnce -> return CompilationSucceeded CompileAlways -> do workDir <- gets pursPwdDir pursLog $ "Bundling Purescript project at " <> T.unpack workDir - outDir <- gets pursOutputDir get >>= bundle -------------------------------------------------------------------------------- @@ -204,25 +186,38 @@ 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) - --------------------------------------------------------------------------------- -mainTemplate :: T.Text -mainTemplate = T.pack [r| - module Main where - - import Debug.Trace - - main = trace "Hello PS world!" -|] 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 @@ -1,29 +1,59 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE OverloadedStrings #-} -module Snap.Snaplet.PureScript.Internal where +module Snap.Snaplet.PureScript.Internal ( + CompilationMode(..) + , CompilationOutput(..) + , Verbosity(..) + , PulpPath(getPulpPath) + , PureScript(..) + , devFlagEnabled + , getCompilationFlavour + , getDestDir + , getBowerFile + , getAbsoluteOutputDir + , findOrInstallPulp + , shV + , shS + ) where -import Snap -import Control.Applicative -import Data.Monoid +import Control.Exception (SomeException) import Control.Monad.IO.Class import Control.Monad.Reader import Data.Configurator as Cfg import Data.Configurator.Types -import Text.Read hiding (String) +import Data.Maybe +import Data.Monoid +import Data.String +import Data.String.Conv import qualified Data.Text as T +import Shelly hiding (FilePath) +import Snap +import Text.Read hiding (String) -------------------------------------------------------------------------------- -data CompilationMode = - CompileOnce - | CompileAlways - deriving (Show, Read) +data CompilationMode = CompileOnce + | CompileAlways + deriving (Show, Read) instance Configured CompilationMode where convert (String t) = readMaybe . T.unpack $ t convert _ = Nothing -data Verbosity = Verbose | Quiet deriving (Show, Read, Eq) +-------------------------------------------------------------------------------- +newtype PulpPath = PulpPath { getPulpPath :: FilePath } deriving (Show, Read) +instance Configured PulpPath where + convert (String "") = Nothing + convert (String t) = Just . PulpPath . toS $ t + convert _ = Nothing + +-------------------------------------------------------------------------------- +data Verbosity = Verbose + | Quiet + deriving (Show, Read, Eq) + instance Configured Verbosity where convert (String t) = readMaybe . T.unpack $ t convert _ = Nothing @@ -40,8 +70,19 @@ , pursBundle :: !Bool -- ^ Whether or not bundle everything in a fat app with a PS namespace. , pursBundleName :: !T.Text + -- ^ The name for your bundled output. + , pursPulpPath :: !PulpPath + -- ^ The absolute path to the path executable. This can be user-provided + -- or inferred automatically by this snaplet. + , pursPsaOpts :: [T.Text] + -- ^ Extra options to pass to https://github.com/natefaubion/purescript-psa, + -- if available. + , 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. , pursPwdDir :: !T.Text - -- ^ The CWD of your snaplet + -- ^ The PWD of your snaplet , pursOutputDir :: !T.Text , pursModules :: ![T.Text] -- ^ Where to store compilation artifacts (defaults to /js) @@ -57,6 +98,48 @@ #endif -------------------------------------------------------------------------------- +shS :: MonadIO m => Sh a -> m a +shS = liftIO . shelly . silently . escaping False + +-------------------------------------------------------------------------------- +shV :: MonadIO m => Sh a -> m a +shV = liftIO . shelly . verbosely . escaping False + +-------------------------------------------------------------------------------- +findOrInstallPulp :: Maybe PulpPath + -> (Monad (m b v), MonadIO (m b v), MonadSnaplet m) + => m b v PulpPath +findOrInstallPulp mbP = do + let p = fromMaybe (PulpPath "pulp") mbP + installed <- shS (pulpInstalled p) + case installed of + True -> return p + False -> shS $ do + echo "Pulp not found, installing it for you..." + installPulp >> whichPulp + +-------------------------------------------------------------------------------- +whichPulp :: MonadIO m => m PulpPath +whichPulp = PulpPath . toS . T.strip <$> shS (run "which" ["pulp"]) + +-------------------------------------------------------------------------------- +installPulp :: MonadIO m => m () +installPulp = shS $ run_ "npm" ["install", "-g", "pulp"] + +-------------------------------------------------------------------------------- +pulpInstalled :: PulpPath -> Sh Bool +pulpInstalled (PulpPath pp) = errExit False $ silently $ do + check `catchany_sh` \(_ :: SomeException) -> return False + where + check = do + run_ (fromString pp) ["version"] + eC <- lastExitCode + return $ case eC of + 0 -> True + 1 -> True + _ -> 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. @@ -69,7 +152,7 @@ Just c -> return c Nothing -> do inDevelMode <- ("devel" ==) <$> getEnvironment - return $ if or [inDevelMode, devFlagEnabled] + return $ if inDevelMode || devFlagEnabled then CompileAlways else CompileOnce @@ -81,7 +164,7 @@ -------------------------------------------------------------------------------- getBowerFile :: (Monad (m b v), MonadIO (m b v), MonadSnaplet m) => m b v T.Text -getBowerFile = return . (`mappend` "/bower.json") =<< getDestDir +getBowerFile = (`mappend` "/bower.json") <$> getDestDir -------------------------------------------------------------------------------- getAbsoluteOutputDir :: Handler b PureScript T.Text