module Yesod.Static
(
Static (..)
, Route (..)
, StaticRoute
, static
, staticDevel
, embed
, combineStylesheets'
, combineScripts'
, CombineSettings
, csStaticDir
, csCssPostProcess
, csJsPostProcess
, csCssPreProcess
, csJsPreProcess
, csCombinedFolder
, staticFiles
, staticFilesList
, publicFiles
, base64md5
#ifdef TEST_EXPORT
, getFileListPieces
#endif
) where
import Prelude hiding (FilePath)
import qualified Prelude
import System.Directory
import Control.Monad
import Data.FileEmbed (embedDir)
import Yesod.Core
import Yesod.Core.Types
import Data.List (intercalate)
import Language.Haskell.TH
import Language.Haskell.TH.Syntax as TH
import Crypto.Conduit (hashFile, sinkHash)
import Crypto.Hash.MD5 (MD5)
import Control.Monad.Trans.State
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.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 Data.Conduit
import Data.Conduit.List (sourceList, consume)
import Data.Conduit.Binary (sourceFile)
import qualified Data.Conduit.Text as CT
import Data.Functor.Identity (runIdentity)
import qualified Filesystem.Path.CurrentOS as F
import Filesystem.Path.CurrentOS ((</>), (<.>), FilePath)
import Filesystem (createTree)
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.Application.Static
( StaticSettings (..)
, staticApp
, webAppSettingsWithLookup
, embeddedSettings
)
import WaiAppStatic.Storage.Filesystem (ETagLookup)
newtype Static = Static StaticSettings
type StaticRoute = Route Static
static :: Prelude.FilePath -> IO Static
static dir = do
hashLookup <- cachedETagLookup dir
return $ Static $ webAppSettingsWithLookup (F.decodeString dir) hashLookup
staticDevel :: Prelude.FilePath -> IO Static
staticDevel dir = do
hashLookup <- cachedETagLookupDevel dir
return $ Static $ webAppSettingsWithLookup (F.decodeString dir) hashLookup
embed :: Prelude.FilePath -> Q Exp
embed fp = [|Static (embeddedSettings $(embedDir fp))|]
instance RenderRoute Static where
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 m where
yesodSubDispatch YesodSubRunnerEnv {..} req =
staticApp set req
where
Static set = ysreGetSub $ yreSite $ ysreParentEnv
notHidden :: Prelude.FilePath -> Bool
notHidden "tmp" = False
notHidden s =
case s of
'.':_ -> False
_ -> True
getFileListPieces :: Prelude.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 $ 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'
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
staticFiles :: Prelude.FilePath -> Q [Dec]
staticFiles dir = mkStaticFiles dir
staticFilesList :: Prelude.FilePath -> [Prelude.FilePath] -> Q [Dec]
staticFilesList dir fs =
mkStaticFilesList dir (map split fs) "StaticRoute" True
where
split :: Prelude.FilePath -> [String]
split [] = []
split x =
let (a, b) = break (== '/') x
in a : split (drop 1 b)
publicFiles :: Prelude.FilePath -> Q [Dec]
publicFiles dir = mkStaticFiles' dir "StaticRoute" False
mkHashMap :: Prelude.FilePath -> IO (M.Map F.FilePath S8.ByteString)
mkHashMap dir = do
fs <- getFileListPieces dir
hashAlist fs >>= return . M.fromList
where
hashAlist :: [[String]] -> IO [(F.FilePath, S8.ByteString)]
hashAlist fs = mapM hashPair fs
where
hashPair :: [String] -> IO (F.FilePath, S8.ByteString)
hashPair pieces = do let file = pathFromRawPieces dir pieces
h <- base64md5File file
return (F.decodeString file, S8.pack h)
pathFromRawPieces :: Prelude.FilePath -> [String] -> Prelude.FilePath
pathFromRawPieces =
foldl' append
where
append a b = a ++ '/' : b
cachedETagLookupDevel :: Prelude.FilePath -> IO ETagLookup
cachedETagLookupDevel dir = do
etags <- mkHashMap dir
mtimeVar <- newIORef (M.empty :: M.Map F.FilePath EpochTime)
return $ \f ->
case M.lookup f etags of
Nothing -> return Nothing
Just checksum -> do
fs <- getFileStatus $ F.encodeString 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 :: Prelude.FilePath -> IO ETagLookup
cachedETagLookup dir = do
etags <- mkHashMap dir
return $ (\f -> return $ M.lookup f etags)
mkStaticFiles :: Prelude.FilePath -> Q [Dec]
mkStaticFiles fp = mkStaticFiles' fp "StaticRoute" True
mkStaticFiles' :: Prelude.FilePath
-> String
-> Bool
-> Q [Dec]
mkStaticFiles' fp routeConName makeHash = do
fs <- qRunIO $ getFileListPieces fp
mkStaticFilesList fp fs routeConName makeHash
mkStaticFilesList
:: Prelude.FilePath
-> [[String]]
-> String
-> Bool
-> Q [Dec]
mkStaticFilesList fp fs routeConName 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 f = do
let name' = intercalate "_" $ map (map replace') f
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)|]
let route = mkName routeConName
pack' <- [|pack|]
qs <- if makeHash
then do hash <- qRunIO $ base64md5File $ pathFromRawPieces fp f
[|[(pack "etag", pack $(TH.lift hash))]|]
else return $ ListE []
return
[ SigD routeName $ ConT route
, FunD routeName
[ Clause [] (NormalB $ (ConE route) `AppE` f' `AppE` qs) []
]
]
base64md5File :: Prelude.FilePath -> IO String
base64md5File = fmap (base64 . encode) . hashFile
where encode d = Data.Serialize.encode (d :: MD5)
base64md5 :: L.ByteString -> String
base64md5 lbs =
base64 $ encode
$ runIdentity
$ sourceList (L.toChunks lbs) $$ sinkHash
where
encode d = Data.Serialize.encode (d :: MD5)
base64 :: S.ByteString -> String
base64 = map tr
. take 8
. S8.unpack
. Data.ByteString.Base64.encode
where
tr '+' = '-'
tr '/' = '_'
tr c = c
data CombineType = JS | CSS
combineStatics' :: CombineType
-> CombineSettings
-> [Route Static]
-> Q Exp
combineStatics' combineType CombineSettings {..} routes = do
texts <- qRunIO $ runResourceT $ mapM_ yield fps $$ awaitForever readUTFFile =$ consume
ltext <- qRunIO $ preProcess $ TL.fromChunks texts
bs <- qRunIO $ postProcess fps $ TLE.encodeUtf8 ltext
let hash' = base64md5 bs
suffix = csCombinedFolder </> F.decodeString hash' <.> extension
fp = csStaticDir </> suffix
qRunIO $ do
createTree $ F.directory fp
L.writeFile (F.encodeString fp) bs
let pieces = map T.unpack $ T.splitOn "/" $ either id id $ F.toText suffix
[|StaticRoute (map pack pieces) []|]
where
fps :: [F.FilePath]
fps = map toFP routes
toFP (StaticRoute pieces _) = csStaticDir </> F.concat (map F.fromText pieces)
readUTFFile fp = sourceFile (F.encodeString fp) =$= CT.decode CT.utf8
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 CombineSettings = CombineSettings
{ csStaticDir :: F.FilePath
, csCssPostProcess :: [FilePath] -> L.ByteString -> IO L.ByteString
, csJsPostProcess :: [FilePath] -> L.ByteString -> IO L.ByteString
, csCssPreProcess :: TL.Text -> IO TL.Text
, csJsPreProcess :: TL.Text -> IO TL.Text
, csCombinedFolder :: FilePath
}
instance Default CombineSettings where
def = CombineSettings
{ csStaticDir = "static"
, csCssPostProcess = \fps ->
either (error . (errorIntro fps)) (return . TLE.encodeUtf8)
. flip luciusRTMinified []
. TLE.decodeUtf8
, csJsPostProcess = const return
, csCssPreProcess =
return
. TL.replace "'/static/" "'../"
. TL.replace "\"/static/" "\"../"
, csJsPreProcess = return
, csCombinedFolder = "combined"
}
errorIntro :: [FilePath] -> [Char] -> [Char]
errorIntro fps s = "Error minifying " ++ show fps ++ ": " ++ s
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))|]
combineStylesheets' :: Bool
-> CombineSettings
-> Name
-> [Route Static]
-> Q Exp
combineStylesheets' development cs con routes
| development = [| mapM_ (addStylesheet . $(return $ ConE con)) $(liftRoutes routes) |]
| otherwise = [| addStylesheet $ $(return $ ConE con) $(combineStatics' CSS cs routes) |]
combineScripts' :: Bool
-> CombineSettings
-> Name
-> [Route Static]
-> Q Exp
combineScripts' development cs con routes
| development = [| mapM_ (addScript . $(return $ ConE con)) $(liftRoutes routes) |]
| otherwise = [| addScript $ $(return $ ConE con) $(combineStatics' JS cs routes) |]