Provide database-schema-specific logging types.

In response to review feedback: #2038 (comment)
cardano-foundation · Aug 19, 2020 · bcec1b9 · bcec1b9
1 parent cce4ad0
commit bcec1b9
Show file tree

Hide file tree

Showing 9 changed files with 173 additions and 60 deletions.
diff --git a/lib/core/src/Cardano/DB/Sqlite.hs b/lib/core/src/Cardano/DB/Sqlite.hs
@@ -9,6 +9,7 @@
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE UndecidableInstances #-}
@@ -23,7 +24,8 @@
 -- An implementation of the DBLayer which uses Persistent and SQLite.
 
 module Cardano.DB.Sqlite
-    ( SqliteContext (..)
+    ( Schema (..)
+    , SqliteContext (..)
     , chunkSize
     , dbChunked
     , destroyDBLayer
@@ -120,15 +122,19 @@ import qualified Database.Sqlite as Sqlite
                             Sqlite connection set up
 -------------------------------------------------------------------------------}
 
+-- | Provides types that are specific to a particular database schema.
+class Schema schema where
+    type SchemaSpecificLog schema
+
 -- | Context for the SQLite 'DBLayer'.
-data SqliteContext = SqliteContext
+data SqliteContext schema = SqliteContext
     { getSqlBackend :: SqlBackend
     -- ^ A handle to the Persistent SQL backend.
     , runQuery :: forall a. SqlPersistT IO a -> IO a
     -- ^ 'safely' run a query with logging and lock-protection
     , dbFile :: Maybe FilePath
     -- ^ The actual database file, if any. If none, runs in-memory
-    , trace :: Tracer IO DBLog
+    , trace :: Tracer IO (DBLog schema)
     -- ^ A 'Tracer' for logging
     }
 
@@ -142,10 +148,10 @@ instance Exception MigrationError
 -- | Run a raw query from the outside using an instantiate DB layer. This is
 -- completely unsafe because it breaks the abstraction boundary and can have
 -- disastrous results on the database consistency.
-unsafeRunQuery :: SqliteContext -> SqlPersistT IO a -> IO a
+unsafeRunQuery :: SqliteContext schema -> SqlPersistT IO a -> IO a
 unsafeRunQuery = runQuery
 
-queryLogFunc :: Tracer IO DBLog -> LogFunc
+queryLogFunc :: Tracer IO (DBLog schema) -> LogFunc
 queryLogFunc tr _loc _source level str = traceWith tr (MsgQuery msg sev)
   where
     -- Filter out parameters which appear after the statement semicolon.
@@ -176,7 +182,7 @@ handleConstraint e = handleJust select handler . fmap Right
 -- This function is idempotent: if the database connection has already been
 -- closed, calling this function will exit without doing anything.
 --
-destroyDBLayer :: SqliteContext -> IO ()
+destroyDBLayer :: SqliteContext schema -> IO ()
 destroyDBLayer (SqliteContext {getSqlBackend, trace, dbFile}) = do
     traceWith trace (MsgClosing dbFile)
     recovering pol [const $ Handler isBusy] (const $ close' getSqlBackend)
@@ -212,9 +218,9 @@ destroyDBLayer (SqliteContext {getSqlBackend, trace, dbFile}) = do
 startSqliteBackend
     :: ManualMigration
     -> Migration
-    -> Tracer IO DBLog
+    -> Tracer IO (DBLog schema)
     -> Maybe FilePath
-    -> IO (Either MigrationError SqliteContext)
+    -> IO (Either MigrationError (SqliteContext schema))
 startSqliteBackend manualMigration autoMigration tr fp = do
     (unsafeBackend, connection) <-
         createSqliteBackend tr fp manualMigration (queryLogFunc tr)
@@ -242,7 +248,7 @@ startSqliteBackend manualMigration autoMigration tr fp = do
 --   /temporarily disabled/, before re-enabling them.
 --
 withForeignKeysDisabled
-    :: Tracer IO DBLog
+    :: Tracer IO (DBLog schema)
     -> Sqlite.Connection
     -> IO a
     -> IO a
@@ -290,7 +296,7 @@ readForeignKeysSetting connection = do
 -- | Update the current value of the Sqlite 'foreign_keys' setting.
 --
 updateForeignKeysSetting
-    :: Tracer IO DBLog
+    :: Tracer IO (DBLog schema)
     -> Sqlite.Connection
     -> ForeignKeysSetting
     -> IO ()
@@ -339,7 +345,7 @@ newtype ManualMigration = ManualMigration
     { executeManualMigration :: Sqlite.Connection -> IO () }
 
 createSqliteBackend
-    :: Tracer IO DBLog
+    :: Tracer IO (DBLog schema)
     -> Maybe FilePath
     -> ManualMigration
     -> LogFunc
@@ -359,8 +365,9 @@ sqliteConnStr = maybe ":memory:" T.pack
                                     Logging
 -------------------------------------------------------------------------------}
 
-data DBLog
-    = MsgMigrations (Either MigrationError Int)
+data DBLog schema
+    = MsgSchemaSpecificLogEntry (SchemaSpecificLog schema)
+    | MsgMigrations (Either MigrationError Int)
     | MsgQuery Text Severity
     | MsgRun BracketLog
     | MsgConnStr Text
@@ -379,8 +386,11 @@ data DBLog
     | MsgUpdatingForeignKeysSetting ForeignKeysSetting
     | MsgFoundDatabase FilePath Text
     | MsgUnknownDBFile FilePath
-    deriving (Generic, Show, Eq, ToJSON)
+    deriving Generic
 
+deriving instance Eq (SchemaSpecificLog schema) => Eq (DBLog schema)
+deriving instance Show (SchemaSpecificLog schema) => Show (DBLog schema)
+deriving instance ToJSON (SchemaSpecificLog schema) => ToJSON (DBLog schema)
 
 {-------------------------------------------------------------------------------
                                     Logging
@@ -432,9 +442,13 @@ instance Eq DBField where
 instance ToJSON DBField where
     toJSON = Aeson.String . fieldName
 
-instance HasPrivacyAnnotation DBLog
-instance HasSeverityAnnotation DBLog where
+instance HasPrivacyAnnotation (DBLog schema)
+
+instance HasSeverityAnnotation (SchemaSpecificLog schema)
+    => HasSeverityAnnotation (DBLog schema)
+  where
     getSeverityAnnotation ev = case ev of
+        MsgSchemaSpecificLogEntry e -> getSeverityAnnotation e
         MsgMigrations (Right 0) -> Debug
         MsgMigrations (Right _) -> Notice
         MsgMigrations (Left _) -> Error
@@ -457,8 +471,11 @@ instance HasSeverityAnnotation DBLog where
         MsgFoundDatabase _ _ -> Info
         MsgUnknownDBFile _ -> Notice
 
-instance ToText DBLog where
+instance ToText (SchemaSpecificLog schema)
+    => ToText (DBLog schema)
+  where
     toText = \case
+        MsgSchemaSpecificLogEntry e -> toText e
         MsgMigrations (Right 0) ->
             "No database migrations were necessary."
         MsgMigrations (Right n) ->

diff --git a/lib/core/src/Cardano/Pool/DB/Sqlite.hs b/lib/core/src/Cardano/Pool/DB/Sqlite.hs
@@ -1,6 +1,9 @@
 {-# LANGUAGE AllowAmbiguousTypes #-}
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE EmptyCase #-}
+{-# LANGUAGE EmptyDataDeriving #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
@@ -27,15 +30,22 @@ module Cardano.Pool.DB.Sqlite
     , withDBLayer
     , defaultFilePath
     , DatabaseView (..)
+
+    -- * Schema-specific types
+    , PoolDb
+    , PoolDbLog
     ) where
 
 import Prelude
 
+import Cardano.BM.Data.Tracer
+    ( HasSeverityAnnotation (..) )
 import Cardano.DB.Sqlite
     ( DBField (..)
     , DBLog (..)
     , ManualMigration (..)
     , MigrationError (..)
+    , Schema (..)
     , SqliteContext (..)
     , destroyDBLayer
     , fieldName
@@ -61,6 +71,8 @@ import Cardano.Wallet.Primitive.Types
     )
 import Cardano.Wallet.Unsafe
     ( unsafeMkPercentage )
+import Control.DeepSeq
+    ( NFData )
 import Control.Exception
     ( bracket, throwIO )
 import Control.Monad
@@ -88,7 +100,7 @@ import Data.String.QQ
 import Data.Text
     ( Text )
 import Data.Text.Class
-    ( toText )
+    ( ToText (..), toText )
 import Data.Time.Clock
     ( UTCTime, addUTCTime, getCurrentTime )
 import Data.Word
@@ -113,6 +125,8 @@ import Database.Persist.Sql
     )
 import Database.Persist.Sqlite
     ( SqlPersistT )
+import GHC.Generics
+    ( Generic )
 import System.Directory
     ( removeFile )
 import System.FilePath
@@ -127,6 +141,22 @@ import qualified Data.Text as T
 import qualified Data.Text.Class as T
 import qualified Database.Sqlite as Sqlite
 
+{-------------------------------------------------------------------------------
+                                   DB Schema
+-------------------------------------------------------------------------------}
+
+data PoolDb
+    deriving (Eq, Generic, Show)
+
+instance NFData PoolDb
+
+instance Schema PoolDb where
+    type SchemaSpecificLog PoolDb = PoolDbLog
+
+{-------------------------------------------------------------------------------
+                                DB Construction
+-------------------------------------------------------------------------------}
+
 -- | Return the preferred @FilePath@ for the stake pool .sqlite file, given a
 -- parent directory.
 defaultFilePath
@@ -142,7 +172,7 @@ defaultFilePath = (</> "stake-pools.sqlite")
 -- If the given file path does not exist, it will be created by the sqlite
 -- library.
 withDBLayer
-    :: Tracer IO DBLog
+    :: Tracer IO (DBLog PoolDb)
        -- ^ Logging object
     -> Maybe FilePath
        -- ^ Database file location, or Nothing for in-memory database
@@ -168,12 +198,12 @@ withDBLayer trace fp timeInterpreter action = do
 -- should be closed with 'destroyDBLayer'. If you use 'withDBLayer' then both of
 -- these things will be handled for you.
 newDBLayer
-    :: Tracer IO DBLog
+    :: Tracer IO (DBLog PoolDb)
        -- ^ Logging object
     -> Maybe FilePath
        -- ^ Database file location, or Nothing for in-memory database
     -> TimeInterpreter IO
-    -> IO (SqliteContext, DBLayer IO)
+    -> IO (SqliteContext PoolDb, DBLayer IO)
 newDBLayer trace fp timeInterpreter = do
     let io = startSqliteBackend
             (migrateManually trace)
@@ -482,7 +512,7 @@ newDBLayer trace fp timeInterpreter = do
                 pure (cpt, cert)
 
 migrateManually
-    :: Tracer IO DBLog
+    :: Tracer IO (DBLog PoolDb)
     -> ManualMigration
 migrateManually _tr =
     ManualMigration $ \conn ->
@@ -558,7 +588,7 @@ activePoolRetirements = DatabaseView "active_pool_retirements" [s|
 -- with ugly work-around we can, at least for now, reset it semi-manually when
 -- needed to keep things tidy here.
 handlingPersistError
-    :: Tracer IO DBLog
+    :: Tracer IO (DBLog PoolDb)
        -- ^ Logging object
     -> Maybe FilePath
        -- ^ Database file location, or Nothing for in-memory database
@@ -669,3 +699,16 @@ fromPoolMeta meta = (poolMetadataHash meta,) $
         , description = poolMetadataDescription meta
         , homepage = poolMetadataHomepage meta
         }
+
+{-------------------------------------------------------------------------------
+                                 DB Logging
+-------------------------------------------------------------------------------}
+
+data PoolDbLog
+    deriving (Eq, Show)
+
+instance HasSeverityAnnotation PoolDbLog where
+    getSeverityAnnotation = \case {}
+
+instance ToText PoolDbLog where
+    toText = \case {}