packages feed

snaplet-fay (empty) → 0.1.0.0

raw patch · 7 files changed

+402/−0 lines, 7 filesdep +basedep +bytestringdep +configuratorsetup-changed

Dependencies added: base, bytestring, configurator, data-default, directory, fay, filepath, mtl, snap, snap-core, transformers

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2012, Adam Bergmark++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Adam Bergmark nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ resources/devel.cfg view
@@ -0,0 +1,4 @@+# "CompileAll" or "CompileOnDemand".+compileMethod = "CompileOnDemand"+# Print more or less information.+verbose = on
+ snaplet-fay.cabal view
@@ -0,0 +1,75 @@+name:                snaplet-fay+-- The package version.  See the Haskell package versioning policy (PVP)+-- for standards guiding when and how versions should be incremented.+-- http://www.haskell.org/haskellwiki/Package_versioning_policy+-- 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+license:             BSD3+license-file:        LICENSE+author:              Adam Bergmark+maintainer:          adam@edea.se+homepage:            https://github.com/faylang/snaplet-fay+category:            Web, Snap+build-type:          Simple+cabal-version:       >=1.8++extra-source-files:  LICENSE++data-files:+  resources/devel.cfg++source-repository head+  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++  exposed-modules:+    Snap.Snaplet.Fay++  other-modules:+    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:+    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.*
+ src/Snap/Snaplet/Fay.hs view
@@ -0,0 +1,105 @@+{-# LANGUAGE OverloadedStrings       #-}+{-# LANGUAGE ScopedTypeVariables     #-}+{-# OPTIONS -fno-warn-name-shadowing #-}++module Snap.Snaplet.Fay (+         CompileMethod (..)+       , Fay+       , initFay+       , fayServe+       ) where+++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           Data.List+import           Data.Maybe+import           Data.String+import           Snap.Core+import           Snap.Snaplet+import           Snap.Util.FileServe+import           System.Directory+import           System.FilePath++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+  config <- getSnapletUserConfig+  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+                        Nothing -> return Nothing+    verbose          <- logErr "Must specify verbose" $ C.lookup config "verbose"++    return (verbose, compileMethod)++  let fay = case opts of+              (Just verbose, Just compileMethod) ->+                Fay (toSrcDir fp) (toDestDir fp) [toSrcDir fp] verbose compileMethod+              _ -> 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)++  return fay++  where+    datadir = Just $ liftM (++ "/resources") getDataDir++    description = "Automatic (re)compilation and serving of Fay files"++    logErr :: MonadIO m => t -> IO (Maybe a) -> WriterT [t] m (Maybe a)+    logErr err m = do+        res <- liftIO m+        when (isNothing res) (tell [err])+        return res++    toSrcDir :: FilePath -> FilePath+    toSrcDir = (</> "src")+    toDestDir :: FilePath -> FilePath+    toDestDir = (</> "js")++-- | Serves the compiled Fay scripts++fayServe :: Handler b Fay ()+fayServe = do+  cfg <- get+  compileWithMethod (compileMethod cfg)++compileWithMethod :: CompileMethod -> Handler b Fay ()+compileWithMethod CompileOnDemand = do+  cfg <- get+  req <- getRequest+  let uri = srcDir cfg </> (toHsName . filename . BS.unpack . rqURI) req+  res <- liftIO (compileFile cfg uri)+  case res of+    Just s -> writeLBS $ fromString s+    Nothing -> return ()++compileWithMethod CompileAll = do+  cfg <- get+  liftIO (compileAll cfg)+  serveDirectory (destDir cfg)
+ src/Snap/Snaplet/Fay/Internal.hs view
@@ -0,0 +1,127 @@+{-# LANGUAGE ViewPatterns       #-}++module Snap.Snaplet.Fay.Internal where++import           Control.Applicative+import           Control.Monad+import           Data.Default+import qualified Language.Fay.Compiler 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]+  , verbose :: Bool+  , compileMethod :: CompileMethod+  }++data CompileMethod = CompileOnDemand | CompileAll++-- | Compile a single file, print errors if they occur and return the+-- | compiled source if successful.+compileFile :: Fay -> FilePath -> IO (Maybe String)+compileFile config f = do+  exists <- doesFileExist f+  if not exists+    then do+      putStrLn $ "snaplet-fay: Could not find: " ++ hsRelativePath f+      return Nothing+    else do+      res <- F.compileFile (def { F.configDirectoryIncludes = includeDirs config }) True f+      case res of+        Right out -> do+          verbosePut config $ "Compiled " ++ hsRelativePath f+          return $ Just 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++-- | 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)++  -- Compile.+  forM_ files $ \f -> do+     res <- compileFile config f+     case res of+       Just s -> writeFile (jsPath config f) s+       Nothing -> return ()++  -- Remove js files that don't have a corresponding source hs file.+  oldFiles <- extFiles "js" (destDir config) >>= filterM (liftM not . doesFileExist . hsPath config)+  forM_ oldFiles $ \f -> do+    removeFile f+    verbosePut config $ "Removed orphaned " ++ jsRelativePath f++  where+    -- Convert back and forth between the filepaths of hs and js files.+++-- | Helpers++-- | Checks if a string ends with another string.+hasSuffix :: String -> String -> Bool+hasSuffix s suffix = reverse suffix == take (length suffix) (reverse s)++-- | Extract the filename from a filepath.+filename :: FilePath -> FilePath+filename = reverse . takeWhile (/= '/') . reverse++-- | Convert a JS filename to a Haskell filename.+toHsName :: String -> String+toHsName x = case reverse x of+               ('s':'j':'.': (reverse -> file)) -> file ++ ".hs"+               _ -> x++-- | Gets the filepath of the files with the given file extension in a folder.+extFiles :: String -> FilePath -> IO [FilePath]+extFiles ext dir = map (dir </>) . filter (`hasSuffix` ('.' : ext)) <$> getDirectoryContents dir++-- | Convert from the location of a js file to the location of its source hs file.+jsPath :: Fay -> FilePath -> FilePath+jsPath config f = destDir config </> filename (F.toJsName f)++-- | Convert from the location of a hs file to the location of the destination js file.+hsPath :: Fay -> FilePath -> FilePath+hsPath config f = srcDir config </> filename (toHsName f)++-- | Get the relative path of a js file.+jsRelativePath :: FilePath -> FilePath+jsRelativePath f = "snaplets/fay/js" </> filename f++-- | Get the relative path of a hs file.+hsRelativePath :: FilePath -> FilePath+hsRelativePath f = "snaplets/fay/src" </> filename f++-- | Helper for printing messages when the verbose flag is set+verbosePut :: Fay -> String -> IO ()+verbosePut config = when (verbose config) . putStrLn . ("snaplet-fay: " ++ )
+ src/Test.hs view
@@ -0,0 +1,59 @@+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")