module Yesod.Static
(
Static (..)
, StaticRoute (..)
, static
, staticDevel
, embed
, staticFiles
, staticFilesList
, publicFiles
, base64md5
) where
import Prelude hiding (FilePath)
import qualified Prelude
import System.Directory
import Control.Monad
import Data.FileEmbed (embedDir)
import Yesod.Handler
import Yesod.Core
import Data.List (intercalate)
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
import qualified Data.ByteString.Lazy as L
import Data.Digest.Pure.MD5
import qualified Data.ByteString.Base64
import qualified Data.ByteString.Char8 as S8
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 qualified Data.Enumerator as E
import qualified Data.Enumerator.List as EL
import qualified Data.Enumerator.Binary as EB
import Network.Wai.Application.Static
( StaticSettings (..)
, defaultWebAppSettings
, staticApp
, embeddedLookup
, toEmbedded
, toFilePath
, fromFilePath
, FilePath
, ETagLookup
, webAppSettingsWithLookup
)
newtype Static = Static StaticSettings
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))
})|]
data StaticRoute = StaticRoute [Text] [(Text, Text)]
deriving (Eq, Show, Read)
type instance Route Static = StaticRoute
instance RenderRoute StaticRoute where
renderRoute (StaticRoute x y) = (x, y)
instance Yesod master => YesodDispatch Static master where
yesodDispatch _ _ [] _ _ = Just $
\req -> return $ responseLBS status301 [("Location", rawPathInfo req `S.append` "/")] ""
yesodDispatch (Static set) _ textPieces _ _ = Just $
\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 file = do
bss <- E.run_ $ EB.enumFile file E.$$ EL.consume
return $ base64md5 $ L.fromChunks bss
base64md5 :: L.ByteString -> String
base64md5 = base64 . md5
base64 :: MD5Digest -> String
base64 = map tr
. take 8
. S8.unpack
. Data.ByteString.Base64.encode
. Data.Serialize.encode
where
tr '+' = '-'
tr '/' = '_'
tr c = c