summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--.gitignore1
-rw-r--r--COPYING14
-rw-r--r--Network/Wai/Middleware/Time.hs59
-rw-r--r--Setup.hs3
-rw-r--r--wai-middleware-time.cabal29
5 files changed, 106 insertions, 0 deletions
diff --git a/.gitignore b/.gitignore
new file mode 100644
index 0000000..9b1c8b1
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1 @@
+/dist
diff --git a/COPYING b/COPYING
new file mode 100644
index 0000000..ee7d6a5
--- /dev/null
+++ b/COPYING
@@ -0,0 +1,14 @@
+ DO WHAT THE FUCK YOU WANT TO PUBLIC LICENSE
+ Version 2, December 2004
+
+ Copyright (C) 2004 Sam Hocevar <sam@hocevar.net>
+
+ Everyone is permitted to copy and distribute verbatim or modified
+ copies of this license document, and changing it is allowed as long
+ as the name is changed.
+
+ DO WHAT THE FUCK YOU WANT TO PUBLIC LICENSE
+ TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION
+
+ 0. You just DO WHAT THE FUCK YOU WANT TO.
+
diff --git a/Network/Wai/Middleware/Time.hs b/Network/Wai/Middleware/Time.hs
new file mode 100644
index 0000000..2a1d034
--- /dev/null
+++ b/Network/Wai/Middleware/Time.hs
@@ -0,0 +1,59 @@
+-- {-# LANGUAGE OverloadedStrings #-}
+-- |
+-- Module : Network.Wai.Middleware.Time
+-- License : WTFPL2
+--
+-- Maintainer : tv@destroy.retiolum
+--
+-- WAI X-Response-Time middleware.
+
+module Network.Wai.Middleware.Time
+ ( time
+ ) where
+
+import Control.Monad.Trans (liftIO)
+import Data.ByteString.Char8 (ByteString, pack)
+import Data.CaseInsensitive (mk)
+import Network.HTTP.Types.Header (HeaderName)
+import Network.HTTP.Types (ResponseHeaders)
+import Network.Wai.Internal (Response (..))
+import Network.Wai (Middleware)
+import System.Clock (getTime, Clock(Monotonic), sec, nsec, TimeSpec)
+import Text.Printf (printf)
+
+getTimeMonotonic :: IO TimeSpec
+getTimeMonotonic = liftIO $ getTime Monotonic
+
+-- | Use time to append an X-Response-Time header to the response.
+time :: Middleware
+time app rq = do
+ t0 <- getTimeMonotonic
+ rs <- app rq
+ t1 <- getTimeMonotonic
+ return $ addResponseTime (timeSpecsToByteString t0 t1) rs
+
+addResponseTime :: ByteString -> Response -> Response
+addResponseTime xrt rs = do
+ case rs of
+ (ResponseFile st hs path part) ->
+ ResponseFile st (responseTime xrt hs) path part
+ (ResponseBuilder st hs b) ->
+ ResponseBuilder st (responseTime xrt hs) b
+ (ResponseSource st hs s) ->
+ ResponseSource st (responseTime xrt hs) s
+ (ResponseRaw rawapp r) ->
+ ResponseRaw rawapp $ addResponseTime xrt r
+
+hResponseTime :: HeaderName
+hResponseTime = mk . pack $ "X-Response-Time"
+
+responseTime :: ByteString -> ResponseHeaders -> ResponseHeaders
+responseTime xrt =
+ (:) (hResponseTime, xrt)
+
+timeSpecsToByteString :: TimeSpec -> TimeSpec -> ByteString
+timeSpecsToByteString t0 t1 =
+ pack $ printf "%d.%09ds" s ns
+ where
+ s = (sec t1) - (sec t0)
+ ns = (nsec t1) - (nsec t0)
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
index 0000000..cd7dc32
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,3 @@
+#!/usr/bin/env runhaskell
+import Distribution.Simple
+main = defaultMain
diff --git a/wai-middleware-time.cabal b/wai-middleware-time.cabal
new file mode 100644
index 0000000..90e857b
--- /dev/null
+++ b/wai-middleware-time.cabal
@@ -0,0 +1,29 @@
+name: wai-middleware-time
+version: 0.0
+license: OtherLicense
+license-file: COPYING
+author: tv
+maintainer: tv@destroy.retiolum
+category: Web
+synopsis: WAI X-Response-Time middleware.
+description:
+ WAI middleware that attaches X-Response-Time headers to responses.
+
+build-type: Simple
+cabal-version: >= 1.10
+
+source-repository head
+ type: git
+ location: gitolite@destroy.retiolum:wai-middleware-time
+
+library
+ build-depends: base >= 4.6 && < 4.7
+ , bytestring >= 0.1.0
+ , case-insensitive >= 1.1.0.3
+ , clock >= 0.3
+ , http-types >= 0.8.3
+ , mtl >= 2.1.3.1
+ , wai >= 2.0.0
+ exposed-modules: Network.Wai.Middleware.Time
+ ghc-options: -Wall
+ default-language: Haskell2010