diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. + + + diff --git a/Network/Wai/Herringbone.hs b/Network/Wai/Herringbone.hs new file mode 100644 --- /dev/null +++ b/Network/Wai/Herringbone.hs @@ -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, +, 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 diff --git a/Network/Wai/Herringbone/BuildAsset.hs b/Network/Wai/Herringbone/BuildAsset.hs new file mode 100644 --- /dev/null +++ b/Network/Wai/Herringbone/BuildAsset.hs @@ -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) diff --git a/Network/Wai/Herringbone/Configuration.hs b/Network/Wai/Herringbone/Configuration.hs new file mode 100644 --- /dev/null +++ b/Network/Wai/Herringbone/Configuration.hs @@ -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 + } diff --git a/Network/Wai/Herringbone/FindAsset.hs b/Network/Wai/Herringbone/FindAsset.hs new file mode 100644 --- /dev/null +++ b/Network/Wai/Herringbone/FindAsset.hs @@ -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 diff --git a/Network/Wai/Herringbone/LocateAssets.hs b/Network/Wai/Herringbone/LocateAssets.hs new file mode 100644 --- /dev/null +++ b/Network/Wai/Herringbone/LocateAssets.hs @@ -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 diff --git a/Network/Wai/Herringbone/Types.hs b/Network/Wai/Herringbone/Types.hs new file mode 100644 --- /dev/null +++ b/Network/Wai/Herringbone/Types.hs @@ -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 = "" + +-- | 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) diff --git a/Network/Wai/Herringbone/WaiAdapter.hs b/Network/Wai/Herringbone/WaiAdapter.hs new file mode 100644 --- /dev/null +++ b/Network/Wai/Herringbone/WaiAdapter.hs @@ -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 = "

Ambiguous asset source

" <> + "

List of possible asset sources:

" <> + "" + 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 + } diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/herringbone.cabal b/herringbone.cabal new file mode 100644 --- /dev/null +++ b/herringbone.cabal @@ -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 . +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 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}