yesod-static 1.1.2.2 → 1.1.2.3
raw patch · 2 files changed
+92/−16 lines, 2 files
Files
- Yesod/Static.hs +91/−15
- yesod-static.cabal +1/−1
Yesod/Static.hs view
@@ -49,6 +49,7 @@ import Prelude hiding (FilePath) import qualified Prelude import System.Directory+import Control.Arrow (second) import Control.Monad import Data.FileEmbed (embedDir) @@ -60,17 +61,21 @@ import Crypto.Conduit (hashFile, sinkHash) import Crypto.Hash.MD5 (MD5)+import Control.Monad.Trans.State+import Control.Monad.IO.Class (liftIO) import qualified Data.ByteString.Base64 import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L import qualified Data.Serialize import Data.Text (Text, pack)+import qualified Data.Text as T+import qualified Data.Set as S import qualified Data.Map as M import Data.IORef (readIORef, newIORef, writeIORef) import Network.Wai (pathInfo) import Data.Char (isLower, isDigit)-import Data.List (foldl')+import Data.List (foldl', inits, tails) import qualified Data.ByteString as S import System.PosixCompat.Files (getFileStatus, modificationTime) import System.Posix.Types (EpochTime)@@ -116,10 +121,10 @@ -- 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. +-- 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. +-- This will cause yesod to embed those assets into the generated HTML file itself. embed :: Prelude.FilePath -> Q Exp embed fp = [|Static (embeddedSettings $(embedDir fp))|] @@ -154,19 +159,35 @@ _ -> True getFileListPieces :: Prelude.FilePath -> IO [[String]]-getFileListPieces = flip go id+getFileListPieces = flip evalStateT M.empty . flip go id where- go :: String -> ([String] -> [String]) -> IO [[String]]+ go :: String+ -> ([String] -> [String])+ -> StateT (M.Map String String) IO [[String]] go fp front = do- allContents <- filter notHidden `fmap` getDirectoryContents fp+ allContents <- liftIO $ filter notHidden `fmap` getDirectoryContents fp let fullPath :: String -> String fullPath f = fp ++ '/' : f- files <- filterM (doesFileExist . fullPath) allContents+ files <- liftIO $ filterM (doesFileExist . fullPath) allContents let files' = map (front . return) files- dirs <- filterM (doesDirectoryExist . fullPath) allContents+ files'' <- mapM dedupe files'+ dirs <- liftIO $ filterM (doesDirectoryExist . fullPath) allContents dirs' <- mapM (\f -> go (fullPath f) (front . (:) f)) dirs- return $ concat $ files' : 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. --@@ -280,14 +301,32 @@ -> Bool -- ^ append checksum query parameter -> Q [Dec] mkStaticFilesList fp fs routeConName makeHash = do- concat `fmap` mapM mkRoute fs+ let (squashedFinal, squashMap) = squashStrings ("etag" : concat fs)+ (squashedName, squashedDecl) <- mkSquashedStringsDecl squashedFinal+ let refName = mkSquashedReference squashedName squashMap+ routes <- concat `fmap` mapM (mkRoute refName) fs+ return (squashedDecl ++ routes) where replace' c | 'A' <= c && c <= 'Z' = c | 'a' <= c && c <= 'z' = c | '0' <= c && c <= '9' = c | otherwise = '_'- mkRoute f = do+ mkSquashedStringsDecl squashedFinal = do+ name <- newName "squashedStrings"+ pack' <- [|pack|]+ squashedFinal' <- lift squashedFinal+ let decl = [ SigD name (ConT ''Text)+ , FunD name+ [ Clause [] (NormalB $ pack' `AppE` squashedFinal') []+ ]+ ]+ return (name, decl)+ mkSquashedReference squashedName squashMap = \str ->+ case M.lookup str squashMap of+ Nothing -> [|pack $(lift str)|]+ Just (pos, len) -> [|T.take len (T.drop pos $(return (VarE squashedName)))|]+ mkRoute refName f = do let name' = intercalate "_" $ map (map replace') f routeName = mkName $ case () of@@ -296,12 +335,11 @@ | isDigit (head name') -> '_' : name' | isLower (head name') -> name' | otherwise -> '_' : name'- f' <- [|map pack $(lift f)|]+ f' <- ListE `fmap` mapM refName f let route = mkName routeConName- pack' <- [|pack|] qs <- if makeHash then do hash <- qRunIO $ base64md5File $ pathFromRawPieces fp f- [|[(pack "etag", pack $(lift hash))]|]+ [|[($(refName "etag"), $(refName hash))]|] else return $ ListE [] return [ SigD routeName $ ConT route@@ -309,6 +347,44 @@ [ Clause [] (NormalB $ (ConE route) `AppE` f' `AppE` qs) [] ] ]+++-- | Convert a list of 'String's into a single 'String' and a+-- 'M.Map' of the original 'String's into an offset and a length on+-- the resulting single 'String'.+squashStrings :: [String] -> (String, M.Map String (Int, Int))+squashStrings = second M.fromAscList . go 0 "" . S.toAscList . S.fromList+ where+ -- Length of the string of maximal length of characters from+ -- the end of the @lastString@ that are the same. Uses a+ -- naive algorithm.+ calculateOverlap lastString newString =+ let -- Make both strings of equal length.+ len = length lastString `min` length newString+ lastString' = reverse $ take len $ reverse lastString+ newString' = take len newString+ -- Using 'head' should be safe but we use another+ -- version to avoid unuseful messages while debugging.+ safeHead (x:_) = x+ safeHead [] = error "squashStrings/overlap: never here"+ in safeHead $ do+ (lastStringSuffix, newStringPrefix) <-+ tails lastString' `zip` reverse (inits newString')+ guard (lastStringSuffix == newStringPrefix)+ return (length lastStringSuffix)++ -- Position the new strings on the resulting string.+ go lastPos lastString (newString:nss) =+ let len = length newString+ overlap = calculateOverlap lastString newString+ thisPos = lastPos - overlap+ newLastPos = lastPos + len - overlap+ (recString, recMap) = go newLastPos newString nss+ in ( drop overlap newString ++ recString+ , (newString, (thisPos, len)) : recMap+ )+ go _ _ [] = ([], [])+ base64md5File :: Prelude.FilePath -> IO String base64md5File = fmap (base64 . encode) . hashFile
yesod-static.cabal view
@@ -1,5 +1,5 @@ name: yesod-static-version: 1.1.2.2+version: 1.1.2.3 license: MIT license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>