Merge pull request #6054 from IntersectMBO/mkarg/experimental/locli-db

bench | locli: new DB  persistence backend for analysis data

Author: mgmeier

bench/locli/CHANGELOG.md

@@ -1,5 +1,14 @@
 # Revision history for locli
 
+## 2.0 -- Dec 2024
+
+* New database (DB) persistence backend for log objects using serverless SQLite DBs
+* Refactor current file persistence backend into its own module
+* New CLI commands `prepare-db` and `unlog-db` to create and read from DB persistence backend respectively
+* New sum type `LogObjectSource` to represent input from different backends (file or DB)
+* Tweak GC to mitigate high RAM requirements (for perf cluster analyses only)
+* New executable `locli-quick` which aims to be a development testbed for (upcoming) DB-backed quick queries
+
 ## 1.36 -- Nov 2024
 
 * Add `CHANGELOG.md` for `locli`

bench/locli/app/locli-quick.hs

@@ -0,0 +1,57 @@
+import           Cardano.Api (SlotNo (..))
+
+import           Cardano.Unlog.BackendDB
+import           Cardano.Unlog.LogObject (LOBody (..), LogObject (..))
+import           Cardano.Unlog.LogObjectDB
+import           Cardano.Util
+
+import           Prelude hiding (log)
+
+import           Data.Bifunctor (second)
+import           Data.List.Split (chop)
+import           Data.Maybe
+import           System.Environment (getArgs)
+
+import           Database.Sqlite.Easy hiding (Text)
+
+
+main :: IO ()
+main = do
+  getArgs >>= \case
+    []     -> putStrLn "please specify DB file"
+    db : _ -> runDB $ fromString db
+
+-- sample case:
+-- we want to know the txns in mempool for each slot
+
+runDB :: ConnectionString -> IO ()
+runDB dbName = do
+  (summary, res2) <-
+    withTimingInfo "withDb/selectMempoolTxs" $
+      withDb dbName $
+        (,) <$> getSummary <*> run selectMempoolTxs
+
+  let logObjects = map (sqlToLogObject summary) res2
+
+  -- TODO: needs a reducer
+  mapM_ (print . second safeLast) (bySlotDomain logObjects)
+  where
+    safeLast [] = []
+    safeLast xs = [last xs]
+
+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)
+    go []       = error "bySlotDomain/chop: empty list"
+
+selectMempoolTxs :: SQL
+selectMempoolTxs = sqlOrdered
+  [ sqlGetSlot
+  , sqlGetTxns `sqlAppend` "WHERE cons='LOMempoolTxs'"
+  ]

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,
@@ -50,6 +50,9 @@ common project-config
                         -Wcompat
                         -Wno-all-missed-specialisations
 
+  if impl(ghc >= 9.8)
+    ghc-options:        -Wno-x-partial
+
   build-depends:        base >= 4.14 && < 5,
 
   if os(windows)
@@ -89,7 +92,10 @@ library
                         Cardano.Org
                         Cardano.Render
 
+                        Cardano.Unlog.BackendDB
+                        Cardano.Unlog.BackendFile
                         Cardano.Unlog.LogObject
+                        Cardano.Unlog.LogObjectDB
                         Cardano.Unlog.Resources
 
   other-modules:        Paths_locli
@@ -116,6 +122,7 @@ library
                       , ouroboros-network-api ^>= 0.10
                       , sop-core
                       , split
+                      , sqlite-easy >= 1.1.0.1
                       , statistics
                       , strict-sop-core
                       , text
@@ -136,7 +143,7 @@ executable locli
   main-is:              locli.hs
   ghc-options:          -threaded
                         -rtsopts
-                        "-with-rtsopts=-T -N7 -A2m -qb -H64m"
+                        "-with-rtsopts=-T -N7 -A2m -c -H64m"
 
   build-depends:        aeson
                       , cardano-prelude
@@ -147,6 +154,30 @@ executable locli
                       , transformers
                       , transformers-except
 
+executable locli-quick
+  import:               project-config
+
+  hs-source-dirs:       app
+  main-is:              locli-quick.hs
+  ghc-options:          -threaded
+                        -rtsopts
+                        "-with-rtsopts=-T -N7 -A2m -c -H64m"
+
+  build-depends:        locli
+                      , aeson
+                      , async
+                      , bytestring
+                      , containers
+                      , cardano-api
+                      , 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 +194,5 @@ test-suite test-locli
                       , text
 
   other-modules:        Test.Analysis.CDF
+                        Test.Unlog.LogObjectDB
                         Test.Unlog.Org

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,28 @@ 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 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 +52,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
 
@@ -154,17 +155,50 @@ newtype CsvOutputFile
   = CsvOutputFile { unCsvOutputFile :: FilePath }
   deriving (Show, Eq)
 
+newtype SqliteOutputFile
+  = SqliteOutputFile { unSqliteOutputFile :: FilePath }
+  deriving (Show, Eq)
+
 newtype OutputFile
   = OutputFile { unOutputFile :: FilePath }
   deriving (Show, Eq)
 
+data LogObjectSource =
+    LogObjectSourceJSON   JsonLogfile
+  | LogObjectSourceSQLite FilePath
+  | LogObjectSourceOther  FilePath
+  deriving (Show, Eq, Generic, NFData)
+
+logObjectSourceFile :: LogObjectSource -> FilePath
+logObjectSourceFile = \case
+  LogObjectSourceJSON j   -> unJsonLogfile j
+  LogObjectSourceSQLite f -> f
+  LogObjectSourceOther f  -> f
+
+toLogObjectSource :: FilePath -> LogObjectSource
+toLogObjectSource fp
+  | ext == ".sqlite" || ext == ".sqlite3" = LogObjectSourceSQLite fp
+  | ext == ".json"                        = LogObjectSourceJSON (JsonLogfile fp)
+  | otherwise                             = LogObjectSourceOther fp
+  where
+    ext = map toLower $ F.takeExtension fp
+
+instance FromJSON LogObjectSource where
+  parseJSON = withText "LogObjectSource" (pure . toLogObjectSource . T.unpack)
+
+instance ToJSON LogObjectSource where
+  toJSON = toJSON . logObjectSourceFile
+
 ---
 --- Orphans
 ---
 deriving newtype instance Real      BlockNo
 deriving newtype instance Divisible BlockNo
+deriving         instance Data      BlockNo
+
 deriving newtype instance Real      SlotNo
 deriving newtype instance Divisible SlotNo
+deriving         instance Data      SlotNo
 
 ---
 --- Readers
@@ -202,6 +236,14 @@ optJsonLogfile optname desc =
       <> metavar "JSONLOGFILE"
       <> help desc
 
+optLogObjectSource :: String -> String -> Parser LogObjectSource
+optLogObjectSource optname desc =
+  fmap toLogObjectSource $
+    Opt.option Opt.str
+      $ long optname
+      <> metavar "JSONLOGFILE|SQLITE3LOGFILE"
+      <> help desc
+
 argJsonLogfile :: Parser JsonLogfile
 argJsonLogfile =
   JsonLogfile <$>
@@ -255,6 +297,14 @@ optCsvOutputFile optname desc =
       <> metavar "CSV-OUTFILE"
       <> help desc
 
+optSqliteOutputFile :: String -> String -> Parser SqliteOutputFile
+optSqliteOutputFile optname desc =
+  fmap SqliteOutputFile $
+    Opt.option Opt.str
+      $ long optname
+      <> metavar "SQLITE-OUTFILE"
+      <> help desc
+
 optOutputFile :: String -> String -> Parser OutputFile
 optOutputFile optname desc =
   fmap OutputFile $
@@ -279,6 +329,12 @@ optWord optname desc def =
     <> metavar "INT"
     <> help desc
     <> value def
+
+optString :: String -> String -> Parser String
+optString optname desc =
+  Opt.option Opt.str $
+    long optname <> metavar "STRING" <> Opt.help desc
+
 -- /path/to/logs-HOSTNAME.some.ext -> HOSTNAME
 hostFromLogfilename :: JsonLogfile -> Host
 hostFromLogfilename (JsonLogfile f) =
@@ -302,26 +358,26 @@ dumpObjects ident xs (JsonOutputFile f) = liftIO $ do
   withFile f WriteMode $ \hnd -> do
     forM_ xs $ LBS.hPutStrLn hnd . encode
 
-dumpAssociatedObjects :: ToJSON a => String -> [(JsonLogfile, a)] -> ExceptT Text IO ()
+dumpAssociatedObjects :: ToJSON a => String -> [(LogObjectSource, a)] -> ExceptT Text IO ()
 dumpAssociatedObjects ident xs = liftIO $
   flip mapConcurrently_ xs $
-    \(JsonLogfile f, x) ->
+    \(logObjectSourceFile -> f, x) ->
       withFile (replaceExtension f $ ident <> ".json") WriteMode $ \hnd ->
         LBS.hPutStrLn hnd $ encode x
 
 readAssociatedObjects :: forall a.
-  FromJSON a => String -> [JsonLogfile] -> ExceptT Text IO [(JsonLogfile, a)]
+  FromJSON a => String -> [JsonLogfile] -> ExceptT Text IO [(LogObjectSource, a)]
 readAssociatedObjects ident fs = firstExceptT T.pack . newExceptT . fmap (mapM sequence) $
   flip mapConcurrently fs $
     \jf@(JsonLogfile f) -> do
         x <- eitherDecode @a <$> LBS.readFile (replaceExtension f $ ident <> ".json")
         progress ident (Q f)
-        pure (jf, x)
+        pure (LogObjectSourceJSON jf, x)
 
-dumpAssociatedObjectStreams :: ToJSON a => String -> [(JsonLogfile, [a])] -> ExceptT Text IO ()
+dumpAssociatedObjectStreams :: ToJSON a => String -> [(LogObjectSource, [a])] -> ExceptT Text IO ()
 dumpAssociatedObjectStreams ident xss = liftIO $
   flip mapConcurrently_ xss $
-    \(JsonLogfile f, xs) -> do
+    \(logObjectSourceFile -> f, xs) -> do
       withFile (replaceExtension f $ ident <> ".json") WriteMode $ \hnd -> do
         forM_ xs $ LBS.hPutStrLn hnd . encode
 
@@ -331,9 +387,9 @@ dumpText ident xs (TextOutputFile f) = liftIO $ do
   withFile f WriteMode $ \hnd -> do
     forM_ xs $ hPutStrLn hnd
 
-dumpAssociatedTextStreams :: String -> [(JsonLogfile, [Text])] -> ExceptT Text IO ()
+dumpAssociatedTextStreams :: String -> [(LogObjectSource, [Text])] -> ExceptT Text IO ()
 dumpAssociatedTextStreams ident xss = liftIO $
   flip mapConcurrently_ xss $
-    \(JsonLogfile f, xs) -> do
+    \(logObjectSourceFile -> f, xs) -> do
       withFile (replaceExtension f $ ident <> ".txt") WriteMode $ \hnd -> do
         forM_ xs $ hPutStrLn hnd