module Yesod.Static
(
Static (..)
, Route (..)
, StaticRoute
, static
, staticDevel
, embed
, staticFiles
, staticFilesList
, publicFiles
, base64md5
#ifdef TEST_EXPORT
, getFileListPieces
#endif
) where
import Prelude hiding (FilePath)
import qualified Prelude
import System.Directory
import Control.Arrow (second)
import Control.Monad
import Data.FileEmbed (embedDir)
import Yesod.Core hiding (lift)
import Data.List (intercalate)
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
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', inits, tails)
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)
import Data.Functor.Identity (runIdentity)
import qualified Filesystem.Path.CurrentOS as F
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 Yesod master => YesodDispatch Static master where
yesodDispatch _ _ (Static set) _ _ _ _ textPieces _ req =
staticApp set req { pathInfo = textPieces }
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
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 = '_'
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
()
| null name' -> error "null-named file"
| isDigit (head name') -> '_' : name'
| isLower (head name') -> name'
| otherwise -> '_' : name'
f' <- ListE `fmap` mapM refName f
let route = mkName routeConName
qs <- if makeHash
then do hash <- qRunIO $ base64md5File $ pathFromRawPieces fp f
[|[($(refName "etag"), $(refName hash))]|]
else return $ ListE []
return
[ SigD routeName $ ConT route
, FunD routeName
[ Clause [] (NormalB $ (ConE route) `AppE` f' `AppE` qs) []
]
]
squashStrings :: [String] -> (String, M.Map String (Int, Int))
squashStrings = second M.fromAscList . go 0 "" . S.toAscList . S.fromList
where
calculateOverlap lastString newString =
let
len = length lastString `min` length newString
lastString' = reverse $ take len $ reverse lastString
newString' = take len newString
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)
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
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