yesod-static 1.1.2.3 → 1.6.1.3

raw patch · 21 files changed

Files

• ChangeLog.md +69/−0
• README.md +3/−0
• Yesod/EmbeddedStatic.hs +178/−0
• Yesod/EmbeddedStatic/Css/AbsoluteUrl.hs +80/−0
• Yesod/EmbeddedStatic/Css/Util.hs +198/−0
• Yesod/EmbeddedStatic/Generators.hs +330/−0
• Yesod/EmbeddedStatic/Internal.hs +162/−0
• Yesod/EmbeddedStatic/Types.hs +70/−0
• Yesod/Static.hs +332/−136
• sample-embed.hs +45/−0
• sample.hs +28/−0
• test/EmbedDevelTest.hs +99/−0
• test/EmbedProductionTest.hs +130/−0
• test/EmbedTestGenerator.hs +65/−0
• test/FileGeneratorTests.hs +96/−0
• test/GeneratorTestUtil.hs +67/−0
• test/embed-dir/abc/def.txt +1/−0
• test/embed-dir/foo +1/−0
• test/embed-dir/lorem.txt +6/−0
• test/tests.hs +8/−1
• yesod-static.cabal +83/−34

@@ -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.

@@ -0,0 +1,3 @@+## yesod-static++Static file serving subsite for Yesod Web Framework.

@@ -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+-- <https://github.com/yesodweb/yesod/blob/master/yesod-static/sample-embed.hs static-embed.hs>.+--+-- 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

@@ -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

@@ -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

@@ -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 <https://github.com/mishoo/UglifyJS2 UglifyJS2> 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 <http://yui.github.io/yuicompressor/ YUI Compressor> 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 <http://yui.github.io/yuicompressor/ YUI Compressor> to compress CSS.+-- Assumes a script @yuicompressor@ is located in the path.+yuiCSS :: BL.ByteString -> IO BL.ByteString+yuiCSS = compressTool "yuicompressor" ["--type", "css"]++-- | Use <https://developers.google.com/closure/compiler/ Closure> 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|+-- ><h1>Hello+-- ><p>Check the+-- >    <a href=@{StaticR compile_time_json}>compile time+-- >|]+-- >+-- >main :: IO ()+-- >main = warp 3000 $ MyApp eStatic

@@ -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

@@ -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+-- <http://www.yesodweb.com/book/settings-types>.+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]

@@ -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:+--+-- <http://www.yesodweb.com/book/settings-types>+--+-- 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) |]

@@ -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|+<h1>Hello+<p>Check the+    <a href=@{StaticR sample_embed_hs}>embedded file+|]++main :: IO ()+main = warp 3000 $ MyApp eStatic

@@ -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

@@ -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

@@ -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|<h1>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\");"

@@ -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]

@@ -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

@@ -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)

@@ -0,0 +1,1 @@+Yesod Rocks

@@ -0,0 +1,1 @@+Bar

@@ -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.

@@ -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

@@ -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 <michael@snoyman.com>@@ -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 <http://www.stackage.org/package/yesod-static> 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