{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -- | Contains web handlers to serve files from a directory. module Snap.Util.FileServe ( getSafePath -- * Configuration for directory serving , MimeMap , HandlerMap , DirectoryConfig(..) , simpleDirectoryConfig , defaultDirectoryConfig , fancyDirectoryConfig , defaultIndexGenerator , defaultMimeTypes , fileType -- * File servers , serveDirectory , serveDirectoryWith , serveFile , serveFileAs ) where ------------------------------------------------------------------------------ import Blaze.ByteString.Builder import Blaze.ByteString.Builder.Char8 import Control.Applicative import Control.Exception (SomeException, evaluate) import Control.Monad import Control.Monad.CatchIO import Control.Monad.Trans import Data.Attoparsec.Char8 import qualified Data.ByteString.Char8 as S import Data.ByteString.Char8 (ByteString) import Data.ByteString.Internal (c2w) import Data.Int import Data.List import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as Map import Data.Maybe (fromMaybe, isNothing) import Data.Monoid import qualified Data.Text as T import qualified Data.Text.Encoding as T #if MIN_VERSION_base(4,6,0) import Prelude hiding (show, Show) #else import Prelude hiding (catch, show, Show) #endif import qualified Prelude import System.Directory import System.FilePath import System.PosixCompat.Files ------------------------------------------------------------------------------ import Snap.Core import Snap.Internal.Debug import Snap.Internal.Parsing import Snap.Iteratee hiding (drop) ------------------------------------------------------------------------------ -- | 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. getSafePath :: MonadSnap m => m FilePath getSafePath = do req <- getRequest let mp = urlDecode $ rqPathInfo req p <- maybe pass (return . S.unpack) 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" ), -- > ( ".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" ), -- > ( ".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" ), -- > ( ".mov" , "video/quicktime" ), -- > ( ".mp3" , "audio/mpeg" ), -- > ( ".mpeg" , "video/mpeg" ), -- > ( ".mpg" , "video/mpeg" ), -- > ( ".ogg" , "application/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" ), -- > ( ".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" ) ] -- defaultMimeTypes :: MimeMap defaultMimeTypes = Map.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" ), ( ".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" ), ( ".mov" , "video/quicktime" ), ( ".mp3" , "audio/mpeg" ), ( ".mpeg" , "video/mpeg" ), ( ".mpg" , "video/mpeg" ), ( ".ogg" , "application/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" ) ] ------------------------------------------------------------------------------ -- | 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 " |