Merge 977a8b0aaa
into a4194dc490
This commit is contained in:
commit
7b5e4ff3ed
|
@ -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