initial commit

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