diff --git a/servant-static/Setup.hs b/servant-static/Setup.hs new file mode 100644 index 00000000..9a994af6 --- /dev/null +++ b/servant-static/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/servant-static/servant-static.cabal b/servant-static/servant-static.cabal new file mode 100644 index 00000000..4178cf7f --- /dev/null +++ b/servant-static/servant-static.cabal @@ -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 diff --git a/servant-static/src/Servant/Server/Embedded.hs b/servant-static/src/Servant/Server/Embedded.hs new file mode 100644 index 00000000..d169ec7c --- /dev/null +++ b/servant-static/src/Servant/Server/Embedded.hs @@ -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) diff --git a/servant-static/src/Servant/Server/Embedded/CSS.hs b/servant-static/src/Servant/Server/Embedded/CSS.hs new file mode 100644 index 00000000..d789126f --- /dev/null +++ b/servant-static/src/Servant/Server/Embedded/CSS.hs @@ -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 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 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) + ||] + } diff --git a/servant-static/src/Servant/Server/Embedded/Files.hs b/servant-static/src/Servant/Server/Embedded/Files.hs new file mode 100644 index 00000000..4f06de6c --- /dev/null +++ b/servant-static/src/Servant/Server/Embedded/Files.hs @@ -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 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 to compress javascript. +-- Assumes a script @yuicompressor@ is located in the path. If not, you can still +-- use something like +-- +-- > compressTool "java" ["-jar", "/path/to/yuicompressor.jar", "--type", "js"] +yuiJavascript :: BL.ByteString -> IO BL.ByteString +yuiJavascript = compressTool "yuicompressor" ["--type", "js"] + +-- | Use to compress CSS. +-- Assumes a script @yuicompressor@ is located in the path. +yuiCSS :: BL.ByteString -> IO BL.ByteString +yuiCSS = compressTool "yuicompressor" ["--type", "css"] + +-- | Use to compress +-- javascript using the default options. Assumes a script @closure@ is located in +-- the path. If not, you can still run using +-- +-- > compressTool "java" ["-jar", "/path/to/compiler.jar"] +closureJs :: BL.ByteString -> IO BL.ByteString +closureJs = compressTool "closure" [] diff --git a/servant-static/src/Servant/Server/Embedded/Ghcjs.hs b/servant-static/src/Servant/Server/Embedded/Ghcjs.hs new file mode 100644 index 00000000..40f3661f --- /dev/null +++ b/servant-static/src/Servant/Server/Embedded/Ghcjs.hs @@ -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"] diff --git a/servant-static/src/Servant/Server/Embedded/TH.hs b/servant-static/src/Servant/Server/Embedded/TH.hs new file mode 100644 index 00000000..7da1ba61 --- /dev/null +++ b/servant-static/src/Servant/Server/Embedded/TH.hs @@ -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 diff --git a/servant-static/src/Servant/Server/Embedded/Types.hs b/servant-static/src/Servant/Server/Embedded/Types.hs new file mode 100644 index 00000000..199dfd90 --- /dev/null +++ b/servant-static/src/Servant/Server/Embedded/Types.hs @@ -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