snaplet-purescript 0.4.0.0 → 0.4.1.0
raw patch · 3 files changed
+165/−87 lines, 3 filesdep +string-convdep ~basedep ~mtldep ~shelly
Dependencies added: string-conv
Dependency ranges changed: base, mtl, shelly
Files
- snaplet-purescript.cabal +11/−11
- src/Snap/Snaplet/PureScript.hs +58/−63
- src/Snap/Snaplet/PureScript/Internal.hs +96/−13
snaplet-purescript.cabal view
@@ -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
src/Snap/Snaplet/PureScript.hs view
@@ -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!"-|]
src/Snap/Snaplet/PureScript/Internal.hs view
@@ -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