From e3ea04d8e71370032da56ad9ea66dcb82d257812 Mon Sep 17 00:00:00 2001
From: Tom Smeding <tom@tomsmeding.com>
Date: Fri, 8 May 2026 20:59:08 +0100
Subject: Instrument handler blocks

---
 .../HTTP/Server/Mini/Internal/Instrument.hs        | 53 ++++++++++++++++++++++
 1 file changed, 53 insertions(+)
 create mode 100644 mini-http-server/Network/HTTP/Server/Mini/Internal/Instrument.hs

(limited to 'mini-http-server/Network/HTTP/Server/Mini')

diff --git a/mini-http-server/Network/HTTP/Server/Mini/Internal/Instrument.hs b/mini-http-server/Network/HTTP/Server/Mini/Internal/Instrument.hs
new file mode 100644
index 0000000..d63d21e
--- /dev/null
+++ b/mini-http-server/Network/HTTP/Server/Mini/Internal/Instrument.hs
@@ -0,0 +1,53 @@
+{-# OPTIONS_GHC -fno-full-laziness -fno-cse #-}
+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
+
+atomicPrint :: Text -> IO ()
+atomicPrint text =
+  withMVar mutex $ \() ->
+    T.putStrLn text >> hFlush stdout
+
+atomicPrintNoWaitS :: String -> IO ()
+atomicPrintNoWaitS = atomicPrintNoWait . T.pack
+
+-- | Does not block, so if you've masked exceptions, nothing will come through here
+atomicPrintNoWait :: Text -> IO ()
+atomicPrintNoWait text = void $ forkIO $ atomicPrint text
-- 
cgit v1.3.1