Performance improvements

  * file serve: serve files using mmap()
  * add more efficient C functions for time parsing

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

cbits/timefuncs.c

@@ -0,0 +1,20 @@
+#include <time.h>
+#include <locale.h>
+
+
+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);
+}

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

src/Snap/Internal/Http/Types.hs

@@ -6,6 +6,7 @@
 
 {-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE EmptyDataDecls #-}
+{-# LANGUAGE ForeignFunctionInterface #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE TypeSynonymInstances #-}
@@ -32,13 +33,29 @@ 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)
 
 ------------------------------------------------------------------------------
 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

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