static: Add an embedded static subsite
This commit adds just the subsite itself. The subsite works by running a list of generaters at compile time. The entries produced by the generators are converted into wai-app-static.WaiAppStatic.Storage.Embedded entries. Also, addStaticContent is supported via an IORef. When a widget produces static content (css, javascript), it is stuck into the IORef inside the embedded static subsite. The embedded static subsite will then serve it from the IORef, properly using a 304 response if the client already has the content.
This commit is contained in:
John Lenz
parent
c876974656
commit
f8a35ce0a0
183
yesod-static/Yesod/EmbeddedStatic.hs
Normal file
183
yesod-static/Yesod/EmbeddedStatic.hs
Normal file
@ -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
|
||||
-- <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 '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.Map 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
|
||||
116
yesod-static/Yesod/EmbeddedStatic/Generators.hs
Normal file
116
yesod-static/Yesod/EmbeddedStatic/Generators.hs
Normal file
@ -0,0 +1,116 @@
|
||||
{-# 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
|
||||
|
||||
-- * Util
|
||||
, pathToName
|
||||
|
||||
-- * Custom Generators
|
||||
|
||||
-- $example
|
||||
) where
|
||||
|
||||
import Data.Char (isDigit, isLower)
|
||||
import Language.Haskell.TH
|
||||
|
||||
import Yesod.EmbeddedStatic.Types
|
||||
|
||||
-- | 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.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 $ [Entry
|
||||
-- > { ebHaskellName = Just $ pathToName loc
|
||||
-- > , ebLocation = loc
|
||||
-- > , ebMimeType = "application/json"
|
||||
-- > , ebProductionContent = getTime
|
||||
-- > , ebDevelReload = [| getTime |]
|
||||
-- > , ebDevelExtraFiles = Nothing
|
||||
-- > }]
|
||||
--
|
||||
-- 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
|
||||
158
yesod-static/Yesod/EmbeddedStatic/Internal.hs
Normal file
158
yesod-static/Yesod/EmbeddedStatic/Internal.hs
Normal file
@ -0,0 +1,158 @@
|
||||
{-# 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 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.Map 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.Map 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
|
||||
45
yesod-static/Yesod/EmbeddedStatic/Types.hs
Normal file
45
yesod-static/Yesod/EmbeddedStatic/Types.hs
Normal file
@ -0,0 +1,45 @@
|
||||
module Yesod.EmbeddedStatic.Types(
|
||||
Location
|
||||
, Entry(..)
|
||||
, Generator
|
||||
) where
|
||||
|
||||
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.
|
||||
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.
|
||||
}
|
||||
|
||||
-- | An embedded generator is executed at compile time to produce the entries to embed.
|
||||
type Generator = Q [Entry]
|
||||
95
yesod-static/test/EmbedDevelTest.hs
Normal file
95
yesod-static/test/EmbedDevelTest.hs
Normal file
@ -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
|
||||
117
yesod-static/test/EmbedProductionTest.hs
Normal file
117
yesod-static/test/EmbedProductionTest.hs
Normal file
@ -0,0 +1,117 @@
|
||||
{-# 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.Encoding as T
|
||||
|
||||
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"
|
||||
let src = BL.takeWhile (/= 34) $ BL.drop 1 $ BL.dropWhile (/= 34) script -- 34 is "
|
||||
|
||||
get $ T.decodeUtf8 $ BL.toStrict src
|
||||
statusIs 200
|
||||
hasCacheControl
|
||||
assertHeader "Content-Type" "application/javascript"
|
||||
bodyEquals "console.log(\"Hello World\");"
|
||||
61
yesod-static/test/EmbedTestGenerator.hs
Normal file
61
yesod-static/test/EmbedTestGenerator.hs
Normal file
@ -0,0 +1,61 @@
|
||||
{-# LANGUAGE TemplateHaskell, QuasiQuotes, OverloadedStrings #-}
|
||||
module EmbedTestGenerator (testGen) where
|
||||
|
||||
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 = Entry
|
||||
{ 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 = Entry
|
||||
{ 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 = Entry
|
||||
{ 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 = Entry
|
||||
{ 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]
|
||||
@ -2,6 +2,11 @@
|
||||
|
||||
import Test.Hspec
|
||||
import YesodStaticTest (specs)
|
||||
import EmbedProductionTest (embedProductionSpecs)
|
||||
import EmbedDevelTest (embedDevSpecs)
|
||||
|
||||
main :: IO ()
|
||||
main = hspec specs
|
||||
main = hspec $ do
|
||||
specs
|
||||
embedProductionSpecs
|
||||
embedDevSpecs
|
||||
|
||||
@ -12,8 +12,7 @@ build-type: Simple
|
||||
homepage: http://www.yesodweb.com/
|
||||
description: Static file serving subsite for Yesod Web Framework.
|
||||
extra-source-files:
|
||||
test/YesodStaticTest.hs
|
||||
test/tests.hs
|
||||
test/*.hs
|
||||
test/fs/bar/baz
|
||||
test/fs/tmp/ignored
|
||||
test/fs/.ignored
|
||||
@ -30,7 +29,7 @@ library
|
||||
, 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,7 +42,15 @@ library
|
||||
, system-fileio >= 0.3
|
||||
, data-default
|
||||
, shakespeare-css >= 1.0.3
|
||||
, mime-types >= 0.1
|
||||
|
||||
exposed-modules: Yesod.Static
|
||||
Yesod.EmbeddedStatic
|
||||
Yesod.EmbeddedStatic.Generators
|
||||
Yesod.EmbeddedStatic.Types
|
||||
|
||||
other-modules: Yesod.EmbeddedStatic.Internal
|
||||
|
||||
ghc-options: -Wall
|
||||
|
||||
test-suite tests
|
||||
@ -53,6 +60,10 @@ test-suite tests
|
||||
cpp-options: -DTEST_EXPORT
|
||||
build-depends: base
|
||||
, hspec >= 1.3
|
||||
, yesod-test >= 1.2
|
||||
, wai-test
|
||||
, HUnit
|
||||
|
||||
-- copy from above
|
||||
, containers
|
||||
, old-time
|
||||
@ -76,6 +87,7 @@ test-suite tests
|
||||
, system-fileio
|
||||
, data-default
|
||||
, shakespeare-css
|
||||
, mime-types
|
||||
|
||||
ghc-options: -Wall
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user