{-# LANGUAGE OverloadedStrings #-}
-- | Serve static files, subject to a policy that can filter or
-- modify incoming URIs. The flow is (depending on cache strategy):
--
-- @
-- incoming request URI ==> policies ==> exists? ==> cached? ==> not modified
-- not cached? ==> respond
-- @
--
-- If any of the polices fail, or the file doesn't
-- exist, then the middleware gives up and calls the inner application.
-- If the file is found, the middleware chooses a content type based
-- on the file extension and returns the file contents as the response.
module Network.Wai.Middleware.Static.Caching
( -- * Middlewares
static, staticPolicy, staticPolicy', unsafeStaticPolicy, unsafeStaticPolicy'
, -- * Cache Control
CachingStrategy(..), FileMeta(..)
, -- * Policies
Policy, (<|>), (>->), policy, predicate
, addBase, addSlash, contains, hasPrefix, hasSuffix, noDots, isNotAbsolute, only
, -- * Utilities
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
-- | Take an incoming URI and optionally modify or filter it.
-- The result will be treated as a filepath.
newtype Policy = Policy { tryPolicy :: String -> Maybe String -- ^ Run a policy
}
-- | A cache strategy which should be used to
-- serve content matching a policy. Meta information is cached for a maxium of
-- 100 seconds before being recomputed.
data CachingStrategy
-- | Do not send any caching headers
= NoCaching
-- | Send common caching headers for public (non dynamic) static files
| PublicStaticCaching
-- | Compute caching headers using the user specified function.
-- See <http://www.mobify.com/blog/beginners-guide-to-http-cache-headers/> for a detailed guide
| CustomCaching (FileMeta -> RequestHeaders)
-- | Note:
-- 'mempty' == @policy Just@ (the always accepting policy)
-- 'mappend' == @>->@ (policy sequencing)
instance Monoid Policy where
mempty = policy Just
mappend p1 p2 = policy (maybe Nothing (tryPolicy p2) . tryPolicy p1)
-- | Lift a function into a 'Policy'
policy :: (String -> Maybe String) -> Policy
policy = Policy
-- | Lift a predicate into a 'Policy'
predicate :: (String -> Bool) -> Policy
predicate p = policy (\s -> if p s then Just s else Nothing)
-- | Sequence two policies. They are run from left to right. (Note: this is `mappend`)
infixr 5 >->
(>->) :: Policy -> Policy -> Policy
(>->) = mappend
-- | Choose between two policies. If the first fails, run the second.
infixr 4 <|>
(<|>) :: Policy -> Policy -> Policy
p1 <|> p2 = policy (\s -> maybe (tryPolicy p2 s) Just (tryPolicy p1 s))
-- | Add a base path to the URI
--
-- > staticPolicy (addBase "/home/user/files")
--
-- GET \"foo\/bar\" looks for \"\/home\/user\/files\/foo\/bar\"
--
addBase :: String -> Policy
addBase b = policy (Just . (b FP.</>))
-- | Add an initial slash to to the URI, if not already present.
--
-- > staticPolicy addSlash
--
-- GET \"foo\/bar\" looks for \"\/foo\/bar\"
addSlash :: Policy
addSlash = policy slashOpt
where slashOpt s@('/':_) = Just s
slashOpt s = Just ('/':s)
-- | Accept only URIs with given suffix
hasSuffix :: String -> Policy
hasSuffix = predicate . isSuffixOf
-- | Accept only URIs with given prefix
hasPrefix :: String -> Policy
hasPrefix = predicate . isPrefixOf
-- | Accept only URIs containing given string
contains :: String -> Policy
contains = predicate . isInfixOf
-- | Reject URIs containing \"..\"
noDots :: Policy
noDots = predicate (not . isInfixOf "..")
-- | Reject URIs that are absolute paths
isNotAbsolute :: Policy
isNotAbsolute = predicate $ not . FP.isAbsolute
-- | Use URI as the key to an association list, rejecting those not found.
-- The policy result is the matching value.
--
-- > staticPolicy (only [("foo/bar", "/home/user/files/bar")])
--
-- GET \"foo\/bar\" looks for \"\/home\/user\/files\/bar\"
-- GET \"baz\/bar\" doesn't match anything
--
only :: [(String,String)] -> Policy
only al = policy (flip lookup al)
-- | Serve static files out of the application root (current directory).
-- If file is found, it is streamed to the client and no further middleware is run. Disables caching.
--
-- Note: for security reasons, this uses the 'noDots' and 'isNotAbsolute' policy by default.
static :: IO Middleware
static = staticPolicy mempty
-- | Serve static files subject to a 'Policy'. Disables caching.
--
-- Note: for security reasons, this uses the 'noDots' and 'isNotAbsolute' policy by default.
staticPolicy :: Policy -> IO Middleware
staticPolicy = staticPolicy' NoCaching
-- | Serve static files subject to a 'Policy' using a specified 'CachingStrategy'
--
-- Note: for security reasons, this uses the 'noDots' and 'isNotAbsolute' policy by default.
staticPolicy' :: CachingStrategy -> Policy -> IO Middleware
staticPolicy' cs p = unsafeStaticPolicy' cs $ noDots >-> isNotAbsolute >-> p
-- | Serve static files subject to a 'Policy'. Unlike 'static' and 'staticPolicy', this
-- has no policies enabled by default, and is hence insecure. Disables caching.
unsafeStaticPolicy :: Policy -> IO Middleware
unsafeStaticPolicy = unsafeStaticPolicy' NoCaching
-- | Serve static files subject to a 'Policy'. Unlike 'static' and 'staticPolicy', this
-- has no policies enabled by default, and is hence insecure. Also allows to set a 'CachingStrategy'.
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
-- | Meta information about a file to calculate cache headers
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"
-- This list taken from snap-core's Snap.Util.FileServe
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" ) ]