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 "?"