From e3ea04d8e71370032da56ad9ea66dcb82d257812 Mon Sep 17 00:00:00 2001 From: Tom Smeding Date: Fri, 8 May 2026 20:59:08 +0100 Subject: Instrument handler blocks --- mini-http-server/Network/HTTP/Server/Mini.hs | 5 +- .../HTTP/Server/Mini/Internal/Instrument.hs | 53 ++++++++++++++++++++++ src/AtomicPrint.hs | 33 -------------- src/Index.hs | 3 +- src/Main.hs | 2 +- src/Mmap.hs | 2 +- tirclogv.cabal | 4 +- 7 files changed, 63 insertions(+), 39 deletions(-) create mode 100644 mini-http-server/Network/HTTP/Server/Mini/Internal/Instrument.hs delete mode 100644 src/AtomicPrint.hs 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 diff --git a/src/AtomicPrint.hs b/src/AtomicPrint.hs deleted file mode 100644 index 82a8552..0000000 --- a/src/AtomicPrint.hs +++ /dev/null @@ -1,33 +0,0 @@ -{-# OPTIONS_GHC -fno-full-laziness -fno-cse #-} -module AtomicPrint ( - atomicPrint, atomicPrintS, - atomicPrintNoWait, atomicPrintNoWaitS, -) where - -import Control.Concurrent -import Control.Monad (void) -import Data.Text qualified as T -import Data.Text.IO.Utf8 qualified as T -import Data.Text (Text) -import System.IO -import System.IO.Unsafe (unsafePerformIO) - - -{-# NOINLINE mutex #-} -mutex :: MVar () -mutex = unsafePerformIO (newMVar ()) - -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 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 -- cgit v1.3.1