RFC for embedded static resource support
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
parent
b9fb80ac5e
commit
977a8b0aaa
|
|
@ -0,0 +1,2 @@
|
|||
import Distribution.Simple
|
||||
main = defaultMain
|
||||
|
|
@ -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
|
||||
|
|
@ -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)
|
||||
|
|
@ -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)
|
||||
||]
|
||||
}
|
||||
|
|
@ -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" []
|
||||
|
|
@ -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"]
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
Loading…
Reference in New Issue