1 {-# LANGUAGE BangPatterns #-}
    2 {-# LANGUAGE CPP #-}
    3 {-# LANGUAGE OverloadedStrings #-}
    4 {-# LANGUAGE ScopedTypeVariables #-}
    5 
    6 -- | Contains web handlers to serve files from a directory.
    7 module Snap.Util.FileServe
    8 (
    9   getSafePath
   10   -- * Configuration for directory serving
   11 , MimeMap
   12 , HandlerMap
   13 , DirectoryConfig(..)
   14 , simpleDirectoryConfig
   15 , defaultDirectoryConfig
   16 , fancyDirectoryConfig
   17 , defaultIndexGenerator
   18 , defaultMimeTypes
   19   -- * File servers
   20 , serveDirectory
   21 , serveDirectoryWith
   22 , serveFile
   23 , serveFileAs
   24   -- * Deprecated interface
   25 , fileServe
   26 , fileServe'
   27 , fileServeSingle
   28 , fileServeSingle'
   29 ) where
   30 
   31 ------------------------------------------------------------------------------
   32 import           Blaze.ByteString.Builder
   33 import           Blaze.ByteString.Builder.Char8
   34 import           Control.Applicative
   35 import           Control.Monad
   36 import           Control.Monad.Trans
   37 import           Data.Attoparsec.Char8 hiding (Done)
   38 import qualified Data.ByteString.Char8 as S
   39 import           Data.ByteString.Char8 (ByteString)
   40 import           Data.ByteString.Internal (c2w)
   41 import           Data.Int
   42 import           Data.List
   43 import           Data.Map (Map)
   44 import qualified Data.Map as Map
   45 import           Data.Maybe (fromMaybe, isNothing)
   46 import           Data.Monoid
   47 import           Prelude hiding (show, Show)
   48 import qualified Prelude
   49 import           System.Directory
   50 import           System.FilePath
   51 import           System.PosixCompat.Files
   52 ------------------------------------------------------------------------------
   53 import           Snap.Internal.Debug
   54 import           Snap.Internal.Parsing
   55 import           Snap.Iteratee hiding (drop)
   56 import           Snap.Types
   57 
   58 
   59 ------------------------------------------------------------------------------
   60 -- | Gets a path from the 'Request' using 'rqPathInfo' and makes sure it is
   61 -- safe to use for opening files.  A path is safe if it is a relative path
   62 -- and has no ".." elements to escape the intended directory structure.
   63 getSafePath :: MonadSnap m => m FilePath
   64 getSafePath = do
   65     req <- getRequest
   66     let mp = urlDecode $ rqPathInfo req
   67 
   68     p <- maybe pass (return . S.unpack) mp
   69 
   70     -- relative paths only!
   71     when (not $ isRelative p) pass
   72 
   73     -- check that we don't have any sneaky .. paths
   74     let dirs = splitDirectories p
   75     when (elem ".." dirs) pass
   76 
   77     return $ joinPath dirs
   78 
   79 
   80 ------------------------------------------------------------------------------
   81 -- | A type alias for dynamic handlers
   82 type HandlerMap m = Map FilePath (FilePath -> m ())
   83 
   84 
   85 ------------------------------------------------------------------------------
   86 -- | A type alias for MIME type
   87 type MimeMap = Map FilePath ByteString
   88 
   89 
   90 ------------------------------------------------------------------------------
   91 -- | The default set of mime type mappings we use when serving files. Its
   92 -- value:
   93 --
   94 -- > Map.fromList [
   95 -- >   ( ".asc"     , "text/plain"                        ),
   96 -- >   ( ".asf"     , "video/x-ms-asf"                    ),
   97 -- >   ( ".asx"     , "video/x-ms-asf"                    ),
   98 -- >   ( ".avi"     , "video/x-msvideo"                   ),
   99 -- >   ( ".bz2"     , "application/x-bzip"                ),
  100 -- >   ( ".c"       , "text/plain"                        ),
  101 -- >   ( ".class"   , "application/octet-stream"          ),
  102 -- >   ( ".conf"    , "text/plain"                        ),
  103 -- >   ( ".cpp"     , "text/plain"                        ),
  104 -- >   ( ".css"     , "text/css"                          ),
  105 -- >   ( ".cxx"     , "text/plain"                        ),
  106 -- >   ( ".dtd"     , "text/xml"                          ),
  107 -- >   ( ".dvi"     , "application/x-dvi"                 ),
  108 -- >   ( ".gif"     , "image/gif"                         ),
  109 -- >   ( ".gz"      , "application/x-gzip"                ),
  110 -- >   ( ".hs"      , "text/plain"                        ),
  111 -- >   ( ".htm"     , "text/html"                         ),
  112 -- >   ( ".html"    , "text/html"                         ),
  113 -- >   ( ".jar"     , "application/x-java-archive"        ),
  114 -- >   ( ".jpeg"    , "image/jpeg"                        ),
  115 -- >   ( ".jpg"     , "image/jpeg"                        ),
  116 -- >   ( ".js"      , "text/javascript"                   ),
  117 -- >   ( ".log"     , "text/plain"                        ),
  118 -- >   ( ".m3u"     , "audio/x-mpegurl"                   ),
  119 -- >   ( ".mov"     , "video/quicktime"                   ),
  120 -- >   ( ".mp3"     , "audio/mpeg"                        ),
  121 -- >   ( ".mpeg"    , "video/mpeg"                        ),
  122 -- >   ( ".mpg"     , "video/mpeg"                        ),
  123 -- >   ( ".ogg"     , "application/ogg"                   ),
  124 -- >   ( ".pac"     , "application/x-ns-proxy-autoconfig" ),
  125 -- >   ( ".pdf"     , "application/pdf"                   ),
  126 -- >   ( ".png"     , "image/png"                         ),
  127 -- >   ( ".ps"      , "application/postscript"            ),
  128 -- >   ( ".qt"      , "video/quicktime"                   ),
  129 -- >   ( ".sig"     , "application/pgp-signature"         ),
  130 -- >   ( ".spl"     , "application/futuresplash"          ),
  131 -- >   ( ".swf"     , "application/x-shockwave-flash"     ),
  132 -- >   ( ".tar"     , "application/x-tar"                 ),
  133 -- >   ( ".tar.bz2" , "application/x-bzip-compressed-tar" ),
  134 -- >   ( ".tar.gz"  , "application/x-tgz"                 ),
  135 -- >   ( ".tbz"     , "application/x-bzip-compressed-tar" ),
  136 -- >   ( ".text"    , "text/plain"                        ),
  137 -- >   ( ".tgz"     , "application/x-tgz"                 ),
  138 -- >   ( ".torrent" , "application/x-bittorrent"          ),
  139 -- >   ( ".txt"     , "text/plain"                        ),
  140 -- >   ( ".wav"     , "audio/x-wav"                       ),
  141 -- >   ( ".wax"     , "audio/x-ms-wax"                    ),
  142 -- >   ( ".wma"     , "audio/x-ms-wma"                    ),
  143 -- >   ( ".wmv"     , "video/x-ms-wmv"                    ),
  144 -- >   ( ".xbm"     , "image/x-xbitmap"                   ),
  145 -- >   ( ".xml"     , "text/xml"                          ),
  146 -- >   ( ".xpm"     , "image/x-xpixmap"                   ),
  147 -- >   ( ".xwd"     , "image/x-xwindowdump"               ),
  148 -- >   ( ".zip"     , "application/zip"                   ) ]
  149 --
  150 defaultMimeTypes :: MimeMap
  151 defaultMimeTypes = Map.fromList [
  152   ( ".asc"     , "text/plain"                        ),
  153   ( ".asf"     , "video/x-ms-asf"                    ),
  154   ( ".asx"     , "video/x-ms-asf"                    ),
  155   ( ".avi"     , "video/x-msvideo"                   ),
  156   ( ".bz2"     , "application/x-bzip"                ),
  157   ( ".c"       , "text/plain"                        ),
  158   ( ".class"   , "application/octet-stream"          ),
  159   ( ".conf"    , "text/plain"                        ),
  160   ( ".cpp"     , "text/plain"                        ),
  161   ( ".css"     , "text/css"                          ),
  162   ( ".cxx"     , "text/plain"                        ),
  163   ( ".dtd"     , "text/xml"                          ),
  164   ( ".dvi"     , "application/x-dvi"                 ),
  165   ( ".gif"     , "image/gif"                         ),
  166   ( ".gz"      , "application/x-gzip"                ),
  167   ( ".hs"      , "text/plain"                        ),
  168   ( ".htm"     , "text/html"                         ),
  169   ( ".html"    , "text/html"                         ),
  170   ( ".jar"     , "application/x-java-archive"        ),
  171   ( ".jpeg"    , "image/jpeg"                        ),
  172   ( ".jpg"     , "image/jpeg"                        ),
  173   ( ".js"      , "text/javascript"                   ),
  174   ( ".log"     , "text/plain"                        ),
  175   ( ".m3u"     , "audio/x-mpegurl"                   ),
  176   ( ".mov"     , "video/quicktime"                   ),
  177   ( ".mp3"     , "audio/mpeg"                        ),
  178   ( ".mpeg"    , "video/mpeg"                        ),
  179   ( ".mpg"     , "video/mpeg"                        ),
  180   ( ".ogg"     , "application/ogg"                   ),
  181   ( ".pac"     , "application/x-ns-proxy-autoconfig" ),
  182   ( ".pdf"     , "application/pdf"                   ),
  183   ( ".png"     , "image/png"                         ),
  184   ( ".ps"      , "application/postscript"            ),
  185   ( ".qt"      , "video/quicktime"                   ),
  186   ( ".sig"     , "application/pgp-signature"         ),
  187   ( ".spl"     , "application/futuresplash"          ),
  188   ( ".swf"     , "application/x-shockwave-flash"     ),
  189   ( ".tar"     , "application/x-tar"                 ),
  190   ( ".tar.bz2" , "application/x-bzip-compressed-tar" ),
  191   ( ".tar.gz"  , "application/x-tgz"                 ),
  192   ( ".tbz"     , "application/x-bzip-compressed-tar" ),
  193   ( ".text"    , "text/plain"                        ),
  194   ( ".tgz"     , "application/x-tgz"                 ),
  195   ( ".torrent" , "application/x-bittorrent"          ),
  196   ( ".ttf"     , "application/x-font-truetype"       ),
  197   ( ".txt"     , "text/plain"                        ),
  198   ( ".wav"     , "audio/x-wav"                       ),
  199   ( ".wax"     , "audio/x-ms-wax"                    ),
  200   ( ".wma"     , "audio/x-ms-wma"                    ),
  201   ( ".wmv"     , "video/x-ms-wmv"                    ),
  202   ( ".xbm"     , "image/x-xbitmap"                   ),
  203   ( ".xml"     , "text/xml"                          ),
  204   ( ".xpm"     , "image/x-xpixmap"                   ),
  205   ( ".xwd"     , "image/x-xwindowdump"               ),
  206   ( ".zip"     , "application/zip"                   ) ]
  207 
  208 
  209 ------------------------------------------------------------------------------
  210 -- | A collection of options for serving static files out of a directory.
  211 data DirectoryConfig m = DirectoryConfig {
  212     -- | Files to look for when a directory is requested (e.g., index.html)
  213     indexFiles      :: [FilePath],
  214 
  215     -- | Handler to generate a directory listing if there is no index.
  216     indexGenerator  :: FilePath -> m (),
  217 
  218     -- | Map of extensions to pass to dynamic file handlers.  This could be
  219     -- used, for example, to implement CGI dispatch, pretty printing of source
  220     -- code, etc.
  221     dynamicHandlers :: HandlerMap m,
  222 
  223     -- | MIME type map to look up content types.
  224     mimeTypes       :: MimeMap,
  225 
  226     -- | Handler that is called before a file is served.  It will only be
  227     -- called when a file is actually found, not for generated index pages.
  228     preServeHook    :: FilePath -> m ()
  229     }
  230 
  231 
  232 ------------------------------------------------------------------------------
  233 -- | Style information for the default directory index generator.
  234 snapIndexStyles :: ByteString
  235 snapIndexStyles =
  236     "body { margin: 0px 0px 0px 0px; font-family: sans-serif }"
  237     `S.append` "div.header {"
  238     `S.append`     "padding: 40px 40px 0px 40px; height:35px;"
  239     `S.append`     "background:rgb(25,50,87);"
  240     `S.append`     "background-image:-webkit-gradient("
  241     `S.append`         "linear,left bottom,left top,"
  242     `S.append`         "color-stop(0.00, rgb(31,62,108)),"
  243     `S.append`         "color-stop(1.00, rgb(19,38,66)));"
  244     `S.append`     "background-image:-moz-linear-gradient("
  245     `S.append`         "center bottom,rgb(31,62,108) 0%,rgb(19,38,66) 100%);"
  246     `S.append`     "text-shadow:-1px 3px 1px rgb(16,33,57);"
  247     `S.append`     "font-size:16pt; letter-spacing: 2pt; color:white;"
  248     `S.append`     "border-bottom:10px solid rgb(46,93,156) }"
  249     `S.append` "div.content {"
  250     `S.append`     "background:rgb(255,255,255);"
  251     `S.append`     "background-image:-webkit-gradient("
  252     `S.append`         "linear,left bottom, left top,"
  253     `S.append`         "color-stop(0.50, rgb(255,255,255)),"
  254     `S.append`         "color-stop(1.00, rgb(224,234,247)));"
  255     `S.append`     "background-image:-moz-linear-gradient("
  256     `S.append`         "center bottom, white 50%, rgb(224,234,247) 100%);"
  257     `S.append`     "padding: 40px 40px 40px 40px }"
  258     `S.append` "div.footer {"
  259     `S.append`     "padding: 16px 0px 10px 10px; height:31px;"
  260     `S.append`     "border-top: 1px solid rgb(194,209,225);"
  261     `S.append`     "color: rgb(160,172,186); font-size:10pt;"
  262     `S.append`     "background: rgb(245,249,255) }"
  263     `S.append` "table { width:100% }"
  264     `S.append` "tr:hover { background:rgb(256,256,224) }"
  265     `S.append` "td { border:dotted thin black; font-family:monospace }"
  266     `S.append` "th { border:solid thin black; background:rgb(28,56,97);"
  267     `S.append`      "text-shadow:-1px 3px 1px rgb(16,33,57); color: white}"
  268 
  269 
  270 ------------------------------------------------------------------------------
  271 -- | An automatic index generator, which is fairly small and does not rely on
  272 -- any external files (which may not be there depending on external request
  273 -- routing).
  274 --
  275 -- A 'MimeMap' is passed in to display the types of files in the directory
  276 -- listing based on their extension.  Preferably, this is the same as the map
  277 -- in the 'DirectoryConfig'
  278 --
  279 -- The styles parameter allows you to apply styles to the directory listing.
  280 -- The listing itself consists of a table, containing a header row using
  281 -- th elements, and one row per file using td elements, so styles for those
  282 -- pieces may be attached to the appropriate tags.
  283 defaultIndexGenerator :: MonadSnap m
  284                       => MimeMap    -- ^ MIME type mapping for reporting types
  285                       -> ByteString -- ^ Style info to insert in header
  286                       -> FilePath   -- ^ Directory to generate index for
  287                       -> m ()
  288 defaultIndexGenerator mm styles d = do
  289     modifyResponse $ setContentType "text/html"
  290     rq      <- getRequest
  291 
  292     let uri = uriWithoutQueryString rq
  293 
  294     writeBS "<style type='text/css'>"
  295     writeBS styles
  296     writeBS "</style><div class=\"header\">Directory Listing: "
  297     writeBS uri
  298     writeBS "</div><div class=\"content\">"
  299     writeBS "<table><tr><th>File Name</th><th>Type</th><th>Last Modified"
  300     writeBS "</th></tr>"
  301 
  302     when (uri /= "/") $
  303         writeBS "<tr><td><a href='../'>..</a></td><td colspan=2>DIR</td></tr>"
  304 
  305     entries <- liftIO $ getDirectoryContents d
  306     dirs    <- liftIO $ filterM (doesDirectoryExist . (d </>)) entries
  307     files   <- liftIO $ filterM (doesFileExist . (d </>)) entries
  308 
  309     forM_ (sort $ filter (not . (`elem` ["..", "."])) dirs) $ \f -> do
  310         writeBS "<tr><td><a href='"
  311         writeBS (S.pack f)
  312         writeBS "/'>"
  313         writeBS (S.pack f)
  314         writeBS "</a></td><td colspan=2>DIR</td></tr>"
  315 
  316     forM_ (sort files) $ \f -> do
  317         stat <- liftIO $ getFileStatus (d </> f)
  318         tm   <- liftIO $ formatHttpTime (modificationTime stat)
  319         writeBS "<tr><td><a href='"
  320         writeBS (S.pack f)
  321         writeBS "'>"
  322         writeBS (S.pack f)
  323         writeBS "</a></td><td>"
  324         writeBS (fileType mm f)
  325         writeBS "</td><td>"
  326         writeBS tm
  327         writeBS "</tr>"
  328 
  329     writeBS "</table></div><div class=\"footer\">Powered by "
  330     writeBS "<b><a href=\"http://snapframework.com\">Snap</a></b></div>"
  331 
  332 
  333 ------------------------------------------------------------------------------
  334 -- | A very simple configuration for directory serving.  This configuration
  335 -- uses built-in MIME types from 'defaultMimeTypes', and has no index files,
  336 -- index generator, dynamic file handlers, or 'preServeHook'.
  337 simpleDirectoryConfig :: MonadSnap m => DirectoryConfig m
  338 simpleDirectoryConfig = DirectoryConfig {
  339     indexFiles = [],
  340     indexGenerator = const pass,
  341     dynamicHandlers = Map.empty,
  342     mimeTypes = defaultMimeTypes,
  343     preServeHook = const $ return ()
  344     }
  345 
  346 
  347 ------------------------------------------------------------------------------
  348 -- | A reasonable default configuration for directory serving.  This
  349 -- configuration uses built-in MIME types from 'defaultMimeTypes', serves
  350 -- common index files @index.html@ and @index.htm@, but does not autogenerate
  351 -- directory indexes, nor have any dynamic file handlers. The 'preServeHook'
  352 -- will not do anything.
  353 defaultDirectoryConfig :: MonadSnap m => DirectoryConfig m
  354 defaultDirectoryConfig = DirectoryConfig {
  355     indexFiles = ["index.html", "index.htm"],
  356     indexGenerator = const pass,
  357     dynamicHandlers = Map.empty,
  358     mimeTypes = defaultMimeTypes,
  359     preServeHook = const $ return ()
  360     }
  361 
  362 
  363 ------------------------------------------------------------------------------
  364 -- | A more elaborate configuration for file serving.  This configuration
  365 -- uses built-in MIME types from 'defaultMimeTypes', serves common index files
  366 -- @index.html@ and @index.htm@, and autogenerates directory indexes with a
  367 -- Snap-like feel.  It still has no dynamic file handlers, nor 'preServeHook',
  368 -- which should be added as needed.
  369 --
  370 -- Files recognized as indexes include @index.html@, @index.htm@,
  371 -- @default.html@, @default.htm@, @home.html@
  372 fancyDirectoryConfig :: MonadSnap m => DirectoryConfig m
  373 fancyDirectoryConfig = DirectoryConfig {
  374     indexFiles = ["index.html", "index.htm"],
  375     indexGenerator = defaultIndexGenerator defaultMimeTypes snapIndexStyles,
  376     dynamicHandlers = Map.empty,
  377     mimeTypes = defaultMimeTypes,
  378     preServeHook = const $ return ()
  379     }
  380 
  381 
  382 ------------------------------------------------------------------------------
  383 -- | Serves static files from a directory using the default configuration
  384 -- as given in 'defaultDirectoryConfig'.
  385 serveDirectory :: MonadSnap m
  386                => FilePath           -- ^ Directory to serve from
  387                -> m ()
  388 serveDirectory = serveDirectoryWith defaultDirectoryConfig
  389 {-# INLINE serveDirectory #-}
  390 
  391 
  392 ------------------------------------------------------------------------------
  393 -- | Serves static files from a directory.  Configuration options are
  394 -- passed in a 'DirectoryConfig' that captures various choices about desired
  395 -- behavior.  The relative path given in 'rqPathInfo' is searched for a
  396 -- requested file, and the file is served with the appropriate mime type if it
  397 -- is found. Absolute paths and \"@..@\" are prohibited to prevent files from
  398 -- being served from outside the sandbox.
  399 serveDirectoryWith :: MonadSnap m
  400                    => DirectoryConfig m  -- ^ Configuration options
  401                    -> FilePath           -- ^ Directory to serve from
  402                    -> m ()
  403 serveDirectoryWith cfg base = do
  404     b <- directory <|> file <|> redir
  405     when (not b) pass
  406 
  407   where
  408 
  409     idxs     = indexFiles cfg
  410     generate = indexGenerator cfg
  411     mimes    = mimeTypes cfg
  412     dyns     = dynamicHandlers cfg
  413     pshook   = preServeHook cfg
  414 
  415     -- Serves a file if it exists; passes if not
  416     serve f = do
  417         liftIO (doesFileExist f) >>= flip unless pass
  418         let fname          = takeFileName f
  419         let staticServe f' = pshook f >> serveFileAs (fileType mimes fname) f'
  420         lookupExt staticServe dyns fname f >> return True <|> return False
  421 
  422     -- Serves a directory via indices if available.  Returns True on success,
  423     -- False on failure to find an index.  Passes /only/ if the request was
  424     -- not for a directory (no trailing slash).
  425     directory = do
  426         rq  <- getRequest
  427         let uri = uriWithoutQueryString rq
  428         unless ("/" `S.isSuffixOf` uri) pass
  429         rel <- (base </>) <$> getSafePath
  430         b   <- liftIO $ doesDirectoryExist rel
  431         if b then do let serveRel f = serve (rel </> f)
  432                      foldl' (<|>) pass (Prelude.map serveRel idxs)
  433                          <|> (generate rel >> return True)
  434                          <|> return False
  435              else return False
  436 
  437     -- Serves a file requested by name.  Passes if the file doesn't exist.
  438     file = serve =<< ((base </>) <$> getSafePath)
  439 
  440     -- If the request is for a directory but lacks a trailing slash, redirects
  441     -- to the directory name with a trailing slash.
  442     redir = do
  443         rel <- (base </>) <$> getSafePath
  444         liftIO (doesDirectoryExist rel) >>= flip unless pass
  445         rq <- getRequest
  446         let uri = uriWithoutQueryString rq
  447         let qss = queryStringSuffix rq
  448         let u = S.concat [uri, "/", qss]
  449         redirect u
  450 
  451 
  452 ------------------------------------------------------------------------------
  453 -- | Serves a single file specified by a full or relative path.  If the file
  454 -- does not exist, throws an exception (not that it does /not/ pass to the
  455 -- next handler).   The path restrictions on 'serveDirectory' don't apply to
  456 -- this function since the path is not being supplied by the user.
  457 serveFile :: MonadSnap m
  458           => FilePath          -- ^ path to file
  459           -> m ()
  460 serveFile fp = serveFileAs (fileType defaultMimeTypes (takeFileName fp)) fp
  461 {-# INLINE serveFile #-}
  462 
  463 
  464 ------------------------------------------------------------------------------
  465 -- | Same as 'serveFile', with control over the MIME mapping used.
  466 serveFileAs :: MonadSnap m
  467             => ByteString        -- ^ MIME type
  468             -> FilePath          -- ^ path to file
  469             -> m ()
  470 serveFileAs mime fp = do
  471     reqOrig <- getRequest
  472 
  473     -- If-Range header must be ignored if there is no Range: header in the
  474     -- request (RFC 2616 section 14.27)
  475     let req = if isNothing $ getHeader "range" reqOrig
  476                 then deleteHeader "if-range" reqOrig
  477                 else reqOrig
  478 
  479     -- check "If-Modified-Since" and "If-Range" headers
  480     let mbH = getHeader "if-modified-since" req
  481     mbIfModified <- liftIO $ case mbH of
  482                                Nothing  -> return Nothing
  483                                (Just s) -> liftM Just $ parseHttpTime s
  484 
  485     -- If-Range header could contain an entity, but then parseHttpTime will
  486     -- fail and return 0 which means a 200 response will be generated anyways
  487     mbIfRange <- liftIO $ case getHeader "if-range" req of
  488                             Nothing  -> return Nothing
  489                             (Just s) -> liftM Just $ parseHttpTime s
  490 
  491     dbg $ "mbIfModified: " ++ Prelude.show mbIfModified
  492     dbg $ "mbIfRange: " ++ Prelude.show mbIfRange
  493 
  494     -- check modification time and bug out early if the file is not modified.
  495     --
  496     -- TODO: a stat cache would be nice here, but it'd need the date thread
  497     -- stuff from snap-server to be folded into snap-core
  498     filestat <- liftIO $ getFileStatus fp
  499     let mt = modificationTime filestat
  500     maybe (return $! ()) (\lt -> when (mt <= lt) notModified) mbIfModified
  501 
  502     let sz = fromIntegral $ fileSize filestat
  503     lm <- liftIO $ formatHttpTime mt
  504 
  505     -- ok, at this point we know the last-modified time and the
  506     -- content-type. set those.
  507     modifyResponse $ setHeader "Last-Modified" lm
  508                    . setHeader "Accept-Ranges" "bytes"
  509                    . setContentType mime
  510 
  511 
  512     -- now check: is this a range request? If there is an 'If-Range' header
  513     -- with an old modification time we skip this check and send a 200
  514     -- response
  515     let skipRangeCheck = maybe (False)
  516                                (\lt -> mt > lt)
  517                                mbIfRange
  518 
  519     -- checkRangeReq checks for a Range: header in the request and sends a
  520     -- partial response if it matches.
  521     wasRange <- if skipRangeCheck
  522                   then return False
  523                   else liftSnap $ checkRangeReq req fp sz
  524 
  525     dbg $ "was this a range request? " ++ Prelude.show wasRange
  526 
  527     -- if we didn't have a range request, we just do normal sendfile
  528     unless wasRange $ do
  529       modifyResponse $ setResponseCode 200
  530                      . setContentLength sz
  531       liftSnap $ sendFile fp
  532 
  533   where
  534     --------------------------------------------------------------------------
  535     notModified = finishWith $
  536                   setResponseCode 304 emptyResponse
  537 
  538 
  539 ------------------------------------------------------------------------------
  540 lookupExt :: a -> Map FilePath a -> FilePath -> a
  541 lookupExt def m f =
  542     if null ext
  543       then def
  544       else fromMaybe (lookupExt def m (drop 1 ext)) mbe
  545 
  546   where
  547     ext             = takeExtensions f
  548     mbe             = Map.lookup ext m
  549 
  550 
  551 ------------------------------------------------------------------------------
  552 fileType :: MimeMap -> FilePath -> ByteString
  553 fileType = lookupExt defaultMimeType
  554 
  555 
  556 ------------------------------------------------------------------------------
  557 defaultMimeType :: ByteString
  558 defaultMimeType = "application/octet-stream"
  559 
  560 
  561 ------------------------------------------------------------------------------
  562 data RangeReq = RangeReq { _rangeFirst :: !Int64
  563                          , _rangeLast  :: !(Maybe Int64)
  564                          }
  565               | SuffixRangeReq { _suffixLength :: !Int64 }
  566   deriving (Eq, Prelude.Show)
  567 
  568 
  569 ------------------------------------------------------------------------------
  570 rangeParser :: Parser RangeReq
  571 rangeParser = string "bytes=" *>
  572               (byteRangeSpec <|> suffixByteRangeSpec) <*
  573               endOfInput
  574   where
  575     byteRangeSpec = do
  576         start <- parseNum
  577         char '-'
  578         end   <- option Nothing $ liftM Just parseNum
  579 
  580         return $ RangeReq start end
  581 
  582     suffixByteRangeSpec = liftM SuffixRangeReq $ char '-' *> parseNum
  583 
  584 
  585 ------------------------------------------------------------------------------
  586 checkRangeReq :: (MonadSnap m) => Request -> FilePath -> Int64 -> m Bool
  587 checkRangeReq req fp sz = do
  588     -- TODO/FIXME: multiple ranges
  589     dbg $ "checkRangeReq, fp=" ++ fp ++ ", sz=" ++ Prelude.show sz
  590     maybe (return False)
  591           (\s -> either (const $ return False)
  592                         withRange
  593                         (fullyParse s rangeParser))
  594           (getHeader "range" req)
  595 
  596   where
  597     withRange rng@(RangeReq start mend) = do
  598         dbg $ "withRange: got Range request: " ++ Prelude.show rng
  599         let end = fromMaybe (sz-1) mend
  600         dbg $ "withRange: start=" ++ Prelude.show start
  601                   ++ ", end=" ++ Prelude.show end
  602 
  603         if start < 0 || end < start || start >= sz || end >= sz
  604            then send416
  605            else send206 start end
  606 
  607     withRange rng@(SuffixRangeReq nbytes) = do
  608         dbg $ "withRange: got Range request: " ++ Prelude.show rng
  609         let end   = sz-1
  610         let start = sz - nbytes
  611 
  612         dbg $ "withRange: start=" ++ Prelude.show start
  613                   ++ ", end=" ++ Prelude.show end
  614 
  615         if start < 0 || end < start || start >= sz || end >= sz
  616            then send416
  617            else send206 start end
  618 
  619     -- note: start and end INCLUSIVE here
  620     send206 start end = do
  621         dbg "inside send206"
  622         let len = end-start+1
  623         let crng = toByteString $
  624                    mconcat [ fromByteString "bytes "
  625                            , fromShow start
  626                            , fromWord8 (c2w '-')
  627                            , fromShow end
  628                            , fromWord8 (c2w '/')
  629                            , fromShow sz ]
  630 
  631         modifyResponse $ setResponseCode 206
  632                        . setHeader "Content-Range" crng
  633                        . setContentLength len
  634 
  635         dbg $ "send206: sending range (" ++ Prelude.show start
  636                 ++ "," ++ Prelude.show (end+1) ++ ") to sendFilePartial"
  637 
  638         -- end here was inclusive, sendFilePartial is exclusive
  639         sendFilePartial fp (start,end+1)
  640         return True
  641 
  642 
  643     send416 = do
  644         dbg "inside send416"
  645         -- if there's an "If-Range" header in the request, then we just send
  646         -- back 200
  647         if getHeader "If-Range" req /= Nothing
  648            then return False
  649            else do
  650                let crng = toByteString $
  651                           mconcat [ fromByteString "bytes */"
  652                                   , fromShow sz ]
  653 
  654                modifyResponse $ setResponseCode 416
  655                               . setHeader "Content-Range" crng
  656                               . setContentLength 0
  657                               . deleteHeader "Content-Type"
  658                               . deleteHeader "Content-Encoding"
  659                               . deleteHeader "Transfer-Encoding"
  660                               . setResponseBody (enumBuilder mempty)
  661 
  662                return True
  663 
  664 
  665 ------------------------------------------------------------------------------
  666 dbg :: (MonadIO m) => String -> m ()
  667 dbg s = debug $ "FileServe:" ++ s
  668 
  669 
  670 ------------------------------------------------------------------------------
  671 -- Obsolete functions retained for compatibility.
  672 ------------------------------------------------------------------------------
  673 
  674 ------------------------------------------------------------------------------
  675 -- | Serves files out of the given directory, using no index files and default
  676 -- MIME types.
  677 --
  678 -- The function name is obsolete.  You should use 'serveDirectory' or
  679 -- 'serveDirectoryWith' instead, which do similar things but with more options
  680 -- and clearer, more consistent names.
  681 fileServe :: MonadSnap m
  682           => FilePath  -- ^ root directory
  683           -> m ()
  684 fileServe = serveDirectoryWith simpleDirectoryConfig
  685 {-# INLINE fileServe #-}
  686 {-# DEPRECATED fileServe "Use serveDirectory or serveDirectoryWith" #-}
  687 
  688 
  689 ------------------------------------------------------------------------------
  690 -- | Serves files out of the given directory, with a given MIME type mapping.
  691 --
  692 -- The function name is obsolete.  You should use 'serveDirectoryWith'
  693 -- instead, which offers more options and a clearer, more consistent name.
  694 fileServe' :: MonadSnap m
  695            => MimeMap           -- ^ MIME type mapping
  696            -> FilePath          -- ^ root directory
  697            -> m ()
  698 fileServe' mm = serveDirectoryWith (simpleDirectoryConfig { mimeTypes = mm })
  699 {-# INLINE fileServe' #-}
  700 {-# DEPRECATED fileServe' "Use serveDirectoryWith instead" #-}
  701 
  702 
  703 ------------------------------------------------------------------------------
  704 -- | Serves a single file specified by a full or relative path.  The
  705 -- path restrictions on fileServe don't apply to this function since
  706 -- the path is not being supplied by the user.
  707 --
  708 -- The function name is obsolete.  You should use 'serveFile' instead, which
  709 -- does the same thing but with a clearer, more consistent name.
  710 fileServeSingle :: MonadSnap m
  711                 => FilePath          -- ^ path to file
  712                 -> m ()
  713 fileServeSingle = serveFile
  714 {-# INLINE fileServeSingle #-}
  715 {-# DEPRECATED fileServeSingle "Use serveFile instead" #-}
  716 
  717 
  718 ------------------------------------------------------------------------------
  719 -- | Same as 'fileServeSingle', with control over the MIME mapping used.
  720 --
  721 -- The function name is obsolete.  You should use 'serveFileAs' instead, which
  722 -- does the same thing but with a clearer, more consistent name.
  723 fileServeSingle' :: MonadSnap m
  724                  => ByteString        -- ^ MIME type mapping
  725                  -> FilePath          -- ^ path to file
  726                  -> m ()
  727 fileServeSingle' = serveFileAs
  728 {-# INLINE fileServeSingle' #-}
  729 {-# DEPRECATED fileServeSingle' "Use serveFileAs instead" #-}
  730 
  731 
  732 ------------------------------------------------------------------------------
  733 uriWithoutQueryString :: Request -> ByteString
  734 uriWithoutQueryString rq = S.concat [ cp, pinfo ]
  735   where
  736     cp    = rqContextPath rq
  737     pinfo = rqPathInfo rq
  738 
  739 
  740 ------------------------------------------------------------------------------
  741 queryStringSuffix :: Request -> ByteString
  742 queryStringSuffix rq = S.concat [ s, qs ]
  743   where
  744     qs = rqQueryString rq
  745     s  = if S.null qs then "" else "?"