diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,69 @@ +# ChangeLog for yesod-static + +## 1.6.1.3 + +* Support `yesod-core` 1.7 + +## 1.6.1.2 + +* Allow JavaScript MIME type used by `mime-types >= 0.1.2.1` in test suite [#1898](https://github.com/yesodweb/yesod/pull/1898) + +## 1.6.1.1 + +* Use crypton instead of cryptonite [#1838](https://github.com/yesodweb/yesod/pull/1838) +* Set `base >= 4.11` for less CPP and imports [#1876](https://github.com/yesodweb/yesod/pull/1876) + + +## 1.6.1.0 + +* Support reproducible embedded file order [#1684](https://github.com/yesodweb/yesod/issues/1684#issuecomment-652562514) + +## 1.6.0.2 + +* Remove unnecessary deriving of Typeable + +## 1.6.0.1 + +* Make test suite build with GHC 8.6 [#1561](https://github.com/yesodweb/yesod/pull/1561) + +## 1.6.0 + +* Upgrade to yesod-core 1.6.0 + +## 1.5.3.1 + +* Switch to cryptonite + +## 1.5.3 + +* Add `staticFilesMap` function +* Add `staticFilesMergeMap` function + +## 1.5.2 + +* Fix test case for CRLF line endings +* Fix warnings + +## 1.5.1.1 + +* Fix test suite compilation + +## 1.5.1 + +* yesod-static doesn't obey Authentication [#1286](https://github.com/yesodweb/yesod/issues/1286) + +## 1.5.0.5 + +* Avoid lazy I/O in mkEmbeddedStatic (fixes [#149](https://github.com/yesodweb/yesod/issues/149)) + +## 1.5.0.4 + +* Doc tweaks + +## 1.5.0 + +* Drop system-filepath + +## 1.4.0.3 + +Fix bug when `StaticRoute` constructor is not imported. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,3 @@ +## yesod-static + +Static file serving subsite for Yesod Web Framework. diff --git a/Yesod/EmbeddedStatic.hs b/Yesod/EmbeddedStatic.hs new file mode 100644 --- /dev/null +++ b/Yesod/EmbeddedStatic.hs @@ -0,0 +1,178 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- | A subsite which serves static content which is embedded at compile time. +-- +-- At compile time, you supply a list of files, directories, processing functions (like javascript +-- minification), and even custom content generators. You can also specify the specific relative +-- locations within the static subsite where these resources should appear. The 'mkEmbeddedStatic' +-- function then computes the resources and embeds them directly into the executable at +-- compile time, so that the original files do not need to be distributed along with +-- the executable. The content is also compressed and hashed at compile time, so that +-- during runtime the compressed content can be sent directly on the wire with the appropriate +-- HTTP header. The precomputed hash is used for an ETag so the client does not redownload +-- the content multiple times. There is also a development mode which does not embed the +-- contents but recomputes it on every request. A simple example using an embedded static +-- subsite is +-- . +-- +-- To add this to a scaffolded project, replace the code in @Settings/StaticFiles.hs@ +-- with a call to 'mkEmbeddedStatic' with the list of all your generators, use the type +-- 'EmbeddedStatic' in your site datatype for @getStatic@, update the route for @/static@ to +-- use the type 'EmbeddedStatic', use 'embedStaticContent' for 'addStaticContent' in +-- @Foundation.hs@, use the routes generated by 'mkEmbeddedStatic' and exported by +-- @Settings/StaticFiles.hs@ to link to your static content, and finally update +-- @Application.hs@ use the variable binding created by 'mkEmbeddedStatic' which +-- contains the created 'EmbeddedStatic'. +-- +-- It is recommended that you serve static resources from a separate domain to save time +-- on transmitting cookies. You can use 'urlParamRenderOverride' to do so, by redirecting +-- routes to this subsite to a different domain (but the same path) and then pointing the +-- alternative domain to this server. In addition, you might consider using a reverse +-- proxy like varnish or squid to cache the static content, but the embedded content in +-- this subsite is cached and served directly from memory so is already quite fast. +module Yesod.EmbeddedStatic ( + -- * Subsite + EmbeddedStatic + , embeddedResourceR + , mkEmbeddedStatic + , embedStaticContent + + -- * Generators + , module Yesod.EmbeddedStatic.Generators +) where + +import Data.IORef +import Data.Maybe (catMaybes) +import Language.Haskell.TH +import Network.HTTP.Types.Status (status404) +import Network.Wai (responseLBS, pathInfo) +import Network.Wai.Application.Static (staticApp) +import System.IO.Unsafe (unsafePerformIO) +import Yesod.Core (YesodSubDispatch(..)) +import Yesod.Core.Types + ( YesodSubRunnerEnv(..) + , YesodRunnerEnv(..) + ) +import qualified Data.ByteString.Lazy as BL +import qualified Data.Text as T +import qualified Data.HashMap.Strict as M +import qualified WaiAppStatic.Storage.Embedded as Static + +import Yesod.EmbeddedStatic.Types +import Yesod.EmbeddedStatic.Internal +import Yesod.EmbeddedStatic.Generators + +-- Haddock doesn't support associated types in instances yet so we can't +-- export EmbeddedResourceR directly. + +-- | Construct a route to an embedded resource. +embeddedResourceR :: [T.Text] -> [(T.Text, T.Text)] -> Route EmbeddedStatic +embeddedResourceR = EmbeddedResourceR + +instance YesodSubDispatch EmbeddedStatic master where + yesodSubDispatch YesodSubRunnerEnv {..} req = resp + where + master = yreSite ysreParentEnv + site = ysreGetSub master + resp = case pathInfo req of + ("res":_) -> stApp site req + ("widget":_) -> staticApp (widgetSettings site) req + _ -> ($ responseLBS status404 [] "Not Found") + +-- | Create the haskell variable for the link to the entry +mkRoute :: ComputedEntry -> Q [Dec] +mkRoute (ComputedEntry { cHaskellName = Nothing }) = return [] +mkRoute (c@ComputedEntry { cHaskellName = Just name }) = do + routeType <- [t| Route EmbeddedStatic |] + link <- [| $(cLink c) |] + return [ SigD name routeType + , ValD (VarP name) (NormalB link) [] + ] + +-- | Creates an 'EmbeddedStatic' by running, at compile time, a list of generators. +-- Each generator produces a list of entries to embed into the executable. +-- +-- This template haskell splice creates a variable binding holding the resulting +-- 'EmbeddedStatic' and in addition creates variable bindings for all the routes +-- produced by the generators. For example, if a directory called static has +-- the following contents: +-- +-- * js/jquery.js +-- +-- * css/bootstrap.css +-- +-- * img/logo.png +-- +-- then a call to +-- +-- > #ifdef DEVELOPMENT +-- > #define DEV_BOOL True +-- > #else +-- > #define DEV_BOOL False +-- > #endif +-- > mkEmbeddedStatic DEV_BOOL "myStatic" [embedDir "static"] +-- +-- will produce variables +-- +-- > myStatic :: EmbeddedStatic +-- > js_jquery_js :: Route EmbeddedStatic +-- > css_bootstrap_css :: Route EmbeddedStatic +-- > img_logo_png :: Route EmbeddedStatic +mkEmbeddedStatic :: Bool -- ^ development? + -> String -- ^ variable name for the created 'EmbeddedStatic' + -> [Generator] -- ^ the generators (see "Yesod.EmbeddedStatic.Generators") + -> Q [Dec] +mkEmbeddedStatic dev esName gen = do + entries <- concat <$> sequence gen + computed <- runIO $ mapM (if dev then devEmbed else prodEmbed) entries + + let settings = Static.mkSettings $ return $ map cStEntry computed + devExtra = listE $ catMaybes $ map ebDevelExtraFiles entries + ioRef = [| unsafePerformIO $ newIORef M.empty |] + + -- build the embedded static + esType <- [t| EmbeddedStatic |] + esCreate <- if dev + then [| EmbeddedStatic (develApp $settings $devExtra) $ioRef |] + else [| EmbeddedStatic (staticApp $! $settings) $ioRef |] + let es = [ SigD (mkName esName) esType + , ValD (VarP $ mkName esName) (NormalB esCreate) [] + ] + + routes <- mapM mkRoute computed + + return $ es ++ concat routes + +-- | Use this for 'addStaticContent' to have the widget static content be served by +-- the embedded static subsite. For example, +-- +-- > import Yesod +-- > import Yesod.EmbeddedStatic +-- > import Text.Jasmine (minifym) +-- > +-- > data MySite = { ..., getStatic :: EmbeddedStatic, ... } +-- > +-- > mkYesod "MySite" [parseRoutes| +-- > ... +-- > /static StaticR EmbeddedStatic getStatic +-- > ... +-- > |] +-- > +-- > instance Yesod MySite where +-- > ... +-- > addStaticContent = embedStaticContent getStatic StaticR mini +-- > where mini = if development then Right else minifym +-- > ... +embedStaticContent :: (site -> EmbeddedStatic) -- ^ How to retrieve the embedded static subsite from your site + -> (Route EmbeddedStatic -> Route site) -- ^ how to convert an embedded static route + -> (BL.ByteString -> Either a BL.ByteString) -- ^ javascript minifier + -> AddStaticContent site +embedStaticContent = staticContentHelper diff --git a/Yesod/EmbeddedStatic/Css/AbsoluteUrl.hs b/Yesod/EmbeddedStatic/Css/AbsoluteUrl.hs new file mode 100644 --- /dev/null +++ b/Yesod/EmbeddedStatic/Css/AbsoluteUrl.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Manipulate CSS urls. +-- +-- * Make relative urls absolute (useful when combining assets) +module Yesod.EmbeddedStatic.Css.AbsoluteUrl ( + -- * Absolute urls + absoluteUrls + , absoluteUrlsAt + , absoluteUrlsWith + , absCssUrlsFileProd + , absCssUrlsProd +) where + +import Yesod.EmbeddedStatic.Generators +import Yesod.EmbeddedStatic.Types + +import qualified Data.ByteString.Lazy as BL +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import qualified Data.Text.IO as T +import qualified Data.Text.Lazy.Encoding as TL +import Control.Monad ((>=>)) +import Data.Maybe (fromMaybe) +import System.FilePath (()) + +import Yesod.EmbeddedStatic.Css.Util + +------------------------------------------------------------------------------- +-- Generator +------------------------------------------------------------------------------- + +-- | Anchors relative CSS image urls +absCssUrlsFileProd :: FilePath -- ^ Anchor relative urls to here + -> FilePath + -> IO BL.ByteString +absCssUrlsFileProd dir file = do + contents <- T.readFile file + return $ TL.encodeUtf8 $ absCssUrlsProd dir contents + +absCssUrlsProd :: FilePath -- ^ Anchor relative urls to here + -> T.Text + -> TL.Text +absCssUrlsProd dir contents = + let css = either error id $ parseCssUrls contents + in renderCssWith toAbsoluteUrl css + where + toAbsoluteUrl (UrlReference rel) = T.concat + [ "url('/" + , (T.pack $ dir T.unpack rel) + , "')" + ] + + +-- | Equivalent to passing the same string twice to 'absoluteUrlsAt'. +absoluteUrls :: FilePath -> Generator +absoluteUrls f = absoluteUrlsAt f f + +-- | Equivalent to passing @return@ to 'absoluteUrlsWith'. +absoluteUrlsAt :: Location -> FilePath -> Generator +absoluteUrlsAt loc f = absoluteUrlsWith loc f Nothing + +-- | Automatically make relative urls absolute +-- +-- During development, leave CSS as is. +-- +-- When CSS is organized into a directory structure, it will work properly for individual requests for each file. +-- During production, we want to combine and minify CSS as much as possible. +-- The combination process combines files from different directories, messing up relative urls. +-- This pre-processor makes relative urls absolute +absoluteUrlsWith :: + Location -- ^ The location the CSS file should appear in the static subsite + -> FilePath -- ^ Path to the CSS file. + -> Maybe (CssGeneration -> IO BL.ByteString) -- ^ Another filter function run after this one (for example @return . yuiCSS . cssContent@) or other CSS filter that runs after this filter. + -> Generator +absoluteUrlsWith loc file mpostFilter = + return [ cssProductionFilter (absCssUrlsFileProd loc >=> postFilter . mkCssGeneration loc file) loc file + ] + where + postFilter = fromMaybe (return . cssContent) mpostFilter diff --git a/Yesod/EmbeddedStatic/Css/Util.hs b/Yesod/EmbeddedStatic/Css/Util.hs new file mode 100644 --- /dev/null +++ b/Yesod/EmbeddedStatic/Css/Util.hs @@ -0,0 +1,198 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} + +module Yesod.EmbeddedStatic.Css.Util where + +import Control.Applicative ((<|>)) +import Control.Monad (void, foldM) +import Data.Hashable (Hashable) +import Network.Mime (MimeType, defaultMimeLookup) +import Text.CSS.Parse (parseBlocks) +import Language.Haskell.TH (litE, stringL) +import Text.CSS.Render (renderBlocks) +import Yesod.EmbeddedStatic.Types +import Yesod.EmbeddedStatic (pathToName) +import Data.Default (def) +import System.FilePath ((), takeFileName, takeDirectory, dropExtension) + +import qualified Blaze.ByteString.Builder as B +import qualified Blaze.ByteString.Builder.Char.Utf8 as B +import qualified Data.Attoparsec.Text as P +import qualified Data.Attoparsec.ByteString.Lazy as PBL +import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Base64 as B64 +import qualified Data.HashMap.Lazy as M +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Text.IO as T +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Builder as TL + +------------------------------------------------------------------------------- +-- Loading CSS +------------------------------------------------------------------------------- + +-- | In the parsed CSS, this will be an image reference that we want to replace. +-- the contents will be the filepath. +newtype UrlReference = UrlReference T.Text + deriving (Show, Eq, Hashable, Ord) + +type EithUrl = (T.Text, Either T.Text UrlReference) + +-- | The parsed CSS +type Css = [(T.Text, [EithUrl])] + +-- | Parse the filename out of url('filename') +parseUrl :: P.Parser T.Text +parseUrl = do + P.skipSpace + void $ P.string "url('" + P.takeTill (== '\'') + +checkForUrl :: T.Text -> T.Text -> EithUrl +checkForUrl n@("background-image") v = parseBackgroundImage n v +checkForUrl n@("src") v = parseBackgroundImage n v +checkForUrl n v = (n, Left v) + +-- | Check if a given CSS attribute is a background image referencing a local file +checkForImage :: T.Text -> T.Text -> EithUrl +checkForImage n@("background-image") v = parseBackgroundImage n v +checkForImage n v = (n, Left v) + +parseBackgroundImage :: T.Text -> T.Text -> EithUrl +parseBackgroundImage n v = (n, case P.parseOnly parseUrl v of + Left _ -> Left v -- Can't parse url + Right url -> -- maybe we should find a uri parser + if any (`T.isPrefixOf` url) ["http://", "https://", "/"] + then Left v + else Right $ UrlReference url) + +parseCssWith :: (T.Text -> T.Text -> EithUrl) -> T.Text -> Either String Css +parseCssWith urlParser contents = + case parseBlocks contents of + Left err -> Left err + Right blocks -> Right [ (t, map (uncurry urlParser) b) | (t,b) <- blocks ] + +parseCssUrls :: T.Text -> Either String Css +parseCssUrls = parseCssWith checkForUrl + +parseCssFileWith :: (T.Text -> T.Text -> EithUrl) -> FilePath -> IO Css +parseCssFileWith urlParser fp = do + mparsed <- parseCssWith urlParser <$> T.readFile fp + case mparsed of + Left err -> fail $ "Unable to parse " ++ fp ++ ": " ++ err + Right css -> return css + +parseCssFileUrls :: FilePath -> IO Css +parseCssFileUrls = parseCssFileWith checkForUrl + +renderCssWith :: (UrlReference -> T.Text) -> Css -> TL.Text +renderCssWith urlRenderer css = + TL.toLazyText $ renderBlocks [(n, map render block) | (n,block) <- css] + where + render (n, Left b) = (n, b) + render (n, Right f) = (n, urlRenderer f) + +-- | Load an image map from the images in the CSS +loadImages :: FilePath -> Css -> (FilePath -> IO (Maybe a)) -> IO (M.HashMap UrlReference a) +loadImages dir css loadImage = foldM load M.empty $ concat [map snd block | (_,block) <- css] + where + load imap (Left _) = return imap + load imap (Right f) | f `M.member` imap = return imap + load imap (Right f@(UrlReference path)) = do + img <- loadImage (dir T.unpack path) + return $ maybe imap (\i -> M.insert f i imap) img + + +-- | If you tack on additional CSS post-processing filters, they use this as an argument. +data CssGeneration = CssGeneration { + cssContent :: BL.ByteString + , cssStaticLocation :: Location + , cssFileLocation :: FilePath + } + +mkCssGeneration :: Location -> FilePath -> BL.ByteString -> CssGeneration +mkCssGeneration loc file content = + CssGeneration { cssContent = content + , cssStaticLocation = loc + , cssFileLocation = file + } + +cssProductionFilter :: + (FilePath -> IO BL.ByteString) -- ^ a filter to be run on production + -> Location -- ^ The location the CSS file should appear in the static subsite + -> FilePath -- ^ Path to the CSS file. + -> Entry +cssProductionFilter prodFilter loc file = + def { ebHaskellName = Just $ pathToName loc + , ebLocation = loc + , ebMimeType = "text/css" + , ebProductionContent = prodFilter file + , ebDevelReload = [| develPassThrough $(litE (stringL loc)) $(litE (stringL file)) |] + , ebDevelExtraFiles = Nothing + } + +cssProductionImageFilter :: (FilePath -> IO BL.ByteString) -> Location -> FilePath -> Entry +cssProductionImageFilter prodFilter loc file = + (cssProductionFilter prodFilter loc file) + { ebDevelReload = [| develBgImgB64 $(litE (stringL loc)) $(litE (stringL file)) |] + , ebDevelExtraFiles = Just [| develExtraFiles $(litE (stringL loc)) |] + } + +------------------------------------------------------------------------------- +-- Helpers for the generators +------------------------------------------------------------------------------- + +-- For development, all we need to do is update the background-image url to base64 encode it. +-- We want to preserve the formatting (whitespace+newlines) during development so we do not parse +-- using css-parse. Instead we write a simple custom parser. + +parseBackground :: Location -> FilePath -> PBL.Parser B.Builder +parseBackground loc file = do + void $ PBL.string "background-image" + s1 <- PBL.takeWhile (\x -> x == 32 || x == 9) -- space or tab + void $ PBL.word8 58 -- colon + s2 <- PBL.takeWhile (\x -> x == 32 || x == 9) -- space or tab + void $ PBL.string "url('" + url <- PBL.takeWhile (/= 39) -- single quote + void $ PBL.string "')" + + let b64 = B64.encode $ T.encodeUtf8 (T.pack $ takeDirectory file) <> url + newUrl = B.fromString (takeFileName loc) <> B.fromString "/" <> B.fromByteString b64 + + return $ B.fromByteString "background-image" + <> B.fromByteString s1 + <> B.fromByteString ":" + <> B.fromByteString s2 + <> B.fromByteString "url('" + <> newUrl + <> B.fromByteString "')" + +parseDev :: Location -> FilePath -> B.Builder -> PBL.Parser B.Builder +parseDev loc file b = do + b' <- parseBackground loc file <|> (B.fromWord8 <$> PBL.anyWord8) + (PBL.endOfInput *> (pure $! b <> b')) <|> (parseDev loc file $! b <> b') + +develPassThrough :: Location -> FilePath -> IO BL.ByteString +develPassThrough _ = BL.readFile + +-- | Create the CSS during development +develBgImgB64 :: Location -> FilePath -> IO BL.ByteString +develBgImgB64 loc file = do + ct <- BL.readFile file + case PBL.eitherResult $ PBL.parse (parseDev loc file mempty) ct of + Left err -> error err + Right b -> return $ B.toLazyByteString b + +-- | Serve the extra image files during development +develExtraFiles :: Location -> [T.Text] -> IO (Maybe (MimeType, BL.ByteString)) +develExtraFiles loc parts = + case reverse parts of + (file:dir) | T.pack loc == T.intercalate "/" (reverse dir) -> do + let file' = T.decodeUtf8 $ B64.decodeLenient $ T.encodeUtf8 $ T.pack $ dropExtension $ T.unpack file + ct <- BL.readFile $ T.unpack file' + return $ Just (defaultMimeLookup file', ct) + _ -> return Nothing diff --git a/Yesod/EmbeddedStatic/Generators.hs b/Yesod/EmbeddedStatic/Generators.hs new file mode 100644 --- /dev/null +++ b/Yesod/EmbeddedStatic/Generators.hs @@ -0,0 +1,330 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | A generator is executed at compile time to load a list of entries +-- to embed into the subsite. This module contains several basic generators, +-- but the design of generators and entries is such that it is straightforward +-- to make custom generators for your own specific purposes, see <#g:4 this section>. +module Yesod.EmbeddedStatic.Generators ( + -- * Generators + Location + , embedFile + , embedFileAt + , embedDir + , embedDirAt + , concatFiles + , concatFilesWith + + -- * Compression options for 'concatFilesWith' + , jasmine + , uglifyJs + , yuiJavascript + , yuiCSS + , closureJs + , compressTool + , tryCompressTools + + -- * Util + , pathToName + + -- * Custom Generators + + -- $example +) where + +import Control.Exception (try, SomeException) +import Control.Monad (forM, when) +import Data.Char (isLower) +import Data.Default (def) +import Data.Maybe (isNothing) +import Language.Haskell.TH +import Network.Mime (defaultMimeLookup) +import System.Directory (doesDirectoryExist, getDirectoryContents, findExecutable) +import System.FilePath (()) +import Text.Jasmine (minifym) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BL +import Conduit +import qualified Data.Text as T +import qualified System.Process as Proc +import System.Exit (ExitCode (ExitSuccess)) +import Control.Concurrent.Async (Concurrently (..)) +import System.IO (hClose) +import Data.List (sort) + +import Yesod.EmbeddedStatic.Types + +-- | Embed a single file. Equivalent to passing the same string twice to 'embedFileAt'. +embedFile :: FilePath -> Generator +embedFile f = embedFileAt f f + +-- | Embed a single file at a given location within the static subsite and generate a +-- route variable based on the location via 'pathToName'. The @FilePath@ must be a relative +-- path to the directory in which you run @cabal build@. During development, the file located +-- at this filepath will be reloaded on every request. When compiling for production, the contents +-- of the file will be embedded into the executable and so the file does not need to be +-- distributed along with the executable. +embedFileAt :: Location -> FilePath -> Generator +embedFileAt loc f = do + let mime = defaultMimeLookup $ T.pack f + let entry = def { + ebHaskellName = Just $ pathToName loc + , ebLocation = loc + , ebMimeType = mime + , ebProductionContent = fmap BL.fromStrict (BS.readFile f) + , ebDevelReload = [| fmap BL.fromStrict + (BS.readFile $(litE $ stringL f)) |] + } + return [entry] + +-- | List all files recursively in a directory +getRecursiveContents :: Location -- ^ The directory to search + -> FilePath -- ^ The prefix to add to the filenames + -> IO [(Location,FilePath)] +getRecursiveContents prefix topdir = do + names <- sort <$> getDirectoryContents topdir + let properNames = filter (`notElem` [".", ".."]) names + paths <- forM properNames $ \name -> do + let path = topdir name + let loc = if null prefix then name else prefix ++ "/" ++ name + isDirectory <- doesDirectoryExist path + if isDirectory + then getRecursiveContents loc path + else return [(loc, path)] + return (concat paths) + +-- | Embed all files in a directory into the static subsite. +-- +-- Equivalent to passing the empty string as the location to 'embedDirAt', +-- so the directory path itself is not part of the resource locations (and so +-- also not part of the generated route variable names). +embedDir :: FilePath -> Generator +embedDir = embedDirAt "" + +-- | Embed all files in a directory to a given location within the static subsite. +-- +-- The directory tree rooted at the 'FilePath' (which must be relative to the directory in +-- which you run @cabal build@) is embedded into the static subsite at the given +-- location. Also, route variables will be created based on the final location +-- of each file. For example, if a directory \"static\" contains the files +-- +-- * css/bootstrap.css +-- +-- * js/jquery.js +-- +-- * js/bootstrap.js +-- +-- then @embedDirAt \"somefolder\" \"static\"@ will +-- +-- * Make the file @static\/css\/bootstrap.css@ available at the location +-- @somefolder\/css\/bootstrap.css@ within the static subsite and similarly +-- for the other two files. +-- +-- * Create variables @somefolder_css_bootstrap_css@, @somefolder_js_jquery_js@, +-- @somefolder_js_bootstrap_js@ all of type @Route EmbeddedStatic@. +-- +-- * During development, the files will be reloaded on every request. During +-- production, the contents of all files will be embedded into the executable. +-- +-- * During development, files that are added to the directory while the server +-- is running will not be detected. You need to recompile the module which +-- contains the call to @mkEmbeddedStatic@. This will also generate new route +-- variables for the new files. +embedDirAt :: Location -> FilePath -> Generator +embedDirAt loc dir = do + files <- runIO $ getRecursiveContents loc dir + concat <$> mapM (uncurry embedFileAt) files + +-- | Concatinate a list of files and embed it at the location. Equivalent to passing @return@ to +-- 'concatFilesWith'. +concatFiles :: Location -> [FilePath] -> Generator +concatFiles loc files = concatFilesWith loc return files + +-- | Concatinate a list of files into a single 'BL.ByteString', run the resulting content through the given +-- function, embed it at the given location, and create a haskell variable name for the route based on +-- the location. +-- +-- The processing function is only run when compiling for production, and the processing function is +-- executed at compile time. During development, on every request the files listed are reloaded, +-- concatenated, and served as a single resource at the given location without being processed. +concatFilesWith :: Location -> (BL.ByteString -> IO BL.ByteString) -> [FilePath] -> Generator +concatFilesWith loc process files = do + let load = do putStrLn $ "Creating " ++ loc + BL.concat <$> mapM BL.readFile files >>= process + expFiles = listE $ map (litE . stringL) files + expCt = [| BL.concat <$> mapM BL.readFile $expFiles |] + mime = defaultMimeLookup $ T.pack loc + return [def { ebHaskellName = Just $ pathToName loc + , ebLocation = loc + , ebMimeType = mime + , ebProductionContent = load + , ebDevelReload = expCt + }] + +-- | Convienient rexport of 'minifym' with a type signature to work with 'concatFilesWith'. +jasmine :: BL.ByteString -> IO BL.ByteString +jasmine ct = return $ either (const ct) id $ minifym ct + +-- | Use to compress javascript. +-- Assumes @uglifyjs@ is located in the path and uses options @[\"-m\", \"-c\"]@ +-- to both mangle and compress and the option \"-\" to cause uglifyjs to read from +-- standard input. +uglifyJs :: BL.ByteString -> IO BL.ByteString +uglifyJs = compressTool "uglifyjs" ["-", "-m", "-c"] + +-- | Use to compress javascript. +-- Assumes a script @yuicompressor@ is located in the path. If not, you can still +-- use something like +-- +-- > compressTool "java" ["-jar", "/path/to/yuicompressor.jar", "--type", "js"] +yuiJavascript :: BL.ByteString -> IO BL.ByteString +yuiJavascript = compressTool "yuicompressor" ["--type", "js"] + +-- | Use to compress CSS. +-- Assumes a script @yuicompressor@ is located in the path. +yuiCSS :: BL.ByteString -> IO BL.ByteString +yuiCSS = compressTool "yuicompressor" ["--type", "css"] + +-- | Use to compress +-- javascript using the default options. Assumes a script @closure@ is located in +-- the path. If not, you can still run using +-- +-- > compressTool "java" ["-jar", "/path/to/compiler.jar"] +closureJs :: BL.ByteString -> IO BL.ByteString +closureJs = compressTool "closure" [] + +-- | Helper to convert a process into a compression function. The process +-- should be set up to take input from standard input and write to standard output. +compressTool :: FilePath -- ^ program + -> [String] -- ^ options + -> BL.ByteString -> IO BL.ByteString +compressTool f opts ct = do + mpath <- findExecutable f + when (isNothing mpath) $ + fail $ "Unable to find " ++ f + let p = (Proc.proc f opts) + { Proc.std_in = Proc.CreatePipe + , Proc.std_out = Proc.CreatePipe + } + (Just hin, Just hout, _, ph) <- Proc.createProcess p + (compressed, (), code) <- runConcurrently $ (,,) + <$> Concurrently (runConduit $ sourceHandle hout .| sinkLazy) + <*> Concurrently (BL.hPut hin ct >> hClose hin) + <*> Concurrently (Proc.waitForProcess ph) + if code == ExitSuccess + then do + putStrLn $ "Compressed successfully with " ++ f + return compressed + else error $ "compressTool: compression failed with " ++ f + + +-- | Try a list of processing functions (like the compressions above) one by one until +-- one succeeds (does not raise an exception). Once a processing function succeeds, +-- none of the remaining functions are used. If none succeeds, the input is just +-- returned unprocessed. This is helpful if you are distributing +-- code on hackage and do not know what compressors the user will have installed. You +-- can list several and they will be tried in order until one succeeds. +tryCompressTools :: [BL.ByteString -> IO BL.ByteString] -> BL.ByteString -> IO BL.ByteString +tryCompressTools [] x = return x +tryCompressTools (p:ps) x = do + mres <- try $ p x + case mres of + Left (err :: SomeException) -> do + putStrLn $ show err + tryCompressTools ps x + Right res -> return res + +-- | Clean up a path to make it a valid haskell name by replacing all non-letters +-- and non-numbers by underscores. In addition, if the path starts with a capital +-- letter or number add an initial underscore. +pathToName :: FilePath -> Name +pathToName f = routeName + where + replace c + | 'A' <= c && c <= 'Z' = c + | 'a' <= c && c <= 'z' = c + | '0' <= c && c <= '9' = c + | otherwise = '_' + name = map replace f + routeName = mkName $ + case name of + [] -> error "null-named file" + n : _ + | isLower n -> name + | otherwise -> '_' : name + + +-- $example +-- Here is an example of creating your own custom generator. +-- Because of template haskell stage restrictions, you must define generators in a +-- different module from where you use them. The following generator will embed a +-- JSON document that contains the compile time. +-- +-- >{-# LANGUAGE TemplateHaskell, QuasiQuotes, OverloadedStrings #-} +-- >module CompileTime where +-- > +-- >import Data.Aeson +-- >import Data.Default +-- >import Data.Time +-- >import Yesod.EmbeddedStatic.Generators +-- >import Yesod.EmbeddedStatic.Types +-- >import qualified Data.ByteString.Lazy as BL +-- > +-- >getTime :: IO BL.ByteString +-- >getTime = do +-- > t <- getCurrentTime +-- > return $ encode $ +-- > object [ "compile_time" .= show t ] +-- > +-- >timeGenerator :: Location -> Generator +-- >timeGenerator loc = +-- > return $ [def +-- > { ebHaskellName = Just $ pathToName loc +-- > , ebLocation = loc +-- > , ebMimeType = "application/json" +-- > , ebProductionContent = getTime +-- > , ebDevelReload = [| getTime |] +-- > }] +-- +-- Notice how the @getTime@ action is given as both 'ebProductionContent' and +-- 'ebDevelReload'. The result is that during development, the @getTime@ action +-- will be re-executed on every request so the time returned will be different +-- for each reload. When compiling for production, the @getTime@ action will +-- be executed once at compile time to produce the content to embed and never +-- called at runtime. +-- +-- Here is a small example yesod program using this generator. Try toggling +-- the development argument to @mkEmbeddedStatic@. +-- +-- >{-# LANGUAGE TemplateHaskell, QuasiQuotes, TypeFamilies #-} +-- >module Main where +-- > +-- >import Yesod +-- >import Yesod.EmbeddedStatic +-- >import CompileTime (timeGenerator) +-- > +-- >mkEmbeddedStatic True "eStatic" [timeGenerator "compile-time.json"] +-- > +-- >-- The above will generate variables +-- >-- eStatic :: EmbeddedStatic +-- >-- compile_time_json :: Route EmbeddedStatic +-- > +-- >data MyApp = MyApp { getStatic :: EmbeddedStatic } +-- > +-- >mkYesod "MyApp" [parseRoutes| +-- >/ HomeR GET +-- >/static StaticR EmbeddedStatic getStatic +-- >|] +-- > +-- >instance Yesod MyApp +-- > +-- >getHomeR :: Handler Html +-- >getHomeR = defaultLayout $ [whamlet| +-- >

Hello +-- >

Check the +-- > compile time +-- >|] +-- > +-- >main :: IO () +-- >main = warp 3000 $ MyApp eStatic diff --git a/Yesod/EmbeddedStatic/Internal.hs b/Yesod/EmbeddedStatic/Internal.hs new file mode 100644 --- /dev/null +++ b/Yesod/EmbeddedStatic/Internal.hs @@ -0,0 +1,162 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} + +module Yesod.EmbeddedStatic.Internal ( + EmbeddedStatic(..) + , Route(..) + , ComputedEntry(..) + , devEmbed + , prodEmbed + , develApp + , AddStaticContent + , staticContentHelper + , widgetSettings +) where + +import Data.IORef +import Language.Haskell.TH +import Network.HTTP.Types (Status(..), status404, status200, status304) +import Network.Mime (MimeType) +import Network.Wai +import Network.Wai.Application.Static (defaultWebAppSettings, staticApp) +import WaiAppStatic.Types +import Yesod.Core + ( HandlerFor + , ParseRoute(..) + , RenderRoute(..) + , getYesod + , liftIO + ) +import qualified Data.ByteString.Lazy as BL +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.HashMap.Strict as M +import qualified WaiAppStatic.Storage.Embedded as Static + +import Yesod.Static (base64md5) +import Yesod.EmbeddedStatic.Types + +-- | The subsite for the embedded static file server. +data EmbeddedStatic = EmbeddedStatic { + stApp :: !Application + , widgetFiles :: !(IORef (M.HashMap T.Text File)) +} + +instance RenderRoute EmbeddedStatic where + data Route EmbeddedStatic = EmbeddedResourceR [T.Text] [(T.Text,T.Text)] + | EmbeddedWidgetR T.Text + deriving (Eq, Show, Read) + renderRoute (EmbeddedResourceR x y) = ("res":x, y) + renderRoute (EmbeddedWidgetR h) = (["widget",h], []) +instance ParseRoute EmbeddedStatic where + parseRoute (("res":x), y) = Just $ EmbeddedResourceR x y + parseRoute (["widget",h], _) = Just $ EmbeddedWidgetR h + parseRoute _ = Nothing + +-- | At compile time, one of these is created for every 'Entry' created by +-- the generators. The cLink is a template haskell expression of type @Route EmbeddedStatic@. +data ComputedEntry = ComputedEntry { + cHaskellName :: Maybe Name -- ^ Optional haskell name to create a variable for the route + , cStEntry :: Static.EmbeddableEntry -- ^ The entry to be embedded into the executable + , cLink :: ExpQ -- ^ The route for this entry +} + +mkStr :: String -> ExpQ +mkStr = litE . stringL + +-- | Create a 'ComputedEntry' for development mode, reloading the content on every request. +devEmbed :: Entry -> IO ComputedEntry +devEmbed e = return computed + where + st = Static.EmbeddableEntry { + Static.eLocation = "res/" `T.append` T.pack (ebLocation e) + , Static.eMimeType = ebMimeType e + , Static.eContent = Right [| $(ebDevelReload e) >>= \c -> + return (T.pack (base64md5 c), c) |] + } + link = [| EmbeddedResourceR (T.splitOn (T.pack "/") $ T.pack $(mkStr $ ebLocation e)) [] |] + computed = ComputedEntry (ebHaskellName e) st link + +-- | Create a 'ComputedEntry' for production mode, hashing and embedding the content into the executable. +prodEmbed :: Entry -> IO ComputedEntry +prodEmbed e = do + ct <- ebProductionContent e + let hash = base64md5 ct + link = [| EmbeddedResourceR (T.splitOn (T.pack "/") $ T.pack $(mkStr $ ebLocation e)) + [(T.pack "etag", T.pack $(mkStr hash))] |] + st = Static.EmbeddableEntry { + Static.eLocation = "res/" `T.append` T.pack (ebLocation e) + , Static.eMimeType = ebMimeType e + , Static.eContent = Left (T.pack hash, ct) + } + return $ ComputedEntry (ebHaskellName e) st link + +toApp :: (Request -> IO Response) -> Application +toApp f req g = f req >>= g + +tryExtraDevelFiles :: [[T.Text] -> IO (Maybe (MimeType, BL.ByteString))] -> Application +tryExtraDevelFiles = toApp . tryExtraDevelFiles' + +tryExtraDevelFiles' :: [[T.Text] -> IO (Maybe (MimeType, BL.ByteString))] -> Request -> IO Response +tryExtraDevelFiles' [] _ = return $ responseLBS status404 [] "" +tryExtraDevelFiles' (f:fs) r = do + mct <- liftIO $ f $ drop 1 $ pathInfo r -- drop the initial "res" + case mct of + Nothing -> tryExtraDevelFiles' fs r + Just (mime, ct) -> do + let hash = T.encodeUtf8 $ T.pack $ base64md5 ct + let headers = [ ("Content-Type", mime) + , ("ETag", hash) + ] + case lookup "If-None-Match" (requestHeaders r) of + Just h | hash == h -> return $ responseLBS status304 headers "" + _ -> return $ responseLBS status200 headers ct + +-- | Helper to create the development application at runtime +develApp :: StaticSettings -> [[T.Text] -> IO (Maybe (MimeType, BL.ByteString))] -> Application +develApp settings extra req sendResponse = do + staticApp settings {ssMaxAge = NoMaxAge} req $ \resp -> + if statusCode (responseStatus resp) == 404 + then tryExtraDevelFiles extra req sendResponse + else sendResponse resp + +-- | The type of 'addStaticContent' +type AddStaticContent site = T.Text -> T.Text -> BL.ByteString + -> HandlerFor site (Maybe (Either T.Text (Route site, [(T.Text, T.Text)]))) + +-- | Helper for embedStaticContent and embedLicensedStaticContent. +staticContentHelper :: (site -> EmbeddedStatic) + -> (Route EmbeddedStatic -> Route site) + -> (BL.ByteString -> Either a BL.ByteString) + -> AddStaticContent site +staticContentHelper getStatic staticR minify ext _ ct = do + wIORef <- widgetFiles . getStatic <$> getYesod + let hash = T.pack $ base64md5 ct + hash' = Just $ T.encodeUtf8 hash + filename = T.concat [hash, ".", ext] + content = case ext of + "js" -> either (const ct) id $ minify ct + _ -> ct + file = File + { fileGetSize = fromIntegral $ BL.length content + , fileToResponse = \s h -> responseLBS s h content + , fileName = unsafeToPiece filename + , fileGetHash = return hash' + , fileGetModified = Nothing + } + liftIO $ atomicModifyIORef' wIORef $ \m -> + (M.insertWith (\old _ -> old) filename file m, ()) + + return $ Just $ Right (staticR $ EmbeddedWidgetR filename, []) + +-- | Create a wai-app-static settings based on the IORef inside the EmbeddedStaic site. +widgetSettings :: EmbeddedStatic -> StaticSettings +widgetSettings es = (defaultWebAppSettings "") { ssLookupFile = lookupFile } + where + lookupFile [_,p] = do -- The first part of the path is "widget" + m <- readIORef $ widgetFiles es + return $ maybe LRNotFound LRFile $ M.lookup (fromPiece p) m + lookupFile _ = return LRNotFound diff --git a/Yesod/EmbeddedStatic/Types.hs b/Yesod/EmbeddedStatic/Types.hs new file mode 100644 --- /dev/null +++ b/Yesod/EmbeddedStatic/Types.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} + +module Yesod.EmbeddedStatic.Types( + Location + , Generator + -- ** Entry + , Entry + , ebHaskellName + , ebLocation + , ebMimeType + , ebProductionContent + , ebDevelReload + , ebDevelExtraFiles +) where + +import Data.Default +import Language.Haskell.TH +import Network.Mime (MimeType) +import qualified Data.ByteString.Lazy as BL + +-- | A location is a relative path within the static subsite at which resource(s) are made available. +-- The location can include slashes to simulate directories but must not start or end with a slash. +type Location = String + +-- | A single resource embedded into the executable at compile time. +-- +-- This data type is a settings type. For more information, see +-- . +data Entry = Entry { + ebHaskellName :: Maybe Name + -- ^ An optional haskell name. If the name is present, a variable + -- of type @Route 'Yesod.EmbeddedStatic.EmbeddedStatic'@ with the + -- given name will be created which points to this resource. + , ebLocation :: Location -- ^ The location to serve the resource from. + , ebMimeType :: MimeType -- ^ The mime type of the resource. + , ebProductionContent :: IO BL.ByteString + -- ^ If the development argument to 'Yesod.EmbeddedStatic.mkEmbeddedStatic' is False, + -- then at compile time this action will be executed to load the content. + -- During development, this action will not be executed. + , ebDevelReload :: ExpQ + -- ^ This must be a template haskell expression of type @IO 'BL.ByteString'@. + -- If the development argument to 'Yesod.EmbeddedStatic.mkEmbeddedStatic' is True, + -- this action is executed on every request to compute the content. Most of the + -- time, 'ebProductionContent' and 'ebDevelReload' should be the same action but + -- occasionally you might want additional processing inside the 'ebProductionContent' + -- function like javascript/css minification to only happen when building for production. + , ebDevelExtraFiles :: Maybe ExpQ + -- ^ Occasionally, during development an entry needs extra files/resources available + -- that are not present during production (for example, image files that are embedded + -- into the CSS at production but left unembedded during development). If present, + -- @ebDevelExtraFiles@ must be a template haskell expression of type + -- @['T.Text'] -> IO (Maybe ('MimeType', 'BL.ByteString'))@. That is, a function + -- taking as input the list of path pieces and optionally returning a mime type + -- and content. +} + +-- | When using 'def', you must fill in at least 'ebLocation'. +instance Default Entry where + def = Entry { ebHaskellName = Nothing + , ebLocation = "xxxx" + , ebMimeType = "application/octet-stream" + , ebProductionContent = return BL.empty + , ebDevelReload = [| return BL.empty |] + , ebDevelExtraFiles = Nothing + } + +-- | An embedded generator is executed at compile time to produce the entries to embed. +type Generator = Q [Entry] diff --git a/Yesod/Static.hs b/Yesod/Static.hs --- a/Yesod/Static.hs +++ b/Yesod/Static.hs @@ -1,10 +1,12 @@ -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} --------------------------------------------------------- -- -- | Serve static files from a Yesod app. @@ -18,7 +20,7 @@ -- -- In fact, in an ideal setup you'll serve your static files from -- a separate domain name to save time on transmitting --- cookies. In that case, you may wish to use 'urlRenderOverride' +-- cookies. In that case, you may wish to use 'urlParamRenderOverride' -- to redirect requests to this subsite to a separate domain -- name. -- @@ -34,56 +36,71 @@ -- * Smart constructor , static , staticDevel - , embed + -- * Combining CSS/JS + -- $combining + , combineStylesheets' + , combineScripts' + -- ** Settings + , CombineSettings + , csStaticDir + , csCssPostProcess + , csJsPostProcess + , csCssPreProcess + , csJsPreProcess + , csCombinedFolder -- * Template Haskell helpers , staticFiles , staticFilesList + , staticFilesMap + , staticFilesMergeMap , publicFiles -- * Hashing , base64md5 + -- * Embed + , embed #ifdef TEST_EXPORT , getFileListPieces #endif ) where -import Prelude hiding (FilePath) -import qualified Prelude import System.Directory -import Control.Arrow (second) +import qualified System.FilePath as FP import Control.Monad import Data.FileEmbed (embedDir) -import Yesod.Core hiding (lift) +import Yesod.Core +import Yesod.Core.Types -import Data.List (intercalate) +import Data.List (intercalate, sort) import Language.Haskell.TH -import Language.Haskell.TH.Syntax +import Language.Haskell.TH.Syntax as TH -import Crypto.Conduit (hashFile, sinkHash) -import Crypto.Hash.MD5 (MD5) +import Crypto.Hash.Conduit (hashFile, sinkHash) +import Crypto.Hash (MD5, Digest) import Control.Monad.Trans.State -import Control.Monad.IO.Class (liftIO) +import qualified Data.ByteArray as ByteArray import qualified Data.ByteString.Base64 import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L -import qualified Data.Serialize import Data.Text (Text, pack) import qualified Data.Text as T -import qualified Data.Set as S import qualified Data.Map as M import Data.IORef (readIORef, newIORef, writeIORef) -import Network.Wai (pathInfo) -import Data.Char (isLower, isDigit) -import Data.List (foldl', inits, tails) +import Data.Char (isLower) +import Data.List (foldl') import qualified Data.ByteString as S import System.PosixCompat.Files (getFileStatus, modificationTime) import System.Posix.Types (EpochTime) -import Data.Conduit (($$)) -import Data.Conduit.List (sourceList) -import Data.Functor.Identity (runIdentity) -import qualified Filesystem.Path.CurrentOS as F +import Conduit +import System.FilePath ((), (<.>), takeDirectory) +import qualified System.FilePath as F +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Encoding as TLE +import Data.Default +--import Text.Lucius (luciusRTMinified) +import Network.Wai (pathInfo) import Network.Wai.Application.Static ( StaticSettings (..) , staticApp @@ -103,21 +120,24 @@ -- Does not have index files or directory listings. The static -- files' contents /must not/ change, however new files can be -- added. -static :: Prelude.FilePath -> IO Static +static :: FilePath -> IO Static static dir = do hashLookup <- cachedETagLookup dir - return $ Static $ webAppSettingsWithLookup (F.decodeString dir) hashLookup + return $ Static $ webAppSettingsWithLookup dir hashLookup -- | Same as 'static', but does not assumes that the files do not -- change and checks their modification time whenever a request -- is made. -staticDevel :: Prelude.FilePath -> IO Static +staticDevel :: FilePath -> IO Static staticDevel dir = do hashLookup <- cachedETagLookupDevel dir - return $ Static $ webAppSettingsWithLookup (F.decodeString dir) hashLookup + return $ Static $ webAppSettingsWithLookup dir hashLookup --- | Produce a 'Static' based on embedding all of the static --- files' contents in the executable at compile time. +-- | Produce a 'Static' based on embedding all of the static files' contents in the +-- executable at compile time. +-- +-- You should use "Yesod.EmbeddedStatic" instead, it is much more powerful. +-- -- Nota Bene: if you replace the scaffolded 'static' call in Settings/StaticFiles.hs -- you will need to change the scaffolded addStaticContent. Otherwise, some of your -- assets will be 404'ed. This is because by default yesod will generate compile those @@ -125,7 +145,7 @@ -- directory itself. With embedded static, that will not work. -- You can easily change @addStaticContent@ to @\_ _ _ -> return Nothing@ as a workaround. -- This will cause yesod to embed those assets into the generated HTML file itself. -embed :: Prelude.FilePath -> Q Exp +embed :: FilePath -> Q Exp embed fp = [|Static (embeddedSettings $(embedDir fp))|] instance RenderRoute Static where @@ -146,26 +166,33 @@ data Route Static = StaticRoute [Text] [(Text, Text)] deriving (Eq, Show, Read) renderRoute (StaticRoute x y) = (x, y) +instance ParseRoute Static where + parseRoute (x, y) = Just $ StaticRoute x y -instance Yesod master => YesodDispatch Static master where - yesodDispatch _ _ (Static set) _ _ _ _ textPieces _ req = - staticApp set req { pathInfo = textPieces } +instance YesodSubDispatch Static master where + yesodSubDispatch YesodSubRunnerEnv {..} req = + ysreParentRunner handlert ysreParentEnv (fmap ysreToParentRoute route) req + where + route = Just $ StaticRoute (pathInfo req) [] -notHidden :: Prelude.FilePath -> Bool + Static set = ysreGetSub $ yreSite $ ysreParentEnv + handlert = sendWaiApplication $ staticApp set + +notHidden :: FilePath -> Bool notHidden "tmp" = False notHidden s = case s of '.':_ -> False _ -> True -getFileListPieces :: Prelude.FilePath -> IO [[String]] +getFileListPieces :: FilePath -> IO [[String]] getFileListPieces = flip evalStateT M.empty . flip go id where go :: String -> ([String] -> [String]) -> StateT (M.Map String String) IO [[String]] go fp front = do - allContents <- liftIO $ filter notHidden `fmap` getDirectoryContents fp + allContents <- liftIO $ (sort . filter notHidden) `fmap` getDirectoryContents fp let fullPath :: String -> String fullPath f = fp ++ '/' : f files <- liftIO $ filterM (doesFileExist . fullPath) allContents @@ -200,12 +227,12 @@ -- definitions would be created: -- -- > style_css = StaticRoute ["style.css"] [] --- > js_script_js = StaticRoute ["js/script.js"] [] +-- > js_script_js = StaticRoute ["js", "script.js"] [] -- -- Note that dots (@.@), dashes (@-@) and slashes (@\/@) are -- replaced by underscores (@\_@) to create valid Haskell -- identifiers. -staticFiles :: Prelude.FilePath -> Q [Dec] +staticFiles :: FilePath -> Q [Dec] staticFiles dir = mkStaticFiles dir -- | Same as 'staticFiles', but takes an explicit list of files @@ -214,15 +241,15 @@ -- files @\"static\/js\/jquery.js\"@ and -- @\"static\/css\/normalize.css\"@, you would use: -- --- > staticFilesList \"static\" [\"js\/jquery.js\", \"css\/normalize.css\"] +-- > staticFilesList "static" ["js/jquery.js", "css/normalize.css"] -- -- This can be useful when you have a very large number of static -- files, but only need to refer to a few of them from Haskell. -staticFilesList :: Prelude.FilePath -> [Prelude.FilePath] -> Q [Dec] +staticFilesList :: FilePath -> [FilePath] -> Q [Dec] staticFilesList dir fs = - mkStaticFilesList dir (map split fs) "StaticRoute" True + mkStaticFilesList dir (map split fs) True where - split :: Prelude.FilePath -> [String] + split :: FilePath -> [String] split [] = [] split x = let (a, b) = break (== '/') x @@ -238,38 +265,85 @@ -- on the future. Browsers still will be able to cache the -- contents, however they'll need send a request to the server to -- see if their copy is up-to-date. -publicFiles :: Prelude.FilePath -> Q [Dec] -publicFiles dir = mkStaticFiles' dir "StaticRoute" False +publicFiles :: FilePath -> Q [Dec] +publicFiles dir = mkStaticFiles' dir False +-- | Similar to 'staticFilesList', but takes a mapping of +-- unmunged names to fingerprinted file names. +-- +-- @since 1.5.3 +staticFilesMap :: FilePath -> M.Map FilePath FilePath -> Q [Dec] +staticFilesMap fp m = mkStaticFilesList' fp (map splitBoth mapList) True + where + splitBoth (k, v) = (split k, split v) + mapList = M.toList m + split :: FilePath -> [String] + split [] = [] + split x = + let (a, b) = break (== '/') x + in a : split (drop 1 b) -mkHashMap :: Prelude.FilePath -> IO (M.Map F.FilePath S8.ByteString) +-- | Similar to 'staticFilesMergeMap', but also generates identifiers +-- for all files in the specified directory that don't have a +-- fingerprinted version. +-- +-- @since 1.5.3 +staticFilesMergeMap :: FilePath -> M.Map FilePath FilePath -> Q [Dec] +staticFilesMergeMap fp m = do + fs <- qRunIO $ getFileListPieces fp + let filesList = map FP.joinPath fs + mergedMapList = M.toList $ foldl' (checkedInsert invertedMap) m filesList + mkStaticFilesList' fp (map splitBoth mergedMapList) True + where + splitBoth (k, v) = (split k, split v) + swap (x, y) = (y, x) + mapList = M.toList m + invertedMap = M.fromList $ map swap mapList + split :: FilePath -> [String] + split [] = [] + split x = + let (a, b) = break (== '/') x + in a : split (drop 1 b) + -- We want to keep mappings for all files that are pre-fingerprinted, + -- so this function checks against all of the existing fingerprinted files and + -- only inserts a new mapping if it's not a fingerprinted file. + checkedInsert + :: M.Map FilePath FilePath -- inverted dictionary + -> M.Map FilePath FilePath -- accumulating state + -> FilePath + -> M.Map FilePath FilePath + checkedInsert iDict st p = if M.member p iDict + then st + else M.insert p p st + +mkHashMap :: FilePath -> IO (M.Map FilePath S8.ByteString) mkHashMap dir = do fs <- getFileListPieces dir hashAlist fs >>= return . M.fromList where - hashAlist :: [[String]] -> IO [(F.FilePath, S8.ByteString)] + hashAlist :: [[String]] -> IO [(FilePath, S8.ByteString)] hashAlist fs = mapM hashPair fs where - hashPair :: [String] -> IO (F.FilePath, S8.ByteString) + hashPair :: [String] -> IO (FilePath, S8.ByteString) hashPair pieces = do let file = pathFromRawPieces dir pieces h <- base64md5File file - return (F.decodeString file, S8.pack h) + return (file, S8.pack h) -pathFromRawPieces :: Prelude.FilePath -> [String] -> Prelude.FilePath +pathFromRawPieces :: FilePath -> [String] -> FilePath pathFromRawPieces = foldl' append where append a b = a ++ '/' : b -cachedETagLookupDevel :: Prelude.FilePath -> IO ETagLookup +cachedETagLookupDevel :: FilePath -> IO ETagLookup cachedETagLookupDevel dir = do etags <- mkHashMap dir - mtimeVar <- newIORef (M.empty :: M.Map F.FilePath EpochTime) + mtimeVar <- newIORef (M.empty :: M.Map FilePath EpochTime) return $ \f -> case M.lookup f etags of Nothing -> return Nothing Just checksum -> do - fs <- getFileStatus $ F.encodeString f + fs <- getFileStatus f let newt = modificationTime fs mtimes <- readIORef mtimeVar oldt <- case M.lookup f mtimes of @@ -278,125 +352,74 @@ return $ if newt /= oldt then Nothing else Just checksum -cachedETagLookup :: Prelude.FilePath -> IO ETagLookup +cachedETagLookup :: FilePath -> IO ETagLookup cachedETagLookup dir = do etags <- mkHashMap dir return $ (\f -> return $ M.lookup f etags) -mkStaticFiles :: Prelude.FilePath -> Q [Dec] -mkStaticFiles fp = mkStaticFiles' fp "StaticRoute" True +mkStaticFiles :: FilePath -> Q [Dec] +mkStaticFiles fp = mkStaticFiles' fp True -mkStaticFiles' :: Prelude.FilePath -- ^ static directory - -> String -- ^ route constructor "StaticRoute" +mkStaticFiles' :: FilePath -- ^ static directory -> Bool -- ^ append checksum query parameter -> Q [Dec] -mkStaticFiles' fp routeConName makeHash = do +mkStaticFiles' fp makeHash = do fs <- qRunIO $ getFileListPieces fp - mkStaticFilesList fp fs routeConName makeHash + mkStaticFilesList fp fs makeHash mkStaticFilesList - :: Prelude.FilePath -- ^ static directory + :: FilePath -- ^ static directory -> [[String]] -- ^ list of files to create identifiers for - -> String -- ^ route constructor "StaticRoute" -> Bool -- ^ append checksum query parameter -> Q [Dec] -mkStaticFilesList fp fs routeConName makeHash = do - let (squashedFinal, squashMap) = squashStrings ("etag" : concat fs) - (squashedName, squashedDecl) <- mkSquashedStringsDecl squashedFinal - let refName = mkSquashedReference squashedName squashMap - routes <- concat `fmap` mapM (mkRoute refName) fs - return (squashedDecl ++ routes) +mkStaticFilesList fp fs makeHash = mkStaticFilesList' fp (zip fs fs) makeHash + +mkStaticFilesList' + :: FilePath -- ^ static directory + -> [([String], [String])] -- ^ list of files to create identifiers for, where + -- the first argument of the tuple is the identifier + -- alias and the second is the actual file name + -> Bool -- ^ append checksum query parameter + -> Q [Dec] +mkStaticFilesList' fp fs makeHash = do + concat `fmap` mapM mkRoute fs where replace' c | 'A' <= c && c <= 'Z' = c | 'a' <= c && c <= 'z' = c | '0' <= c && c <= '9' = c | otherwise = '_' - mkSquashedStringsDecl squashedFinal = do - name <- newName "squashedStrings" - pack' <- [|pack|] - squashedFinal' <- lift squashedFinal - let decl = [ SigD name (ConT ''Text) - , FunD name - [ Clause [] (NormalB $ pack' `AppE` squashedFinal') [] - ] - ] - return (name, decl) - mkSquashedReference squashedName squashMap = \str -> - case M.lookup str squashMap of - Nothing -> [|pack $(lift str)|] - Just (pos, len) -> [|T.take len (T.drop pos $(return (VarE squashedName)))|] - mkRoute refName f = do - let name' = intercalate "_" $ map (map replace') f + mkRoute (alias, f) = do + let name' = intercalate "_" $ map (map replace') alias routeName = mkName $ - case () of - () - | null name' -> error "null-named file" - | isDigit (head name') -> '_' : name' - | isLower (head name') -> name' + case name' of + [] -> error "null-named file" + n : _ + | isLower n -> name' | otherwise -> '_' : name' - f' <- ListE `fmap` mapM refName f - let route = mkName routeConName + f' <- [|map pack $(TH.lift f)|] qs <- if makeHash then do hash <- qRunIO $ base64md5File $ pathFromRawPieces fp f - [|[($(refName "etag"), $(refName hash))]|] + [|[(pack "etag", pack $(TH.lift hash))]|] else return $ ListE [] return - [ SigD routeName $ ConT route + [ SigD routeName $ ConT ''StaticRoute , FunD routeName - [ Clause [] (NormalB $ (ConE route) `AppE` f' `AppE` qs) [] + [ Clause [] (NormalB $ (ConE 'StaticRoute) `AppE` f' `AppE` qs) [] ] ] - --- | Convert a list of 'String's into a single 'String' and a --- 'M.Map' of the original 'String's into an offset and a length on --- the resulting single 'String'. -squashStrings :: [String] -> (String, M.Map String (Int, Int)) -squashStrings = second M.fromAscList . go 0 "" . S.toAscList . S.fromList - where - -- Length of the string of maximal length of characters from - -- the end of the @lastString@ that are the same. Uses a - -- naive algorithm. - calculateOverlap lastString newString = - let -- Make both strings of equal length. - len = length lastString `min` length newString - lastString' = reverse $ take len $ reverse lastString - newString' = take len newString - -- Using 'head' should be safe but we use another - -- version to avoid unuseful messages while debugging. - safeHead (x:_) = x - safeHead [] = error "squashStrings/overlap: never here" - in safeHead $ do - (lastStringSuffix, newStringPrefix) <- - tails lastString' `zip` reverse (inits newString') - guard (lastStringSuffix == newStringPrefix) - return (length lastStringSuffix) - - -- Position the new strings on the resulting string. - go lastPos lastString (newString:nss) = - let len = length newString - overlap = calculateOverlap lastString newString - thisPos = lastPos - overlap - newLastPos = lastPos + len - overlap - (recString, recMap) = go newLastPos newString nss - in ( drop overlap newString ++ recString - , (newString, (thisPos, len)) : recMap - ) - go _ _ [] = ([], []) - - -base64md5File :: Prelude.FilePath -> IO String +base64md5File :: FilePath -> IO String base64md5File = fmap (base64 . encode) . hashFile - where encode d = Data.Serialize.encode (d :: MD5) + where encode d = ByteArray.convert (d :: Digest MD5) base64md5 :: L.ByteString -> String base64md5 lbs = base64 $ encode - $ runIdentity - $ sourceList (L.toChunks lbs) $$ sinkHash + $ runConduitPure + $ Conduit.sourceLazy lbs .| sinkHash where - encode d = Data.Serialize.encode (d :: MD5) + encode d = ByteArray.convert (d :: Digest MD5) base64 :: S.ByteString -> String base64 = map tr @@ -407,3 +430,176 @@ tr '+' = '-' tr '/' = '_' tr c = c + +-- $combining +-- +-- A common scenario on a site is the desire to include many external CSS and +-- Javascript files on every page. Doing so via the Widget functionality in +-- Yesod will work, but would also mean that the same content will be +-- downloaded many times. A better approach would be to combine all of these +-- files together into a single static file and serve that as a static resource +-- for every page. That resource can be cached on the client, and bandwidth +-- usage reduced. +-- +-- This could be done as a manual process, but that becomes tedious. Instead, +-- you can use some Template Haskell code which will combine these files into a +-- single static file at compile time. + +data CombineType = JS | CSS + +combineStatics' :: CombineType + -> CombineSettings + -> [Route Static] -- ^ files to combine + -> Q Exp +combineStatics' combineType CombineSettings {..} routes = do + texts <- qRunIO $ runConduitRes + $ yieldMany fps + .| awaitForever readUTFFile + .| sinkLazy + ltext <- qRunIO $ preProcess texts + bs <- qRunIO $ postProcess fps $ TLE.encodeUtf8 ltext + let hash' = base64md5 bs + suffix = csCombinedFolder hash' <.> extension + fp = csStaticDir suffix + qRunIO $ do + createDirectoryIfMissing True $ takeDirectory fp + L.writeFile fp bs + let pieces = map T.unpack $ T.splitOn "/" $ T.pack suffix + [|StaticRoute (map pack pieces) []|] + where + fps :: [FilePath] + fps = map toFP routes + toFP (StaticRoute pieces _) = csStaticDir F.joinPath (map T.unpack pieces) + readUTFFile fp = sourceFile fp .| decodeUtf8C + postProcess = + case combineType of + JS -> csJsPostProcess + CSS -> csCssPostProcess + preProcess = + case combineType of + JS -> csJsPreProcess + CSS -> csCssPreProcess + extension = + case combineType of + JS -> "js" + CSS -> "css" + +-- | Data type for holding all settings for combining files. +-- +-- This data type is a settings type. For more information, see: +-- +-- +-- +-- Since 1.2.0 +data CombineSettings = CombineSettings + { csStaticDir :: FilePath + -- ^ File path containing static files. + -- + -- Default: static + -- + -- Since 1.2.0 + , csCssPostProcess :: [FilePath] -> L.ByteString -> IO L.ByteString + -- ^ Post processing to be performed on CSS files. + -- + -- Default: Pass-through. + -- + -- Since 1.2.0 + , csJsPostProcess :: [FilePath] -> L.ByteString -> IO L.ByteString + -- ^ Post processing to be performed on Javascript files. + -- + -- Default: Pass-through. + -- + -- Since 1.2.0 + , csCssPreProcess :: TL.Text -> IO TL.Text + -- ^ Pre-processing to be performed on CSS files. + -- + -- Default: convert all occurences of /static/ to ../ + -- + -- Since 1.2.0 + , csJsPreProcess :: TL.Text -> IO TL.Text + -- ^ Pre-processing to be performed on Javascript files. + -- + -- Default: Pass-through. + -- + -- Since 1.2.0 + , csCombinedFolder :: FilePath + -- ^ Subfolder to put combined files into. + -- + -- Default: combined + -- + -- Since 1.2.0 + } + +instance Default CombineSettings where + def = CombineSettings + { csStaticDir = "static" + {- Disabled due to: https://github.com/yesodweb/yesod/issues/623 + , csCssPostProcess = \fps -> + either (error . (errorIntro fps)) (return . TLE.encodeUtf8) + . flip luciusRTMinified [] + . TLE.decodeUtf8 + -} + , csCssPostProcess = const return + , csJsPostProcess = const return + -- FIXME The following borders on a hack. With combining of files, + -- the final location of the CSS is no longer fixed, so relative + -- references will break. Instead, we switched to using /static/ + -- absolute references. However, when served from a separate domain + -- name, this will break too. The solution is that, during + -- development, we keep /static/, and in the combining phase, we + -- replace /static with a relative reference to the parent folder. + , csCssPreProcess = + return + . TL.replace "'/static/" "'../" + . TL.replace "\"/static/" "\"../" + , csJsPreProcess = return + , csCombinedFolder = "combined" + } + +liftRoutes :: [Route Static] -> Q Exp +liftRoutes = + fmap ListE . mapM go + where + go :: Route Static -> Q Exp + go (StaticRoute x y) = [|StaticRoute $(liftTexts x) $(liftPairs y)|] + + liftTexts = fmap ListE . mapM liftT + liftT t = [|pack $(TH.lift $ T.unpack t)|] + + liftPairs = fmap ListE . mapM liftPair + liftPair (x, y) = [|($(liftT x), $(liftT y))|] + +-- | Combine multiple CSS files together. Common usage would be: +-- +-- >>> combineStylesheets' development def 'StaticR [style1_css, style2_css] +-- +-- Where @development@ is a variable in your site indicated whether you are in +-- development or production mode. +-- +-- Since 1.2.0 +combineStylesheets' :: Bool -- ^ development? if so, perform no combining + -> CombineSettings + -> Name -- ^ Static route constructor name, e.g. \'StaticR + -> [Route Static] -- ^ files to combine + -> Q Exp +combineStylesheets' development cs con routes + | development = [| mapM_ (addStylesheet . $(return $ ConE con)) $(liftRoutes routes) |] + | otherwise = [| addStylesheet $ $(return $ ConE con) $(combineStatics' CSS cs routes) |] + + +-- | Combine multiple JS files together. Common usage would be: +-- +-- >>> combineScripts' development def 'StaticR [script1_js, script2_js] +-- +-- Where @development@ is a variable in your site indicated whether you are in +-- development or production mode. +-- +-- Since 1.2.0 +combineScripts' :: Bool -- ^ development? if so, perform no combining + -> CombineSettings + -> Name -- ^ Static route constructor name, e.g. \'StaticR + -> [Route Static] -- ^ files to combine + -> Q Exp +combineScripts' development cs con routes + | development = [| mapM_ (addScript . $(return $ ConE con)) $(liftRoutes routes) |] + | otherwise = [| addScript $ $(return $ ConE con) $(combineStatics' JS cs routes) |] diff --git a/sample-embed.hs b/sample-embed.hs new file mode 100644 --- /dev/null +++ b/sample-embed.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + +-- | This embeds just a single file; it embeds the source code file +-- \"sample-embed.hs\" from the current directory so when you compile, +-- the sample-embed.hs file must be in the current directory. +-- +-- Try toggling the development argument to 'mkEmbeddedStatic'. When the +-- development argument is true the file \"sample-embed.hs\" is reloaded +-- from disk on every request (try changing it after you start the server). +-- When development is false, the contents are embedded and the sample-embed.hs +-- file does not even need to be present during runtime. +module Main where + +import Yesod.Core +import Yesod.EmbeddedStatic + +mkEmbeddedStatic False "eStatic" [embedFile "sample-embed.hs"] + +-- The above will generate variables +-- eStatic :: EmbeddedStatic +-- sample_embed_hs :: Route EmbeddedStatic + +data MyApp = MyApp { getStatic :: EmbeddedStatic } + +mkYesod "MyApp" [parseRoutes| +/ HomeR GET +/static StaticR EmbeddedStatic getStatic +|] + +instance Yesod MyApp where + addStaticContent = embedStaticContent getStatic StaticR Right + +getHomeR :: Handler Html +getHomeR = defaultLayout $ do + toWidget [julius|console.log("Hello World");|] + [whamlet| +

Hello +

Check the + embedded file +|] + +main :: IO () +main = warp 3000 $ MyApp eStatic diff --git a/sample.hs b/sample.hs new file mode 100644 --- /dev/null +++ b/sample.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + +import Yesod.Static +import Yesod.Core +import Network.Wai.Handler.Warp (run) +import Network.Wai.Application.Static + +staticFiles "." + +data Sample = Sample { getStatic :: Static } + +--getStatic _ = Static $ defaultFileServerSettings { ssFolder = fileSystemLookup $ toFilePath "." } +mkYesod "Sample" [parseRoutes| +/ RootR GET +/static StaticR Static getStatic +|] +instance Yesod Sample where + +getRootR = do + redirect "static" + return () + +main = do + s <- static "." + toWaiApp (Sample s) >>= run 3000 diff --git a/test/EmbedDevelTest.hs b/test/EmbedDevelTest.hs new file mode 100644 --- /dev/null +++ b/test/EmbedDevelTest.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + +module EmbedDevelTest where + +-- Tests the development mode of the embedded static subsite by +-- using a custom generator testGen. + +import Data.Maybe (isNothing) +import EmbedTestGenerator +import EmbedProductionTest (findEtag) +import Network.Wai.Test (SResponse(simpleHeaders)) +import Test.HUnit (assertBool) +import Test.Hspec (Spec) +import Yesod.Core +import Yesod.EmbeddedStatic +import Yesod.Test + +mkEmbeddedStatic True "eDev" [testGen] + +data MyApp = MyApp { getStatic :: EmbeddedStatic } + +mkYesod "MyApp" [parseRoutes| +/static StaticR EmbeddedStatic getStatic +|] + +instance Yesod MyApp + +noCacheControl :: YesodExample site () +noCacheControl = withResponse $ \r -> do + liftIO $ assertBool "Cache-Control exists" $ + isNothing $ lookup "Cache-Control" $ simpleHeaders r + liftIO $ assertBool "Expires exists" $ + isNothing $ lookup "Expires" $ simpleHeaders r + +embedDevSpecs :: Spec +embedDevSpecs = yesodSpec (MyApp eDev) $ do + ydescribe "Embedded Development Entries" $ do + yit "e1 loads" $ do + get $ StaticR e1 + statusIs 200 + assertHeader "Content-Type" "text/plain" + noCacheControl + bodyEquals "e1 devel" + + tag <- findEtag + request $ do + setMethod "GET" + setUrl $ StaticR e1 + addRequestHeader ("If-None-Match", tag) + statusIs 304 + + yit "e2 with simulated directory" $ do + get $ StaticR e2 + statusIs 200 + assertHeader "Content-Type" "abcdef" + noCacheControl + bodyEquals "e2 devel" + + yit "e3 without haskell name" $ do + get $ StaticR $ embeddedResourceR ["xxxx", "e3"] [] + statusIs 200 + assertHeader "Content-Type" "yyy" + noCacheControl + bodyEquals "e3 devel" + + yit "e4 loads" $ do + get $ StaticR e4 + statusIs 200 + assertHeader "Content-Type" "text/plain" + noCacheControl + bodyEquals "e4 devel" + + yit "e4 extra development dev1" $ do + get $ StaticR $ embeddedResourceR ["dev1"] [] + statusIs 200 + assertHeader "Content-Type" "mime" + noCacheControl + bodyEquals "dev1 content" + + tag <- findEtag + request $ do + setMethod "GET" + setUrl $ StaticR $ embeddedResourceR ["dev1"] [] + addRequestHeader ("If-None-Match", tag) + statusIs 304 + + yit "e4 extra development with path" $ do + get $ StaticR $ embeddedResourceR ["dir", "dev2"] [] + statusIs 200 + assertHeader "Content-Type" "mime2" + noCacheControl + bodyEquals "dev2 content" + + yit "extra development file 404" $ do + get $ StaticR $ embeddedResourceR ["xxxxxxxxxx"] [] + statusIs 404 diff --git a/test/EmbedProductionTest.hs b/test/EmbedProductionTest.hs new file mode 100644 --- /dev/null +++ b/test/EmbedProductionTest.hs @@ -0,0 +1,130 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + +module EmbedProductionTest where + +-- Tests the production mode of the embedded static subsite by +-- using a custom generator testGen. Also tests that the widget +-- content is embedded properly. + +import Data.Maybe (isJust) +import EmbedTestGenerator +import Network.Wai.Test (SResponse(simpleHeaders)) +import Test.HUnit (assertFailure, assertBool) +import Test.Hspec (Spec) +import Yesod.Core +import Yesod.EmbeddedStatic +import Yesod.Test +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Encoding as TL + +mkEmbeddedStatic False "eProduction" [testGen] + +data MyApp = MyApp { getStatic :: EmbeddedStatic } + +mkYesod "MyApp" [parseRoutes| +/ HomeR GET +/static StaticR EmbeddedStatic getStatic +|] + +getHomeR :: Handler Html +getHomeR = defaultLayout $ do + toWidget [julius|console.log("Hello World");|] + [whamlet|

Hello|] + +instance Yesod MyApp where + addStaticContent = embedStaticContent getStatic StaticR Right + +findEtag :: YesodExample site B.ByteString +findEtag = withResponse $ \r -> + case lookup "ETag" (simpleHeaders r) of + Nothing -> liftIO (assertFailure "No etag found") >> error "" + Just e -> return e + +hasCacheControl :: YesodExample site () +hasCacheControl = withResponse $ \r -> do + liftIO $ assertBool "Cache-Control missing" $ + isJust $ lookup "Cache-Control" $ simpleHeaders r + liftIO $ assertBool "Expires missing" $ + isJust $ lookup "Expires" $ simpleHeaders r + +embedProductionSpecs :: Spec +embedProductionSpecs = yesodSpec (MyApp eProduction) $ do + ydescribe "Embedded Production Entries" $ do + yit "e1 loads" $ do + get $ StaticR e1 + statusIs 200 + assertHeader "Content-Type" "text/plain" + hasCacheControl + bodyEquals "e1 production" + + tag <- findEtag + request $ do + setMethod "GET" + setUrl $ StaticR e1 + addRequestHeader ("If-None-Match", tag) + statusIs 304 + + yit "e1 with custom built path" $ do + get $ StaticR $ embeddedResourceR ["e1"] [] + statusIs 200 + assertHeader "Content-Type" "text/plain" + hasCacheControl + bodyEquals "e1 production" + + yit "e2 with simulated directory" $ do + get $ StaticR e2 + statusIs 200 + assertHeader "Content-Type" "abcdef" + hasCacheControl + bodyEquals "e2 production" + + yit "e2 with custom built directory path" $ do + get $ StaticR $ embeddedResourceR ["dir", "e2"] [] + statusIs 200 + assertHeader "Content-Type" "abcdef" + hasCacheControl + bodyEquals "e2 production" + + yit "e3 without haskell name" $ do + get $ StaticR $ embeddedResourceR ["xxxx", "e3"] [] + statusIs 200 + assertHeader "Content-Type" "yyy" + hasCacheControl + bodyEquals "e3 production" + + yit "e4 is embedded" $ do + get $ StaticR e4 + statusIs 200 + assertHeader "Content-Type" "text/plain" + hasCacheControl + bodyEquals "e4 production" + + yit "e4 extra development files are not embedded" $ do + get $ StaticR $ embeddedResourceR ["dev1"] [] + statusIs 404 + + ydescribe "Embedded Widget Content" $ + yit "Embedded Javascript" $ do + get HomeR + statusIs 200 + script <- htmlQuery "script" >>= \case + [s] -> return s + _ -> liftIO $ fail "Expected singleton list of script" + let src = BL.takeWhile (/= 34) $ BL.drop 1 $ BL.dropWhile (/= 34) script -- 34 is " + + get $ TL.toStrict $ TL.decodeUtf8 src + statusIs 200 + hasCacheControl + withResponse $ \resp -> liftIO $ + assertBool "Content-Type header is application/javascript or text/javascript" $ + lookup "Content-Type" (simpleHeaders resp) `elem` + [ Just "text/javascript" -- mime-types >= 0.1.2.1 + , Just "application/javascript" -- mime-types <= 0.1.2.0 + ] + bodyEquals "console.log(\"Hello World\");" diff --git a/test/EmbedTestGenerator.hs b/test/EmbedTestGenerator.hs new file mode 100644 --- /dev/null +++ b/test/EmbedTestGenerator.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} + +module EmbedTestGenerator (testGen) where + +import Data.Default +import Network.Mime (MimeType) +import Yesod.EmbeddedStatic.Types +import Yesod.EmbeddedStatic.Generators (pathToName) + +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Encoding as TL +import qualified Data.ByteString.Lazy as BL + +e1, e2, e3, e4 :: Entry + +-- Basic entry +e1 = def + { ebHaskellName = Just $ pathToName "e1" + , ebLocation = "e1" + , ebMimeType = "text/plain" + , ebProductionContent = return $ TL.encodeUtf8 "e1 production" + , ebDevelReload = [| return $ TL.encodeUtf8 $ TL.pack "e1 devel" |] + , ebDevelExtraFiles = Nothing + } + +-- Test simulated directory in location +e2 = def + { ebHaskellName = Just $ pathToName "e2" + , ebLocation = "dir/e2" + , ebMimeType = "abcdef" + , ebProductionContent = return $ TL.encodeUtf8 "e2 production" + , ebDevelReload = [| return $ TL.encodeUtf8 $ TL.pack "e2 devel" |] + , ebDevelExtraFiles = Nothing + } + +-- Test empty haskell name +e3 = def + { ebHaskellName = Nothing + , ebLocation = "xxxx/e3" + , ebMimeType = "yyy" + , ebProductionContent = return $ TL.encodeUtf8 "e3 production" + , ebDevelReload = [| return $ TL.encodeUtf8 $ TL.pack "e3 devel" |] + , ebDevelExtraFiles = Nothing + } + +devExtra :: [T.Text] -> IO (Maybe (MimeType, BL.ByteString)) +devExtra ["dev1"] = return $ Just ("mime", "dev1 content") +devExtra ["dir", "dev2"] = return $ Just ("mime2", "dev2 content") +devExtra _ = return Nothing + +-- Entry with devel extra files +e4 = def + { ebHaskellName = Just $ pathToName "e4" + , ebLocation = "e4" + , ebMimeType = "text/plain" + , ebProductionContent = return $ TL.encodeUtf8 "e4 production" + , ebDevelReload = [| return $ TL.encodeUtf8 $ TL.pack "e4 devel" |] + , ebDevelExtraFiles = Just [| devExtra |] + } + +testGen :: Generator +testGen = return [e1, e2, e3, e4] diff --git a/test/FileGeneratorTests.hs b/test/FileGeneratorTests.hs new file mode 100644 --- /dev/null +++ b/test/FileGeneratorTests.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} + +module FileGeneratorTests (fileGenSpecs) where + +import Control.Exception +import Control.Monad (forM_) +import GeneratorTestUtil +import Test.Hspec +import Test.HUnit (assertFailure, assertEqual) +import Yesod.EmbeddedStatic.Generators +import qualified Data.ByteString.Lazy as BL + +-- | Embeds the LICENSE file +license :: GenTestResult +license = $(embedFile "LICENSE" >>= + testOneEntry (Just "_LICENSE") "LICENSE" (BL.readFile "LICENSE") + ) + +licenseAt :: GenTestResult +licenseAt = $(embedFileAt "abc.txt" "LICENSE" >>= + testOneEntry (Just "abc_txt") "abc.txt" (BL.readFile "LICENSE") + ) + +embDir :: [GenTestResult] +embDir = $(embedDir "test/embed-dir" >>= + testEntries + [ (Just "abc_def_txt", "abc/def.txt", BL.readFile "test/embed-dir/abc/def.txt") + , (Just "lorem_txt", "lorem.txt", BL.readFile "test/embed-dir/lorem.txt") + , (Just "foo", "foo", BL.readFile "test/embed-dir/foo") + ] + ) + +embDirAt :: [GenTestResult] +embDirAt = $(embedDirAt "xxx" "test/embed-dir" >>= + testEntries + [ (Just "xxx_abc_def_txt", "xxx/abc/def.txt", BL.readFile "test/embed-dir/abc/def.txt") + , (Just "xxx_lorem_txt", "xxx/lorem.txt", BL.readFile "test/embed-dir/lorem.txt") + , (Just "xxx_foo", "xxx/foo", BL.readFile "test/embed-dir/foo") + ] + ) + +concatR :: GenTestResult +concatR = $(concatFiles "out.txt" [ "test/embed-dir/abc/def.txt", "test/embed-dir/foo"] >>= + testOneEntry (Just "out_txt") "out.txt" (return "Yesod Rocks\nBar\n") + ) + +-- The transform function should only run at compile for the production content +concatWithR :: GenTestResult +concatWithR = $(concatFilesWith "out2.txt" + (\x -> return $ x `BL.append` "Extra") + [ "test/embed-dir/abc/def.txt", "test/embed-dir/foo"] >>= + testOneEntry (Just "out2_txt") "out2.txt" (return "Yesod Rocks\nBar\nExtra") + ) + +fileGenSpecs :: Spec +fileGenSpecs = do + describe "Embed File" $ do + it "embeds a single file" $ + assertGenResult (BL.readFile "LICENSE") license + it "embeds a single file at a location" $ + assertGenResult (BL.readFile "LICENSE") licenseAt + + describe "Embed Directory" $ do + it "embeds a directory" $ + forM_ [embDir, embDirAt] $ \d -> case d of + [GenError e] -> assertFailure e + [def, foo, lorem] -> do + assertGenResult (BL.readFile "test/embed-dir/abc/def.txt") def + assertGenResult (BL.readFile "test/embed-dir/foo") foo + assertGenResult (BL.readFile "test/embed-dir/lorem.txt") lorem + _ -> assertFailure "Bad directory list" + + describe "Concat Files" $ do + it "simple concat" $ + assertGenResult (return "Yesod Rocks\nBar\n") concatR + it "concat with processing function" $ + assertGenResult (return "Yesod Rocks\nBar\n") concatWithR -- no Extra since this is development + + describe "Compress" $ do + it "compress tool function" $ do + out <- compressTool "runhaskell" [] "main = putStrLn \"Hello World\"" + -- 13 == CR, to make this test work on Windows + BL.filter (/= 13) out `shouldBe` "Hello World\n" + + it "tryCompressTools" $ do + out <- flip tryCompressTools "abcdef" + [ const $ throwIO $ ErrorCall "An expected error" + , const $ return "foo" + , const $ return "bar" + ] + assertEqual "" "foo" out + out2 <- flip tryCompressTools "abcdef" + [ const $ throwIO $ ErrorCall "An expected error"] + assertEqual "" "abcdef" out2 diff --git a/test/GeneratorTestUtil.hs b/test/GeneratorTestUtil.hs new file mode 100644 --- /dev/null +++ b/test/GeneratorTestUtil.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} + +module GeneratorTestUtil where + +import Control.Monad (when) +import Data.List (sortBy) +import Language.Haskell.TH +import Test.HUnit +import Yesod.EmbeddedStatic.Types as Y +import qualified Data.ByteString.Lazy as BL +import RIO (HasCallStack) + +-- We test the generators by executing them at compile time +-- and sticking the result into the GenTestResult. We then +-- test the GenTestResult at runtime. But to test the ebDevelReload +-- we must run the action at runtime so that is also embedded. +-- Because of template haskell stage restrictions, this code +-- needs to be in a separate module. + +data GenTestResult = GenError String + | GenSuccessWithDevel (IO BL.ByteString) + +-- | Creates a GenTestResult at compile time by testing the entry. +testEntry :: Maybe String -> Y.Location -> IO BL.ByteString -> Entry -> ExpQ +testEntry name _ _ e | ebHaskellName e /= (mkName <$> name) = + [| GenError ("haskell name " ++ $(litE $ stringL $ show $ ebHaskellName e) + ++ " /= " + ++ $(litE $ stringL $ show name)) |] +testEntry _ loc _ e | ebLocation e /= loc = + [| GenError ("location " ++ $(litE $ stringL $ show $ ebLocation e)) |] +testEntry _ _ act e = do + expected <- fmap stripCR $ runIO act + actual <- fmap stripCR $ runIO $ ebProductionContent e + if expected == actual + then [| GenSuccessWithDevel $(ebDevelReload e) |] + else [| GenError $ "production content: " ++ $(litE $ stringL $ show (expected, actual)) |] + +-- | Remove all carriage returns, for Windows testing +stripCR :: BL.ByteString -> BL.ByteString +stripCR = BL.filter (/= 13) + +testOneEntry :: Maybe String -> Y.Location -> IO BL.ByteString -> [Entry] -> ExpQ +testOneEntry name loc ct [e] = testEntry name loc ct e +testOneEntry _ _ _ _ = [| GenError "not exactly one entry" |] + +-- | Tests a list of entries +testEntries :: [(Maybe String, Y.Location, IO BL.ByteString)] -> [Entry] -> ExpQ +testEntries a b | length a /= length b = [| [GenError "lengths differ"] |] +testEntries a b = listE $ zipWith f a' b' + where + a' = sortBy (\(_,l1,_) (_,l2,_) -> compare l1 l2) a + b' = sortBy (\e1 e2 -> ebLocation e1 `compare` ebLocation e2) b + f (name, loc, ct) e = testEntry name loc ct e + +-- | Use this at runtime to assert the 'GenTestResult' is OK +assertGenResult :: HasCallStack + => (IO BL.ByteString) -- ^ expected development content + -> GenTestResult -- ^ test result created at compile time + -> Assertion +assertGenResult _ (GenError e) = assertFailure ("invalid " ++ e) +assertGenResult mexpected (GenSuccessWithDevel mactual) = do + expected <- fmap stripCR mexpected + actual <- fmap stripCR mactual + when (expected /= actual) $ + assertFailure $ "invalid devel content: " ++ show (expected, actual) diff --git a/test/embed-dir/abc/def.txt b/test/embed-dir/abc/def.txt new file mode 100644 --- /dev/null +++ b/test/embed-dir/abc/def.txt @@ -0,0 +1,1 @@ +Yesod Rocks diff --git a/test/embed-dir/foo b/test/embed-dir/foo new file mode 100644 --- /dev/null +++ b/test/embed-dir/foo @@ -0,0 +1,1 @@ +Bar diff --git a/test/embed-dir/lorem.txt b/test/embed-dir/lorem.txt new file mode 100644 --- /dev/null +++ b/test/embed-dir/lorem.txt @@ -0,0 +1,6 @@ +Lorem ipsum dolor sit amet, consectetur adipisicing elit, sed do eiusmod tempor +incididunt ut labore et dolore magna aliqua. Ut enim ad minim veniam, quis +nostrud exercitation ullamco laboris nisi ut aliquip ex ea commodo consequat. +Duis aute irure dolor in reprehenderit in voluptate velit esse cillum dolore eu +fugiat nulla pariatur. Excepteur sint occaecat cupidatat non proident, sunt in +culpa qui officia deserunt mollit anim id est laborum. diff --git a/test/tests.hs b/test/tests.hs --- a/test/tests.hs +++ b/test/tests.hs @@ -2,6 +2,13 @@ import Test.Hspec import YesodStaticTest (specs) +import EmbedProductionTest (embedProductionSpecs) +import EmbedDevelTest (embedDevSpecs) +import FileGeneratorTests (fileGenSpecs) main :: IO () -main = hspec specs +main = hspec $ do + specs + embedProductionSpecs + embedDevSpecs + fileGenSpecs diff --git a/yesod-static.cabal b/yesod-static.cabal --- a/yesod-static.cabal +++ b/yesod-static.cabal @@ -1,5 +1,5 @@ name: yesod-static -version: 1.1.2.3 +version: 1.6.1.3 license: MIT license-file: LICENSE author: Michael Snoyman @@ -7,71 +7,120 @@ synopsis: Static file serving subsite for Yesod Web Framework. category: Web, Yesod stability: Stable -cabal-version: >= 1.8 +cabal-version: >= 1.10 build-type: Simple homepage: http://www.yesodweb.com/ -description: Static file serving subsite for Yesod Web Framework. +description: API docs and the README are available at extra-source-files: - test/YesodStaticTest.hs - test/tests.hs + sample.hs + sample-embed.hs + test/*.hs test/fs/bar/baz test/fs/tmp/ignored test/fs/.ignored test/fs/foo + test/embed-dir/foo + test/embed-dir/lorem.txt + test/embed-dir/abc/def.txt + ChangeLog.md + README.md library - build-depends: base >= 4 && < 5 - , containers >= 0.2 - , old-time >= 1.0 - , yesod-core >= 1.1 && < 1.2 + default-language: Haskell2010 + build-depends: base >= 4.11 && < 5 + , async + , attoparsec >= 0.10 , base64-bytestring >= 0.1.0.1 - , cereal >= 0.3 + , blaze-builder >= 0.3 , bytestring >= 0.9.1.4 - , template-haskell + , conduit >= 1.3 + , containers >= 0.2 + , crypton >= 1.0 + , crypton-conduit >= 0.2.3 + , css-text >= 0.1.2 + , data-default , directory >= 1.0 - , transformers >= 0.2.2 - , wai-app-static >= 1.3 && < 1.4 - , wai >= 1.3 && < 1.5 - , text >= 0.9 , file-embed >= 0.0.4.1 && < 0.5 + , filepath >= 1.3 + , hashable >= 1.1 + , hjsmin , http-types >= 0.7 + , memory + , mime-types >= 0.1 + , process + , template-haskell + , text >= 0.9 + , transformers >= 0.2.2 , unix-compat >= 0.2 - , conduit >= 0.5 - , crypto-conduit >= 0.4 - , cryptohash >= 0.6.1 - , system-filepath >= 0.4.6 && < 0.5 + , unordered-containers >= 0.2 + , wai >= 1.3 + , wai-app-static >= 3.1 + , yesod-core >= 1.6 && < 1.8 + exposed-modules: Yesod.Static + Yesod.EmbeddedStatic + Yesod.EmbeddedStatic.Generators + Yesod.EmbeddedStatic.Types + Yesod.EmbeddedStatic.Css.AbsoluteUrl + + other-modules: Yesod.EmbeddedStatic.Internal + Yesod.EmbeddedStatic.Css.Util + ghc-options: -Wall + other-extensions: TemplateHaskell test-suite tests + default-language: Haskell2010 hs-source-dirs: ., test main-is: tests.hs type: exitcode-stdio-1.0 cpp-options: -DTEST_EXPORT - build-depends: base + other-modules: EmbedDevelTest + EmbedProductionTest + EmbedTestGenerator + FileGeneratorTests + GeneratorTestUtil + Yesod.EmbeddedStatic + Yesod.EmbeddedStatic.Generators + Yesod.EmbeddedStatic.Internal + Yesod.EmbeddedStatic.Types + Yesod.Static + YesodStaticTest + build-depends: base < 5 , hspec >= 1.3 + , yesod-test >= 1.6 + , wai-extra + , HUnit + -- copy from above - , containers - , old-time - , yesod-core + , async , base64-bytestring - , cereal , bytestring - , template-haskell + , conduit + , containers + , crypton + , crypton-conduit + , data-default , directory - , transformers - , wai-app-static - , wai - , text , file-embed + , filepath + , hjsmin , http-types + , memory + , mime-types + , process + , template-haskell + , text + , transformers , unix-compat - , conduit - , crypto-conduit - , cryptohash - , system-filepath + , unordered-containers + , wai + , wai-app-static + , yesod-core + , rio - ghc-options: -Wall + ghc-options: -Wall -threaded + other-extensions: TemplateHaskell source-repository head type: git