yesod-static-1.6.1.0/Yesod/0000755000000000000000000000000013700124674013542 5ustar0000000000000000yesod-static-1.6.1.0/Yesod/EmbeddedStatic/0000755000000000000000000000000013677403504016410 5ustar0000000000000000yesod-static-1.6.1.0/Yesod/EmbeddedStatic/Css/0000755000000000000000000000000013674600066017137 5ustar0000000000000000yesod-static-1.6.1.0/test/0000755000000000000000000000000013674600066013442 5ustar0000000000000000yesod-static-1.6.1.0/test/embed-dir/0000755000000000000000000000000013674600066015272 5ustar0000000000000000yesod-static-1.6.1.0/test/embed-dir/abc/0000755000000000000000000000000013674600066016017 5ustar0000000000000000yesod-static-1.6.1.0/test/fs/0000755000000000000000000000000013674600066014052 5ustar0000000000000000yesod-static-1.6.1.0/test/fs/bar/0000755000000000000000000000000013674600066014616 5ustar0000000000000000yesod-static-1.6.1.0/test/fs/tmp/0000755000000000000000000000000013674600066014652 5ustar0000000000000000yesod-static-1.6.1.0/Yesod/Static.hs0000644000000000000000000005213713700124674015335 0ustar0000000000000000{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE FlexibleContexts #-} --------------------------------------------------------- -- -- | Serve static files from a Yesod app. -- -- This is great for developing your application, but also for a -- dead-simple deployment. Caching headers are automatically -- taken care of. -- -- If you are running a proxy server (like Apache or Nginx), -- you may want to have that server do the static serving instead. -- -- In fact, in an ideal setup you'll serve your static files from -- a separate domain name to save time on transmitting -- cookies. In that case, you may wish to use 'urlParamRenderOverride' -- to redirect requests to this subsite to a separate domain -- name. -- -- Note that this module's static subsite ignores all files and -- directories that are hidden by Unix conventions (i.e. start -- with a dot, such as @\".ssh\"@) and the directory "tmp" on the -- root of the directory with static files. module Yesod.Static ( -- * Subsite Static (..) , Route (..) , StaticRoute -- * Smart constructor , static , staticDevel -- * Combining CSS/JS -- $combining , combineStylesheets' , combineScripts' -- ** Settings , CombineSettings , csStaticDir , csCssPostProcess , csJsPostProcess , csCssPreProcess , csJsPreProcess , csCombinedFolder -- * Template Haskell helpers , staticFiles , staticFilesList , staticFilesMap , staticFilesMergeMap , publicFiles -- * Hashing , base64md5 -- * Embed , embed #ifdef TEST_EXPORT , getFileListPieces #endif ) where import System.Directory import qualified System.FilePath as FP import Control.Monad import Data.FileEmbed (embedDir) import Yesod.Core import Yesod.Core.Types import Data.List (intercalate, sort) import Language.Haskell.TH import Language.Haskell.TH.Syntax as TH import Crypto.Hash.Conduit (hashFile, sinkHash) import Crypto.Hash (MD5, Digest) import Control.Monad.Trans.State import qualified Data.ByteArray as ByteArray import qualified Data.ByteString.Base64 import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L import Data.Text (Text, pack) import qualified Data.Text as T import qualified Data.Map as M import Data.IORef (readIORef, newIORef, writeIORef) import Data.Char (isLower, isDigit) import Data.List (foldl') import qualified Data.ByteString as S import System.PosixCompat.Files (getFileStatus, modificationTime) import System.Posix.Types (EpochTime) import Conduit import System.FilePath ((), (<.>), takeDirectory) import qualified System.FilePath as F import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Encoding as TLE import Data.Default --import Text.Lucius (luciusRTMinified) import Network.Wai (pathInfo) import Network.Wai.Application.Static ( StaticSettings (..) , staticApp , webAppSettingsWithLookup , embeddedSettings ) import WaiAppStatic.Storage.Filesystem (ETagLookup) -- | Type used for the subsite with static contents. newtype Static = Static StaticSettings type StaticRoute = Route Static -- | Produce a default value of 'Static' for a given file -- folder. -- -- Does not have index files or directory listings. The static -- files' contents /must not/ change, however new files can be -- added. static :: FilePath -> IO Static static dir = do hashLookup <- cachedETagLookup dir return $ Static $ webAppSettingsWithLookup dir hashLookup -- | Same as 'static', but does not assumes that the files do not -- change and checks their modification time whenever a request -- is made. staticDevel :: FilePath -> IO Static staticDevel dir = do hashLookup <- cachedETagLookupDevel dir return $ Static $ webAppSettingsWithLookup dir hashLookup -- | Produce a 'Static' based on embedding all of the static files' contents in the -- executable at compile time. -- -- You should use "Yesod.EmbeddedStatic" instead, it is much more powerful. -- -- Nota Bene: if you replace the scaffolded 'static' call in Settings/StaticFiles.hs -- you will need to change the scaffolded addStaticContent. Otherwise, some of your -- assets will be 404'ed. This is because by default yesod will generate compile those -- assets to @static/tmp@ which for 'static' is fine since they are served out of the -- directory itself. With embedded static, that will not work. -- You can easily change @addStaticContent@ to @\_ _ _ -> return Nothing@ as a workaround. -- This will cause yesod to embed those assets into the generated HTML file itself. embed :: FilePath -> Q Exp embed fp = [|Static (embeddedSettings $(embedDir fp))|] instance RenderRoute Static where -- | A route on the static subsite (see also 'staticFiles'). -- -- You may use this constructor directly to manually link to a -- static file. The first argument is the sub-path to the file -- being served whereas the second argument is the key-value -- pairs in the query string. For example, -- -- > StaticRoute $ StaticR [\"thumb001.jpg\"] [(\"foo\", \"5\"), (\"bar\", \"choc\")] -- -- would generate a url such as -- @http://www.example.com/static/thumb001.jpg?foo=5&bar=choc@ -- The StaticRoute constructor can be used when the URL cannot be -- statically generated at compile-time (e.g. when generating -- image galleries). data Route Static = StaticRoute [Text] [(Text, Text)] deriving (Eq, Show, Read) renderRoute (StaticRoute x y) = (x, y) instance ParseRoute Static where parseRoute (x, y) = Just $ StaticRoute x y instance YesodSubDispatch Static master where yesodSubDispatch YesodSubRunnerEnv {..} req = ysreParentRunner handlert ysreParentEnv (fmap ysreToParentRoute route) req where route = Just $ StaticRoute (pathInfo req) [] Static set = ysreGetSub $ yreSite $ ysreParentEnv handlert = sendWaiApplication $ staticApp set notHidden :: FilePath -> Bool notHidden "tmp" = False notHidden s = case s of '.':_ -> False _ -> True getFileListPieces :: FilePath -> IO [[String]] getFileListPieces = flip evalStateT M.empty . flip go id where go :: String -> ([String] -> [String]) -> StateT (M.Map String String) IO [[String]] go fp front = do allContents <- liftIO $ (sort . filter notHidden) `fmap` getDirectoryContents fp let fullPath :: String -> String fullPath f = fp ++ '/' : f files <- liftIO $ filterM (doesFileExist . fullPath) allContents let files' = map (front . return) files files'' <- mapM dedupe files' dirs <- liftIO $ filterM (doesDirectoryExist . fullPath) allContents dirs' <- mapM (\f -> go (fullPath f) (front . (:) f)) dirs return $ concat $ files'' : dirs' -- Reuse data buffers for identical strings dedupe :: [String] -> StateT (M.Map String String) IO [String] dedupe = mapM dedupe' dedupe' :: String -> StateT (M.Map String String) IO String dedupe' s = do m <- get case M.lookup s m of Just s' -> return s' Nothing -> do put $ M.insert s s m return s -- | Template Haskell function that automatically creates routes -- for all of your static files. -- -- For example, if you used -- -- > staticFiles "static/" -- -- and you had files @\"static\/style.css\"@ and -- @\"static\/js\/script.js\"@, then the following top-level -- definitions would be created: -- -- > style_css = StaticRoute ["style.css"] [] -- > js_script_js = StaticRoute ["js", "script.js"] [] -- -- Note that dots (@.@), dashes (@-@) and slashes (@\/@) are -- replaced by underscores (@\_@) to create valid Haskell -- identifiers. staticFiles :: FilePath -> Q [Dec] staticFiles dir = mkStaticFiles dir -- | Same as 'staticFiles', but takes an explicit list of files -- to create identifiers for. The files path given are relative -- to the static folder. For example, to create routes for the -- files @\"static\/js\/jquery.js\"@ and -- @\"static\/css\/normalize.css\"@, you would use: -- -- > staticFilesList "static" ["js/jquery.js", "css/normalize.css"] -- -- This can be useful when you have a very large number of static -- files, but only need to refer to a few of them from Haskell. staticFilesList :: FilePath -> [FilePath] -> Q [Dec] staticFilesList dir fs = mkStaticFilesList dir (map split fs) True where split :: FilePath -> [String] split [] = [] split x = let (a, b) = break (== '/') x in a : split (drop 1 b) -- | Same as 'staticFiles', but doesn't append an ETag to the -- query string. -- -- Using 'publicFiles' will speed up the compilation, since there -- won't be any need for hashing files during compile-time. -- However, since the ETag ceases to be part of the URL, the -- 'Static' subsite won't be able to set the expire date too far -- on the future. Browsers still will be able to cache the -- contents, however they'll need send a request to the server to -- see if their copy is up-to-date. publicFiles :: FilePath -> Q [Dec] publicFiles dir = mkStaticFiles' dir False -- | Similar to 'staticFilesList', but takes a mapping of -- unmunged names to fingerprinted file names. -- -- @since 1.5.3 staticFilesMap :: FilePath -> M.Map FilePath FilePath -> Q [Dec] staticFilesMap fp m = mkStaticFilesList' fp (map splitBoth mapList) True where splitBoth (k, v) = (split k, split v) mapList = M.toList m split :: FilePath -> [String] split [] = [] split x = let (a, b) = break (== '/') x in a : split (drop 1 b) -- | Similar to 'staticFilesMergeMap', but also generates identifiers -- for all files in the specified directory that don't have a -- fingerprinted version. -- -- @since 1.5.3 staticFilesMergeMap :: FilePath -> M.Map FilePath FilePath -> Q [Dec] staticFilesMergeMap fp m = do fs <- qRunIO $ getFileListPieces fp let filesList = map FP.joinPath fs mergedMapList = M.toList $ foldl' (checkedInsert invertedMap) m filesList mkStaticFilesList' fp (map splitBoth mergedMapList) True where splitBoth (k, v) = (split k, split v) swap (x, y) = (y, x) mapList = M.toList m invertedMap = M.fromList $ map swap mapList split :: FilePath -> [String] split [] = [] split x = let (a, b) = break (== '/') x in a : split (drop 1 b) -- We want to keep mappings for all files that are pre-fingerprinted, -- so this function checks against all of the existing fingerprinted files and -- only inserts a new mapping if it's not a fingerprinted file. checkedInsert :: M.Map FilePath FilePath -- inverted dictionary -> M.Map FilePath FilePath -- accumulating state -> FilePath -> M.Map FilePath FilePath checkedInsert iDict st p = if M.member p iDict then st else M.insert p p st mkHashMap :: FilePath -> IO (M.Map FilePath S8.ByteString) mkHashMap dir = do fs <- getFileListPieces dir hashAlist fs >>= return . M.fromList where hashAlist :: [[String]] -> IO [(FilePath, S8.ByteString)] hashAlist fs = mapM hashPair fs where hashPair :: [String] -> IO (FilePath, S8.ByteString) hashPair pieces = do let file = pathFromRawPieces dir pieces h <- base64md5File file return (file, S8.pack h) pathFromRawPieces :: FilePath -> [String] -> FilePath pathFromRawPieces = foldl' append where append a b = a ++ '/' : b cachedETagLookupDevel :: FilePath -> IO ETagLookup cachedETagLookupDevel dir = do etags <- mkHashMap dir mtimeVar <- newIORef (M.empty :: M.Map FilePath EpochTime) return $ \f -> case M.lookup f etags of Nothing -> return Nothing Just checksum -> do fs <- getFileStatus f let newt = modificationTime fs mtimes <- readIORef mtimeVar oldt <- case M.lookup f mtimes of Nothing -> writeIORef mtimeVar (M.insert f newt mtimes) >> return newt Just oldt -> return oldt return $ if newt /= oldt then Nothing else Just checksum cachedETagLookup :: FilePath -> IO ETagLookup cachedETagLookup dir = do etags <- mkHashMap dir return $ (\f -> return $ M.lookup f etags) mkStaticFiles :: FilePath -> Q [Dec] mkStaticFiles fp = mkStaticFiles' fp True mkStaticFiles' :: FilePath -- ^ static directory -> Bool -- ^ append checksum query parameter -> Q [Dec] mkStaticFiles' fp makeHash = do fs <- qRunIO $ getFileListPieces fp mkStaticFilesList fp fs makeHash mkStaticFilesList :: FilePath -- ^ static directory -> [[String]] -- ^ list of files to create identifiers for -> Bool -- ^ append checksum query parameter -> Q [Dec] mkStaticFilesList fp fs makeHash = mkStaticFilesList' fp (zip fs fs) makeHash mkStaticFilesList' :: FilePath -- ^ static directory -> [([String], [String])] -- ^ list of files to create identifiers for, where -- the first argument of the tuple is the identifier -- alias and the second is the actual file name -> Bool -- ^ append checksum query parameter -> Q [Dec] mkStaticFilesList' fp fs makeHash = do concat `fmap` mapM mkRoute fs where replace' c | 'A' <= c && c <= 'Z' = c | 'a' <= c && c <= 'z' = c | '0' <= c && c <= '9' = c | otherwise = '_' mkRoute (alias, f) = do let name' = intercalate "_" $ map (map replace') alias routeName = mkName $ case () of () | null name' -> error "null-named file" | isDigit (head name') -> '_' : name' | isLower (head name') -> name' | otherwise -> '_' : name' f' <- [|map pack $(TH.lift f)|] qs <- if makeHash then do hash <- qRunIO $ base64md5File $ pathFromRawPieces fp f [|[(pack "etag", pack $(TH.lift hash))]|] else return $ ListE [] return [ SigD routeName $ ConT ''StaticRoute , FunD routeName [ Clause [] (NormalB $ (ConE 'StaticRoute) `AppE` f' `AppE` qs) [] ] ] base64md5File :: FilePath -> IO String base64md5File = fmap (base64 . encode) . hashFile where encode d = ByteArray.convert (d :: Digest MD5) base64md5 :: L.ByteString -> String base64md5 lbs = base64 $ encode $ runConduitPure $ Conduit.sourceLazy lbs .| sinkHash where encode d = ByteArray.convert (d :: Digest MD5) base64 :: S.ByteString -> String base64 = map tr . take 8 . S8.unpack . Data.ByteString.Base64.encode where tr '+' = '-' tr '/' = '_' tr c = c -- $combining -- -- A common scenario on a site is the desire to include many external CSS and -- Javascript files on every page. Doing so via the Widget functionality in -- Yesod will work, but would also mean that the same content will be -- downloaded many times. A better approach would be to combine all of these -- files together into a single static file and serve that as a static resource -- for every page. That resource can be cached on the client, and bandwidth -- usage reduced. -- -- This could be done as a manual process, but that becomes tedious. Instead, -- you can use some Template Haskell code which will combine these files into a -- single static file at compile time. data CombineType = JS | CSS combineStatics' :: CombineType -> CombineSettings -> [Route Static] -- ^ files to combine -> Q Exp combineStatics' combineType CombineSettings {..} routes = do texts <- qRunIO $ runConduitRes $ yieldMany fps .| awaitForever readUTFFile .| sinkLazy ltext <- qRunIO $ preProcess texts bs <- qRunIO $ postProcess fps $ TLE.encodeUtf8 ltext let hash' = base64md5 bs suffix = csCombinedFolder hash' <.> extension fp = csStaticDir suffix qRunIO $ do createDirectoryIfMissing True $ takeDirectory fp L.writeFile fp bs let pieces = map T.unpack $ T.splitOn "/" $ T.pack suffix [|StaticRoute (map pack pieces) []|] where fps :: [FilePath] fps = map toFP routes toFP (StaticRoute pieces _) = csStaticDir F.joinPath (map T.unpack pieces) readUTFFile fp = sourceFile fp .| decodeUtf8C postProcess = case combineType of JS -> csJsPostProcess CSS -> csCssPostProcess preProcess = case combineType of JS -> csJsPreProcess CSS -> csCssPreProcess extension = case combineType of JS -> "js" CSS -> "css" -- | Data type for holding all settings for combining files. -- -- This data type is a settings type. For more information, see: -- -- -- -- Since 1.2.0 data CombineSettings = CombineSettings { csStaticDir :: FilePath -- ^ File path containing static files. -- -- Default: static -- -- Since 1.2.0 , csCssPostProcess :: [FilePath] -> L.ByteString -> IO L.ByteString -- ^ Post processing to be performed on CSS files. -- -- Default: Pass-through. -- -- Since 1.2.0 , csJsPostProcess :: [FilePath] -> L.ByteString -> IO L.ByteString -- ^ Post processing to be performed on Javascript files. -- -- Default: Pass-through. -- -- Since 1.2.0 , csCssPreProcess :: TL.Text -> IO TL.Text -- ^ Pre-processing to be performed on CSS files. -- -- Default: convert all occurences of /static/ to ../ -- -- Since 1.2.0 , csJsPreProcess :: TL.Text -> IO TL.Text -- ^ Pre-processing to be performed on Javascript files. -- -- Default: Pass-through. -- -- Since 1.2.0 , csCombinedFolder :: FilePath -- ^ Subfolder to put combined files into. -- -- Default: combined -- -- Since 1.2.0 } instance Default CombineSettings where def = CombineSettings { csStaticDir = "static" {- Disabled due to: https://github.com/yesodweb/yesod/issues/623 , csCssPostProcess = \fps -> either (error . (errorIntro fps)) (return . TLE.encodeUtf8) . flip luciusRTMinified [] . TLE.decodeUtf8 -} , csCssPostProcess = const return , csJsPostProcess = const return -- FIXME The following borders on a hack. With combining of files, -- the final location of the CSS is no longer fixed, so relative -- references will break. Instead, we switched to using /static/ -- absolute references. However, when served from a separate domain -- name, this will break too. The solution is that, during -- development, we keep /static/, and in the combining phase, we -- replace /static with a relative reference to the parent folder. , csCssPreProcess = return . TL.replace "'/static/" "'../" . TL.replace "\"/static/" "\"../" , csJsPreProcess = return , csCombinedFolder = "combined" } liftRoutes :: [Route Static] -> Q Exp liftRoutes = fmap ListE . mapM go where go :: Route Static -> Q Exp go (StaticRoute x y) = [|StaticRoute $(liftTexts x) $(liftPairs y)|] liftTexts = fmap ListE . mapM liftT liftT t = [|pack $(TH.lift $ T.unpack t)|] liftPairs = fmap ListE . mapM liftPair liftPair (x, y) = [|($(liftT x), $(liftT y))|] -- | Combine multiple CSS files together. Common usage would be: -- -- >>> combineStylesheets' development def 'StaticR [style1_css, style2_css] -- -- Where @development@ is a variable in your site indicated whether you are in -- development or production mode. -- -- Since 1.2.0 combineStylesheets' :: Bool -- ^ development? if so, perform no combining -> CombineSettings -> Name -- ^ Static route constructor name, e.g. \'StaticR -> [Route Static] -- ^ files to combine -> Q Exp combineStylesheets' development cs con routes | development = [| mapM_ (addStylesheet . $(return $ ConE con)) $(liftRoutes routes) |] | otherwise = [| addStylesheet $ $(return $ ConE con) $(combineStatics' CSS cs routes) |] -- | Combine multiple JS files together. Common usage would be: -- -- >>> combineScripts' development def 'StaticR [script1_js, script2_js] -- -- Where @development@ is a variable in your site indicated whether you are in -- development or production mode. -- -- Since 1.2.0 combineScripts' :: Bool -- ^ development? if so, perform no combining -> CombineSettings -> Name -- ^ Static route constructor name, e.g. \'StaticR -> [Route Static] -- ^ files to combine -> Q Exp combineScripts' development cs con routes | development = [| mapM_ (addScript . $(return $ ConE con)) $(liftRoutes routes) |] | otherwise = [| addScript $ $(return $ ConE con) $(combineStatics' JS cs routes) |] yesod-static-1.6.1.0/Yesod/EmbeddedStatic.hs0000644000000000000000000001662613674600066016756 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | A subsite which serves static content which is embedded at compile time. -- -- At compile time, you supply a list of files, directories, processing functions (like javascript -- minification), and even custom content generators. You can also specify the specific relative -- locations within the static subsite where these resources should appear. The 'mkEmbeddedStatic' -- function then computes the resources and embeds them directly into the executable at -- compile time, so that the original files do not need to be distributed along with -- the executable. The content is also compressed and hashed at compile time, so that -- during runtime the compressed content can be sent directly on the wire with the appropriate -- HTTP header. The precomputed hash is used for an ETag so the client does not redownload -- the content multiple times. There is also a development mode which does not embed the -- contents but recomputes it on every request. A simple example using an embedded static -- subsite is -- . -- -- To add this to a scaffolded project, replace the code in @Settings/StaticFiles.hs@ -- with a call to 'mkEmbeddedStatic' with the list of all your generators, use the type -- 'EmbeddedStatic' in your site datatype for @getStatic@, update the route for @/static@ to -- use the type 'EmbeddedStatic', use 'embedStaticContent' for 'addStaticContent' in -- @Foundation.hs@, use the routes generated by 'mkEmbeddedStatic' and exported by -- @Settings/StaticFiles.hs@ to link to your static content, and finally update -- @Application.hs@ use the variable binding created by 'mkEmbeddedStatic' which -- contains the created 'EmbeddedStatic'. -- -- It is recommended that you serve static resources from a separate domain to save time -- on transmitting cookies. You can use 'urlParamRenderOverride' to do so, by redirecting -- routes to this subsite to a different domain (but the same path) and then pointing the -- alternative domain to this server. In addition, you might consider using a reverse -- proxy like varnish or squid to cache the static content, but the embedded content in -- this subsite is cached and served directly from memory so is already quite fast. module Yesod.EmbeddedStatic ( -- * Subsite EmbeddedStatic , embeddedResourceR , mkEmbeddedStatic , embedStaticContent -- * Generators , module Yesod.EmbeddedStatic.Generators ) where import Control.Applicative as A ((<$>)) import Data.IORef import Data.Maybe (catMaybes) import Language.Haskell.TH import Network.HTTP.Types.Status (status404) import Network.Wai (responseLBS, pathInfo) import Network.Wai.Application.Static (staticApp) import System.IO.Unsafe (unsafePerformIO) import Yesod.Core (YesodSubDispatch(..)) import Yesod.Core.Types ( YesodSubRunnerEnv(..) , YesodRunnerEnv(..) ) import qualified Data.ByteString.Lazy as BL import qualified Data.Text as T import qualified Data.HashMap.Strict as M import qualified WaiAppStatic.Storage.Embedded as Static import Yesod.EmbeddedStatic.Types import Yesod.EmbeddedStatic.Internal import Yesod.EmbeddedStatic.Generators -- Haddock doesn't support associated types in instances yet so we can't -- export EmbeddedResourceR directly. -- | Construct a route to an embedded resource. embeddedResourceR :: [T.Text] -> [(T.Text, T.Text)] -> Route EmbeddedStatic embeddedResourceR = EmbeddedResourceR instance YesodSubDispatch EmbeddedStatic master where yesodSubDispatch YesodSubRunnerEnv {..} req = resp where master = yreSite ysreParentEnv site = ysreGetSub master resp = case pathInfo req of ("res":_) -> stApp site req ("widget":_) -> staticApp (widgetSettings site) req _ -> ($ responseLBS status404 [] "Not Found") -- | Create the haskell variable for the link to the entry mkRoute :: ComputedEntry -> Q [Dec] mkRoute (ComputedEntry { cHaskellName = Nothing }) = return [] mkRoute (c@ComputedEntry { cHaskellName = Just name }) = do routeType <- [t| Route EmbeddedStatic |] link <- [| $(cLink c) |] return [ SigD name routeType , ValD (VarP name) (NormalB link) [] ] -- | Creates an 'EmbeddedStatic' by running, at compile time, a list of generators. -- Each generator produces a list of entries to embed into the executable. -- -- This template haskell splice creates a variable binding holding the resulting -- 'EmbeddedStatic' and in addition creates variable bindings for all the routes -- produced by the generators. For example, if a directory called static has -- the following contents: -- -- * js/jquery.js -- -- * css/bootstrap.css -- -- * img/logo.png -- -- then a call to -- -- > #ifdef DEVELOPMENT -- > #define DEV_BOOL True -- > #else -- > #define DEV_BOOL False -- > #endif -- > mkEmbeddedStatic DEV_BOOL "myStatic" [embedDir "static"] -- -- will produce variables -- -- > myStatic :: EmbeddedStatic -- > js_jquery_js :: Route EmbeddedStatic -- > css_bootstrap_css :: Route EmbeddedStatic -- > img_logo_png :: Route EmbeddedStatic mkEmbeddedStatic :: Bool -- ^ development? -> String -- ^ variable name for the created 'EmbeddedStatic' -> [Generator] -- ^ the generators (see "Yesod.EmbeddedStatic.Generators") -> Q [Dec] mkEmbeddedStatic dev esName gen = do entries <- concat A.<$> sequence gen computed <- runIO $ mapM (if dev then devEmbed else prodEmbed) entries let settings = Static.mkSettings $ return $ map cStEntry computed devExtra = listE $ catMaybes $ map ebDevelExtraFiles entries ioRef = [| unsafePerformIO $ newIORef M.empty |] -- build the embedded static esType <- [t| EmbeddedStatic |] esCreate <- if dev then [| EmbeddedStatic (develApp $settings $devExtra) $ioRef |] else [| EmbeddedStatic (staticApp $! $settings) $ioRef |] let es = [ SigD (mkName esName) esType , ValD (VarP $ mkName esName) (NormalB esCreate) [] ] routes <- mapM mkRoute computed return $ es ++ concat routes -- | Use this for 'addStaticContent' to have the widget static content be served by -- the embedded static subsite. For example, -- -- > import Yesod -- > import Yesod.EmbeddedStatic -- > import Text.Jasmine (minifym) -- > -- > data MySite = { ..., getStatic :: EmbeddedStatic, ... } -- > -- > mkYesod "MySite" [parseRoutes| -- > ... -- > /static StaticR EmbeddedStatic getStatic -- > ... -- > |] -- > -- > instance Yesod MySite where -- > ... -- > addStaticContent = embedStaticContent getStatic StaticR mini -- > where mini = if development then Right else minifym -- > ... embedStaticContent :: (site -> EmbeddedStatic) -- ^ How to retrieve the embedded static subsite from your site -> (Route EmbeddedStatic -> Route site) -- ^ how to convert an embedded static route -> (BL.ByteString -> Either a BL.ByteString) -- ^ javascript minifier -> AddStaticContent site embedStaticContent = staticContentHelper yesod-static-1.6.1.0/Yesod/EmbeddedStatic/Generators.hs0000644000000000000000000003170713677403504021065 0ustar0000000000000000{-# 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 as A ((<$>), (<*>)) import Control.Exception (try, SomeException) import Control.Monad (forM, when) import Data.Char (isDigit, isLower) 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 Conduit 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 Data.List (sort) 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 <- sort <$> 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 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 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" [] -- | 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 $ (,,) A.<$> Concurrently (runConduit $ sourceHandle hout .| sinkLazy) A.<*> Concurrently (BL.hPut hin ct >> hClose hin) A.<*> Concurrently (Proc.waitForProcess ph) if code == ExitSuccess then do putStrLn $ "Compressed successfully with " ++ f return 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| -- >

Hello -- >

Check the -- > compile time -- >|] -- > -- >main :: IO () -- >main = warp 3000 $ MyApp eStatic yesod-static-1.6.1.0/Yesod/EmbeddedStatic/Types.hs0000644000000000000000000000622013674600066020047 0ustar0000000000000000{-# LANGUAGE TemplateHaskell, QuasiQuotes, OverloadedStrings #-} module Yesod.EmbeddedStatic.Types( Location , Generator -- ** Entry , Entry , ebHaskellName , ebLocation , ebMimeType , ebProductionContent , ebDevelReload , ebDevelExtraFiles ) where import Data.Default import Language.Haskell.TH import Network.Mime (MimeType) import qualified Data.ByteString.Lazy as BL -- | A location is a relative path within the static subsite at which resource(s) are made available. -- The location can include slashes to simulate directories but must not start or end with a slash. type Location = String -- | A single resource embedded into the executable at compile time. -- -- This data type is a settings type. For more information, see -- . data Entry = Entry { ebHaskellName :: Maybe Name -- ^ An optional haskell name. If the name is present, a variable -- of type @Route 'Yesod.EmbeddedStatic.EmbeddedStatic'@ with the -- given name will be created which points to this resource. , ebLocation :: Location -- ^ The location to serve the resource from. , ebMimeType :: MimeType -- ^ The mime type of the resource. , ebProductionContent :: IO BL.ByteString -- ^ If the development argument to 'Yesod.EmbeddedStatic.mkEmbeddedStatic' is False, -- then at compile time this action will be executed to load the content. -- During development, this action will not be executed. , ebDevelReload :: ExpQ -- ^ This must be a template haskell expression of type @IO 'BL.ByteString'@. -- If the development argument to 'Yesod.EmbeddedStatic.mkEmbeddedStatic' is True, -- this action is executed on every request to compute the content. Most of the -- time, 'ebProductionContent' and 'ebDevelReload' should be the same action but -- occasionally you might want additional processing inside the 'ebProductionContent' -- function like javascript/css minification to only happen when building for production. , ebDevelExtraFiles :: Maybe ExpQ -- ^ Occasionally, during development an entry needs extra files/resources available -- that are not present during production (for example, image files that are embedded -- into the CSS at production but left unembedded during development). If present, -- @ebDevelExtraFiles@ must be a template haskell expression of type -- @['T.Text'] -> IO (Maybe ('MimeType', 'BL.ByteString'))@. That is, a function -- taking as input the list of path pieces and optionally returning a mime type -- and content. } -- | When using 'def', you must fill in at least 'ebLocation'. instance Default Entry where def = Entry { ebHaskellName = Nothing , ebLocation = "xxxx" , ebMimeType = "application/octet-stream" , ebProductionContent = return BL.empty , ebDevelReload = [| return BL.empty |] , ebDevelExtraFiles = Nothing } -- | An embedded generator is executed at compile time to produce the entries to embed. type Generator = Q [Entry] yesod-static-1.6.1.0/Yesod/EmbeddedStatic/Css/AbsoluteUrl.hs0000644000000000000000000000550513674600066021741 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} -- | Manipulate CSS urls. -- -- * Make relative urls absolute (useful when combining assets) module Yesod.EmbeddedStatic.Css.AbsoluteUrl ( -- * Absolute urls absoluteUrls , absoluteUrlsAt , absoluteUrlsWith , absCssUrlsFileProd , absCssUrlsProd ) where import Yesod.EmbeddedStatic.Generators import Yesod.EmbeddedStatic.Types import qualified Data.ByteString.Lazy as BL import qualified Data.Text as T import qualified Data.Text.Lazy as TL import qualified Data.Text.IO as T import qualified Data.Text.Lazy.Encoding as TL import Control.Monad ((>=>)) import Data.Maybe (fromMaybe) import System.FilePath (()) import Yesod.EmbeddedStatic.Css.Util ------------------------------------------------------------------------------- -- Generator ------------------------------------------------------------------------------- -- | Anchors relative CSS image urls absCssUrlsFileProd :: FilePath -- ^ Anchor relative urls to here -> FilePath -> IO BL.ByteString absCssUrlsFileProd dir file = do contents <- T.readFile file return $ TL.encodeUtf8 $ absCssUrlsProd dir contents absCssUrlsProd :: FilePath -- ^ Anchor relative urls to here -> T.Text -> TL.Text absCssUrlsProd dir contents = let css = either error id $ parseCssUrls contents in renderCssWith toAbsoluteUrl css where toAbsoluteUrl (UrlReference rel) = T.concat [ "url('/" , (T.pack $ dir T.unpack rel) , "')" ] -- | Equivalent to passing the same string twice to 'absoluteUrlsAt'. absoluteUrls :: FilePath -> Generator absoluteUrls f = absoluteUrlsAt f f -- | Equivalent to passing @return@ to 'absoluteUrlsWith'. absoluteUrlsAt :: Location -> FilePath -> Generator absoluteUrlsAt loc f = absoluteUrlsWith loc f Nothing -- | Automatically make relative urls absolute -- -- During development, leave CSS as is. -- -- When CSS is organized into a directory structure, it will work properly for individual requests for each file. -- During production, we want to combine and minify CSS as much as possible. -- The combination process combines files from different directories, messing up relative urls. -- This pre-processor makes relative urls absolute absoluteUrlsWith :: Location -- ^ The location the CSS file should appear in the static subsite -> FilePath -- ^ Path to the CSS file. -> Maybe (CssGeneration -> IO BL.ByteString) -- ^ Another filter function run after this one (for example @return . yuiCSS . cssContent@) or other CSS filter that runs after this filter. -> Generator absoluteUrlsWith loc file mpostFilter = return [ cssProductionFilter (absCssUrlsFileProd loc >=> postFilter . mkCssGeneration loc file) loc file ] where postFilter = fromMaybe (return . cssContent) mpostFilter yesod-static-1.6.1.0/Yesod/EmbeddedStatic/Internal.hs0000644000000000000000000001600113674600066020515 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE CPP #-} module Yesod.EmbeddedStatic.Internal ( EmbeddedStatic(..) , Route(..) , ComputedEntry(..) , devEmbed , prodEmbed , develApp , AddStaticContent , staticContentHelper , widgetSettings ) where import Control.Applicative as A ((<$>)) import Data.IORef import Language.Haskell.TH import Network.HTTP.Types (Status(..), status404, status200, status304) import Network.Mime (MimeType) import Network.Wai import Network.Wai.Application.Static (defaultWebAppSettings, staticApp) import WaiAppStatic.Types import Yesod.Core ( HandlerFor , ParseRoute(..) , RenderRoute(..) , getYesod , liftIO ) import qualified Data.ByteString.Lazy as BL import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.HashMap.Strict as M import qualified WaiAppStatic.Storage.Embedded as Static import Yesod.Static (base64md5) import Yesod.EmbeddedStatic.Types #if !MIN_VERSION_base(4,6,0) -- copied from base atomicModifyIORef' :: IORef a -> (a -> (a,b)) -> IO b atomicModifyIORef' ref f = do b <- atomicModifyIORef ref (\x -> let (a, b) = f x in (a, a `seq` b)) b `seq` return b #endif -- | The subsite for the embedded static file server. data EmbeddedStatic = EmbeddedStatic { stApp :: !Application , widgetFiles :: !(IORef (M.HashMap T.Text File)) } instance RenderRoute EmbeddedStatic where data Route EmbeddedStatic = EmbeddedResourceR [T.Text] [(T.Text,T.Text)] | EmbeddedWidgetR T.Text deriving (Eq, Show, Read) renderRoute (EmbeddedResourceR x y) = ("res":x, y) renderRoute (EmbeddedWidgetR h) = (["widget",h], []) instance ParseRoute EmbeddedStatic where parseRoute (("res":x), y) = Just $ EmbeddedResourceR x y parseRoute (["widget",h], _) = Just $ EmbeddedWidgetR h parseRoute _ = Nothing -- | At compile time, one of these is created for every 'Entry' created by -- the generators. The cLink is a template haskell expression of type @Route EmbeddedStatic@. data ComputedEntry = ComputedEntry { cHaskellName :: Maybe Name -- ^ Optional haskell name to create a variable for the route , cStEntry :: Static.EmbeddableEntry -- ^ The entry to be embedded into the executable , cLink :: ExpQ -- ^ The route for this entry } mkStr :: String -> ExpQ mkStr = litE . stringL -- | Create a 'ComputedEntry' for development mode, reloading the content on every request. devEmbed :: Entry -> IO ComputedEntry devEmbed e = return computed where st = Static.EmbeddableEntry { Static.eLocation = "res/" `T.append` T.pack (ebLocation e) , Static.eMimeType = ebMimeType e , Static.eContent = Right [| $(ebDevelReload e) >>= \c -> return (T.pack (base64md5 c), c) |] } link = [| EmbeddedResourceR (T.splitOn (T.pack "/") $ T.pack $(mkStr $ ebLocation e)) [] |] computed = ComputedEntry (ebHaskellName e) st link -- | Create a 'ComputedEntry' for production mode, hashing and embedding the content into the executable. prodEmbed :: Entry -> IO ComputedEntry prodEmbed e = do ct <- ebProductionContent e let hash = base64md5 ct link = [| EmbeddedResourceR (T.splitOn (T.pack "/") $ T.pack $(mkStr $ ebLocation e)) [(T.pack "etag", T.pack $(mkStr hash))] |] st = Static.EmbeddableEntry { Static.eLocation = "res/" `T.append` T.pack (ebLocation e) , Static.eMimeType = ebMimeType e , Static.eContent = Left (T.pack hash, ct) } return $ ComputedEntry (ebHaskellName e) st link toApp :: (Request -> IO Response) -> Application toApp f req g = f req >>= g tryExtraDevelFiles :: [[T.Text] -> IO (Maybe (MimeType, BL.ByteString))] -> Application tryExtraDevelFiles = toApp . tryExtraDevelFiles' tryExtraDevelFiles' :: [[T.Text] -> IO (Maybe (MimeType, BL.ByteString))] -> Request -> IO Response tryExtraDevelFiles' [] _ = return $ responseLBS status404 [] "" tryExtraDevelFiles' (f:fs) r = do mct <- liftIO $ f $ drop 1 $ pathInfo r -- drop the initial "res" case mct of Nothing -> tryExtraDevelFiles' fs r Just (mime, ct) -> do let hash = T.encodeUtf8 $ T.pack $ base64md5 ct let headers = [ ("Content-Type", mime) , ("ETag", hash) ] case lookup "If-None-Match" (requestHeaders r) of Just h | hash == h -> return $ responseLBS status304 headers "" _ -> return $ responseLBS status200 headers ct -- | Helper to create the development application at runtime develApp :: StaticSettings -> [[T.Text] -> IO (Maybe (MimeType, BL.ByteString))] -> Application develApp settings extra req sendResponse = do staticApp settings {ssMaxAge = NoMaxAge} req $ \resp -> if statusCode (responseStatus resp) == 404 then tryExtraDevelFiles extra req sendResponse else sendResponse resp -- | The type of 'addStaticContent' type AddStaticContent site = T.Text -> T.Text -> BL.ByteString -> HandlerFor site (Maybe (Either T.Text (Route site, [(T.Text, T.Text)]))) -- | Helper for embedStaticContent and embedLicensedStaticContent. staticContentHelper :: (site -> EmbeddedStatic) -> (Route EmbeddedStatic -> Route site) -> (BL.ByteString -> Either a BL.ByteString) -> AddStaticContent site staticContentHelper getStatic staticR minify ext _ ct = do wIORef <- widgetFiles . getStatic A.<$> getYesod let hash = T.pack $ base64md5 ct hash' = Just $ T.encodeUtf8 hash filename = T.concat [hash, ".", ext] content = case ext of "js" -> either (const ct) id $ minify ct _ -> ct file = File { fileGetSize = fromIntegral $ BL.length content , fileToResponse = \s h -> responseLBS s h content , fileName = unsafeToPiece filename , fileGetHash = return hash' , fileGetModified = Nothing } liftIO $ atomicModifyIORef' wIORef $ \m -> (M.insertWith (\old _ -> old) filename file m, ()) return $ Just $ Right (staticR $ EmbeddedWidgetR filename, []) -- | Create a wai-app-static settings based on the IORef inside the EmbeddedStaic site. widgetSettings :: EmbeddedStatic -> StaticSettings widgetSettings es = (defaultWebAppSettings "") { ssLookupFile = lookupFile } where lookupFile [_,p] = do -- The first part of the path is "widget" m <- readIORef $ widgetFiles es return $ maybe LRNotFound LRFile $ M.lookup (fromPiece p) m lookupFile _ = return LRNotFound yesod-static-1.6.1.0/Yesod/EmbeddedStatic/Css/Util.hs0000644000000000000000000001743413674600066020421 0ustar0000000000000000{-# LANGUAGE OverloadedStrings, QuasiQuotes, TemplateHaskell, TupleSections, GeneralizedNewtypeDeriving #-} module Yesod.EmbeddedStatic.Css.Util where import Control.Applicative import Control.Monad (void, foldM) import Data.Hashable (Hashable) import Data.Monoid import Network.Mime (MimeType, defaultMimeLookup) import Text.CSS.Parse (parseBlocks) import Language.Haskell.TH (litE, stringL) import Text.CSS.Render (renderBlocks) import Yesod.EmbeddedStatic.Types import Yesod.EmbeddedStatic (pathToName) import Data.Default (def) import System.FilePath ((), takeFileName, takeDirectory, dropExtension) import qualified Blaze.ByteString.Builder as B import qualified Blaze.ByteString.Builder.Char.Utf8 as B import qualified Data.Attoparsec.Text as P import qualified Data.Attoparsec.ByteString.Lazy as PBL import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Base64 as B64 import qualified Data.HashMap.Lazy as M import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.Text.IO as T import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Builder as TL ------------------------------------------------------------------------------- -- Loading CSS ------------------------------------------------------------------------------- -- | In the parsed CSS, this will be an image reference that we want to replace. -- the contents will be the filepath. newtype UrlReference = UrlReference T.Text deriving (Show, Eq, Hashable, Ord) type EithUrl = (T.Text, Either T.Text UrlReference) -- | The parsed CSS type Css = [(T.Text, [EithUrl])] -- | Parse the filename out of url('filename') parseUrl :: P.Parser T.Text parseUrl = do P.skipSpace void $ P.string "url('" P.takeTill (== '\'') checkForUrl :: T.Text -> T.Text -> EithUrl checkForUrl n@("background-image") v = parseBackgroundImage n v checkForUrl n@("src") v = parseBackgroundImage n v checkForUrl n v = (n, Left v) -- | Check if a given CSS attribute is a background image referencing a local file checkForImage :: T.Text -> T.Text -> EithUrl checkForImage n@("background-image") v = parseBackgroundImage n v checkForImage n v = (n, Left v) parseBackgroundImage :: T.Text -> T.Text -> EithUrl parseBackgroundImage n v = (n, case P.parseOnly parseUrl v of Left _ -> Left v -- Can't parse url Right url -> -- maybe we should find a uri parser if any (`T.isPrefixOf` url) ["http://", "https://", "/"] then Left v else Right $ UrlReference url) parseCssWith :: (T.Text -> T.Text -> EithUrl) -> T.Text -> Either String Css parseCssWith urlParser contents = let mparsed = parseBlocks contents in case mparsed of Left err -> Left err Right blocks -> Right [ (t, map (uncurry urlParser) b) | (t,b) <- blocks ] parseCssUrls :: T.Text -> Either String Css parseCssUrls = parseCssWith checkForUrl parseCssFileWith :: (T.Text -> T.Text -> EithUrl) -> FilePath -> IO Css parseCssFileWith urlParser fp = do mparsed <- parseCssWith urlParser <$> T.readFile fp case mparsed of Left err -> fail $ "Unable to parse " ++ fp ++ ": " ++ err Right css -> return css parseCssFileUrls :: FilePath -> IO Css parseCssFileUrls = parseCssFileWith checkForUrl renderCssWith :: (UrlReference -> T.Text) -> Css -> TL.Text renderCssWith urlRenderer css = TL.toLazyText $ renderBlocks [(n, map render block) | (n,block) <- css] where render (n, Left b) = (n, b) render (n, Right f) = (n, urlRenderer f) -- | Load an image map from the images in the CSS loadImages :: FilePath -> Css -> (FilePath -> IO (Maybe a)) -> IO (M.HashMap UrlReference a) loadImages dir css loadImage = foldM load M.empty $ concat [map snd block | (_,block) <- css] where load imap (Left _) = return imap load imap (Right f) | f `M.member` imap = return imap load imap (Right f@(UrlReference path)) = do img <- loadImage (dir T.unpack path) return $ maybe imap (\i -> M.insert f i imap) img -- | If you tack on additional CSS post-processing filters, they use this as an argument. data CssGeneration = CssGeneration { cssContent :: BL.ByteString , cssStaticLocation :: Location , cssFileLocation :: FilePath } mkCssGeneration :: Location -> FilePath -> BL.ByteString -> CssGeneration mkCssGeneration loc file content = CssGeneration { cssContent = content , cssStaticLocation = loc , cssFileLocation = file } cssProductionFilter :: (FilePath -> IO BL.ByteString) -- ^ a filter to be run on production -> Location -- ^ The location the CSS file should appear in the static subsite -> FilePath -- ^ Path to the CSS file. -> Entry cssProductionFilter prodFilter loc file = def { ebHaskellName = Just $ pathToName loc , ebLocation = loc , ebMimeType = "text/css" , ebProductionContent = prodFilter file , ebDevelReload = [| develPassThrough $(litE (stringL loc)) $(litE (stringL file)) |] , ebDevelExtraFiles = Nothing } cssProductionImageFilter :: (FilePath -> IO BL.ByteString) -> Location -> FilePath -> Entry cssProductionImageFilter prodFilter loc file = (cssProductionFilter prodFilter loc file) { ebDevelReload = [| develBgImgB64 $(litE (stringL loc)) $(litE (stringL file)) |] , ebDevelExtraFiles = Just [| develExtraFiles $(litE (stringL loc)) |] } ------------------------------------------------------------------------------- -- Helpers for the generators ------------------------------------------------------------------------------- -- For development, all we need to do is update the background-image url to base64 encode it. -- We want to preserve the formatting (whitespace+newlines) during development so we do not parse -- using css-parse. Instead we write a simple custom parser. parseBackground :: Location -> FilePath -> PBL.Parser B.Builder parseBackground loc file = do void $ PBL.string "background-image" s1 <- PBL.takeWhile (\x -> x == 32 || x == 9) -- space or tab void $ PBL.word8 58 -- colon s2 <- PBL.takeWhile (\x -> x == 32 || x == 9) -- space or tab void $ PBL.string "url('" url <- PBL.takeWhile (/= 39) -- single quote void $ PBL.string "')" let b64 = B64.encode $ T.encodeUtf8 (T.pack $ takeDirectory file) <> url newUrl = B.fromString (takeFileName loc) <> B.fromString "/" <> B.fromByteString b64 return $ B.fromByteString "background-image" <> B.fromByteString s1 <> B.fromByteString ":" <> B.fromByteString s2 <> B.fromByteString "url('" <> newUrl <> B.fromByteString "')" parseDev :: Location -> FilePath -> B.Builder -> PBL.Parser B.Builder parseDev loc file b = do b' <- parseBackground loc file <|> (B.fromWord8 <$> PBL.anyWord8) (PBL.endOfInput *> (pure $! b <> b')) <|> (parseDev loc file $! b <> b') develPassThrough :: Location -> FilePath -> IO BL.ByteString develPassThrough _ = BL.readFile -- | Create the CSS during development develBgImgB64 :: Location -> FilePath -> IO BL.ByteString develBgImgB64 loc file = do ct <- BL.readFile file case PBL.eitherResult $ PBL.parse (parseDev loc file mempty) ct of Left err -> error err Right b -> return $ B.toLazyByteString b -- | Serve the extra image files during development develExtraFiles :: Location -> [T.Text] -> IO (Maybe (MimeType, BL.ByteString)) develExtraFiles loc parts = case reverse parts of (file:dir) | T.pack loc == T.intercalate "/" (reverse dir) -> do let file' = T.decodeUtf8 $ B64.decodeLenient $ T.encodeUtf8 $ T.pack $ dropExtension $ T.unpack file ct <- BL.readFile $ T.unpack file' return $ Just (defaultMimeLookup file', ct) _ -> return Nothing yesod-static-1.6.1.0/test/tests.hs0000644000000000000000000000047513674600066015146 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} import Test.Hspec import YesodStaticTest (specs) import EmbedProductionTest (embedProductionSpecs) import EmbedDevelTest (embedDevSpecs) import FileGeneratorTests (fileGenSpecs) main :: IO () main = hspec $ do specs embedProductionSpecs embedDevSpecs fileGenSpecs yesod-static-1.6.1.0/test/EmbedDevelTest.hs0000644000000000000000000000564513674600066016644 0ustar0000000000000000{-# LANGUAGE TemplateHaskell, QuasiQuotes, TypeFamilies, OverloadedStrings #-} module EmbedDevelTest where -- Tests the development mode of the embedded static subsite by -- using a custom generator testGen. import Data.Maybe (isNothing) import EmbedTestGenerator import EmbedProductionTest (findEtag) import Network.Wai.Test (SResponse(simpleHeaders)) import Test.HUnit (assertBool) import Test.Hspec (Spec) import Yesod.Core import Yesod.EmbeddedStatic import Yesod.Test mkEmbeddedStatic True "eDev" [testGen] data MyApp = MyApp { getStatic :: EmbeddedStatic } mkYesod "MyApp" [parseRoutes| /static StaticR EmbeddedStatic getStatic |] instance Yesod MyApp noCacheControl :: YesodExample site () noCacheControl = withResponse $ \r -> do liftIO $ assertBool "Cache-Control exists" $ isNothing $ lookup "Cache-Control" $ simpleHeaders r liftIO $ assertBool "Expires exists" $ isNothing $ lookup "Expires" $ simpleHeaders r embedDevSpecs :: Spec embedDevSpecs = yesodSpec (MyApp eDev) $ do ydescribe "Embedded Development Entries" $ do yit "e1 loads" $ do get $ StaticR e1 statusIs 200 assertHeader "Content-Type" "text/plain" noCacheControl bodyEquals "e1 devel" tag <- findEtag request $ do setMethod "GET" setUrl $ StaticR e1 addRequestHeader ("If-None-Match", tag) statusIs 304 yit "e2 with simulated directory" $ do get $ StaticR e2 statusIs 200 assertHeader "Content-Type" "abcdef" noCacheControl bodyEquals "e2 devel" yit "e3 without haskell name" $ do get $ StaticR $ embeddedResourceR ["xxxx", "e3"] [] statusIs 200 assertHeader "Content-Type" "yyy" noCacheControl bodyEquals "e3 devel" yit "e4 loads" $ do get $ StaticR e4 statusIs 200 assertHeader "Content-Type" "text/plain" noCacheControl bodyEquals "e4 devel" yit "e4 extra development dev1" $ do get $ StaticR $ embeddedResourceR ["dev1"] [] statusIs 200 assertHeader "Content-Type" "mime" noCacheControl bodyEquals "dev1 content" tag <- findEtag request $ do setMethod "GET" setUrl $ StaticR $ embeddedResourceR ["dev1"] [] addRequestHeader ("If-None-Match", tag) statusIs 304 yit "e4 extra development with path" $ do get $ StaticR $ embeddedResourceR ["dir", "dev2"] [] statusIs 200 assertHeader "Content-Type" "mime2" noCacheControl bodyEquals "dev2 content" yit "extra development file 404" $ do get $ StaticR $ embeddedResourceR ["xxxxxxxxxx"] [] statusIs 404 yesod-static-1.6.1.0/test/EmbedProductionTest.hs0000644000000000000000000001000313674600066017713 0ustar0000000000000000{-# LANGUAGE TemplateHaskell, QuasiQuotes, TypeFamilies, OverloadedStrings #-} {-# LANGUAGE LambdaCase #-} module EmbedProductionTest where -- Tests the production mode of the embedded static subsite by -- using a custom generator testGen. Also tests that the widget -- content is embedded properly. import Data.Maybe (isJust) import EmbedTestGenerator import Network.Wai.Test (SResponse(simpleHeaders)) import Test.HUnit (assertFailure, assertBool) import Test.Hspec (Spec) import Yesod.Core import Yesod.EmbeddedStatic import Yesod.Test import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Encoding as TL mkEmbeddedStatic False "eProduction" [testGen] data MyApp = MyApp { getStatic :: EmbeddedStatic } mkYesod "MyApp" [parseRoutes| / HomeR GET /static StaticR EmbeddedStatic getStatic |] getHomeR :: Handler Html getHomeR = defaultLayout $ do toWidget [julius|console.log("Hello World");|] [whamlet|

Hello|] instance Yesod MyApp where addStaticContent = embedStaticContent getStatic StaticR Right findEtag :: YesodExample site B.ByteString findEtag = withResponse $ \r -> case lookup "ETag" (simpleHeaders r) of Nothing -> liftIO (assertFailure "No etag found") >> error "" Just e -> return e hasCacheControl :: YesodExample site () hasCacheControl = withResponse $ \r -> do liftIO $ assertBool "Cache-Control missing" $ isJust $ lookup "Cache-Control" $ simpleHeaders r liftIO $ assertBool "Expires missing" $ isJust $ lookup "Expires" $ simpleHeaders r embedProductionSpecs :: Spec embedProductionSpecs = yesodSpec (MyApp eProduction) $ do ydescribe "Embedded Production Entries" $ do yit "e1 loads" $ do get $ StaticR e1 statusIs 200 assertHeader "Content-Type" "text/plain" hasCacheControl bodyEquals "e1 production" tag <- findEtag request $ do setMethod "GET" setUrl $ StaticR e1 addRequestHeader ("If-None-Match", tag) statusIs 304 yit "e1 with custom built path" $ do get $ StaticR $ embeddedResourceR ["e1"] [] statusIs 200 assertHeader "Content-Type" "text/plain" hasCacheControl bodyEquals "e1 production" yit "e2 with simulated directory" $ do get $ StaticR e2 statusIs 200 assertHeader "Content-Type" "abcdef" hasCacheControl bodyEquals "e2 production" yit "e2 with custom built directory path" $ do get $ StaticR $ embeddedResourceR ["dir", "e2"] [] statusIs 200 assertHeader "Content-Type" "abcdef" hasCacheControl bodyEquals "e2 production" yit "e3 without haskell name" $ do get $ StaticR $ embeddedResourceR ["xxxx", "e3"] [] statusIs 200 assertHeader "Content-Type" "yyy" hasCacheControl bodyEquals "e3 production" yit "e4 is embedded" $ do get $ StaticR e4 statusIs 200 assertHeader "Content-Type" "text/plain" hasCacheControl bodyEquals "e4 production" yit "e4 extra development files are not embedded" $ do get $ StaticR $ embeddedResourceR ["dev1"] [] statusIs 404 ydescribe "Embedded Widget Content" $ yit "Embedded Javascript" $ do get HomeR statusIs 200 script <- htmlQuery "script" >>= \case [s] -> return s _ -> liftIO $ fail "Expected singleton list of script" let src = BL.takeWhile (/= 34) $ BL.drop 1 $ BL.dropWhile (/= 34) script -- 34 is " get $ TL.toStrict $ TL.decodeUtf8 src statusIs 200 hasCacheControl assertHeader "Content-Type" "application/javascript" bodyEquals "console.log(\"Hello World\");" yesod-static-1.6.1.0/test/EmbedTestGenerator.hs0000644000000000000000000000404513674600066017524 0ustar0000000000000000{-# LANGUAGE TemplateHaskell, QuasiQuotes, OverloadedStrings #-} module EmbedTestGenerator (testGen) where import Data.Default import Network.Mime (MimeType) import Yesod.EmbeddedStatic.Types import Yesod.EmbeddedStatic.Generators (pathToName) import qualified Data.Text as T import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Encoding as TL import qualified Data.ByteString.Lazy as BL e1, e2, e3, e4 :: Entry -- Basic entry e1 = def { ebHaskellName = Just $ pathToName "e1" , ebLocation = "e1" , ebMimeType = "text/plain" , ebProductionContent = return $ TL.encodeUtf8 "e1 production" , ebDevelReload = [| return $ TL.encodeUtf8 $ TL.pack "e1 devel" |] , ebDevelExtraFiles = Nothing } -- Test simulated directory in location e2 = def { ebHaskellName = Just $ pathToName "e2" , ebLocation = "dir/e2" , ebMimeType = "abcdef" , ebProductionContent = return $ TL.encodeUtf8 "e2 production" , ebDevelReload = [| return $ TL.encodeUtf8 $ TL.pack "e2 devel" |] , ebDevelExtraFiles = Nothing } -- Test empty haskell name e3 = def { ebHaskellName = Nothing , ebLocation = "xxxx/e3" , ebMimeType = "yyy" , ebProductionContent = return $ TL.encodeUtf8 "e3 production" , ebDevelReload = [| return $ TL.encodeUtf8 $ TL.pack "e3 devel" |] , ebDevelExtraFiles = Nothing } devExtra :: [T.Text] -> IO (Maybe (MimeType, BL.ByteString)) devExtra ["dev1"] = return $ Just ("mime", "dev1 content") devExtra ["dir", "dev2"] = return $ Just ("mime2", "dev2 content") devExtra _ = return Nothing -- Entry with devel extra files e4 = def { ebHaskellName = Just $ pathToName "e4" , ebLocation = "e4" , ebMimeType = "text/plain" , ebProductionContent = return $ TL.encodeUtf8 "e4 production" , ebDevelReload = [| return $ TL.encodeUtf8 $ TL.pack "e4 devel" |] , ebDevelExtraFiles = Just [| devExtra |] } testGen :: Generator testGen = return [e1, e2, e3, e4] yesod-static-1.6.1.0/test/FileGeneratorTests.hs0000644000000000000000000000756613674600066017565 0ustar0000000000000000{-# LANGUAGE TemplateHaskell, QuasiQuotes, OverloadedStrings #-} module FileGeneratorTests (fileGenSpecs) where import Control.Exception import Control.Monad (forM_) import GeneratorTestUtil import Test.Hspec import Test.HUnit (assertFailure, assertEqual) import Yesod.EmbeddedStatic.Generators import qualified Data.ByteString.Lazy as BL -- | Embeds the LICENSE file license :: GenTestResult license = $(embedFile "LICENSE" >>= testOneEntry (Just "_LICENSE") "LICENSE" (BL.readFile "LICENSE") ) licenseAt :: GenTestResult licenseAt = $(embedFileAt "abc.txt" "LICENSE" >>= testOneEntry (Just "abc_txt") "abc.txt" (BL.readFile "LICENSE") ) embDir :: [GenTestResult] embDir = $(embedDir "test/embed-dir" >>= testEntries [ (Just "abc_def_txt", "abc/def.txt", BL.readFile "test/embed-dir/abc/def.txt") , (Just "lorem_txt", "lorem.txt", BL.readFile "test/embed-dir/lorem.txt") , (Just "foo", "foo", BL.readFile "test/embed-dir/foo") ] ) embDirAt :: [GenTestResult] embDirAt = $(embedDirAt "xxx" "test/embed-dir" >>= testEntries [ (Just "xxx_abc_def_txt", "xxx/abc/def.txt", BL.readFile "test/embed-dir/abc/def.txt") , (Just "xxx_lorem_txt", "xxx/lorem.txt", BL.readFile "test/embed-dir/lorem.txt") , (Just "xxx_foo", "xxx/foo", BL.readFile "test/embed-dir/foo") ] ) concatR :: GenTestResult concatR = $(concatFiles "out.txt" [ "test/embed-dir/abc/def.txt", "test/embed-dir/foo"] >>= testOneEntry (Just "out_txt") "out.txt" (return "Yesod Rocks\nBar\n") ) -- The transform function should only run at compile for the production content concatWithR :: GenTestResult concatWithR = $(concatFilesWith "out2.txt" (\x -> return $ x `BL.append` "Extra") [ "test/embed-dir/abc/def.txt", "test/embed-dir/foo"] >>= testOneEntry (Just "out2_txt") "out2.txt" (return "Yesod Rocks\nBar\nExtra") ) fileGenSpecs :: Spec fileGenSpecs = do describe "Embed File" $ do it "embeds a single file" $ assertGenResult (BL.readFile "LICENSE") license it "embeds a single file at a location" $ assertGenResult (BL.readFile "LICENSE") licenseAt describe "Embed Directory" $ do it "embeds a directory" $ forM_ [embDir, embDirAt] $ \d -> case d of [GenError e] -> assertFailure e [def, foo, lorem] -> do assertGenResult (BL.readFile "test/embed-dir/abc/def.txt") def assertGenResult (BL.readFile "test/embed-dir/foo") foo assertGenResult (BL.readFile "test/embed-dir/lorem.txt") lorem _ -> assertFailure "Bad directory list" describe "Concat Files" $ do it "simple concat" $ assertGenResult (return "Yesod Rocks\nBar\n") concatR it "concat with processing function" $ assertGenResult (return "Yesod Rocks\nBar\n") concatWithR -- no Extra since this is development describe "Compress" $ do it "compress tool function" $ do out <- compressTool "runhaskell" [] "main = putStrLn \"Hello World\"" -- 13 == CR, to make this test work on Windows BL.filter (/= 13) out `shouldBe` "Hello World\n" it "tryCompressTools" $ do out <- flip tryCompressTools "abcdef" [ const $ throwIO $ ErrorCall "An expected error" , const $ return "foo" , const $ return "bar" ] assertEqual "" "foo" out out2 <- flip tryCompressTools "abcdef" [ const $ throwIO $ ErrorCall "An expected error"] assertEqual "" "abcdef" out2 yesod-static-1.6.1.0/test/GeneratorTestUtil.hs0000644000000000000000000000561513674600066017431 0ustar0000000000000000{-# LANGUAGE TemplateHaskell, QuasiQuotes, OverloadedStrings #-} module GeneratorTestUtil where import Control.Applicative import Control.Monad (when) import Data.List (sortBy) import Language.Haskell.TH import Test.HUnit import Yesod.EmbeddedStatic.Types as Y import qualified Data.ByteString.Lazy as BL import RIO (HasCallStack) -- We test the generators by executing them at compile time -- and sticking the result into the GenTestResult. We then -- test the GenTestResult at runtime. But to test the ebDevelReload -- we must run the action at runtime so that is also embedded. -- Because of template haskell stage restrictions, this code -- needs to be in a separate module. data GenTestResult = GenError String | GenSuccessWithDevel (IO BL.ByteString) -- | Creates a GenTestResult at compile time by testing the entry. testEntry :: Maybe String -> Y.Location -> IO BL.ByteString -> Entry -> ExpQ testEntry name _ _ e | ebHaskellName e /= (mkName Control.Applicative.<$> name) = [| GenError ("haskell name " ++ $(litE $ stringL $ show $ ebHaskellName e) ++ " /= " ++ $(litE $ stringL $ show name)) |] testEntry _ loc _ e | ebLocation e /= loc = [| GenError ("location " ++ $(litE $ stringL $ show $ ebLocation e)) |] testEntry _ _ act e = do expected <- fmap stripCR $ runIO act actual <- fmap stripCR $ runIO $ ebProductionContent e if expected == actual then [| GenSuccessWithDevel $(ebDevelReload e) |] else [| GenError $ "production content: " ++ $(litE $ stringL $ show (expected, actual)) |] -- | Remove all carriage returns, for Windows testing stripCR :: BL.ByteString -> BL.ByteString stripCR = BL.filter (/= 13) testOneEntry :: Maybe String -> Y.Location -> IO BL.ByteString -> [Entry] -> ExpQ testOneEntry name loc ct [e] = testEntry name loc ct e testOneEntry _ _ _ _ = [| GenError "not exactly one entry" |] -- | Tests a list of entries testEntries :: [(Maybe String, Y.Location, IO BL.ByteString)] -> [Entry] -> ExpQ testEntries a b | length a /= length b = [| [GenError "lengths differ"] |] testEntries a b = listE $ zipWith f a' b' where a' = sortBy (\(_,l1,_) (_,l2,_) -> compare l1 l2) a b' = sortBy (\e1 e2 -> ebLocation e1 `compare` ebLocation e2) b f (name, loc, ct) e = testEntry name loc ct e -- | Use this at runtime to assert the 'GenTestResult' is OK assertGenResult :: HasCallStack => (IO BL.ByteString) -- ^ expected development content -> GenTestResult -- ^ test result created at compile time -> Assertion assertGenResult _ (GenError e) = assertFailure ("invalid " ++ e) assertGenResult mexpected (GenSuccessWithDevel mactual) = do expected <- fmap stripCR mexpected actual <- fmap stripCR mactual when (expected /= actual) $ assertFailure $ "invalid devel content: " ++ show (expected, actual) yesod-static-1.6.1.0/test/YesodStaticTest.hs0000644000000000000000000000040113674600066017064 0ustar0000000000000000module YesodStaticTest (specs) where import Test.Hspec import Yesod.Static (getFileListPieces) specs :: Spec specs = do describe "get file list" $ do it "pieces" $ do getFileListPieces "test/fs" `shouldReturn` [["foo"], ["bar", "baz"]] yesod-static-1.6.1.0/LICENSE0000644000000000000000000000207513674600066013474 0ustar0000000000000000Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/ Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. yesod-static-1.6.1.0/Setup.lhs0000755000000000000000000000016213674600066014275 0ustar0000000000000000#!/usr/bin/env runhaskell > module Main where > import Distribution.Simple > main :: IO () > main = defaultMain yesod-static-1.6.1.0/yesod-static.cabal0000644000000000000000000001050313677404311016054 0ustar0000000000000000name: yesod-static version: 1.6.1.0 license: MIT license-file: LICENSE author: Michael Snoyman maintainer: Michael Snoyman , Greg Weber synopsis: Static file serving subsite for Yesod Web Framework. category: Web, Yesod stability: Stable cabal-version: >= 1.10 build-type: Simple homepage: http://www.yesodweb.com/ description: API docs and the README are available at extra-source-files: sample.hs sample-embed.hs test/*.hs test/fs/bar/baz test/fs/tmp/ignored test/fs/.ignored test/fs/foo test/embed-dir/foo test/embed-dir/lorem.txt test/embed-dir/abc/def.txt ChangeLog.md README.md library default-language: Haskell2010 build-depends: base >= 4.10 && < 5 , async , attoparsec >= 0.10 , base64-bytestring >= 0.1.0.1 , blaze-builder >= 0.3 , bytestring >= 0.9.1.4 , conduit >= 1.3 , containers >= 0.2 , cryptonite >= 0.11 , cryptonite-conduit >= 0.1 , css-text >= 0.1.2 , data-default , directory >= 1.0 , file-embed >= 0.0.4.1 && < 0.5 , filepath >= 1.3 , hashable >= 1.1 , hjsmin , http-types >= 0.7 , memory , mime-types >= 0.1 , process , template-haskell , text >= 0.9 , transformers >= 0.2.2 , unix-compat >= 0.2 , unordered-containers >= 0.2 , wai >= 1.3 , wai-app-static >= 3.1 , yesod-core >= 1.6 && < 1.7 exposed-modules: Yesod.Static Yesod.EmbeddedStatic Yesod.EmbeddedStatic.Generators Yesod.EmbeddedStatic.Types Yesod.EmbeddedStatic.Css.AbsoluteUrl other-modules: Yesod.EmbeddedStatic.Internal Yesod.EmbeddedStatic.Css.Util ghc-options: -Wall other-extensions: TemplateHaskell test-suite tests default-language: Haskell2010 hs-source-dirs: ., test main-is: tests.hs type: exitcode-stdio-1.0 cpp-options: -DTEST_EXPORT other-modules: EmbedDevelTest EmbedProductionTest EmbedTestGenerator FileGeneratorTests GeneratorTestUtil Yesod.EmbeddedStatic Yesod.EmbeddedStatic.Generators Yesod.EmbeddedStatic.Internal Yesod.EmbeddedStatic.Types Yesod.Static YesodStaticTest build-depends: base , hspec >= 1.3 , yesod-test >= 1.6 , wai-extra , HUnit -- copy from above , async , base64-bytestring , bytestring , conduit , containers , cryptonite , cryptonite-conduit , data-default , directory , file-embed , filepath , hjsmin , http-types , memory , mime-types , process , template-haskell , text , transformers , unix-compat , unordered-containers , wai , wai-app-static , yesod-core , rio ghc-options: -Wall -threaded other-extensions: TemplateHaskell source-repository head type: git location: https://github.com/yesodweb/yesod yesod-static-1.6.1.0/sample.hs0000644000000000000000000000113313674600066014276 0ustar0000000000000000{-# LANGUAGE QuasiQuotes, TypeFamilies, MultiParamTypeClasses #-} {-# LANGUAGE TemplateHaskell #-} import Yesod.Static import Yesod.Core import Network.Wai.Handler.Warp (run) import Network.Wai.Application.Static staticFiles "." data Sample = Sample { getStatic :: Static } --getStatic _ = Static $ defaultFileServerSettings { ssFolder = fileSystemLookup $ toFilePath "." } mkYesod "Sample" [parseRoutes| / RootR GET /static StaticR Static getStatic |] instance Yesod Sample where getRootR = do redirect "static" return () main = do s <- static "." toWaiApp (Sample s) >>= run 3000 yesod-static-1.6.1.0/sample-embed.hs0000644000000000000000000000250113674600066015350 0ustar0000000000000000{-# LANGUAGE TemplateHaskell, QuasiQuotes, TypeFamilies #-} -- | This embeds just a single file; it embeds the source code file -- \"sample-embed.hs\" from the current directory so when you compile, -- the sample-embed.hs file must be in the current directory. -- -- Try toggling the development argument to 'mkEmbeddedStatic'. When the -- development argument is true the file \"sample-embed.hs\" is reloaded -- from disk on every request (try changing it after you start the server). -- When development is false, the contents are embedded and the sample-embed.hs -- file does not even need to be present during runtime. module Main where import Yesod.Core import Yesod.EmbeddedStatic mkEmbeddedStatic False "eStatic" [embedFile "sample-embed.hs"] -- The above will generate variables -- eStatic :: EmbeddedStatic -- sample_embed_hs :: Route EmbeddedStatic data MyApp = MyApp { getStatic :: EmbeddedStatic } mkYesod "MyApp" [parseRoutes| / HomeR GET /static StaticR EmbeddedStatic getStatic |] instance Yesod MyApp where addStaticContent = embedStaticContent getStatic StaticR Right getHomeR :: Handler Html getHomeR = defaultLayout $ do toWidget [julius|console.log("Hello World");|] [whamlet|

Hello

Check the embedded file |] main :: IO () main = warp 3000 $ MyApp eStatic yesod-static-1.6.1.0/test/fs/bar/baz0000644000000000000000000000000013674600066015303 0ustar0000000000000000yesod-static-1.6.1.0/test/fs/tmp/ignored0000644000000000000000000000000013674600066016212 0ustar0000000000000000yesod-static-1.6.1.0/test/fs/.ignored0000644000000000000000000000000013674600066015470 0ustar0000000000000000yesod-static-1.6.1.0/test/fs/foo0000644000000000000000000000000013674600066014546 0ustar0000000000000000yesod-static-1.6.1.0/test/embed-dir/foo0000644000000000000000000000000413674600066015772 0ustar0000000000000000Bar yesod-static-1.6.1.0/test/embed-dir/lorem.txt0000644000000000000000000000067713674600066017163 0ustar0000000000000000Lorem ipsum dolor sit amet, consectetur adipisicing elit, sed do eiusmod tempor incididunt ut labore et dolore magna aliqua. Ut enim ad minim veniam, quis nostrud exercitation ullamco laboris nisi ut aliquip ex ea commodo consequat. Duis aute irure dolor in reprehenderit in voluptate velit esse cillum dolore eu fugiat nulla pariatur. Excepteur sint occaecat cupidatat non proident, sunt in culpa qui officia deserunt mollit anim id est laborum. yesod-static-1.6.1.0/test/embed-dir/abc/def.txt0000644000000000000000000000001413674600066017311 0ustar0000000000000000Yesod Rocks yesod-static-1.6.1.0/ChangeLog.md0000644000000000000000000000164513677403602014642 0ustar0000000000000000# ChangeLog for yesod-static ## 1.6.1.0 * Support reproducible embedded file order [#1684](https://github.com/yesodweb/yesod/issues/1684#issuecomment-652562514) ## 1.6.0.2 * Remove unnecessary deriving of Typeable ## 1.6.0.1 * Make test suite build with GHC 8.6 [#1561](https://github.com/yesodweb/yesod/pull/1561) ## 1.6.0 * Upgrade to yesod-core 1.6.0 ## 1.5.3.1 * Switch to cryptonite ## 1.5.3 * Add `staticFilesMap` function * Add `staticFilesMergeMap` function ## 1.5.2 * Fix test case for CRLF line endings * Fix warnings ## 1.5.1.1 * Fix test suite compilation ## 1.5.1 * yesod-static doesn't obey Authentication [#1286](https://github.com/yesodweb/yesod/issues/1286) ## 1.5.0.5 * Avoid lazy I/O in mkEmbeddedStatic (fixes [#149](https://github.com/yesodweb/yesod/issues/149)) ## 1.5.0.4 * Doc tweaks ## 1.5.0 * Drop system-filepath ## 1.4.0.3 Fix bug when `StaticRoute` constructor is not imported. yesod-static-1.6.1.0/README.md0000644000000000000000000000010613674600066013737 0ustar0000000000000000## yesod-static Static file serving subsite for Yesod Web Framework.