WIP scaffolding for sqlite backend

pact-core.cabal

@@ -27,15 +27,19 @@ common pact-core-common
     , containers
     , data-default
     , deepseq
+    , direct-sqlite
     , directory
     , exceptions
     , filepath
     , lens
+    , lifted-base
+    , monad-control
     , mtl
     , pact-time
     , prettyprinter
     , prettyprinter-ansi-terminal
     , transformers
+    , transformers-base
     , text
     , vector
     , vector-algorithms
@@ -102,6 +106,8 @@ library
     Pact.Core.Info
     Pact.Core.Errors
     Pact.Core.Persistence
+    Pact.Core.Persistence.SQLite
+    Pact.Core.Persistence.MockPersistence
     Pact.Core.PactValue
     Pact.Core.Debug
     Pact.Core.Capabilities

pact-core/Pact/Core/Names.hs

@@ -42,13 +42,15 @@ module Pact.Core.Names
  , OverloadedName(..)
  , FullyQualifiedName(..)
  , TableName(..)
+ , tableName
  , replRawModuleName
  , replModuleName
  , replModuleHash
  , fqnToName
  , fqnToQualName
  , NativeName(..)
  , RowKey(..)
+ , rowKey
  , renderFullyQualName
  , FQNameRef(..)
  , fqName
@@ -296,6 +298,8 @@ instance Pretty NamedDeBruijn where
 newtype TableName = TableName { _tableName :: Text }
   deriving (Eq, Ord, Show)
 
+makeLenses ''TableName
+
 instance Pretty TableName where
   pretty (TableName tn) = pretty tn
 
@@ -318,6 +322,8 @@ newtype RowKey
   = RowKey { _rowKey :: Text }
   deriving (Eq, Ord, Show)
 
+makeLenses ''RowKey
+
 data FQNameRef name where
   FQParsed :: ParsedName -> FQNameRef ParsedName
   FQName :: FullyQualifiedName -> FQNameRef Name

pact-core/Pact/Core/Persistence.hs

@@ -21,7 +21,6 @@ module Pact.Core.Persistence
  , Purity(..)
  , RowData(..)
  , ExecutionMode(..)
- , mockPactDb
  , mdModuleName
  , mdModuleHash
  , readModule, writeModule
@@ -32,15 +31,14 @@ module Pact.Core.Persistence
  , TxId(..)
  , TxLog(..)
  , dbOpDisallowed
+
+ , FQKS
  ) where
 
 import Control.Lens
-import Control.Monad(unless)
 import Control.Exception(throwIO, Exception)
-import Data.Maybe(isJust)
 import Data.Text(Text)
 import Data.Word(Word64)
-import Data.IORef
 import Data.Map.Strict(Map)
 
 import Pact.Core.Type
@@ -52,7 +50,6 @@ import Pact.Core.PactValue
 import Pact.Core.Pacts.Types
 -- import Pact.Core.Errors
 
-import qualified Data.Map.Strict as M
 import Data.Dynamic (Typeable)
 
 -- | Modules as they are stored
@@ -234,219 +231,3 @@ instance Semigroup (Loaded b i) where
 instance Monoid (Loaded b i) where
   mempty = Loaded mempty mempty mempty
 
-mockPactDb :: forall b i. IO (PactDb b i)
-mockPactDb = do
-  refMod <- newIORef M.empty
-  refKs <- newIORef M.empty
-  refUsrTbl <- newIORef M.empty
-  refPacts <- newIORef M.empty
-  refRb <- newIORef Nothing
-  refTxLog <- newIORef mempty
-  refTxId <- newIORef 0
-  pure $ PactDb
-    { _pdbPurity = PImpure
-    , _pdbRead = read' refKs refMod refUsrTbl refPacts
-    , _pdbWrite = write refKs refMod refUsrTbl refTxId refTxLog refPacts
-    , _pdbKeys = keys refKs refMod refUsrTbl refPacts
-    , _pdbCreateUserTable = createUsrTable refUsrTbl refTxLog
-    , _pdbBeginTx = beginTx refRb refTxId refTxLog refMod refKs refUsrTbl
-    , _pdbCommitTx = commitTx refRb refTxId refTxLog refMod refKs refUsrTbl
-    , _pdbRollbackTx = rollbackTx refRb refTxLog refMod refKs refUsrTbl
-    , _pdbTxIds = txIds refTxLog
-    , _pdbGetTxLog = txLog refTxLog
-    }
-  where
-  beginTx refRb refTxId refTxLog refMod refKs refUsrTbl em = do
-    readIORef refRb >>= \case
-      Just (_, _, _, _, _) -> pure Nothing
-      Nothing -> do
-        mods <- readIORef refMod
-        ks <- readIORef refKs
-        usrTbl <- readIORef refUsrTbl
-        txl <- readIORef refTxLog
-        writeIORef refRb (Just (em, txl, mods, ks, usrTbl))
-        tid <- readIORef refTxId
-        pure (Just (TxId tid))
-
-  commitTx refRb refTxId refTxLog refMod refKs refUsrTbl = readIORef refRb >>= \case
-    Just (em, txl, mods, ks, usr) -> case em of
-      Transactional -> do
-        writeIORef refRb Nothing
-        modifyIORef' refTxId (+ 1)
-      Local -> do
-        writeIORef refRb Nothing
-        writeIORef refMod mods
-        writeIORef refKs ks
-        writeIORef refUsrTbl usr
-        writeIORef refTxLog txl
-    Nothing ->
-      throwIO NoTxToCommit
-
-  rollbackTx refRb refTxLog refMod refKs refUsrTbl = readIORef refRb >>= \case
-    Just (_, txl, mods, ks, usr) -> do
-      writeIORef refRb Nothing
-      writeIORef refTxLog txl
-      writeIORef refMod mods
-      writeIORef refKs ks
-      writeIORef refUsrTbl usr
-    Nothing -> throwIO NoTxToCommit
-
-  txLog refTxLog tn tid = do
-    m <- readIORef refTxLog
-    case M.lookup tn m of
-      Just txids -> case M.lookup tid txids of
-        Just n -> pure n
-        Nothing -> throwIO (NoTxLog tn tid)
-      Nothing -> throwIO (NoTxLog tn tid)
-
-  txIds refTxLog tn txId = do
-    txl <- readIORef refTxLog
-    case M.lookup tn txl of
-      Just mtxl -> pure [ x | x <- M.keys mtxl, x >= txId ]
-      Nothing -> throwIO (NoSuchTable tn)
-
-  keys
-    :: forall k v
-    .  IORef (Map KeySetName FQKS)
-    -> IORef (Map ModuleName (ModuleData b i))
-    -> IORef (Map TableName (Map RowKey RowData))
-    -> IORef (Map PactId (Maybe PactExec))
-    -> Domain k v b i
-    -> IO [k]
-  keys refKs refMod refUsrTbl refPacts d = case d of
-    DKeySets -> do
-      r <- readIORef refKs
-      return (M.keys r)
-    DModules -> do
-      r <- readIORef refMod
-      return (M.keys r)
-    DUserTables tbl -> do
-      r <- readIORef refUsrTbl
-      case M.lookup tbl r of
-        Just t -> return (M.keys t)
-        Nothing -> throwIO (NoSuchTable tbl)
-    DPacts -> do
-      r <- readIORef refPacts
-      return (M.keys r)
-
-  createUsrTable
-    :: IORef (Map TableName (Map RowKey RowData))
-    -> IORef (Map TableName (Map TxId [TxLog RowData]))
-    -> TableName
-    -> ModuleName
-    -> IO ()
-  createUsrTable refUsrTbl refTxLog tbl _ = do
-    ref <- readIORef refUsrTbl
-    case M.lookup tbl ref of
-      Nothing -> do
-        modifyIORef refTxLog (M.insert tbl mempty)
-        modifyIORef refUsrTbl (M.insert tbl mempty)
-        pure ()
-      Just _ -> throwIO (TableAlreadyExists tbl)
-
-  read'
-    :: forall k v
-    .  IORef (Map KeySetName FQKS)
-    -> IORef (Map ModuleName (ModuleData b i))
-    -> IORef (Map TableName (Map RowKey RowData))
-    -> IORef (Map PactId (Maybe PactExec))
-    -> Domain k v b i
-    -> k
-    -> IO (Maybe v)
-  read' refKs refMod refUsrTbl refPacts domain k = case domain of
-    DKeySets -> readKS refKs k
-    DModules -> readMod refMod k
-    DUserTables tbl ->
-      readRowData refUsrTbl tbl k
-    DPacts -> readPacts' refPacts k
-
-  checkTable tbl ref = do
-    r <- readIORef ref
-    unless (isJust (M.lookup tbl r)) $ throwIO (NoSuchTable tbl)
-
-  write
-    :: forall k v
-    .  IORef (Map KeySetName FQKS)
-    -> IORef (Map ModuleName (ModuleData b i))
-    -> IORef (Map TableName (Map RowKey RowData))
-    -> IORef Word64
-    -> IORef (Map TableName (Map TxId [TxLog RowData]))
-    -> IORef (Map PactId (Maybe PactExec))
-    -> WriteType
-    -> Domain k v b i
-    -> k
-    -> v
-    -> IO ()
-  write refKs refMod refUsrTbl refTxId refTxLog refPacts wt domain k v = case domain of
-    DKeySets -> writeKS refKs k v
-    DModules -> writeMod refMod v
-    DUserTables tbl -> writeRowData refUsrTbl refTxId refTxLog tbl wt k v
-    DPacts -> writePacts' refPacts k v
-
-  readRowData ref tbl k = do
-    checkTable tbl ref
-    r <- readIORef ref
-    pure (r ^? ix tbl . ix k)
-
-  writeToTxLog
-    :: IORef Word64
-    -> IORef (Map TableName (Map TxId [TxLog RowData]))
-    -> TableName
-    -> RowKey
-    -> RowData
-    -> IO ()
-  writeToTxLog refTxId refTxLog tbl k rdata = do
-    tid <- readIORef refTxId
-    let entry = M.singleton (TxId tid) [TxLog (_tableName tbl) (_rowKey k) rdata]
-    modifyIORef' refTxLog (M.insertWith (M.unionWith (<>)) tbl entry)
-
-  writeRowData
-    :: IORef (Map TableName (Map RowKey RowData))
-    -> IORef Word64
-    -> IORef (Map TableName (Map TxId [TxLog RowData]))
-    -> TableName
-    -> WriteType
-    -> RowKey
-    -> RowData
-    -> IO ()
-  writeRowData ref refTxId refTxLog tbl wt k v = checkTable tbl ref *> case wt of
-    Write -> do
-      writeToTxLog refTxId refTxLog tbl k v
-      modifyIORef' ref (M.insertWith M.union tbl (M.singleton k v))
-    Insert -> do
-      r <- readIORef ref
-      case M.lookup tbl r >>= M.lookup k of
-        Just _ -> throwIO WriteException
-        Nothing -> do
-          writeToTxLog refTxId refTxLog tbl k v
-          modifyIORef' ref (M.insertWith M.union tbl (M.singleton k v))
-    Update -> do
-      r <- readIORef ref
-      case M.lookup tbl r >>= M.lookup k of
-        Just (RowData m) -> do
-          let (RowData v') = v
-              nrd = RowData (M.union v' m)
-          writeToTxLog refTxId refTxLog tbl k nrd
-          modifyIORef' ref (M.insertWith M.union tbl (M.singleton k nrd))
-        Nothing -> throwIO WriteException
-
-
-  readKS ref ksn = do
-    m <- readIORef ref
-    pure (M.lookup ksn m)
-
-  writeKS ref ksn ks = modifyIORef' ref (M.insert ksn ks)
-
-  readMod ref mn = do
-    m <- readIORef ref
-    pure (M.lookup mn m)
-
-  writeMod ref md = let
-    mname = view mdModuleName md
-    in modifyIORef' ref (M.insert mname md)
-
-  readPacts' ref pid = do
-    m <- readIORef ref
-    pure (M.lookup pid m)
-
-  writePacts' ref pid pe = modifyIORef' ref (M.insert pid pe)