ipedb (empty) → 0.1.0.0
raw patch · 12 files changed
+652/−0 lines, 12 filesdep +basedep +directorydep +filepath
Dependencies added: base, directory, filepath, ghc-events, ipedb, optparse-applicative, sqlite-simple, tasty, tasty-hunit, temporary, text
Files
- CHANGELOG.md +6/−0
- app/Main.hs +6/−0
- ipedb.cabal +86/−0
- src/IpeDb/Eventlog/Index.hs +148/−0
- src/IpeDb/InfoProv.hs +42/−0
- src/IpeDb/Main.hs +33/−0
- src/IpeDb/Options.hs +74/−0
- src/IpeDb/Query.hs +40/−0
- src/IpeDb/Table.hs +121/−0
- src/IpeDb/Types.hs +14/−0
- test/Main.hs +82/−0
- test/data/ipedb.eventlog too large to diff
+ CHANGELOG.md view
@@ -0,0 +1,6 @@+# Revision history for eventlog-splittable-ipe++## 0.1.0.0 -- 2026.03.02++* Allows to index and query `.eventlog` files+* First version. Released on an unsuspecting world.
+ app/Main.hs view
@@ -0,0 +1,6 @@+module Main (main) where++import IpeDb.Main (defaultMain)++main :: IO ()+main = defaultMain
+ ipedb.cabal view
@@ -0,0 +1,86 @@+cabal-version: 3.6+name: ipedb+version: 0.1.0.0+license: BSD-3-Clause+author: Hannes Siebenhandl, Matthew Pickering+synopsis: Generate a database for IPE data.+description: Tool and library to index an `.eventlog` file and query IPE data.+maintainer: hannes@well-typed.com+build-type: Simple+extra-doc-files: CHANGELOG.md+category: Development+tested-with:+ ghc ==9.10.3+ ghc ==9.12.2+ ghc ==9.14.1++extra-source-files:+ test/data/*.eventlog++common warnings+ ghc-options:+ -Wall+ -Wunused-packages++common defaults+ default-language: GHC2021+ default-extensions:+ BangPatterns+ DeriveAnyClass+ DeriveGeneric+ DerivingStrategies+ GeneralizedNewtypeDeriving+ LambdaCase+ NamedFieldPuns+ NoFieldSelectors+ OverloadedRecordDot+ TypeApplications++library+ import: warnings, defaults+ exposed-modules:+ IpeDb.Eventlog.Index+ IpeDb.InfoProv+ IpeDb.Main+ IpeDb.Options+ IpeDb.Query+ IpeDb.Table+ IpeDb.Types++ build-depends:+ base >=4.20 && <4.23,+ ghc-events >=0.18 && <0.22,+ optparse-applicative >=0.16.1 && <0.20,+ sqlite-simple ^>=0.4.19.0,+ text ^>=2.1.2,++ hs-source-dirs: src+ default-language: Haskell2010++executable ipedb+ import: warnings, defaults+ main-is: Main.hs+ build-depends:+ base >=4.20 && <4.23,+ ipedb,++ hs-source-dirs: app+ default-language: Haskell2010++test-suite ipedb-test+ import: warnings, defaults+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Main.hs+ build-depends:+ base >=4.20 && <4.23,+ directory >=1.3.8.5 && <1.4,+ filepath >=1.4.300.1 && <1.6,+ ipedb,+ tasty ^>=1.5.3,+ tasty-hunit ^>=0.10.2,+ temporary ^>=1.3,++source-repository head+ type: git+ location: https://github.com/well-typed/ipedb.git
+ src/IpeDb/Eventlog/Index.hs view
@@ -0,0 +1,148 @@+{-# LANGUAGE OverloadedStrings #-}++module IpeDb.Eventlog.Index (+ -- * High level API for interacting with the database+ withDatabase,+ generateInfoProvDb,+ findOneInfoProv,+ findAllInfoProvs,++ -- * Low level API for interacting with the database+ setupDb,+ setupTables,+ setupIndexing,+ insertInfoProv,+ upsertInfoProvStrings,++ -- * ghc-events specific helpers+ insertInfoProvData,+)+where++import Data.Foldable (traverse_)+import qualified Database.SQLite.Simple as Sqlite+import Database.SQLite.Simple.Types (Only (..))+import qualified GHC.RTS.Events as GhcEvents+import IpeDb.InfoProv as Ipe+import IpeDb.Table as Table+import Data.Text (Text)+import qualified Data.Text as Text++findOneInfoProv :: Sqlite.Connection -> IpeId -> IO (Maybe InfoProv)+findOneInfoProv conn ipeId = do+ r <- Sqlite.query conn findInfoTableQuery (Only ipeId)+ case r of+ [ipe] -> pure $ Just ipe+ _ -> pure $ Nothing++findAllInfoProvs :: Sqlite.Connection -> IO [InfoProv]+findAllInfoProvs conn = do+ Sqlite.query conn findAllInfoTablesQuery ()++generateInfoProvDb :: Sqlite.Connection -> FilePath -> IO ()+generateInfoProvDb conn fp = do+ setupDb conn+ GhcEvents.readEventLogFromFile fp >>= \case+ Left err -> fail err+ Right (GhcEvents.EventLog _h (GhcEvents.Data es)) -> Sqlite.withExclusiveTransaction conn $ do+ insertInfoProvData conn es++setupDb :: Sqlite.Connection -> IO ()+setupDb conn = do+ Sqlite.withExclusiveTransaction conn $ setupTables conn+ setupIndexing conn++withDatabase :: FilePath -> (Sqlite.Connection -> IO a) -> IO a+withDatabase fp act = Sqlite.withConnection fp $ \conn ->+ act conn++-- ----------------------------------------------------------------------------+-- Low Level Sqlite api+-- ----------------------------------------------------------------------------++setupTables :: Sqlite.Connection -> IO ()+setupTables conn = do+ Sqlite.execute_ conn dropStringTableStmt+ Sqlite.execute_ conn dropInfoProvTableStmt+ Sqlite.execute_ conn dropInfoProvTableViewStmt+ Sqlite.execute_ conn stringTableStmt+ Sqlite.execute_ conn infoProvTableStmt+ Sqlite.execute_ conn infoProvTableViewStmt++setupIndexing :: Sqlite.Connection -> IO ()+setupIndexing conn = do+ Sqlite.execute_ conn "PRAGMA synchronous = OFF;"+ Sqlite.execute_ conn "PRAGMA journal_mode = OFF;"+ Sqlite.execute_ conn "PRAGMA temp_store = MEMORY;"+ Sqlite.execute_ conn "PRAGMA locking_mode = EXCLUSIVE;"++insertInfoProv :: Sqlite.Connection -> InfoProv -> IO ()+insertInfoProv conn prov = do+ row <- upsertInfoProvStrings conn prov+ _ <- Sqlite.execute conn insertInfoTableQuery row+ pure ()++upsertInfoProvStrings :: Sqlite.Connection -> InfoProv -> IO InfoProvRow+upsertInfoProvStrings conn prov = do+ let+ (srcLocFile, srcLocRange) = splitGhcSrcLoc prov.srcLoc+ Sqlite.executeMany+ conn+ insertOrIgnoreString+ [ Only prov.tableName+ , Only prov.typeDesc+ , Only prov.label+ , Only prov.moduleName+ , Only srcLocFile+ ]+ [(taId, tyId, labelId, modId, srcLocId)] <-+ Sqlite.query+ conn+ getIpeStrings+ ( prov.typeDesc+ , prov.label+ , prov.moduleName+ , srcLocFile+ , prov.tableName+ )+ pure+ InfoProvRow+ { Table.infoId = prov.infoId+ , Table.tableName = taId+ , Table.closureDesc = prov.closureDesc+ , Table.typeDesc = tyId+ , Table.label = labelId+ , Table.moduleName = modId+ , Table.srcLoc = srcLocId+ , Table.srcLocRange = srcLocRange+ }++splitGhcSrcLoc :: Text -> (Text, Text)+splitGhcSrcLoc srcLoc = Text.break (== ':') srcLoc++-- ----------------------------------------------------------------------------+-- Eventlog processing+-- ----------------------------------------------------------------------------++insertInfoProvData :: (Foldable t) => Sqlite.Connection -> t GhcEvents.Event -> IO ()+insertInfoProvData conn es = traverse_ (processIpeEvents conn) es++processIpeEvents :: Sqlite.Connection -> GhcEvents.Event -> IO ()+processIpeEvents conn ev = case eventInfoToInfoProv (GhcEvents.evSpec ev) of+ Nothing -> pure ()+ Just infoProv -> insertInfoProv conn infoProv++eventInfoToInfoProv :: GhcEvents.EventInfo -> Maybe InfoProv+eventInfoToInfoProv ev = case ev of+ it@GhcEvents.InfoTableProv{} ->+ Just+ InfoProv+ { Ipe.infoId = IpeId $ GhcEvents.itInfo it+ , Ipe.tableName = GhcEvents.itTableName it+ , Ipe.closureDesc = fromIntegral $ GhcEvents.itClosureDesc it+ , Ipe.typeDesc = GhcEvents.itTyDesc it+ , Ipe.label = GhcEvents.itLabel it+ , Ipe.moduleName = GhcEvents.itModule it+ , Ipe.srcLoc = GhcEvents.itSrcLoc it+ }+ _ -> Nothing
+ src/IpeDb/InfoProv.hs view
@@ -0,0 +1,42 @@+module IpeDb.InfoProv (+ InfoProv (..),+ IpeId (..),+ prettyIpeId,+) where++import Data.Int+import Data.Text (Text)+import qualified Data.Text as Text+import Data.Word+import qualified Database.SQLite.Simple as Sqlite+import qualified Database.SQLite.Simple.FromField as Sqlite+import qualified Database.SQLite.Simple.ToField as Sqlite+import GHC.Generics (Generic)+import qualified Numeric++data InfoProv = InfoProv+ { infoId :: !IpeId+ , tableName :: !Text+ , closureDesc :: !Int64+ , typeDesc :: !Text+ , label :: !Text+ , moduleName :: !Text+ , srcLoc :: !Text+ }+ deriving (Show, Eq, Ord, Generic)+ deriving anyclass (Sqlite.FromRow, Sqlite.ToRow)++newtype IpeId = IpeId+ { id :: Word64+ }+ deriving (Eq, Ord)+ deriving newtype (Sqlite.FromField, Sqlite.ToField)++instance Show IpeId where+ show ipeId = "IpeId {id = " <> showAsHex (ipeId.id) <> "}"++showAsHex :: (Integral a) => a -> String+showAsHex n = "0x" <> Numeric.showHex n ""++prettyIpeId :: IpeId -> Text+prettyIpeId = Text.pack . showAsHex . (.id)
+ src/IpeDb/Main.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE OverloadedStrings #-}++module IpeDb.Main (defaultMain) where++import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.IO as Text+import IpeDb.InfoProv+import qualified IpeDb.Options as Opts+import IpeDb.Query++defaultMain :: IO ()+defaultMain = do+ opts <- Opts.parseOptions+ case opts.command of+ Opts.Query query -> withInfoProvDb opts.databaseFp $ \db -> do+ lookupInfoProv db query.ipeId >>= \case+ Nothing -> Text.putStrLn $ "No Info Prov found for " <> Text.show query.ipeId+ Just prov -> Text.putStrLn $ prettyInfoProv prov+ Opts.Index index -> withInfoProvDb opts.databaseFp $ \db -> do+ populateFromEventlog db index.eventlog++prettyInfoProv :: InfoProv -> Text+prettyInfoProv prov =+ Text.unlines+ [ "Info Table " <> prettyIpeId prov.infoId+ , " Table Name: " <> prov.tableName+ , " Closure Desc: " <> Text.show prov.closureDesc+ , " Type Desc: " <> prov.typeDesc+ , " Label: " <> prov.label+ , " Modulename: " <> prov.moduleName+ , " Source Location: " <> prov.srcLoc+ ]
+ src/IpeDb/Options.hs view
@@ -0,0 +1,74 @@+module IpeDb.Options (+ Options (..),+ Command (..),+ IndexOptions (..),+ QueryOptions (..),+ parseOptions,+ options,+ commands,+ queryCommand,+ indexCommand,+) where++import IpeDb.InfoProv (IpeId (..))+import Options.Applicative++data Options = Options+ { databaseFp :: FilePath+ , command :: Command+ }+ deriving (Show, Eq, Ord)++data Command+ = Index IndexOptions+ | Query QueryOptions+ deriving (Show, Eq, Ord)++data IndexOptions = IndexOptions+ { eventlog :: FilePath+ }+ deriving (Show, Eq, Ord)++data QueryOptions = QueryOptions+ { ipeId :: IpeId+ }+ deriving (Show, Eq, Ord)++parseOptions :: IO Options+parseOptions = execParser opts+ where+ opts =+ info+ (options <**> helper)+ ( fullDesc+ <> progDesc "Index for Info Provenance entries"+ <> header "ipedb - A database for info provenance entries"+ )++options :: Parser Options+options =+ Options+ <$> strArgument+ ( metavar "FILENAME"+ <> help "Database location"+ )+ <*> commands++commands :: Parser Command+commands =+ hsubparser+ ( command "index" (info (Index <$> indexCommand) (progDesc "Add a file to the repository"))+ <> command "query" (info (Query <$> queryCommand) (progDesc "Add a file to the repository"))+ )++queryCommand :: Parser QueryOptions+queryCommand =+ QueryOptions+ <$> ( IpeId+ <$> argument auto (help "Find the info table provenance information for the given key" <> metavar "INT")+ )++indexCommand :: Parser IndexOptions+indexCommand =+ IndexOptions+ <$> strArgument (help "Eventlog location to index" <> metavar "FILENAME")
+ src/IpeDb/Query.hs view
@@ -0,0 +1,40 @@+module IpeDb.Query (+ withInfoProvDb,+ setupInfoProvDb,+ populateFromEventlog,+ lookupInfoProv,+ insertInfoProv,+ listInfoProvs,+) where++import qualified IpeDb.Eventlog.Index as Index+import IpeDb.InfoProv+import IpeDb.Types++-- ----------------------------------------------------------------------------+-- High Level API+-- ----------------------------------------------------------------------------++withInfoProvDb :: FilePath -> (InfoProvDb -> IO a) -> IO a+withInfoProvDb fp act =+ Index.withDatabase fp (\conn -> act InfoProvDb{conn})++setupInfoProvDb :: InfoProvDb -> IO ()+setupInfoProvDb db =+ Index.setupDb db.conn++populateFromEventlog :: InfoProvDb -> FilePath -> IO ()+populateFromEventlog db fp =+ Index.generateInfoProvDb db.conn fp++lookupInfoProv :: InfoProvDb -> IpeId -> IO (Maybe InfoProv)+lookupInfoProv db ipeId = do+ Index.findOneInfoProv db.conn ipeId++insertInfoProv :: InfoProvDb -> InfoProv -> IO ()+insertInfoProv db ipe = do+ Index.insertInfoProv db.conn ipe++listInfoProvs :: InfoProvDb -> IO [InfoProv]+listInfoProvs db = do+ Index.findAllInfoProvs db.conn
+ src/IpeDb/Table.hs view
@@ -0,0 +1,121 @@+{-# LANGUAGE OverloadedStrings #-}++module IpeDb.Table (+ InfoProvRow (..),+ dropStringTableStmt,+ dropInfoProvTableStmt,+ dropInfoProvTableViewStmt,+ stringTableStmt,+ infoProvTableStmt,+ infoProvTableViewStmt,+ findInfoTableQuery,+ findAllInfoTablesQuery,+ insertInfoTableQuery,+ insertOrIgnoreString,+ getStringEntry,+ getIpeStrings,+) where++import Data.Int+import qualified Database.SQLite.Simple as Sqlite+import IpeDb.InfoProv+import GHC.Generics (Generic)+import Data.Text (Text)++data InfoProvRow = InfoProvRow+ { infoId :: !IpeId+ , tableName :: !Int64+ , closureDesc :: !Int64+ , typeDesc :: !Int64+ , label :: !Int64+ , moduleName :: !Int64+ , srcLoc :: !Int64+ , srcLocRange :: !Text+ }+ deriving (Show, Eq, Ord, Generic)+ deriving anyclass (Sqlite.FromRow, Sqlite.ToRow)++dropStringTableStmt :: Sqlite.Query+dropStringTableStmt = "DROP TABLE IF EXISTS strings;"++dropInfoProvTableStmt :: Sqlite.Query+dropInfoProvTableStmt = "DROP TABLE IF EXISTS info_prov;"++dropInfoProvTableViewStmt :: Sqlite.Query+dropInfoProvTableViewStmt = "DROP VIEW IF EXISTS view_info_prov;"++stringTableStmt :: Sqlite.Query+stringTableStmt =+ "\+ \ CREATE TABLE strings ( \+ \ id INTEGER PRIMARY KEY, \+ \ value TEXT NOT NULL UNIQUE \+ \);"++infoProvTableStmt :: Sqlite.Query+infoProvTableStmt =+ "\+ \ CREATE TABLE info_prov ( \+ \ info_id INTEGER PRIMARY KEY, \+ \ table_name INTEGER NOT NULL REFERENCES strings(id),\+ \ closure_desc INTEGER NOT NULL, \+ \ type_desc INTEGER NOT NULL REFERENCES strings(id),\+ \ label INTEGER NOT NULL REFERENCES strings(id),\+ \ module_name INTEGER NOT NULL REFERENCES strings(id),\+ \ src_loc INTEGER NOT NULL REFERENCES strings(id),\+ \ src_loc_range TEXT NOT NULL \+ \);"++infoProvTableViewStmt :: Sqlite.Query+infoProvTableViewStmt =+ "\+ \ CREATE VIEW view_info_prov AS \+ \ SELECT \+ \ i.info_id, \+ \ table_name.value AS table_name, \+ \ i.closure_desc, \+ \ type_desc.value AS type_desc, \+ \ label.value AS label, \+ \ module_name.value AS module_name, \+ \ concat(src_loc.value, i.src_loc_range) AS src_loc \+ \ FROM info_prov i \+ \ JOIN strings AS table_name ON i.table_name = table_name.id \+ \ JOIN strings AS type_desc ON i.type_desc = type_desc.id \+ \ JOIN strings AS label ON i.label = label.id \+ \ JOIN strings AS module_name ON i.module_name = module_name.id \+ \ JOIN strings AS src_loc ON i.src_loc = src_loc.id;"++findInfoTableQuery :: Sqlite.Query+findInfoTableQuery = "SELECT * FROM view_info_prov WHERE info_id = ?;"++findAllInfoTablesQuery :: Sqlite.Query+findAllInfoTablesQuery = "SELECT * FROM view_info_prov;"++insertInfoTableQuery :: Sqlite.Query+insertInfoTableQuery =+ "\+ \ INSERT INTO info_prov\+ \ (info_id, table_name, closure_desc, type_desc, label, module_name, src_loc, src_loc_range)\+ \ VALUES (?, ?, ?, ?, ?, ?, ?, ?);"++insertOrIgnoreString :: Sqlite.Query+insertOrIgnoreString = "INSERT OR IGNORE INTO strings(value) VALUES (?);"++getIpeStrings :: Sqlite.Query+getIpeStrings =+ "\+ \ SELECT \+ \ table_name.id AS table_name, \+ \ type_desc.id AS type_desc, \+ \ label.id AS label, \+ \ module_name.id AS module_name, \+ \ src_loc.id AS src_loc \+ \ FROM strings AS table_name \+ \ JOIN strings AS type_desc ON ? = type_desc.value \+ \ JOIN strings AS label ON ? = label.value \+ \ JOIN strings AS module_name ON ? = module_name.value \+ \ JOIN strings AS src_loc ON ? = src_loc.value \+ \ WHERE ? = table_name.value ;"++getStringEntry :: Sqlite.Query+getStringEntry = "SELECT id, value FROM strings WHERE value = ?;"
+ src/IpeDb/Types.hs view
@@ -0,0 +1,14 @@+module IpeDb.Types+ ( InfoProvDb (..),+ )+where++import qualified Database.SQLite.Simple as Sqlite++-- ----------------------------------------------------------------------------+-- Db type+-- ----------------------------------------------------------------------------++data InfoProvDb = InfoProvDb+ { conn :: Sqlite.Connection+ }
+ test/Main.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE OverloadedStrings #-}++module Main (main) where++import IpeDb.InfoProv+import IpeDb.Query qualified as Query+import System.Directory (doesFileExist)+import System.FilePath+import System.IO.Temp+import Test.Tasty+import Test.Tasty.HUnit++main :: IO ()+main = defaultMain tests++testdataDir :: FilePath+testdataDir = "test" </> "data"++tests :: TestTree+tests =+ testGroup+ "ipedb"+ [ integrationTests+ ]++integrationTests :: TestTree+integrationTests =+ testGroup+ "integration"+ [ testGroup+ "index"+ [ testCase "ipedb.eventlog" $+ withSystemTempDirectory "ipedb" $ \tempDir -> do+ let+ db_loc = tempDir </> "ipedb.db"+ eventlog_log = testdataDir </> "ipedb.eventlog"++ exists_start <- doesFileExist db_loc+ assertBool "Database must not exist before generating it" (not exists_start)++ Query.withInfoProvDb db_loc $ \db ->+ Query.populateFromEventlog db eventlog_log++ exists <- doesFileExist db_loc+ assertBool "Database exists after generating it" exists+ ]+ , testGroup+ "query"+ [ testCase "can insert and find info prov" $+ withSystemTempDirectory "ipedb" $ \tempDir -> do+ let+ db_loc = tempDir </> "ipedb.db"++ Query.withInfoProvDb db_loc $ \db -> do+ Query.setupInfoProvDb db+ let+ dummyIpe =+ InfoProv+ { infoId = IpeId 0xdeadb33f+ , tableName = "DummyInfo"+ , closureDesc = 42+ , typeDesc = "Dummy"+ , label = "This is a dummy IPE info"+ , moduleName = "Dummy"+ , srcLoc = "Dummy.hs:45"+ }+ Query.insertInfoProv db dummyIpe+ ipe <- Query.lookupInfoProv db dummyIpe.infoId++ ipe @?= Just dummyIpe+ , testCase "list ipedb.eventlog info provs" $+ withSystemTempDirectory "ipedb" $ \tempDir -> do+ let+ db_loc = tempDir </> "ipedb.db"+ eventlog_log = testdataDir </> "ipedb.eventlog"+ Query.withInfoProvDb db_loc $ \db -> do+ Query.populateFromEventlog db eventlog_log+ info_provs <- Query.listInfoProvs db++ assertBool "There must be at least 500 info provs in the table" (length info_provs > 500)+ ]+ ]
+ test/data/ipedb.eventlog view
file too large to diff