implemanting Date.

warp/Network/Wai/Handler/Warp/Date.hs

@@ -0,0 +1,55 @@
+{-# LANGUAGE CPP #-}
+
+module Network.Wai.Handler.Warp.Date (
+    withDateCache
+  , getDate
+  , DateCache
+  , GMTDate
+  ) where
+
+import Control.Applicative
+import Control.Concurrent
+import Control.Exception
+import Control.Monad
+import Data.ByteString.Char8
+import Data.IORef
+
+#if WINDOWS
+import Data.Time
+import System.Locale
+#else
+import Network.HTTP.Date
+import System.Posix (epochTime)
+#endif
+
+type GMTDate = ByteString
+
+data DateCache = DateCache (IORef GMTDate)
+
+withDateCache :: (DateCache -> IO a) -> IO a
+withDateCache action = bracket initialize
+                               (\(t,_) -> killThread t)
+                               (\(_,dc) -> action dc)
+
+initialize :: IO (ThreadId, DateCache)
+initialize = do
+    dc <- DateCache <$> (getCurrentGMTDate >>= newIORef)
+    t <- forkIO $ forever $ do
+        threadDelay 1000000
+        update dc
+    return (t, dc)
+
+getDate :: DateCache -> IO GMTDate
+getDate (DateCache ref) = readIORef ref
+
+update :: DateCache -> IO ()
+update (DateCache ref) = getCurrentGMTDate >>= writeIORef ref
+
+getCurrentGMTDate :: IO GMTDate
+#ifdef WINDOWS
+getCurrentGMTDate = formatDate <$> getCurrentTime
+  where
+    formatDate = pack . formatTime defaultTimeLocale "%a, %d %b %Y %H:%M:%S GMT"
+#else
+getCurrentGMTDate = formatHTTPDate . epochTimeToHTTPDate <$> epochTime
+#endif

warp/warp.cabal

@@ -55,6 +55,7 @@ Library
   Exposed-modules:   Network.Wai.Handler.Warp
                      Network.Wai.Handler.Warp.Timeout
   Other-modules:     Network.Wai.Handler.Warp.Conduit
+                     Network.Wai.Handler.Warp.Date
                      Network.Wai.Handler.Warp.FdCache
                      Network.Wai.Handler.Warp.Header
                      Network.Wai.Handler.Warp.ReadInt
@@ -76,8 +77,11 @@ Library
       Other-modules: Network.Wai.Handler.Warp.MultiMap
   if os(windows)
       Cpp-Options:   -DWINDOWS
+      Build-Depends: time
+                   , old-locale
   else
       Build-Depends: unix
+                   , http-date
 
 Test-Suite doctest
   Type:                 exitcode-stdio-1.0
@@ -126,6 +130,8 @@ Test-Suite spec
                    , QuickCheck
                    , hspec                    >= 1.3
                    , resourcet
+                   , time
+                   , old-locale
 
     -- Yes, this means that the test suite will no longer work on Windows.
     -- Unfortunately there is a bug in older versions of cabal, and this conditional
@@ -133,7 +139,8 @@ Test-Suite spec
   --if (os(linux) || os(freebsd) || os(darwin)) && flag(allow-sendfilefd)
     Cpp-Options:   -DSENDFILEFD
     Build-Depends: unix
-                   , hashable
+                 , hashable
+                 , http-date
   --if os(windows)
   --    Cpp-Options:   -DWINDOWS