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

module Marconi.Index.Datum
  ( -- * DatumIndex
    DatumIndex
  , Event
  , Query
  , Result
  , Notification
  , Depth(..)
  , open
  ) where

import Codec.Serialise (Serialise (encode), deserialiseOrFail, serialise)
import Control.Applicative ((<|>))
import Control.Lens.Operators ((^.))
import Data.ByteString.Lazy (toStrict)
import Data.Foldable (find)
import Data.Maybe (fromJust, listToMaybe)
import Database.SQLite.Simple (Only (Only), SQLData (SQLBlob, SQLInteger))
import Database.SQLite.Simple qualified as SQL
import Database.SQLite.Simple.FromField (FromField (fromField), ResultError (ConversionFailed), returnError)
import Database.SQLite.Simple.ToField (ToField (toField))

import Cardano.Api qualified as C
import Cardano.Binary (fromCBOR, toCBOR)
import Codec.Serialise.Class (Serialise (decode))
import RewindableIndex.Index.VSqlite (SqliteIndex)
import RewindableIndex.Index.VSqlite qualified as Ix

type DatumHash    = C.Hash C.ScriptData
type Event        = [(C.SlotNo, (DatumHash, C.ScriptData))]
type Query        = DatumHash
type Result       = Maybe C.ScriptData
type Notification = ()

type DatumIndex = SqliteIndex Event Notification Query Result

newtype Depth = Depth Int

instance FromField DatumHash where
  fromField :: FieldParser DatumHash
fromField Field
f = FieldParser ByteString
forall a. FromField a => FieldParser a
fromField Field
f Ok ByteString -> (ByteString -> Ok DatumHash) -> Ok DatumHash
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
    Ok DatumHash
-> (DatumHash -> Ok DatumHash) -> Maybe DatumHash -> Ok DatumHash
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ((String -> String -> String -> ResultError)
-> Field -> String -> Ok DatumHash
forall a err.
(Typeable a, Exception err) =>
(String -> String -> String -> err) -> Field -> String -> Ok a
returnError String -> String -> String -> ResultError
ConversionFailed Field
f String
"Cannot deserialise datumhash.")
           DatumHash -> Ok DatumHash
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    (Maybe DatumHash -> Ok DatumHash)
-> (ByteString -> Maybe DatumHash) -> ByteString -> Ok DatumHash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AsType DatumHash -> ByteString -> Maybe DatumHash
forall a.
SerialiseAsRawBytes a =>
AsType a -> ByteString -> Maybe a
C.deserialiseFromRawBytes (AsType ScriptData -> AsType DatumHash
forall a. AsType a -> AsType (Hash a)
C.AsHash AsType ScriptData
C.AsScriptData)

instance ToField DatumHash where
  toField :: DatumHash -> SQLData
toField = ByteString -> SQLData
SQLBlob (ByteString -> SQLData)
-> (DatumHash -> ByteString) -> DatumHash -> SQLData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DatumHash -> ByteString
forall a. SerialiseAsRawBytes a => a -> ByteString
C.serialiseToRawBytes

instance Serialise C.ScriptData where
  encode :: ScriptData -> Encoding
encode = ScriptData -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR
  decode :: Decoder s ScriptData
decode = Decoder s ScriptData
forall a s. FromCBOR a => Decoder s a
fromCBOR

instance FromField C.ScriptData where
  fromField :: FieldParser ScriptData
fromField Field
f = FieldParser ByteString
forall a. FromField a => FieldParser a
fromField Field
f Ok ByteString -> (ByteString -> Ok ScriptData) -> Ok ScriptData
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
    (DeserialiseFailure -> Ok ScriptData)
-> (ScriptData -> Ok ScriptData)
-> Either DeserialiseFailure ScriptData
-> Ok ScriptData
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Ok ScriptData -> DeserialiseFailure -> Ok ScriptData
forall a b. a -> b -> a
const (Ok ScriptData -> DeserialiseFailure -> Ok ScriptData)
-> Ok ScriptData -> DeserialiseFailure -> Ok ScriptData
forall a b. (a -> b) -> a -> b
$ (String -> String -> String -> ResultError)
-> Field -> String -> Ok ScriptData
forall a err.
(Typeable a, Exception err) =>
(String -> String -> String -> err) -> Field -> String -> Ok a
returnError String -> String -> String -> ResultError
ConversionFailed Field
f String
"Cannot deserialise datumhash.") ScriptData -> Ok ScriptData
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    (Either DeserialiseFailure ScriptData -> Ok ScriptData)
-> (ByteString -> Either DeserialiseFailure ScriptData)
-> ByteString
-> Ok ScriptData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either DeserialiseFailure ScriptData
forall a. Serialise a => ByteString -> Either DeserialiseFailure a
deserialiseOrFail

instance ToField C.ScriptData where
  toField :: ScriptData -> SQLData
toField = ByteString -> SQLData
SQLBlob (ByteString -> SQLData)
-> (ScriptData -> ByteString) -> ScriptData -> SQLData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
toStrict (ByteString -> ByteString)
-> (ScriptData -> ByteString) -> ScriptData -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScriptData -> ByteString
forall a. Serialise a => a -> ByteString
serialise

instance FromField C.SlotNo where
  fromField :: FieldParser SlotNo
fromField Field
f = Word64 -> SlotNo
C.SlotNo (Word64 -> SlotNo) -> Ok Word64 -> Ok SlotNo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FieldParser Word64
forall a. FromField a => FieldParser a
fromField Field
f

instance ToField C.SlotNo where
  toField :: SlotNo -> SQLData
toField (C.SlotNo Word64
s) = Int64 -> SQLData
SQLInteger (Int64 -> SQLData) -> Int64 -> SQLData
forall a b. (a -> b) -> a -> b
$ Word64 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
s

open
  :: FilePath
  -> Depth
  -> IO DatumIndex
open :: String -> Depth -> IO DatumIndex
open String
dbPath (Depth Int
k) = do
  DatumIndex
ix <- Maybe DatumIndex -> DatumIndex
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe DatumIndex -> DatumIndex)
-> IO (Maybe DatumIndex) -> IO DatumIndex
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (DatumIndex -> DatumHash -> [Event] -> IO Result)
-> (DatumIndex -> IO ())
-> (DatumIndex -> Event -> IO [()])
-> Int
-> Int
-> String
-> IO (Maybe DatumIndex)
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 DatumIndex -> DatumHash -> [Event] -> IO Result
query DatumIndex -> IO ()
store DatumIndex -> Event -> 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 = DatumIndex
ix DatumIndex
-> Getting Connection DatumIndex Connection -> Connection
forall s a. s -> Getting a s a -> a
^. Getting Connection DatumIndex 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 kv_datumhsh_datum (datumHash TEXT PRIMARY KEY, datum BLOB, slotNo INT)"
  DatumIndex -> IO DatumIndex
forall (f :: * -> *) a. Applicative f => a -> f a
pure DatumIndex
ix

-- | This function is used to query the data stored in the indexer as a whole:
--   data that can still change (through rollbacks), buffered data and stored data.
--
--   Here is a query that takes into account all received events:
--   > getEvents (ix ^. storage) >>= query ix <hash>
--
--   Here is a query that only takes into account stored events:
--   > query ix <hash> []
query
  :: DatumIndex -- ^ The indexer
  -> Query      -- ^ The query is a `DatumHash`
  -> [Event]    -- ^ The list of events that we want to query on top of whatever is settled.
  -> IO Result  -- ^ The result is an optional datum.
query :: DatumIndex -> DatumHash -> [Event] -> IO Result
query DatumIndex
ix DatumHash
hsh [Event]
es = IO Result
memoryResult IO Result -> IO Result -> IO Result
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> IO Result
sqliteResult
  where
    -- TODO: Consider buffered events
    memoryResult :: IO Result
    memoryResult :: IO Result
memoryResult = do
      [Event]
bufferedEvents <- Storage Vector IO Event -> IO [Event]
forall (v :: * -> *) (m :: * -> *) e.
(MVector (Mutable v) e, PrimMonad m, Show e) =>
Storage v m e -> m [e]
Ix.getBuffer (DatumIndex
ix DatumIndex
-> Getting
     (Storage Vector IO Event) DatumIndex (Storage Vector IO Event)
-> Storage Vector IO Event
forall s a. s -> Getting a s a -> a
^. Getting
  (Storage Vector IO Event) DatumIndex (Storage Vector IO Event)
forall (m :: * -> *) h (v :: * -> *) e n q r.
Lens' (SplitIndex m h v e n q r) (Storage v m e)
Ix.storage)
      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
$ (DatumHash, ScriptData) -> ScriptData
forall a b. (a, b) -> b
snd ((DatumHash, ScriptData) -> ScriptData)
-> ((SlotNo, (DatumHash, ScriptData)) -> (DatumHash, ScriptData))
-> (SlotNo, (DatumHash, ScriptData))
-> ScriptData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SlotNo, (DatumHash, ScriptData)) -> (DatumHash, ScriptData)
forall a b. (a, b) -> b
snd ((SlotNo, (DatumHash, ScriptData)) -> ScriptData)
-> Maybe (SlotNo, (DatumHash, ScriptData)) -> Result
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((SlotNo, (DatumHash, ScriptData)) -> Bool)
-> Event -> Maybe (SlotNo, (DatumHash, ScriptData))
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((DatumHash -> DatumHash -> Bool
forall a. Eq a => a -> a -> Bool
== DatumHash
hsh) (DatumHash -> Bool)
-> ((SlotNo, (DatumHash, ScriptData)) -> DatumHash)
-> (SlotNo, (DatumHash, ScriptData))
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DatumHash, ScriptData) -> DatumHash
forall a b. (a, b) -> a
fst ((DatumHash, ScriptData) -> DatumHash)
-> ((SlotNo, (DatumHash, ScriptData)) -> (DatumHash, ScriptData))
-> (SlotNo, (DatumHash, ScriptData))
-> DatumHash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SlotNo, (DatumHash, ScriptData)) -> (DatumHash, ScriptData)
forall a b. (a, b) -> b
snd) ([Event] -> Event
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([Event] -> Event) -> [Event] -> Event
forall a b. (a -> b) -> a -> b
$ [Event]
es [Event] -> [Event] -> [Event]
forall a. [a] -> [a] -> [a]
++ [Event]
bufferedEvents)
    sqliteResult :: IO Result
    sqliteResult :: IO Result
sqliteResult = do
      [[ScriptData]]
result <- Connection -> Query -> Only DatumHash -> IO [[ScriptData]]
forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
SQL.query (DatumIndex
ix DatumIndex
-> Getting Connection DatumIndex Connection -> Connection
forall s a. s -> Getting a s a -> a
^. Getting Connection DatumIndex Connection
forall (m :: * -> *) h (v :: * -> *) e n q r.
Lens' (SplitIndex m h v e n q r) h
Ix.handle) Query
"SELECT datum from kv_datumhsh_datum WHERE datumHash = ?" (DatumHash -> Only DatumHash
forall a. a -> Only a
Only DatumHash
hsh)
      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
$ [ScriptData] -> ScriptData
forall a. [a] -> a
head ([ScriptData] -> ScriptData) -> Maybe [ScriptData] -> Result
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[ScriptData]] -> Maybe [ScriptData]
forall a. [a] -> Maybe a
listToMaybe [[ScriptData]]
result

store :: DatumIndex -> IO ()
store :: DatumIndex -> IO ()
store DatumIndex
ix = do
  let c :: Connection
c = DatumIndex
ix DatumIndex
-> Getting Connection DatumIndex Connection -> Connection
forall s a. s -> Getting a s a -> a
^. Getting Connection DatumIndex 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"
  Storage Vector IO Event -> IO [Event]
forall (v :: * -> *) (m :: * -> *) e.
(MVector (Mutable v) e, PrimMonad m, Show e) =>
Storage v m e -> m [e]
Ix.getBuffer (DatumIndex
ix DatumIndex
-> Getting
     (Storage Vector IO Event) DatumIndex (Storage Vector IO Event)
-> Storage Vector IO Event
forall s a. s -> Getting a s a -> a
^. Getting
  (Storage Vector IO Event) DatumIndex (Storage Vector IO Event)
forall (m :: * -> *) h (v :: * -> *) e n q r.
Lens' (SplitIndex m h v e n q r) (Storage v m e)
Ix.storage) IO [Event] -> ([Event] -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
    ((SlotNo, (DatumHash, ScriptData)) -> IO ()) -> Event -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ( Connection
-> Query -> (SlotNo, DatumHash, ScriptData, SlotNo) -> IO ()
forall q. ToRow q => Connection -> Query -> q -> IO ()
SQL.execute Connection
c Query
"INSERT INTO kv_datumhsh_datum (slotNo, datumHash, datum) VALUES (?,?,?) ON CONFLICT(datumHash) DO UPDATE SET slotNo = ?"
          ((SlotNo, DatumHash, ScriptData, SlotNo) -> IO ())
-> ((SlotNo, (DatumHash, ScriptData))
    -> (SlotNo, DatumHash, ScriptData, SlotNo))
-> (SlotNo, (DatumHash, ScriptData))
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SlotNo, (DatumHash, ScriptData))
-> (SlotNo, DatumHash, ScriptData, SlotNo)
unpack)
    (Event -> IO ()) -> ([Event] -> Event) -> [Event] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Event] -> Event
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
  Connection -> Query -> IO ()
SQL.execute_ Connection
c Query
"COMMIT"
  where
    unpack :: (C.SlotNo, (DatumHash, C.ScriptData)) -> (C.SlotNo, DatumHash, C.ScriptData, C.SlotNo)
    unpack :: (SlotNo, (DatumHash, ScriptData))
-> (SlotNo, DatumHash, ScriptData, SlotNo)
unpack (SlotNo
s, (DatumHash
h, ScriptData
d)) = (SlotNo
s, DatumHash
h, ScriptData
d, SlotNo
s)

onInsert :: DatumIndex -> Event -> IO [Notification]
onInsert :: DatumIndex -> Event -> IO [()]
onInsert DatumIndex
_ Event
_ = [()] -> IO [()]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []