|
| 1 | +{-# LANGUAGE FlexibleContexts #-} |
| 2 | +-- | Serve files whose on-disk timestamps are meaningless because they |
| 3 | +-- live in the Nix store. |
| 4 | +-- |
| 5 | +-- On NixOS (and more generally, whenever files are served straight out |
| 6 | +-- of @\/nix\/store@, or via a symlink into it), every file's |
| 7 | +-- modification time is reset to a fixed epoch |
| 8 | +-- (@1970-01-01T00:00:01Z@). 'Happstack.Server.FileServe.serveFile' and |
| 9 | +-- 'Happstack.Server.FileServe.serveDirectory' rely on |
| 10 | +-- 'System.Directory.getModificationTime' to generate the |
| 11 | +-- @Last-Modified@ header used for conditional GETs, so browsers never |
| 12 | +-- see a file as having changed after a new package is deployed, and |
| 13 | +-- can keep serving a stale cached copy indefinitely. |
| 14 | +-- |
| 15 | +-- Nix store paths are content-addressed |
| 16 | +-- (@\/nix\/store\/\<hash\>-\<name\>@), so the hash itself is a perfect, |
| 17 | +-- free entity tag: it changes whenever the file's content changes, and |
| 18 | +-- stays fixed otherwise. The functions in this module resolve the |
| 19 | +-- requested path (following any symlinks, such as those an activation |
| 20 | +-- script uses to point a stable path at the current store path), |
| 21 | +-- derive an @ETag@ from the resulting store hash, and use it to honor |
| 22 | +-- @if-none-match@ instead of @if-modified-since@ whenever the file |
| 23 | +-- resolves into the store. |
| 24 | +-- |
| 25 | +-- Use 'serveFileNix' and 'serveDirectoryNix' exactly as you would |
| 26 | +-- 'Happstack.Server.FileServe.serveFile' and |
| 27 | +-- 'Happstack.Server.FileServe.serveDirectory'. |
| 28 | +module Happstack.Server.FileServe.Nix |
| 29 | + ( -- * Serving Functions |
| 30 | + serveFileNix |
| 31 | + , serveFileFromNix |
| 32 | + , serveDirectoryNix |
| 33 | + , serveDirectoryNix' |
| 34 | + -- * Low-Level |
| 35 | + , sendFileResponseNix |
| 36 | + , filePathSendFileNix |
| 37 | + -- * Nix store hashes |
| 38 | + , nixStoreHash |
| 39 | + , getNixETag |
| 40 | + ) where |
| 41 | + |
| 42 | +import Control.Monad (MonadPlus, msum) |
| 43 | +import Control.Monad.Trans (MonadIO(liftIO)) |
| 44 | +import qualified Data.Map as Map |
| 45 | +import Data.List (stripPrefix) |
| 46 | +import Data.Time (UTCTime) |
| 47 | +import Happstack.Server.FileServe.BuildingBlocks |
| 48 | + ( Browsing(..), browseIndex, combineSafe, fileServe', guessContentTypeM |
| 49 | + , mimeTypes, renderDirectoryContents, serveFileUsing, tryIndex |
| 50 | + ) |
| 51 | +import Happstack.Server.Monads (ServerMonad(askRq), FilterMonad, WebMonad) |
| 52 | +import Happstack.Server.Response (ToMessage(toResponse), forbidden, ifModifiedSince, ifNoneMatch) |
| 53 | +import Happstack.Server.Types (Length(ContentLength), Request, Response(SendFile), RsFlags(rsfLength), nullRsFlags, setHeader) |
| 54 | +import System.Directory (canonicalizePath, getModificationTime) |
| 55 | +import System.IO (IOMode(ReadMode), hFileSize, withBinaryFile) |
| 56 | + |
| 57 | +-- | Extract the content hash from a Nix store path, if the given path |
| 58 | +-- lies directly under @\/nix\/store@. |
| 59 | +-- |
| 60 | +-- >>> nixStoreHash "/nix/store/9b9f3z6y1k9vjjb3l5x1x1x1x1x1x1x1-hello-2.10/bin/hello" |
| 61 | +-- Just "9b9f3z6y1k9vjjb3l5x1x1x1x1x1x1x1" |
| 62 | +nixStoreHash :: FilePath -> Maybe String |
| 63 | +nixStoreHash fp = |
| 64 | + do rest <- stripPrefix "/nix/store/" fp |
| 65 | + let hash = takeWhile (/= '-') rest |
| 66 | + if length hash == 32 && all isNixBase32Char hash |
| 67 | + then Just hash |
| 68 | + else Nothing |
| 69 | + where |
| 70 | + isNixBase32Char c = c `elem` ("0123456789abcdfghijklmnpqrsvwxyz" :: String) |
| 71 | + |
| 72 | +-- | Resolve a 'FilePath' (following symlinks) and compute an entity |
| 73 | +-- tag from its Nix store hash, if it has one. |
| 74 | +-- |
| 75 | +-- Returns 'Nothing' if the resolved path is not inside @\/nix\/store@, |
| 76 | +-- in which case callers should fall back to modification-time based |
| 77 | +-- caching. |
| 78 | +getNixETag :: FilePath -> IO (Maybe String) |
| 79 | +getNixETag fp = |
| 80 | + do resolved <- canonicalizePath fp |
| 81 | + return $ nixStoreHash resolved |
| 82 | + |
| 83 | +-- | Like 'Happstack.Server.FileServe.BuildingBlocks.sendFileResponse', |
| 84 | +-- but prefers a Nix-store-derived @ETag@ (see 'getNixETag') over |
| 85 | +-- @if-modified-since@ when one is available. |
| 86 | +sendFileResponseNix :: String -- ^ content-type string |
| 87 | + -> FilePath -- ^ file path for content to send |
| 88 | + -> Maybe String -- ^ entity tag, see 'getNixETag' |
| 89 | + -> Maybe UTCTime -- ^ mod-time for the file, used only when no entity tag is available |
| 90 | + -> Request -- ^ incoming request (used to check for if-modified-since \/ if-none-match) |
| 91 | + -> Integer -- ^ offset into file |
| 92 | + -> Integer -- ^ number of bytes to send |
| 93 | + -> Response |
| 94 | +sendFileResponseNix ct filePath mEtag mModTime request offset count = |
| 95 | + let base = setHeader "Content-Type" ct $ |
| 96 | + SendFile 200 Map.empty (nullRsFlags { rsfLength = ContentLength }) Nothing filePath offset count |
| 97 | + in case mEtag of |
| 98 | + Just etag -> ifNoneMatch etag request base |
| 99 | + Nothing -> maybe base (\modTime -> ifModifiedSince modTime request base) mModTime |
| 100 | + |
| 101 | +-- | Send the specified file using @sendfile()@, with a Nix-store-aware |
| 102 | +-- @ETag@ when the file resolves into the store. |
| 103 | +-- |
| 104 | +-- NOTE: assumes file exists and is readable by the server. See |
| 105 | +-- 'Happstack.Server.FileServe.BuildingBlocks.serveFileUsing'. |
| 106 | +-- |
| 107 | +-- WARNING: No security checks are performed. |
| 108 | +filePathSendFileNix :: (ServerMonad m, MonadIO m) |
| 109 | + => String -- ^ content-type string |
| 110 | + -> FilePath -- ^ path to file on disk |
| 111 | + -> m Response |
| 112 | +filePathSendFileNix contentType fp = |
| 113 | + do count <- liftIO $ withBinaryFile fp ReadMode hFileSize |
| 114 | + modtime <- liftIO $ getModificationTime fp |
| 115 | + etag <- liftIO $ getNixETag fp |
| 116 | + rq <- askRq |
| 117 | + return $ sendFileResponseNix contentType fp etag (Just modtime) rq 0 count |
| 118 | + |
| 119 | +-- | Like 'Happstack.Server.FileServe.serveFile', but uses |
| 120 | +-- 'filePathSendFileNix' to serve, so files that resolve into the Nix |
| 121 | +-- store get a content-hash @ETag@ instead of a useless, constant |
| 122 | +-- @Last-Modified@ time. |
| 123 | +serveFileNix :: (ServerMonad m, FilterMonad Response m, MonadIO m, MonadPlus m) => |
| 124 | + (FilePath -> m String) -- ^ function for determining content-type of file. Typically 'Happstack.Server.FileServe.asContentType' or 'Happstack.Server.FileServe.guessContentTypeM' |
| 125 | + -> FilePath -- ^ path to the file to serve |
| 126 | + -> m Response |
| 127 | +serveFileNix = serveFileUsing filePathSendFileNix |
| 128 | + |
| 129 | +-- | Like 'serveFileNix', but uses 'Happstack.Server.FileServe.BuildingBlocks.combineSafe' |
| 130 | +-- to prevent directory traversal attacks when the path to the file is |
| 131 | +-- supplied by the user. |
| 132 | +serveFileFromNix :: (ServerMonad m, FilterMonad Response m, MonadIO m, MonadPlus m) => |
| 133 | + FilePath -- ^ directory wherein served files must be contained |
| 134 | + -> (FilePath -> m String) -- ^ function for determining content-type of file |
| 135 | + -> FilePath -- ^ path to the file to serve |
| 136 | + -> m Response |
| 137 | +serveFileFromNix root mimeFn fp = |
| 138 | + maybe no yes $ combineSafe root fp |
| 139 | + where |
| 140 | + no = forbidden $ toResponse "Directory traversal forbidden" |
| 141 | + yes = serveFileNix mimeFn |
| 142 | + |
| 143 | +-- | Like 'Happstack.Server.FileServe.serveDirectory', but serves files |
| 144 | +-- and index pages via 'filePathSendFileNix'. |
| 145 | +serveDirectoryNix :: (WebMonad Response m, ServerMonad m, FilterMonad Response m, MonadIO m, MonadPlus m) => |
| 146 | + Browsing -- ^ allow directory browsing |
| 147 | + -> [FilePath] -- ^ index file names, in case the requested path is a directory |
| 148 | + -> FilePath -- ^ file/directory to serve |
| 149 | + -> m Response |
| 150 | +serveDirectoryNix browsing ixFiles localPath = |
| 151 | + serveDirectoryNix' browsing ixFiles (guessContentTypeM mimeTypes) localPath |
| 152 | + |
| 153 | +-- | Like 'serveDirectoryNix' but with custom mime types. |
| 154 | +serveDirectoryNix' :: (WebMonad Response m, ServerMonad m, FilterMonad Response m, MonadIO m, MonadPlus m) |
| 155 | + => Browsing -- ^ allow directory browsing |
| 156 | + -> [FilePath] -- ^ index file names, in case the requested path is a directory |
| 157 | + -> (FilePath -> m String) -- ^ function which returns the mime-type for FilePath |
| 158 | + -> FilePath -- ^ file/directory to serve |
| 159 | + -> m Response |
| 160 | +serveDirectoryNix' browsing ixFiles mimeFn localPath = |
| 161 | + fileServe' filePathSendFileNix mimeFn indexFn localPath |
| 162 | + where |
| 163 | + indexFn fp = |
| 164 | + msum [ tryIndex filePathSendFileNix mimeFn ixFiles fp |
| 165 | + , if browsing == EnableBrowsing |
| 166 | + then browseIndex renderDirectoryContents filePathSendFileNix mimeFn ixFiles fp |
| 167 | + else forbidden $ toResponse "Directory index forbidden" |
| 168 | + ] |
0 commit comments