{-# 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 -- * File servers , serveDirectory , serveDirectoryWith , serveFile , serveFileAs -- * Deprecated interface , fileServe , fileServe' , fileServeSingle , fileServeSingle' ) where ------------------------------------------------------------------------------ import Blaze.ByteString.Builder import Blaze.ByteString.Builder.Char8 import Control.Applicative import Control.Monad import Control.Monad.Trans import Data.Attoparsec.Char8 hiding (Done) 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.Map (Map) import qualified Data.Map as Map import Data.Maybe (fromMaybe, isNothing) import Data.Monoid import Prelude hiding (show, Show) import qualified Prelude import System.Directory import System.FilePath import System.PosixCompat.Files ------------------------------------------------------------------------------ import Snap.Internal.Debug import Snap.Internal.Parsing import Snap.Iteratee hiding (drop) import Snap.Types ------------------------------------------------------------------------------ -- | 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 = Map FilePath (FilePath -> m ()) ------------------------------------------------------------------------------ -- | A type alias for MIME type type MimeMap = Map 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" ), -- > ( ".jar" , "application/x-java-archive" ), -- > ( ".jpeg" , "image/jpeg" ), -- > ( ".jpg" , "image/jpeg" ), -- > ( ".js" , "text/javascript" ), -- > ( ".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" ), -- > ( ".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" ), ( ".jar" , "application/x-java-archive" ), ( ".jpeg" , "image/jpeg" ), ( ".jpg" , "image/jpeg" ), ( ".js" , "text/javascript" ), ( ".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" ), ( ".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 } ------------------------------------------------------------------------------ -- | Style information for the default directory index generator. snapIndexStyles :: ByteString snapIndexStyles = "body { margin: 0px 0px 0px 0px; font-family: sans-serif }" `S.append` "div.header {" `S.append` "padding: 40px 40px 0px 40px; height:35px;" `S.append` "background:rgb(25,50,87);" `S.append` "background-image:-webkit-gradient(" `S.append` "linear,left bottom,left top," `S.append` "color-stop(0.00, rgb(31,62,108))," `S.append` "color-stop(1.00, rgb(19,38,66)));" `S.append` "background-image:-moz-linear-gradient(" `S.append` "center bottom,rgb(31,62,108) 0%,rgb(19,38,66) 100%);" `S.append` "text-shadow:-1px 3px 1px rgb(16,33,57);" `S.append` "font-size:16pt; letter-spacing: 2pt; color:white;" `S.append` "border-bottom:10px solid rgb(46,93,156) }" `S.append` "div.content {" `S.append` "background:rgb(255,255,255);" `S.append` "background-image:-webkit-gradient(" `S.append` "linear,left bottom, left top," `S.append` "color-stop(0.50, rgb(255,255,255))," `S.append` "color-stop(1.00, rgb(224,234,247)));" `S.append` "background-image:-moz-linear-gradient(" `S.append` "center bottom, white 50%, rgb(224,234,247) 100%);" `S.append` "padding: 40px 40px 40px 40px }" `S.append` "div.footer {" `S.append` "padding: 16px 0px 10px 10px; height:31px;" `S.append` "border-top: 1px solid rgb(194,209,225);" `S.append` "color: rgb(160,172,186); font-size:10pt;" `S.append` "background: rgb(245,249,255) }" `S.append` "table { width:100% }" `S.append` "tr:hover { background:rgb(256,256,224) }" `S.append` "td { border:dotted thin black; font-family:monospace }" `S.append` "th { border:solid thin black; background:rgb(28,56,97);" `S.append` "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" rq <- getRequest writeBS "
File Name | Type | Last Modified" writeBS " |
---|---|---|
.. | DIR | |
" writeBS (S.pack f) writeBS " | DIR | |
" writeBS (S.pack f) writeBS " | " writeBS (fileType mm f) writeBS " | " writeBS tm writeBS " |