herringbone (empty) → 0.0.1

raw patch · 11 files changed

+610/−0 lines, 11 filesdep +HUnitdep +basedep +bytestringsetup-changed

Dependencies added: HUnit, base, bytestring, containers, directory, hspec, http-types, old-locale, system-fileio, system-filepath, text, time, unix-compat, wai, wai-app-static, warp

Files

• LICENSE +25/−0
• Network/Wai/Herringbone.hs +51/−0
• Network/Wai/Herringbone/BuildAsset.hs +71/−0
• Network/Wai/Herringbone/Configuration.hs +31/−0
• Network/Wai/Herringbone/FindAsset.hs +30/−0
• Network/Wai/Herringbone/LocateAssets.hs +89/−0
• Network/Wai/Herringbone/Types.hs +149/−0
• Network/Wai/Herringbone/WaiAdapter.hs +93/−0
• Setup.hs +2/−0
• herringbone.cabal +68/−0
• test/Spec.hs +1/−0

@@ -0,0 +1,25 @@++The MIT License (MIT)++Copyright (c) 2013 Harry Garrood++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.+++          

@@ -0,0 +1,51 @@+{- |+wai-herringbone is a Haskell/Wai library for compiling and serving web assets.+It aims to make it dead simple to create a 'Network.Wai.Middleware' or+'Network.Wai.Application' which deals with all of your static assets, including+preprocessing for languages like Fay, CoffeeScript, Sass, and LESS.++It takes most of its inspiration from the Ruby library,+<https://github.com/sstephenson/sprockets Sprockets>, hence the name.++Example:++> import Network.Wai.Herringbone+>+> fay, sass :: PP+>+> hb = Herringbone+> hb = herringbone+>     ( addSourceDir "assets"+>     . setDestDir   "compiled_assets"+>     . addPreprocessors [fay, sass]+>     )+>+> -- You can now access assets programmatically+> asset <- findAsset hb (makeLogicalPath ["application.js"])+>+> -- Or make a WAI Application to do it for you+> app = toApplication hb+-}+module Network.Wai.Herringbone (+    -- * Creating a Herringbone+    Herringbone(..),+    module Network.Wai.Herringbone.Configuration,+    -- * Assets+    LogicalPath,+    fromLogicalPath,+    toFilePath,+    Asset(..),+    findAsset,+    -- * Preprocessors+    PP(..),+    PPs,+    AssetError(..),+    CompileError,+    -- * WAI+    toApplication+) where++import Network.Wai.Herringbone.Configuration+import Network.Wai.Herringbone.Types+import Network.Wai.Herringbone.FindAsset+import Network.Wai.Herringbone.WaiAdapter

@@ -0,0 +1,71 @@+{-# LANGUAGE RankNTypes #-}+-- | This module contains functions to build assets (that is, run preprocessing+-- if necessary, and copy to destination directory).+module Network.Wai.Herringbone.BuildAsset where++import Data.Time+import Filesystem.Path.CurrentOS (FilePath, (</>))+import qualified Filesystem as F+import Prelude hiding (FilePath)++import Network.Wai.Herringbone.Types++-- | Build an asset to produce a 'Asset'. This action checks whether the+-- compilation is necessary based on the modified times of the source and+-- destination files.+buildAsset :: Herringbone+           -> LogicalPath -- ^ Logical path of asset to build+           -> FilePath    -- ^ Source file path+           -> [PP]        -- ^ List of preprocessors to run+           -> IO (Either CompileError Asset)+buildAsset hb logPath sourcePath pps = do+    let destPath = hbDestDir hb </> toFilePath logPath++    sourceModifiedTime <- F.getModified sourcePath+    compileNeeded <- shouldCompile sourceModifiedTime destPath++    result <- if compileNeeded+                then compileAsset sourcePath destPath pps+                else return $ Right ()++    either (return . Left)+           (\_ -> do size <- F.getSize destPath+                     return . Right $ Asset+                                        size+                                        sourcePath+                                        destPath+                                        logPath+                                        sourceModifiedTime)+           result++-- | Should we compile an asset? True if either the asset doesn't exist, or if+-- its modified time is older than the supplied source modification time.+shouldCompile :: UTCTime -> FilePath -> IO Bool+shouldCompile sourceModifiedTime destPath = do+    exists <- F.isFile destPath+    if not exists+        then return True+        else do+            destModifiedTime <- F.getModified destPath+            return $ sourceModifiedTime > destModifiedTime++-- | Compile the given asset by invoking any preprocessors on the source path,+-- and copying the result to the destination path.+compileAsset :: FilePath -- ^ Source path+             -> FilePath -- ^ Dest path+             -> [PP]     -- ^ List of preprocessors to apply+             -> IO (Either CompileError ())+compileAsset sourcePath destPath pps = do+    sourceData <- F.readFile sourcePath++    result <- chainEither (map ppAction pps) sourceData+    either (return . Left)+           (\resultData -> do F.writeFile destPath resultData+                              return (Right ()))+           result++chainEither :: Monad m => [a -> m (Either b a)] -> a -> m (Either b a)+chainEither fs m = foldl go z fs+    where+        go = \acc f -> acc >>= either (return . Left) f+        z  = return (Right m)

@@ -0,0 +1,31 @@+module Network.Wai.Herringbone.Configuration where++import Network.Wai.Herringbone.Types+import Filesystem.Path.CurrentOS (FilePath)+import Prelude hiding (FilePath)++-- | Preferred way of creating 'Herringbone' instances.+herringbone :: ConfigBuilder -> Herringbone+herringbone builder = builder defaultHerringbone++type ConfigBuilder = Herringbone -> Herringbone++-- | Adds a directory to the list of source directories.+addSourceDir :: FilePath -> ConfigBuilder+addSourceDir dir hb = hb { hbSourceDirs = dir : hbSourceDirs hb }++-- | Sets the destination directory. Note that this will overwrite the+-- destination directory if one is already set.+setDestDir :: FilePath -> ConfigBuilder+setDestDir dir hb = hb { hbDestDir = dir }++-- | Add the preprocessors in the list to the preprocessor collection.+addPreprocessors :: [PP] -> ConfigBuilder+addPreprocessors ppList hb = hb { hbPPs = insertAllPPs ppList (hbPPs hb) }++defaultHerringbone :: Herringbone+defaultHerringbone = Herringbone+    { hbSourceDirs = []+    , hbDestDir    = error "herringbone: destination dir must be specified"+    , hbPPs        = noPPs+    }

@@ -0,0 +1,30 @@+module Network.Wai.Herringbone.FindAsset where++import Network.Wai.Herringbone.LocateAssets+import Network.Wai.Herringbone.BuildAsset+import Network.Wai.Herringbone.Types+import Prelude hiding (FilePath)+import Filesystem.Path.CurrentOS (FilePath)++findAsset :: Herringbone+          -> LogicalPath+          -> IO (Either AssetError Asset)+findAsset hb path = do+    assets <- locateAssets hb path+    case assets of+        []               -> return . Left $ AssetNotFound+        [(srcPath, pps)] -> buildAsset' hb path srcPath pps+        xs               -> return . Left $ AmbiguousSources (map fst xs)++buildAsset' :: Herringbone+            -> LogicalPath+            -> FilePath+            -> [PP]+            -> IO (Either AssetError Asset)+buildAsset' hb path srcPath pps = do+    result <- buildAsset hb path srcPath pps+    return $ mapLeft AssetCompileError result+    where+    mapLeft :: (a -> b) -> Either a r -> Either b r+    mapLeft f (Left x)  = Left $ f x+    mapLeft _ (Right x) = Right x

@@ -0,0 +1,89 @@+-- | This module deals with locating assets on the disk, and calculating how to+-- create assets which need preprocessing.+module Network.Wai.Herringbone.LocateAssets where++import Data.Maybe+import Data.Text (Text)+import Filesystem.Path.CurrentOS (FilePath, (</>))+import qualified Filesystem.Path.CurrentOS as F+import qualified Filesystem as F+import Prelude hiding (FilePath)++import Network.Wai.Herringbone.Types++locateAssets :: Herringbone -> LogicalPath -> IO [(FilePath, [PP])]+locateAssets hb logPath = do+    let sourceDirs = hbSourceDirs hb+    let pps        = hbPPs hb+    let pathPieces = fromLogicalPath logPath+    assets <- sequence $ map (getAssetsFrom pps pathPieces) sourceDirs+    return $ concat assets++getAssetsFrom :: PPs+              -> [Text]      -- ^ requested path pieces+              -> FilePath    -- ^ Directory to look in+              -> IO [(FilePath, [PP])]+getAssetsFrom _   []          _    = return []+getAssetsFrom pps pathPieces' dir' = do+    let pathPieces        = map F.fromText pathPieces'+    let dir               = foldl (</>) dir' (init pathPieces)+    let assetName         = last pathPieces++    exists <- F.isDirectory dir+    if exists+        then do contents <- F.listDirectory dir+                let filenames = getAssetsFrom'+                                    pps+                                    assetName+                                    (map F.filename contents)+                return $ map (\(path, xs) -> (dir </> path, xs)) filenames+        else return []++-- Given a list of preprocessors, the path of an asset we want to serve, and+-- a list of potential source files, return a list of all the files which could+-- be used as a source for that file, together with the preprocessors which+-- would need to be applied (in the correct order) to preprocess that file.+--+-- For example, given preprocessors for "sass" and "erb", the asset path+-- "style.css", and the following list of potential files:+--+--  "style.css"+--  "style.css.sass"+--  "style.css.sass.erb"+--  "style.css.unrecognised-ext"+--  "javascript.js"+--+-- we should get back:+--+--  [ ("style.css", [])+--  , ("style.css.sass", [sass])+--  , ("style.css.sass.erb", [erb, sass])+--  ]+getAssetsFrom' :: PPs+               -> FilePath      -- ^ Asset to serve+               -> [FilePath]    -- ^ Potential source files+               -> [(FilePath, [PP])]+getAssetsFrom' pps assetPath = catMaybes . map resolve+    where+    resolve :: FilePath -> Maybe (FilePath, [PP])+    resolve fp = fmap (\xs -> (fp, xs)) $ (resolvePPs pps assetPath fp)++-- Can we apply a sequence of the given preprocessors to the given source file+-- path to get the given asset? If so, return the list of preprocessors which+-- should be applied to it to make this happen.+resolvePPs :: PPs -> FilePath -> FilePath -> Maybe [PP]+resolvePPs pps assetPath source = do+    exts   <- getExtraExtensions assetPath source+    ppList <- sequence $ map (\e -> lookupPP e pps) exts+    return ppList++-- Check if a file path is formed from another file path plus a list of+-- extensions, and if so, return those extensions, in reverse order.+-- Eg:+--  getExtraExtensions "game.js" "game.js.coffee"     == Just ["coffee"]+--  getExtraExtensions "style.css" "game.js.coffee"   == Nothing+--  getExtraExtensions "game.js" "game.js.coffee.erb" == Just ["erb", "coffee"]+getExtraExtensions :: FilePath -> FilePath -> Maybe [Text]+getExtraExtensions fp fpWithExts = do+    stripped <- F.stripPrefix fp fpWithExts+    return $ (reverse . F.extensions) stripped

@@ -0,0 +1,149 @@+module Network.Wai.Herringbone.Types where++import Data.Char+import Data.Time.Clock+import Data.Time.Format+import System.Locale+import Data.Text (Text)+import qualified Data.Map as M+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import qualified Filesystem.Path.CurrentOS as F+import Filesystem.Path.CurrentOS (FilePath)+import Prelude hiding (FilePath)++class ToLazyByteString a where+    toLazyByteString :: a -> BL.ByteString++instance ToLazyByteString String where+    toLazyByteString = BL.pack . map (fromIntegral . ord)++instance ToLazyByteString FilePath where+    toLazyByteString = toLazyByteString . F.encode++instance ToLazyByteString B.ByteString where+    toLazyByteString = BL.fromChunks . (: [])++data AssetError = AssetNotFound+                | AssetCompileError CompileError+                | AmbiguousSources [FilePath]+                deriving (Show, Eq)++-- | A string which should contain information about why an asset failed to+-- compile.+type CompileError = B.ByteString++-- | A preprocessor something which is run on the asset before it is served.+-- Preprocessors are run when a file extension matches the preprocessor+-- extension. For example, if you have a preprocessor for \"coffee\" files, you+-- request \"application.js\", and there is a file named+-- \"application.js.coffee\", Herringbone will run the coffee preprocessor on+-- that file and serve you the result.+--+-- You can add more preprocessors by adding more file extensions;+-- \"application.js.coffee.erb\" will be preprocessed first by \"erb\", then by+-- \"coffee\" (assuming you have registered preprocessors for those files).+data PP = PP+    { ppExtension :: Text+    -- ^ The file extension this preprocessor acts upon, eg \"sass\" or+    -- \"hamlet\"+    , ppAction    :: B.ByteString -> IO (Either CompileError B.ByteString)+    -- ^ Perform the preprocessing.+    }++instance Show PP where+    show pp = "<PP: " ++ show (ppExtension pp) ++ ">"++-- | Beware: This instance is only here for testing. It only looks at the+-- extensions to decide whether two 'PP's are equal. Don't use this!+instance Eq PP where+    (PP ext1 _) == (PP ext2 _) = ext1 == ext2++instance Ord PP where+    compare (PP ext1 _) (PP ext2 _) = compare ext1 ext2++-- | A collection of preprocessors.+newtype PPs = PPs { unPPs :: M.Map Text PP }+    deriving (Show)++noPPs :: PPs+noPPs = PPs M.empty++supportedBy :: PPs -> Text -> Bool+supportedBy pps = flip M.member (unPPs pps)++supportedExts :: PPs -> [Text]+supportedExts = M.keys . unPPs++insertPP :: PP -> PPs -> PPs+insertPP pp = PPs . M.insert (ppExtension pp) pp . unPPs++lookupPP :: Text -> PPs -> Maybe PP+lookupPP ext = M.lookup ext . unPPs++fromList :: [PP] -> PPs+fromList ppList = insertAllPPs ppList noPPs++insertAllPPs :: [PP] -> PPs -> PPs+insertAllPPs ppList pps = foldr insertPP pps ppList++-- | The \'main\' datatype in this library. Just a container for the+-- configuration. All of the important functions will take a 'Herringbone' as+-- their first argument.+data Herringbone = Herringbone+    { hbSourceDirs :: [FilePath]+    -- ^ A list of source directories; this is where assets should be placed.+    , hbDestDir    :: FilePath+    -- ^ Where to copy assets to after they've been compiled.+    , hbPPs        :: PPs+    -- ^ Preprocessors+    }+    deriving (Show)++-- | All assets in Herringbone are referenced by their logical path. This is+-- the path to an asset, relative to any of the source directories.+newtype LogicalPath = LogicalPath { fromLogicalPath :: [Text] }+    deriving (Show)++-- | Create a LogicalPath from a list of Text values. This returns Nothing if+-- the path would be unsafe (that is, if it contains \"..\"), to prevent+-- directory traversal attacks.+makeLogicalPath :: [Text] -> Maybe LogicalPath+makeLogicalPath xs = if safe xs then Just $ LogicalPath xs else Nothing+    where+        safe = all (not . (==) "..")++-- | Create a LogicalPath without checking any of the values.+unsafeMakeLogicalPath :: [Text] -> LogicalPath+unsafeMakeLogicalPath = LogicalPath++toFilePath :: LogicalPath -> FilePath+toFilePath = F.concat . map F.fromText . fromLogicalPath++-- | A preprocessed asset. Any function that returns this will already have+-- done the preprocessing (if necessary).+data Asset = Asset+    { assetSize         :: Integer+    -- ^ Size of the asset in bytes.+    , assetSourcePath   :: FilePath+    -- ^ Path to the asset's source file on disk.+    , assetFilePath     :: FilePath+    -- ^ Path to the preprocessed asset on disk. Note that assets which do not+    -- require preprocessing will still be copied to the destination directory.+    , assetLogicalPath  :: LogicalPath+    -- ^ The logical path referencing this asset.+    , assetModifiedTime :: UTCTime+    -- ^ Modification time of the asset's source file.+    }++instance Show Asset where+    show (Asset size sourcePath filePath logicalPath modifiedTime) =+        "BundledAsset { " +++        "assetSize = " ++ show size ++ ", " +++        "assetSourcePath = " ++ show sourcePath ++ ", " +++        "assetFilePath = " ++ show filePath ++ ", " +++        "assetLogicalPath = " ++ show logicalPath ++ ", " +++        "assetModifiedTime = " ++ showTime modifiedTime ++ " }"++        where+        showTime = formatTime defaultTimeLocale (dateTimeFmt defaultTimeLocale)

@@ -0,0 +1,93 @@+module Network.Wai.Herringbone.WaiAdapter where++import Control.Monad+import qualified Data.ByteString.Lazy as BL+import Data.Time+import Data.Time.Clock.POSIX+import System.Posix.Types (EpochTime)+import Data.Monoid+import Data.List+import Data.Maybe+import Network.Wai+import Network.Wai.Application.Static+import WaiAppStatic.Types+import Network.HTTP.Types+import Prelude hiding (FilePath)+import Filesystem.Path.CurrentOS (FilePath)+import qualified Filesystem.Path.CurrentOS as F+import qualified Filesystem as F++import Network.Wai.Herringbone.FindAsset+import Network.Wai.Herringbone.Types++-- | Convert a 'Herringbone' to a WAI 'Application'.+toApplication :: Herringbone -> Application+toApplication hb@(Herringbone { hbDestDir = dest }) =+    staticApp $ (defaultWebAppSettings dest) { ssLookupFile = lookupFile hb }++lookupFile :: Herringbone -> Pieces -> IO LookupResult+lookupFile hb pieces = do+    asset <- findAsset hb (toLogicalPath pieces)+    either assetErrorToLR bundledAssetToLR asset++    where+    assetErrorToLR = return . go++    go AssetNotFound           = LRNotFound+    go (AssetCompileError err) = LRFile . assetCompileError $ err+    go (AmbiguousSources xs)   = LRFile . ambiguousSources $ xs++    bundledAssetToLR asset = do+        file <- toFile (assetSourcePath asset)+                       (assetFilePath asset)+                       (last pieces)+        return . LRFile $ file++toLogicalPath :: Pieces -> LogicalPath+toLogicalPath = LogicalPath . map fromPiece++-- This is just given to wai-app-static which takes care of serving it.+toFile :: FilePath -- ^ source path+       -> FilePath -- ^ dest path+       -> Piece    -- ^ file name+       -> IO File+toFile source dest name = do+    size  <- F.getSize dest+    mtime <- F.getModified source+    let strDest = F.encodeString dest+    return File+        { fileGetSize     = fromIntegral size+        , fileToResponse  = \s h -> responseFile s h strDest Nothing+        , fileName        = name+        , fileGetHash     = return Nothing -- TODO+        , fileGetModified = Just . toEpochTime $ mtime+        }++toEpochTime :: UTCTime -> EpochTime+toEpochTime = fromIntegral . toSecs+    where+    toSecs :: UTCTime -> Int+    toSecs = floor . utcTimeToPOSIXSeconds++assetCompileError :: CompileError -> File+assetCompileError err =+    fileError (toLazyByteString err) (unsafeToPiece "compile-error.html")++ambiguousSources :: [FilePath] -> File+ambiguousSources sources =+    let body = "<h1>Ambiguous asset source</h1>" <>+                "<p>List of possible asset sources:</p>" <>+                "<ul>" <>+                BL.concat (map (\s -> "<li>" <> toLazyByteString s <> "</li>") sources) <>+                "</ul>"+    in fileError body (unsafeToPiece "error-ambiguous-source.html")++fileError :: BL.ByteString -> Piece -> File+fileError body name =+    File+        { fileGetSize     = fromIntegral $ BL.length body+        , fileToResponse  = \_ headers -> responseLBS status500 headers body+        , fileName        = name+        , fileGetHash     = return Nothing+        , fileGetModified = Nothing+        }

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,68 @@+name:                herringbone+version:             0.0.1+synopsis:            A library for compiling and serving static web assets.+description:         A library for compiling and serving static web assets. For more information, please see <https://github.com/hdgarrood/herringbone>.+license:             MIT+license-file:        LICENSE+author:              Harry Garrood+maintainer:          harry@garrood.me+category:            Web+build-type:          Simple+cabal-version:       >=1.10++source-repository head+  type:     git+  location: https://github.com/hdgarrood/herringbone++test-suite herringbone-tests+  type:                 exitcode-stdio-1.0+  main-is:              Spec.hs+  hs-source-dirs:       test .+  ghc-options:          -Wall+  build-depends:        base >=4.6 && <4.7,+                        wai  >= 2.0 && <3,+                        wai-app-static,+                        text,+                        bytestring,+                        containers,+                        system-filepath,+                        system-fileio,+                        directory,+                        unix-compat,+                        http-types,+                        time,+                        old-locale,+                        hspec,+                        HUnit,+                        warp+  default-extensions:   OverloadedStrings,+                        TypeSynonymInstances,+                        FlexibleInstances+  default-language:     Haskell2010++library+  ghc-options:          -Wall+  exposed-modules:      Network.Wai.Herringbone+  other-modules:        Network.Wai.Herringbone.Types+                        Network.Wai.Herringbone.Configuration+                        Network.Wai.Herringbone.LocateAssets+                        Network.Wai.Herringbone.BuildAsset+                        Network.Wai.Herringbone.FindAsset+                        Network.Wai.Herringbone.WaiAdapter+  build-depends:        base >=4.6 && <4.7,+                        wai  >= 2.0 && <3,+                        wai-app-static,+                        text,+                        bytestring,+                        containers,+                        system-filepath,+                        system-fileio,+                        directory,+                        unix-compat,+                        http-types,+                        time,+                        old-locale+  default-extensions:   OverloadedStrings,+                        TypeSynonymInstances,+                        FlexibleInstances+  default-language:     Haskell2010

@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}