snap-core-0.1.1: src/Snap/Util/FileServe.hs
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
-- | Contains web handlers to serve files from a directory.
module Snap.Util.FileServe
(
getSafePath
, fileServe
, fileServe'
, fileServeSingle
, fileServeSingle'
, defaultMimeTypes
, MimeMap
) where
------------------------------------------------------------------------------
import Control.Monad
import Control.Monad.Trans
import qualified Data.ByteString.Char8 as S
import Data.ByteString.Char8 (ByteString)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe (fromMaybe)
import System.Directory
import System.FilePath
import System.Posix.Files
------------------------------------------------------------------------------
import Snap.Types
------------------------------------------------------------------------------
-- | 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" ) ]
------------------------------------------------------------------------------
-- | 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 :: Snap FilePath
getSafePath = do
req <- getRequest
let p = S.unpack $ rqPathInfo req
-- check that we don't have any sneaky .. paths
let dirs = splitDirectories p
when (elem ".." dirs) pass
return p
------------------------------------------------------------------------------
-- | Serves files out of the given directory. The relative path given in
-- 'rqPathInfo' is searched for the given file, and the file is served with the
-- appropriate mime type if it is found. Absolute paths and \"@..@\" are prohibited
-- to prevent files from being served from outside the sandbox.
--
-- Uses 'defaultMimeTypes' to determine the @Content-Type@ based on the file's
-- extension.
fileServe :: FilePath -- ^ root directory
-> Snap ()
fileServe = fileServe' defaultMimeTypes
{-# INLINE fileServe #-}
------------------------------------------------------------------------------
-- | Same as 'fileServe', with control over the MIME mapping used.
fileServe' :: MimeMap -- ^ MIME type mapping
-> FilePath -- ^ root directory
-> Snap ()
fileServe' mm root = do
sp <- getSafePath
let fp = root </> sp
-- check that the file exists
liftIO (doesFileExist fp) >>= flip unless pass
let fn = takeFileName fp
let mime = fileType mm fn
fileServeSingle' mime fp
{-# INLINE fileServe' #-}
------------------------------------------------------------------------------
-- | Serves a single file specified by a full or relative path. The
-- path restrictions on fileServe don't apply to this function since
-- the path is not being supplied by the user.
fileServeSingle :: FilePath -- ^ path to file
-> Snap ()
fileServeSingle fp =
fileServeSingle' (fileType defaultMimeTypes (takeFileName fp)) fp
{-# INLINE fileServeSingle #-}
------------------------------------------------------------------------------
-- | Same as 'fileServeSingle', with control over the MIME mapping used.
fileServeSingle' :: ByteString -- ^ MIME type mapping
-> FilePath -- ^ path to file
-> Snap ()
fileServeSingle' mime fp = do
req <- getRequest
let mbH = getHeader "if-modified-since" req
mbIfModified <- liftIO $ case mbH of
Nothing -> return Nothing
(Just s) -> liftM Just $ parseHttpTime s
-- check modification time and bug out early if the file is not modified.
filestat <- liftIO $ getFileStatus fp
let mt = modificationTime filestat
maybe (return ()) (chkModificationTime mt) mbIfModified
let sz = fromEnum $ fileSize filestat
lm <- liftIO $ formatHttpTime mt
modifyResponse $ setHeader "Last-Modified" lm
. setContentType mime
. setContentLength sz
sendFile fp
where
--------------------------------------------------------------------------
chkModificationTime mt lt = when (mt <= lt) notModified
--------------------------------------------------------------------------
notModified = finishWith $
setResponseStatus 304 "Not Modified" emptyResponse
------------------------------------------------------------------------------
fileType :: MimeMap -> FilePath -> ByteString
fileType mm f =
if null ext
then defaultMimeType
else fromMaybe (fileType mm (drop 1 ext))
mbe
where
ext = takeExtensions f
mbe = Map.lookup ext mm
------------------------------------------------------------------------------
defaultMimeType :: ByteString
defaultMimeType = "application/octet-stream"