{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE OverloadedStrings  #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

module Plutus.PAB.Core.Indexer.TxConfirmationStatus
  ( -- * TxConfirmationStatus
    TCSIndex
  , TxInfo(..)
  , Depth(..)
  , open
  , Ix.insert
  , Ix.rewind
  ) where

import Cardano.Api (SlotNo (SlotNo))
import Control.Applicative ((<|>))
import Control.Exception (SomeException, catch)
import Control.Lens.Operators ((^.))
import Data.Foldable (forM_)
import Data.Functor ((<&>))
import Data.List (find)
import Data.Maybe (fromJust)
import Data.Monoid (Last (Last), Sum (Sum))
import Data.String (fromString)
import Database.SQLite.Simple (Only (Only), SQLData (SQLText))
import Database.SQLite.Simple qualified as SQL
import Database.SQLite.Simple.FromField (FromField (fromField))
import Database.SQLite.Simple.FromRow (FromRow (fromRow), field)
import Database.SQLite.Simple.ToField (ToField (toField))
import Database.SQLite.Simple.ToRow (ToRow (toRow))
import GHC.Generics (Generic)
import Ledger (TxId)
import Plutus.ChainIndex.Types (BlockNumber (BlockNumber),
                                TxConfirmedState (TxConfirmedState, blockAdded, timesConfirmed, validity),
                                TxValidity (TxValid))

import Marconi.Core.Index.VSqlite (SqliteIndex)
import Marconi.Core.Index.VSqlite qualified as Ix

type Result = Maybe TxConfirmedState

data TxInfo = TxInfo
  { TxInfo -> TxId
txId        :: TxId
  , TxInfo -> BlockNumber
blockNumber :: BlockNumber
  , TxInfo -> SlotNo
slotNumber  :: SlotNo
  } deriving (TxInfo -> TxInfo -> Bool
(TxInfo -> TxInfo -> Bool)
-> (TxInfo -> TxInfo -> Bool) -> Eq TxInfo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TxInfo -> TxInfo -> Bool
$c/= :: TxInfo -> TxInfo -> Bool
== :: TxInfo -> TxInfo -> Bool
$c== :: TxInfo -> TxInfo -> Bool
Eq, Int -> TxInfo -> ShowS
[TxInfo] -> ShowS
TxInfo -> String
(Int -> TxInfo -> ShowS)
-> (TxInfo -> String) -> ([TxInfo] -> ShowS) -> Show TxInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TxInfo] -> ShowS
$cshowList :: [TxInfo] -> ShowS
show :: TxInfo -> String
$cshow :: TxInfo -> String
showsPrec :: Int -> TxInfo -> ShowS
$cshowsPrec :: Int -> TxInfo -> ShowS
Show, (forall x. TxInfo -> Rep TxInfo x)
-> (forall x. Rep TxInfo x -> TxInfo) -> Generic TxInfo
forall x. Rep TxInfo x -> TxInfo
forall x. TxInfo -> Rep TxInfo x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep TxInfo x -> TxInfo
$cfrom :: forall x. TxInfo -> Rep TxInfo x
Generic)

type TCSIndex = SqliteIndex Event () TxId Result
type Event = [TxInfo]

newtype Depth = Depth Int

instance FromField TxId where
  fromField :: FieldParser TxId
fromField Field
f = String -> TxId
forall a. IsString a => String -> a
fromString (String -> TxId) -> Ok String -> Ok TxId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FieldParser String
forall a. FromField a => FieldParser a
fromField Field
f

instance ToField TxId where
  toField :: TxId -> SQLData
toField = Text -> SQLData
SQLText (Text -> SQLData) -> (TxId -> Text) -> TxId -> SQLData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
forall a. IsString a => String -> a
fromString (String -> Text) -> (TxId -> String) -> TxId -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxId -> String
forall a. Show a => a -> String
show

deriving newtype instance FromField BlockNumber

deriving newtype instance ToField BlockNumber

deriving newtype instance FromField SlotNo

deriving newtype instance ToField SlotNo

instance ToRow TxInfo where
  toRow :: TxInfo -> [SQLData]
toRow TxInfo
t = [ TxId -> SQLData
forall a. ToField a => a -> SQLData
toField (TxId -> SQLData) -> TxId -> SQLData
forall a b. (a -> b) -> a -> b
$ TxInfo -> TxId
txId TxInfo
t
            , BlockNumber -> SQLData
forall a. ToField a => a -> SQLData
toField (BlockNumber -> SQLData) -> BlockNumber -> SQLData
forall a b. (a -> b) -> a -> b
$ TxInfo -> BlockNumber
blockNumber TxInfo
t
            , SlotNo -> SQLData
forall a. ToField a => a -> SQLData
toField (SlotNo -> SQLData) -> SlotNo -> SQLData
forall a b. (a -> b) -> a -> b
$ TxInfo -> SlotNo
slotNumber TxInfo
t
            ]

instance FromRow TxInfo where
  fromRow :: RowParser TxInfo
fromRow = TxId -> BlockNumber -> SlotNo -> TxInfo
TxInfo (TxId -> BlockNumber -> SlotNo -> TxInfo)
-> RowParser TxId -> RowParser (BlockNumber -> SlotNo -> TxInfo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RowParser TxId
forall a. FromField a => RowParser a
field RowParser (BlockNumber -> SlotNo -> TxInfo)
-> RowParser BlockNumber -> RowParser (SlotNo -> TxInfo)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> RowParser BlockNumber
forall a. FromField a => RowParser a
field RowParser (SlotNo -> TxInfo)
-> RowParser SlotNo -> RowParser TxInfo
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> RowParser SlotNo
forall a. FromField a => RowParser a
field

open
  :: FilePath
  -> Depth
  -> IO TCSIndex
open :: String -> Depth -> IO TCSIndex
open String
dbPath (Depth Int
k) = do
  TCSIndex
ix <- Maybe TCSIndex -> TCSIndex
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe TCSIndex -> TCSIndex) -> IO (Maybe TCSIndex) -> IO TCSIndex
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TCSIndex -> TxId -> [[TxInfo]] -> IO Result)
-> (TCSIndex -> IO ())
-> (TCSIndex -> [TxInfo] -> IO [()])
-> Int
-> Int
-> String
-> IO (Maybe TCSIndex)
forall e n q r.
(BoxedIndex e n q r -> q -> [e] -> IO r)
-> (BoxedIndex e n q r -> IO ())
-> (BoxedIndex e n q r -> e -> IO [n])
-> Int
-> Int
-> String
-> IO (Maybe (BoxedIndex e n q r))
Ix.newBoxed TCSIndex -> TxId -> [[TxInfo]] -> IO Result
query TCSIndex -> IO ()
store TCSIndex -> [TxInfo] -> IO [()]
onInsert Int
k ((Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2) String
dbPath
  let c :: Connection
c = TCSIndex
ix TCSIndex -> Getting Connection TCSIndex Connection -> Connection
forall s a. s -> Getting a s a -> a
^. Getting Connection TCSIndex Connection
forall (m :: * -> *) h (v :: * -> *) e n q r.
Lens' (SplitIndex m h v e n q r) h
Ix.handle
  Connection -> Query -> IO ()
SQL.execute_ Connection
c Query
"CREATE TABLE IF NOT EXISTS tx_status (txId TEXT NOT NULL PRIMARY KEY, blockNo INT NOT NULL, slotNo INT NOT NULL)"
  TCSIndex -> IO TCSIndex
forall (f :: * -> *) a. Applicative f => a -> f a
pure TCSIndex
ix

query
  :: TCSIndex
  -> TxId
  -> [Event]
  -> IO Result
query :: TCSIndex -> TxId -> [[TxInfo]] -> IO Result
query TCSIndex
ix TxId
txId' [[TxInfo]]
events = Result -> Result -> Result
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(<|>) (Result -> Result -> Result) -> IO Result -> IO (Result -> Result)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Result
searchInMemory
                            IO (Result -> Result) -> IO Result -> IO Result
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO Result
searchOnDisk
  where
    searchInMemory :: IO Result
    searchInMemory :: IO Result
searchInMemory = do
      [[TxInfo]]
buffered <- Storage Vector IO [TxInfo] -> IO [[TxInfo]]
forall (v :: * -> *) (m :: * -> *) e.
(MVector (Mutable v) e, PrimMonad m, Show e) =>
Storage v m e -> m [e]
Ix.getBuffer (Storage Vector IO [TxInfo] -> IO [[TxInfo]])
-> Storage Vector IO [TxInfo] -> IO [[TxInfo]]
forall a b. (a -> b) -> a -> b
$ TCSIndex
ix TCSIndex
-> Getting
     (Storage Vector IO [TxInfo]) TCSIndex (Storage Vector IO [TxInfo])
-> Storage Vector IO [TxInfo]
forall s a. s -> Getting a s a -> a
^. Getting
  (Storage Vector IO [TxInfo]) TCSIndex (Storage Vector IO [TxInfo])
forall (m :: * -> *) h (v :: * -> *) e n q r.
Lens' (SplitIndex m h v e n q r) (Storage v m e)
Ix.storage
      let event :: Maybe (Int, TxInfo)
event = ((Int, TxInfo) -> Bool) -> [(Int, TxInfo)] -> Maybe (Int, TxInfo)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\(Int
_, TxInfo
e) -> TxInfo -> TxId
txId TxInfo
e TxId -> TxId -> Bool
forall a. Eq a => a -> a -> Bool
== TxId
txId')
                ([(Int, TxInfo)] -> Maybe (Int, TxInfo))
-> [(Int, TxInfo)] -> Maybe (Int, TxInfo)
forall a b. (a -> b) -> a -> b
$ [Int] -> [TxInfo] -> [(Int, TxInfo)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1..] ([[TxInfo]] -> [TxInfo]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[TxInfo]] -> [TxInfo]) -> [[TxInfo]] -> [TxInfo]
forall a b. (a -> b) -> a -> b
$ [[TxInfo]]
events [[TxInfo]] -> [[TxInfo]] -> [[TxInfo]]
forall a. [a] -> [a] -> [a]
++ [[TxInfo]]
buffered)
      Result -> IO Result
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Result -> IO Result) -> Result -> IO Result
forall a b. (a -> b) -> a -> b
$ Maybe (Int, TxInfo)
event Maybe (Int, TxInfo)
-> ((Int, TxInfo) -> TxConfirmedState) -> Result
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \ (Int
cs, TxInfo TxId
_ BlockNumber
bn SlotNo
_) ->
        TxConfirmedState :: Sum Int -> Last BlockNumber -> Last TxValidity -> TxConfirmedState
TxConfirmedState { timesConfirmed :: Sum Int
timesConfirmed = Int -> Sum Int
forall a. a -> Sum a
Sum    Int
cs
                         , blockAdded :: Last BlockNumber
blockAdded     = Maybe BlockNumber -> Last BlockNumber
forall a. Maybe a -> Last a
Last (Maybe BlockNumber -> Last BlockNumber)
-> Maybe BlockNumber -> Last BlockNumber
forall a b. (a -> b) -> a -> b
$ BlockNumber -> Maybe BlockNumber
forall a. a -> Maybe a
Just BlockNumber
bn
                         , validity :: Last TxValidity
validity       = Maybe TxValidity -> Last TxValidity
forall a. Maybe a -> Last a
Last (Maybe TxValidity -> Last TxValidity)
-> Maybe TxValidity -> Last TxValidity
forall a b. (a -> b) -> a -> b
$ TxValidity -> Maybe TxValidity
forall a. a -> Maybe a
Just TxValidity
TxValid
                         }

    searchOnDisk :: IO Result
    searchOnDisk :: IO Result
searchOnDisk = do
      [TxInfo]
txStatus :: [TxInfo]
        <- Connection -> Query -> Only TxId -> IO [TxInfo]
forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
SQL.query (TCSIndex
ix TCSIndex -> Getting Connection TCSIndex Connection -> Connection
forall s a. s -> Getting a s a -> a
^. Getting Connection TCSIndex Connection
forall (m :: * -> *) h (v :: * -> *) e n q r.
Lens' (SplitIndex m h v e n q r) h
Ix.handle) Query
"SELECT txId, blockNo, slotNo FROM tx_status WHERE txId = ?" (TxId -> Only TxId
forall a. a -> Only a
Only TxId
txId')
      Result -> IO Result
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Result -> IO Result) -> Result -> IO Result
forall a b. (a -> b) -> a -> b
$ if [TxInfo] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TxInfo]
txStatus
              then Result
forall a. Maybe a
Nothing
              else let (TxInfo TxId
_ BlockNumber
bn SlotNo
_) = [TxInfo] -> TxInfo
forall a. [a] -> a
head [TxInfo]
txStatus
                   in TxConfirmedState -> Result
forall a. a -> Maybe a
Just (TxConfirmedState -> Result) -> TxConfirmedState -> Result
forall a b. (a -> b) -> a -> b
$
                        TxConfirmedState :: Sum Int -> Last BlockNumber -> Last TxValidity -> TxConfirmedState
TxConfirmedState { timesConfirmed :: Sum Int
timesConfirmed = Int -> Sum Int
forall a. a -> Sum a
Sum Int
0
                                         , blockAdded :: Last BlockNumber
blockAdded     = Maybe BlockNumber -> Last BlockNumber
forall a. Maybe a -> Last a
Last (Maybe BlockNumber -> Last BlockNumber)
-> Maybe BlockNumber -> Last BlockNumber
forall a b. (a -> b) -> a -> b
$ BlockNumber -> Maybe BlockNumber
forall a. a -> Maybe a
Just BlockNumber
bn
                                         , validity :: Last TxValidity
validity       = Maybe TxValidity -> Last TxValidity
forall a. Maybe a -> Last a
Last (Maybe TxValidity -> Last TxValidity)
-> Maybe TxValidity -> Last TxValidity
forall a b. (a -> b) -> a -> b
$ TxValidity -> Maybe TxValidity
forall a. a -> Maybe a
Just TxValidity
TxValid
                                         }

store :: TCSIndex -> IO ()
store :: TCSIndex -> IO ()
store TCSIndex
ix = do
  [[TxInfo]]
buffer <- Storage Vector IO [TxInfo] -> IO [[TxInfo]]
forall (v :: * -> *) (m :: * -> *) e.
(MVector (Mutable v) e, PrimMonad m, Show e) =>
Storage v m e -> m [e]
Ix.getBuffer (Storage Vector IO [TxInfo] -> IO [[TxInfo]])
-> Storage Vector IO [TxInfo] -> IO [[TxInfo]]
forall a b. (a -> b) -> a -> b
$ TCSIndex
ix TCSIndex
-> Getting
     (Storage Vector IO [TxInfo]) TCSIndex (Storage Vector IO [TxInfo])
-> Storage Vector IO [TxInfo]
forall s a. s -> Getting a s a -> a
^. Getting
  (Storage Vector IO [TxInfo]) TCSIndex (Storage Vector IO [TxInfo])
forall (m :: * -> *) h (v :: * -> *) e n q r.
Lens' (SplitIndex m h v e n q r) (Storage v m e)
Ix.storage
  let c :: Connection
c   = TCSIndex
ix TCSIndex -> Getting Connection TCSIndex Connection -> Connection
forall s a. s -> Getting a s a -> a
^. Getting Connection TCSIndex Connection
forall (m :: * -> *) h (v :: * -> *) e n q r.
Lens' (SplitIndex m h v e n q r) h
Ix.handle
  Connection -> Query -> IO ()
SQL.execute_ Connection
c Query
"BEGIN"
  [TxInfo] -> (TxInfo -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([[TxInfo]] -> [TxInfo]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[TxInfo]]
buffer) ((TxInfo -> IO ()) -> IO ()) -> (TxInfo -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \TxInfo
event -> do
    Connection -> Query -> TxInfo -> IO ()
forall q. ToRow q => Connection -> Query -> q -> IO ()
SQL.execute Connection
c Query
"INSERT INTO tx_status (txId, blockNo, slotNo) VALUES (?, ?, ?)" TxInfo
event IO () -> (SomeException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` (\SomeException
e -> String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"SQL Exception: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> TxId -> String
forall a. Show a => a -> String
show (TxInfo -> TxId
txId TxInfo
event) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> SomeException -> String
forall a. Show a => a -> String
show (SomeException
e :: SomeException))
  Connection -> Query -> IO ()
SQL.execute_ Connection
c Query
"COMMIT"

onInsert :: TCSIndex -> Event -> IO [()]
onInsert :: TCSIndex -> [TxInfo] -> IO [()]
onInsert TCSIndex
_ix [TxInfo]
_update = [()] -> IO [()]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []