{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Snap.Internal.Util.FileServe
(
getSafePath
, MimeMap
, HandlerMap
, DirectoryConfig(..)
, simpleDirectoryConfig
, defaultDirectoryConfig
, fancyDirectoryConfig
, defaultIndexGenerator
, defaultMimeTypes
, fileType
, serveDirectory
, serveDirectoryWith
, serveFile
, serveFileAs
, decodeFilePath
, checkRangeReq
) where
import Control.Applicative (Alternative ((<|>)), Applicative ((*>), (<*)), (<$>))
import Control.Exception.Lifted (SomeException, catch, evaluate)
import Control.Monad (Monad ((>>), (>>=), return), filterM, forM_, liftM, unless, void, when, (=<<))
import Control.Monad.IO.Class (MonadIO (..))
import Data.Attoparsec.ByteString.Char8 (Parser, char, endOfInput, option, string)
import Data.ByteString.Builder (Builder, byteString, char8, stringUtf8, toLazyByteString)
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as S (append, concat, intercalate, isSuffixOf, null, pack, takeWhile)
import qualified Data.ByteString.Lazy.Char8 as L
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as Map (empty, fromList, lookup)
import Data.List (drop, dropWhile, elem, filter, foldl', null, sort, (++))
import Data.Maybe (fromMaybe, isNothing)
import Data.Monoid (Monoid (mappend, mconcat))
import qualified Data.Text as T (Text, pack, unpack)
import qualified Data.Text.Encoding as T (decodeUtf8, encodeUtf8)
import Data.Word (Word64)
import Prelude (Bool (..), Eq (..), FilePath, IO, Maybe (Just, Nothing), Num (..), Ord (..), Show (show), String, const, either, flip, fromIntegral, id, maybe, not, ($), ($!), (.), (||))
import qualified Prelude
import Snap.Core (MonadSnap (..), Request (rqPathInfo, rqQueryString, rqURI), deleteHeader, emptyResponse, finishWith, formatHttpTime, getHeader, getRequest, modifyResponse, parseHttpTime, pass, redirect, sendFile, sendFilePartial, setContentLength, setContentType, setHeader, setResponseBody, setResponseCode, urlDecode, writeBS)
import Snap.Internal.Debug (debug)
import Snap.Internal.Parsing (fullyParse, parseNum)
import System.Directory (doesDirectoryExist, doesFileExist, getDirectoryContents)
import System.FilePath (isRelative, joinPath, splitDirectories, takeExtensions, takeFileName, (</>))
import System.PosixCompat.Files (fileSize, getFileStatus, modificationTime)
getSafePath :: MonadSnap m => m FilePath
getSafePath :: m FilePath
getSafePath = do
Request
req <- m Request
forall (m :: * -> *). MonadSnap m => m Request
getRequest
let mp :: Maybe ByteString
mp = ByteString -> Maybe ByteString
urlDecode (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ Request -> ByteString
rqPathInfo Request
req
FilePath
p <- m FilePath
-> (ByteString -> m FilePath) -> Maybe ByteString -> m FilePath
forall b a. b -> (a -> b) -> Maybe a -> b
maybe m FilePath
forall (m :: * -> *) a. MonadSnap m => m a
pass (FilePath -> m FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> m FilePath)
-> (ByteString -> FilePath) -> ByteString -> m FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FilePath
T.unpack (Text -> FilePath)
-> (ByteString -> Text) -> ByteString -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
T.decodeUtf8) Maybe ByteString
mp
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ FilePath -> Bool
isRelative FilePath
p) m ()
forall (m :: * -> *) a. MonadSnap m => m a
pass
let dirs :: [FilePath]
dirs = FilePath -> [FilePath]
splitDirectories FilePath
p
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FilePath -> [FilePath] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem FilePath
".." [FilePath]
dirs) m ()
forall (m :: * -> *) a. MonadSnap m => m a
pass
FilePath -> m FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> m FilePath) -> FilePath -> m FilePath
forall a b. (a -> b) -> a -> b
$! [FilePath] -> FilePath
joinPath [FilePath]
dirs
type HandlerMap m = HashMap FilePath (FilePath -> m ())
type MimeMap = HashMap FilePath ByteString
defaultMimeTypes :: MimeMap
defaultMimeTypes :: MimeMap
defaultMimeTypes =
[(FilePath, ByteString)] -> MimeMap
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
Map.fromList [
( FilePath
".asc" , ByteString
"text/plain" ),
( FilePath
".asf" , ByteString
"video/x-ms-asf" ),
( FilePath
".asx" , ByteString
"video/x-ms-asf" ),
( FilePath
".au" , ByteString
"audio/basic" ),
( FilePath
".avi" , ByteString
"video/x-msvideo" ),
( FilePath
".bmp" , ByteString
"image/bmp" ),
( FilePath
".bz2" , ByteString
"application/x-bzip" ),
( FilePath
".c" , ByteString
"text/plain" ),
( FilePath
".class" , ByteString
"application/octet-stream" ),
( FilePath
".conf" , ByteString
"text/plain" ),
( FilePath
".cpp" , ByteString
"text/plain" ),
( FilePath
".css" , ByteString
"text/css" ),
( FilePath
".csv" , ByteString
"text/csv" ),
( FilePath
".cxx" , ByteString
"text/plain" ),
( FilePath
".doc" , ByteString
"application/msword" ),
( FilePath
".docx" , ByteString -> ByteString -> ByteString
S.append ByteString
"application/vnd.openxmlformats-officedocument"
ByteString
".wordprocessingml.document" ),
( FilePath
".dotx" , ByteString -> ByteString -> ByteString
S.append ByteString
"application/vnd.openxmlformats-officedocument"
ByteString
".wordprocessingml.template" ),
( FilePath
".dtd" , ByteString
"application/xml-dtd" ),
( FilePath
".dvi" , ByteString
"application/x-dvi" ),
( FilePath
".exe" , ByteString
"application/octet-stream" ),
( FilePath
".flv" , ByteString
"video/x-flv" ),
( FilePath
".gif" , ByteString
"image/gif" ),
( FilePath
".gz" , ByteString
"application/x-gzip" ),
( FilePath
".hs" , ByteString
"text/plain" ),
( FilePath
".htm" , ByteString
"text/html" ),
( FilePath
".html" , ByteString
"text/html" ),
( FilePath
".ico" , ByteString
"image/x-icon" ),
( FilePath
".jar" , ByteString
"application/x-java-archive" ),
( FilePath
".jpeg" , ByteString
"image/jpeg" ),
( FilePath
".jpg" , ByteString
"image/jpeg" ),
( FilePath
".js" , ByteString
"text/javascript" ),
( FilePath
".json" , ByteString
"application/json" ),
( FilePath
".log" , ByteString
"text/plain" ),
( FilePath
".m3u" , ByteString
"audio/x-mpegurl" ),
( FilePath
".m3u8" , ByteString
"application/x-mpegURL" ),
( FilePath
".mka" , ByteString
"audio/x-matroska" ),
( FilePath
".mk3d" , ByteString
"video/x-matroska" ),
( FilePath
".mkv" , ByteString
"video/x-matroska" ),
( FilePath
".mov" , ByteString
"video/quicktime" ),
( FilePath
".mp3" , ByteString
"audio/mpeg" ),
( FilePath
".mp4" , ByteString
"video/mp4" ),
( FilePath
".mpeg" , ByteString
"video/mpeg" ),
( FilePath
".mpg" , ByteString
"video/mpeg" ),
( FilePath
".ogg" , ByteString
"application/ogg" ),
( FilePath
".pac" , ByteString
"application/x-ns-proxy-autoconfig" ),
( FilePath
".pdf" , ByteString
"application/pdf" ),
( FilePath
".png" , ByteString
"image/png" ),
( FilePath
".potx" , ByteString -> ByteString -> ByteString
S.append ByteString
"application/vnd.openxmlformats-officedocument"
ByteString
".presentationml.template" ),
( FilePath
".ppsx" , ByteString -> ByteString -> ByteString
S.append ByteString
"application/vnd.openxmlformats-officedocument"
ByteString
".presentationml.slideshow" ),
( FilePath
".ppt" , ByteString
"application/vnd.ms-powerpoint" ),
( FilePath
".pptx" , ByteString -> ByteString -> ByteString
S.append ByteString
"application/vnd.openxmlformats-officedocument"
ByteString
".presentationml.presentation" ),
( FilePath
".ps" , ByteString
"application/postscript" ),
( FilePath
".qt" , ByteString
"video/quicktime" ),
( FilePath
".rtf" , ByteString
"text/rtf" ),
( FilePath
".sig" , ByteString
"application/pgp-signature" ),
( FilePath
".sldx" , ByteString -> ByteString -> ByteString
S.append ByteString
"application/vnd.openxmlformats-officedocument"
ByteString
".presentationml.slide" ),
( FilePath
".spl" , ByteString
"application/futuresplash" ),
( FilePath
".svg" , ByteString
"image/svg+xml" ),
( FilePath
".swf" , ByteString
"application/x-shockwave-flash" ),
( FilePath
".tar" , ByteString
"application/x-tar" ),
( FilePath
".tar.bz2" , ByteString
"application/x-bzip-compressed-tar" ),
( FilePath
".tar.gz" , ByteString
"application/x-tgz" ),
( FilePath
".tbz" , ByteString
"application/x-bzip-compressed-tar" ),
( FilePath
".text" , ByteString
"text/plain" ),
( FilePath
".tgz" , ByteString
"application/x-tgz" ),
( FilePath
".tiff" , ByteString
"image/tiff" ),
( FilePath
".tif" , ByteString
"image/tiff" ),
( FilePath
".torrent" , ByteString
"application/x-bittorrent" ),
( FilePath
".ts" , ByteString
"video/mp2t" ),
( FilePath
".ttf" , ByteString
"font/ttf" ),
( FilePath
".txt" , ByteString
"text/plain" ),
( FilePath
".wav" , ByteString
"audio/x-wav" ),
( FilePath
".wax" , ByteString
"audio/x-ms-wax" ),
( FilePath
".webm" , ByteString
"video/webm" ),
( FilePath
".wma" , ByteString
"audio/x-ms-wma" ),
( FilePath
".wmv" , ByteString
"video/x-ms-wmv" ),
( FilePath
".xbm" , ByteString
"image/x-xbitmap" ),
( FilePath
".xlam" , ByteString
"application/vnd.ms-excel.addin.macroEnabled.12" ),
( FilePath
".xls" , ByteString
"application/vnd.ms-excel" ),
( FilePath
".xlsb" , ByteString
"application/vnd.ms-excel.sheet.binary.macroEnabled.12" ),
( FilePath
".xlsx" , ByteString -> ByteString -> ByteString
S.append ByteString
"application/vnd.openxmlformats-officedocument."
ByteString
"spreadsheetml.sheet" ),
( FilePath
".xltx" , ByteString -> ByteString -> ByteString
S.append ByteString
"application/vnd.openxmlformats-officedocument."
ByteString
"spreadsheetml.template" ),
( FilePath
".xml" , ByteString
"text/xml" ),
( FilePath
".xpm" , ByteString
"image/x-xpixmap" ),
( FilePath
".xwd" , ByteString
"image/x-xwindowdump" ),
( FilePath
".zip" , ByteString
"application/zip" ) ]
data DirectoryConfig m = DirectoryConfig {
DirectoryConfig m -> [FilePath]
indexFiles :: [FilePath],
DirectoryConfig m -> FilePath -> m ()
indexGenerator :: FilePath -> m (),
DirectoryConfig m -> HandlerMap m
dynamicHandlers :: HandlerMap m,
DirectoryConfig m -> MimeMap
mimeTypes :: MimeMap,
DirectoryConfig m -> FilePath -> m ()
preServeHook :: FilePath -> m ()
}
snapIndexStyles :: ByteString
snapIndexStyles :: ByteString
snapIndexStyles =
ByteString -> [ByteString] -> ByteString
S.intercalate ByteString
"\n"
[ ByteString
"body { margin: 0px 0px 0px 0px; font-family: sans-serif }"
, ByteString
"div.header {"
, ByteString
"padding: 40px 40px 0px 40px; height:35px;"
, ByteString
"background:rgb(25,50,87);"
, ByteString
"background-image:-webkit-gradient("
, ByteString
"linear,left bottom,left top,"
, ByteString
"color-stop(0.00, rgb(31,62,108)),"
, ByteString
"color-stop(1.00, rgb(19,38,66)));"
, ByteString
"background-image:-moz-linear-gradient("
, ByteString
"center bottom,rgb(31,62,108) 0%,rgb(19,38,66) 100%);"
, ByteString
"text-shadow:-1px 3px 1px rgb(16,33,57);"
, ByteString
"font-size:16pt; letter-spacing: 2pt; color:white;"
, ByteString
"border-bottom:10px solid rgb(46,93,156) }"
, ByteString
"div.content {"
, ByteString
"background:rgb(255,255,255);"
, ByteString
"background-image:-webkit-gradient("
, ByteString
"linear,left bottom, left top,"
, ByteString
"color-stop(0.50, rgb(255,255,255)),"
, ByteString
"color-stop(1.00, rgb(224,234,247)));"
, ByteString
"background-image:-moz-linear-gradient("
, ByteString
"center bottom, white 50%, rgb(224,234,247) 100%);"
, ByteString
"padding: 40px 40px 40px 40px }"
, ByteString
"div.footer {"
, ByteString
"padding: 16px 0px 10px 10px; height:31px;"
, ByteString
"border-top: 1px solid rgb(194,209,225);"
, ByteString
"color: rgb(160,172,186); font-size:10pt;"
, ByteString
"background: rgb(245,249,255) }"
, ByteString
"table { max-width:100%; margin: 0 auto;" ByteString -> ByteString -> ByteString
`S.append`
ByteString
" border-collapse: collapse; }"
, ByteString
"tr:hover { background:rgb(256,256,224) }"
, ByteString
"td { border:0; font-family:monospace; padding: 2px 0; }"
, ByteString
"td.filename, td.type { padding-right: 2em; }"
, ByteString
"th { border:0; background:rgb(28,56,97);"
, ByteString
"text-shadow:-1px 3px 1px rgb(16,33,57); color: white}"
]
defaultIndexGenerator :: MonadSnap m
=> MimeMap
-> ByteString
-> FilePath
-> m ()
defaultIndexGenerator :: MimeMap -> ByteString -> FilePath -> m ()
defaultIndexGenerator MimeMap
mm ByteString
styles FilePath
d = do
(Response -> Response) -> m ()
forall (m :: * -> *). MonadSnap m => (Response -> Response) -> m ()
modifyResponse ((Response -> Response) -> m ()) -> (Response -> Response) -> m ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Response -> Response
setContentType ByteString
"text/html; charset=utf-8"
Request
rq <- m Request
forall (m :: * -> *). MonadSnap m => m Request
getRequest
let uri :: ByteString
uri = Request -> ByteString
uriWithoutQueryString Request
rq
let pInfo :: ByteString
pInfo = Request -> ByteString
rqPathInfo Request
rq
ByteString -> m ()
forall (m :: * -> *). MonadSnap m => ByteString -> m ()
writeBS ByteString
"<!DOCTYPE html>\n<html>\n<head>"
ByteString -> m ()
forall (m :: * -> *). MonadSnap m => ByteString -> m ()
writeBS ByteString
"<title>Directory Listing: "
ByteString -> m ()
forall (m :: * -> *). MonadSnap m => ByteString -> m ()
writeBS ByteString
uri
ByteString -> m ()
forall (m :: * -> *). MonadSnap m => ByteString -> m ()
writeBS ByteString
"</title>"
ByteString -> m ()
forall (m :: * -> *). MonadSnap m => ByteString -> m ()
writeBS ByteString
"<style type='text/css'>"
ByteString -> m ()
forall (m :: * -> *). MonadSnap m => ByteString -> m ()
writeBS ByteString
styles
ByteString -> m ()
forall (m :: * -> *). MonadSnap m => ByteString -> m ()
writeBS ByteString
"</style></head><body>"
ByteString -> m ()
forall (m :: * -> *). MonadSnap m => ByteString -> m ()
writeBS ByteString
"<div class=\"header\">Directory Listing: "
ByteString -> m ()
forall (m :: * -> *). MonadSnap m => ByteString -> m ()
writeBS ByteString
uri
ByteString -> m ()
forall (m :: * -> *). MonadSnap m => ByteString -> m ()
writeBS ByteString
"</div><div class=\"content\">"
ByteString -> m ()
forall (m :: * -> *). MonadSnap m => ByteString -> m ()
writeBS ByteString
"<table><tr><th>File Name</th><th>Type</th><th>Last Modified"
ByteString -> m ()
forall (m :: * -> *). MonadSnap m => ByteString -> m ()
writeBS ByteString
"</th></tr>"
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString
pInfo ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString
"") (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
ByteString -> m ()
forall (m :: * -> *). MonadSnap m => ByteString -> m ()
writeBS ByteString
"<tr><td><a href='../'>..</a></td><td colspan=2>DIR</td></tr>"
[FilePath]
entries <- IO [FilePath] -> m [FilePath]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [FilePath] -> m [FilePath]) -> IO [FilePath] -> m [FilePath]
forall a b. (a -> b) -> a -> b
$ FilePath -> IO [FilePath]
getDirectoryContents FilePath
d
[FilePath]
dirs <- IO [FilePath] -> m [FilePath]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [FilePath] -> m [FilePath]) -> IO [FilePath] -> m [FilePath]
forall a b. (a -> b) -> a -> b
$ (FilePath -> IO Bool) -> [FilePath] -> IO [FilePath]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (FilePath -> IO Bool
doesDirectoryExist (FilePath -> IO Bool)
-> (FilePath -> FilePath) -> FilePath -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath
d FilePath -> FilePath -> FilePath
</>)) [FilePath]
entries
[FilePath]
files <- IO [FilePath] -> m [FilePath]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [FilePath] -> m [FilePath]) -> IO [FilePath] -> m [FilePath]
forall a b. (a -> b) -> a -> b
$ (FilePath -> IO Bool) -> [FilePath] -> IO [FilePath]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (FilePath -> IO Bool
doesFileExist (FilePath -> IO Bool)
-> (FilePath -> FilePath) -> FilePath -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath
d FilePath -> FilePath -> FilePath
</>)) [FilePath]
entries
[FilePath] -> (FilePath -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([FilePath] -> [FilePath]
forall a. Ord a => [a] -> [a]
sort ([FilePath] -> [FilePath]) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> a -> b
$ (FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (FilePath -> Bool) -> FilePath -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath -> [FilePath] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [FilePath
"..", FilePath
"."])) [FilePath]
dirs) ((FilePath -> m ()) -> m ()) -> (FilePath -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \FilePath
f0 -> do
ByteString
f <- IO ByteString -> m ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> m ByteString) -> IO ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ (Text -> ByteString) -> IO Text -> IO ByteString
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (\Text
s -> Text -> ByteString
T.encodeUtf8 Text
s ByteString -> ByteString -> ByteString
forall a. Monoid a => a -> a -> a
`mappend` ByteString
"/")
(IO Text -> IO ByteString) -> IO Text -> IO ByteString
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Text
decodeFilePath FilePath
f0
ByteString -> m ()
forall (m :: * -> *). MonadSnap m => ByteString -> m ()
writeBS ByteString
"<tr><td class='filename'><a href='"
ByteString -> m ()
forall (m :: * -> *). MonadSnap m => ByteString -> m ()
writeBS ByteString
f
ByteString -> m ()
forall (m :: * -> *). MonadSnap m => ByteString -> m ()
writeBS ByteString
"'>"
ByteString -> m ()
forall (m :: * -> *). MonadSnap m => ByteString -> m ()
writeBS ByteString
f
ByteString -> m ()
forall (m :: * -> *). MonadSnap m => ByteString -> m ()
writeBS ByteString
"</a></td><td class='type' colspan=2>DIR</td></tr>"
[FilePath] -> (FilePath -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([FilePath] -> [FilePath]
forall a. Ord a => [a] -> [a]
sort [FilePath]
files) ((FilePath -> m ()) -> m ()) -> (FilePath -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \FilePath
f0 -> do
ByteString
f <- IO ByteString -> m ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> m ByteString) -> IO ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ (Text -> ByteString) -> IO Text -> IO ByteString
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Text -> ByteString
T.encodeUtf8 (IO Text -> IO ByteString) -> IO Text -> IO ByteString
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Text
decodeFilePath FilePath
f0
FileStatus
stat <- IO FileStatus -> m FileStatus
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FileStatus -> m FileStatus) -> IO FileStatus -> m FileStatus
forall a b. (a -> b) -> a -> b
$ FilePath -> IO FileStatus
getFileStatus (FilePath
d FilePath -> FilePath -> FilePath
</> FilePath
f0)
ByteString
tm <- IO ByteString -> m ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> m ByteString) -> IO ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ CTime -> IO ByteString
formatHttpTime (FileStatus -> CTime
modificationTime FileStatus
stat)
ByteString -> m ()
forall (m :: * -> *). MonadSnap m => ByteString -> m ()
writeBS ByteString
"<tr><td class='filename'><a href='"
ByteString -> m ()
forall (m :: * -> *). MonadSnap m => ByteString -> m ()
writeBS ByteString
f
ByteString -> m ()
forall (m :: * -> *). MonadSnap m => ByteString -> m ()
writeBS ByteString
"'>"
ByteString -> m ()
forall (m :: * -> *). MonadSnap m => ByteString -> m ()
writeBS ByteString
f
ByteString -> m ()
forall (m :: * -> *). MonadSnap m => ByteString -> m ()
writeBS ByteString
"</a></td><td class='type'>"
ByteString -> m ()
forall (m :: * -> *). MonadSnap m => ByteString -> m ()
writeBS (MimeMap -> FilePath -> ByteString
fileType MimeMap
mm FilePath
f0)
ByteString -> m ()
forall (m :: * -> *). MonadSnap m => ByteString -> m ()
writeBS ByteString
"</td><td>"
ByteString -> m ()
forall (m :: * -> *). MonadSnap m => ByteString -> m ()
writeBS ByteString
tm
ByteString -> m ()
forall (m :: * -> *). MonadSnap m => ByteString -> m ()
writeBS ByteString
"</tr>"
ByteString -> m ()
forall (m :: * -> *). MonadSnap m => ByteString -> m ()
writeBS ByteString
"</table></div><div class=\"footer\">Powered by "
ByteString -> m ()
forall (m :: * -> *). MonadSnap m => ByteString -> m ()
writeBS ByteString
"<b><a href=\"http://snapframework.com/\">Snap</a></b></div>"
ByteString -> m ()
forall (m :: * -> *). MonadSnap m => ByteString -> m ()
writeBS ByteString
"</body>"
decodeFilePath :: FilePath -> IO T.Text
decodeFilePath :: FilePath -> IO Text
decodeFilePath FilePath
fp = do
Text -> IO Text
forall (m :: * -> *) a. MonadBase IO m => a -> m a
evaluate (ByteString -> Text
T.decodeUtf8 ByteString
bs) IO Text -> (SomeException -> IO Text) -> IO Text
forall (m :: * -> *) e a.
(MonadBaseControl IO m, Exception e) =>
m a -> (e -> m a) -> m a
`catch`
(\(SomeException
_::SomeException) -> Text -> IO Text
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> Text
T.pack FilePath
fp))
where
bs :: ByteString
bs = FilePath -> ByteString
S.pack FilePath
fp
simpleDirectoryConfig :: MonadSnap m => DirectoryConfig m
simpleDirectoryConfig :: DirectoryConfig m
simpleDirectoryConfig = DirectoryConfig :: forall (m :: * -> *).
[FilePath]
-> (FilePath -> m ())
-> HandlerMap m
-> MimeMap
-> (FilePath -> m ())
-> DirectoryConfig m
DirectoryConfig {
indexFiles :: [FilePath]
indexFiles = [],
indexGenerator :: FilePath -> m ()
indexGenerator = m () -> FilePath -> m ()
forall a b. a -> b -> a
const m ()
forall (m :: * -> *) a. MonadSnap m => m a
pass,
dynamicHandlers :: HandlerMap m
dynamicHandlers = HandlerMap m
forall k v. HashMap k v
Map.empty,
mimeTypes :: MimeMap
mimeTypes = MimeMap
defaultMimeTypes,
preServeHook :: FilePath -> m ()
preServeHook = m () -> FilePath -> m ()
forall a b. a -> b -> a
const (m () -> FilePath -> m ()) -> m () -> FilePath -> m ()
forall a b. (a -> b) -> a -> b
$ () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return (() -> m ()) -> () -> m ()
forall a b. (a -> b) -> a -> b
$! ()
}
defaultDirectoryConfig :: MonadSnap m => DirectoryConfig m
defaultDirectoryConfig :: DirectoryConfig m
defaultDirectoryConfig = DirectoryConfig :: forall (m :: * -> *).
[FilePath]
-> (FilePath -> m ())
-> HandlerMap m
-> MimeMap
-> (FilePath -> m ())
-> DirectoryConfig m
DirectoryConfig {
indexFiles :: [FilePath]
indexFiles = [FilePath
"index.html", FilePath
"index.htm"],
indexGenerator :: FilePath -> m ()
indexGenerator = m () -> FilePath -> m ()
forall a b. a -> b -> a
const m ()
forall (m :: * -> *) a. MonadSnap m => m a
pass,
dynamicHandlers :: HandlerMap m
dynamicHandlers = HandlerMap m
forall k v. HashMap k v
Map.empty,
mimeTypes :: MimeMap
mimeTypes = MimeMap
defaultMimeTypes,
preServeHook :: FilePath -> m ()
preServeHook = m () -> FilePath -> m ()
forall a b. a -> b -> a
const (m () -> FilePath -> m ()) -> m () -> FilePath -> m ()
forall a b. (a -> b) -> a -> b
$ () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return (() -> m ()) -> () -> m ()
forall a b. (a -> b) -> a -> b
$! ()
}
fancyDirectoryConfig :: MonadSnap m => DirectoryConfig m
fancyDirectoryConfig :: DirectoryConfig m
fancyDirectoryConfig = DirectoryConfig :: forall (m :: * -> *).
[FilePath]
-> (FilePath -> m ())
-> HandlerMap m
-> MimeMap
-> (FilePath -> m ())
-> DirectoryConfig m
DirectoryConfig {
indexFiles :: [FilePath]
indexFiles = [FilePath
"index.html", FilePath
"index.htm"],
indexGenerator :: FilePath -> m ()
indexGenerator = MimeMap -> ByteString -> FilePath -> m ()
forall (m :: * -> *).
MonadSnap m =>
MimeMap -> ByteString -> FilePath -> m ()
defaultIndexGenerator MimeMap
defaultMimeTypes ByteString
snapIndexStyles,
dynamicHandlers :: HandlerMap m
dynamicHandlers = HandlerMap m
forall k v. HashMap k v
Map.empty,
mimeTypes :: MimeMap
mimeTypes = MimeMap
defaultMimeTypes,
preServeHook :: FilePath -> m ()
preServeHook = m () -> FilePath -> m ()
forall a b. a -> b -> a
const (m () -> FilePath -> m ()) -> m () -> FilePath -> m ()
forall a b. (a -> b) -> a -> b
$ () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return (() -> m ()) -> () -> m ()
forall a b. (a -> b) -> a -> b
$! ()
}
serveDirectory :: MonadSnap m
=> FilePath
-> m ()
serveDirectory :: FilePath -> m ()
serveDirectory = DirectoryConfig m -> FilePath -> m ()
forall (m :: * -> *).
MonadSnap m =>
DirectoryConfig m -> FilePath -> m ()
serveDirectoryWith DirectoryConfig m
forall (m :: * -> *). MonadSnap m => DirectoryConfig m
defaultDirectoryConfig
{-# INLINE serveDirectory #-}
serveDirectoryWith :: MonadSnap m
=> DirectoryConfig m
-> FilePath
-> m ()
serveDirectoryWith :: DirectoryConfig m -> FilePath -> m ()
serveDirectoryWith DirectoryConfig m
cfg FilePath
base = do
Bool
b <- m Bool
directory m Bool -> m Bool -> m Bool
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> m Bool
file m Bool -> m Bool -> m Bool
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> m Bool
forall b. m b
redir
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
b) m ()
forall (m :: * -> *) a. MonadSnap m => m a
pass
where
idxs :: [FilePath]
idxs = DirectoryConfig m -> [FilePath]
forall (m :: * -> *). DirectoryConfig m -> [FilePath]
indexFiles DirectoryConfig m
cfg
generate :: FilePath -> m ()
generate = DirectoryConfig m -> FilePath -> m ()
forall (m :: * -> *). DirectoryConfig m -> FilePath -> m ()
indexGenerator DirectoryConfig m
cfg
mimes :: MimeMap
mimes = DirectoryConfig m -> MimeMap
forall (m :: * -> *). DirectoryConfig m -> MimeMap
mimeTypes DirectoryConfig m
cfg
dyns :: HandlerMap m
dyns = DirectoryConfig m -> HandlerMap m
forall (m :: * -> *). DirectoryConfig m -> HandlerMap m
dynamicHandlers DirectoryConfig m
cfg
pshook :: FilePath -> m ()
pshook = DirectoryConfig m -> FilePath -> m ()
forall (m :: * -> *). DirectoryConfig m -> FilePath -> m ()
preServeHook DirectoryConfig m
cfg
serve :: FilePath -> m Bool
serve FilePath
f = do
IO Bool -> m Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (FilePath -> IO Bool
doesFileExist FilePath
f) m Bool -> (Bool -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Bool -> m () -> m ()) -> m () -> Bool -> m ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless m ()
forall (m :: * -> *) a. MonadSnap m => m a
pass
let fname :: FilePath
fname = FilePath -> FilePath
takeFileName FilePath
f
let staticServe :: FilePath -> m ()
staticServe FilePath
f' = FilePath -> m ()
pshook FilePath
f m () -> m () -> m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ByteString -> FilePath -> m ()
forall (m :: * -> *). MonadSnap m => ByteString -> FilePath -> m ()
serveFileAs (MimeMap -> FilePath -> ByteString
fileType MimeMap
mimes FilePath
fname) FilePath
f'
(FilePath -> m ()) -> HandlerMap m -> FilePath -> FilePath -> m ()
forall a. a -> HashMap FilePath a -> FilePath -> a
lookupExt FilePath -> m ()
staticServe HandlerMap m
dyns FilePath
fname FilePath
f m () -> m Bool -> m Bool
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
directory :: m Bool
directory = do
Request
rq <- m Request
forall (m :: * -> *). MonadSnap m => m Request
getRequest
let uri :: ByteString
uri = Request -> ByteString
uriWithoutQueryString Request
rq
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString
"/" ByteString -> ByteString -> Bool
`S.isSuffixOf` ByteString
uri) m ()
forall (m :: * -> *) a. MonadSnap m => m a
pass
FilePath
rel <- (FilePath
base FilePath -> FilePath -> FilePath
</>) (FilePath -> FilePath) -> m FilePath -> m FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m FilePath
forall (m :: * -> *). MonadSnap m => m FilePath
getSafePath
Bool
b <- IO Bool -> m Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> m Bool) -> IO Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Bool
doesDirectoryExist FilePath
rel
if Bool
b then do let serveRel :: FilePath -> m Bool
serveRel FilePath
f = FilePath -> m Bool
serve (FilePath
rel FilePath -> FilePath -> FilePath
</> FilePath
f)
(m Bool -> m Bool -> m Bool) -> m Bool -> [m Bool] -> m Bool
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' m Bool -> m Bool -> m Bool
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(<|>) m Bool
forall (m :: * -> *) a. MonadSnap m => m a
pass ((FilePath -> m Bool) -> [FilePath] -> [m Bool]
forall a b. (a -> b) -> [a] -> [b]
Prelude.map FilePath -> m Bool
serveRel [FilePath]
idxs)
m Bool -> m Bool -> m Bool
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (FilePath -> m ()
generate FilePath
rel m () -> m Bool -> m Bool
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True)
m Bool -> m Bool -> m Bool
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
else Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
file :: m Bool
file = FilePath -> m Bool
serve (FilePath -> m Bool) -> m FilePath -> m Bool
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ((FilePath
base FilePath -> FilePath -> FilePath
</>) (FilePath -> FilePath) -> m FilePath -> m FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m FilePath
forall (m :: * -> *). MonadSnap m => m FilePath
getSafePath)
redir :: m b
redir = do
FilePath
rel <- (FilePath
base FilePath -> FilePath -> FilePath
</>) (FilePath -> FilePath) -> m FilePath -> m FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m FilePath
forall (m :: * -> *). MonadSnap m => m FilePath
getSafePath
IO Bool -> m Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (FilePath -> IO Bool
doesDirectoryExist FilePath
rel) m Bool -> (Bool -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Bool -> m () -> m ()) -> m () -> Bool -> m ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless m ()
forall (m :: * -> *) a. MonadSnap m => m a
pass
Request
rq <- m Request
forall (m :: * -> *). MonadSnap m => m Request
getRequest
let uri :: ByteString
uri = Request -> ByteString
uriWithoutQueryString Request
rq
let qss :: ByteString
qss = Request -> ByteString
queryStringSuffix Request
rq
let u :: ByteString
u = [ByteString] -> ByteString
S.concat [ByteString
uri, ByteString
"/", ByteString
qss]
ByteString -> m b
forall (m :: * -> *) a. MonadSnap m => ByteString -> m a
redirect ByteString
u
serveFile :: MonadSnap m
=> FilePath
-> m ()
serveFile :: FilePath -> m ()
serveFile FilePath
fp = ByteString -> FilePath -> m ()
forall (m :: * -> *). MonadSnap m => ByteString -> FilePath -> m ()
serveFileAs (MimeMap -> FilePath -> ByteString
fileType MimeMap
defaultMimeTypes (FilePath -> FilePath
takeFileName FilePath
fp)) FilePath
fp
{-# INLINE serveFile #-}
serveFileAs :: MonadSnap m
=> ByteString
-> FilePath
-> m ()
serveFileAs :: ByteString -> FilePath -> m ()
serveFileAs ByteString
mime FilePath
fp = do
Request
reqOrig <- m Request
forall (m :: * -> *). MonadSnap m => m Request
getRequest
let req :: Request
req = if Maybe ByteString -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe ByteString -> Bool) -> Maybe ByteString -> Bool
forall a b. (a -> b) -> a -> b
$ CI ByteString -> Request -> Maybe ByteString
forall a. HasHeaders a => CI ByteString -> a -> Maybe ByteString
getHeader CI ByteString
"range" Request
reqOrig
then CI ByteString -> Request -> Request
forall a. HasHeaders a => CI ByteString -> a -> a
deleteHeader CI ByteString
"if-range" Request
reqOrig
else Request
reqOrig
let mbH :: Maybe ByteString
mbH = CI ByteString -> Request -> Maybe ByteString
forall a. HasHeaders a => CI ByteString -> a -> Maybe ByteString
getHeader CI ByteString
"if-modified-since" Request
req
Maybe CTime
mbIfModified <- IO (Maybe CTime) -> m (Maybe CTime)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe CTime) -> m (Maybe CTime))
-> IO (Maybe CTime) -> m (Maybe CTime)
forall a b. (a -> b) -> a -> b
$ case Maybe ByteString
mbH of
Maybe ByteString
Nothing -> Maybe CTime -> IO (Maybe CTime)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe CTime
forall a. Maybe a
Nothing
(Just ByteString
s) -> (CTime -> Maybe CTime) -> IO CTime -> IO (Maybe CTime)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM CTime -> Maybe CTime
forall a. a -> Maybe a
Just (IO CTime -> IO (Maybe CTime)) -> IO CTime -> IO (Maybe CTime)
forall a b. (a -> b) -> a -> b
$ ByteString -> IO CTime
parseHttpTime ByteString
s
Maybe CTime
mbIfRange <- IO (Maybe CTime) -> m (Maybe CTime)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe CTime) -> m (Maybe CTime))
-> IO (Maybe CTime) -> m (Maybe CTime)
forall a b. (a -> b) -> a -> b
$ case CI ByteString -> Request -> Maybe ByteString
forall a. HasHeaders a => CI ByteString -> a -> Maybe ByteString
getHeader CI ByteString
"if-range" Request
req of
Maybe ByteString
Nothing -> Maybe CTime -> IO (Maybe CTime)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe CTime
forall a. Maybe a
Nothing
(Just ByteString
s) -> (CTime -> Maybe CTime) -> IO CTime -> IO (Maybe CTime)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM CTime -> Maybe CTime
forall a. a -> Maybe a
Just (IO CTime -> IO (Maybe CTime)) -> IO CTime -> IO (Maybe CTime)
forall a b. (a -> b) -> a -> b
$ ByteString -> IO CTime
parseHttpTime ByteString
s
FilePath -> m ()
forall (m :: * -> *). MonadIO m => FilePath -> m ()
dbg (FilePath -> m ()) -> FilePath -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath
"mbIfModified: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Maybe CTime -> FilePath
forall a. Show a => a -> FilePath
Prelude.show Maybe CTime
mbIfModified
FilePath -> m ()
forall (m :: * -> *). MonadIO m => FilePath -> m ()
dbg (FilePath -> m ()) -> FilePath -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath
"mbIfRange: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Maybe CTime -> FilePath
forall a. Show a => a -> FilePath
Prelude.show Maybe CTime
mbIfRange
FileStatus
filestat <- IO FileStatus -> m FileStatus
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FileStatus -> m FileStatus) -> IO FileStatus -> m FileStatus
forall a b. (a -> b) -> a -> b
$ FilePath -> IO FileStatus
getFileStatus FilePath
fp
let mt :: CTime
mt = FileStatus -> CTime
modificationTime FileStatus
filestat
m () -> (CTime -> m ()) -> Maybe CTime -> m ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return (() -> m ()) -> () -> m ()
forall a b. (a -> b) -> a -> b
$! ()) (\CTime
lt -> Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CTime
mt CTime -> CTime -> Bool
forall a. Ord a => a -> a -> Bool
<= CTime
lt) m ()
forall a. m a
notModified) Maybe CTime
mbIfModified
let sz :: Word64
sz = FileOffset -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (FileOffset -> Word64) -> FileOffset -> Word64
forall a b. (a -> b) -> a -> b
$ FileStatus -> FileOffset
fileSize FileStatus
filestat
ByteString
lm <- IO ByteString -> m ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> m ByteString) -> IO ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ CTime -> IO ByteString
formatHttpTime CTime
mt
(Response -> Response) -> m ()
forall (m :: * -> *). MonadSnap m => (Response -> Response) -> m ()
modifyResponse ((Response -> Response) -> m ()) -> (Response -> Response) -> m ()
forall a b. (a -> b) -> a -> b
$ CI ByteString -> ByteString -> Response -> Response
forall a. HasHeaders a => CI ByteString -> ByteString -> a -> a
setHeader CI ByteString
"Last-Modified" ByteString
lm
(Response -> Response)
-> (Response -> Response) -> Response -> Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CI ByteString -> ByteString -> Response -> Response
forall a. HasHeaders a => CI ByteString -> ByteString -> a -> a
setHeader CI ByteString
"Accept-Ranges" ByteString
"bytes"
(Response -> Response)
-> (Response -> Response) -> Response -> Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Response -> Response
setContentType ByteString
mime
let skipRangeCheck :: Bool
skipRangeCheck = Bool -> (CTime -> Bool) -> Maybe CTime -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Bool
False)
(\CTime
lt -> CTime
mt CTime -> CTime -> Bool
forall a. Ord a => a -> a -> Bool
> CTime
lt)
Maybe CTime
mbIfRange
Bool
wasRange <- if Bool
skipRangeCheck
then Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
else Snap Bool -> m Bool
forall (m :: * -> *) a. MonadSnap m => Snap a -> m a
liftSnap (Snap Bool -> m Bool) -> Snap Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ Request -> FilePath -> Word64 -> Snap Bool
forall (m :: * -> *).
MonadSnap m =>
Request -> FilePath -> Word64 -> m Bool
checkRangeReq Request
req FilePath
fp Word64
sz
FilePath -> m ()
forall (m :: * -> *). MonadIO m => FilePath -> m ()
dbg (FilePath -> m ()) -> FilePath -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath
"was this a range request? " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Bool -> FilePath
forall a. Show a => a -> FilePath
Prelude.show Bool
wasRange
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
wasRange (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
(Response -> Response) -> m ()
forall (m :: * -> *). MonadSnap m => (Response -> Response) -> m ()
modifyResponse ((Response -> Response) -> m ()) -> (Response -> Response) -> m ()
forall a b. (a -> b) -> a -> b
$ Int -> Response -> Response
setResponseCode Int
200
(Response -> Response)
-> (Response -> Response) -> Response -> Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Response -> Response
setContentLength Word64
sz
Snap () -> m ()
forall (m :: * -> *) a. MonadSnap m => Snap a -> m a
liftSnap (Snap () -> m ()) -> Snap () -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath -> Snap ()
forall (m :: * -> *). MonadSnap m => FilePath -> m ()
sendFile FilePath
fp
where
notModified :: m a
notModified = Response -> m a
forall (m :: * -> *) a. MonadSnap m => Response -> m a
finishWith (Response -> m a) -> Response -> m a
forall a b. (a -> b) -> a -> b
$
Int -> Response -> Response
setResponseCode Int
304 Response
emptyResponse
lookupExt :: a -> HashMap FilePath a -> FilePath -> a
lookupExt :: a -> HashMap FilePath a -> FilePath -> a
lookupExt a
def HashMap FilePath a
m FilePath
f =
if FilePath -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null FilePath
ext
then a
def
else a -> Maybe a -> a
forall a. a -> Maybe a -> a
fromMaybe (a -> HashMap FilePath a -> FilePath -> a
forall a. a -> HashMap FilePath a -> FilePath -> a
lookupExt a
def HashMap FilePath a
m (FilePath -> FilePath
next FilePath
ext)) Maybe a
mbe
where
next :: FilePath -> FilePath
next = (Char -> Bool) -> FilePath -> FilePath
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'.') (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> FilePath -> FilePath
forall a. Int -> [a] -> [a]
drop Int
1
ext :: FilePath
ext = FilePath -> FilePath
takeExtensions FilePath
f
mbe :: Maybe a
mbe = FilePath -> HashMap FilePath a -> Maybe a
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
Map.lookup FilePath
ext HashMap FilePath a
m
fileType :: MimeMap -> FilePath -> ByteString
fileType :: MimeMap -> FilePath -> ByteString
fileType = ByteString -> MimeMap -> FilePath -> ByteString
forall a. a -> HashMap FilePath a -> FilePath -> a
lookupExt ByteString
defaultMimeType
defaultMimeType :: ByteString
defaultMimeType :: ByteString
defaultMimeType = ByteString
"application/octet-stream"
data RangeReq = RangeReq !Word64 !(Maybe Word64)
| SuffixRangeReq !Word64
rangeParser :: Parser RangeReq
rangeParser :: Parser RangeReq
rangeParser = ByteString -> Parser ByteString
string ByteString
"bytes=" Parser ByteString -> Parser RangeReq -> Parser RangeReq
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*>
(Parser RangeReq
byteRangeSpec Parser RangeReq -> Parser RangeReq -> Parser RangeReq
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser RangeReq
suffixByteRangeSpec) Parser RangeReq -> Parser ByteString () -> Parser RangeReq
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<*
Parser ByteString ()
forall t. Chunk t => Parser t ()
endOfInput
where
byteRangeSpec :: Parser RangeReq
byteRangeSpec = do
Word64
start <- Int64 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Word64)
-> Parser ByteString Int64 -> Parser ByteString Word64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString Int64
parseNum
Parser ByteString Char -> Parser ByteString ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Parser ByteString Char -> Parser ByteString ())
-> Parser ByteString Char -> Parser ByteString ()
forall a b. (a -> b) -> a -> b
$! Char -> Parser ByteString Char
char Char
'-'
Maybe Int64
end <- Maybe Int64
-> Parser ByteString (Maybe Int64)
-> Parser ByteString (Maybe Int64)
forall (f :: * -> *) a. Alternative f => a -> f a -> f a
option Maybe Int64
forall a. Maybe a
Nothing (Parser ByteString (Maybe Int64)
-> Parser ByteString (Maybe Int64))
-> Parser ByteString (Maybe Int64)
-> Parser ByteString (Maybe Int64)
forall a b. (a -> b) -> a -> b
$ (Int64 -> Maybe Int64)
-> Parser ByteString Int64 -> Parser ByteString (Maybe Int64)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Int64 -> Maybe Int64
forall a. a -> Maybe a
Just Parser ByteString Int64
parseNum
RangeReq -> Parser RangeReq
forall (m :: * -> *) a. Monad m => a -> m a
return (RangeReq -> Parser RangeReq) -> RangeReq -> Parser RangeReq
forall a b. (a -> b) -> a -> b
$! Word64 -> Maybe Word64 -> RangeReq
RangeReq Word64
start (Int64 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Word64) -> Maybe Int64 -> Maybe Word64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Int64
end)
suffixByteRangeSpec :: Parser RangeReq
suffixByteRangeSpec =
(Int64 -> RangeReq) -> Parser ByteString Int64 -> Parser RangeReq
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (Word64 -> RangeReq
SuffixRangeReq (Word64 -> RangeReq) -> (Int64 -> Word64) -> Int64 -> RangeReq
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral) (Parser ByteString Int64 -> Parser RangeReq)
-> Parser ByteString Int64 -> Parser RangeReq
forall a b. (a -> b) -> a -> b
$ Char -> Parser ByteString Char
char Char
'-' Parser ByteString Char
-> Parser ByteString Int64 -> Parser ByteString Int64
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ByteString Int64
parseNum
checkRangeReq :: (MonadSnap m) => Request -> FilePath -> Word64 -> m Bool
checkRangeReq :: Request -> FilePath -> Word64 -> m Bool
checkRangeReq Request
req FilePath
fp Word64
sz = do
m Bool -> (ByteString -> m Bool) -> Maybe ByteString -> m Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False)
(\ByteString
s -> (FilePath -> m Bool)
-> (RangeReq -> m Bool) -> Either FilePath RangeReq -> m Bool
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (m Bool -> FilePath -> m Bool
forall a b. a -> b -> a
const (m Bool -> FilePath -> m Bool) -> m Bool -> FilePath -> m Bool
forall a b. (a -> b) -> a -> b
$ Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False)
RangeReq -> m Bool
withRange
(ByteString -> Parser RangeReq -> Either FilePath RangeReq
forall a. ByteString -> Parser a -> Either FilePath a
fullyParse ByteString
s Parser RangeReq
rangeParser))
(CI ByteString -> Request -> Maybe ByteString
forall a. HasHeaders a => CI ByteString -> a -> Maybe ByteString
getHeader CI ByteString
"range" Request
req)
where
withRange :: RangeReq -> m Bool
withRange (RangeReq Word64
start Maybe Word64
mend) = do
let end :: Word64
end = Word64 -> Maybe Word64 -> Word64
forall a. a -> Maybe a -> a
fromMaybe (Word64
szWord64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
-Word64
1) Maybe Word64
mend
FilePath -> m ()
forall (m :: * -> *). MonadIO m => FilePath -> m ()
dbg (FilePath -> m ()) -> FilePath -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath
"withRange: start=" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Word64 -> FilePath
forall a. Show a => a -> FilePath
Prelude.show Word64
start
FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
", end=" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Word64 -> FilePath
forall a. Show a => a -> FilePath
Prelude.show Word64
end
if Word64
start Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
< Word64
0 Bool -> Bool -> Bool
|| Word64
end Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
< Word64
start Bool -> Bool -> Bool
|| Word64
start Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word64
sz Bool -> Bool -> Bool
|| Word64
end Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word64
sz
then m Bool
send416
else Word64 -> Word64 -> m Bool
forall (m :: * -> *). MonadSnap m => Word64 -> Word64 -> m Bool
send206 Word64
start Word64
end
withRange (SuffixRangeReq Word64
nbytes) = do
let end :: Word64
end = Word64
szWord64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
-Word64
1
let start :: Word64
start = Word64
sz Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
nbytes
FilePath -> m ()
forall (m :: * -> *). MonadIO m => FilePath -> m ()
dbg (FilePath -> m ()) -> FilePath -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath
"withRange: start=" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Word64 -> FilePath
forall a. Show a => a -> FilePath
Prelude.show Word64
start
FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
", end=" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Word64 -> FilePath
forall a. Show a => a -> FilePath
Prelude.show Word64
end
if Word64
start Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
< Word64
0 Bool -> Bool -> Bool
|| Word64
end Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
< Word64
start Bool -> Bool -> Bool
|| Word64
start Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word64
sz Bool -> Bool -> Bool
|| Word64
end Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word64
sz
then m Bool
send416
else Word64 -> Word64 -> m Bool
forall (m :: * -> *). MonadSnap m => Word64 -> Word64 -> m Bool
send206 Word64
start Word64
end
send206 :: Word64 -> Word64 -> m Bool
send206 Word64
start Word64
end = do
FilePath -> m ()
forall (m :: * -> *). MonadIO m => FilePath -> m ()
dbg FilePath
"inside send206"
let !len :: Word64
len = Word64
endWord64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
-Word64
startWord64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+Word64
1
let crng :: ByteString
crng = [ByteString] -> ByteString
S.concat ([ByteString] -> ByteString)
-> (ByteString -> [ByteString]) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
L.toChunks (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$
Builder -> ByteString
toLazyByteString (Builder -> ByteString) -> Builder -> ByteString
forall a b. (a -> b) -> a -> b
$
[Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat [ ByteString -> Builder
byteString ByteString
"bytes "
, Word64 -> Builder
forall a. Show a => a -> Builder
fromShow Word64
start
, Char -> Builder
char8 Char
'-'
, Word64 -> Builder
forall a. Show a => a -> Builder
fromShow Word64
end
, Char -> Builder
char8 Char
'/'
, Word64 -> Builder
forall a. Show a => a -> Builder
fromShow Word64
sz ]
(Response -> Response) -> m ()
forall (m :: * -> *). MonadSnap m => (Response -> Response) -> m ()
modifyResponse ((Response -> Response) -> m ()) -> (Response -> Response) -> m ()
forall a b. (a -> b) -> a -> b
$ Int -> Response -> Response
setResponseCode Int
206
(Response -> Response)
-> (Response -> Response) -> Response -> Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CI ByteString -> ByteString -> Response -> Response
forall a. HasHeaders a => CI ByteString -> ByteString -> a -> a
setHeader CI ByteString
"Content-Range" ByteString
crng
(Response -> Response)
-> (Response -> Response) -> Response -> Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Response -> Response
setContentLength Word64
len
FilePath -> m ()
forall (m :: * -> *). MonadIO m => FilePath -> m ()
dbg (FilePath -> m ()) -> FilePath -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath
"send206: sending range (" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Word64 -> FilePath
forall a. Show a => a -> FilePath
Prelude.show Word64
start
FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"," FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Word64 -> FilePath
forall a. Show a => a -> FilePath
Prelude.show (Word64
endWord64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+Word64
1) FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
") to sendFilePartial"
FilePath -> (Word64, Word64) -> m ()
forall (m :: * -> *).
MonadSnap m =>
FilePath -> (Word64, Word64) -> m ()
sendFilePartial FilePath
fp (Word64
start,Word64
endWord64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+Word64
1)
Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
send416 :: m Bool
send416 = do
FilePath -> m ()
forall (m :: * -> *). MonadIO m => FilePath -> m ()
dbg FilePath
"inside send416"
if CI ByteString -> Request -> Maybe ByteString
forall a. HasHeaders a => CI ByteString -> a -> Maybe ByteString
getHeader CI ByteString
"If-Range" Request
req Maybe ByteString -> Maybe ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe ByteString
forall a. Maybe a
Nothing
then Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
else do
let crng :: ByteString
crng = [ByteString] -> ByteString
S.concat ([ByteString] -> ByteString)
-> (ByteString -> [ByteString]) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
L.toChunks (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$
Builder -> ByteString
toLazyByteString (Builder -> ByteString) -> Builder -> ByteString
forall a b. (a -> b) -> a -> b
$
[Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat [ ByteString -> Builder
byteString ByteString
"bytes */"
, Word64 -> Builder
forall a. Show a => a -> Builder
fromShow Word64
sz ]
(Response -> Response) -> m ()
forall (m :: * -> *). MonadSnap m => (Response -> Response) -> m ()
modifyResponse ((Response -> Response) -> m ()) -> (Response -> Response) -> m ()
forall a b. (a -> b) -> a -> b
$ Int -> Response -> Response
setResponseCode Int
416
(Response -> Response)
-> (Response -> Response) -> Response -> Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CI ByteString -> ByteString -> Response -> Response
forall a. HasHeaders a => CI ByteString -> ByteString -> a -> a
setHeader CI ByteString
"Content-Range" ByteString
crng
(Response -> Response)
-> (Response -> Response) -> Response -> Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Response -> Response
setContentLength Word64
0
(Response -> Response)
-> (Response -> Response) -> Response -> Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CI ByteString -> Response -> Response
forall a. HasHeaders a => CI ByteString -> a -> a
deleteHeader CI ByteString
"Content-Type"
(Response -> Response)
-> (Response -> Response) -> Response -> Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CI ByteString -> Response -> Response
forall a. HasHeaders a => CI ByteString -> a -> a
deleteHeader CI ByteString
"Content-Encoding"
(Response -> Response)
-> (Response -> Response) -> Response -> Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CI ByteString -> Response -> Response
forall a. HasHeaders a => CI ByteString -> a -> a
deleteHeader CI ByteString
"Transfer-Encoding"
(Response -> Response)
-> (Response -> Response) -> Response -> Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (OutputStream Builder -> IO (OutputStream Builder))
-> Response -> Response
setResponseBody (OutputStream Builder -> IO (OutputStream Builder)
forall (m :: * -> *) a. Monad m => a -> m a
return (OutputStream Builder -> IO (OutputStream Builder))
-> (OutputStream Builder -> OutputStream Builder)
-> OutputStream Builder
-> IO (OutputStream Builder)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OutputStream Builder -> OutputStream Builder
forall a. a -> a
id)
Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
dbg :: (MonadIO m) => String -> m ()
dbg :: FilePath -> m ()
dbg FilePath
s = FilePath -> m ()
forall (m :: * -> *). MonadIO m => FilePath -> m ()
debug (FilePath -> m ()) -> FilePath -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath
"FileServe:" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
s
uriWithoutQueryString :: Request -> ByteString
uriWithoutQueryString :: Request -> ByteString
uriWithoutQueryString Request
rq = (Char -> Bool) -> ByteString -> ByteString
S.takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'?') ByteString
uri
where
uri :: ByteString
uri = Request -> ByteString
rqURI Request
rq
queryStringSuffix :: Request -> ByteString
queryStringSuffix :: Request -> ByteString
queryStringSuffix Request
rq = [ByteString] -> ByteString
S.concat [ ByteString
s, ByteString
qs ]
where
qs :: ByteString
qs = Request -> ByteString
rqQueryString Request
rq
s :: ByteString
s = if ByteString -> Bool
S.null ByteString
qs then ByteString
"" else ByteString
"?"
fromShow :: Show a => a -> Builder
fromShow :: a -> Builder
fromShow = FilePath -> Builder
stringUtf8 (FilePath -> Builder) -> (a -> FilePath) -> a -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> FilePath
forall a. Show a => a -> FilePath
show