Instrument handler blocks

6 files changed, 34 insertions, 10 deletions

diff --git a/mini-http-server/Network/HTTP/Server/Mini.hs b/mini-http-server/Network/HTTP/Server/Mini.hs
index 266e958..fb982d7 100644
--- a/mini-http-server/Network/HTTP/Server/Mini.hs
+++ b/mini-http-server/Network/HTTP/Server/Mini.hs
@@ -13,6 +13,7 @@ import Network.Socket
 import Network.Socket.ByteString
 
 import Network.HTTP.Server.Mini.Internal.Parser
+import Network.HTTP.Server.Mini.Internal.Instrument
 import Network.HTTP.Server.Mini.Printer
 import Network.HTTP.Server.Mini.Types
 
@@ -72,5 +73,5 @@ handleConnection settings conn handler =
   readRequest (setMaxRequestSize settings) (recv conn) >>= \case
     Nothing -> return ()
     Just req -> do
-      resp <- handler req
-      sendResponse conn resp
+      resp <- instrument "handler" $ handler req
+      instrument "sendResponse" $ sendResponse conn resp
diff --git a/src/AtomicPrint.hs b/mini-http-server/Network/HTTP/Server/Mini/Internal/Instrument.hs
index 82a8552..d63d21e 100644
--- a/src/AtomicPrint.hs
+++ b/mini-http-server/Network/HTTP/Server/Mini/Internal/Instrument.hs
@@ -1,22 +1,42 @@
 {-# OPTIONS_GHC -fno-full-laziness -fno-cse #-}
-module AtomicPrint (
-  atomicPrint, atomicPrintS,
-  atomicPrintNoWait, atomicPrintNoWaitS,
-) where
+module Network.HTTP.Server.Mini.Internal.Instrument where
 
 import Control.Concurrent
 import Control.Monad (void)
+import Data.IORef
 import Data.Text qualified as T
 import Data.Text.IO.Utf8 qualified as T
 import Data.Text (Text)
+import Data.Time.Clock.POSIX
 import System.IO
 import System.IO.Unsafe (unsafePerformIO)
 
 
+{-# NOINLINE nextId #-}
+nextId :: IORef Int
+nextId = unsafePerformIO (newIORef 1)
+
+-- Number of instrument blocks open
+{-# NOINLINE numOpen #-}
+numOpen :: IORef Int
+numOpen = unsafePerformIO (newIORef 0)
+
 {-# NOINLINE mutex #-}
 mutex :: MVar ()
 mutex = unsafePerformIO (newMVar ())
 
+instrument :: String -> IO a -> IO a
+instrument name action = do
+  idval <- atomicModifyIORef' nextId (\i -> (i+1, i))
+  atomicPrintS (show idval ++ "< " ++ name)
+  atomicModifyIORef' numOpen (\i -> (i+1, ()))
+  t1 <- getPOSIXTime
+  res <- action
+  t2 <- getPOSIXTime
+  numOpenAfter <- atomicModifyIORef' numOpen (\i -> (i-1, i-1))
+  atomicPrintS (show idval ++ "> " ++ name ++ " (" ++ show (t2 - t1) ++ ") (" ++ show numOpenAfter ++ ")")
+  return res
+
 atomicPrintS :: String -> IO ()
 atomicPrintS = atomicPrint . T.pack
 
diff --git a/src/Index.hs b/src/Index.hs
index 89a24e3..148f314 100644
--- a/src/Index.hs
+++ b/src/Index.hs
@@ -41,7 +41,8 @@ import System.FilePath
 import System.FSNotify qualified as FN
 import Text.Read (readMaybe)
 
-import AtomicPrint
+import Network.HTTP.Server.Mini.Internal.Instrument (atomicPrintS, atomicPrint)
+
 import Debounce
 import Cache
 import Config (Channel(..), prettyChannel)
diff --git a/src/Main.hs b/src/Main.hs
index 6b8e884..247b345 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -26,10 +26,10 @@ import Text.Mustache.Types (Value(..))
 import Text.Read (readMaybe)
 
 import Network.HTTP.Server.Mini
+import Network.HTTP.Server.Mini.Internal.Instrument (atomicPrintS)
 
 -- import Debug.Trace
 
-import AtomicPrint
 import Calendar
 import Config
 import Index
diff --git a/src/Mmap.hs b/src/Mmap.hs
index ff32d0f..34d5d38 100644
--- a/src/Mmap.hs
+++ b/src/Mmap.hs
@@ -9,7 +9,7 @@ import Foreign.C.Types
 import System.Posix.IO
 import System.Posix.Types
 
-import AtomicPrint
+import Network.HTTP.Server.Mini.Internal.Instrument (atomicPrintNoWaitS)
 
 
 foreign import ccall "tirclogv_mmap"
diff --git a/tirclogv.cabal b/tirclogv.cabal
index cf073b0..ead88fb 100644
--- a/tirclogv.cabal
+++ b/tirclogv.cabal
@@ -19,7 +19,6 @@ executable tirclogv
   import: common
   main-is: Main.hs
   other-modules:
-    AtomicPrint
     Cache
     Calendar
     Config
@@ -57,6 +56,7 @@ library mini-http-server
     Network.HTTP.Server.Mini.URI
     Network.HTTP.Server.Mini.Types
 
+    Network.HTTP.Server.Mini.Internal.Instrument
     Network.HTTP.Server.Mini.Internal.Parser
   other-modules:
     Network.HTTP.Server.Mini.Printer
@@ -66,6 +66,8 @@ library mini-http-server
     bytestring,
     flatparse,
     network,
+    text,
+    time,
     transformers,
     stm
   hs-source-dirs: mini-http-server