diff --git a/Yesod/EmbeddedStatic.hs b/Yesod/EmbeddedStatic.hs new file mode 100644 --- /dev/null +++ b/Yesod/EmbeddedStatic.hs @@ -0,0 +1,183 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +-- | A subsite which serves static content which is embedded at compile time. +-- +-- At compile time, you supply a list of files, directories, processing functions (like javascript +-- minification), and even custom content generators. You can also specify the specific relative +-- locations within the static subsite where these resources should appear. The 'mkEmbeddedStatic' +-- function then computes the resources and embeds them directly into the executable at +-- compile time, so that the original files do not need to be distributed along with +-- the executable. The content is also compressed and hashed at compile time, so that +-- during runtime the compressed content can be sent directly on the wire with the appropriate +-- HTTP header. The precomputed hash is used for an ETag so the client does not redownload +-- the content multiple times. There is also a development mode which does not embed the +-- contents but recomputes it on every request. A simple example using an embedded static +-- subsite is +-- . +-- +-- To add this to a scaffolded project, replace the code in @Settings/StaticFiles.hs@ +-- with a call to 'mkEmbeddedStatic' with the list of all your generators, use the type +-- 'EmbeddedStatic' in your site datatype for @getStatic@, update the route for @/static@ to +-- use the type 'EmbeddedStatic', use 'embedStaticContent' for 'addStaticContent' in +-- @Foundation.hs@, use the routes generated by 'mkEmbeddedStatic' and exported by +-- @Settings/StaticFiles.hs@ to link to your static content, and finally update +-- @Application.hs@ use the variable binding created by 'mkEmbeddedStatic' which +-- contains the created 'EmbeddedStatic'. +-- +-- It is recommended that you serve static resources from a separate domain to save time +-- on transmitting cookies. You can use 'urlRenderOverride' 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 Control.Applicative ((<$>)) +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 + ( HandlerT + , Yesod(..) + , 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 Yesod master => YesodSubDispatch EmbeddedStatic (HandlerT master IO) 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 + _ -> return $ 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 :: Yesod site + => (site -> EmbeddedStatic) -- ^ How to retrieve the embedded static subsite from your site + -> (Route EmbeddedStatic -> Route site) -- ^ how to convert an embedded static route + -> (BL.ByteString -> Either a BL.ByteString) -- ^ javascript minifier + -> AddStaticContent site +embedStaticContent = staticContentHelper diff --git a/Yesod/EmbeddedStatic/Generators.hs b/Yesod/EmbeddedStatic/Generators.hs new file mode 100644 --- /dev/null +++ b/Yesod/EmbeddedStatic/Generators.hs @@ -0,0 +1,317 @@ +{-# LANGUAGE TemplateHaskell, QuasiQuotes, ScopedTypeVariables #-} +-- | 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.Applicative ((<$>)) +import Control.Exception (try, SomeException) +import Control.Monad (forM, when) +import Control.Monad.Trans.Resource (runResourceT) +import Data.Char (isDigit, isLower) +import Data.Conduit (($$), (=$)) +import Data.Conduit.Process (proc, conduitProcess) +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.Lazy as BL +import qualified Data.Conduit.List as C +import qualified Data.Text as T + +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 = BL.readFile f + , ebDevelReload = [| BL.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 <- getDirectoryContents topdir + let properNames = filter (`notElem` [".", ".."]) names + paths <- forM properNames $ \name -> do + let path = topdir name + let loc = if null prefix then name else prefix ++ "/" ++ name + isDirectory <- doesDirectoryExist path + if isDirectory + then getRecursiveContents loc path + else return [(loc, path)] + return (concat paths) + +-- | Embed all files in a directory into the static subsite. +-- +-- Equivalent to passing the empty string as the location to 'embedDirAt', +-- so the directory path itself is not part of the resource locations (and so +-- also not part of the generated route variable names). +embedDir :: FilePath -> Generator +embedDir = embedDirAt "" + +-- | Embed all files in a directory to a given location within the static subsite. +-- +-- The directory tree rooted at the 'FilePath' (which must be relative to the directory in +-- which you run @cabal build@) is embedded into the static subsite at the given +-- location. Also, route variables will be created based on the final location +-- of each file. For example, if a directory \"static\" contains the files +-- +-- * css/bootstrap.css +-- +-- * js/jquery.js +-- +-- * js/bootstrap.js +-- +-- then @embedDirAt \"somefolder\" \"static\"@ will +-- +-- * Make the file @static\/css\/bootstrap.css@ available at the location +-- @somefolder\/css\/bootstrap.css@ within the static subsite and similarly +-- for the other two files. +-- +-- * Create variables @somefolder_css_bootstrap_css@, @somefolder_js_jquery_js@, +-- @somefolder_js_bootstrap_js@ all of type @Route EmbeddedStatic@. +-- +-- * During development, the files will be reloaded on every request. During +-- production, the contents of all files will be embedded into the executable. +-- +-- * During development, files that are added to the directory while the server +-- is running will not be detected. You need to recompile the module which +-- contains the call to @mkEmbeddedStatic@. This will also generate new route +-- variables for the new files. +embedDirAt :: Location -> FilePath -> Generator +embedDirAt loc dir = do + files <- runIO $ getRecursiveContents loc dir + concat <$> mapM (uncurry embedFileAt) files + +-- | Concatinate a list of files and embed it at the location. Equivalent to passing @return@ to +-- 'concatFilesWith'. +concatFiles :: Location -> [FilePath] -> Generator +concatFiles loc files = concatFilesWith loc return files + +-- | Concatinate a list of files into a single 'BL.ByteString', run the resulting content through the given +-- function, embed it at the given location, and create a haskell variable name for the route based on +-- the location. +-- +-- The processing function is only run when compiling for production, and the processing function is +-- executed at compile time. During development, on every request the files listed are reloaded, +-- concatenated, and served as a single resource at the given location without being processed. +concatFilesWith :: Location -> (BL.ByteString -> IO BL.ByteString) -> [FilePath] -> Generator +concatFilesWith loc process files = do + let load = do putStrLn $ "Creating " ++ loc + BL.concat <$> mapM BL.readFile files >>= process + expFiles = listE $ map (litE . stringL) files + expCt = [| BL.concat <$> mapM BL.readFile $expFiles |] + mime = defaultMimeLookup $ T.pack loc + return [def { ebHaskellName = Just $ pathToName loc + , ebLocation = loc + , ebMimeType = mime + , ebProductionContent = load + , ebDevelReload = expCt + }] + +-- | Convienient rexport of 'minifym' with a type signature to work with 'concatFilesWith'. +jasmine :: BL.ByteString -> IO BL.ByteString +jasmine ct = return $ either (const ct) id $ minifym ct + +-- | Use to compress javascript. +-- Assumes @uglifyjs@ is located in the path and uses options @[\"-m\", \"-c\"]@ +-- to both mangle and compress and the option \"-\" to cause uglifyjs to read from +-- standard input. +uglifyJs :: BL.ByteString -> IO BL.ByteString +uglifyJs = compressTool "uglifyjs" ["-m", "-c", "-"] + +-- | Use to compress javascript. +-- Assumes a script @yuicompressor@ is located in the path. If not, you can still +-- use something like +-- +-- > compressTool "java" ["-jar", "/path/to/yuicompressor.jar", "--type", "js"] +yuiJavascript :: BL.ByteString -> IO BL.ByteString +yuiJavascript = compressTool "yuicompressor" ["--type", "js"] + +-- | Use to compress CSS. +-- Assumes a script @yuicompressor@ is located in the path. +yuiCSS :: BL.ByteString -> IO BL.ByteString +yuiCSS = compressTool "yuicompressor" ["--type", "css"] + +-- | Use to compress +-- javascript using the default options. Assumes a script @closure@ is located in +-- the path. If not, you can still run using +-- +-- > compressTool "java" ["-jar", "/path/to/compiler.jar"] +closureJs :: BL.ByteString -> IO BL.ByteString +closureJs = compressTool "closure" [] + +-- | Helper to convert a process into a compression function. The process +-- should be set up to take input from standard input and write to standard output. +compressTool :: FilePath -- ^ program + -> [String] -- ^ options + -> BL.ByteString -> IO BL.ByteString +compressTool f opts ct = do + mpath <- findExecutable f + when (isNothing mpath) $ + fail $ "Unable to find " ++ f + let src = C.sourceList $ BL.toChunks ct + p = proc f opts + sink = C.consume + compressed <- runResourceT (src $$ conduitProcess p =$ sink) + putStrLn $ "Compressed successfully with " ++ f + return $ BL.fromChunks compressed + + +-- | 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 () of + () + | null name -> error "null-named file" + | isDigit (head name) -> '_' : name + | isLower (head name) -> name + | otherwise -> '_' : name + + +-- $example +-- Here is an example of creating your own custom generator. +-- Because of template haskell stage restrictions, you must define generators in a +-- different module from where you use them. The following generator will embed a +-- JSON document that contains the compile time. +-- +-- >{-# LANGUAGE TemplateHaskell, QuasiQuotes, OverloadedStrings #-} +-- >module CompileTime where +-- > +-- >import Data.Aeson +-- >import Data.Default +-- >import Data.Time +-- >import Yesod.EmbeddedStatic.Generators +-- >import Yesod.EmbeddedStatic.Types +-- >import qualified Data.ByteString.Lazy as BL +-- > +-- >getTime :: IO BL.ByteString +-- >getTime = do +-- > t <- getCurrentTime +-- > return $ encode $ +-- > object [ "compile_time" .= show t ] +-- > +-- >timeGenerator :: Location -> Generator +-- >timeGenerator loc = +-- > return $ [def +-- > { ebHaskellName = Just $ pathToName loc +-- > , ebLocation = loc +-- > , ebMimeType = "application/json" +-- > , ebProductionContent = getTime +-- > , ebDevelReload = [| getTime |] +-- > }] +-- +-- Notice how the @getTime@ action is given as both 'ebProductionContent' and +-- 'ebDevelReload'. The result is that during development, the @getTime@ action +-- will be re-executed on every request so the time returned will be different +-- for each reload. When compiling for production, the @getTime@ action will +-- be executed once at compile time to produce the content to embed and never +-- called at runtime. +-- +-- Here is a small example yesod program using this generator. Try toggling +-- the development argument to @mkEmbeddedStatic@. +-- +-- >{-# LANGUAGE TemplateHaskell, QuasiQuotes, TypeFamilies #-} +-- >module Main where +-- > +-- >import Yesod +-- >import Yesod.EmbeddedStatic +-- >import CompileTime (timeGenerator) +-- > +-- >mkEmbeddedStatic True "eStatic" [timeGenerator "compile-time.json"] +-- > +-- >-- The above will generate variables +-- >-- eStatic :: EmbeddedStatic +-- >-- compile_time_json :: Route EmbeddedStatic +-- > +-- >data MyApp = MyApp { getStatic :: EmbeddedStatic } +-- > +-- >mkYesod "MyApp" [parseRoutes| +-- >/ HomeR GET +-- >/static StaticR EmbeddedStatic getStatic +-- >|] +-- > +-- >instance Yesod MyApp +-- > +-- >getHomeR :: Handler Html +-- >getHomeR = defaultLayout $ [whamlet| +-- >

Hello +-- >

Check the +-- > compile time +-- >|] +-- > +-- >main :: IO () +-- >main = warp 3000 $ MyApp eStatic diff --git a/Yesod/EmbeddedStatic/Internal.hs b/Yesod/EmbeddedStatic/Internal.hs new file mode 100644 --- /dev/null +++ b/Yesod/EmbeddedStatic/Internal.hs @@ -0,0 +1,169 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE CPP #-} +module Yesod.EmbeddedStatic.Internal ( + EmbeddedStatic(..) + , Route(..) + , ComputedEntry(..) + , devEmbed + , prodEmbed + , develApp + , AddStaticContent + , staticContentHelper + , widgetSettings +) where + +import Control.Applicative ((<$>)) +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 + ( HandlerT + , ParseRoute(..) + , RenderRoute(..) + , Yesod(..) + , 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 + +#if !MIN_VERSION_base(4,6,0) +-- copied from base +atomicModifyIORef' :: IORef a -> (a -> (a,b)) -> IO b +atomicModifyIORef' ref f = do + b <- atomicModifyIORef ref + (\x -> let (a, b) = f x + in (a, a `seq` b)) + b `seq` return b +#endif + +-- | 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 + +tryExtraDevelFiles :: [[T.Text] -> IO (Maybe (MimeType, BL.ByteString))] -> Application +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 = do + resp <- staticApp settings {ssMaxAge = NoMaxAge} req + if statusCode (responseStatus resp) == 404 + then tryExtraDevelFiles extra req + else return resp + +-- | The type of 'addStaticContent' +type AddStaticContent site = T.Text -> T.Text -> BL.ByteString + -> HandlerT site IO (Maybe (Either T.Text (Route site, [(T.Text, T.Text)]))) + +-- | Helper for embedStaticContent and embedLicensedStaticContent. +staticContentHelper :: Yesod site + => (site -> EmbeddedStatic) + -> (Route EmbeddedStatic -> Route site) + -> (BL.ByteString -> Either a BL.ByteString) + -> AddStaticContent site +staticContentHelper getStatic staticR minify ext _ ct = do + wIORef <- widgetFiles . getStatic <$> getYesod + let hash = T.pack $ base64md5 ct + hash' = Just $ T.encodeUtf8 hash + filename = T.concat [hash, ".", ext] + content = case ext of + "js" -> either (const ct) id $ minify ct + _ -> ct + file = File + { fileGetSize = fromIntegral $ BL.length content + , fileToResponse = \s h -> responseLBS s h content + , fileName = unsafeToPiece filename + , fileGetHash = return hash' + , fileGetModified = Nothing + } + liftIO $ atomicModifyIORef' wIORef $ \m -> + (M.insertWith (\old _ -> old) filename file m, ()) + + return $ Just $ Right (staticR $ EmbeddedWidgetR filename, []) + +-- | Create a wai-app-static settings based on the IORef inside the EmbeddedStaic site. +widgetSettings :: EmbeddedStatic -> StaticSettings +widgetSettings es = (defaultWebAppSettings "") { ssLookupFile = lookupFile } + where + lookupFile [_,p] = do -- The first part of the path is "widget" + m <- readIORef $ widgetFiles es + return $ maybe LRNotFound LRFile $ M.lookup (fromPiece p) m + lookupFile _ = return LRNotFound diff --git a/Yesod/EmbeddedStatic/Types.hs b/Yesod/EmbeddedStatic/Types.hs new file mode 100644 --- /dev/null +++ b/Yesod/EmbeddedStatic/Types.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE TemplateHaskell, QuasiQuotes, OverloadedStrings #-} +module Yesod.EmbeddedStatic.Types( + Location + , Generator + -- ** Entry + , Entry + , ebHaskellName + , ebLocation + , ebMimeType + , ebProductionContent + , ebDevelReload + , ebDevelExtraFiles +) where + +import Data.Default +import Language.Haskell.TH +import Network.Mime (MimeType) +import qualified Data.ByteString.Lazy as BL + +-- | A location is a relative path within the static subsite at which resource(s) are made available. +-- The location can include slashes to simulate directories but must not start or end with a slash. +type Location = String + +-- | A single resource embedded into the executable at compile time. +-- +-- This data type is a settings type. For more information, see +-- . +data Entry = Entry { + ebHaskellName :: Maybe Name + -- ^ An optional haskell name. If the name is present, a variable + -- of type @Route 'Yesod.EmbeddedStatic.EmbeddedStatic'@ with the + -- given name will be created which points to this resource. + , ebLocation :: Location -- ^ The location to serve the resource from. + , ebMimeType :: MimeType -- ^ The mime type of the resource. + , ebProductionContent :: IO BL.ByteString + -- ^ If the development argument to 'Yesod.EmbeddedStatic.mkEmbeddedStatic' is False, + -- then at compile time this action will be executed to load the content. + -- During development, this action will not be executed. + , ebDevelReload :: ExpQ + -- ^ This must be a template haskell expression of type @IO 'BL.ByteString'@. + -- If the development argument to 'Yesod.EmbeddedStatic.mkEmbeddedStatic' is True, + -- this action is executed on every request to compute the content. Most of the + -- time, 'ebProductionContent' and 'ebDevelReload' should be the same action but + -- occasionally you might want additional processing inside the 'ebProductionContent' + -- function like javascript/css minification to only happen when building for production. + , ebDevelExtraFiles :: Maybe ExpQ + -- ^ Occasionally, during development an entry needs extra files/resources available + -- that are not present during production (for example, image files that are embedded + -- into the CSS at production but left unembedded during development). If present, + -- @ebDevelExtraFiles@ must be a template haskell expression of type + -- @['T.Text'] -> IO (Maybe ('MimeType', 'BL.ByteString'))@. That is, a function + -- taking as input the list of path pieces and optionally returning a mime type + -- and content. +} + +-- | When using 'def', you must fill in at least 'ebLocation'. +instance Default Entry where + def = Entry { ebHaskellName = Nothing + , ebLocation = "xxxx" + , ebMimeType = "application/octet-stream" + , ebProductionContent = return BL.empty + , ebDevelReload = [| return BL.empty |] + , ebDevelExtraFiles = Nothing + } + +-- | An embedded generator is executed at compile time to produce the entries to embed. +type Generator = Q [Entry] diff --git a/Yesod/Static.hs b/Yesod/Static.hs --- a/Yesod/Static.hs +++ b/Yesod/Static.hs @@ -35,7 +35,6 @@ -- * Smart constructor , static , staticDevel - , embed -- * Combining CSS/JS -- $combining , combineStylesheets' @@ -54,6 +53,8 @@ , publicFiles -- * Hashing , base64md5 + -- * Embed + , embed #ifdef TEST_EXPORT , getFileListPieces #endif @@ -134,8 +135,11 @@ hashLookup <- cachedETagLookupDevel dir return $ Static $ webAppSettingsWithLookup (F.decodeString 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 diff --git a/sample-embed.hs b/sample-embed.hs new file mode 100644 --- /dev/null +++ b/sample-embed.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE TemplateHaskell, QuasiQuotes, TypeFamilies #-} +-- | This embeds just a single file; it embeds the source code file +-- \"sample-embed.hs\" from the current directory so when you compile, +-- the sample-embed.hs file must be in the current directory. +-- +-- Try toggling the development argument to 'mkEmbeddedStatic'. When the +-- development argument is true the file \"sample-embed.hs\" is reloaded +-- from disk on every request (try changing it after you start the server). +-- When development is false, the contents are embedded and the sample-embed.hs +-- file does not even need to be present during runtime. +module Main where + +import Yesod.Core +import Yesod.EmbeddedStatic + +mkEmbeddedStatic False "eStatic" [embedFile "sample-embed.hs"] + +-- The above will generate variables +-- eStatic :: EmbeddedStatic +-- sample_embed_hs :: Route EmbeddedStatic + +data MyApp = MyApp { getStatic :: EmbeddedStatic } + +mkYesod "MyApp" [parseRoutes| +/ HomeR GET +/static StaticR EmbeddedStatic getStatic +|] + +instance Yesod MyApp where + addStaticContent = embedStaticContent getStatic StaticR Right + +getHomeR :: Handler Html +getHomeR = defaultLayout $ do + toWidget [julius|console.log("Hello World");|] + [whamlet| +

Hello +

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

Hello|] + +instance Yesod MyApp where + addStaticContent = embedStaticContent getStatic StaticR Right + +findEtag :: YesodExample site B.ByteString +findEtag = withResponse $ \r -> + case lookup "ETag" (simpleHeaders r) of + Nothing -> liftIO (assertFailure "No etag found") >> error "" + Just e -> return e + +hasCacheControl :: YesodExample site () +hasCacheControl = withResponse $ \r -> do + liftIO $ assertBool "Cache-Control missing" $ + isJust $ lookup "Cache-Control" $ simpleHeaders r + liftIO $ assertBool "Expires missing" $ + isJust $ lookup "Expires" $ simpleHeaders r + +embedProductionSpecs :: Spec +embedProductionSpecs = yesodSpec (MyApp eProduction) $ do + ydescribe "Embedded Production Entries" $ do + yit "e1 loads" $ do + get $ StaticR e1 + statusIs 200 + assertHeader "Content-Type" "text/plain" + hasCacheControl + bodyEquals "e1 production" + + tag <- findEtag + request $ do + setMethod "GET" + setUrl $ StaticR e1 + addRequestHeader ("If-None-Match", tag) + statusIs 304 + + yit "e1 with custom built path" $ do + get $ StaticR $ embeddedResourceR ["e1"] [] + statusIs 200 + assertHeader "Content-Type" "text/plain" + hasCacheControl + bodyEquals "e1 production" + + yit "e2 with simulated directory" $ do + get $ StaticR e2 + statusIs 200 + assertHeader "Content-Type" "abcdef" + hasCacheControl + bodyEquals "e2 production" + + yit "e2 with custom built directory path" $ do + get $ StaticR $ embeddedResourceR ["dir", "e2"] [] + statusIs 200 + assertHeader "Content-Type" "abcdef" + hasCacheControl + bodyEquals "e2 production" + + yit "e3 without haskell name" $ do + get $ StaticR $ embeddedResourceR ["xxxx", "e3"] [] + statusIs 200 + assertHeader "Content-Type" "yyy" + hasCacheControl + bodyEquals "e3 production" + + yit "e4 is embedded" $ do + get $ StaticR e4 + statusIs 200 + assertHeader "Content-Type" "text/plain" + hasCacheControl + bodyEquals "e4 production" + + yit "e4 extra development files are not embedded" $ do + get $ StaticR $ embeddedResourceR ["dev1"] [] + statusIs 404 + + ydescribe "Embedded Widget Content" $ + yit "Embedded Javascript" $ do + get HomeR + statusIs 200 + [script] <- htmlQuery "script" + let src = BL.takeWhile (/= 34) $ BL.drop 1 $ BL.dropWhile (/= 34) script -- 34 is " + + get $ TL.toStrict $ TL.decodeUtf8 src + statusIs 200 + hasCacheControl + assertHeader "Content-Type" "application/javascript" + bodyEquals "console.log(\"Hello World\");" diff --git a/test/EmbedTestGenerator.hs b/test/EmbedTestGenerator.hs new file mode 100644 --- /dev/null +++ b/test/EmbedTestGenerator.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE TemplateHaskell, QuasiQuotes, OverloadedStrings #-} +module EmbedTestGenerator (testGen) where + +import Data.Default +import Network.Mime (MimeType) +import Yesod.EmbeddedStatic.Types +import Yesod.EmbeddedStatic.Generators (pathToName) + +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Encoding as TL +import qualified Data.ByteString.Lazy as BL + +e1, e2, e3, e4 :: Entry + +-- Basic entry +e1 = def + { ebHaskellName = Just $ pathToName "e1" + , ebLocation = "e1" + , ebMimeType = "text/plain" + , ebProductionContent = return $ TL.encodeUtf8 "e1 production" + , ebDevelReload = [| return $ TL.encodeUtf8 $ TL.pack "e1 devel" |] + , ebDevelExtraFiles = Nothing + } + +-- Test simulated directory in location +e2 = def + { ebHaskellName = Just $ pathToName "e2" + , ebLocation = "dir/e2" + , ebMimeType = "abcdef" + , ebProductionContent = return $ TL.encodeUtf8 "e2 production" + , ebDevelReload = [| return $ TL.encodeUtf8 $ TL.pack "e2 devel" |] + , ebDevelExtraFiles = Nothing + } + +-- Test empty haskell name +e3 = def + { ebHaskellName = Nothing + , ebLocation = "xxxx/e3" + , ebMimeType = "yyy" + , ebProductionContent = return $ TL.encodeUtf8 "e3 production" + , ebDevelReload = [| return $ TL.encodeUtf8 $ TL.pack "e3 devel" |] + , ebDevelExtraFiles = Nothing + } + +devExtra :: [T.Text] -> IO (Maybe (MimeType, BL.ByteString)) +devExtra ["dev1"] = return $ Just ("mime", "dev1 content") +devExtra ["dir", "dev2"] = return $ Just ("mime2", "dev2 content") +devExtra _ = return Nothing + +-- Entry with devel extra files +e4 = def + { ebHaskellName = Just $ pathToName "e4" + , ebLocation = "e4" + , ebMimeType = "text/plain" + , ebProductionContent = return $ TL.encodeUtf8 "e4 production" + , ebDevelReload = [| return $ TL.encodeUtf8 $ TL.pack "e4 devel" |] + , ebDevelExtraFiles = Just [| devExtra |] + } + +testGen :: Generator +testGen = return [e1, e2, e3, e4] diff --git a/test/FileGeneratorTests.hs b/test/FileGeneratorTests.hs new file mode 100644 --- /dev/null +++ b/test/FileGeneratorTests.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE TemplateHaskell, QuasiQuotes, OverloadedStrings #-} +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\"" + assertEqual "" "Hello World\n" out + + it "tryCompressTools" $ do + out <- flip tryCompressTools "abcdef" + [ const $ throwIO $ ErrorCall "An expected error" + , const $ return "foo" + , const $ return "bar" + ] + assertEqual "" "foo" out + out2 <- flip tryCompressTools "abcdef" + [ const $ throwIO $ ErrorCall "An expected error"] + assertEqual "" "abcdef" out2 diff --git a/test/GeneratorTestUtil.hs b/test/GeneratorTestUtil.hs new file mode 100644 --- /dev/null +++ b/test/GeneratorTestUtil.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE TemplateHaskell, QuasiQuotes, OverloadedStrings #-} +module GeneratorTestUtil where + +import Control.Applicative +import Control.Monad (when) +import Data.List (sortBy) +import Language.Haskell.TH +import Test.HUnit +import Yesod.EmbeddedStatic.Types +import qualified Data.ByteString.Lazy as BL + +-- 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 -> 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 <- runIO act + actual <- runIO $ ebProductionContent e + if expected == actual + then [| GenSuccessWithDevel $(ebDevelReload e) |] + else [| GenError "production content" |] + +testOneEntry :: Maybe String -> 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, 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 :: (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 <- mexpected + actual <- mactual + when (expected /= actual) $ + assertFailure "invalid devel content" diff --git a/test/embed-dir/abc/def.txt b/test/embed-dir/abc/def.txt new file mode 100644 --- /dev/null +++ b/test/embed-dir/abc/def.txt @@ -0,0 +1,1 @@ +Yesod Rocks diff --git a/test/embed-dir/foo b/test/embed-dir/foo new file mode 100644 --- /dev/null +++ b/test/embed-dir/foo @@ -0,0 +1,1 @@ +Bar diff --git a/test/embed-dir/lorem.txt b/test/embed-dir/lorem.txt new file mode 100644 --- /dev/null +++ b/test/embed-dir/lorem.txt @@ -0,0 +1,6 @@ +Lorem ipsum dolor sit amet, consectetur adipisicing elit, sed do eiusmod tempor +incididunt ut labore et dolore magna aliqua. Ut enim ad minim veniam, quis +nostrud exercitation ullamco laboris nisi ut aliquip ex ea commodo consequat. +Duis aute irure dolor in reprehenderit in voluptate velit esse cillum dolore eu +fugiat nulla pariatur. Excepteur sint occaecat cupidatat non proident, sunt in +culpa qui officia deserunt mollit anim id est laborum. diff --git a/test/tests.hs b/test/tests.hs --- a/test/tests.hs +++ b/test/tests.hs @@ -2,6 +2,13 @@ import Test.Hspec import YesodStaticTest (specs) +import EmbedProductionTest (embedProductionSpecs) +import EmbedDevelTest (embedDevSpecs) +import FileGeneratorTests (fileGenSpecs) main :: IO () -main = hspec specs +main = hspec $ do + specs + embedProductionSpecs + embedDevSpecs + fileGenSpecs diff --git a/yesod-static.cabal b/yesod-static.cabal --- a/yesod-static.cabal +++ b/yesod-static.cabal @@ -1,5 +1,5 @@ name: yesod-static -version: 1.2.0.1 +version: 1.2.1 license: MIT license-file: LICENSE author: Michael Snoyman @@ -12,12 +12,16 @@ homepage: http://www.yesodweb.com/ description: Static file serving subsite for Yesod Web Framework. 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 library build-depends: base >= 4 && < 5 @@ -30,7 +34,7 @@ , template-haskell , directory >= 1.0 , transformers >= 0.2.2 - , wai-app-static >= 1.3 && < 1.4 + , wai-app-static >= 1.3.2 && < 1.4 , wai >= 1.3 && < 1.5 , text >= 0.9 , file-embed >= 0.0.4.1 && < 0.5 @@ -43,8 +47,22 @@ , system-fileio >= 0.3 , data-default , shakespeare-css >= 1.0.3 + , mime-types >= 0.1 + , hjsmin + , process-conduit >= 1.0 && < 1.1 + , filepath >= 1.3 + , resourcet >= 0.4 + , unordered-containers >= 0.2 + exposed-modules: Yesod.Static + Yesod.EmbeddedStatic + Yesod.EmbeddedStatic.Generators + Yesod.EmbeddedStatic.Types + + other-modules: Yesod.EmbeddedStatic.Internal + ghc-options: -Wall + extensions: TemplateHaskell test-suite tests hs-source-dirs: ., test @@ -53,6 +71,10 @@ cpp-options: -DTEST_EXPORT build-depends: base , hspec >= 1.3 + , yesod-test >= 1.2 + , wai-test + , HUnit + -- copy from above , containers , old-time @@ -76,8 +98,15 @@ , system-fileio , data-default , shakespeare-css + , mime-types + , hjsmin + , process-conduit + , filepath + , resourcet + , unordered-containers ghc-options: -Wall + extensions: TemplateHaskell source-repository head type: git