diff --git a/Network/Wai/Herringbone.hs b/Network/Wai/Herringbone.hs deleted file mode 100644 --- a/Network/Wai/Herringbone.hs +++ /dev/null @@ -1,51 +0,0 @@ -{- | -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 deleted file mode 100644 --- a/Network/Wai/Herringbone/BuildAsset.hs +++ /dev/null @@ -1,71 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/Network/Wai/Herringbone/Configuration.hs +++ /dev/null @@ -1,31 +0,0 @@ -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 deleted file mode 100644 --- a/Network/Wai/Herringbone/FindAsset.hs +++ /dev/null @@ -1,30 +0,0 @@ -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 deleted file mode 100644 --- a/Network/Wai/Herringbone/LocateAssets.hs +++ /dev/null @@ -1,89 +0,0 @@ --- | 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 deleted file mode 100644 --- a/Network/Wai/Herringbone/Types.hs +++ /dev/null @@ -1,149 +0,0 @@ -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 deleted file mode 100644 --- a/Network/Wai/Herringbone/WaiAdapter.hs +++ /dev/null @@ -1,93 +0,0 @@ -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/Web/Herringbone.hs b/Web/Herringbone.hs new file mode 100644 --- /dev/null +++ b/Web/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 Web.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 Web.Herringbone ( + -- * Creating a Herringbone + Herringbone(..), + module Web.Herringbone.Configuration, + -- * Assets + LogicalPath, + fromLogicalPath, + toFilePath, + Asset(..), + findAsset, + -- * Preprocessors + PP(..), + PPs, + AssetError(..), + CompileError, + -- * WAI + toApplication +) where + +import Web.Herringbone.Configuration +import Web.Herringbone.Types +import Web.Herringbone.FindAsset +import Web.Herringbone.Adapter.Wai diff --git a/Web/Herringbone/Adapter/Wai.hs b/Web/Herringbone/Adapter/Wai.hs new file mode 100644 --- /dev/null +++ b/Web/Herringbone/Adapter/Wai.hs @@ -0,0 +1,93 @@ +module Web.Herringbone.Adapter.Wai 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 Web.Herringbone.FindAsset +import Web.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:

" <> + "
    " <> + BL.concat (map (\s -> "
  • " <> toLazyByteString s <> "
    • ") 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/Web/Herringbone/BuildAsset.hs b/Web/Herringbone/BuildAsset.hs new file mode 100644 --- /dev/null +++ b/Web/Herringbone/BuildAsset.hs @@ -0,0 +1,70 @@ +-- | This module contains functions to build assets (that is, run preprocessing +-- if necessary, and copy to destination directory). +module Web.Herringbone.BuildAsset where + +import Data.Time +import Filesystem.Path.CurrentOS (FilePath, ()) +import qualified Filesystem as F +import Prelude hiding (FilePath) + +import Web.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/Web/Herringbone/Configuration.hs b/Web/Herringbone/Configuration.hs new file mode 100644 --- /dev/null +++ b/Web/Herringbone/Configuration.hs @@ -0,0 +1,31 @@ +module Web.Herringbone.Configuration where + +import Web.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/Web/Herringbone/FindAsset.hs b/Web/Herringbone/FindAsset.hs new file mode 100644 --- /dev/null +++ b/Web/Herringbone/FindAsset.hs @@ -0,0 +1,31 @@ +module Web.Herringbone.FindAsset where + +import Prelude hiding (FilePath) +import Filesystem.Path.CurrentOS (FilePath) + +import Web.Herringbone.LocateAssets +import Web.Herringbone.BuildAsset +import Web.Herringbone.Types + +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/Web/Herringbone/LocateAssets.hs b/Web/Herringbone/LocateAssets.hs new file mode 100644 --- /dev/null +++ b/Web/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 Web.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 Web.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/Web/Herringbone/Types.hs b/Web/Herringbone/Types.hs new file mode 100644 --- /dev/null +++ b/Web/Herringbone/Types.hs @@ -0,0 +1,149 @@ +module Web.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/herringbone.cabal b/herringbone.cabal --- a/herringbone.cabal +++ b/herringbone.cabal @@ -1,5 +1,5 @@ name: herringbone -version: 0.0.1 +version: 0.0.2 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 @@ -37,18 +37,19 @@ warp default-extensions: OverloadedStrings, TypeSynonymInstances, - FlexibleInstances + FlexibleInstances, + RankNTypes 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 + exposed-modules: Web.Herringbone + other-modules: Web.Herringbone.Types + Web.Herringbone.Configuration + Web.Herringbone.LocateAssets + Web.Herringbone.BuildAsset + Web.Herringbone.FindAsset + Web.Herringbone.Adapter.Wai build-depends: base >=4.6 && <4.7, wai >= 2.0 && <3, wai-app-static, @@ -64,5 +65,6 @@ old-locale default-extensions: OverloadedStrings, TypeSynonymInstances, - FlexibleInstances + FlexibleInstances, + RankNTypes default-language: Haskell2010