module Snap.Util.FileServe
(
getSafePath
, fileServe
, fileServe'
, fileServeSingle
, fileServeSingle'
, defaultMimeTypes
, MimeMap
) where
import Control.Applicative
import Control.Monad
import Control.Monad.Trans
import Data.Attoparsec.Char8 hiding (Done)
import qualified Data.ByteString.Char8 as S
import qualified Data.ByteString.Lazy.Char8 as L
import Data.ByteString.Char8 (ByteString)
import Data.Int
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe (fromMaybe, isNothing)
import Prelude hiding (show, Show)
import qualified Prelude
import System.Directory
import System.FilePath
import System.PosixCompat.Files
import Text.Show.ByteString hiding (runPut)
import Snap.Internal.Debug
import Snap.Internal.Parsing
import Snap.Iteratee hiding (drop)
import Snap.Types
type MimeMap = Map FilePath ByteString
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" ) ]
getSafePath :: MonadSnap m => m FilePath
getSafePath = do
req <- getRequest
let mp = urlDecode $ rqPathInfo req
p <- maybe pass (return . S.unpack) mp
when (not $ isRelative p) pass
let dirs = splitDirectories p
when (elem ".." dirs) pass
return $ joinPath dirs
fileServe :: MonadSnap m
=> FilePath
-> m ()
fileServe = fileServe' defaultMimeTypes
fileServe' :: MonadSnap m
=> MimeMap
-> FilePath
-> m ()
fileServe' mm root = do
sp <- getSafePath
let fp = root </> sp
liftIO (doesFileExist fp) >>= flip unless pass
let fn = takeFileName fp
let mime = fileType mm fn
fileServeSingle' mime fp
fileServeSingle :: MonadSnap m
=> FilePath
-> m ()
fileServeSingle fp =
fileServeSingle' (fileType defaultMimeTypes (takeFileName fp)) fp
fileServeSingle' :: MonadSnap m
=> ByteString
-> FilePath
-> m ()
fileServeSingle' mime fp = do
reqOrig <- getRequest
let req = if isNothing $ getHeader "range" reqOrig
then deleteHeader "if-range" reqOrig
else reqOrig
let mbH = getHeader "if-modified-since" req
mbIfModified <- liftIO $ case mbH of
Nothing -> return Nothing
(Just s) -> liftM Just $ parseHttpTime s
mbIfRange <- liftIO $ case getHeader "if-range" req of
Nothing -> return Nothing
(Just s) -> liftM Just $ parseHttpTime s
dbg $ "mbIfModified: " ++ Prelude.show mbIfModified
dbg $ "mbIfRange: " ++ Prelude.show mbIfRange
filestat <- liftIO $ getFileStatus fp
let mt = modificationTime filestat
maybe (return $! ()) (\lt -> when (mt <= lt) notModified) mbIfModified
let sz = fromIntegral $ fileSize filestat
lm <- liftIO $ formatHttpTime mt
modifyResponse $ setHeader "Last-Modified" lm
. setHeader "Accept-Ranges" "bytes"
. setContentType mime
let skipRangeCheck = maybe (False)
(\lt -> mt > lt)
mbIfRange
wasRange <- if skipRangeCheck
then return False
else liftSnap $ checkRangeReq req fp sz
dbg $ "was this a range request? " ++ Prelude.show wasRange
unless wasRange $ do
modifyResponse $ setResponseCode 200
. setContentLength sz
liftSnap $ sendFile fp
where
notModified = finishWith $
setResponseCode 304 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"
data RangeReq = RangeReq { _rangeFirst :: !Int64
, _rangeLast :: !(Maybe Int64)
}
| SuffixRangeReq { _suffixLength :: !Int64 }
deriving (Eq, Prelude.Show)
rangeParser :: Parser RangeReq
rangeParser = string "bytes=" *>
(byteRangeSpec <|> suffixByteRangeSpec) <*
endOfInput
where
byteRangeSpec = do
start <- parseNum
char '-'
end <- option Nothing $ liftM Just parseNum
return $ RangeReq start end
suffixByteRangeSpec = liftM SuffixRangeReq $ char '-' *> parseNum
checkRangeReq :: (MonadSnap m) => Request -> FilePath -> Int64 -> m Bool
checkRangeReq req fp sz = do
dbg $ "checkRangeReq, fp=" ++ fp ++ ", sz=" ++ Prelude.show sz
maybe (return False)
(\s -> either (const $ return False)
withRange
(fullyParse s rangeParser))
(getHeader "range" req)
where
withRange rng@(RangeReq start mend) = do
dbg $ "withRange: got Range request: " ++ Prelude.show rng
let end = fromMaybe (sz1) mend
dbg $ "withRange: start=" ++ Prelude.show start
++ ", end=" ++ Prelude.show end
if start < 0 || end < start || start >= sz || end >= sz
then send416
else send206 start end
withRange rng@(SuffixRangeReq nbytes) = do
dbg $ "withRange: got Range request: " ++ Prelude.show rng
let end = sz1
let start = sz nbytes
dbg $ "withRange: start=" ++ Prelude.show start
++ ", end=" ++ Prelude.show end
if start < 0 || end < start || start >= sz || end >= sz
then send416
else send206 start end
send206 start end = do
dbg "inside send206"
let len = endstart+1
let crng = S.concat $
L.toChunks $
L.concat [ "bytes "
, show start
, "-"
, show end
, "/"
, show sz ]
modifyResponse $ setResponseCode 206
. setHeader "Content-Range" crng
. setContentLength len
dbg $ "send206: sending range (" ++ Prelude.show start
++ "," ++ Prelude.show (end+1) ++ ") to sendFilePartial"
sendFilePartial fp (start,end+1)
return True
send416 = do
dbg "inside send416"
if getHeader "If-Range" req /= Nothing
then return False
else do
let crng = S.concat $
L.toChunks $
L.concat ["bytes */", show sz]
modifyResponse $ setResponseCode 416
. setHeader "Content-Range" crng
. setContentLength 0
. deleteHeader "Content-Type"
. deleteHeader "Content-Encoding"
. deleteHeader "Transfer-Encoding"
. setResponseBody (enumBS "")
return True
dbg :: (MonadIO m) => String -> m ()
dbg s = debug $ "FileServe:" ++ s