diff --git a/CHANGELOG.md b/CHANGELOG.md
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -4,6 +4,20 @@
 The format is based on [Keep a Changelog](http://keepachangelog.com/en/1.0.0/)
 and this project adheres to [Semantic Versioning](http://semver.org/spec/v2.0.0.html)
 
+## 0.50.3
+### Added
+- Log HTTP request bodies.
+
+### Removed
+- Remove web request timeout.
+
+### Fixed
+- Do not ignore unknown start tx anchors in conduits.
+- Use fast transaction counting in cache.
+
+### Changed
+- Use WAI middlewares to manage stats.
+
 ## 0.50.2
 ### Fixed
 - Do not use lazy parsers for incoming data that may throw exceptions.
diff --git a/app/Main.hs b/app/Main.hs
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -80,7 +80,6 @@
     , configStatsdPort      :: !Int
     , configStatsdPrefix    :: !String
     , configWebRequests     :: !Int
-    , configWebReqTimeout   :: !Int
     , configWebPriceGet     :: !Int
     , configCacheThreads    :: !Int
     }
@@ -115,7 +114,6 @@
                  , configStatsdPort      = defStatsdPort
                  , configStatsdPrefix    = defStatsdPrefix
                  , configWebRequests     = defWebRequests
-                 , configWebReqTimeout   = defWebReqTimeout
                  , configWebPriceGet     = defWebPriceGet
                  , configCacheThreads    = defCacheThreads
                  }
@@ -282,11 +280,6 @@
     defEnv "CACHE_THREADS" 8 readMaybe
 {-# NOINLINE defCacheThreads #-}
 
-defWebReqTimeout :: Int
-defWebReqTimeout = unsafePerformIO $
-    defEnv "WEB_REQ_TIMEOUT" (45 * 1000 * 1000) readMaybe
-{-# NOINLINE defWebReqTimeout #-}
-
 defWebPriceGet :: Int
 defWebPriceGet = unsafePerformIO $
     defEnv "WEB_PRICE_GET" (90 * 1000 * 1000) readMaybe
@@ -550,13 +543,6 @@
         <> help "Simultaneous web requests"
         <> showDefault
         <> value (configWebRequests def)
-    configWebReqTimeout <-
-        option auto $
-        metavar "MICROSECONDS"
-        <> long "web-req-timeout"
-        <> help "Web request server timeout"
-        <> showDefault
-        <> value (configWebReqTimeout def)
     configWebPriceGet <-
         option auto $
         metavar "MICROSECONDS"
@@ -648,7 +634,6 @@
            , configStatsdPort = statsdport
            , configStatsdPrefix = statsdpfx
            , configWebRequests = wreqs
-           , configWebReqTimeout = wtimeout
            , configWebPriceGet = wpget
            , configCacheThreads = cth
            } =
@@ -696,7 +681,6 @@
                     , webNoMempool = nomem
                     , webStats = stats
                     , webRequests = wreqs
-                    , webReqTimeout = wtimeout
                     , webPriceGet = wpget
                     }
   where
diff --git a/haskoin-store.cabal b/haskoin-store.cabal
--- a/haskoin-store.cabal
+++ b/haskoin-store.cabal
@@ -4,10 +4,10 @@
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: 827fba47671e7c0038fb903785a91426dd34287b9cc01615b5b05469647de51f
+-- hash: d6fda2240441dbdfd884df223e921e20ca53b6d8d41fa6475dd99c09025afb3f
 
 name:           haskoin-store
-version:        0.50.2
+version:        0.50.3
 synopsis:       Storage and index for Bitcoin and Bitcoin Cash
 description:    Please see the README on GitHub at <https://github.com/haskoin/haskoin-store#readme>
 category:       Bitcoin, Finance, Network
@@ -81,6 +81,7 @@
     , transformers >=0.5.6.2
     , unliftio >=0.2.12.1
     , unordered-containers >=0.2.10.0
+    , vault >=0.3.1.5
     , wai >=3.2.2.1
     , wai-extra >=3.1.6
     , warp >=3.3.10
@@ -135,6 +136,7 @@
     , transformers >=0.5.6.2
     , unliftio >=0.2.12.1
     , unordered-containers >=0.2.10.0
+    , vault >=0.3.1.5
     , wai >=3.2.2.1
     , wai-extra >=3.1.6
     , warp >=3.3.10
@@ -193,6 +195,7 @@
     , transformers >=0.5.6.2
     , unliftio >=0.2.12.1
     , unordered-containers >=0.2.10.0
+    , vault >=0.3.1.5
     , wai >=3.2.2.1
     , wai-extra >=3.1.6
     , warp >=3.3.10
diff --git a/src/Haskoin/Store/Cache.hs b/src/Haskoin/Store/Cache.hs
--- a/src/Haskoin/Store/Cache.hs
+++ b/src/Haskoin/Store/Cache.hs
@@ -361,27 +361,27 @@
     => XPubSpec
     -> Limits
     -> CacheX m [TxRef]
-cacheGetXPubTxs xpub limits = do
-    score <-
-        case start limits of
-            Nothing -> return Nothing
-            Just (AtTx th) ->
-                lift (getTxData th) >>= \case
-                    Just TxData {txDataBlock = b@BlockRef {}} ->
-                        return (Just (blockRefScore b))
-                    _ -> return Nothing
-            Just (AtBlock h) ->
-                return (Just (blockRefScore (BlockRef h maxBound)))
-    xs <-
-        runRedis $
-        getFromSortedSet
-            (txSetPfx <> encode xpub)
-            score
-            (offset limits)
-            (limit limits)
-    touchKeys [xpub]
-    return $ map (uncurry f) xs
+cacheGetXPubTxs xpub limits =
+    case start limits of
+        Nothing ->
+            go Nothing
+        Just (AtTx th) -> lift (getTxData th) >>= \case
+            Just TxData {txDataBlock = b@BlockRef {}} ->
+                go $ Just (blockRefScore b)
+            Nothing ->
+                return []
+        Just (AtBlock h) ->
+            go (Just (blockRefScore (BlockRef h maxBound)))
   where
+    go score = do
+        xs <- runRedis $
+            getFromSortedSet
+                (txSetPfx <> encode xpub)
+                score
+                (offset limits)
+                (limit limits)
+        touchKeys [xpub]
+        return $ map (uncurry f) xs
     f t s = TxRef {txRefHash = t, txRefBlock = scoreBlockRef s}
 
 cacheGetXPubUnspents ::
@@ -389,25 +389,28 @@
     => XPubSpec
     -> Limits
     -> CacheX m [(BlockRef, OutPoint)]
-cacheGetXPubUnspents xpub limits = do
-    score <- case start limits of
-        Nothing -> return Nothing
+cacheGetXPubUnspents xpub limits =
+    case start limits of
+        Nothing ->
+            go Nothing
         Just (AtTx th) -> lift (getTxData th) >>= \case
             Just TxData {txDataBlock = b@BlockRef {}} ->
-                return (Just (blockRefScore b))
-            _ -> return Nothing
+                go (Just (blockRefScore b))
+            Nothing ->
+                return []
         Just (AtBlock h) ->
-            return (Just (blockRefScore (BlockRef h maxBound)))
-    xs <-
-        runRedis $
-        getFromSortedSet
-            (utxoPfx <> encode xpub)
-            score
-            (offset limits)
-            (limit limits)
-    touchKeys [xpub]
-    return $ map (uncurry f) xs
+            go (Just (blockRefScore (BlockRef h maxBound)))
   where
+    go score = do
+        xs <-
+            runRedis $
+            getFromSortedSet
+                (utxoPfx <> encode xpub)
+                score
+                (offset limits)
+                (limit limits)
+        touchKeys [xpub]
+        return $ map (uncurry f) xs
     f o s = (scoreBlockRef s, o)
 
 redisGetXPubBalances :: (Functor f, RedisCtx m f) => XPubSpec -> m (f [XPubBal])
diff --git a/src/Haskoin/Store/Database/Reader.hs b/src/Haskoin/Store/Database/Reader.hs
--- a/src/Haskoin/Store/Database/Reader.hs
+++ b/src/Haskoin/Store/Database/Reader.hs
@@ -16,8 +16,8 @@
     , balanceCF
     ) where
 
-import           Conduit                      (ConduitT, lift, mapC, runConduit,
-                                               sinkList, (.|))
+import           Conduit                      (ConduitT, dropWhileC, lift, mapC,
+                                               runConduit, sinkList, (.|))
 import           Control.Monad.Except         (runExceptT, throwError)
 import           Control.Monad.Reader         (ReaderT, ask, asks, runReaderT)
 import           Data.Bits                    ((.&.))
@@ -197,16 +197,25 @@
     f (AddrTxKey _ t) () = t
     f _ _                = undefined
     x = case s of
-        Nothing -> matching it (AddrTxKeyA a)
-        Just (AtTx txh) -> lift (getTxDataDB txh bdb) >>= \case
-            Just TxData {txDataBlock = b@BlockRef{}} ->
-                matchingSkip it (AddrTxKeyA a) (AddrTxKeyB a b)
-            _ -> matching it (AddrTxKeyA a)
+        Nothing ->
+            matching it (AddrTxKeyA a)
         Just (AtBlock bh) ->
             matchingSkip
-            it
-            (AddrTxKeyA a)
-            (AddrTxKeyB a (BlockRef bh maxBound))
+                it
+                (AddrTxKeyA a)
+                (AddrTxKeyB a (BlockRef bh maxBound))
+        Just (AtTx txh) ->
+            lift (getTxDataDB txh bdb) >>= \case
+                Just TxData {txDataBlock = b@BlockRef{}} ->
+                    matchingSkip it (AddrTxKeyA a) (AddrTxKeyB a b)
+                Just TxData {txDataBlock = MemRef{}} ->
+                    let cond (AddrTxKey _a (TxRef MemRef{} th)) =
+                            th /= txh
+                        cond (AddrTxKey _a (TxRef BlockRef{} _th)) =
+                            False
+                    in matching it (AddrTxKeyA a) .|
+                       (dropWhileC (cond . fst) >> mapC id)
+                Nothing -> return ()
 
 getAddressTxsDB ::
        MonadIO m
@@ -231,13 +240,46 @@
     -> Limits
     -> DatabaseReader
     -> m [Unspent]
-getAddressesUnspentsDB addrs limits bdb = do
-    us <-
-        concat <$>
-        mapM (\a -> getAddressUnspentsDB a (deOffset limits) bdb) addrs
-    let us' = sortBy (flip compare `on` unspentBlock) (nub' us)
-    return $ applyLimits limits us'
+getAddressesUnspentsDB addrs limits bdb@DatabaseReader{databaseHandle = db} =
+    liftIO $ iters addrs [] $ \cs ->
+    runConduit $
+    joinDescStreams cs .| applyLimitsC limits .| sinkList
+  where
+    iters [] acc f = f acc
+    iters (a : as) acc f =
+        withIterCF db (addrOutCF db) $ \it ->
+        iters as (unspentConduit a bdb (start limits) it : acc) f
 
+unspentConduit :: MonadUnliftIO m
+               => Address
+               -> DatabaseReader
+               -> Maybe Start
+               -> Iterator
+               -> ConduitT i Unspent m ()
+unspentConduit a bdb s it =
+    x .| mapC (uncurry toUnspent)
+  where
+    x = case s of
+        Nothing ->
+            matching it (AddrOutKeyA a)
+        Just (AtBlock h) ->
+            matchingSkip
+                it
+                (AddrOutKeyA a)
+                (AddrOutKeyB a (BlockRef h maxBound))
+        Just (AtTx txh) ->
+            lift (getTxDataDB txh bdb) >>= \case
+                Just TxData {txDataBlock = b@BlockRef{}} ->
+                    matchingSkip it (AddrOutKeyA a) (AddrOutKeyB a b)
+                Just TxData {txDataBlock = MemRef{}} ->
+                    let cond (AddrOutKey _a MemRef{} p) =
+                            outPointHash p /= txh
+                        cond (AddrOutKey _a BlockRef{} _p) =
+                            False
+                    in matching it (AddrOutKeyA a) .|
+                       (dropWhileC (cond . fst) >> mapC id)
+                Nothing -> return ()
+
 getAddressUnspentsDB ::
        MonadIO m
     => Address
@@ -258,8 +300,15 @@
                 (AddrOutKeyB a (BlockRef h maxBound))
         Just (AtTx txh) ->
             lift (getTxDataDB txh bdb) >>= \case
-                Just TxData {txDataBlock = b@BlockRef {}} ->
+                Just TxData {txDataBlock = b@BlockRef{}} ->
                     matchingSkip it (AddrOutKeyA a) (AddrOutKeyB a b)
+                Just TxData {txDataBlock = MemRef{}} ->
+                    let cond (AddrOutKey _a MemRef{} p) =
+                            outPointHash p /= txh
+                        cond (AddrOutKey _a BlockRef{} _p) =
+                            False
+                    in matching it (AddrOutKeyA a) .|
+                       (dropWhileC (cond . fst) >> mapC id)
                 _ -> matching it (AddrOutKeyA a)
 
 instance MonadIO m => StoreReadBase (DatabaseReaderT m) where
diff --git a/src/Haskoin/Store/Logic.hs b/src/Haskoin/Store/Logic.hs
--- a/src/Haskoin/Store/Logic.hs
+++ b/src/Haskoin/Store/Logic.hs
@@ -700,10 +700,9 @@
     let ss = map sealConduitT xs
     go Nothing =<< g ss
   where
-    g ss = let f (x, y) = (, [x]) <$> y
-               l = mapMaybe f <$> lift (traverse ($$++ await) ss)
-           in Map.fromListWith (++) <$> l
     j (x, y) = (, [x]) <$> y
+    g ss = let l = mapMaybe j <$> lift (traverse ($$++ await) ss)
+           in Map.fromListWith (++) <$> l
     go m mp = case Map.lookupMax mp of
         Nothing -> return ()
         Just (x, ss) -> do
diff --git a/src/Haskoin/Store/Web.hs b/src/Haskoin/Store/Web.hs
--- a/src/Haskoin/Store/Web.hs
+++ b/src/Haskoin/Store/Web.hs
@@ -8,6 +8,7 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TemplateHaskell     #-}
 {-# LANGUAGE TupleSections       #-}
+{-# OPTIONS_GHC -Wno-deprecations #-}
 module Haskoin.Store.Web
     ( -- * Web
       WebConfig (..)
@@ -30,7 +31,7 @@
                                                           when, (<=<))
 import           Control.Monad.Logger                    (MonadLoggerIO,
                                                           logDebugS, logErrorS,
-                                                          logInfoS)
+                                                          logInfoS, logWarnS)
 import           Control.Monad.Reader                    (ReaderT, ask, asks,
                                                           local, runReaderT)
 import           Control.Monad.Trans                     (lift)
@@ -46,6 +47,8 @@
 import           Data.Aeson.Encoding                     (encodingToLazyByteString,
                                                           list)
 import           Data.Aeson.Text                         (encodeToLazyText)
+import           Data.ByteString                         (ByteString)
+import qualified Data.ByteString                         as B
 import qualified Data.ByteString.Base16                  as B16
 import           Data.ByteString.Builder                 (lazyByteString)
 import qualified Data.ByteString.Char8                   as C
@@ -81,6 +84,7 @@
 import           Data.Time.Clock.System                  (getSystemTime,
                                                           systemSeconds,
                                                           systemToUTCTime)
+import qualified Data.Vault.Lazy                         as V
 import           Data.Word                               (Word32, Word64)
 import           Database.RocksDB                        (Property (..),
                                                           getProperty)
@@ -117,6 +121,8 @@
                                                           statusIsSuccessful)
 import           Network.Wai                             (Middleware,
                                                           Request (..),
+                                                          Response,
+                                                          getRequestBodyChunk,
                                                           responseLBS,
                                                           responseStatus)
 import           Network.Wai.Handler.Warp                (defaultSettings,
@@ -181,7 +187,6 @@
     , webNoMempool  :: !Bool
     , webStats      :: !(Maybe Metrics.Store)
     , webRequests   :: !Int
-    , webReqTimeout :: !Int
     , webPriceGet   :: !Int
     }
 
@@ -219,6 +224,8 @@
     , dbStatsStat      :: !StatDist
     , eventsConnected  :: !Metrics.Gauge
     , inFlightRequests :: !Metrics.Gauge
+    , statKey          :: !(V.Key (TVar (Maybe (WebMetrics -> StatDist))))
+    , itemsKey         :: !(V.Key (TVar Int))
     }
 
 createMetrics :: MonadIO m => Metrics.Store -> m WebMetrics
@@ -249,6 +256,8 @@
     dbStatsStat       <- d "dbstats"
     eventsConnected   <- g "events.connected"
     inFlightRequests  <- g "inflight"
+    statKey           <- V.newKey
+    itemsKey          <- V.newKey
     return WebMetrics{..}
   where
     d x = createStatDist       ("web." <> x) s
@@ -272,30 +281,15 @@
     start m = liftIO $ Metrics.Gauge.inc (gf m)
     end m = liftIO $ Metrics.Gauge.dec (gf m)
 
-withTimeout :: MonadUnliftIO m
-            => (WebMetrics -> StatDist)
-            -> WebT m a
-            -> WebT m a
-withTimeout metric go = do
-    to <- lift $ asks (webReqTimeout . webConfig)
-    m <- liftWith $ \run -> timeout to (run go)
-    case m of
-        Nothing -> raise metric ServerTimeout
-        Just x  -> restoreT $ return x
-
-withToken :: MonadUnliftIO m => WebT m a -> WebT m a
-withToken go = do
-    tok <- lift $ asks webTokens
-    minf <- lift $ asks (fmap inFlightRequests . webMetrics)
-    max_req <- lift $ asks (webRequests . webConfig)
-    x <- liftWith $ \run ->
-        bracket (t tok) (p tok) $ \rem -> do
+withToken :: Int -> TVar Int -> Maybe WebMetrics -> IO a -> IO a
+withToken max_req tok metrics go = do
+    let minf = inFlightRequests <$> metrics
+    bracket (t tok) (p tok) $ \rem -> do
         let i = fromIntegral $ max_req - rem
         case minf of
             Nothing  -> return ()
-            Just inf -> liftIO $ Metrics.Gauge.set inf i
-        run go
-    restoreT $ return x
+            Just inf -> Metrics.Gauge.set inf i
+        go
   where
     t tok = atomically $ do
         ts <- readTVar tok
@@ -304,33 +298,21 @@
         readTVar tok
     p tok _ = atomically $ modifyTVar tok (+1)
 
-withMetrics :: MonadUnliftIO m
-            => (WebMetrics -> StatDist)
-            -> Int
-            -> WebT m a
-            -> WebT m a
-withMetrics df i go =
-    lift (asks webMetrics) >>= \case
-        Nothing -> go'
-        Just m -> do
-            x <-
-                liftWith $ \run ->
-                bracket
-                (systemToUTCTime <$> liftIO getSystemTime)
-                (end m)
-                (const (run go'))
-            restoreT $ return x
+setMetrics :: MonadUnliftIO m
+           => (WebMetrics -> StatDist)
+           -> Int
+           -> WebT m ()
+setMetrics df i = asks webMetrics >>= \case
+    Nothing -> return ()
+    Just m -> do
+        req <- S.request
+        let stat_var = fromMaybe e $ V.lookup (statKey m) (vault req)
+            item_var = fromMaybe e $ V.lookup (itemsKey m) (vault req)
+        atomically $ do
+            writeTVar stat_var (Just df)
+            writeTVar item_var i
   where
-    go' = withTimeout df $ withToken go
-    end metrics t1 = do
-        t2 <- systemToUTCTime <$> liftIO getSystemTime
-        let diff = round $ diffUTCTime t2 t1 * 1000
-        everyStat metrics `addStatTime` diff
-        everyStat metrics `addStatItems` fromIntegral i
-        addStatQuery (everyStat metrics)
-        df metrics `addStatTime` diff
-        df metrics `addStatItems` fromIntegral i
-        addStatQuery (df metrics)
+    e = error "the ways of the warrior are yet to be mastered"
 
 data WebTimeouts = WebTimeouts
     { txTimeout    :: !Word64
@@ -367,6 +349,7 @@
     xPubSummary = runInWebReader . xPubSummary
     xPubUnspents xpub = runInWebReader . xPubUnspents xpub
     xPubTxs xpub = runInWebReader . xPubTxs xpub
+    xPubTxCount = runInWebReader . xPubTxCount
     getNumTxData = runInWebReader . getNumTxData
 
 instance (MonadUnliftIO m, MonadLoggerIO m) => StoreReadBase (WebT m) where
@@ -388,6 +371,7 @@
     xPubSummary = lift . xPubSummary
     xPubUnspents xpub = lift . xPubUnspents xpub
     xPubTxs xpub = lift . xPubTxs xpub
+    xPubTxCount = lift . xPubTxCount
     getMaxGap = lift getMaxGap
     getInitialGap = lift getInitialGap
     getNumTxData = lift . getNumTxData
@@ -402,11 +386,11 @@
                     , webStore = store
                     , webStats = stats
                     , webPriceGet = pget
-                    , webRequests = toks
+                    , webRequests = max_req
                     } = do
     ticker <- newTVarIO HashMap.empty
     metrics <- mapM createMetrics stats
-    tok <- newTVarIO toks
+    tok <- newTVarIO max_req
     let st = WebState
              {
                  webConfig = cfg,
@@ -416,23 +400,18 @@
              }
         net = storeNetwork store
     withAsync (price net pget ticker) $ \_ -> do
-        reqLogger <- logIt
+        reqLogger <- logIt metrics
         runner <- askRunInIO
         S.scottyOptsT opts (runner . (`runReaderT` st)) $ do
             S.middleware reqLogger
-            S.middleware $ requestSizeLimitMiddleware lim
+            S.middleware reqSizeLimit
+            S.middleware $ reqToken max_req tok metrics
             S.defaultHandler defHandler
             handlePaths
             S.notFound $ S.raise ThingNotFound
   where
-    lim = setOnLengthExceeded too_big defaultRequestSizeLimitSettings
     opts = def {S.settings = settings defaultSettings}
     settings = setPort port . setHost (fromString host)
-    too_big w64 = \_app _req send -> send $
-        responseLBS
-        requestEntityTooLarge413
-        [("Content-Type", "application/json")]
-        (A.encode $ object ["error" .= ("request size too large" :: Text)])
 
 price :: (MonadUnliftIO m, MonadLoggerIO m)
       => Network
@@ -499,9 +478,8 @@
 
 defHandler :: Monad m => Except -> WebT m ()
 defHandler e = do
-    proto <- setupContentType False
     S.status $ errStatus e
-    S.raw $ protoSerial proto toEncoding toJSON e
+    S.json e
 
 handlePaths :: (MonadUnliftIO m, MonadLoggerIO m)
             => S.ScottyT Except (ReaderT WebState m) ()
@@ -773,29 +751,44 @@
 setHeaders :: (Monad m, S.ScottyError e) => ActionT e m ()
 setHeaders = S.setHeader "Access-Control-Allow-Origin" "*"
 
+waiExcept :: Status -> Except -> Response
+waiExcept s e =
+    responseLBS s hs e'
+  where
+    hs = [ ("Access-Control-Allow-Origin", "*")
+         , ("Content-Type", "application/json")
+         ]
+    e' = A.encode e
+
+
+setupJSON :: Monad m => Bool -> ActionT Except m SerialAs
+setupJSON pretty = do
+    S.setHeader "Content-Type" "application/json"
+    p <- S.param "pretty" `S.rescue` const (return pretty)
+    return $ if p then SerialAsPrettyJSON else SerialAsJSON
+
+setupBinary :: Monad m => ActionT Except m SerialAs
+setupBinary = do
+    S.setHeader "Content-Type" "application/octet-stream"
+    return SerialAsBinary
+
 setupContentType :: Monad m => Bool -> ActionT Except m SerialAs
 setupContentType pretty = do
     accept <- S.header "accept"
-    maybe goJson setType accept
+    maybe (setupJSON pretty) setType accept
   where
-    setType "application/octet-stream" = goBinary
-    setType _                          = goJson
-    goBinary = do
-        S.setHeader "Content-Type" "application/octet-stream"
-        return SerialAsBinary
-    goJson = do
-        S.setHeader "Content-Type" "application/json"
-        p <- S.param "pretty" `S.rescue` const (return pretty)
-        return $ if p then SerialAsPrettyJSON else SerialAsJSON
+    setType "application/octet-stream" = setupBinary
+    setType _                          = setupJSON pretty
 
 -- GET Block / GET Blocks --
 
 scottyBlock ::
        (MonadUnliftIO m, MonadLoggerIO m) => GetBlock -> WebT m BlockData
-scottyBlock (GetBlock h (NoTx noTx)) =
-    withMetrics blockStat 1 $
-    maybe (raise blockStat ThingNotFound) (return . pruneTx noTx) =<<
-    getBlock h
+scottyBlock (GetBlock h (NoTx noTx)) = do
+    setMetrics blockStat 1
+    getBlock h >>= maybe
+        (raise blockStat ThingNotFound)
+        (return . pruneTx noTx)
 
 getBlocks :: (MonadUnliftIO m, MonadLoggerIO m)
           => [H.BlockHash]
@@ -806,8 +799,9 @@
 
 scottyBlocks ::
        (MonadUnliftIO m, MonadLoggerIO m) => GetBlocks -> WebT m [BlockData]
-scottyBlocks (GetBlocks hs (NoTx notx)) =
-    withMetrics blockStat (length hs) $ getBlocks hs notx
+scottyBlocks (GetBlocks hs (NoTx notx)) = do
+    setMetrics blockStat (length hs)
+    getBlocks hs notx
 
 pruneTx :: Bool -> BlockData -> BlockData
 pruneTx False b = b
@@ -817,14 +811,16 @@
 
 scottyBlockRaw :: (MonadUnliftIO m, MonadLoggerIO m)
                => GetBlockRaw -> WebT m (RawResult H.Block)
-scottyBlockRaw (GetBlockRaw h) =
-    withMetrics rawBlockStat 1 $
+scottyBlockRaw (GetBlockRaw h) = do
+    setMetrics rawBlockStat 1
     RawResult <$> getRawBlock h
 
 getRawBlock :: (MonadUnliftIO m, MonadLoggerIO m)
             => H.BlockHash -> WebT m H.Block
 getRawBlock h = do
-    b <- maybe (raise rawBlockStat ThingNotFound) return =<< getBlock h
+    b <- getBlock h >>= maybe
+        (raise rawBlockStat ThingNotFound)
+        return
     lift (toRawBlock b)
 
 toRawBlock :: (MonadUnliftIO m, StoreReadBase m) => BlockData -> m H.Block
@@ -843,8 +839,8 @@
 
 scottyBlockBest ::
        (MonadUnliftIO m, MonadLoggerIO m) => GetBlockBest -> WebT m BlockData
-scottyBlockBest (GetBlockBest (NoTx notx)) =
-    withMetrics blockStat 1 $
+scottyBlockBest (GetBlockBest (NoTx notx)) = do
+    setMetrics blockStat 1
     getBestBlock >>= \case
         Nothing -> raise blockStat ThingNotFound
         Just bb -> getBlock bb >>= \case
@@ -855,10 +851,13 @@
        (MonadUnliftIO m, MonadLoggerIO m)
     => GetBlockBestRaw
     -> WebT m (RawResult H.Block)
-scottyBlockBestRaw _ =
-    withMetrics rawBlockStat 1 $
-    fmap RawResult $
-    maybe (raise rawBlockStat ThingNotFound) getRawBlock =<< getBestBlock
+scottyBlockBestRaw _ = do
+    setMetrics rawBlockStat 1
+    bb <- getBestBlock
+    RawResult <$> maybe
+        (raise rawBlockStat ThingNotFound)
+        getRawBlock
+        bb
 
 -- GET BlockLatest --
 
@@ -866,9 +865,11 @@
        (MonadUnliftIO m, MonadLoggerIO m)
     => GetBlockLatest
     -> WebT m [BlockData]
-scottyBlockLatest (GetBlockLatest (NoTx noTx)) =
-    withMetrics blockStat 100 $
-    maybe (raise blockStat ThingNotFound) (go [] <=< getBlock) =<< getBestBlock
+scottyBlockLatest (GetBlockLatest (NoTx noTx)) = do
+    setMetrics blockStat 100
+    getBestBlock >>= maybe
+        (raise blockStat ThingNotFound)
+        (go [] <=< getBlock)
   where
     go acc Nothing = return acc
     go acc (Just b)
@@ -882,16 +883,16 @@
 
 scottyBlockHeight ::
        (MonadUnliftIO m, MonadLoggerIO m) => GetBlockHeight -> WebT m [BlockData]
-scottyBlockHeight (GetBlockHeight h (NoTx notx)) =
-    withMetrics blockStat 1 $
+scottyBlockHeight (GetBlockHeight h (NoTx notx)) = do
+    setMetrics blockStat 1
     (`getBlocks` notx) =<< getBlocksAtHeight (fromIntegral h)
 
 scottyBlockHeights ::
        (MonadUnliftIO m, MonadLoggerIO m)
     => GetBlockHeights
     -> WebT m [BlockData]
-scottyBlockHeights (GetBlockHeights (HeightsParam heights) (NoTx notx)) =
-    withMetrics blockStat (length heights) $ do
+scottyBlockHeights (GetBlockHeights (HeightsParam heights) (NoTx notx)) = do
+    setMetrics blockStat (length heights)
     bhs <- concat <$> mapM getBlocksAtHeight (fromIntegral <$> heights)
     getBlocks bhs notx
 
@@ -899,32 +900,32 @@
        (MonadUnliftIO m, MonadLoggerIO m)
     => GetBlockHeightRaw
     -> WebT m (RawResultList H.Block)
-scottyBlockHeightRaw (GetBlockHeightRaw h) =
-    withMetrics rawBlockStat 1 $
+scottyBlockHeightRaw (GetBlockHeightRaw h) = do
+    setMetrics rawBlockStat 1
     RawResultList <$> (mapM getRawBlock =<< getBlocksAtHeight (fromIntegral h))
 
 -- GET BlockTime / BlockTimeRaw --
 
 scottyBlockTime :: (MonadUnliftIO m, MonadLoggerIO m)
                 => GetBlockTime -> WebT m BlockData
-scottyBlockTime (GetBlockTime (TimeParam t) (NoTx notx)) =
-    withMetrics blockStat 1 $ do
+scottyBlockTime (GetBlockTime (TimeParam t) (NoTx notx)) = do
+    setMetrics blockStat 1
     ch <- lift $ asks (storeChain . webStore . webConfig)
     m <- blockAtOrBefore ch t
     maybe (raise blockStat ThingNotFound) (return . pruneTx notx) m
 
 scottyBlockMTP :: (MonadUnliftIO m, MonadLoggerIO m)
                => GetBlockMTP -> WebT m BlockData
-scottyBlockMTP (GetBlockMTP (TimeParam t) (NoTx noTx)) =
-    withMetrics blockStat 1 $ do
+scottyBlockMTP (GetBlockMTP (TimeParam t) (NoTx noTx)) = do
+    setMetrics blockStat 1
     ch <- lift $ asks (storeChain . webStore . webConfig)
     m <- blockAtOrAfterMTP ch t
     maybe (raise blockStat ThingNotFound) (return . pruneTx noTx) m
 
 scottyBlockTimeRaw :: (MonadUnliftIO m, MonadLoggerIO m)
                    => GetBlockTimeRaw -> WebT m (RawResult H.Block)
-scottyBlockTimeRaw (GetBlockTimeRaw (TimeParam t)) =
-    withMetrics rawBlockStat 1 $ do
+scottyBlockTimeRaw (GetBlockTimeRaw (TimeParam t)) = do
+    setMetrics rawBlockStat 1
     ch <- lift $ asks (storeChain . webStore . webConfig)
     m <- blockAtOrBefore ch t
     b <- maybe (raise rawBlockStat ThingNotFound) return m
@@ -932,8 +933,8 @@
 
 scottyBlockMTPRaw :: (MonadUnliftIO m, MonadLoggerIO m)
                   => GetBlockMTPRaw -> WebT m (RawResult H.Block)
-scottyBlockMTPRaw (GetBlockMTPRaw (TimeParam t)) =
-    withMetrics rawBlockStat 1 $ do
+scottyBlockMTPRaw (GetBlockMTPRaw (TimeParam t)) = do
+    setMetrics rawBlockStat 1
     ch <- lift $ asks (storeChain . webStore . webConfig)
     m <- blockAtOrAfterMTP ch t
     b <- maybe (raise rawBlockStat ThingNotFound) return m
@@ -942,20 +943,20 @@
 -- GET Transactions --
 
 scottyTx :: (MonadUnliftIO m, MonadLoggerIO m) => GetTx -> WebT m Transaction
-scottyTx (GetTx txid) =
-    withMetrics txStat 1 $
+scottyTx (GetTx txid) = do
+    setMetrics txStat 1
     maybe (raise txStat ThingNotFound) return =<< getTransaction txid
 
 scottyTxs ::
        (MonadUnliftIO m, MonadLoggerIO m) => GetTxs -> WebT m [Transaction]
-scottyTxs (GetTxs txids) =
-    withMetrics txStat (length txids) $
+scottyTxs (GetTxs txids) = do
+    setMetrics txStat (length txids)
     catMaybes <$> mapM getTransaction (nub txids)
 
 scottyTxRaw ::
        (MonadUnliftIO m, MonadLoggerIO m) => GetTxRaw -> WebT m (RawResult Tx)
-scottyTxRaw (GetTxRaw txid) =
-    withMetrics txStat 1 $ do
+scottyTxRaw (GetTxRaw txid) = do
+    setMetrics txStat 1
     tx <- maybe (raise txStat ThingNotFound) return =<< getTransaction txid
     return $ RawResult $ transactionData tx
 
@@ -963,8 +964,8 @@
        (MonadUnliftIO m, MonadLoggerIO m)
     => GetTxsRaw
     -> WebT m (RawResultList Tx)
-scottyTxsRaw (GetTxsRaw txids) =
-    withMetrics txStat (length txids) $ do
+scottyTxsRaw (GetTxsRaw txids) = do
+    setMetrics txStat (length txids)
     txs <- catMaybes <$> mapM f (nub txids)
     return $ RawResultList $ transactionData <$> txs
   where
@@ -988,14 +989,14 @@
 scottyTxsBlock ::
        (MonadUnliftIO m, MonadLoggerIO m) => GetTxsBlock -> WebT m [Transaction]
 scottyTxsBlock (GetTxsBlock h) =
-    withMetrics txsBlockStat 1 $ getTxsBlock h
+    setMetrics txsBlockStat 1 >> getTxsBlock h
 
 scottyTxsBlockRaw ::
        (MonadUnliftIO m, MonadLoggerIO m)
     => GetTxsBlockRaw
     -> WebT m (RawResultList Tx)
-scottyTxsBlockRaw (GetTxsBlockRaw h) =
-    withMetrics txsBlockStat 1 $
+scottyTxsBlockRaw (GetTxsBlockRaw h) = do
+    setMetrics txsBlockStat 1
     RawResultList . fmap transactionData <$> getTxsBlock h
 
 -- GET TransactionAfterHeight --
@@ -1004,8 +1005,8 @@
        (MonadUnliftIO m, MonadLoggerIO m)
     => GetTxAfter
     -> WebT m (GenericResult (Maybe Bool))
-scottyTxAfter (GetTxAfter txid height) =
-    withMetrics txAfterStat 1 $
+scottyTxAfter (GetTxAfter txid height) = do
+    setMetrics txAfterStat 1
     GenericResult <$> cbAfterHeight (fromIntegral height) txid
 
 -- | Check if any of the ancestors of this transaction is a coinbase after the
@@ -1045,8 +1046,8 @@
 -- POST Transaction --
 
 scottyPostTx :: (MonadUnliftIO m, MonadLoggerIO m) => PostTx -> WebT m TxId
-scottyPostTx (PostTx tx) =
-    withMetrics postTxStat 1 $
+scottyPostTx (PostTx tx) = do
+    setMetrics postTxStat 1
     lift (asks webConfig) >>= \cfg -> lift (publishTx cfg tx) >>= \case
         Right ()             -> return $ TxId (txHash tx)
         Left e@(PubReject _) -> raise postTxStat $ UserError $ show e
@@ -1102,8 +1103,8 @@
 
 scottyMempool ::
        (MonadUnliftIO m, MonadLoggerIO m) => GetMempool -> WebT m [TxHash]
-scottyMempool (GetMempool limitM (OffsetParam o)) =
-    withMetrics mempoolStat 1 $ do
+scottyMempool (GetMempool limitM (OffsetParam o)) = do
+    setMetrics mempoolStat 1
     wl <- lift $ asks (webMaxLimits . webConfig)
     let wl' = wl { maxLimitCount = 0 }
         l = Limits (validateLimit wl' False limitM) (fromIntegral o) Nothing
@@ -1139,62 +1140,62 @@
 
 scottyAddrTxs ::
        (MonadUnliftIO m, MonadLoggerIO m) => GetAddrTxs -> WebT m [TxRef]
-scottyAddrTxs (GetAddrTxs addr pLimits) =
-    withMetrics addrTxStat 1 $
+scottyAddrTxs (GetAddrTxs addr pLimits) = do
+    setMetrics addrTxStat 1
     getAddressTxs addr =<< paramToLimits False pLimits
 
 scottyAddrsTxs ::
        (MonadUnliftIO m, MonadLoggerIO m) => GetAddrsTxs -> WebT m [TxRef]
-scottyAddrsTxs (GetAddrsTxs addrs pLimits) =
-    withMetrics addrTxStat (length addrs) $
+scottyAddrsTxs (GetAddrsTxs addrs pLimits) = do
+    setMetrics addrTxStat (length addrs)
     getAddressesTxs addrs =<< paramToLimits False pLimits
 
 scottyAddrTxsFull ::
        (MonadUnliftIO m, MonadLoggerIO m)
     => GetAddrTxsFull
     -> WebT m [Transaction]
-scottyAddrTxsFull (GetAddrTxsFull addr pLimits) =
-    withMetrics addrTxFullStat 1 $ do
+scottyAddrTxsFull (GetAddrTxsFull addr pLimits) = do
+    setMetrics addrTxFullStat 1
     txs <- getAddressTxs addr =<< paramToLimits True pLimits
     catMaybes <$> mapM (getTransaction . txRefHash) txs
 
 scottyAddrsTxsFull :: (MonadUnliftIO m, MonadLoggerIO m)
                    => GetAddrsTxsFull -> WebT m [Transaction]
-scottyAddrsTxsFull (GetAddrsTxsFull addrs pLimits) =
-    withMetrics addrTxFullStat (length addrs) $ do
+scottyAddrsTxsFull (GetAddrsTxsFull addrs pLimits) = do
+    setMetrics addrTxFullStat (length addrs)
     txs <- getAddressesTxs addrs =<< paramToLimits True pLimits
     catMaybes <$> mapM (getTransaction . txRefHash) txs
 
 scottyAddrBalance :: (MonadUnliftIO m, MonadLoggerIO m)
                   => GetAddrBalance -> WebT m Balance
-scottyAddrBalance (GetAddrBalance addr) =
-    withMetrics addrBalanceStat 1 $
+scottyAddrBalance (GetAddrBalance addr) = do
+    setMetrics addrBalanceStat 1
     getDefaultBalance addr
 
 scottyAddrsBalance ::
        (MonadUnliftIO m, MonadLoggerIO m) => GetAddrsBalance -> WebT m [Balance]
-scottyAddrsBalance (GetAddrsBalance addrs) =
-    withMetrics addrBalanceStat (length addrs) $
+scottyAddrsBalance (GetAddrsBalance addrs) = do
+    setMetrics addrBalanceStat (length addrs)
     getBalances addrs
 
 scottyAddrUnspent ::
        (MonadUnliftIO m, MonadLoggerIO m) => GetAddrUnspent -> WebT m [Unspent]
-scottyAddrUnspent (GetAddrUnspent addr pLimits) =
-    withMetrics addrUnspentStat 1 $
+scottyAddrUnspent (GetAddrUnspent addr pLimits) = do
+    setMetrics addrUnspentStat 1
     getAddressUnspents addr =<< paramToLimits False pLimits
 
 scottyAddrsUnspent ::
        (MonadUnliftIO m, MonadLoggerIO m) => GetAddrsUnspent -> WebT m [Unspent]
-scottyAddrsUnspent (GetAddrsUnspent addrs pLimits) =
-    withMetrics addrUnspentStat (length addrs) $
+scottyAddrsUnspent (GetAddrsUnspent addrs pLimits) = do
+    setMetrics addrUnspentStat (length addrs)
     getAddressesUnspents addrs =<< paramToLimits False pLimits
 
 -- GET XPubs --
 
 scottyXPub ::
        (MonadUnliftIO m, MonadLoggerIO m) => GetXPub -> WebT m XPubSummary
-scottyXPub (GetXPub xpub deriv (NoCache noCache)) =
-    withMetrics xPubStat 1 $
+scottyXPub (GetXPub xpub deriv (NoCache noCache)) =  do
+    setMetrics xPubStat 1
     lift . runNoCache noCache $ xPubSummary $ XPubSpec xpub deriv
 
 getXPubTxs :: (MonadUnliftIO m, MonadLoggerIO m)
@@ -1205,24 +1206,24 @@
 
 scottyXPubTxs ::
        (MonadUnliftIO m, MonadLoggerIO m) => GetXPubTxs -> WebT m [TxRef]
-scottyXPubTxs (GetXPubTxs xpub deriv plimits (NoCache nocache)) =
-    withMetrics xPubTxStat 1 $
+scottyXPubTxs (GetXPubTxs xpub deriv plimits (NoCache nocache)) = do
+    setMetrics xPubTxStat 1
     getXPubTxs xpub deriv plimits nocache
 
 scottyXPubTxsFull ::
        (MonadUnliftIO m, MonadLoggerIO m)
     => GetXPubTxsFull
     -> WebT m [Transaction]
-scottyXPubTxsFull (GetXPubTxsFull xpub deriv plimits (NoCache nocache)) =
-    withMetrics xPubTxFullStat 1 $ do
+scottyXPubTxsFull (GetXPubTxsFull xpub deriv plimits (NoCache nocache)) = do
+    setMetrics xPubTxFullStat 1
     refs <- getXPubTxs xpub deriv plimits nocache
     txs <- lift . runNoCache nocache $ mapM (getTransaction . txRefHash) refs
     return $ catMaybes txs
 
 scottyXPubBalances ::
        (MonadUnliftIO m, MonadLoggerIO m) => GetXPubBalances -> WebT m [XPubBal]
-scottyXPubBalances (GetXPubBalances xpub deriv (NoCache noCache)) =
-    withMetrics xPubStat 1 $
+scottyXPubBalances (GetXPubBalances xpub deriv (NoCache noCache)) = do
+    setMetrics xPubStat 1
     filter f <$> lift (runNoCache noCache (xPubBals spec))
   where
     spec = XPubSpec xpub deriv
@@ -1232,8 +1233,8 @@
        (MonadUnliftIO m, MonadLoggerIO m)
     => GetXPubUnspent
     -> WebT m [XPubUnspent]
-scottyXPubUnspent (GetXPubUnspent xpub deriv pLimits (NoCache noCache)) =
-    withMetrics xPubUnspentStat 1 $ do
+scottyXPubUnspent (GetXPubUnspent xpub deriv pLimits (NoCache noCache)) = do
+    setMetrics xPubUnspentStat 1
     limits <- paramToLimits False pLimits
     lift . runNoCache noCache $ xPubUnspents (XPubSpec xpub deriv) limits
 
@@ -1331,7 +1332,8 @@
     get_limit >>= \limit ->
     get_min_conf >>= \min_conf ->
     let len = HashSet.size addrs + HashMap.size xspecs
-    in withMetrics unspentStat len $ do
+    in do
+    setMetrics unspentStat len
     net <- lift $ asks (storeNetwork . webStore . webConfig)
     height <- getChainHeight
     let mn BinfoUnspent{..} = min_conf > getBinfoUnspentConfirmations
@@ -1461,7 +1463,8 @@
     get_prune >>= \prune ->
     get_filter >>= \fltr ->
     let len = HashSet.size addrs' + HashSet.size xpubs
-    in withMetrics multiaddrStat len $ do
+    in do
+    setMetrics multiaddrStat len
     xbals <- get_xbals xspecs
     xtxns <- mapM (fmap fromIntegral . xPubTxCount) xspecs
     let sxbals = subset sxpubs xbals
@@ -1637,8 +1640,8 @@
     get_addr >>= \addr ->
     getNumTxId >>= \numtxid ->
     get_offset >>= \off ->
-    get_count >>= \n ->
-    withMetrics rawaddrStat 1 $ do
+    get_count >>= \n -> do
+    setMetrics rawaddrStat 1
     bal <- fromMaybe (zeroBalance addr) <$> getBalance addr
     net <- lift $ asks (storeNetwork . webStore . webConfig)
     let abook = HashMap.singleton addr Nothing
@@ -1674,8 +1677,8 @@
 scottyShortBal :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()
 scottyShortBal =
     getBinfoActive balanceStat >>= \(xspecs, addrs) ->
-    getNumTxId >>= \numtxid ->
-    withMetrics balanceStat (hl addrs + ml xspecs) $ do
+    getNumTxId >>= \numtxid -> do
+    setMetrics balanceStat (hl addrs + ml xspecs)
     net <- lift $ asks (storeNetwork . webStore . webConfig)
     abals <- catMaybes <$> mapM (get_addr_balance net) (HashSet.toList addrs)
     xbals <- mapM (get_xspec_balance net) (HashMap.elems xspecs)
@@ -1724,8 +1727,8 @@
 scottyBinfoBlockHeight :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()
 scottyBinfoBlockHeight =
     getNumTxId >>= \numtxid ->
-    withMetrics rawBlockStat 1 $
     S.param "height" >>= \height ->
+    setMetrics rawBlockStat 1 >>
     getBlocksAtHeight height >>= \block_hashes -> do
     block_headers <- catMaybes <$> mapM getBlock block_hashes
     next_block_hashes <- getBlocksAtHeight (height + 1)
@@ -1756,7 +1759,7 @@
 scottyBinfoBlock =
     getNumTxId >>= \numtxid ->
     getBinfoHex >>= \hex ->
-    withMetrics rawBlockStat 1 $
+    setMetrics rawBlockStat 1 >>
     S.param "block" >>= \case
     BinfoBlockHash bh -> go numtxid hex bh
     BinfoBlockIndex i ->
@@ -1800,7 +1803,7 @@
     getNumTxId >>= \numtxid ->
     getBinfoHex >>= \hex ->
     S.param "txid" >>= \txid ->
-    withMetrics rawtxStat 1 $
+    setMetrics rawtxStat 1 >>
     let f (BinfoTxIdHash h)  = maybeToList <$> getTransaction h
         f (BinfoTxIdIndex i) = getNumTransaction i
     in f txid >>= \case
@@ -1823,10 +1826,9 @@
 scottyPeers :: (MonadUnliftIO m, MonadLoggerIO m)
             => GetPeers
             -> WebT m [PeerInformation]
-scottyPeers _ =
-    withMetrics peerStat 1 $
-    lift $
-    getPeersInformation =<< asks (storeManager . webStore . webConfig)
+scottyPeers _ = do
+    setMetrics peerStat 1
+    lift $ getPeersInformation =<< asks (storeManager . webStore . webConfig)
 
 -- | Obtain information about connected peers from peer manager process.
 getPeersInformation
@@ -1852,8 +1854,8 @@
 
 scottyHealth ::
        (MonadUnliftIO m, MonadLoggerIO m) => GetHealth -> WebT m HealthCheck
-scottyHealth _ =
-    withMetrics healthStat 1 $ do
+scottyHealth _ = do
+    setMetrics healthStat 1
     h <- lift $ asks webConfig >>= healthCheck
     unless (isOK h) $ S.status status503
     return h
@@ -1928,8 +1930,8 @@
     return hc
 
 scottyDbStats :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()
-scottyDbStats =
-    withMetrics dbStatsStat 1 $ do
+scottyDbStats = do
+    setMetrics dbStatsStat 1
     setHeaders
     db <- lift $ asks (databaseHandle . storeDB . webStore . webConfig)
     statsM <- lift (getProperty db Stats)
@@ -1991,7 +1993,7 @@
     bin = runGetS deserialize
     hex b = case B16.decodeBase16 $ C.filter (not . isSpace) b of
                 Right x -> bin x
-                Left s -> Left (T.unpack s)
+                Left s  -> Left (T.unpack s)
 
 parseOffset :: MonadIO m => WebT m OffsetParam
 parseOffset = do
@@ -2071,26 +2073,106 @@
     h c = c { webStore = i (webStore c) }
     i s = s { storeCache = Nothing }
 
-logIt :: (MonadUnliftIO m, MonadLoggerIO m) => m Middleware
-logIt = do
+logIt :: (MonadUnliftIO m, MonadLoggerIO m)
+      => Maybe WebMetrics -> m Middleware
+logIt metrics = do
     runner <- askRunInIO
     return $ \app req respond -> do
-        app req $ \res -> do
-            let s = responseStatus res
-                msg = fmtReq req <> " [" <> fmtStatus s <> "]"
-            if statusIsSuccessful s
-                then runner $ $(logDebugS) "Web" msg
-                else runner $ $(logErrorS) "Web" msg
-            respond res
+        var <- newTVarIO B.empty
+        req' <- case metrics of
+            Nothing ->
+                return
+                req
+                {
+                    requestBody =
+                        req_body var (getRequestBodyChunk req)
+                }
+            Just m -> do
+                stat_var <- newTVarIO Nothing
+                item_var <- newTVarIO 0
+                let vault' = V.insert (statKey m) stat_var $
+                             V.insert (itemsKey m) item_var $
+                             vault req
+                return
+                    req
+                    {
+                        vault = vault',
+                        requestBody =
+                            req_body var (getRequestBodyChunk req)
+                    }
+        bracket start (end var runner req') $ \t1 ->
+            app req' $ \res -> do
+                t2 <- systemToUTCTime <$> getSystemTime
+                let diff = round $ diffUTCTime t2 t1 * 1000
+                b <- readTVarIO var
+                let s = responseStatus res
+                    msg = fmtReq b req' <> ": " <> fmtStatus s diff
+                if statusIsSuccessful s
+                    then runner $ $(logDebugS) "Web" msg
+                    else runner $ $(logErrorS) "Web" msg
+                respond res
+  where
+    start = systemToUTCTime <$> getSystemTime
+    req_body var old_body = do
+        b <- old_body
+        unless (B.null b) . atomically $ modifyTVar var (<> b)
+        return b
+    add_stat d i s = do
+        addStatQuery s
+        addStatTime s d
+        addStatItems s (fromIntegral i)
+    end var runner req t1 = do
+        t2 <- systemToUTCTime <$> getSystemTime
+        let diff = round $ diffUTCTime t2 t1 * 1000
+        case metrics of
+            Nothing -> return ()
+            Just m -> do
+                let m_stat_var = V.lookup (statKey m) (vault req)
+                    m_item_var = V.lookup (itemsKey m) (vault req)
+                i <- case m_item_var of
+                    Nothing       -> return 0
+                    Just item_var -> readTVarIO item_var
+                add_stat diff i (everyStat m)
+                case m_stat_var of
+                    Nothing -> return ()
+                    Just stat_var ->
+                        readTVarIO stat_var >>= \case
+                            Nothing -> return ()
+                            Just f  -> add_stat diff i (f m)
+        when (diff > 10000) $ do
+            b <- readTVarIO var
+            runner $ $(logWarnS) "Web" $
+                "Slow [" <> cs (show diff) <> " ms]: " <> fmtReq b req
 
-fmtReq :: Request -> Text
-fmtReq req =
+reqToken :: Int -> TVar Int -> Maybe WebMetrics -> Middleware
+reqToken max_req tok metrics app req respond =
+    withToken max_req tok metrics $ app req respond
+
+reqSizeLimit :: Middleware
+reqSizeLimit = requestSizeLimitMiddleware lim
+  where
+    max_len _req = return (Just (256 * 1024))
+    lim = setOnLengthExceeded too_big $
+          setMaxLengthForRequest max_len $
+          defaultRequestSizeLimitSettings
+    too_big w64 = \_app _req send -> send $
+        waiExcept requestEntityTooLarge413 RequestTooLarge
+
+fmtReq :: ByteString -> Request -> Text
+fmtReq bs req =
     let m = requestMethod req
         v = httpVersion req
         p = rawPathInfo req
         q = rawQueryString req
-     in T.decodeUtf8 $ m <> " " <> p <> q <> " " <> cs (show v)
+        txt = case T.decodeUtf8' bs of
+                  Left _   -> " {invalid utf8}"
+                  Right "" -> ""
+                  Right t  -> " [" <> t <> "]"
+    in T.decodeUtf8 (m <> " " <> p <> q <> " " <> cs (show v)) <> txt
 
-fmtStatus :: Status -> Text
-fmtStatus s = cs (show (statusCode s)) <> " " <> cs (statusMessage s)
+fmtStatus :: Status -> Int -> Text
+fmtStatus s i =
+    cs (show (statusCode s)) <> " " <>
+    cs (statusMessage s) <> " (" <>
+    cs (show i) <> " ms)"