From c643e0cec421f6af4b6985ad85d980cbbfc3b0c8 Mon Sep 17 00:00:00 2001 From: Gregory Collins Date: Sun, 25 Apr 2010 17:40:56 -0400 Subject: [PATCH] Performance improvements * file serve: serve files using mmap() * add more efficient C functions for time parsing --- TODO | 2 +- cbits/timefuncs.c | 20 +++++++++++++++ snap-core.cabal | 8 ++++++ src/Snap/Internal/Http/Types.hs | 31 ++++++++++++++++++++++-- src/Snap/Util/FileServe.hs | 43 +++++++++++++++++++++------------ 5 files changed, 85 insertions(+), 19 deletions(-) create mode 100644 cbits/timefuncs.c diff --git a/TODO b/TODO index ae1e0182..33bdb65c 100644 --- a/TODO +++ b/TODO @@ -21,7 +21,7 @@ - links to source control :END: - +** TODO [#A] Mention that Snap is for unix systems only * TODO [#A] Finish HTTP server test suite * TODO [#A] Review HTTP server code for exception safety diff --git a/cbits/timefuncs.c b/cbits/timefuncs.c new file mode 100644 index 00000000..6d986324 --- /dev/null +++ b/cbits/timefuncs.c @@ -0,0 +1,20 @@ +#include +#include + + +void set_c_locale() { + setlocale(LC_TIME, "C"); +} + + +time_t c_parse_http_time(char* s) { + struct tm dest; + strptime(s, "%a, %d %b %Y %H:%M:%S GMT", &dest); + return mktime(&dest); +} + +void c_format_http_time(time_t src, char* dest) { + struct tm t; + gmtime_r(&src, &t); + strftime(dest, 40, "%a, %d %b %Y %H:%M:%S GMT", &t); +} diff --git a/snap-core.cabal b/snap-core.cabal index 5c2514ac..f3f3ae4f 100644 --- a/snap-core.cabal +++ b/snap-core.cabal @@ -42,6 +42,9 @@ category: Web Library hs-source-dirs: src + c-sources: cbits/timefuncs.c + include-dirs: cbits + exposed-modules: Data.CIByteString, Snap.Types, @@ -60,6 +63,7 @@ Library attoparsec >= 0.8.0.2 && < 0.9, base >= 4 && < 5, bytestring, + bytestring-mmap >= 0.2.1 && <0.3, bytestring-nums, cereal >= 0.2 && < 0.3, containers, @@ -75,6 +79,8 @@ Library unix, zlib + ghc-prof-options: -prof -auto-all + if impl(ghc >= 6.12.0) ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2 -fno-warn-unused-do-bind @@ -105,6 +111,8 @@ Executable snap unix, zlib + ghc-prof-options: -prof -auto-all + if impl(ghc >= 6.12.0) ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2 -fno-warn-unused-do-bind diff --git a/src/Snap/Internal/Http/Types.hs b/src/Snap/Internal/Http/Types.hs index 425a142e..e04fa584 100644 --- a/src/Snap/Internal/Http/Types.hs +++ b/src/Snap/Internal/Http/Types.hs @@ -6,6 +6,7 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeSynonymInstances #-} @@ -32,6 +33,12 @@ import Data.Serialize.Builder import Data.Time.Clock import Data.Time.Format import Data.Word +import Foreign hiding (new) +import Foreign.C.Error +import Foreign.C.String +import Foreign.C.Types +import Foreign.Marshal.Alloc +import Foreign.Ptr import Prelude hiding (take) import System.Locale (defaultTimeLocale) @@ -39,6 +46,16 @@ import System.Locale (defaultTimeLocale) import Data.CIByteString import qualified Snap.Iteratee as I + +foreign import ccall unsafe "set_c_locale" + set_c_locale :: IO () + +foreign import ccall unsafe "c_parse_http_time" + c_parse_http_time :: CString -> IO CTime + +foreign import ccall unsafe "c_format_http_time" + c_format_http_time :: CTime -> CString -> IO () + ------------------------------------------------------------------------------ type Enumerator a = I.Enumerator IO a @@ -442,6 +459,7 @@ clearContentLength r = r { rspContentLength = Nothing } ------------------------------------------------------------------------------ -- HTTP dates +{- -- | Converts a 'ClockTime' into an HTTP timestamp. formatHttpTime :: UTCTime -> ByteString formatHttpTime = fromStr . formatTime defaultTimeLocale "%a, %d %b %Y %X GMT" @@ -452,10 +470,19 @@ parseHttpTime s' = parseTime defaultTimeLocale "%a, %d %b %Y %H:%M:%S GMT" s where s = toStr s' +-} +-- | Converts a 'CTime' into an HTTP timestamp. +formatHttpTime :: CTime -> IO ByteString +formatHttpTime t = allocaBytes 40 $ \ptr -> do + c_format_http_time t ptr + S.packCString ptr + +-- | Converts an HTTP timestamp into a 'CTime'. +parseHttpTime :: ByteString -> IO CTime +parseHttpTime s = S.useAsCString s $ \ptr -> + c_parse_http_time ptr ------------------------------------------------------------------------------- --- URL encoding ------------------------------------------------------------------------------ -- URL ENCODING diff --git a/src/Snap/Util/FileServe.hs b/src/Snap/Util/FileServe.hs index 29da37df..56e1791f 100644 --- a/src/Snap/Util/FileServe.hs +++ b/src/Snap/Util/FileServe.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} -- | Contains web handlers to serve files from a directory. module Snap.Util.FileServe @@ -13,20 +14,22 @@ module Snap.Util.FileServe ) where ------------------------------------------------------------------------------ +import Control.Exception import Control.Monad import Control.Monad.Trans import qualified Data.ByteString.Char8 as S import Data.ByteString.Char8 (ByteString) import Data.Iteratee.IO (enumHandle) +import Data.Iteratee.WrappedByteString import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe (fromMaybe) -import Data.Ratio ((%)) -import Data.Time.Clock -import Data.Time.Clock.POSIX +import Data.Word (Word8) +import Foreign.C.Types import System.Directory import System.FilePath import System.IO +import System.IO.Posix.MMap import System.Posix.Files import System.Time @@ -189,6 +192,7 @@ getSafePath = do fileServe :: FilePath -- ^ root directory -> Snap () fileServe = fileServe' defaultMimeTypes +{-# INLINE fileServe #-} ------------------------------------------------------------------------------ @@ -206,6 +210,7 @@ fileServe' mm root = do let fn = takeFileName fp let mime = fileType mm fn fileServeSingle' mime fp +{-# INLINE fileServe' #-} ------------------------------------------------------------------------------ @@ -216,7 +221,7 @@ fileServeSingle :: FilePath -- ^ path to file -> Snap () fileServeSingle fp = fileServeSingle' (fileType defaultMimeTypes (takeFileName fp)) fp - +{-# INLINE fileServeSingle #-} ------------------------------------------------------------------------------ -- | Same as 'fileServeSingle', with control over the MIME mapping used. @@ -225,15 +230,21 @@ fileServeSingle' :: ByteString -- ^ MIME type mapping -> Snap () fileServeSingle' mime fp = do req <- getRequest - let mbIfModified = (getHeader "if-modified-since" req >>= - parseHttpTime) + + let mbH = getHeader "if-modified-since" req + mbIfModified <- liftIO $ case mbH of + Nothing -> return Nothing + (Just s) -> liftM Just $ parseHttpTime s + -- check modification time and bug out early if the file is not modified. mt <- liftIO $ liftM clock2time $ getModificationTime fp maybe (return ()) (chkModificationTime mt) mbIfModified sz <- liftIO $ liftM (fromEnum . fileSize) $ getFileStatus fp - modifyResponse $ setHeader "Last-Modified" (formatHttpTime mt) + lm <- liftIO $ formatHttpTime mt + + modifyResponse $ setHeader "Last-Modified" lm . setContentType mime . setContentLength sz . setResponseBody (enumFile fp) @@ -267,15 +278,15 @@ defaultMimeType = "application/octet-stream" ------------------------------------------------------------------------------ enumFile :: FilePath -> Iteratee IO a -> IO (Iteratee IO a) enumFile fp iter = do - h <- liftIO $ openBinaryFile fp ReadMode - i' <- enumHandle h iter - return $ do - x <- i' - liftIO (hClose h) - return x + es <- (try $ + liftM WrapBS $ + unsafeMMapFile fp) :: IO (Either SomeException (WrappedByteString Word8)) + + case es of + (Left e) -> return $ throwErr $ Err "IO error" + (Right s) -> liftM liftI $ runIter iter $ Chunk s ------------------------------------------------------------------------------ -clock2time :: ClockTime -> UTCTime -clock2time (TOD x y) = - posixSecondsToUTCTime $ fromInteger x + fromRational (y % 1000000000000) +clock2time :: ClockTime -> CTime +clock2time (TOD x _) = fromInteger x