Instrument handler blocks

2 files changed, 56 insertions, 2 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/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