1 {-# LANGUAGE OverloadedStrings #-}
    2 module Databrary.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 Databrary.Ops
   15 import Databrary.Has
   16 import Databrary.Files
   17 import Databrary.HTTP.Request
   18 import Databrary.HTTP
   19 import Databrary.Action
   20 import Databrary.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)