module Network.Salvia.Handler.File
( hFile
, hFileResource
, fileMime
, hFileFilter
, hFileResourceFilter
, hResource
, hUri
)
where
import Control.Applicative
import Control.Category
import Control.Monad.State hiding (get)
import Data.ByteString.Lazy.UTF8 (fromString)
import Data.Digest.Pure.MD5
import Data.Maybe
import Data.Record.Label
import Data.Time
import Data.Time.Clock.POSIX
import Network.Protocol.Http
import Network.Protocol.Mime
import Network.Protocol.Uri
import Network.Salvia.Handler.Error
import Network.Salvia.Handler.Range
import Network.Salvia.Interface
import Prelude hiding ((.), id)
import System.IO
import System.Locale
import System.Posix.Files
import qualified Data.ByteString.Lazy as B
hFileResource :: (MonadIO m, HttpM' m, SendM m) => FilePath -> m ()
hFileResource file =
hSafeIO (openBinaryFile file ReadMode) $ \fd ->
do fs <- liftIO (hFileSize fd)
rng <- request (getM range)
mt <- liftIO $
formatTime defaultTimeLocale "%a, %d %b %Y %H:%M:%S %z"
. posixSecondsToUTCTime
. realToFrac
. modificationTime <$> getFileStatus file
let etag = show . md5 $ fromString mt
response $
do contentType =: Just (fileMime file, Nothing)
contentLength =: Just fs
lastModified =: Just mt
eTag =: Just etag
acceptRanges =: Just "bytes"
status =: OK
case rng of
Just (Range (Just from) to _) ->
do let t = fromMaybe (fs 1) to
r = Range (Just from) (Just t) (Just fs)
response $
do status =: PartialContent
contentRange =: Just r
contentLength =: Just (t from + 1)
let chop = maybe id (B.take . fromIntegral . (subtract from)) to
spoolWithBs (chop . B.drop (fromIntegral from)) fd
return ()
_ -> spoolWithBs id fd
fileMime :: FilePath -> Mime
fileMime file =
maybe defaultMime id
$ (either (const Nothing) Just (parseUri file)
>>= mimetype . get path)
hFileResourceFilter :: (MonadIO m, HttpM Response m, SendM m) => (String -> String) -> FilePath -> m ()
hFileResourceFilter f file =
hSafeIO (openFile file ReadMode) $ \fd ->
do response $
do contentType =: Just (fileMime file, Just "utf-8")
status =: OK
spoolWith f fd
hResource :: HttpM Request m => (FilePath -> m a) -> m a
hResource rh = request (getM (path . asUri)) >>= rh
hUri :: HttpM Request m => (Uri -> m a) -> m a
hUri rh = request (getM asUri) >>= rh
hFile :: (MonadIO m, HttpM' m, SendM m) => m ()
hFile = hResource hFileResource
hFileFilter :: (MonadIO m, HttpM' m, SendM m) => (String -> String) -> m ()
hFileFilter = hResource . hFileResourceFilter