eeva/servant
1
0
Fork 0
Code Issues Pull requests Projects Releases Wiki Activity

RFC for embedded static resource support

Browse source 
This code allows to embed static content such as javascript and CSS into the executable at compile time
so that it does not need to be distributed along with the server.  In addition, this module
supports processing of these resources before they are embedded, such as javascript or CSS
minification.  Finally, there is a development mode which will recompute each resource on every
request, so allow a simple browser refresh to reload potentially changed javascript or CSS.

Documentation is in the haddock comment in Servant.Server.Embedded.hs
This commit is contained in:
John Lenz 2016-01-23 17:45:37 -06:00
parent b9fb80ac5e
commit 977a8b0aaa
8 changed files with 720 additions and 0 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
servant-static/Setup.hs Normal file
View file

@ -0,0 +1,2 @@
import Distribution.Simple
main = defaultMain

49
servant-static/servant-static.cabal Normal file
View file

@ -0,0 +1,49 @@
name: servant-static
version: 0.1.0
build-type: Simple
cabal-version: >=1.10
library
hs-source-dirs: src
default-language: Haskell2010
ghc-options: -Wall
exposed-modules: Servant.Server.Embedded.TH,
Servant.Server.Embedded.Types,
Servant.Server.Embedded.Files,
Servant.Server.Embedded.CSS,
Servant.Server.Embedded.Ghcjs,
Servant.Server.Embedded
default-extensions: TemplateHaskell
QuasiQuotes
OverloadedStrings
TupleSections
TypeFamilies
MagicHash
FlexibleContexts
DataKinds
ScopedTypeVariables
FlexibleInstances
MultiParamTypeClasses
build-depends: base
, async
, base64-bytestring
, blaze-builder
, byteable
, bytestring
, conduit
, conduit-extra
, cryptohash
, directory
, filepath
, http-types
, mime-types
, process
, servant
, servant-server
, template-haskell
, text
, wai
, zlib

142
servant-static/src/Servant/Server/Embedded.hs Normal file
View file

@ -0,0 +1,142 @@
-- | A module to embed static content such as javascript and CSS into the executable at compile time
-- so that it does not need to be distributed along with the server. In addition, this module
-- supports processing of these resources before they are embedded, such as javascript or CSS
-- minification. Finally, there is a development mode which will recompute each resource on every
-- request, so allow a simple browser refresh to reload potentially changed javascript or CSS.
--
-- To use this module, use 'EmbeddedContent' in your servant API definition. For example,
--
-- >type MyAPI = "static" :> "js" :> "bootstrap.js" :> EmbeddedContent "application/javascript"
-- > :<|> "static" :> "css" :> "bootstrap.css" :> EmbeddedContent "text/css"
-- > :<|> "static" :> "css" :> "mysite.css" :> EmbeddedContent "text/css"
--
-- Then, decide on a generator for each 'EmbeddedContent'. There are several generators which embed
-- files directly, minifiy files, and use 3rd party tools like less and postcss. You can also
-- easily create your own generators. Each generator is passed to 'embed' and will produce a
-- haskell variable of type 'EmbeddedEntry'. For example,
--
-- >#if DEVELOPMENT
-- >#define DEV_BOOL True
-- >#else
-- >#define DEV_BOOL False
-- >#endif
-- >
-- >embed DEV_BOOL
-- > [ embedFileWith uglifyJs "bootJs" "node_modules/bootstrap/dist/js/bootstrap.js"
-- > , embedFile "bootCss" "node_modules/bootstrap/dist/css/bootstrap.min.css"
-- > , embedWithPostCSS "mysiteCss" "css/mysite.css"
-- > ]
--
-- The above template haskell splice will produce the following three variables automatically (you
-- do not need to enter anything extra):
--
-- >bootJs :: EmbeddedEntry "application/javascript"
-- >bootCss :: EmbeddedEntry "text/css"
-- >mysiteCss :: EmbeddedEntry "text/css"
--
-- These 'EmbeddedEntry's are used to create the server for the 'EmbeddedContent' endpoints.
--
-- >staticServer :: Server MyAPI
-- >staticServer = bootJs :<|> bootCss :<|> mysiteCss
--
-- If the DEVELOPMENT define is true (I suggest you use a cabal flag), on each
-- request the server will recompute the resource. This means that the file will be reloaded from
-- disk or postcss will be re-executed on each request. Thus when the DEVELOPMENT flag is true, a
-- browser refresh will reload and recompute the resources from disk.
--
-- When the DEVELOPMENT define is false, instead at compile time the resource will be loaded, the
-- processing will occur, it will be compressed with gzip, and finally the resulting bytes will be
-- embedded directly into the executable. The server will then return this embedded content on each
-- request without computing anything or loading anything from disk.
--
-- In addition, when DEVELOPMENT is false, the server will use etags, 304 not modified responses,
-- and potentially Cache-Control headers to reduce the need for the client to re-request these
-- resources. The server will always use etags to return 304 not modified responses. By default,
-- these etags are the md5 hash of the content. So for example if bootstrap is updated to a new
-- version, the file @node_modules\/bootstrap\/dist\/js\/bootstrap.js@ will change and so the etag
-- will be different. Thus when the client re-requests the resource, the etag the client sends will
-- differ from the server and so the server will return the new content.
--
-- Using just etags still requires the client to send a request for each resource and for the
-- server to respond with 304 not modified the vast majority of the time. To mitigate that, a
-- Cache-Control header can be configured to be used to tell the client to not re-request the
-- resource. In this module, such a Cache-Control header is controlled by an etag query parameter
-- on the URL. If the client requests the resource via a URL @\/static\/js\/bootstrap.js@, no
-- Cache-Control header is sent because when a new version of the server is released the client
-- might need to re-download the bootstrap.js. If instead the client requested the
-- resource via the URL @\/static\/js\/bootstrap.js?etag=123456789@ and the etag is correct, a
-- Cache-Control header is set to tell the client to cache the resource for one year. When a new
-- version of the server is released with an updated bootstrap version, the etag will change and as
-- long as the new server uses an HTML script tag referring to a URL with the new etag, the client
-- will download the new bootstrap version because the URL has changed.
--
-- The calculated etag is stored inside the 'EmbeddedEntry' created by template haskell and can be
-- passed to 'safeLink' in order to create a link which includes the correct etag. The function
-- 'embeddedLink' is a simple wrapper around 'safeLink' which extracts the etag from the
-- 'EmbeddedEntry'.
--
-- >bootstrapJsLink :: URI
-- >bootstrapJsLink =
-- > embeddedLink (Proxy :: Proxy MyAPI)
-- > (Proxy :: Proxy ("static" :> "js" :> "bootstrap.js" :> EmbeddedContent "application/javascript"))
-- > bootJs
module Servant.Server.Embedded(
EmbeddedContent(..)
, EntryVarName
, Generator
, EmbeddableEntry
, EmbeddedEntry
, embed
, Etag(..)
, embeddedLink
-- * Generators
, module Servant.Server.Embedded.Files
, module Servant.Server.Embedded.CSS
, module Servant.Server.Embedded.Ghcjs
) where
import Control.Monad (forM)
import Language.Haskell.TH
import Servant
import Servant.Server.Embedded.CSS
import Servant.Server.Embedded.Files
import Servant.Server.Embedded.Ghcjs
import Servant.Server.Embedded.TH
import Servant.Server.Embedded.Types
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
-- | For each 'Generator', embed the result of the generator into the executable to produce
-- an 'EmbeddedEntry'. Each resource can be embedded in two ways, controlled by the boolean passed
-- to 'embed'. In development mode, the resource will be recomputed on each request allowing a
-- single browser refresh to reload the content. In production mode, the resource is loaded and
-- embedded into the executable at compile time.
--
-- After creating the 'EmbeddedEntry', 'embed' will create a haskell variable to hold the
-- 'EmbeddedEntry'. The name of the haskell variable is the 'EntryVarName' passed to the function
-- which creates the generator.
embed :: Bool -- ^ development mode?
-> [Generator]
-> Q [Dec]
embed dev gens = concat <$> do
entries <- sequence gens
forM entries $ \e -> do
let n = mkName (ebeName e)
let emb = if dev then embedDevel e else embedProduction e
def <- valD (varP n) (normalB (unType <$> emb)) []
let mime = T.unpack $ T.decodeUtf8 $ ebeMimeType e
sig <- sigD n (conT ''EmbeddedEntry `appT` litT (strTyLit mime))
return [sig, def]
-- | The 'HasLink' instance of 'EmbeddedContent' requires an 'Etag' be passed to create the link.
-- This etag is stored inside the 'EmbeddedEntry' on the server, and so 'embeddedLink' is a simple
-- wrapper around 'safeLink' which extracts the 'Etag' from the 'EmbeddedEntry' and then passes it
-- to 'safeLink'.
embeddedLink :: (IsElem endpoint api, HasLink endpoint, MkLink endpoint ~ (Maybe Etag -> URI))
=> Proxy api -> Proxy endpoint -> EmbeddedEntry mime -> URI
embeddedLink p1 p2 x = safeLink p1 p2 (eeEtag x)

76
servant-static/src/Servant/Server/Embedded/CSS.hs Normal file
View file

@ -0,0 +1,76 @@
-- | This module contains 'Generators' for processing and embedding CSS.
module Servant.Server.Embedded.CSS (
embedWithLess
, embedWithPostCSS
) where
import Data.List (intersperse)
import Language.Haskell.TH
import Language.Haskell.TH.Syntax (TExp(..), liftString, lift)
import Servant.Server.Embedded.Files (compressTool)
import Servant.Server.Embedded.TH
import qualified Data.ByteString.Lazy as BL
-- | Execute <http://lesscss.org/ lesscss> and serve the resulting CSS. It assumes that
-- @lessc@ and @cleancss@ are installed in @node_modules@, so run @npm install less clean-css@.
-- During development, @lessc@ will be executed on every request so a browser refresh is enough to
-- reload any changes to the CSS files. During production, @lessc@ is executed at compile time and
-- the resulting CSS is passed through @cleancss@. The 'FilePath' is relative to the directory
-- containing the @.cabal@ file.
embedWithLess :: EntryVarName -> FilePath -> Generator
embedWithLess n f = do
let less = compressTool "sh" ["-c", "node_modules/less/bin/lessc - | node_modules/clean-css/bin/cleancss"]
return EmbeddableEntry
{ ebeName = n
, ebeMimeType = "text/css"
, ebeProduction = etagAsHash <$> (BL.readFile f >>= less)
, ebeDevelReload = [|| BL.readFile $$(TExp <$> litE (stringL f)) >>=
compressTool "node_modules/less/bin/lessc" ["-"]
||]
}
-- | Compile a file using postcss.
compilePostCSS :: EntryVarName -> FilePath -> Bool -> [String] -> IO BL.ByteString
compilePostCSS n fp sourceMaps plugins = compressTool "node" ["-e", script] ""
where
mapArg = if sourceMaps then ", map:true" else ""
addRequire plugin = "require('" ++ plugin ++ "')"
requirePlugins = concat $ intersperse "," $ map addRequire plugins
script = unlines
[ "require('fs').readFile('" ++ fp ++ "', function(err, css) {"
, "if (err) console.log('Error: ' + err.toString());"
, "require('postcss')([" ++ requirePlugins ++ "])"
, ".process(css, { from: '" ++ fp ++ "', to: '" ++ show n ++ ".css'" ++ mapArg ++ "})"
, ".then(function(result) {"
, "console.log(result.css);"
, "})"
, ".catch(function(err) {"
, "console.log('Error:' + err.toString());"
, "});"
, "});"
]
-- | Use <https://github.com/postcss/postcss postcss> to compile and embed CSS.
-- It assumes that the postcss plugins and @cssnano@ are installed in @node_modules@.
-- During development, @postcss@ will be executed on every request so a browser refresh is enough to
-- reload any changes to the CSS files. In addition, during development sourceMaps will be created.
-- During production, @postcss@ is executed at compile time in addition to the @cssnano@ plugin.
-- The 'FilePath' is relative to the directory containing the @.cabal@ file.
embedWithPostCSS :: EntryVarName -- ^ The variable name to create.
-> FilePath -- ^ Path to CSS file to compile.
-> [String] -- ^ List of postcss plugins. When compiling for production,
-- @cssnano@ is added to the end of this list. Each plugin
-- in this list must be installed into @node_modules@ so that
-- when @node@ executes @require(plugin)@ the plugin is loaded.
-> Generator
embedWithPostCSS n fp plugins = return
EmbeddableEntry
{ ebeName = n
, ebeMimeType = "text/css"
, ebeProduction = etagAsHash <$> compilePostCSS (show n) fp False (plugins ++ ["cssnano"])
, ebeDevelReload = [|| compilePostCSS $$(TExp <$> liftString (show n))
$$(TExp <$> liftString fp)
True
$$(TExp <$> lift plugins)
||]
}

141
servant-static/src/Servant/Server/Embedded/Files.hs Normal file
View file

@ -0,0 +1,141 @@
-- | This module contains 'Generators' which embed and potentially process
-- files.
module Servant.Server.Embedded.Files (
embedFile
, embedFileWith
, concatFiles
, concatFilesWith
-- * Compression tools
, compressTool
, uglifyJs
, yuiJavascript
, yuiCSS
, closureJs
) where
import Control.Concurrent.Async (Concurrently (..))
import Control.Monad (when)
import Data.Conduit (($$))
import Data.Conduit.Binary (sourceHandle)
import Data.Maybe (isNothing)
import Language.Haskell.TH
import Language.Haskell.TH.Syntax (TExp(..))
import Network.Mime (defaultMimeLookup, MimeType)
import Servant.Server.Embedded.TH
import System.Directory (findExecutable, doesFileExist)
import System.Exit (ExitCode (ExitSuccess))
import System.IO (hClose)
import qualified Data.ByteString.Lazy as BL
import qualified Data.Conduit.List as C
import qualified System.Process as Proc
import qualified Data.Text as T
-- | Embed a file. When compiling for production, the file content is embedded
-- into the executable. When compiling for development, the file will be reloaded
-- from disk on every request. The 'FilePath' must be specified relative to the
-- directory which contains the @.cabal@ file.
embedFile :: EntryVarName -> FilePath -> Generator
embedFile n fp = return
EmbeddableEntry
{ ebeName = n
, ebeMimeType = defaultMimeLookup $ T.pack fp
, ebeProduction = etagAsHash <$> BL.readFile fp
, ebeDevelReload = [|| BL.readFile $$(TExp <$> litE (stringL fp)) ||]
}
-- | Embed a file and execute a processing function at compile time.
--
-- 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 file is reloaded
-- and served as a single resource at the given location without being processed.
embedFileWith :: (BL.ByteString -> IO BL.ByteString) -> EntryVarName -> FilePath -> Generator
embedFileWith process n fp = return
EmbeddableEntry
{ ebeName = n
, ebeMimeType = defaultMimeLookup $ T.pack fp
, ebeProduction = etagAsHash <$> (BL.readFile fp >>= process)
, ebeDevelReload = [|| BL.readFile $$(TExp <$> litE (stringL fp)) ||]
}
-- | Concat a list of files into a single bytestring and serve the resuling content.
-- The 'FilePath's must be given relative to the directory containing the @.cabal@ file.
concatFiles :: EntryVarName -> MimeType -> [FilePath] -> Generator
concatFiles n mime files = do
let load = BL.concat <$> mapM BL.readFile files
let filesExp = TExp <$> listE (map (litE . stringL) files)
return EmbeddableEntry
{ ebeName = n
, ebeMimeType = mime
, ebeProduction = etagAsHash <$> load
, ebeDevelReload = [|| BL.concat <$> mapM BL.readFile $$filesExp ||]
}
-- | Concat a list of files into a single bytestring. When compiling for production, pass the
-- resulting bytestring through the processing function. The 'FilePath's must be given relative
-- to the directory containing the @.cabal@ file.
concatFilesWith :: (BL.ByteString -> IO BL.ByteString) -> EntryVarName -> MimeType -> [FilePath] -> Generator
concatFilesWith process n mime files = do
let load = (BL.concat <$> mapM BL.readFile files) >>= process
let filesExp = TExp <$> listE (map (litE . stringL) files)
return EmbeddableEntry
{ ebeName = n
, ebeMimeType = mime
, ebeProduction = etagAsHash <$> load
, ebeDevelReload = [|| BL.concat <$> mapM BL.readFile $$filesExp ||]
}
-- | 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
fExists <- doesFileExist f
mpath <- if fExists
then return $ Just f
else 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 (sourceHandle hout $$ C.consume)
<*> Concurrently (BL.hPut hin ct >> hClose hin)
<*> Concurrently (Proc.waitForProcess ph)
if code == ExitSuccess
then do
putStrLn $ "Compressed successfully with " ++ f
return $ BL.fromChunks compressed
else error $ "compressTool: compression failed with " ++ f
-- | Use <https://github.com/mishoo/UglifyJS2 UglifyJS2> to compress javascript.
-- Assumes @node_modules\/uglifyjs\/bin\/uglifyjs@ exists so just run @npm install uglifyjs@. It
-- uses options @[\"-m\", \"-c\"]@ to both mangle and compress.
uglifyJs :: BL.ByteString -> IO BL.ByteString
uglifyJs = compressTool "./node_modules/uglifyjs/bin/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" []

47
servant-static/src/Servant/Server/Embedded/Ghcjs.hs Normal file
View file

@ -0,0 +1,47 @@
module Servant.Server.Embedded.Ghcjs (
embedGhcjsFromStackBuild
) where
import Data.List (intercalate)
import Data.Monoid ((<>))
import Language.Haskell.TH
import Language.Haskell.TH.Syntax (TExp(..))
import Servant.Server.Embedded.Files (compressTool)
import Servant.Server.Embedded.TH
import System.Directory (getCurrentDirectory)
import System.FilePath ((</>))
import System.Process (readCreateProcess, proc, CreateProcess(..))
import qualified Data.ByteString.Lazy as BL
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Encoding as TL
embedGhcjsFromStackBuild :: EntryVarName -> FilePath -> String -> [String] -> Generator
embedGhcjsFromStackBuild name dir projName varsToProtect = do
curDir <- runIO getCurrentDirectory
let dir' = curDir </> dir
installDir <- runIO $ readCreateProcess (proc "stack" ["path", "--local-install-root"]) { cwd = Just dir' } ""
let fp = (filter (/='\n') installDir) </> "bin" </> (projName++".jsexe") </> "all.js"
return EmbeddableEntry
{ ebeName = name
, ebeMimeType = "application/javascript"
, ebeProduction = etagAsHash <$> (BL.readFile fp >>= compressGhcjs varsToProtect)
, ebeDevelReload = [|| BL.readFile $$(TExp <$> litE (stringL fp)) ||]
}
compressGhcjs :: [String] -> BL.ByteString -> IO BL.ByteString
compressGhcjs varsToProtect allJs = removeBadJs >>= closureCompile
where
vars = TL.encodeUtf8 $ TL.pack $ intercalate "," varsToProtect
addWindow x = "window['" ++ x ++ "']"
windowVars = TL.encodeUtf8 $ TL.pack $ intercalate "," $ map addWindow varsToProtect
input = BL.concat [ "(function(global"
, if null varsToProtect then "" else "," <> vars
, ") {"
, allJs
, "})(window"
, if null varsToProtect then "" else "," <> windowVars
, ");"
]
removeBadJs = compressTool "sed" ["s/goog.provide.*//;s/goog.require.*//;s/final\\([^a-z]\\)/final0\\1/"] input
closureCompile = compressTool "closure" ["--compilation_level=ADVANCED_OPTIMIZATIONS"]

214
servant-static/src/Servant/Server/Embedded/TH.hs Normal file
View file

@ -0,0 +1,214 @@
-- | This module which contains the template haskell code which embeds the content. Normally, you
-- do not need to use anything from this module. You only need this module if you are creating your
-- own custom content generators, or you want more control over specifically how the resulting
-- 'EmbeddedEntry' structs are created and stored.
module Servant.Server.Embedded.TH (
EntryVarName
, EmbeddableEntry(..)
, Generator
, base64md5
, etagAsHash
, embedDevel
, embedProduction
) where
import Blaze.ByteString.Builder.ByteString (insertByteString)
import Codec.Compression.GZip (compress)
import Crypto.Hash (MD5, Digest, hashlazy)
import Data.ByteString.Unsafe (unsafePackAddressLen)
import Data.Byteable (toBytes)
import Data.Monoid ((<>))
import GHC.Exts (Int(..))
import Language.Haskell.TH
import Language.Haskell.TH.Lib (TExpQ)
import Language.Haskell.TH.Syntax (TExp(..), lift)
import Network.HTTP.Types (status200, status304)
import Network.Mime (MimeType)
import Network.Wai
import System.IO.Unsafe (unsafeDupablePerformIO)
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.ByteString.Base64 as Base64
import Servant.Server.Embedded.Types
-- | For each entry, the template haskell code will produce a variable of type @'EmbeddedEntry'
-- mime@. The variable name is specified by a value of type 'EntryVarName', so the string must
-- be a valid haskell identifier (start with a lower case letter, no spaces, etc.).
type EntryVarName = String
-- | A structure which only exists at compile time and specifies how some content should
-- be served. The same content is described in two possible ways, either an IO action
-- which is executed at compile time to embed the content in the executable, or as an
-- action which will be executed on every request.
data EmbeddableEntry = EmbeddableEntry {
ebeName :: EntryVarName
, ebeMimeType :: MimeType
, ebeProduction :: IO (Etag, BL.ByteString)
-- ^ An action executed at compile time to load the content to embed.
, ebeDevelReload :: TExpQ (IO BL.ByteString)
-- ^ A template haskell expression that produces an @IO BL.ByteString@. This
-- @IO BL.ByteString@ will be executed on every request to load the content.
-- The etag will be the hash of the content.
}
-- | A generator is an action which describes how to embed some content.
type Generator = Q EmbeddableEntry
-- | Hash and base64 encode a bytestring.
base64md5 :: BL.ByteString -> B.ByteString
base64md5 lbs = Base64.encode $ toBytes d
where
d :: Digest MD5
d = hashlazy lbs
-- | Helper function to create the Etag by calling 'base64md5' on the content.
etagAsHash :: BL.ByteString -> (Etag, BL.ByteString)
etagAsHash b = (Etag $ base64md5 b, b)
-----------------------------------------------------------------------
-- | This is executed at runtime to recreate and serve the content on each request.
serveDevel :: MimeType -> IO BL.ByteString -> Application
serveDevel mime buildCt request sendResp = do
ct <- buildCt
let etag = "\"" <> base64md5 ct <> "\""
h = [ ("Content-Type", mime)
, ("ETag", etag)
]
case lookup "if-none-match" $ requestHeaders request of
Just m | m == etag -> sendResp $ responseLBS status304 [] ""
_ -> sendResp $ responseLBS status200 h ct
-- | Embed the 'EmbeddableEntry' into the executable using 'ebeDevelReload', so that the
-- content will be recomputed on each request. The action 'ebeProduction' is ignored.
embedDevel ::EmbeddableEntry -> TExpQ (EmbeddedEntry mime)
embedDevel e = addTypeDecl (ebeMimeType e)
[| EmbeddedEntry
{ eeEtag = Nothing
, eeApp = serveDevel $(bytestringE $ ebeMimeType e) $(unType <$> ebeDevelReload e)
}
|]
-----------------------------------------------------------------------------------
-- | This is executed at runtime to serve the previously embedded content.
serveProd :: MimeType -> Bool -> Etag -> B.ByteString -> Application
serveProd mime isCompressed (Etag etag) ct request sendResp = do
let etag' = "\"" <> etag <> "\""
h = [ ("Content-Type", mime)
, ("ETag", etag')
] ++
[ ("Content-Encoding", "gzip") | isCompressed ]
cacheControl = [ ("Expires", "Thu, 31 Dec 2037 23:55:55 GMT")
, ("Cache-Control", "public, max-age=31536000") -- one year = 60*60*24*365
]
let ifMatch = lookup "if-none-match" $ requestHeaders request
etagQuery = lookup "etag" $ queryString request
sendResp $ case (ifMatch, etagQuery) of
-- if both header and query, check both match
(Just m, Just (Just t)) | m == etag' && t == etag -> responseLBS status304 [] ""
-- if just the header, check that it matches
(Just m, Nothing) | m == etag' -> responseLBS status304 [] ""
-- if the etag argument was given correctly, respond with the content and
-- specify that it should be cached forever.
(_, Just (Just t)) | t == etag ->
responseBuilder status200 (h++cacheControl) $ insertByteString $ ct
-- if no etag argument was given or it was incorrect, then we cannot specify
-- the cache control headers
_ -> responseBuilder status200 h $ insertByteString $ ct
-- | Embed the 'EmbeddableEntry' into the executable by calling 'ebeProduction'. The resulting
-- content will be compressed using gzip (depends on mime-type) and embedded into the executable.
-- At runtime, the content will be served. In addition, if the incomming request URL contains an
-- @?etag=..@ query parameter, a @Cache-Control@ header will be returned to the client to indicate
-- that the content should be cached by the client forever. Links with this etag are created by
-- the 'HasLink' instance, so if you always use links from 'safeLink' to refer to this
-- resource, the client will only request the resource when the etag changes.
embedProduction :: EmbeddableEntry -> TExpQ (EmbeddedEntry mime)
embedProduction e = do
runIO $ putStrLn $ "Embedding resouce for " ++ ebeName e
(Etag etag, ct) <- runIO $ ebeProduction e
let (isCompressed, embeddedCt) = tryCompress (ebeMimeType e) ct
etagVar <- newName "etag"
addTypeDecl (ebeMimeType e)
$ letE [ valD (varP etagVar) (normalB $ bytestringE etag) [] ]
[| EmbeddedEntry
{ eeEtag = Just (Etag $(varE etagVar))
, eeApp = serveProd $(bytestringE $ ebeMimeType e)
$(lift isCompressed)
(Etag $(varE etagVar))
$(bytestringLazyE embeddedCt)
}
|]
-- | Turn an expression producing an 'EmbeddedEntry' into one which has a type
-- declaration for 'EmbeddedEntry' with the given mime type.
addTypeDecl :: MimeType -> ExpQ -> TExpQ (EmbeddedEntry mime)
addTypeDecl mime entryExp = do
eVar <- newName "entry"
let mimeStr = T.unpack $ T.decodeUtf8 mime
TExp <$> letE
-- let eVar :: EmbeddedEntry mime = entryExp
[ valD (sigP (varP eVar) (conT ''EmbeddedEntry `appT` litT (strTyLit mimeStr)))
(normalB entryExp)
[]
]
-- in eVar
(varE eVar)
-----------------------------------------------------------------------------------
-- The following code was copied from wai-app-static (with a few small changes)
-----------------------------------------------------------------------------------
-- The use of unsafePackAddressLen is safe here because the length
-- is correct and we will only be reading from the bytestring, never
-- modifying it.
--
-- The only IO within unsafePackAddressLen is within newForeignPtr_ where
-- a new IORef is created as newIORef (NoFinalizers, []) to hold the finalizer
-- for the pointer. Since the pointer for the content will never have a finalizer
-- added, we do not care if this finalizer IORef gets created more than once since
-- the IORef will always be holding (NoFinalizers, []). Therefore
-- unsafeDupablePerformIO is safe.
bytestringE :: B.ByteString -> ExpQ
bytestringE b = [| unsafeDupablePerformIO (unsafePackAddressLen (I# $lenE) $ctE) |]
where
lenE = litE $ intPrimL $ toInteger $ B.length b
ctE = litE $ stringPrimL $ B.unpack b
bytestringLazyE :: BL.ByteString -> ExpQ
bytestringLazyE b = [| unsafeDupablePerformIO (unsafePackAddressLen (I# $lenE) $ctE) |]
where
lenE = litE $ intPrimL $ toInteger $ BL.length b
ctE = litE $ stringPrimL $ BL.unpack b
shouldCompress :: MimeType -> Bool
shouldCompress m = "text/" `B.isPrefixOf` m || m `elem` extra
where
extra = [ "application/json"
, "application/javascript"
, "application/ecmascript"
]
-- | Only compress if the mime type is correct and the compressed text is actually shorter.
tryCompress :: MimeType -> BL.ByteString -> (Bool, BL.ByteString)
tryCompress mime ct
| shouldCompress mime = (c, ct')
| otherwise = (False, ct)
where
compressed = compress ct
c = BL.length compressed < BL.length ct
ct' = if c then compressed else ct

49
servant-static/src/Servant/Server/Embedded/Types.hs Normal file
View file

@ -0,0 +1,49 @@
module Servant.Server.Embedded.Types (
Etag(..)
, EmbeddedContent(..)
, EmbeddedEntry(..)
) where
import Data.Proxy (Proxy(..))
import GHC.TypeLits (Symbol)
import Network.Wai
import Servant.Server
import Servant.Server.Internal
import Servant.Utils.Links
import qualified Data.ByteString as B
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
-- | Endpoint for embedded content.
data EmbeddedContent (mime :: Symbol) = EmbeddedContent
-- | An etag is used to return 304 not modified responses and cache control headers.
-- If the content changes, the etag must change as well.
newtype Etag = Etag B.ByteString
-- | This structure exists at runtime and describes content that has
-- been embedded.
data EmbeddedEntry (mime :: Symbol) = EmbeddedEntry {
eeEtag :: Maybe Etag
, eeApp :: Application
}
instance HasServer (EmbeddedContent mime) config where
type ServerT (EmbeddedContent mime) m = EmbeddedEntry mime
route Proxy _ entry = LeafRouter $ \request respond -> do
r <- runDelayed entry
case r of
Route e -> (eeApp e) request (respond . Route)
Fail a -> respond $ Fail a
FailFatal e -> respond $ FailFatal e
instance HasLink (EmbeddedContent mime) where
type MkLink (EmbeddedContent mime) = Maybe Etag -> URI
toLink Proxy lnk metag = uri { uriQuery = q }
where
uri = linkURI lnk
q = case (uriQuery uri, metag) of
("", Just (Etag etag)) -> "?etag=" ++ T.unpack (T.decodeUtf8 etag)
(query, Just (Etag etag)) -> query ++ "&etag=" ++ T.unpack (T.decodeUtf8 etag)
(query, _) -> query