{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -- | Contains web handlers to serve files from a directory. module Snap.Internal.Util.FileServe ( -- * Helper functions getSafePath -- * Configuration for directory serving , MimeMap , HandlerMap , DirectoryConfig(..) , simpleDirectoryConfig , defaultDirectoryConfig , fancyDirectoryConfig , defaultIndexGenerator , defaultMimeTypes , fileType -- * File servers , serveDirectory , serveDirectoryWith , serveFile , serveFileAs -- * Internal functions , decodeFilePath ) where ------------------------------------------------------------------------------ import Control.Applicative (Alternative ((<|>)), Applicative ((*>), (<*)), (<$>)) import Control.Exception.Lifted (SomeException, catch, evaluate) import Control.Monad (Monad ((>>), (>>=), return), filterM, forM_, liftM, unless, void, when, (=<<)) import Control.Monad.IO.Class (MonadIO (..)) import Data.Attoparsec.ByteString.Char8 (Parser, char, endOfInput, option, string) import Data.ByteString.Builder (Builder, byteString, char8, stringUtf8, toLazyByteString) import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as S (append, concat, intercalate, isSuffixOf, null, pack, takeWhile) import qualified Data.ByteString.Lazy.Char8 as L import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as Map (empty, fromList, lookup) import Data.List (drop, dropWhile, elem, filter, foldl', null, sort, (++)) import Data.Maybe (fromMaybe, isNothing) import Data.Monoid (Monoid (mappend, mconcat)) import qualified Data.Text as T (Text, pack, unpack) import qualified Data.Text.Encoding as T (decodeUtf8, encodeUtf8) import Data.Word (Word64) import Prelude (Bool (..), Eq (..), FilePath, IO, Maybe (Just, Nothing), Num (..), Ord (..), Show (show), String, const, either, flip, fromIntegral, id, maybe, not, ($), ($!), (.), (||)) import qualified Prelude import Snap.Core (MonadSnap (..), Request (rqPathInfo, rqQueryString, rqURI), deleteHeader, emptyResponse, finishWith, formatHttpTime, getHeader, getRequest, modifyResponse, parseHttpTime, pass, redirect, sendFile, sendFilePartial, setContentLength, setContentType, setHeader, setResponseBody, setResponseCode, urlDecode, writeBS) import Snap.Internal.Debug (debug) import Snap.Internal.Parsing (fullyParse, parseNum) import System.Directory (doesDirectoryExist, doesFileExist, getDirectoryContents) import System.FilePath (isRelative, joinPath, splitDirectories, takeExtensions, takeFileName, (>)) import System.PosixCompat.Files (fileSize, getFileStatus, modificationTime) ------------------------------------------------------------------------------ -- | Gets a path from the 'Request' using 'rqPathInfo' and makes sure it is -- safe to use for opening files. A path is safe if it is a relative path -- and has no ".." elements to escape the intended directory structure. -- -- Example: -- -- @ -- ghci> :set -XOverloadedStrings -- ghci> import qualified "Data.Map" as M -- ghci> import qualified "Snap.Test" as T -- ghci> import qualified "Data.ByteString.Char8" as B8 -- ghci> T.runHandler (T.get \"\/foo\/bar\" M.empty) ('getSafePath' >>= 'writeBS' . B8.pack) -- HTTP\/1.1 200 OK -- server: Snap\/test -- date: Fri, 08 Aug 2014 16:13:20 GMT -- -- foo\/bar -- ghci> T.runHandler (T.get \"\/foo\/..\/bar\" M.empty) ('getSafePath' >>= 'writeBS' . B8.pack) -- HTTP\/1.1 404 Not Found -- ... -- @ getSafePath :: MonadSnap m => m FilePath getSafePath = do req <- getRequest let mp = urlDecode $ rqPathInfo req p <- maybe pass (return . T.unpack . T.decodeUtf8) mp -- relative paths only! when (not $ isRelative p) pass -- check that we don't have any sneaky .. paths let dirs = splitDirectories p when (elem ".." dirs) pass return $! joinPath dirs ------------------------------------------------------------------------------ -- | A type alias for dynamic handlers type HandlerMap m = HashMap FilePath (FilePath -> m ()) ------------------------------------------------------------------------------ -- | A type alias for MIME type type MimeMap = HashMap FilePath ByteString ------------------------------------------------------------------------------ -- | The default set of mime type mappings we use when serving files. Its -- value: -- -- > Map.fromList [ -- > ( ".asc" , "text/plain" ), -- > ( ".asf" , "video/x-ms-asf" ), -- > ( ".asx" , "video/x-ms-asf" ), -- > ( ".au" , "audio/basic" ), -- > ( ".avi" , "video/x-msvideo" ), -- > ( ".bmp" , "image/bmp" ), -- > ( ".bz2" , "application/x-bzip" ), -- > ( ".c" , "text/plain" ), -- > ( ".class" , "application/octet-stream" ), -- > ( ".conf" , "text/plain" ), -- > ( ".cpp" , "text/plain" ), -- > ( ".css" , "text/css" ), -- > ( ".cxx" , "text/plain" ), -- > ( ".doc" , "application/msword" ), -- > ( ".docx" , S.append "application/vnd.openxmlformats-officedocument" -- > ".wordprocessingml.document" ), -- > ( ".dotx" , S.append "application/vnd.openxmlformats-officedocument" -- > ".wordprocessingml.template" ), -- > ( ".dtd" , "application/xml-dtd" ), -- > ( ".dvi" , "application/x-dvi" ), -- > ( ".exe" , "application/octet-stream" ), -- > ( ".flv" , "video/x-flv" ), -- > ( ".gif" , "image/gif" ), -- > ( ".gz" , "application/x-gzip" ), -- > ( ".hs" , "text/plain" ), -- > ( ".htm" , "text/html" ), -- > ( ".html" , "text/html" ), -- > ( ".ico" , "image/x-icon" ), -- > ( ".jar" , "application/x-java-archive" ), -- > ( ".jpeg" , "image/jpeg" ), -- > ( ".jpg" , "image/jpeg" ), -- > ( ".js" , "text/javascript" ), -- > ( ".json" , "application/json" ), -- > ( ".log" , "text/plain" ), -- > ( ".m3u" , "audio/x-mpegurl" ), -- > ( ".m3u8" , "application/x-mpegURL" ), -- > ( ".mka" , "audio/x-matroska" ), -- > ( ".mk3d" , "video/x-matroska" ), -- > ( ".mkv" , "video/x-matroska" ), -- > ( ".mov" , "video/quicktime" ), -- > ( ".mp3" , "audio/mpeg" ), -- > ( ".mp4" , "video/mp4" ), -- > ( ".mpeg" , "video/mpeg" ), -- > ( ".mpg" , "video/mpeg" ), -- > ( ".ogg" , "application/ogg" ), -- > ( ".pac" , "application/x-ns-proxy-autoconfig" ), -- > ( ".pdf" , "application/pdf" ), -- > ( ".png" , "image/png" ), -- > ( ".potx" , S.append "application/vnd.openxmlformats-officedocument" -- > ".presentationml.template" ), -- > ( ".ppsx" , S.append "application/vnd.openxmlformats-officedocument" -- > ".presentationml.slideshow" ), -- > ( ".ppt" , "application/vnd.ms-powerpoint" ), -- > ( ".pptx" , S.append "application/vnd.openxmlformats-officedocument" -- > ".presentationml.presentation" ), -- > ( ".ps" , "application/postscript" ), -- > ( ".qt" , "video/quicktime" ), -- > ( ".rtf" , "text/rtf" ), -- > ( ".sig" , "application/pgp-signature" ), -- > ( ".sldx" , S.append "application/vnd.openxmlformats-officedocument" -- > ".presentationml.slide" ), -- > ( ".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" ), -- > ( ".tif" , "image/tiff" ), -- > ( ".tiff" , "image/tiff" ), -- > ( ".tgz" , "application/x-tgz" ), -- > ( ".torrent" , "application/x-bittorrent" ), -- > ( ".ts" , "video/mp2t" ), -- > ( ".txt" , "text/plain" ), -- > ( ".wav" , "audio/x-wav" ), -- > ( ".wax" , "audio/x-ms-wax" ), -- > ( ".webm" , "video/webm" ), -- > ( ".wma" , "audio/x-ms-wma" ), -- > ( ".wmv" , "video/x-ms-wmv" ), -- > ( ".xbm" , "image/x-xbitmap" ), -- > ( ".xlam" , "application/vnd.ms-excel.addin.macroEnabled.12" ), -- > ( ".xls" , "application/vnd.ms-excel" ), -- > ( ".xlsb" , "application/vnd.ms-excel.sheet.binary.macroEnabled.12" ), -- > ( ".xlsx" , S.append "application/vnd.openxmlformats-officedocument." -- > "spreadsheetml.sheet" ), -- > ( ".xltx" , S.append "application/vnd.openxmlformats-officedocument." -- > "spreadsheetml.template" ), -- > ( ".xml" , "text/xml" ), -- > ( ".xpm" , "image/x-xpixmap" ), -- > ( ".xwd" , "image/x-xwindowdump" ), -- > ( ".zip" , "application/zip" ) ] defaultMimeTypes :: MimeMap defaultMimeTypes = Map.fromList [ ( ".asc" , "text/plain" ), ( ".asf" , "video/x-ms-asf" ), ( ".asx" , "video/x-ms-asf" ), ( ".au" , "audio/basic" ), ( ".avi" , "video/x-msvideo" ), ( ".bmp" , "image/bmp" ), ( ".bz2" , "application/x-bzip" ), ( ".c" , "text/plain" ), ( ".class" , "application/octet-stream" ), ( ".conf" , "text/plain" ), ( ".cpp" , "text/plain" ), ( ".css" , "text/css" ), ( ".cxx" , "text/plain" ), ( ".doc" , "application/msword" ), ( ".docx" , S.append "application/vnd.openxmlformats-officedocument" ".wordprocessingml.document" ), ( ".dotx" , S.append "application/vnd.openxmlformats-officedocument" ".wordprocessingml.template" ), ( ".dtd" , "application/xml-dtd" ), ( ".dvi" , "application/x-dvi" ), ( ".exe" , "application/octet-stream" ), ( ".flv" , "video/x-flv" ), ( ".gif" , "image/gif" ), ( ".gz" , "application/x-gzip" ), ( ".hs" , "text/plain" ), ( ".htm" , "text/html" ), ( ".html" , "text/html" ), ( ".ico" , "image/x-icon" ), ( ".jar" , "application/x-java-archive" ), ( ".jpeg" , "image/jpeg" ), ( ".jpg" , "image/jpeg" ), ( ".js" , "text/javascript" ), ( ".json" , "application/json" ), ( ".log" , "text/plain" ), ( ".m3u" , "audio/x-mpegurl" ), ( ".m3u8" , "application/x-mpegURL" ), ( ".mka" , "audio/x-matroska" ), ( ".mk3d" , "video/x-matroska" ), ( ".mkv" , "video/x-matroska" ), ( ".mov" , "video/quicktime" ), ( ".mp3" , "audio/mpeg" ), ( ".mp4" , "video/mp4" ), ( ".mpeg" , "video/mpeg" ), ( ".mpg" , "video/mpeg" ), ( ".ogg" , "application/ogg" ), ( ".pac" , "application/x-ns-proxy-autoconfig" ), ( ".pdf" , "application/pdf" ), ( ".png" , "image/png" ), ( ".potx" , S.append "application/vnd.openxmlformats-officedocument" ".presentationml.template" ), ( ".ppsx" , S.append "application/vnd.openxmlformats-officedocument" ".presentationml.slideshow" ), ( ".ppt" , "application/vnd.ms-powerpoint" ), ( ".pptx" , S.append "application/vnd.openxmlformats-officedocument" ".presentationml.presentation" ), ( ".ps" , "application/postscript" ), ( ".qt" , "video/quicktime" ), ( ".rtf" , "text/rtf" ), ( ".sig" , "application/pgp-signature" ), ( ".sldx" , S.append "application/vnd.openxmlformats-officedocument" ".presentationml.slide" ), ( ".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" ), ( ".tif" , "image/tiff" ), ( ".tiff" , "image/tiff" ), ( ".tgz" , "application/x-tgz" ), ( ".torrent" , "application/x-bittorrent" ), ( ".ts" , "video/mp2t" ), ( ".txt" , "text/plain" ), ( ".wav" , "audio/x-wav" ), ( ".wax" , "audio/x-ms-wax" ), ( ".webm" , "video/webm" ), ( ".wma" , "audio/x-ms-wma" ), ( ".wmv" , "video/x-ms-wmv" ), ( ".xbm" , "image/x-xbitmap" ), ( ".xlam" , "application/vnd.ms-excel.addin.macroEnabled.12" ), ( ".xls" , "application/vnd.ms-excel" ), ( ".xlsb" , "application/vnd.ms-excel.sheet.binary.macroEnabled.12" ), ( ".xlsx" , S.append "application/vnd.openxmlformats-officedocument." "spreadsheetml.sheet" ), ( ".xltx" , S.append "application/vnd.openxmlformats-officedocument." "spreadsheetml.template" ), ( ".xml" , "text/xml" ), ( ".xpm" , "image/x-xpixmap" ), ( ".xwd" , "image/x-xwindowdump" ), ( ".zip" , "application/zip" ) ] ------------------------------------------------------------------------------ -- | A collection of options for serving static files out of a directory. data DirectoryConfig m = DirectoryConfig { -- | Files to look for when a directory is requested (e.g., index.html) indexFiles :: [FilePath], -- | Handler to generate a directory listing if there is no index. indexGenerator :: FilePath -> m (), -- | Map of extensions to pass to dynamic file handlers. This could be -- used, for example, to implement CGI dispatch, pretty printing of source -- code, etc. dynamicHandlers :: HandlerMap m, -- | MIME type map to look up content types. mimeTypes :: MimeMap, -- | Handler that is called before a file is served. It will only be -- called when a file is actually found, not for generated index pages. preServeHook :: FilePath -> m () } ------------------------------------------------------------------------------ -- | Style information for the default directory index generator. snapIndexStyles :: ByteString snapIndexStyles = S.intercalate "\n" [ "body { margin: 0px 0px 0px 0px; font-family: sans-serif }" , "div.header {" , "padding: 40px 40px 0px 40px; height:35px;" , "background:rgb(25,50,87);" , "background-image:-webkit-gradient(" , "linear,left bottom,left top," , "color-stop(0.00, rgb(31,62,108))," , "color-stop(1.00, rgb(19,38,66)));" , "background-image:-moz-linear-gradient(" , "center bottom,rgb(31,62,108) 0%,rgb(19,38,66) 100%);" , "text-shadow:-1px 3px 1px rgb(16,33,57);" , "font-size:16pt; letter-spacing: 2pt; color:white;" , "border-bottom:10px solid rgb(46,93,156) }" , "div.content {" , "background:rgb(255,255,255);" , "background-image:-webkit-gradient(" , "linear,left bottom, left top," , "color-stop(0.50, rgb(255,255,255))," , "color-stop(1.00, rgb(224,234,247)));" , "background-image:-moz-linear-gradient(" , "center bottom, white 50%, rgb(224,234,247) 100%);" , "padding: 40px 40px 40px 40px }" , "div.footer {" , "padding: 16px 0px 10px 10px; height:31px;" , "border-top: 1px solid rgb(194,209,225);" , "color: rgb(160,172,186); font-size:10pt;" , "background: rgb(245,249,255) }" , "table { max-width:100%; margin: 0 auto;" `S.append` " border-collapse: collapse; }" , "tr:hover { background:rgb(256,256,224) }" , "td { border:0; font-family:monospace; padding: 2px 0; }" , "td.filename, td.type { padding-right: 2em; }" , "th { border:0; background:rgb(28,56,97);" , "text-shadow:-1px 3px 1px rgb(16,33,57); color: white}" ] ------------------------------------------------------------------------------ -- | An automatic index generator, which is fairly small and does not rely on -- any external files (which may not be there depending on external request -- routing). -- -- A 'MimeMap' is passed in to display the types of files in the directory -- listing based on their extension. Preferably, this is the same as the map -- in the 'DirectoryConfig' -- -- The styles parameter allows you to apply styles to the directory listing. -- The listing itself consists of a table, containing a header row using -- th elements, and one row per file using td elements, so styles for those -- pieces may be attached to the appropriate tags. defaultIndexGenerator :: MonadSnap m => MimeMap -- ^ MIME type mapping for reporting types -> ByteString -- ^ Style info to insert in header -> FilePath -- ^ Directory to generate index for -> m () defaultIndexGenerator mm styles d = do modifyResponse $ setContentType "text/html; charset=utf-8" rq <- getRequest let uri = uriWithoutQueryString rq let pInfo = rqPathInfo rq writeBS "\n\n
" writeBS "File Name | Type | Last Modified" writeBS " |
---|---|---|
.. | DIR | |
" writeBS f writeBS " | DIR | |
" writeBS f writeBS " | " writeBS (fileType mm f0) writeBS " | " writeBS tm writeBS " |