Permalink
Browse files

Send 'Date' header.

Uses code copied from happstack-server.
  • Loading branch information...
1 parent f7c4805 commit ac143164ebb2c5a4e2d3e7681db1270adb20d234 @aslatter committed Feb 11, 2012
Showing with 92 additions and 7 deletions.
  1. +3 −1 happstack-wai.cabal
  2. +67 −0 src/Happstack/Server/Internal/Clock.hs
  3. +22 −6 src/Happstack/Server/Wai.hs
View
@@ -17,8 +17,8 @@ cabal-version: >=1.8
library
exposed-modules: Happstack.Server.Wai
+ other-modules: Happstack.Server.Internal.Clock
hs-source-dirs: src
- -- other-modules:
build-depends: base,
bytestring == 0.9.*,
@@ -27,7 +27,9 @@ library
containers == 0.4.*,
happstack-server == 6.5.*,
http-types == 0.6.*,
+ old-locale == 1.0.*,
text == 0.11.*,
+ time == 1.4.*,
transformers == 0.2.*,
wai == 1.1.*,
warp == 1.1.*
@@ -0,0 +1,67 @@
+{-# OPTIONS -fno-cse #-}
+
+{-
+From happstack-server
+License BSD3
+Author Happstack team, HAppS LLC
+ -}
+
+module Happstack.Server.Internal.Clock
+ ( getApproximateTime
+ , getApproximatePOSIXTime
+ , getApproximateUTCTime
+ , formatHttpDate
+ ) where
+
+import Control.Applicative ((<$>))
+import Control.Concurrent
+import Data.IORef
+import Data.Time.Clock (UTCTime)
+import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime, posixSecondsToUTCTime)
+import Data.Time.Format (formatTime)
+import System.IO.Unsafe
+import System.Locale
+
+import qualified Data.ByteString.Char8 as B
+
+data DateCache = DateCache {
+ cachedPOSIXTime :: !(IORef POSIXTime)
+ , cachedHttpDate :: !(IORef B.ByteString)
+ }
+
+formatHttpDate :: UTCTime -> String
+formatHttpDate = formatTime defaultTimeLocale "%a, %d %b %Y %X GMT"
+{-# INLINE formatHttpDate #-}
+
+mkTime :: IO (POSIXTime, B.ByteString)
+mkTime =
+ do now <- getPOSIXTime
+ return (now, B.pack $ formatHttpDate (posixSecondsToUTCTime now))
+
+{-# NOINLINE clock #-}
+clock :: DateCache
+clock = unsafePerformIO $ do
+ (now, httpDate) <- mkTime
+ nowRef <- newIORef now
+ httpDateRef <- newIORef httpDate
+ let dateCache = (DateCache nowRef httpDateRef)
+ forkIO $ updater dateCache
+ return dateCache
+
+updater :: DateCache -> IO ()
+updater dateCache =
+ do threadDelay (10^(6 :: Int)) -- Every second
+ (now, httpDate) <- mkTime
+ writeIORef (cachedPOSIXTime dateCache) now
+ writeIORef (cachedHttpDate dateCache) httpDate
+ updater dateCache
+
+getApproximateTime :: IO B.ByteString
+getApproximateTime = readIORef (cachedHttpDate clock)
+
+getApproximatePOSIXTime :: IO POSIXTime
+getApproximatePOSIXTime = readIORef (cachedPOSIXTime clock)
+
+getApproximateUTCTime :: IO UTCTime
+getApproximateUTCTime = posixSecondsToUTCTime <$> getApproximatePOSIXTime
+
@@ -7,6 +7,7 @@ module Happstack.Server.Wai
-- ** Low-level functions
, convertRequest
, convertResponse
+ , standardHeaders
) where
import Control.Applicative
@@ -22,6 +23,7 @@ import Data.Text (Text)
import qualified Data.Text as T
import qualified Happstack.Server as H
+import qualified Happstack.Server.Internal.Clock as H
import qualified Happstack.Server.Internal.Cookie as H
import qualified Happstack.Server.Internal.MessageWrap as H
@@ -38,15 +40,17 @@ toApplication :: H.ServerPart H.Response -> W.Application
toApplication sp wReq = do
hReq <- convertRequest wReq
hResp <- liftIO $ H.simpleHTTP'' sp hReq
- return $ convertResponse hResp
+ additionalHeaders <- liftIO standardHeaders
+ return $ convertResponse additionalHeaders hResp
-- | Run a 'H.ServerPart' on warp at the specified port.
run :: Warp.Port -> H.ServerPart H.Response -> IO ()
run port = Warp.run port . toApplication
-- TODO - return '400 bad request' if we can't convert it
-- | Convert a WAI 'W.Request' to a Happstack 'H.Request'.
-convertRequest :: W.Request -> ResourceT IO H.Request
+convertRequest :: W.Request -- ^ WAI request
+ -> ResourceT IO H.Request
convertRequest wReq = do
bodyInputRef <- liftIO newEmptyMVar
bodyLbs <- BL.fromChunks <$> C.lazyConsume (W.requestBody wReq)
@@ -131,9 +135,22 @@ convertMethod m =
W.CONNECT -> H.CONNECT
W.OPTIONS -> H.OPTIONS
+-- | 'Date' header and server identification.
+standardHeaders :: IO W.ResponseHeaders
+standardHeaders = do
+ dtStr <- H.getApproximateTime
+ return
+ [ ("Date", dtStr)
+ , serverIdent
+ , waiIdent
+ ]
+
-- | Convert a Happstack 'H.Response' to a WAI 'W.Response'
-convertResponse :: H.Response -> W.Response
-convertResponse hResp =
+convertResponse :: W.ResponseHeaders
+ -- ^ Headers not in the response to send to the client (see 'standardHeaders')
+ -> H.Response -- ^ Happstack response
+ -> W.Response
+convertResponse additionalHeaders hResp =
case hResp of
H.SendFile{H.sfOffset=off,H.sfCount=count,H.sfFilePath=filePath}
->
@@ -145,8 +162,7 @@ convertResponse hResp =
-- TODO description
status = W.Status (H.rsCode hResp) ""
headersNoCl =
- (serverIdent :) $
- (waiIdent :) $
+ (additionalHeaders ++) $
concatMap (\(H.HeaderPair k vs) -> map (\v -> (CI.mk k, v)) vs) $
Map.elems (H.rsHeaders hResp)
headers =

0 comments on commit ac14316

Please sign in to comment.