"
writeBS ""
where
packFn fp = do
tryFirst [ T.decodeUtf8
, T.decodeUtf16LE
, T.decodeUtf16BE
, T.decodeUtf32LE
, T.decodeUtf32BE
, const (T.pack fp) ]
where
tryFirst [] = error "No valid decoding"
tryFirst (f:fs) =
evaluate (f bs) `catch` \(_::SomeException) -> tryFirst fs
bs = S.pack fp
------------------------------------------------------------------------------
-- | A very simple configuration for directory serving. This configuration
-- uses built-in MIME types from 'defaultMimeTypes', and has no index files,
-- index generator, dynamic file handlers, or 'preServeHook'.
simpleDirectoryConfig :: MonadSnap m => DirectoryConfig m
simpleDirectoryConfig = DirectoryConfig {
indexFiles = [],
indexGenerator = const pass,
dynamicHandlers = Map.empty,
mimeTypes = defaultMimeTypes,
preServeHook = const $ return ()
}
------------------------------------------------------------------------------
-- | A reasonable default configuration for directory serving. This
-- configuration uses built-in MIME types from 'defaultMimeTypes', serves
-- common index files @index.html@ and @index.htm@, but does not autogenerate
-- directory indexes, nor have any dynamic file handlers. The 'preServeHook'
-- will not do anything.
defaultDirectoryConfig :: MonadSnap m => DirectoryConfig m
defaultDirectoryConfig = DirectoryConfig {
indexFiles = ["index.html", "index.htm"],
indexGenerator = const pass,
dynamicHandlers = Map.empty,
mimeTypes = defaultMimeTypes,
preServeHook = const $ return ()
}
------------------------------------------------------------------------------
-- | A more elaborate configuration for file serving. This configuration
-- uses built-in MIME types from 'defaultMimeTypes', serves common index files
-- @index.html@ and @index.htm@, and autogenerates directory indexes with a
-- Snap-like feel. It still has no dynamic file handlers, nor 'preServeHook',
-- which should be added as needed.
--
-- Files recognized as indexes include @index.html@, @index.htm@,
-- @default.html@, @default.htm@, @home.html@
fancyDirectoryConfig :: MonadSnap m => DirectoryConfig m
fancyDirectoryConfig = DirectoryConfig {
indexFiles = ["index.html", "index.htm"],
indexGenerator = defaultIndexGenerator defaultMimeTypes snapIndexStyles,
dynamicHandlers = Map.empty,
mimeTypes = defaultMimeTypes,
preServeHook = const $ return ()
}
------------------------------------------------------------------------------
-- | Serves static files from a directory using the default configuration
-- as given in 'defaultDirectoryConfig'.
serveDirectory :: MonadSnap m
=> FilePath -- ^ Directory to serve from
-> m ()
serveDirectory = serveDirectoryWith defaultDirectoryConfig
{-# INLINE serveDirectory #-}
------------------------------------------------------------------------------
-- | Serves static files from a directory. Configuration options are
-- passed in a 'DirectoryConfig' that captures various choices about desired
-- behavior. The relative path given in 'rqPathInfo' is searched for a
-- requested 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.
serveDirectoryWith :: MonadSnap m
=> DirectoryConfig m -- ^ Configuration options
-> FilePath -- ^ Directory to serve from
-> 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
pshook = preServeHook cfg
-- Serves a file if it exists; passes if not
serve f = do
liftIO (doesFileExist f) >>= flip unless pass
let fname = takeFileName f
let staticServe f' = pshook f >> serveFileAs (fileType mimes fname) f'
lookupExt staticServe dyns fname f >> return True <|> return False
-- Serves a directory via indices if available. Returns True on success,
-- False on failure to find an index. Passes /only/ if the request was
-- not for a directory (no trailing slash).
directory = do
rq <- getRequest
let uri = uriWithoutQueryString rq
unless ("/" `S.isSuffixOf` uri) 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
-- Serves a file requested by name. Passes if the file doesn't exist.
file = serve =<< ((base ) <$> getSafePath)
-- If the request is for a directory but lacks a trailing slash, redirects
-- to the directory name with a trailing slash.
redir = do
rel <- (base ) <$> getSafePath
liftIO (doesDirectoryExist rel) >>= flip unless pass
rq <- getRequest
let uri = uriWithoutQueryString rq
let qss = queryStringSuffix rq
let u = S.concat [uri, "/", qss]
redirect u
------------------------------------------------------------------------------
-- | Serves a single file specified by a full or relative path. If the file
-- does not exist, throws an exception (not that it does /not/ pass to the
-- next handler). The path restrictions on 'serveDirectory' don't apply to
-- this function since the path is not being supplied by the user.
serveFile :: MonadSnap m
=> FilePath -- ^ path to file
-> m ()
serveFile fp = serveFileAs (fileType defaultMimeTypes (takeFileName fp)) fp
{-# INLINE serveFile #-}
------------------------------------------------------------------------------
-- | Same as 'serveFile', with control over the MIME mapping used.
serveFileAs :: MonadSnap m
=> ByteString -- ^ MIME type
-> FilePath -- ^ path to file
-> m ()
serveFileAs mime fp = do
reqOrig <- getRequest
-- If-Range header must be ignored if there is no Range: header in the
-- request (RFC 2616 section 14.27)
let req = if isNothing $ getHeader "range" reqOrig
then deleteHeader "if-range" reqOrig
else reqOrig
-- check "If-Modified-Since" and "If-Range" headers
let mbH = getHeader "if-modified-since" req
mbIfModified <- liftIO $ case mbH of
Nothing -> return Nothing
(Just s) -> liftM Just $ parseHttpTime s
-- If-Range header could contain an entity, but then parseHttpTime will
-- fail and return 0 which means a 200 response will be generated anyways
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
-- check modification time and bug out early if the file is not modified.
--
-- TODO: a stat cache would be nice here, but it'd need the date thread
-- stuff from snap-server to be folded into snap-core
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
-- ok, at this point we know the last-modified time and the
-- content-type. set those.
modifyResponse $ setHeader "Last-Modified" lm
. setHeader "Accept-Ranges" "bytes"
. setContentType mime
-- now check: is this a range request? If there is an 'If-Range' header
-- with an old modification time we skip this check and send a 200
-- response
let skipRangeCheck = maybe (False)
(\lt -> mt > lt)
mbIfRange
-- checkRangeReq checks for a Range: header in the request and sends a
-- partial response if it matches.
wasRange <- if skipRangeCheck
then return False
else liftSnap $ checkRangeReq req fp sz
dbg $ "was this a range request? " ++ Prelude.show wasRange
-- if we didn't have a range request, we just do normal sendfile
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
-- TODO/FIXME: multiple ranges
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 (sz-1) 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 = sz-1
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
-- note: start and end INCLUSIVE here
send206 start end = do
dbg "inside send206"
let len = end-start+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"
-- end here was inclusive, sendFilePartial is exclusive
sendFilePartial fp (start,end+1)
return True
send416 = do
dbg "inside send416"
-- if there's an "If-Range" header in the request, then we just send
-- back 200
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
------------------------------------------------------------------------------
uriWithoutQueryString :: Request -> ByteString
uriWithoutQueryString rq = S.takeWhile (/= '?') uri
where
uri = rqURI rq
------------------------------------------------------------------------------
queryStringSuffix :: Request -> ByteString
queryStringSuffix rq = S.concat [ s, qs ]
where
qs = rqQueryString rq
s = if S.null qs then "" else "?"