diff --git a/resources/devel.cfg b/resources/devel.cfg --- a/resources/devel.cfg +++ b/resources/devel.cfg @@ -1,4 +1,20 @@ -# "CompileAll" or "CompileOnDemand". -compileMethod = "CompileOnDemand" -# Print more or less information. +# "Development": Compile files on every request. +# +# "Production": Compile all files i snaplets/src/fay when the application is started and then serve them statically. +# +# Both methods will write files to disk for debugging purposes. +# Default is "Development". +compileMode = "Development" +# Print more or less information about what the snaplet is doing. +# Default is on. verbose = on +# Run js-beautify on the results if it is available in the PATH. +# If it isn't available the compiled file will be used as is. +# Default is on. +prettyPrint = on +# A comma-separated list of directories to look for fay imports in. +# This is useful if you want to share modules between Fay and Snap. +# Paths are relative to the root of the snap application. +# snaplets/src/fay will always be checked for imports. +# Default is "" meaning no additional directories will be checked. +includeDirs = "" diff --git a/snaplet-fay.cabal b/snaplet-fay.cabal --- a/snaplet-fay.cabal +++ b/snaplet-fay.cabal @@ -5,14 +5,16 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 0.1.0.0 -synopsis: Fay integration for Snap with automatic (re)compilation during development -description: For more information, please see https://github.com/faylang/snaplet-fay +version: 0.2.0.0 +synopsis: Fay integration for Snap with request- and pre-compilation. +description: Fay integration for Snap with request based compilation during development and precompilation in production. + For more information, please see . license: BSD3 license-file: LICENSE author: Adam Bergmark maintainer: adam@edea.se homepage: https://github.com/faylang/snaplet-fay +bug-reports: https://github.com/faylang/snaplet-fay/issues category: Web, Snap build-type: Simple cabal-version: >=1.8 @@ -26,10 +28,6 @@ type: git location: https://github.com/faylang/snaplet-fay.git -Flag test - Description: Whether to build the test executable - Default: False - library ghc-options: -Wall hs-source-dirs: src @@ -41,33 +39,13 @@ Snap.Snaplet.Fay.Internal, Paths_snaplet_fay build-depends: - base == 4.5.*, - bytestring == 0.9.*, - configurator == 0.2.*, - data-default == 0.5.*, - directory == 1.1.*, - fay == 0.6.*, - filepath == 1.3.*, - mtl == 2.1.*, - snap == 0.9.*, - snap-core == 0.9.*, - transformers == 0.3.* - -Executable test - if !flag(test) - buildable: False - - ghc-options: -Wall - hs-source-dirs: src - main-is: Test.hs - - build-depends: + aeson == 0.6.*, base == 4.5.*, bytestring == 0.9.*, configurator == 0.2.*, - data-default == 0.5.*, + data-default >= 0.4, directory == 1.1.*, - fay == 0.6.*, + fay >= 0.9.1, filepath == 1.3.*, mtl == 2.1.*, snap == 0.9.*, diff --git a/src/Snap/Snaplet/Fay.hs b/src/Snap/Snaplet/Fay.hs --- a/src/Snap/Snaplet/Fay.hs +++ b/src/Snap/Snaplet/Fay.hs @@ -1,24 +1,31 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS -fno-warn-name-shadowing #-} module Snap.Snaplet.Fay ( - CompileMethod (..) - , Fay + Fay , initFay , fayServe + , fayax + , toFayax + , fromFayax ) where - +import Control.Applicative import Control.Monad import Control.Monad.Reader import Control.Monad.State.Class import Control.Monad.Trans.Writer -import qualified Data.ByteString.Char8 as BS -import qualified Data.Configurator as C +import qualified Data.Aeson as A +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as BS +import qualified Data.ByteString.Lazy as BL +import qualified Data.Configurator as C +import Data.Data import Data.List import Data.Maybe import Data.String +import Language.Fay.Convert import Snap.Core import Snap.Snaplet import Snap.Util.FileServe @@ -28,11 +35,6 @@ import Paths_snaplet_fay import Snap.Snaplet.Fay.Internal -methodFromString :: String -> Maybe CompileMethod -methodFromString "CompileOnDemand" = Just CompileOnDemand -methodFromString "CompileAll" = Just CompileAll -methodFromString _ = Nothing - -- | Snaplet initialization initFay :: SnapletInit b Fay initFay = makeSnaplet "fay" description datadir $ do @@ -40,33 +42,39 @@ fp <- getSnapletFilePath (opts, errs) <- runWriterT $ do - compileMethodStr <- logErr "Must specify compileMethod" $ C.lookup config "compileMethod" - compileMethod <- case compileMethodStr of - Just x -> logErr "Invalid compileMethod" . return $ methodFromString x + compileModeStr <- logErr "Must specify compileMode" $ C.lookup config "compileMode" + compileMode <- case compileModeStr of + Just x -> logErr "Invalid compileMode" . return $ compileModeFromString x Nothing -> return Nothing verbose <- logErr "Must specify verbose" $ C.lookup config "verbose" - - return (verbose, compileMethod) + prettyPrint <- logErr "Must specify prettyPrint" $ C.lookup config "prettyPrint" + includeDirs <- logErr "Must specify includeDirs" $ C.lookup config "includeDirs" + let inc = maybe [] (split ',') includeDirs + inc' <- liftIO $ mapM canonicalizePath inc + return (verbose, compileMode, prettyPrint, inc') let fay = case opts of - (Just verbose, Just compileMethod) -> - Fay (toSrcDir fp) (toDestDir fp) [toSrcDir fp] verbose compileMethod + (Just verbose, Just compileMode, Just prettyPrint, includeDirs) -> + Fay fp verbose compileMode prettyPrint (fp : includeDirs) _ -> error $ intercalate "\n" errs - liftIO $ do - -- Create the snaplet directory - dirExists <- doesDirectoryExist fp - unless dirExists $ createDirectory fp - -- Create the src directory - dirExists <- doesDirectoryExist $ toSrcDir fp - unless dirExists . createDirectory $ toSrcDir fp - -- Create the js directory - dirExists <- doesDirectoryExist (toDestDir fp) - unless dirExists $ createDirectory (toDestDir fp) + -- Make sure snaplet/fay, snaplet/fay/src, snaplet/fay/js are present. + liftIO $ mapM_ createDirUnlessExists [fp, srcDir fay, destDir fay] + when (Production == compileMode fay) (liftIO $ compileAll fay) + return fay where + -- TODO Use split package + split :: Eq a => a -> [a] -> [[a]] + split _ [] = [] + split a as = takeWhile (/= a) as : split a (drop 1 $ dropWhile (/= a) as) + + createDirUnlessExists fp = do + dirExists <- doesDirectoryExist fp + unless dirExists $ createDirectory fp + datadir = Just $ liftM (++ "/resources") getDataDir description = "Automatic (re)compilation and serving of Fay files" @@ -77,29 +85,77 @@ when (isNothing res) (tell [err]) return res - toSrcDir :: FilePath -> FilePath - toSrcDir = ( "src") - toDestDir :: FilePath -> FilePath - toDestDir = ( "js") - --- | Serves the compiled Fay scripts + compileModeFromString :: String -> Maybe CompileMode + compileModeFromString "Development" = Just Development + compileModeFromString "Production" = Just Production + compileModeFromString _ = Nothing +-- | Serves the compiled Fay scripts using the chosen compile mode. fayServe :: Handler b Fay () fayServe = do - cfg <- get - compileWithMethod (compileMethod cfg) + modifyResponse . setContentType $ "text/javascript;charset=utf-8" + get >>= compileWithMode . compileMode -compileWithMethod :: CompileMethod -> Handler b Fay () -compileWithMethod CompileOnDemand = do +-- | Send and receive JSON. +-- | Automatically decodes a JSON request into a Fay record which is +-- | passed to `g`. The handler `g` should then return a Fay record (of +-- | a possibly separate type) which is encoded and passed back as a +-- | JSON response. +-- | If you only want to send JSON and handle input manually, use toFayax. +-- | If you want to receive JSON and handle the response manually, use fromFayax +fayax :: (Data f1, Read f1, Show f2) => (f1 -> Handler h1 h2 f2) -> Handler h1 h2 () +fayax g = do + res <- decode + case res of + Left body -> send500 $ Just body + Right res -> toFayax . g $ res + +-- | fayax only sending JSON. +toFayax :: Show f2 => Handler h1 h2 f2 -> Handler h1 h2 () +toFayax g = do + modifyResponse . setContentType $ "text/json;charset=utf-8" + writeLBS . A.encode . showToFay =<< g + +-- | fayax only recieving JSON. +fromFayax :: (Data f1, Read f1) => (f1 -> Handler h1 h2 ()) -> Handler h1 h2 () +fromFayax g = do + res <- decode + case res of + Left body -> send500 $ Just body + Right res -> g res + +-- | Read the request input and convert to a Fay value. +decode :: (Data f1, Read f1) => Handler h1 h2 (Either ByteString f1) +decode = do + body <- readRequestBody 1024 -- Nothing will break by abusing this :)! + res <- return $ A.decode body >>= readFromFay + return $ case res of + Nothing -> Left. BS.concat . BL.toChunks $ "Could not decode " `BL.append` body + Just x -> Right x + +-- | Compiles according to the specified mode. +compileWithMode :: CompileMode -> Handler b Fay () +compileWithMode Development = do cfg <- get - req <- getRequest - let uri = srcDir cfg (toHsName . filename . BS.unpack . rqURI) req + uri <- (srcDir cfg ) . toHsName . filename . BS.unpack . rqURI <$> getRequest res <- liftIO (compileFile cfg uri) case res of - Just s -> writeLBS $ fromString s - Nothing -> return () + Success s -> writeBS $ fromString s + NotFound -> send404 Nothing + Error err -> send500 . Just . BS.pack $ err +-- Production compilation has already been done. +compileWithMode Production = get >>= serveDirectory . destDir -compileWithMethod CompileAll = do - cfg <- get - liftIO (compileAll cfg) - serveDirectory (destDir cfg) +-- | Respond with Not Found +send404 :: Maybe ByteString -> Handler a b () +send404 msg = do + modifyResponse $ setResponseStatus 404 "Not Found" + writeBS $ fromMaybe "Not Found" msg + finishWith =<< getResponse + +-- | Respond with Internal Server Error +send500 :: Maybe ByteString -> Handler a b () +send500 msg = do + modifyResponse $ setResponseStatus 500 "Internal Server Error" + writeBS $ fromMaybe "Internal Server Error" msg + finishWith =<< getResponse diff --git a/src/Snap/Snaplet/Fay/Internal.hs b/src/Snap/Snaplet/Fay/Internal.hs --- a/src/Snap/Snaplet/Fay/Internal.hs +++ b/src/Snap/Snaplet/Fay/Internal.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE ViewPatterns #-} module Snap.Snaplet.Fay.Internal where @@ -6,75 +6,73 @@ import Control.Monad import Data.Default import qualified Language.Fay.Compiler as F -import qualified Language.Fay.Types as F +import qualified Language.Fay.Types as F import System.Directory import System.FilePath -- | Configuration - data Fay = Fay { - srcDir :: FilePath - , destDir :: FilePath - , includeDirs :: [FilePath] + snapletFilePath :: FilePath , verbose :: Bool - , compileMethod :: CompileMethod + , compileMode :: CompileMode + , prettyPrint :: Bool + , _includeDirs :: [FilePath] } -data CompileMethod = CompileOnDemand | CompileAll +-- | Location of .hs files +srcDir :: Fay -> FilePath +srcDir = ( "src") . snapletFilePath +-- | Location of .js files +destDir :: Fay -> FilePath +destDir = ( "js") . snapletFilePath + +-- | Where to check for imports +includeDirs :: Fay -> [FilePath] +includeDirs config = srcDir config : _includeDirs config + +-- | Compile on every request or when Snap starts. +data CompileMode = Development | Production + deriving Eq + +-- | Used by callers of compileFile to get the status of compilation. +data CompileResult = Success String | NotFound | Error String + -- | Compile a single file, print errors if they occur and return the -- | compiled source if successful. -compileFile :: Fay -> FilePath -> IO (Maybe String) +compileFile :: Fay -> FilePath -> IO CompileResult compileFile config f = do exists <- doesFileExist f if not exists then do putStrLn $ "snaplet-fay: Could not find: " ++ hsRelativePath f - return Nothing + return NotFound else do - res <- F.compileFile (def { F.configDirectoryIncludes = includeDirs config }) True f + res <- F.compileFile def { F.configDirectoryIncludes = includeDirs config + , F.configPrettyPrint = prettyPrint config + , F.configAutorun = True } f case res of Right out -> do verbosePut config $ "Compiled " ++ hsRelativePath f - return $ Just out + writeFile (jsPath config f) out + return $ Success out Left err -> do - putStrLn $ "snaplet-fay: Error compiling " ++ hsRelativePath f ++ ":" - print err - return Nothing - --- | Check if a file should be recompiled, either when the hs file was --- | updated or the file hasn't been compiled at all. -shouldCompile :: Fay -> FilePath -> IO Bool -shouldCompile config hsFile = do - jsExists <- doesFileExist (jsPath config hsFile) - if not jsExists - then return True - else do - hsmod <- getModificationTime hsFile - jsmod <- getModificationTime (jsPath config hsFile) - return $ hsmod > jsmod + let errString = "snaplet-fay: Error compiling " ++ hsRelativePath f ++ ":\n" ++ show err + putStrLn errString + return $ Error errString -- | Checks the specified source folder and compiles all new and modified scripts. -- Also removes any js files whose Fay source has been deleted. -- All files are checked each request. --- --- NOTE: --- --- Currently import dependencies are not handled, if a dependency has --- changed the dependet will not be recompiled compileAll :: Fay -> IO () compileAll config = do - -- Fetch all hs files that don't have a corresponding js - -- file or has been updated since the js file was last compiled. - files <- filterM (shouldCompile config) =<< extFiles "hs" (srcDir config) + -- Find files, only checks the root snaplet directory + -- TODO check subdirs. + files <- extFiles "hs" (srcDir config) -- Compile. - forM_ files $ \f -> do - res <- compileFile config f - case res of - Just s -> writeFile (jsPath config f) s - Nothing -> return () + forM_ files $ compileFile config -- Remove js files that don't have a corresponding source hs file. oldFiles <- extFiles "js" (destDir config) >>= filterM (liftM not . doesFileExist . hsPath config) @@ -114,14 +112,14 @@ hsPath :: Fay -> FilePath -> FilePath hsPath config f = srcDir config filename (toHsName f) --- | Get the relative path of a js file. +-- | Relative path to a js file. jsRelativePath :: FilePath -> FilePath jsRelativePath f = "snaplets/fay/js" filename f --- | Get the relative path of a hs file. +-- | Relative path to a hs file. hsRelativePath :: FilePath -> FilePath hsRelativePath f = "snaplets/fay/src" filename f --- | Helper for printing messages when the verbose flag is set +-- | Print log messages when the verbose flag is set verbosePut :: Fay -> String -> IO () verbosePut config = when (verbose config) . putStrLn . ("snaplet-fay: " ++ ) diff --git a/src/Test.hs b/src/Test.hs deleted file mode 100644 --- a/src/Test.hs +++ /dev/null @@ -1,59 +0,0 @@ -module Main where - --- | The tests pass if the program produces no output - -import Control.Applicative -import Control.Monad -import System.Directory -import System.FilePath - -import Snap.Snaplet.Fay -import Snap.Snaplet.Fay.Internal - - -config :: Fay -config = Fay { - srcDir = "test-files" - , destDir = "test-dest" - , includeDirs = ["test-files"] - , verbose = False - , compileMethod = CompileAll - } - - -assertM :: String -> IO Bool -> IO () -assertM s f = f >>= \b -> unless b (putStrLn s) - - -assert :: String -> Bool -> IO () -assert _ True = return () -assert s False = putStrLn s - - -touch :: FilePath -> IO () -touch fp = writeFile fp "main = return ()" - - -rmf :: FilePath -> IO () -rmf fp = doesFileExist fp >>= (`when` removeFile fp) - - -main :: IO () -main = do - mapM_ removeFile =<< (extFiles "js" . destDir) config - compileAll config - len <- length <$> extFiles "js" (destDir config) - assert "0" (len > 0) - - rmf (srcDir config "NewFile.hs") - rmf (destDir config "NewFile.js") - - assertM "1" $ not <$> doesFileExist (destDir config "NewFile.js") - touch $ srcDir config "NewFile.hs" - - compileAll config - assertM "2" $ doesFileExist (destDir config "NewFile.js") - removeFile $ srcDir config "NewFile.hs" - - compileAll config - assertM "3" $ not <$> doesFileExist (destDir config "NewFile.js")