module Network.Wai.Middleware.Static.Caching
(
static, staticPolicy, staticPolicy', unsafeStaticPolicy, unsafeStaticPolicy'
,
CachingStrategy(..), FileMeta(..)
,
Policy, (<|>), (>->), policy, predicate
, addBase, addSlash, contains, hasPrefix, hasSuffix, noDots, isNotAbsolute, only
,
tryPolicy
) where
import Caching.ExpiringCacheMap.HashECM (newECMIO, lookupECM, CacheSettings(..), consistentDuration)
import Control.Monad.Trans (liftIO)
import Data.List
import Data.Maybe (fromMaybe)
import Data.Monoid
import Data.Time
import Data.Time.Clock.POSIX
import Network.HTTP.Types (status200, status304)
import Network.HTTP.Types.Header (RequestHeaders)
import Network.Wai
import System.Directory (doesFileExist)
import System.Locale
import System.Posix.Files
import qualified Crypto.Hash.SHA1 as SHA1
import qualified Data.ByteString as B
import qualified Data.ByteString as BS
import qualified Data.ByteString.Base16 as B16
import qualified Data.ByteString.Char8 as BSC
import qualified Data.ByteString.Lazy as BSL
import qualified Data.Map as M
import qualified Data.Text as T
import qualified System.FilePath as FP
newtype Policy = Policy { tryPolicy :: String -> Maybe String
}
data CachingStrategy
= NoCaching
| PublicStaticCaching
| CustomCaching (FileMeta -> RequestHeaders)
instance Monoid Policy where
mempty = policy Just
mappend p1 p2 = policy (maybe Nothing (tryPolicy p2) . tryPolicy p1)
policy :: (String -> Maybe String) -> Policy
policy = Policy
predicate :: (String -> Bool) -> Policy
predicate p = policy (\s -> if p s then Just s else Nothing)
infixr 5 >->
(>->) :: Policy -> Policy -> Policy
(>->) = mappend
infixr 4 <|>
(<|>) :: Policy -> Policy -> Policy
p1 <|> p2 = policy (\s -> maybe (tryPolicy p2 s) Just (tryPolicy p1 s))
addBase :: String -> Policy
addBase b = policy (Just . (b FP.</>))
addSlash :: Policy
addSlash = policy slashOpt
where slashOpt s@('/':_) = Just s
slashOpt s = Just ('/':s)
hasSuffix :: String -> Policy
hasSuffix = predicate . isSuffixOf
hasPrefix :: String -> Policy
hasPrefix = predicate . isPrefixOf
contains :: String -> Policy
contains = predicate . isInfixOf
noDots :: Policy
noDots = predicate (not . isInfixOf "..")
isNotAbsolute :: Policy
isNotAbsolute = predicate $ not . FP.isAbsolute
only :: [(String,String)] -> Policy
only al = policy (flip lookup al)
static :: IO Middleware
static = staticPolicy mempty
staticPolicy :: Policy -> IO Middleware
staticPolicy = staticPolicy' NoCaching
staticPolicy' :: CachingStrategy -> Policy -> IO Middleware
staticPolicy' cs p = unsafeStaticPolicy' cs $ noDots >-> isNotAbsolute >-> p
unsafeStaticPolicy :: Policy -> IO Middleware
unsafeStaticPolicy = unsafeStaticPolicy' NoCaching
unsafeStaticPolicy' :: CachingStrategy -> Policy -> IO Middleware
unsafeStaticPolicy' cacheStrategy p =
do getFileMeta <- initializeFileMetaCache
return $ middlewareHook getFileMeta cacheStrategy p
middlewareHook ::
(FilePath -> IO FileMeta)
-> CachingStrategy
-> Policy
-> (Request -> (Response -> IO b) -> IO b)
-> Request
-> (Response -> IO b)
-> IO b
middlewareHook getFileMeta cs p app req callback =
maybe (app req callback)
(\fp ->
do exists <- liftIO $ doesFileExist fp
if exists
then case cs of
NoCaching -> sendFile fp
_ ->
do wasNotModified <- checkNotModified fp (readHeader "If-Modified-Since") (readHeader "If-None-Match")
if wasNotModified
then sendNotModified fp
else sendFile fp
else app req callback)
(tryPolicy p $ T.unpack $ T.intercalate "/" $ pathInfo req)
where
readHeader header =
lookup header $ requestHeaders req
checkNotModified fp modSince etag =
do fm <- getFileMeta fp
return $ or [ Just (fm_lastModified fm) == modSince
, Just (fm_etag fm) == etag
]
computeHeaders fp =
case cs of
NoCaching -> return []
PublicStaticCaching ->
do fm <- getFileMeta fp
return [ ("Cache-Control", "no-transform,public,max-age=300,s-maxage=900")
, ("Last-Modified", fm_lastModified fm)
, ("ETag", fm_etag fm)
, ("Vary", "Accept-Encoding")
]
CustomCaching f ->
do fm <- getFileMeta fp
return (f fm)
sendNotModified fp =
do cacheHeaders <- computeHeaders fp
callback $ responseLBS status304 cacheHeaders BSL.empty
sendFile fp =
do let basicHeaders =
[ ("Content-Type", getMimeType fp)
]
cacheHeaders <- computeHeaders fp
let headers =
basicHeaders ++ cacheHeaders
callback $ responseFile status200 headers fp Nothing
data FileMeta
= FileMeta
{ fm_lastModified :: !BS.ByteString
, fm_etag :: !BS.ByteString
, fm_fileName :: FilePath
} deriving (Show, Eq)
initializeFileMetaCache :: IO (FilePath -> IO FileMeta)
initializeFileMetaCache =
do let cacheAccess =
consistentDuration 100 $ \state fp ->
do fileMeta <- computeFileMeta fp
return $! (state, fileMeta)
cacheTick =
do time <- getPOSIXTime
return (round (time * 100))
cacheFreq = 1
cacheLRU =
CacheWithLRUList 100 100 200
filecache <- newECMIO cacheAccess cacheTick cacheFreq cacheLRU
return (lookupECM filecache)
computeFileMeta :: FilePath -> IO FileMeta
computeFileMeta fp =
do mtime <- getModTime fp
ct <- BSL.readFile fp
return $ FileMeta
{ fm_lastModified =
BSC.pack $ formatTime defaultTimeLocale "%a, %d-%b-%Y %X %Z" mtime
, fm_etag = B16.encode (SHA1.hashlazy ct)
, fm_fileName = fp
}
getModTime :: FilePath -> IO UTCTime
getModTime fullFilePath =
do stat <- getFileStatus fullFilePath
return $ (\t -> posixSecondsToUTCTime (realToFrac t :: POSIXTime)) $ modificationTime stat
type Ascii = B.ByteString
getMimeType :: FilePath -> Ascii
getMimeType = go . extensions
where go [] = defaultMimeType
go (ext:exts) = fromMaybe (go exts) $ M.lookup ext defaultMimeTypes
extensions :: FilePath -> [String]
extensions [] = []
extensions fp = case dropWhile (/= '.') fp of
[] -> []
s -> let ext = tail s
in ext : extensions ext
defaultMimeType :: Ascii
defaultMimeType = "application/octet-stream"
defaultMimeTypes :: M.Map String Ascii
defaultMimeTypes = M.fromList [
( "asc" , "text/plain" ),
( "asf" , "video/x-ms-asf" ),
( "asx" , "video/x-ms-asf" ),
( "avi" , "video/x-msvideo" ),
( "bz2" , "application/x-bzip" ),
( "c" , "text/plain" ),
( "class" , "application/octet-stream" ),
( "conf" , "text/plain" ),
( "cpp" , "text/plain" ),
( "css" , "text/css" ),
( "cxx" , "text/plain" ),
( "dtd" , "text/xml" ),
( "dvi" , "application/x-dvi" ),
( "gif" , "image/gif" ),
( "gz" , "application/x-gzip" ),
( "hs" , "text/plain" ),
( "htm" , "text/html" ),
( "html" , "text/html" ),
( "jar" , "application/x-java-archive" ),
( "jpeg" , "image/jpeg" ),
( "jpg" , "image/jpeg" ),
( "js" , "text/javascript" ),
( "json" , "application/json" ),
( "log" , "text/plain" ),
( "m3u" , "audio/x-mpegurl" ),
( "mov" , "video/quicktime" ),
( "mp3" , "audio/mpeg" ),
( "mp4" , "video/mp4" ),
( "mpeg" , "video/mpeg" ),
( "mpg" , "video/mpeg" ),
( "ogg" , "application/ogg" ),
( "ogv" , "video/ogg" ),
( "pac" , "application/x-ns-proxy-autoconfig" ),
( "pdf" , "application/pdf" ),
( "png" , "image/png" ),
( "ps" , "application/postscript" ),
( "qt" , "video/quicktime" ),
( "sig" , "application/pgp-signature" ),
( "spl" , "application/futuresplash" ),
( "svg" , "image/svg+xml" ),
( "swf" , "application/x-shockwave-flash" ),
( "tar" , "application/x-tar" ),
( "tar.bz2" , "application/x-bzip-compressed-tar" ),
( "tar.gz" , "application/x-tgz" ),
( "tbz" , "application/x-bzip-compressed-tar" ),
( "text" , "text/plain" ),
( "tgz" , "application/x-tgz" ),
( "torrent" , "application/x-bittorrent" ),
( "ttf" , "application/x-font-truetype" ),
( "txt" , "text/plain" ),
( "wav" , "audio/x-wav" ),
( "wax" , "audio/x-ms-wax" ),
( "wma" , "audio/x-ms-wma" ),
( "wmv" , "video/x-ms-wmv" ),
( "xbm" , "image/x-xbitmap" ),
( "xml" , "text/xml" ),
( "xpm" , "image/x-xpixmap" ),
( "xwd" , "image/x-xwindowdump" ),
( "zip" , "application/zip" ) ]