From 9a08d29b05f1f2c9c458a2e5af872614dab2a455 Mon Sep 17 00:00:00 2001 From: Michael Karg Date: Tue, 12 Nov 2024 21:39:51 +0100 Subject: [PATCH] WIP: db persistence layer for locli --- bench/locli/CHANGELOG.md | 4 + bench/locli/app/locli-db.hs | 170 +++++++ bench/locli/locli.cabal | 31 +- .../locli/src/Cardano/Analysis/API/Ground.hs | 48 +- bench/locli/src/Cardano/Analysis/MachPerf.hs | 2 +- bench/locli/src/Cardano/Command.hs | 1 + bench/locli/src/Cardano/Unlog/BackendFile.hs | 85 ++++ bench/locli/src/Cardano/Unlog/LogObject.hs | 119 ++--- bench/locli/src/Cardano/Unlog/LogObjectDB.hs | 440 ++++++++++++++++++ bench/locli/src/Cardano/Util.hs | 98 ++-- bench/locli/test/Test/Unlog/LogObjectDB.hs | 24 + bench/locli/test/test-locli.hs | 2 + 12 files changed, 870 insertions(+), 154 deletions(-) create mode 100644 bench/locli/app/locli-db.hs create mode 100644 bench/locli/src/Cardano/Unlog/BackendFile.hs create mode 100644 bench/locli/src/Cardano/Unlog/LogObjectDB.hs create mode 100644 bench/locli/test/Test/Unlog/LogObjectDB.hs diff --git a/bench/locli/CHANGELOG.md b/bench/locli/CHANGELOG.md index 6bfaea32800..3ab54b862b3 100644 --- a/bench/locli/CHANGELOG.md +++ b/bench/locli/CHANGELOG.md @@ -1,5 +1,9 @@ # Revision history for locli +## NEXT + +* New database persistence backend for log objects + ## 1.36 -- Nov 2024 * Add `CHANGELOG.md` for `locli` diff --git a/bench/locli/app/locli-db.hs b/bench/locli/app/locli-db.hs new file mode 100644 index 00000000000..01b5b77409f --- /dev/null +++ b/bench/locli/app/locli-db.hs @@ -0,0 +1,170 @@ +{-# OPTIONS_GHC -fno-warn-unused-top-binds #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +{-# OPTIONS_GHC -fno-warn-unused-local-binds #-} +{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} + + +import Cardano.Api (BlockNo (..), MonadIO, SlotNo (..)) + +import Cardano.Analysis.API.Ground (Hash (..), Host (..), TId (..)) +import Cardano.Logging.Resources.Types (ResourceStats, Resources (..)) +import Cardano.Unlog.LogObject (LOAnyType (..), LOBody (..), LogObject (..), fromTextRef) +import Cardano.Unlog.LogObjectDB +import Cardano.Util (smaybe) + +import Prelude hiding (log) + +import Control.Concurrent.Async +import Control.Concurrent.Extra +import Control.Exception +import Control.Monad +import Data.Aeson as Aeson +import Data.Bool (bool) +import qualified Data.ByteString.Lazy.Char8 as BSL +import Data.Coerce +import Data.Data +import qualified Data.HashMap.Lazy as HM +import qualified Data.HashMap.Strict as HMS +import Data.List.Split (chop) +import qualified Data.Map.Lazy as ML +import Data.Maybe +import qualified Data.Text as TS (Text, empty, intercalate, pack, splitOn, unpack) +import qualified Data.Text.Lazy as TL (Text, fromStrict, pack) +import qualified Data.Text.Short as ShortText (ShortText, empty, fromText, pack, toText) +import Data.Time.Clock (UTCTime) +import Data.Time.Clock.POSIX (getPOSIXTime, posixSecondsToUTCTime, utcTimeToPOSIXSeconds) +import Data.Typeable +import Data.Word +import qualified GHC.Stats as RTS +import System.Directory (removeFile) +import System.Environment (getArgs) + +import Database.Sqlite.Easy hiding (Text) + + +dbName :: ConnectionString +dbName = "test_logobject.sqlite3" + +dbPath :: FilePath +dbPath = TS.unpack $ unConnectionString dbName + +main :: IO () +main = do + print selectAll + getArgs >>= \case + [] -> tryRead >> putStrLn "(to recreate DB, provide log name as arg)" + log : _ -> do + removeFile dbPath `catch` \SomeException{} -> pure () + ls <- BSL.lines <$> BSL.readFile log + + _ <- + timed "withDb/createDbCounting" $ withDb dbName $ do + let + alterFunc :: Maybe Int -> Maybe Int + alterFunc = maybe (Just 1) (Just . succ) + + go acc line = case eitherDecode line of + Right logObject@LogObject{loNS, loKind} -> do + + mapM_ runSqlRunnable (logObjectToSql logObject) + + let name = fromTextRef loNS <> ":" <> fromTextRef loKind + pure $ ML.alter alterFunc name acc + Left err -> uncurry runWith (errorToSql err $ BSL.unpack line) >> pure acc + + mapM_ run createTables + + tracefreqs <- transaction $ foldM go (ML.empty :: TraceFreqs) ls + + transaction $ mapM_ runSqlRunnable (traceFreqsToSql tracefreqs) + + [[tMin, tMax]] <- run "SELECT MIN(at), MAX(at) FROM (SELECT at FROM resource union SELECT at FROM slot union SELECT at FROM txns union SELECT at FROM event)" + let + dbSummary = SummaryDB + { sdbName = "test" + , sdbLines = sum tracefreqs + , sdbFirstAt = fromSqlData tMin + , sdbLastAt = fromSqlData tMax + } + runSqlRunnable $ summaryToSql dbSummary + + pure () + + +dbSummaryDum :: SummaryDB +dbSummaryDum = SummaryDB "tryRead" 0 undefined undefined + +tryRead :: IO () +tryRead = do + res <- take 84 . drop 4096 <$> timed "withDb/selectAll" (withDb dbName (run selectAll)) + mapM_ print res + mapM_ (\r -> print r >> print (sqlToLogObject dbSummaryDum r)) res + +timed :: MonadIO m => String -> m a -> m a +timed name action = do + before <- liftIO getPOSIXTime + result <- action + after <- liftIO getPOSIXTime + heap <- liftIO $ RTS.gcdetails_mem_in_use_bytes . RTS.gc <$> RTS.getRTSStats + + let + seconds :: Int + seconds = floor $ after - before + mibibytes = heap `div` 1024 `div` 1024 + + liftIO $ putStrLn $ "<> time: " ++ show seconds ++ "s; heap: " ++ show mibibytes ++ "MiB; (" ++ name ++ ")" + pure result + + +createTables :: [SQL] +createTables = + [ "CREATE TABLE event (at REAL NOT NULL, cons TEXT NOT NULL, slot INTEGER, block INTEGER, hash TEXT)" + , "CREATE TABLE resource (at REAL NOT NULL, centi_cpu INTEGER, rss INTEGER, heap INTEGER, alloc INTEGER, as_blob BLOB)" + , "CREATE TABLE slot (at REAL NOT NULL, slot INTEGER, utxo_size INTEGER, chain_dens REAL)" + , "CREATE TABLE txns (at REAL NOT NULL, cons TEXT NOT NULL, count INTEGER, rejected INTEGER, tid TEXT)" + , "CREATE TABLE tracefreq (msg TEXT NOT NULL, count INTEGER NOT NULL)" + , "CREATE TABLE summary (name TEXT NOT NULL, lines INTEGER NOT NULL, first_at REAL NOT NULL, last_at REAL NOT NULL)" + , "CREATE TABLE error (msg TEXT NOT NULL, input TEXT)" + ] + +selectAll :: SQL +selectAll = + "SELECT at, cons, slot as arg1, block as arg2, null as arg3, hash as arg4 FROM event \ + \UNION \ + \SELECT at, cons, count as arg1, rejected as arg2, null as arg3, tid as arg4 FROM txns \ + \UNION \ + \SELECT at, 'LOResources' as cons, null, null, null, as_blob FROM resource \ + \UNION \ + \SELECT at, 'LOTraceStartLeadershipCheck' as cons, slot, utxo_size, chain_dens, null FROM slot \ + \ORDER BY at" + + +bySlotDomain :: [LogObject] -> [(SlotNo, [LogObject])] +bySlotDomain logObjs = + case dropWhile (isNothing . newSlot) logObjs of + [] -> [] + xs -> chop go xs + where + newSlot LogObject{loBody} = case loBody of { LOTraceStartLeadershipCheck s _ _ -> Just s; _ -> Nothing } + + go ~(lo:los) = let (inSlot, rest) = span (isNothing . newSlot) los in ((fromJust $ newSlot lo, inSlot), rest) + + +{- +createIndex :: SQL +createIndex = + "CREATE INDEX idx_lo_body ON lo_body(at)" +-} + +{- +mempool saturation example, needs reducer: +select at, null as slot, count from txns where cons='LOMempoolTxs' union select at, slot, null as count from slot order by at; +-} + +{- +TODO: gather summary data: + +grep '^{' f | head -n1: 1st timestamp +grep -c '^{' f: no. of trace msgs +tail -n1 f: last timestamp +-} diff --git a/bench/locli/locli.cabal b/bench/locli/locli.cabal index ba55c43f405..1958a24612c 100644 --- a/bench/locli/locli.cabal +++ b/bench/locli/locli.cabal @@ -1,7 +1,7 @@ cabal-version: 3.0 name: locli -version: 1.36 +version: 2.0 synopsis: Cardano log analysis CLI description: Cardano log analysis CLI. category: Cardano, @@ -89,7 +89,9 @@ library Cardano.Org Cardano.Render + Cardano.Unlog.BackendFile Cardano.Unlog.LogObject + Cardano.Unlog.LogObjectDB Cardano.Unlog.Resources other-modules: Paths_locli @@ -116,6 +118,7 @@ library , ouroboros-network-api ^>= 0.10 , sop-core , split + , sqlite-easy >= 1.1.0.1 , statistics , strict-sop-core , text @@ -147,6 +150,31 @@ executable locli , transformers , transformers-except +executable locli-db + import: project-config + + hs-source-dirs: app + main-is: locli-db.hs + ghc-options: -threaded + -rtsopts + "-with-rtsopts=-T -N7 -A2m -qb -H64m" + + build-depends: locli + , aeson + , async + , bytestring + , containers + , cardano-api + , directory + , extra + , split + , text + , text-short + , time + , trace-resources + , sqlite-easy >= 1.1.0.1 + , unordered-containers + test-suite test-locli import: project-config @@ -163,4 +191,5 @@ test-suite test-locli , text other-modules: Test.Analysis.CDF + Test.Unlog.LogObjectDB Test.Unlog.Org diff --git a/bench/locli/src/Cardano/Analysis/API/Ground.hs b/bench/locli/src/Cardano/Analysis/API/Ground.hs index 005108b4946..3ae750f3374 100644 --- a/bench/locli/src/Cardano/Analysis/API/Ground.hs +++ b/bench/locli/src/Cardano/Analysis/API/Ground.hs @@ -1,6 +1,7 @@ -{-# LANGUAGE PolyKinds #-} {-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GeneralisedNewtypeDeriving #-} +{-# LANGUAGE PolyKinds #-} {-# OPTIONS_GHC -Wno-orphans #-} module Cardano.Analysis.API.Ground ( module Cardano.Analysis.API.Ground @@ -10,28 +11,29 @@ module Cardano.Analysis.API.Ground ) where -import Prelude as P (show) -import Cardano.Prelude hiding (head, toText) -import Unsafe.Coerce qualified as Unsafe +import Cardano.Prelude hiding (head, toText) +import Cardano.Slotting.Slot (EpochNo (..), SlotNo (..)) +import Cardano.Util +import Ouroboros.Network.Block (BlockNo (..)) -import Data.Aeson -import Data.Aeson.Types (toJSONKeyText) -import Data.ByteString.Lazy.Char8 qualified as LBS -import Data.Map.Strict qualified as Map -import Data.Text qualified as T -import Data.Text.Short qualified as SText -import Data.Text.Short (ShortText, fromText, toText) -import Data.Time.Clock (UTCTime, NominalDiffTime) -import Options.Applicative -import Options.Applicative qualified as Opt -import System.FilePath qualified as F +import Prelude as P (show) -import Cardano.Slotting.Slot (EpochNo(..), SlotNo(..)) -import Ouroboros.Network.Block (BlockNo(..)) +import Data.Aeson +import Data.Aeson.Types (toJSONKeyText) +import qualified Data.ByteString.Lazy.Char8 as LBS +import Data.CDF +import Data.Data (Data) +import Data.DataDomain +import qualified Data.Map.Strict as Map +import qualified Data.Text as T +import Data.Text.Short (ShortText, fromText, toText) +import qualified Data.Text.Short as SText +import Data.Time.Clock (NominalDiffTime, UTCTime) +import Options.Applicative +import qualified Options.Applicative as Opt +import qualified System.FilePath as F -import Data.CDF -import Data.DataDomain -import Cardano.Util +import qualified Unsafe.Coerce as Unsafe newtype FieldName = FieldName { unFieldName :: Text } @@ -51,7 +53,7 @@ instance Show TId where show = ("TId " ++) . P.show . unTId newtype Hash = Hash { unHash :: ShortText } - deriving (Eq, Generic, Ord) + deriving (Eq, Generic, Ord, Data) deriving newtype (FromJSON, ToJSON) deriving anyclass NFData @@ -112,6 +114,10 @@ data HostDeduction = HostFromLogfilename deriving stock (Eq, Ord, Show) +deriving instance Data SlotNo + +deriving instance Data BlockNo + --- --- Files --- diff --git a/bench/locli/src/Cardano/Analysis/MachPerf.hs b/bench/locli/src/Cardano/Analysis/MachPerf.hs index 4ee40096443..84b3ddf6d43 100644 --- a/bench/locli/src/Cardano/Analysis/MachPerf.hs +++ b/bench/locli/src/Cardano/Analysis/MachPerf.hs @@ -47,7 +47,7 @@ timelineFromLogObjects run@Run{genesis} (f, xs') = $ foldl' (timelineStep run f) zeroTimelineAccum xs & (aRunScalars &&& reverse . aSlotStats) where - xs = filter (not . (`textRefEquals` "DecodeError") . loKind) xs' + xs = filter (not . ("DecodeError" `textRefEquals`) . loKind) xs' firstRelevantLogObjectTime :: UTCTime firstRelevantLogObjectTime = loAt (head xs) `max` systemStart genesis diff --git a/bench/locli/src/Cardano/Command.hs b/bench/locli/src/Cardano/Command.hs index 21a5a539152..318eb4035e6 100644 --- a/bench/locli/src/Cardano/Command.hs +++ b/bench/locli/src/Cardano/Command.hs @@ -29,6 +29,7 @@ import Cardano.Analysis.MachPerf import Cardano.Analysis.Summary import Cardano.Render import Cardano.Report +import Cardano.Unlog.BackendFile import Cardano.Unlog.LogObject import Cardano.Util hiding (head) diff --git a/bench/locli/src/Cardano/Unlog/BackendFile.hs b/bench/locli/src/Cardano/Unlog/BackendFile.hs new file mode 100644 index 00000000000..1c9889c0dcc --- /dev/null +++ b/bench/locli/src/Cardano/Unlog/BackendFile.hs @@ -0,0 +1,85 @@ + +module Cardano.Unlog.BackendFile where + +import Cardano.Analysis.API.Ground +import Cardano.Prelude hiding (Text, show, toText) +import Cardano.Unlog.LogObject +import Cardano.Util + +import Prelude (id, show) + +import qualified Data.Aeson as AE (eitherDecode) +import qualified Data.ByteString.Lazy as LBS +import qualified Data.Map.Strict as Map +import qualified Data.Text as TS +import qualified Data.Text.Short as Text +import GHC.Conc (numCapabilities) + + +runLiftLogObjects :: RunLogs () -> Bool -> Maybe [LOAnyType] + -> ExceptT TS.Text IO (RunLogs [LogObject]) +runLiftLogObjects rl@RunLogs{..} okDErr loAnyLimit = liftIO $ + go Map.empty 0 simultaneousReads + where + go (force -> !acc) batchBase = \case + [] -> pure $ rl{ rlHostLogs = acc } + c:cs -> do + let batchBase' = batchBase + length c + when (length c > 1) $ + progress "logs" (Q $ printf "processing batch %d - %d" batchBase (batchBase' - 1)) + hlsMap <- readHostLogChunk c + go (acc `Map.union` hlsMap) batchBase' cs + + simultaneousReads = chunksOf numCapabilities (Map.toList rlHostLogs) + + readHostLogChunk :: [(Host, HostLogs ())] -> IO (Map Host (HostLogs [LogObject])) + readHostLogChunk hls = + Map.fromList <$> forConcurrently hls (uncurry readHostLogs) + + readHostLogs :: Host -> HostLogs () -> IO (Host, HostLogs [LogObject]) + readHostLogs h hl@HostLogs{..} = + readLogObjectStream (unJsonLogfile $ fst hlLogs) okDErr loAnyLimit + <&> (h,) . setLogs hl . fmap (setLOhost h) + + setLogs :: HostLogs a -> b -> HostLogs b + setLogs hl x = hl { hlLogs = (fst $ hlLogs hl, x) } + setLOhost :: Host -> LogObject -> LogObject + setLOhost h lo = lo { loHost = h } + +readLogObjectStream :: FilePath -> Bool -> Maybe [LOAnyType] -> IO [LogObject] +readLogObjectStream f okDErr loAnyLimit = + LBS.readFile f + <&> + (if okDErr then id else + filter ((\case + LODecodeError input err -> error + (printf "Decode error while parsing %s:\n%s\non input:\n>>> %s" f (Text.toString err) (Text.toString input)) + _ -> True) + . loBody)) . + filter ((case loAnyLimit of + Nothing -> \case + LOAny{} -> False + _ -> True + Just constraint -> \case + LOAny laty obj -> + elem laty constraint + || error (printf "Unexpected LOAny while parsing %s -- %s: %s" + f (show laty) (show obj)) + _ -> True) + . loBody) . + filter (not . isDecodeError "Error in $: not enough input" . loBody) . + fmap (\bs -> + AE.eitherDecode bs & + either + (LogObject zeroUTCTime "Cardano.Analysis.DecodeError" "DecodeError" "" (TId "0") + . LODecodeError (Text.fromByteString (LBS.toStrict bs) + & fromMaybe "#") + . Text.fromText + . TS.pack) + id) + . filter (not . LBS.null) + . LBS.split (fromIntegral $ fromEnum '\n') + where + isDecodeError x = \case + LODecodeError _ x' -> x == x' + _ -> False diff --git a/bench/locli/src/Cardano/Unlog/LogObject.hs b/bench/locli/src/Cardano/Unlog/LogObject.hs index 8702e1e8f2f..338af9d7d3f 100644 --- a/bench/locli/src/Cardano/Unlog/LogObject.hs +++ b/bench/locli/src/Cardano/Unlog/LogObject.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE GeneralisedNewtypeDeriving #-} @@ -9,15 +10,12 @@ {-# OPTIONS_GHC -Wno-partial-fields -Wno-orphans #-} {- HLINT ignore "Redundant <$>" -} -{- HLINT ignore "Redundant if" -} -{- HLINT ignore "Use infix" -} module Cardano.Unlog.LogObject ( HostLogs (..) , hlRawLogObjects , RunLogs (..) , rlLogs - , runLiftLogObjects , LogObject (..) , loPretty -- @@ -25,22 +23,27 @@ module Cardano.Unlog.LogObject , logObjectStreamInterpreterKeys , LOBody (..) , LOAnyType (..) - , readLogObjectStream + , fromTextRef , textRefEquals ) where +import Cardano.Analysis.API.Ground +import Cardano.Logging.Resources.Types import Cardano.Prelude hiding (Text, show, toText) -import GHC.Conc (numCapabilities) -import Prelude (id, show, unzip3) +import Cardano.Util + +import Prelude (show, unzip3) import qualified Data.Aeson as AE import qualified Data.Aeson.Key as Aeson import qualified Data.Aeson.KeyMap as KeyMap import Data.Aeson.Types (Parser) -import qualified Data.ByteString.Lazy as LBS +import Data.Data (Data) import Data.Hashable (hash) import qualified Data.Map.Strict as Map +import Data.Profile +import Data.String (IsString (..)) import qualified Data.Text as LText import Data.Text.Short (ShortText, fromText, toText) import qualified Data.Text.Short as Text @@ -48,13 +51,6 @@ import Data.Tuple.Extra (fst3, snd3, thd3) import Data.Vector (Vector) import qualified Data.Vector as V -import Cardano.Logging.Resources.Types - -import Data.Profile - -import Cardano.Analysis.API.Ground -import Cardano.Util - type Text = ShortText @@ -70,14 +66,20 @@ data TextRef toTextRef :: Text -> TextRef toTextRef t = let h = hash t in if Text.null (lookupTextRef h) then TextLit t else TextRef h -textRefEquals :: TextRef -> Text -> Bool -textRefEquals (TextRef i) = (== lookupTextRef i) -textRefEquals (TextLit t) = (== t) +fromTextRef :: TextRef -> Text +fromTextRef (TextRef i) = lookupTextRef i +fromTextRef (TextLit t) = t + +textRefEquals :: Text -> TextRef -> Bool +textRefEquals t = (t ==) . fromTextRef instance Show TextRef where show (TextRef i) = show $ lookupTextRef i show (TextLit t) = show t +instance IsString TextRef where + fromString = toTextRef . fromString + instance ToJSON TextRef where toJSON (TextRef i) = toJSON $ lookupTextRef i toJSON (TextLit t) = toJSON t @@ -111,73 +113,6 @@ data RunLogs a rlLogs :: RunLogs a -> [(JsonLogfile, a)] rlLogs = fmap hlLogs . Map.elems . rlHostLogs -runLiftLogObjects :: RunLogs () -> Bool -> Maybe [LOAnyType] - -> ExceptT LText.Text IO (RunLogs [LogObject]) -runLiftLogObjects rl@RunLogs{..} okDErr loAnyLimit = liftIO $ - go Map.empty 0 simultaneousReads - where - go (force -> !acc) batchBase = \case - [] -> pure $ rl{ rlHostLogs = acc } - c:cs -> do - let batchBase' = batchBase + length c - when (length c > 1) $ - progress "logs" (Q $ printf "processing batch %d - %d" batchBase (batchBase' - 1)) - hlsMap <- readHostLogChunk c - go (acc `Map.union` hlsMap) batchBase' cs - - simultaneousReads = chunksOf numCapabilities (Map.toList rlHostLogs) - - readHostLogChunk :: [(Host, HostLogs ())] -> IO (Map Host (HostLogs [LogObject])) - readHostLogChunk hls = - Map.fromList <$> forConcurrently hls (uncurry readHostLogs) - - readHostLogs :: Host -> HostLogs () -> IO (Host, HostLogs [LogObject]) - readHostLogs h hl@HostLogs{..} = - readLogObjectStream (unJsonLogfile $ fst hlLogs) okDErr loAnyLimit - <&> (h,) . setLogs hl . fmap (setLOhost h) - - setLogs :: HostLogs a -> b -> HostLogs b - setLogs hl x = hl { hlLogs = (fst $ hlLogs hl, x) } - setLOhost :: Host -> LogObject -> LogObject - setLOhost h lo = lo { loHost = h } - -readLogObjectStream :: FilePath -> Bool -> Maybe [LOAnyType] -> IO [LogObject] -readLogObjectStream f okDErr loAnyLimit = - LBS.readFile f - <&> - (if okDErr then id else - filter ((\case - LODecodeError input err -> error - (printf "Decode error while parsing %s:\n%s\non input:\n>>> %s" f (Text.toString err) (Text.toString input)) - _ -> True) - . loBody)) . - filter ((case loAnyLimit of - Nothing -> \case - LOAny{} -> False - _ -> True - Just constraint -> \case - LOAny laty obj -> - elem laty constraint - || error (printf "Unexpected LOAny while parsing %s -- %s: %s" - f (show laty) (show obj)) - _ -> True) - . loBody) . - filter (not . isDecodeError "Error in $: not enough input" . loBody) . - fmap (\bs -> - AE.eitherDecode bs & - either - (LogObject zeroUTCTime (TextLit "Cardano.Analysis.DecodeError") (TextLit "DecodeError") "" (TId "0") - . LODecodeError (Text.fromByteString (LBS.toStrict bs) - & fromMaybe "#") - . Text.fromText - . LText.pack) - id) - . filter (not . LBS.null) - . LBS.split (fromIntegral $ fromEnum '\n') - where - isDecodeError x = \case - LODecodeError _ x' -> x == x' - _ -> False data LogObject = LogObject @@ -193,12 +128,9 @@ data LogObject instance ToJSON LogObject -instance Print ShortText where - hPutStr h = hPutStr h . toText - hPutStrLn h = hPutStrLn h . toText - deriving instance NFData a => NFData (Resources a) + loPretty :: LogObject -> LText.Text loPretty LogObject{..} = mconcat [ stripS . LText.pack $ show loAt, " " @@ -339,6 +271,9 @@ interpreters = map3ple Map.fromList . unzip3 . fmap ent $ -- Ledger snapshots: , (,,,) "TraceSnapshotEvent.TookSnapshot" "TraceLedgerEvent.TookSnapshot" "ChainDB.LedgerEvent.TookSnapshot" $ \_ -> pure LOLedgerTookSnapshot + -- TODO: track slot and duration (SMaybe) + -- {"at":"2024-10-19T10:16:27.459112022Z","ns":"ChainDB.LedgerEvent.TookSnapshot","data":{"enclosedTime":{"tag":"RisingEdge"},"kind":"TookSnapshot","snapshot":{"kind":"snapshot"},"tip":"RealPoint (SlotNo 5319) adefbb19d6284aa68f902d33018face42d37e1a7970415d2a81bd4c2dea585ba"},"sev":"Info","thread":"81","host":"client-us-04"} + -- {"at":"2024-10-19T10:16:45.925381225Z","ns":"ChainDB.LedgerEvent.TookSnapshot","data":{"enclosedTime":{"contents":18.466253914,"tag":"FallingEdgeWith"},"kind":"TookSnapshot","snapshot":{"kind":"snapshot"},"tip":"RealPoint (SlotNo 5319) adefbb19d6284aa68f902d33018face42d37e1a7970415d2a81bd4c2dea585ba"},"sev":"Info","thread":"81","host":"client-us-04"} -- Tx receive path & mempool: , (,,,) "TraceBenchTxSubServAck" "TraceBenchTxSubServAck" "TraceBenchTxSubServAck" $ @@ -471,7 +406,7 @@ data LOBody { loRawText :: !ShortText , loError :: !ShortText } - deriving (Eq, Generic, Show) + deriving (Eq, Generic, Show, Data) deriving anyclass NFData data LOAnyType @@ -479,9 +414,11 @@ data LOAnyType | LANonBlocking | LARollback | LANoInterpreter - deriving (Eq, Generic, NFData, Read, Show, ToJSON) + deriving (Eq, Generic, NFData, Read, Show, ToJSON, Data) -deriving instance Eq ResourceStats +deriving instance Eq ResourceStats +deriving instance Typeable ResourceStats +deriving instance Data ResourceStats instance ToJSON LOBody diff --git a/bench/locli/src/Cardano/Unlog/LogObjectDB.hs b/bench/locli/src/Cardano/Unlog/LogObjectDB.hs new file mode 100644 index 00000000000..709fe22ba26 --- /dev/null +++ b/bench/locli/src/Cardano/Unlog/LogObjectDB.hs @@ -0,0 +1,440 @@ +{-# LANGUAGE UndecidableInstances #-} + +{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} + +{-# OPTIONS_GHC -fno-warn-unused-imports #-} + + +module Cardano.Unlog.LogObjectDB + ( AsSQLData (..) + , SummaryDB (..) + , SQLRunnable + , TraceFreqs + + , sqlToLogObject + , logObjectToSql + , errorToSql + , summaryToSql + , traceFreqsToSql + + , runSqlRunnable + + , allLOBodyConstructors + , knownLOBodyConstructors + ) where + +import Cardano.Analysis.API.Ground +import Cardano.Logging.Resources.Types (ResourceStats, Resources (..)) +import Cardano.Unlog.LogObject +import Cardano.Util hiding (count) + +import Prelude + +import Data.Aeson as Aeson (decodeStrict, encode) +import Data.Bool (bool) +import qualified Data.ByteString.Lazy.Char8 as BSL (toStrict) +import Data.Data (dataTypeConstrs, dataTypeOf, showConstr, toConstr) +import qualified Data.Map.Lazy as ML +import Data.Maybe +import qualified Data.Set as Set +import qualified Data.Text as TS (Text, empty, intercalate, pack, splitOn, unpack) +import qualified Data.Text.Lazy as TL (Text, fromStrict, pack) +import qualified Data.Text.Short as ShortText (ShortText, empty, fromText, pack, toText) + +import Database.Sqlite.Easy hiding (Text) +import Database.Sqlite.Easy.Internal (SQL (..)) + + +data SummaryDB = SummaryDB + { sdbName :: Host + , sdbLines :: Int + , sdbFirstAt :: UTCTime + , sdbLastAt :: UTCTime + } + +type TraceFreqs = ML.Map ShortText.ShortText Int + +-- an SQL statement, and its arguments; directly applicable to `uncurry runWith` +type SQLRunnable = (SQL, [SQLData]) + +runSqlRunnable :: SQLRunnable -> SQLite [[SQLData]] +runSqlRunnable = uncurry runWith + + +-- table error + +insertError :: SQL +insertError = + "INSERT INTO error VALUES (?,?)" + +errorToSql :: String -> String -> SQLRunnable +errorToSql errorMsg origInput = + (insertError, toArgs $ Tuple ("", errorMsg) ("", origInput)) + +-- table summary + +insertSummary :: SQL +insertSummary = + "INSERT INTO summary VALUES (?,?,?,?)" + +summaryToSql :: SummaryDB -> SQLRunnable +summaryToSql SummaryDB{sdbName = Host name, ..} = + ( insertSummary + , [ toSqlData name, toSqlData sdbLines, toSqlData sdbFirstAt, toSqlData sdbLastAt ] + ) + +-- table tracefreq + +insertTraceFreq :: SQL +insertTraceFreq = + "INSERT INTO tracefreq VALUES (?,?)" + +traceFreqsToSql :: TraceFreqs -> [SQLRunnable] +traceFreqsToSql ts = + (,) insertTraceFreq <$> + [ toArgs (Tuple ("", k) ("", v)) | (k, v) <- ML.toAscList ts ] + +-- table resource + +insertResource :: SQL +insertResource = + "INSERT INTO resource VALUES (?,?,?,?,?,?)" + +resourceArgs :: UTCTime -> ResourceStats -> [SQLData] +resourceArgs at rs@Resources{rCentiCpu, rRSS, rHeap, rAlloc} = + [ toSqlData at + , toSqlData rCentiCpu + , toSqlData rRSS + , toSqlData rHeap + , toSqlData rAlloc + , toSqlData rs + ] + +-- table slot + +insertSlot :: SQL +insertSlot = + "INSERT INTO slot VALUES (?,?,?,?)" + +slotArgs :: UTCTime -> ArgNTuple -> [SQLData] +slotArgs at args@Triple{} = toSqlData at : toArgs args +slotArgs _ _ = error "slotArgs: three arguments expected" + +-- tables event and txns + +logObjectToSql :: LogObject -> Maybe SQLRunnable +logObjectToSql lo@LogObject{loAt, loBody, loTid} = + -- case Aeson.eitherDecode inp of + + -- Left err -> Just (insertError, toArgs $ Tuple ("", err) ("", BSL.unpack inp)) + + -- Right -> + case loBody of + + -- no suitable interpreter found when parsing log object stream + LOAny{} -> Nothing + -- trace not emitted by the node + LOGeneratorSummary{} -> Nothing + -- not required for analysis + LOTxsAcked{} -> Nothing + + LOResources stats -> Just (insertResource, resourceArgs loAt stats) + + LOTraceStartLeadershipCheck slot utxoSize chainDensity + -> Just (insertSlot, slotArgs loAt (Triple ("", slot) ("", utxoSize) ("", chainDensity))) + -- forging + LOBlockContext slot block -> newLOEvent $ Tuple ("slot", slot) ("block", block) + LOLedgerState s -> newLOEvent $ Singleton ("slot", s) + LOLedgerView s -> newLOEvent $ Singleton ("slot", s) + LOTraceLeadershipDecided s b -> newLOEvent $ Tuple ("slot", s) ("block", b) + LOTickedLedgerState s -> newLOEvent $ Singleton ("slot", s) + LOMempoolSnapshot s -> newLOEvent $ Singleton ("slot", s) + LOBlockForged s b h1 h2 -> newLOEvent $ Triple ("slot", s) ("block", b) ("hash", (h1, h2)) + + -- diffusion + LOChainSyncClientSeenHeader s b h + -> newLOEvent $ Triple ("slot", s) ("block", b) ("hash", h) + LOBlockFetchClientRequested h len + -> newLOEvent $ Tuple ("block", len) ("hash", h) + LOBlockFetchClientCompletedFetch h + -> newLOEvent $ Singleton ("hash", h) + LOChainSyncServerSendHeader h + -> newLOEvent $ Singleton ("hash", h) + LOBlockFetchServerSending h + -> newLOEvent $ Singleton ("hash", h) + LOBlockAddedToCurrentChain h mSz len + -> newLOEvent $ Triple ("slot", mSz) ("block", len) ("hash", h) + + LOLedgerTookSnapshot -> newLOEvent Empty + + -- txn receive path + LOTxsCollected c -> newLOTxns $ Tuple ("count", c) ("tid", loTid) + LOTxsProcessed c r -> newLOTxns $ Triple ("count", c) ("rejected", r) ("tid", loTid) + LOMempoolTxs c -> newLOTxns $ Singleton ("count", c) + LOMempoolRejectedTx -> newLOTxns Empty + + -- that goes to the error table + LODecodeError rawText err -> Just (insertError, toArgs $ Tuple ("", err) ("", rawText)) + + where + newLOEvent = Just . insertVariadic "event" lo + newLOTxns = Just . insertVariadic "txns" lo + + +insertVariadic :: SQL -> LogObject -> ArgNTuple -> SQLRunnable +insertVariadic table LogObject{loAt, loBody} argNTuple = (sql, args) + where + args = toSqlData loAt : toSqlData loBody : toArgs argNTuple + (columns, templ) = toFieldList argNTuple + sql = "INSERT INTO " <> table <>"(at,cons" <> columns <> ") VALUES (?,?" <> templ <> ")" + + +-- some minimal guarantees for the variadic INSERTs on tables event and txns + +type Column = TS.Text + +-- values to store, paired with their column name +data ArgNTuple where + Empty :: ArgNTuple + Singleton :: forall x. (AsSQLData x) => (Column, x) -> ArgNTuple + Tuple :: forall x y. (AsSQLData x, AsSQLData y) => (Column, x) -> (Column, y) -> ArgNTuple + Triple :: forall x y z. (AsSQLData x, AsSQLData y, AsSQLData z) => (Column, x) -> (Column, y) -> (Column, z) -> ArgNTuple + +toArgs :: ArgNTuple -> [SQLData] +toArgs = \case + Empty -> [] + Singleton (_, x) -> [toSqlData x] + Tuple (_, x) (_, y) -> [toSqlData x, toSqlData y] + Triple (_, x) (_, y) (_, z) -> [toSqlData x, toSqlData y, toSqlData z] + +-- for simplicity's sake, this yields both the column names +-- and the correct number of additional placeholders to extend the template +toFieldList :: ArgNTuple -> (SQL, SQL) +toFieldList = \case + Empty -> ("" , "") + Singleton (x, _) -> (go [x] , ",?") + Tuple (x, _) (y, _) -> (go [x, y] , ",?,?") + Triple (x, _) (y, _) (z, _) -> (go [x, y, z] , ",?,?,?") + where + go = SQL . TS.intercalate "," . (TS.empty :) + + +sqlToLogObject :: SummaryDB -> [SQLData] -> LogObject +sqlToLogObject _ [] = error "toLogObject: no columns in result row" +sqlToLogObject SummaryDB{sdbName} (at : rest) = + let body = fromSqlDataWithArgs rest + in LogObject + { loAt = fromSqlData at + , loNS = "" + , loKind = "" + , loHost = sdbName + , loTid = logObjectNeedsTIdforAnalysis rest body + , loBody = body + } + +-- There's only a couple of log objects that need the TId field for analysis. +-- Hence, it's only stored for those. +-- NB. The assumption here is it is the last column in the schema for table 'txns' +logObjectNeedsTIdforAnalysis :: [SQLData] -> LOBody -> TId +logObjectNeedsTIdforAnalysis args = \case + LOTxsCollected{} -> theTId + LOTxsProcessed{} -> theTId + _ -> TId ShortText.empty + where + theTId = fromSqlData $ last args + +toLOBodyConverters :: [SQLData] -> ML.Map TL.Text LOBody +toLOBodyConverters args = ML.fromList + [ ( "LOResources", LOResources (fromSqlData $ last args)) + + , ( "LOTraceStartLeadershipCheck" + , LOTraceStartLeadershipCheck (fromSqlData slot) (fromSqlData utxoSize) (fromSqlData chainDens) + ) + + -- forging + , ( "LOBlockContext", LOBlockContext (fromSqlData slot) (fromSqlData block)) + , ( "LOLedgerState", LOLedgerState (fromSqlData slot)) + , ( "LOLedgerView", LOLedgerView (fromSqlData slot)) + , ( "LOTraceLeadershipDecided" + , LOTraceLeadershipDecided (fromSqlData slot) (fromSqlData block) + ) + , ( "LOTickedLedgerState", LOTickedLedgerState (fromSqlData slot)) + , ( "LOMempoolSnapshot", LOMempoolSnapshot (fromSqlData slot)) + , ( "LOBlockForged", uncurry (LOBlockForged (fromSqlData slot) (fromSqlData block)) (fromSqlData hash)) + + -- diffusion + , ( "LOChainSyncClientSeenHeader" + , LOChainSyncClientSeenHeader (fromSqlData slot) (fromSqlData block) (fromSqlData hash) + ) + , ( "LOBlockFetchClientRequested" + , LOBlockFetchClientRequested (fromSqlData hash) (fromSqlData block) + ) + , ( "LOBlockFetchClientCompletedFetch" + , LOBlockFetchClientCompletedFetch (fromSqlData hash) + ) + , ( "LOChainSyncServerSendHeader" + , LOChainSyncServerSendHeader (fromSqlData hash) + ) + , ( "LOBlockFetchServerSending" + , LOBlockFetchServerSending (fromSqlData hash) + ) + , ( "LOBlockAddedToCurrentChain" + , LOBlockAddedToCurrentChain (fromSqlData hash) (fromSqlData slot) (fromSqlData block) + ) + + , ( "LOLedgerTookSnapshot", LOLedgerTookSnapshot) + + -- txn receive path + , ( "LOTxsCollected", LOTxsCollected (fromSqlData count)) + , ( "LOTxsProcessed", LOTxsProcessed (fromSqlData count) (fromSqlData rejected)) + , ( "LOMempoolTxs", LOMempoolTxs (fromSqlData count)) + , ( "LOMempoolRejectedTx", LOMempoolRejectedTx) + + -- constructor not expected to appear given the definition of `selectAll` + , ( "LODecodeError", errorGiven "LODecodeError") + + -- all constructors not expected to appear given the definition of `logLineToSQL` + , ( "LOAny", errorGiven "LOAny") + , ( "LOGeneratorSummary", errorGiven "LOGeneratorSummary") + , ( "LOTxsAcked", errorGiven "LOTxsAcked") + ] + where + errorGiven cons = LODecodeError (ShortText.pack $ show args) ("toLOBodyConverters: unexpected " <> cons <> " (with args)") + + -- match remaining columns (after 'at' and 'cons') on a result row from `selectAll`, + -- offering custom matches for each table. + + -- table: event + slot : block : _ : hash : _ = args + + -- table: slot + _ : utxoSize : chainDens : _ = args + + -- table: txns + count : rejected : _ = args + +toLOBody :: [SQLData] -> LOBody +toLOBody (SQLText cons : args) = fromMaybe unresolved resolve + where + resolve = TL.fromStrict cons `ML.lookup` toLOBodyConverters args + unresolved = LODecodeError (ShortText.fromText cons) "toLOBody: no converter for that constructor; LOBody type definition may have changed in `locli` code" +toLOBody r = error $ "toLOBody: could not pattern match on result row " ++ show r + + +allLOBodyConstructors, knownLOBodyConstructors :: Set.Set TL.Text +knownLOBodyConstructors = ML.keysSet $ toLOBodyConverters [] +allLOBodyConstructors = Set.fromList $ map (TL.pack . showConstr) (dataTypeConstrs $ dataTypeOf (undefined :: LOBody)) + + +-- +-- data marshalling +-- + +class AsSQLData x where + toSqlData :: x -> SQLData + + fromSqlData :: SQLData -> x + + fromSqlDataWithArgs :: [SQLData] -> x + fromSqlDataWithArgs = \case + [x] -> fromSqlData x + _ -> error "fromSqlDataWithArgs(default): arg count must be exactly one" + + +instance {-# OVERLAPPABLE #-} Integral a => AsSQLData a where + toSqlData = SQLInteger . fromIntegral + fromSqlData = withSqlInteger fromIntegral + +instance AsSQLData Bool where + toSqlData = bool (SQLInteger 0) (SQLInteger 1) + fromSqlData = withSqlInteger (== 1) + +instance AsSQLData Double where + toSqlData = SQLFloat + fromSqlData = withSqlFloat id + +instance AsSQLData String where + toSqlData = SQLText . TS.pack + fromSqlData = withSqlText TS.unpack + +instance AsSQLData UTCTime where + toSqlData = SQLFloat . realToFrac . utcTimeToPOSIXSeconds + fromSqlData = withSqlFloat (posixSecondsToUTCTime . realToFrac) + +instance AsSQLData LOBody where + toSqlData = SQLText . TS.pack . showConstr . toConstr + fromSqlData = const $ error "fromSqlData(LOBody): argument list needed" + fromSqlDataWithArgs = toLOBody + +instance AsSQLData SlotNo where + toSqlData = toSqlData . unSlotNo + fromSqlData = SlotNo . fromSqlData + +instance AsSQLData BlockNo where + toSqlData = toSqlData . unBlockNo + fromSqlData = BlockNo . fromSqlData + +instance AsSQLData ShortText.ShortText where + toSqlData = SQLText . ShortText.toText + fromSqlData = withSqlText ShortText.fromText + +instance AsSQLData Hash where + toSqlData = toSqlData . unHash + fromSqlData = Hash . fromSqlData + +instance AsSQLData TId where + toSqlData = toSqlData . unTId + fromSqlData = TId . fromSqlData + +-- a shortcut, so we only need one TEXT argument column in table `event` +instance AsSQLData (Hash, Hash) where + toSqlData (unHash -> h1, unHash -> h2) = + SQLText . ShortText.toText $ h1 <> "|" <> h2 + fromSqlData = withSqlText $ \t -> + case TS.splitOn "|" t of + [h1, h2] -> (Hash $ ShortText.fromText h1, Hash $ ShortText.fromText h2) + _ -> error "fromSqlData(Hash,Hash): unexpected pipe-separation" + +instance AsSQLData ResourceStats where + toSqlData = SQLBlob . BSL.toStrict . Aeson.encode + fromSqlData = withSqlBlob (fromJust . Aeson.decodeStrict) + +-- this must conform to the columns in table `summary` / serialisation in `summaryToSql` +instance AsSQLData SummaryDB where + toSqlData = const $ error "toSqlData(SummaryDB): can't be represented as a single SQLData; use `summaryToSql`" + fromSqlData = const $ error "fromSqlData(SummaryDB): argument list needed" + fromSqlDataWithArgs [c1, c2, c3, c4] = + SummaryDB + { sdbName = Host (fromSqlData c1) + , sdbLines = fromSqlData c2 + , sdbFirstAt = fromSqlData c3 + , sdbLastAt = fromSqlData c4 + } + fromSqlDataWithArgs x = error $ "fromSqlDataWithArgs(SummaryDB): expected 4 columns, got:" ++ show x + +instance AsSQLData a => AsSQLData (SMaybe a) where + toSqlData = smaybe SQLNull toSqlData + fromSqlData = \case + SQLNull -> SNothing + a -> SJust (fromSqlData a) + + +withSqlText :: (TS.Text -> a) -> SQLData -> a +withSqlText f = \case + SQLText t -> f t + a -> error $ "withSqlText: no match on " ++ show a + +withSqlInteger :: (Int64 -> a) -> SQLData -> a +withSqlInteger f = \case + SQLInteger i -> f i + a -> error $ "withSqlInteger: no match on " ++ show a + +withSqlFloat :: (Double -> a) -> SQLData -> a +withSqlFloat f = \case + SQLFloat d -> f d + a -> error $ "withSqlFloat: no match on " ++ show a + +withSqlBlob :: (ByteString -> a) -> SQLData -> a +withSqlBlob f = \case + SQLBlob b -> f b + a -> error $ "withSqlBlob: no match on " ++ show a diff --git a/bench/locli/src/Cardano/Util.hs b/bench/locli/src/Cardano/Util.hs index 7ccbe0b6643..d33eee271e6 100644 --- a/bench/locli/src/Cardano/Util.hs +++ b/bench/locli/src/Cardano/Util.hs @@ -1,9 +1,9 @@ {-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE GeneralisedNewtypeDeriving #-} {-# OPTIONS_GHC -Wno-orphans #-} {-# OPTIONS_GHC -Wno-incomplete-patterns #-} -{- HLINT ignore "Use list literal pattern" -} module Cardano.Util ( module Prelude , module Data.Aeson @@ -24,36 +24,39 @@ module Cardano.Util ) where -import Prelude (String, error, head, last) -import Text.Show qualified as Show (Show(..)) -import Cardano.Prelude - -import Data.Aeson (FromJSON (..), ToJSON (..), Object, Value (..), (.:), (.:?), (.!=), withObject, object) -import Data.Aeson qualified as AE -import Control.Arrow ((&&&), (***)) -import Control.Applicative ((<|>)) -import Control.Concurrent.Async (forConcurrently, forConcurrently_, mapConcurrently, mapConcurrently_) -import Control.DeepSeq qualified as DS -import Control.Monad.Trans.Except.Extra (firstExceptT, newExceptT) -import Data.ByteString.Lazy.Char8 qualified as LBS -import Data.IntervalMap.FingerTree (Interval (..), low, high, point) -import Data.List (span) -import Data.List.Split (chunksOf) -import Data.Text qualified as T -import Data.SOP (I (..), unI) -import Data.SOP.Strict -import Data.Time.Clock (NominalDiffTime, UTCTime (..), diffUTCTime, addUTCTime) -import Data.Time.Clock.POSIX -import Data.Vector (Vector) -import Data.Vector qualified as Vec -import GHC.Base (build) -import Text.Printf (printf) - -import System.FilePath qualified as F - -import Ouroboros.Consensus.Util.Time - -import Cardano.Ledger.BaseTypes (StrictMaybe (..), fromSMaybe) +import Cardano.Ledger.BaseTypes (StrictMaybe (..), fromSMaybe) +import Cardano.Prelude +import Ouroboros.Consensus.Util.Time + +import Prelude (String, error, head, last) + +import Control.Applicative ((<|>)) +import Control.Arrow ((&&&), (***)) +import Control.Concurrent.Async (forConcurrently, forConcurrently_, mapConcurrently, + mapConcurrently_) +import Control.Concurrent.Extra (Lock, newLock, withLock) +import qualified Control.DeepSeq as DS +import Control.Monad.Trans.Except.Extra (firstExceptT, newExceptT) +import Data.Aeson (FromJSON (..), Object, ToJSON (..), Value (..), object, withObject, + (.!=), (.:), (.:?)) +import qualified Data.Aeson as AE +import qualified Data.ByteString.Lazy.Char8 as LBS +import Data.Data (Data) +import Data.IntervalMap.FingerTree (Interval (..), high, low, point) +import Data.List (span) +import Data.List.Split (chunksOf) +import Data.SOP (I (..), unI) +import Data.SOP.Strict +import qualified Data.Text as T +import Data.Time.Clock (NominalDiffTime, UTCTime (..), addUTCTime, diffUTCTime) +import Data.Time.Clock.POSIX +import Data.Vector (Vector) +import qualified Data.Vector as Vec +import GHC.Base (build) +import qualified System.FilePath as F +import System.IO.Unsafe (unsafePerformIO) +import Text.Printf (printf) +import qualified Text.Show as Show (Show (..)) deriving newtype instance FromJSON a => (FromJSON (I a)) @@ -84,6 +87,8 @@ intvDurationSec = uncurry diffUTCTime . (high &&& low) -- type SMaybe a = StrictMaybe a +deriving instance Data a => Data (SMaybe a) + smaybe :: b -> (a -> b) -> StrictMaybe a -> b smaybe x _ SNothing = x smaybe _ f (SJust x) = f x @@ -146,7 +151,7 @@ mapLast :: (a -> a) -> [a] -> [a] mapLast _ [] = error "mapHead: partial" mapLast f xs' = reverse $ go [] xs' where go acc = \case - x:[] -> f x:acc + [x] -> f x:acc x:xs -> go ( x:acc) xs redistribute :: (a, (b, c)) -> ((a, b), (a, c)) @@ -160,23 +165,36 @@ toDouble :: forall a. Real a => a -> Double toDouble = fromRational . toRational data F - = R String - | Q String - | L [String] + = R String + | RNoCR String + | Q String + | L [String] | forall a. ToJSON a => J a +progressLock :: Lock +progressLock = unsafePerformIO newLock +{-# NOINLINE progressLock #-} + progress :: MonadIO m => String -> F -> m () -progress key = putStr . T.pack . \case - R x -> printf "{ \"%s\": %s }\n" key x - Q x -> printf "{ \"%s\": \"%s\" }\n" key x - L xs -> printf "{ \"%s\": \"%s\" }\n" key (Cardano.Prelude.intercalate "\", \"" xs) - J x -> printf "{ \"%s\": %s }\n" key (LBS.unpack $ AE.encode x) +progress key format = liftIO $ + withLock progressLock $ + putStr $ T.pack $ case format of + R x -> printf "{ \"%s\": %s }\n" key x + RNoCR x -> printf "{ \"%s\": %s } " key x + Q x -> printf "{ \"%s\": \"%s\" }\n" key x + L xs -> printf "{ \"%s\": \"%s\" }\n" key (Cardano.Prelude.intercalate "\", \"" xs) + J x -> printf "{ \"%s\": %s }\n" key (LBS.unpack $ AE.encode x) -- Dumping to files -- replaceExtension :: FilePath -> String -> FilePath replaceExtension f new = F.dropExtension f <> "." <> new +sequenceConcurrentlyChunksOf :: Int -> [IO a] -> IO [a] +sequenceConcurrentlyChunksOf n action = do + locks <- cycle <$> replicateM n newLock + let withLockActions = zipWith ($) (map withLock locks) action + runConcurrently $ traverse Concurrently withLockActions spans :: forall a. (a -> Bool) -> [a] -> [Vector a] spans f = go [] diff --git a/bench/locli/test/Test/Unlog/LogObjectDB.hs b/bench/locli/test/Test/Unlog/LogObjectDB.hs new file mode 100644 index 00000000000..36bd6cdc200 --- /dev/null +++ b/bench/locli/test/Test/Unlog/LogObjectDB.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -Wno-missing-signatures #-} +module Test.Unlog.LogObjectDB where + +import Cardano.Prelude +import Cardano.Unlog.LogObjectDB + +import qualified Data.Set as Set (difference, empty) + +import Hedgehog + + +-- This property ensures there are converter implementations +-- for all LOBody constructors. These converters are used +-- to reliably reconstruct a LOBody value from a database result row. + +prop_LOBody_converter_for_each_constructor = property $ + allLOBodyConstructors `Set.difference` knownLOBodyConstructors + === + Set.empty + +tests :: IO Bool +tests = + checkSequential $$discover diff --git a/bench/locli/test/test-locli.hs b/bench/locli/test/test-locli.hs index b352106773b..77edcbf25bb 100644 --- a/bench/locli/test/test-locli.hs +++ b/bench/locli/test/test-locli.hs @@ -4,10 +4,12 @@ import Hedgehog.Main (defaultMain) import qualified Test.Analysis.CDF import qualified Test.Unlog.Org +import qualified Test.Unlog.LogObjectDB main :: IO () main = defaultMain [ Test.Analysis.CDF.tests , Test.Unlog.Org.tests + , Test.Unlog.LogObjectDB.tests ]