332 lines
13 KiB
Haskell
332 lines
13 KiB
Haskell
{-# LANGUAGE TemplateHaskell, QuasiQuotes, ScopedTypeVariables #-}
|
|
-- | A generator is executed at compile time to load a list of entries
|
|
-- to embed into the subsite. This module contains several basic generators,
|
|
-- but the design of generators and entries is such that it is straightforward
|
|
-- to make custom generators for your own specific purposes, see <#g:4 this section>.
|
|
module Yesod.EmbeddedStatic.Generators (
|
|
-- * Generators
|
|
Location
|
|
, embedFile
|
|
, embedFileAt
|
|
, embedDir
|
|
, embedDirAt
|
|
, concatFiles
|
|
, concatFilesWith
|
|
|
|
-- * Compression options for 'concatFilesWith'
|
|
, jasmine
|
|
, uglifyJs
|
|
, yuiJavascript
|
|
, yuiCSS
|
|
, closureJs
|
|
, compressTool
|
|
, tryCompressTools
|
|
|
|
-- * Util
|
|
, pathToName
|
|
|
|
-- * Custom Generators
|
|
|
|
-- $example
|
|
) where
|
|
|
|
import Control.Applicative ((<$>), (<*>))
|
|
import Control.Exception (try, SomeException)
|
|
import Control.Monad (forM, when)
|
|
import Control.Monad.Trans.Resource (runResourceT)
|
|
import Data.Char (isDigit, isLower)
|
|
import Data.Conduit (($$))
|
|
import Data.Default (def)
|
|
import Data.Maybe (isNothing)
|
|
import Language.Haskell.TH
|
|
import Network.Mime (defaultMimeLookup)
|
|
import System.Directory (doesDirectoryExist, getDirectoryContents, findExecutable)
|
|
import System.FilePath ((</>))
|
|
import Text.Jasmine (minifym)
|
|
import qualified Data.ByteString as BS
|
|
import qualified Data.ByteString.Lazy as BL
|
|
import qualified Data.Conduit.List as C
|
|
import Data.Conduit.Binary (sourceHandle)
|
|
import qualified Data.Text as T
|
|
import qualified System.Process as Proc
|
|
import System.Exit (ExitCode (ExitSuccess))
|
|
import Control.Concurrent.Async (Concurrently (..))
|
|
import System.IO (hClose)
|
|
|
|
import Yesod.EmbeddedStatic.Types
|
|
|
|
-- | Embed a single file. Equivalent to passing the same string twice to 'embedFileAt'.
|
|
embedFile :: FilePath -> Generator
|
|
embedFile f = embedFileAt f f
|
|
|
|
-- | Embed a single file at a given location within the static subsite and generate a
|
|
-- route variable based on the location via 'pathToName'. The @FilePath@ must be a relative
|
|
-- path to the directory in which you run @cabal build@. During development, the file located
|
|
-- at this filepath will be reloaded on every request. When compiling for production, the contents
|
|
-- of the file will be embedded into the executable and so the file does not need to be
|
|
-- distributed along with the executable.
|
|
embedFileAt :: Location -> FilePath -> Generator
|
|
embedFileAt loc f = do
|
|
let mime = defaultMimeLookup $ T.pack f
|
|
let entry = def {
|
|
ebHaskellName = Just $ pathToName loc
|
|
, ebLocation = loc
|
|
, ebMimeType = mime
|
|
, ebProductionContent = fmap BL.fromStrict (BS.readFile f)
|
|
, ebDevelReload = [| fmap BL.fromStrict
|
|
(BS.readFile $(litE $ stringL f)) |]
|
|
}
|
|
return [entry]
|
|
|
|
-- | List all files recursively in a directory
|
|
getRecursiveContents :: Location -- ^ The directory to search
|
|
-> FilePath -- ^ The prefix to add to the filenames
|
|
-> IO [(Location,FilePath)]
|
|
getRecursiveContents prefix topdir = do
|
|
names <- getDirectoryContents topdir
|
|
let properNames = filter (`notElem` [".", ".."]) names
|
|
paths <- forM properNames $ \name -> do
|
|
let path = topdir </> name
|
|
let loc = if null prefix then name else prefix ++ "/" ++ name
|
|
isDirectory <- doesDirectoryExist path
|
|
if isDirectory
|
|
then getRecursiveContents loc path
|
|
else return [(loc, path)]
|
|
return (concat paths)
|
|
|
|
-- | Embed all files in a directory into the static subsite.
|
|
--
|
|
-- Equivalent to passing the empty string as the location to 'embedDirAt',
|
|
-- so the directory path itself is not part of the resource locations (and so
|
|
-- also not part of the generated route variable names).
|
|
embedDir :: FilePath -> Generator
|
|
embedDir = embedDirAt ""
|
|
|
|
-- | Embed all files in a directory to a given location within the static subsite.
|
|
--
|
|
-- The directory tree rooted at the 'FilePath' (which must be relative to the directory in
|
|
-- which you run @cabal build@) is embedded into the static subsite at the given
|
|
-- location. Also, route variables will be created based on the final location
|
|
-- of each file. For example, if a directory \"static\" contains the files
|
|
--
|
|
-- * css/bootstrap.css
|
|
--
|
|
-- * js/jquery.js
|
|
--
|
|
-- * js/bootstrap.js
|
|
--
|
|
-- then @embedDirAt \"somefolder\" \"static\"@ will
|
|
--
|
|
-- * Make the file @static\/css\/bootstrap.css@ available at the location
|
|
-- @somefolder\/css\/bootstrap.css@ within the static subsite and similarly
|
|
-- for the other two files.
|
|
--
|
|
-- * Create variables @somefolder_css_bootstrap_css@, @somefolder_js_jquery_js@,
|
|
-- @somefolder_js_bootstrap_js@ all of type @Route EmbeddedStatic@.
|
|
--
|
|
-- * During development, the files will be reloaded on every request. During
|
|
-- production, the contents of all files will be embedded into the executable.
|
|
--
|
|
-- * During development, files that are added to the directory while the server
|
|
-- is running will not be detected. You need to recompile the module which
|
|
-- contains the call to @mkEmbeddedStatic@. This will also generate new route
|
|
-- variables for the new files.
|
|
embedDirAt :: Location -> FilePath -> Generator
|
|
embedDirAt loc dir = do
|
|
files <- runIO $ getRecursiveContents loc dir
|
|
concat <$> mapM (uncurry embedFileAt) files
|
|
|
|
-- | Concatinate a list of files and embed it at the location. Equivalent to passing @return@ to
|
|
-- 'concatFilesWith'.
|
|
concatFiles :: Location -> [FilePath] -> Generator
|
|
concatFiles loc files = concatFilesWith loc return files
|
|
|
|
-- | Concatinate a list of files into a single 'BL.ByteString', run the resulting content through the given
|
|
-- function, embed it at the given location, and create a haskell variable name for the route based on
|
|
-- the location.
|
|
--
|
|
-- 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 files listed are reloaded,
|
|
-- concatenated, and served as a single resource at the given location without being processed.
|
|
concatFilesWith :: Location -> (BL.ByteString -> IO BL.ByteString) -> [FilePath] -> Generator
|
|
concatFilesWith loc process files = do
|
|
let load = do putStrLn $ "Creating " ++ loc
|
|
BL.concat <$> mapM BL.readFile files >>= process
|
|
expFiles = listE $ map (litE . stringL) files
|
|
expCt = [| BL.concat <$> mapM BL.readFile $expFiles |]
|
|
mime = defaultMimeLookup $ T.pack loc
|
|
return [def { ebHaskellName = Just $ pathToName loc
|
|
, ebLocation = loc
|
|
, ebMimeType = mime
|
|
, ebProductionContent = load
|
|
, ebDevelReload = expCt
|
|
}]
|
|
|
|
-- | Convienient rexport of 'minifym' with a type signature to work with 'concatFilesWith'.
|
|
jasmine :: BL.ByteString -> IO BL.ByteString
|
|
jasmine ct = return $ either (const ct) id $ minifym ct
|
|
|
|
-- | Use <https://github.com/mishoo/UglifyJS2 UglifyJS2> to compress javascript.
|
|
-- Assumes @uglifyjs@ is located in the path and uses options @[\"-m\", \"-c\"]@
|
|
-- to both mangle and compress and the option \"-\" to cause uglifyjs to read from
|
|
-- standard input.
|
|
uglifyJs :: BL.ByteString -> IO BL.ByteString
|
|
uglifyJs = compressTool "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" []
|
|
|
|
-- | 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
|
|
mpath <- 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
|
|
|
|
|
|
-- | Try a list of processing functions (like the compressions above) one by one until
|
|
-- one succeeds (does not raise an exception). Once a processing function succeeds,
|
|
-- none of the remaining functions are used. If none succeeds, the input is just
|
|
-- returned unprocessed. This is helpful if you are distributing
|
|
-- code on hackage and do not know what compressors the user will have installed. You
|
|
-- can list several and they will be tried in order until one succeeds.
|
|
tryCompressTools :: [BL.ByteString -> IO BL.ByteString] -> BL.ByteString -> IO BL.ByteString
|
|
tryCompressTools [] x = return x
|
|
tryCompressTools (p:ps) x = do
|
|
mres <- try $ p x
|
|
case mres of
|
|
Left (err :: SomeException) -> do
|
|
putStrLn $ show err
|
|
tryCompressTools ps x
|
|
Right res -> return res
|
|
|
|
-- | Clean up a path to make it a valid haskell name by replacing all non-letters
|
|
-- and non-numbers by underscores. In addition, if the path starts with a capital
|
|
-- letter or number add an initial underscore.
|
|
pathToName :: FilePath -> Name
|
|
pathToName f = routeName
|
|
where
|
|
replace c
|
|
| 'A' <= c && c <= 'Z' = c
|
|
| 'a' <= c && c <= 'z' = c
|
|
| '0' <= c && c <= '9' = c
|
|
| otherwise = '_'
|
|
name = map replace f
|
|
routeName = mkName $
|
|
case () of
|
|
()
|
|
| null name -> error "null-named file"
|
|
| isDigit (head name) -> '_' : name
|
|
| isLower (head name) -> name
|
|
| otherwise -> '_' : name
|
|
|
|
|
|
-- $example
|
|
-- Here is an example of creating your own custom generator.
|
|
-- Because of template haskell stage restrictions, you must define generators in a
|
|
-- different module from where you use them. The following generator will embed a
|
|
-- JSON document that contains the compile time.
|
|
--
|
|
-- >{-# LANGUAGE TemplateHaskell, QuasiQuotes, OverloadedStrings #-}
|
|
-- >module CompileTime where
|
|
-- >
|
|
-- >import Data.Aeson
|
|
-- >import Data.Default
|
|
-- >import Data.Time
|
|
-- >import Yesod.EmbeddedStatic.Generators
|
|
-- >import Yesod.EmbeddedStatic.Types
|
|
-- >import qualified Data.ByteString.Lazy as BL
|
|
-- >
|
|
-- >getTime :: IO BL.ByteString
|
|
-- >getTime = do
|
|
-- > t <- getCurrentTime
|
|
-- > return $ encode $
|
|
-- > object [ "compile_time" .= show t ]
|
|
-- >
|
|
-- >timeGenerator :: Location -> Generator
|
|
-- >timeGenerator loc =
|
|
-- > return $ [def
|
|
-- > { ebHaskellName = Just $ pathToName loc
|
|
-- > , ebLocation = loc
|
|
-- > , ebMimeType = "application/json"
|
|
-- > , ebProductionContent = getTime
|
|
-- > , ebDevelReload = [| getTime |]
|
|
-- > }]
|
|
--
|
|
-- Notice how the @getTime@ action is given as both 'ebProductionContent' and
|
|
-- 'ebDevelReload'. The result is that during development, the @getTime@ action
|
|
-- will be re-executed on every request so the time returned will be different
|
|
-- for each reload. When compiling for production, the @getTime@ action will
|
|
-- be executed once at compile time to produce the content to embed and never
|
|
-- called at runtime.
|
|
--
|
|
-- Here is a small example yesod program using this generator. Try toggling
|
|
-- the development argument to @mkEmbeddedStatic@.
|
|
--
|
|
-- >{-# LANGUAGE TemplateHaskell, QuasiQuotes, TypeFamilies #-}
|
|
-- >module Main where
|
|
-- >
|
|
-- >import Yesod
|
|
-- >import Yesod.EmbeddedStatic
|
|
-- >import CompileTime (timeGenerator)
|
|
-- >
|
|
-- >mkEmbeddedStatic True "eStatic" [timeGenerator "compile-time.json"]
|
|
-- >
|
|
-- >-- The above will generate variables
|
|
-- >-- eStatic :: EmbeddedStatic
|
|
-- >-- compile_time_json :: Route EmbeddedStatic
|
|
-- >
|
|
-- >data MyApp = MyApp { getStatic :: EmbeddedStatic }
|
|
-- >
|
|
-- >mkYesod "MyApp" [parseRoutes|
|
|
-- >/ HomeR GET
|
|
-- >/static StaticR EmbeddedStatic getStatic
|
|
-- >|]
|
|
-- >
|
|
-- >instance Yesod MyApp
|
|
-- >
|
|
-- >getHomeR :: Handler Html
|
|
-- >getHomeR = defaultLayout $ [whamlet|
|
|
-- ><h1>Hello
|
|
-- ><p>Check the
|
|
-- > <a href=@{StaticR compile_time_json}>compile time
|
|
-- >|]
|
|
-- >
|
|
-- >main :: IO ()
|
|
-- >main = warp 3000 $ MyApp eStatic
|