{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE OverloadedStrings #-} module Snap.Snaplet.PureScript ( initPurs , pursServe , 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.State.Strict import Paths_snaplet_purescript import Shelly hiding (get) import Text.Printf import Data.Monoid import Data.Configurator import qualified Data.Text.Encoding as TE import qualified Data.Text as T import Snap.Snaplet.PureScript.Internal as Internals (PureScript) import Snap.Snaplet.PureScript.Internal import Text.RawString.QQ -------------------------------------------------------------------------------- -- | Snaplet initialization initPurs :: SnapletInit b PureScript initPurs = makeSnaplet "purs" description (Just dataDir) $ do config <- getSnapletUserConfig env <- getEnvironment 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") 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 purs <- shelly $ verbosely $ do 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"] echo $ "Checking existance of " <> toTextIgnore envCfg let purs = PureScript { pursCompilationMode = cm , pursVerbosity = verbosity , pursBundle = bndl , pursBundleName = bundleName , pursPwdDir = destDir , pursOutputDir = outDir , pursModules = modules } unless envCfgExists $ do touchfile envCfg writefile envCfg (envCfgTemplate purs) return purs -- compile at least once, regardless of the CompilationMode. -- NOTE: We might want to 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) CompilationSucceeded -> return () return purs where description = "Automatic (re)compilation of PureScript projects" dataDir = liftM (++ "/resources") getDataDir -------------------------------------------------------------------------------- pursLog :: String -> Handler b PureScript () pursLog l = do verb <- get >>= return . pursVerbosity 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 case requestedJs of "" -> fail (jsNotFound requestedJs) _ -> 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 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 -------------------------------------------------------------------------------- bundle :: MonadIO m => PureScript -> m CompilationOutput bundle PureScript{..} = liftIO $ shelly $ verbosely $ errExit False $ chdir (fromText pursPwdDir) $ do let bundlePath = pursOutputDir <> "/" <> pursBundleName case pursBundle of False -> return CompilationSucceeded True -> do 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"]) eC <- lastExitCode case (eC == 0) of True -> return CompilationSucceeded False -> return $ CompilationFailed res -------------------------------------------------------------------------------- compileWithMode :: Handler b PureScript CompilationOutput compileWithMode = do mode <- gets pursCompilationMode case mode of CompileOnce -> return CompilationSucceeded CompileAlways -> do workDir <- gets pursPwdDir pursLog $ "Compiling Purescript project at " <> T.unpack workDir get >>= build -------------------------------------------------------------------------------- bundleWithMode :: T.Text -> Handler b PureScript CompilationOutput bundleWithMode artifactName = 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 -------------------------------------------------------------------------------- jsNotFound :: T.Text -> String jsNotFound js = printf [r| You asked me to serve: %s But I wasn't able to find a suitable PureScript module to build. If this is the first time you are running snaplet-purescript, have a look inside snaplets/purs/devel.cfg. |] (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 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!" |]