chrisdone/RIO.ConcurrentLog.hs

## RIO.ConcurrentLog.hs
{-# LANGUAGE OverloadedStrings #-}

-- |

module RIO.ConcurrentLog where

import qualified Data.ByteString.Builder as SB
import           Data.List
import           Data.Time
import           RIO
import           System.Random

mkConcLogger :: Handle -> IO (ThreadId -> Builder -> IO ())
mkConcLogger h = do
  ref <- newMVar []
  hPutBuilder h ("<html><body>" <> style <> "<table><tbody>")
  pure
    (\threadId bytes -> do
       -- Adds randomness and triggers race conditions.
       -- randomMs <- randomRIO (1,500)
       -- threadDelay (1000 * randomMs)
       modifyMVar
         ref
         (\threads ->
            let threads' =
                  if elem threadId threads
                    then threads
                    else threads <> [threadId]
             in do now <- getCurrentTime
                   case findIndex (== threadId) threads' of
                     Nothing -> pure ()
                     Just index ->
                       SB.hPutBuilder
                         h
                         ("<tr><td style=\"width: 18em;\">" <> fromString (show now) <> "</td>" <>
                          row bytes index (length threads' - index - 1) <>
                          "</tr>")
                   pure (threads', ())))

row :: SB.Builder -> Int -> Int -> Builder
row line index remaining =
  mconcat (replicate index "<td class=\"empty\"></td>") <> "<td class=\"populated\">" <>
  line <>
  "</td>" <> mconcat (replicate remaining "<td class=\"empty\"></td>")

style :: Builder
style =
  "<style>\n\
   \table {\n\
   \font-family: \"Ubuntu Mono\", monospace;\n\
   \}\n\
   \td { background: #f5f5f5; width: 20em;}\n\
   \.populated {\n\
   \border: 1px solid #ccc;\n\
   \background: #eee;\n\
   \overflow: auto;\n\
   \}\n\
   \.lexx-delimiter {\n\
   \  color: #449a86\n\
   \}\n\
   \.lexx-constructor {\n\
   \  color: #44449a\n\
   \}\n\
   \.lexx-misc {\n\
   \  color: #444;\n\
   \}\n\
   \.lexx-string {\n\
   \  color: #8d449a;\n\
   \}\n\
   \.lexx-digits {\n\
   \  color: #349a91;\n\
   \}\n\
   \</style>"

## Sample.hs
mkTestLogFunc :: (Show a, MonadIO m) => FilePath -> m (GLogFunc a)
mkTestLogFunc fp =
  do liftIO (S8.putStrLn ("Writing HTML logs to " <> fromString fp))
     h <- liftIO (openFile fp WriteMode)
     write <- liftIO (mkConcLogger h)
     pure (mkGLogFunc
             (\_cs x -> do
                debug <- lookupEnv "KAFKA_TEST_DEBUG"
                when
                  (isJust debug)
                  (do tid <- myThreadId
                      prettyWrite (tid, x)
                      write tid (SB.lazyByteString (prettyPrintHtml (tid, x)))
                      System.IO.hFlush h)))
	{-# LANGUAGE OverloadedStrings #-}

	-- \|

	module RIO.ConcurrentLog where

	import qualified Data.ByteString.Builder as SB
	import Data.List
	import Data.Time
	import RIO
	import System.Random

	mkConcLogger :: Handle -> IO (ThreadId -> Builder -> IO ())
	mkConcLogger h = do
	ref <- newMVar []
	hPutBuilder h ("<html><body>" <> style <> "<table><tbody>")
	pure
	(\threadId bytes -> do
	-- Adds randomness and triggers race conditions.
	-- randomMs <- randomRIO (1,500)
	-- threadDelay (1000 * randomMs)
	modifyMVar
	ref
	(\threads ->
	let threads' =
	if elem threadId threads
	then threads
	else threads <> [threadId]
	in do now <- getCurrentTime
	case findIndex (== threadId) threads' of
	Nothing -> pure ()
	Just index ->
	SB.hPutBuilder
	h
	("<tr><td style=\"width: 18em;\">" <> fromString (show now) <> "</td>" <>
	row bytes index (length threads' - index - 1) <>
	"</tr>")
	pure (threads', ())))

	row :: SB.Builder -> Int -> Int -> Builder
	row line index remaining =
	mconcat (replicate index "<td class=\"empty\"></td>") <> "<td class=\"populated\">" <>
	line <>
	"</td>" <> mconcat (replicate remaining "<td class=\"empty\"></td>")

	style :: Builder
	style =
	"<style>\n\
	\table {\n\
	\font-family: \"Ubuntu Mono\", monospace;\n\
	\}\n\
	\td { background: #f5f5f5; width: 20em;}\n\
	\.populated {\n\
	\border: 1px solid #ccc;\n\
	\background: #eee;\n\
	\overflow: auto;\n\
	\}\n\
	\.lexx-delimiter {\n\
	\ color: #449a86\n\
	\}\n\
	\.lexx-constructor {\n\
	\ color: #44449a\n\
	\}\n\
	\.lexx-misc {\n\
	\ color: #444;\n\
	\}\n\
	\.lexx-string {\n\
	\ color: #8d449a;\n\
	\}\n\
	\.lexx-digits {\n\
	\ color: #349a91;\n\
	\}\n\
	\</style>"
	mkTestLogFunc :: (Show a, MonadIO m) => FilePath -> m (GLogFunc a)
	mkTestLogFunc fp =
	do liftIO (S8.putStrLn ("Writing HTML logs to " <> fromString fp))
	h <- liftIO (openFile fp WriteMode)
	write <- liftIO (mkConcLogger h)
	pure (mkGLogFunc
	(\_cs x -> do
	debug <- lookupEnv "KAFKA_TEST_DEBUG"
	when
	(isJust debug)
	(do tid <- myThreadId
	prettyWrite (tid, x)
	write tid (SB.lazyByteString (prettyPrintHtml (tid, x)))
	System.IO.hFlush h)))