diff options
| -rw-r--r-- | .gitignore | 1 | ||||
| -rw-r--r-- | COPYING | 14 | ||||
| -rw-r--r-- | Network/Wai/Middleware/Time.hs | 59 | ||||
| -rw-r--r-- | Setup.hs | 3 | ||||
| -rw-r--r-- | wai-middleware-time.cabal | 29 |
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 @@ -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 |