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.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 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 Data.Monoid (mempty)
import qualified Data.Map as M
import Data.IORef (readIORef, newIORef, writeIORef)
import Network.Wai (pathInfo, rawPathInfo, responseLBS)
import Data.Char (isLower, isDigit)
import Data.List (foldl')
import qualified Data.ByteString as S
import Network.HTTP.Types (status301)
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 Network.Wai.Application.Static
( StaticSettings (..)
, defaultWebAppSettings
, staticApp
, embeddedLookup
, toEmbedded
, toFilePath
, fromFilePath
, FilePath
, ETagLookup
, webAppSettingsWithLookup
)
newtype Static = Static StaticSettings
type StaticRoute = Route Static
static :: Prelude.FilePath -> IO Static
static dir = do
hashLookup <- cachedETagLookup dir
return $ Static $ webAppSettingsWithLookup (toFilePath dir) hashLookup
staticDevel :: Prelude.FilePath -> IO Static
staticDevel dir = do
hashLookup <- cachedETagLookupDevel dir
return $ Static $ webAppSettingsWithLookup (toFilePath dir) hashLookup
embed :: Prelude.FilePath -> Q Exp
embed fp =
[|Static (defaultWebAppSettings
{ ssFolder = embeddedLookup (toEmbedded $(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 _ _ _ _ _ _ [] _ req =
return $ responseLBS status301 [("Location", rawPathInfo req `S.append` "/")] ""
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 go id
where
go :: String -> ([String] -> [String]) -> IO [[String]]
go fp front = do
allContents <- filter notHidden `fmap` getDirectoryContents fp
let fullPath :: String -> String
fullPath f = fp ++ '/' : f
files <- filterM (doesFileExist . fullPath) allContents
let files' = map (front . return) files
dirs <- filterM (doesDirectoryExist . fullPath) allContents
dirs' <- mapM (\f -> go (fullPath f) (front . (:) f)) dirs
return $ concat $ files' : dirs'
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 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 (toFilePath 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 FilePath EpochTime)
return $ \f ->
case M.lookup f etags of
Nothing -> return Nothing
Just checksum -> do
fs <- getFileStatus $ fromFilePath 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 $(lift f)|]
let route = mkName routeConName
pack' <- [|pack|]
qs <- if makeHash
then do hash <- qRunIO $ base64md5File $ pathFromRawPieces fp f
[|[(pack $(lift hash), mempty)]|]
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