1 {-# LANGUAGE OverloadedStrings #-}
    2 module HTTP.File
    3   ( fileResponse
    4   , serveFile
    5   ) where
    6 
    7 import Control.Monad (when)
    8 import Control.Monad.IO.Class (liftIO)
    9 import qualified Data.ByteString as BS
   10 import Data.Monoid ((<>))
   11 import Network.HTTP.Types (ResponseHeaders, hLastModified, hContentType, hCacheControl, hIfModifiedSince, notModified304, hIfRange)
   12 import System.Posix.Types (FileOffset)
   13 
   14 import Ops
   15 import Has
   16 import Files
   17 import HTTP.Request
   18 import HTTP
   19 import Action
   20 import Model.Format
   21 
   22 fileResponse :: RawFilePath -> Format -> Maybe BS.ByteString -> BS.ByteString -> Handler (ResponseHeaders, Maybe FileOffset)
   23 fileResponse file fmt save etag = do
   24   (sz, mt) <- maybeAction =<< liftIO (fileInfo file)
   25   let fh =
   26         [ ("etag", quoteHTTP etag)
   27         , (hLastModified, formatHTTPTimestamp mt)
   28         , (hContentType, formatMimeType fmt)
   29         , ("content-disposition", maybe "inline" (\n -> "attachment; filename="
   30             <> quoteHTTP (addFormatExtension n fmt)) save)
   31         , (hCacheControl, "max-age=31556926, private")
   32         ]
   33   req <- peek
   34   let ifnm = map unquoteHTTP $ (splitHTTP =<<) $ lookupRequestHeaders "if-none-match" req
   35       notmod
   36         | null ifnm = any (mt <=) $ (parseHTTPTimestamp =<<) $ lookupRequestHeader hIfModifiedSince req
   37         | otherwise = any (\m -> m == "*" || m == etag) ifnm
   38   when notmod $ result $ emptyResponse notModified304 fh
   39   return (fh,
   40     -- allow range detection or force full file:
   41     any ((etag /=) . unquoteHTTP) (lookupRequestHeader hIfRange req) `thenUse` sz)
   42 
   43 serveFile :: RawFilePath -> Format -> Maybe BS.ByteString -> BS.ByteString -> Handler Response
   44 serveFile file fmt save etag = do
   45   (h, part) <- fileResponse file fmt save etag
   46   fp <- liftIO $ unRawFilePath file
   47   return $ okResponse h (fp, part)