{-# 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