diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,31 @@ +Copyright (c) 2012-Present, Andrew Farmer +Copyright (c) 2015-Present, Alexander Thiemann + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Andrew Farmer nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Network/Wai/Middleware/Static/Caching.hs b/Network/Wai/Middleware/Static/Caching.hs new file mode 100644 --- /dev/null +++ b/Network/Wai/Middleware/Static/Caching.hs @@ -0,0 +1,344 @@ +{-# 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" ) ] diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/wai-middleware-static-caching.cabal b/wai-middleware-static-caching.cabal new file mode 100644 --- /dev/null +++ b/wai-middleware-static-caching.cabal @@ -0,0 +1,47 @@ +Name: wai-middleware-static-caching +Version: 0.6.0.1 +Synopsis: WAI middleware that serves requests to static files. +Homepage: https://github.com/agrafix/wai-middleware-static +Bug-reports: https://github.com/agrafix/wai-middleware-static/issues +License: BSD3 +License-file: LICENSE +Author: Andrew Farmer , Alexander Thiemann +Maintainer: Alexander Thiemann +Copyright: (c) 2012-2014 Andrew Farmer, (c) 2015 Alexander Thiemann +Category: Web +Stability: experimental +Build-type: Simple +Cabal-version: >= 1.10 +Description: + Fork of wai-middleware-static introducing caching: + WAI middleware that intercepts requests to static files and serves them + if they exist. Also implements caching strategies. + . + [WAI] + [wai-middleware-static] + +Library + Exposed-modules: Network.Wai.Middleware.Static.Caching + default-language: Haskell2010 + Build-depends: + base >= 4.6.0.1 && < 5, + base16-bytestring >= 0.1 && < 0.2, + bytestring >= 0.10.0.2 && < 0.11, + containers >= 0.5.0.0 && < 0.6, + cryptohash >= 0.11 && < 0.12, + directory >= 1.2.0.1 && < 1.3, + expiring-cache-map >= 0.0.5 && < 0.1, + filepath >= 1.3.0.1 && < 1.4, + http-types >= 0.8.2 && < 0.9, + mtl >= 2.1.2 && < 2.3, + old-locale >= 1.0 && < 1.1, + text >= 0.11.3.1 && < 1.3, + time >= 1.4 && < 1.5, + unix >= 2.7 && < 2.8, + wai >= 3.0.0 && < 3.1 + + GHC-options: -Wall -fno-warn-orphans + +source-repository head + type: git + location: git://github.com/agrafix/wai-middleware-static.git