{-# 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 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" ) ]