diff --git a/happstack-server.cabal b/happstack-server.cabal index 9a8cc06..327a4da 100644 --- a/happstack-server.cabal +++ b/happstack-server.cabal @@ -46,6 +46,7 @@ Library Happstack.Server.Error Happstack.Server.FileServe Happstack.Server.FileServe.BuildingBlocks + Happstack.Server.FileServe.Nix Happstack.Server.I18N Happstack.Server.Internal.Compression Happstack.Server.Internal.Cookie @@ -91,7 +92,7 @@ Library filepath, hslogger >= 1.0.2, html, - monad-control >= 1.0 && < 1.1, + monad-control >= 1.0.3 && < 1.1, mtl >= 2.2 && < 2.4, parsec < 4, process, diff --git a/src/Happstack/Server/FileServe/Nix.hs b/src/Happstack/Server/FileServe/Nix.hs new file mode 100644 index 0000000..fdbf836 --- /dev/null +++ b/src/Happstack/Server/FileServe/Nix.hs @@ -0,0 +1,168 @@ +{-# LANGUAGE FlexibleContexts #-} +-- | Serve files whose on-disk timestamps are meaningless because they +-- live in the Nix store. +-- +-- On NixOS (and more generally, whenever files are served straight out +-- of @\/nix\/store@, or via a symlink into it), every file's +-- modification time is reset to a fixed epoch +-- (@1970-01-01T00:00:01Z@). 'Happstack.Server.FileServe.serveFile' and +-- 'Happstack.Server.FileServe.serveDirectory' rely on +-- 'System.Directory.getModificationTime' to generate the +-- @Last-Modified@ header used for conditional GETs, so browsers never +-- see a file as having changed after a new package is deployed, and +-- can keep serving a stale cached copy indefinitely. +-- +-- Nix store paths are content-addressed +-- (@\/nix\/store\/\-\@), so the hash itself is a perfect, +-- free entity tag: it changes whenever the file's content changes, and +-- stays fixed otherwise. The functions in this module resolve the +-- requested path (following any symlinks, such as those an activation +-- script uses to point a stable path at the current store path), +-- derive an @ETag@ from the resulting store hash, and use it to honor +-- @if-none-match@ instead of @if-modified-since@ whenever the file +-- resolves into the store. +-- +-- Use 'serveFileNix' and 'serveDirectoryNix' exactly as you would +-- 'Happstack.Server.FileServe.serveFile' and +-- 'Happstack.Server.FileServe.serveDirectory'. +module Happstack.Server.FileServe.Nix + ( -- * Serving Functions + serveFileNix + , serveFileFromNix + , serveDirectoryNix + , serveDirectoryNix' + -- * Low-Level + , sendFileResponseNix + , filePathSendFileNix + -- * Nix store hashes + , nixStoreHash + , getNixETag + ) where + +import Control.Monad (MonadPlus, msum) +import Control.Monad.Trans (MonadIO(liftIO)) +import qualified Data.Map as Map +import Data.List (stripPrefix) +import Data.Time (UTCTime) +import Happstack.Server.FileServe.BuildingBlocks + ( Browsing(..), browseIndex, combineSafe, fileServe', guessContentTypeM + , mimeTypes, renderDirectoryContents, serveFileUsing, tryIndex + ) +import Happstack.Server.Monads (ServerMonad(askRq), FilterMonad, WebMonad) +import Happstack.Server.Response (ToMessage(toResponse), forbidden, ifModifiedSince, ifNoneMatch) +import Happstack.Server.Types (Length(ContentLength), Request, Response(SendFile), RsFlags(rsfLength), nullRsFlags, setHeader) +import System.Directory (canonicalizePath, getModificationTime) +import System.IO (IOMode(ReadMode), hFileSize, withBinaryFile) + +-- | Extract the content hash from a Nix store path, if the given path +-- lies directly under @\/nix\/store@. +-- +-- >>> nixStoreHash "/nix/store/9b9f3z6y1k9vjjb3l5x1x1x1x1x1x1x1-hello-2.10/bin/hello" +-- Just "9b9f3z6y1k9vjjb3l5x1x1x1x1x1x1x1" +nixStoreHash :: FilePath -> Maybe String +nixStoreHash fp = + do rest <- stripPrefix "/nix/store/" fp + let hash = takeWhile (/= '-') rest + if length hash == 32 && all isNixBase32Char hash + then Just hash + else Nothing + where + isNixBase32Char c = c `elem` ("0123456789abcdfghijklmnpqrsvwxyz" :: String) + +-- | Resolve a 'FilePath' (following symlinks) and compute an entity +-- tag from its Nix store hash, if it has one. +-- +-- Returns 'Nothing' if the resolved path is not inside @\/nix\/store@, +-- in which case callers should fall back to modification-time based +-- caching. +getNixETag :: FilePath -> IO (Maybe String) +getNixETag fp = + do resolved <- canonicalizePath fp + return $ nixStoreHash resolved + +-- | Like 'Happstack.Server.FileServe.BuildingBlocks.sendFileResponse', +-- but prefers a Nix-store-derived @ETag@ (see 'getNixETag') over +-- @if-modified-since@ when one is available. +sendFileResponseNix :: String -- ^ content-type string + -> FilePath -- ^ file path for content to send + -> Maybe String -- ^ entity tag, see 'getNixETag' + -> Maybe UTCTime -- ^ mod-time for the file, used only when no entity tag is available + -> Request -- ^ incoming request (used to check for if-modified-since \/ if-none-match) + -> Integer -- ^ offset into file + -> Integer -- ^ number of bytes to send + -> Response +sendFileResponseNix ct filePath mEtag mModTime request offset count = + let base = setHeader "Content-Type" ct $ + SendFile 200 Map.empty (nullRsFlags { rsfLength = ContentLength }) Nothing filePath offset count + in case mEtag of + Just etag -> ifNoneMatch etag request base + Nothing -> maybe base (\modTime -> ifModifiedSince modTime request base) mModTime + +-- | Send the specified file using @sendfile()@, with a Nix-store-aware +-- @ETag@ when the file resolves into the store. +-- +-- NOTE: assumes file exists and is readable by the server. See +-- 'Happstack.Server.FileServe.BuildingBlocks.serveFileUsing'. +-- +-- WARNING: No security checks are performed. +filePathSendFileNix :: (ServerMonad m, MonadIO m) + => String -- ^ content-type string + -> FilePath -- ^ path to file on disk + -> m Response +filePathSendFileNix contentType fp = + do count <- liftIO $ withBinaryFile fp ReadMode hFileSize + modtime <- liftIO $ getModificationTime fp + etag <- liftIO $ getNixETag fp + rq <- askRq + return $ sendFileResponseNix contentType fp etag (Just modtime) rq 0 count + +-- | Like 'Happstack.Server.FileServe.serveFile', but uses +-- 'filePathSendFileNix' to serve, so files that resolve into the Nix +-- store get a content-hash @ETag@ instead of a useless, constant +-- @Last-Modified@ time. +serveFileNix :: (ServerMonad m, FilterMonad Response m, MonadIO m, MonadPlus m) => + (FilePath -> m String) -- ^ function for determining content-type of file. Typically 'Happstack.Server.FileServe.asContentType' or 'Happstack.Server.FileServe.guessContentTypeM' + -> FilePath -- ^ path to the file to serve + -> m Response +serveFileNix = serveFileUsing filePathSendFileNix + +-- | Like 'serveFileNix', but uses 'Happstack.Server.FileServe.BuildingBlocks.combineSafe' +-- to prevent directory traversal attacks when the path to the file is +-- supplied by the user. +serveFileFromNix :: (ServerMonad m, FilterMonad Response m, MonadIO m, MonadPlus m) => + FilePath -- ^ directory wherein served files must be contained + -> (FilePath -> m String) -- ^ function for determining content-type of file + -> FilePath -- ^ path to the file to serve + -> m Response +serveFileFromNix root mimeFn fp = + maybe no yes $ combineSafe root fp + where + no = forbidden $ toResponse "Directory traversal forbidden" + yes = serveFileNix mimeFn + +-- | Like 'Happstack.Server.FileServe.serveDirectory', but serves files +-- and index pages via 'filePathSendFileNix'. +serveDirectoryNix :: (WebMonad Response m, ServerMonad m, FilterMonad Response m, MonadIO m, MonadPlus m) => + Browsing -- ^ allow directory browsing + -> [FilePath] -- ^ index file names, in case the requested path is a directory + -> FilePath -- ^ file/directory to serve + -> m Response +serveDirectoryNix browsing ixFiles localPath = + serveDirectoryNix' browsing ixFiles (guessContentTypeM mimeTypes) localPath + +-- | Like 'serveDirectoryNix' but with custom mime types. +serveDirectoryNix' :: (WebMonad Response m, ServerMonad m, FilterMonad Response m, MonadIO m, MonadPlus m) + => Browsing -- ^ allow directory browsing + -> [FilePath] -- ^ index file names, in case the requested path is a directory + -> (FilePath -> m String) -- ^ function which returns the mime-type for FilePath + -> FilePath -- ^ file/directory to serve + -> m Response +serveDirectoryNix' browsing ixFiles mimeFn localPath = + fileServe' filePathSendFileNix mimeFn indexFn localPath + where + indexFn fp = + msum [ tryIndex filePathSendFileNix mimeFn ixFiles fp + , if browsing == EnableBrowsing + then browseIndex renderDirectoryContents filePathSendFileNix mimeFn ixFiles fp + else forbidden $ toResponse "Directory index forbidden" + ] diff --git a/src/Happstack/Server/Response.hs b/src/Happstack/Server/Response.hs index 18df8c7..4a5f6f8 100644 --- a/src/Happstack/Server/Response.hs +++ b/src/Happstack/Server/Response.hs @@ -24,6 +24,8 @@ module Happstack.Server.Response , resp -- * Handling if-modified-since , ifModifiedSince + -- * Handling if-none-match + , ifNoneMatch ) where #if MIN_VERSION_xhtml(3000,3,0) @@ -32,6 +34,8 @@ import qualified Data.ByteString.Builder as L import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as L import qualified Data.ByteString.Lazy.UTF8 as LU (fromString) +import Data.Char (isSpace) +import Data.List (dropWhileEnd) import qualified Data.Map as M import qualified Data.Text as T import qualified Data.Text.Encoding as T @@ -192,6 +196,50 @@ ifModifiedSince modTime request response = then noContentLength $ result 304 "" -- Not Modified else setHeader "Last-modified" repr response +-- |Honor an @if-none-match@ header in a 'Request' using a strong entity tag. +-- +-- Sets the @ETag@ header on the outgoing 'Response'. If the incoming +-- @if-none-match@ header contains a matching entity tag (or @*@), +-- returns 304 (Not Modified) instead. +-- +-- Unlike 'ifModifiedSince', this does not depend on file modification +-- times, so it stays correct even when the filesystem does not track +-- them meaningfully -- e.g. files served out of the Nix store, whose +-- timestamps are always reset to a fixed epoch. See +-- "Happstack.Server.FileServe.Nix". +ifNoneMatch :: String -- ^ entity tag for the 'Response' (with or without surrounding quotes) + -> Request -- ^ incoming request (used to check for if-none-match) + -> Response -- ^ Response to send if the tag does not match + -> Response +ifNoneMatch etag request response = + let quoted = quoteETag etag + matches = case getHeader "if-none-match" request of + Nothing -> False + Just val -> matchesETag quoted (B.unpack val) + in if matches + then noContentLength $ result 304 "" -- Not Modified + else setHeader "ETag" quoted response + +quoteETag :: String -> String +quoteETag etag@('"':_) = etag +quoteETag etag = "\"" ++ etag ++ "\"" + +matchesETag :: String -> String -> Bool +matchesETag etag headerValue = any candidateMatches (splitETags headerValue) + where + candidateMatches "*" = True + candidateMatches tag = stripWeak tag == stripWeak etag + stripWeak ('W':'/':t) = t + stripWeak t = t + +splitETags :: String -> [String] +splitETags = map trim . splitOn ',' + where + trim = dropWhileEnd isSpace . dropWhile isSpace + splitOn c s = case break (== c) s of + (a, []) -> [a] + (a, _:bs) -> a : splitOn c bs + -- | Deprecated: use 'composeFilter'. modifyResponse :: (FilterMonad a m) => (a -> a) -> m() modifyResponse = composeFilter