module Snap.Util.FileServe
(
getSafePath
, MimeMap
, HandlerMap
, DirectoryConfig(..)
, simpleDirectoryConfig
, defaultDirectoryConfig
, fancyDirectoryConfig
, defaultIndexGenerator
, defaultMimeTypes
, serveDirectory
, serveDirectoryWith
, serveFile
, serveFileAs
, 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
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
type HandlerMap m = Map FilePath (FilePath -> m ())
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" ) ]
data DirectoryConfig m = DirectoryConfig {
indexFiles :: [FilePath],
indexGenerator :: FilePath -> m (),
dynamicHandlers :: HandlerMap m,
mimeTypes :: MimeMap
}
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}"
defaultIndexGenerator :: MonadSnap m
=> MimeMap
-> ByteString
-> FilePath
-> m ()
defaultIndexGenerator mm styles d = do
modifyResponse $ setContentType "text/html"
rq <- getRequest
writeBS "<style type='text/css'>"
writeBS styles
writeBS "</style><div class=\"header\">Directory Listing: "
writeBS (rqURI rq)
writeBS "</div><div class=\"content\">"
writeBS "<table><tr><th>File Name</th><th>Type</th><th>Last Modified"
writeBS "</th></tr>"
when (rqURI rq /= "/") $
writeBS "<tr><td><a href='../'>..</a></td><td colspan=2>DIR</td></tr>"
entries <- liftIO $ getDirectoryContents d
dirs <- liftIO $ filterM (doesDirectoryExist . (d </>)) entries
files <- liftIO $ filterM (doesFileExist . (d </>)) entries
forM_ (sort $ filter (not . (`elem` ["..", "."])) dirs) $ \f -> do
writeBS "<tr><td><a href='"
writeBS (S.pack f)
writeBS "/'>"
writeBS (S.pack f)
writeBS "</a></td><td colspan=2>DIR</td></tr>"
forM_ (sort files) $ \f -> do
stat <- liftIO $ getFileStatus (d </> f)
tm <- liftIO $ formatHttpTime (modificationTime stat)
writeBS "<tr><td><a href='"
writeBS (S.pack f)
writeBS "'>"
writeBS (S.pack f)
writeBS "</a></td><td>"
writeBS (fileType mm f)
writeBS "</td><td>"
writeBS tm
writeBS "</tr>"
writeBS "</table></div><div class=\"footer\">Powered by "
writeBS "<b><a href=\"http://snapframework.com\">Snap</a></b></div>"
simpleDirectoryConfig :: MonadSnap m => DirectoryConfig m
simpleDirectoryConfig = DirectoryConfig {
indexFiles = [],
indexGenerator = const pass,
dynamicHandlers = Map.empty,
mimeTypes = defaultMimeTypes
}
defaultDirectoryConfig :: MonadSnap m => DirectoryConfig m
defaultDirectoryConfig = DirectoryConfig {
indexFiles = ["index.html", "index.htm"],
indexGenerator = const pass,
dynamicHandlers = Map.empty,
mimeTypes = defaultMimeTypes
}
fancyDirectoryConfig :: MonadSnap m => DirectoryConfig m
fancyDirectoryConfig = DirectoryConfig {
indexFiles = ["index.html", "index.htm"],
indexGenerator = defaultIndexGenerator defaultMimeTypes snapIndexStyles,
dynamicHandlers = Map.empty,
mimeTypes = defaultMimeTypes
}
serveDirectory :: MonadSnap m
=> FilePath
-> m ()
serveDirectory = serveDirectoryWith defaultDirectoryConfig
serveDirectoryWith :: MonadSnap m
=> DirectoryConfig m
-> FilePath
-> m ()
serveDirectoryWith cfg base = do
b <- directory <|> file <|> redir
when (not b) pass
where
idxs = indexFiles cfg
generate = indexGenerator cfg
mimes = mimeTypes cfg
dyns = dynamicHandlers cfg
serve f = do
liftIO (doesFileExist f) >>= flip unless pass
let fname = takeFileName f
let staticServe = do serveFileAs (fileType mimes fname)
lookupExt staticServe dyns fname f >> return True <|> return False
directory = do
rq <- getRequest
unless ("/" `S.isSuffixOf` rqURI rq) pass
rel <- (base </>) <$> getSafePath
b <- liftIO $ doesDirectoryExist rel
if b then do let serveRel f = serve (rel </> f)
foldl' (<|>) pass (Prelude.map serveRel idxs)
<|> (generate rel >> return True)
<|> return False
else return False
file = serve =<< ((base </>) <$> getSafePath)
redir = do
rel <- (base </>) <$> getSafePath
liftIO (doesDirectoryExist rel) >>= flip unless pass
rq <- getRequest
redirect $ rqURI rq `S.append` "/" `S.append` rqQueryString rq
serveFile :: MonadSnap m
=> FilePath
-> m ()
serveFile fp = serveFileAs (fileType defaultMimeTypes (takeFileName fp)) fp
serveFileAs :: MonadSnap m
=> ByteString
-> FilePath
-> m ()
serveFileAs 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
lookupExt :: a -> Map FilePath a -> FilePath -> a
lookupExt def m f =
if null ext
then def
else fromMaybe (lookupExt def m (drop 1 ext)) mbe
where
ext = takeExtensions f
mbe = Map.lookup ext m
fileType :: MimeMap -> FilePath -> ByteString
fileType = lookupExt defaultMimeType
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 = toByteString $
mconcat [ fromByteString "bytes "
, fromShow start
, fromWord8 (c2w '-')
, fromShow end
, fromWord8 (c2w '/')
, fromShow 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 = toByteString $
mconcat [ fromByteString "bytes */"
, fromShow sz ]
modifyResponse $ setResponseCode 416
. setHeader "Content-Range" crng
. setContentLength 0
. deleteHeader "Content-Type"
. deleteHeader "Content-Encoding"
. deleteHeader "Transfer-Encoding"
. setResponseBody (enumBuilder mempty)
return True
dbg :: (MonadIO m) => String -> m ()
dbg s = debug $ "FileServe:" ++ s
fileServe :: MonadSnap m
=> FilePath
-> m ()
fileServe = serveDirectoryWith simpleDirectoryConfig
fileServe' :: MonadSnap m
=> MimeMap
-> FilePath
-> m ()
fileServe' mm = serveDirectoryWith (simpleDirectoryConfig { mimeTypes = mm })
fileServeSingle :: MonadSnap m
=> FilePath
-> m ()
fileServeSingle = serveFile
fileServeSingle' :: MonadSnap m
=> ByteString
-> FilePath
-> m ()
fileServeSingle' = serveFileAs