snaplet-fay 0.1.0.0 → 0.2.0.0

raw patch · 5 files changed

+171/−182 lines, 5 filesdep +aesondep ~data-defaultdep ~fayPVP ok

version bump matches the API change (PVP)

Dependencies added: aeson

Dependency ranges changed: data-default, fay

API changes (from Hackage documentation)

Files

• resources/devel.cfg +19/−3
• snaplet-fay.cabal +8/−30
• src/Snap/Snaplet/Fay.hs +103/−47
• src/Snap/Snaplet/Fay/Internal.hs +41/−43
• src/Test.hs +0/−59

@@ -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 = ""

@@ -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 <https://github.com/faylang/snaplet-fay>. 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.*,

@@ -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

@@ -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: " ++ )

@@ -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")