Finish Rosetta Endpoints

chainweb.cabal

@@ -207,8 +207,10 @@ library
         , Chainweb.RestAPI.NodeInfo
         , Chainweb.RestAPI.Orphans
         , Chainweb.RestAPI.Utils
+        , Chainweb.Rosetta.Internal
         , Chainweb.Rosetta.RestAPI
         , Chainweb.Rosetta.RestAPI.Server
+        , Chainweb.Rosetta.Util
         , Chainweb.SPV
         , Chainweb.SPV.CreateProof
         , Chainweb.SPV.VerifyProof
@@ -463,6 +465,7 @@ test-suite chainweb-tests
         Chainweb.Test.Pact.Utils
         Chainweb.Test.RestAPI
         Chainweb.Test.RestAPI.Client_
+        Chainweb.Test.Rosetta
         Chainweb.Test.Roundtrips
         Chainweb.Test.SPV
         Chainweb.Test.Store.CAS
@@ -522,6 +525,7 @@ test-suite chainweb-tests
         , resource-pool >= 0.2
         , resourcet >= 1.2
         , retry >= 0.7
+        , rosetta >= 1.0
         , scheduler >= 1.4
         , semialign >= 1
         , servant >= 0.16

src/Chainweb/Mempool/Mempool.hs

@@ -535,6 +535,9 @@ instance FromJSON TransactionHash where
       p :: Text -> Either SomeException TransactionHash
       !p = (TransactionHash . SB.toShort <$>) . decodeB64UrlNoPaddingText
 
+instance HasTextRepresentation TransactionHash where
+  toText (TransactionHash th) = encodeB64UrlNoPaddingText $ SB.fromShort th
+  fromText = (TransactionHash . SB.toShort <$>) . decodeB64UrlNoPaddingText
 
 ------------------------------------------------------------------------------
 data TransactionMetadata = TransactionMetadata {

src/Chainweb/Pact/Backend/InMemoryCheckpointer.hs

@@ -82,6 +82,7 @@ initInMemoryCheckpointEnv loggers logger ver cid = do
                     , _cpRegisterProcessedTx = doRegisterSuccessful inmem
                     , _cpLookupProcessedTx = doLookupSuccessful inmem
                     , _cpGetBlockHistory = \_ _ -> error "unimplemented"
+                    , _cpGetHistoricalLookup = \_ _ _ -> error "unimplemented"
                 }
             , _cpeLogger = logger
             })

src/Chainweb/Pact/Backend/RelationalCheckpointer.hs

@@ -101,6 +101,7 @@ initRelationalCheckpointer' bstate sqlenv loggr v cid = do
               , _cpRegisterProcessedTx = doRegisterSuccessful db
               , _cpLookupProcessedTx = doLookupSuccessful db
               , _cpGetBlockHistory = doGetBlockHistory db
+              , _cpGetHistoricalLookup = doGetHistoricalLookup db
               }
         , _cpeLogger = loggr
         })
@@ -275,31 +276,25 @@ doGetBlockHistory :: FromJSON v => Db -> BlockHeader -> Domain k v -> IO BlockTx
 doGetBlockHistory dbenv blockHeader d = runBlockEnv dbenv $ do
   callDb "doGetBlockHistory" $ \db -> do
     endTxId <- getEndTxId db bHeight (_blockHash blockHeader)
-    startTxId <- getEndTxId db (pred bHeight) (_blockParent blockHeader)
+    startTxId <- if (bHeight == genesisHeight v cid)
+      then pure 0  -- genesis block
+      else getEndTxId db (pred bHeight) (_blockParent blockHeader)
     history <- queryHistory db (domainTableName d) startTxId endTxId
     return $! BlockTxHistory $ foldl' groupByTxid mempty history
   where
-
+    v = _blockChainwebVersion blockHeader
+    cid = _blockChainId blockHeader
     bHeight = _blockHeight blockHeader
 
     groupByTxid :: Ord a => M.Map a [b] -> (a,b) -> M.Map a [b]
     groupByTxid r (t,l) = M.insertWith (++) t [l] r
 
-    getEndTxId db bhi bha = do
-      r <- qry db
-        "SELECT endingtxid FROM BlockHistory WHERE blockheight = ? and hash = ?;"
-        [SInt $ fromIntegral $ bhi, SBlob $ encode $ bha]
-        [RInt]
-      case r of
-        [[SInt tid]] -> return tid
-        [] -> throwM $ BlockHeaderLookupFailure $ "doGetBlockHistory: not in db: " <>
-              sshow (bhi,bha)
-        _ -> internalError $ "doGetBlockHistory: expected single-row int result, got " <> sshow r
-
+    -- Start index is inclusive, while ending index is not.
+    -- `endingtxid` in a block is the beginning txid of the following block.
     queryHistory :: Database -> Utf8 -> Int64 -> Int64 -> IO [(TxId,TxLog Value)]
     queryHistory db tableName s e = do
       let sql = "SELECT txid, rowkey, rowdata FROM [" <> tableName <>
-                "] WHERE txid > ? AND txid <= ?"
+                "] WHERE txid >= ? AND txid < ?"
       r <- qry db sql
            [SInt s,SInt e]
            [RInt,RText,RBlob]
@@ -308,3 +303,42 @@ doGetBlockHistory dbenv blockHeader d = runBlockEnv dbenv $ do
         err -> internalError $
                "readHistoryResult': Expected single row with three columns as the \
                \result, got: " <> T.pack (show err)
+
+getEndTxId :: Database -> BlockHeight -> BlockHash -> IO Int64
+getEndTxId db bhi bha = do
+  r <- qry db
+    "SELECT endingtxid FROM BlockHistory WHERE blockheight = ? and hash = ?;"
+    [SInt $ fromIntegral $ bhi, SBlob $ encode $ bha]
+    [RInt]
+  case r of
+    [[SInt tid]] -> return tid
+    [] -> throwM $ BlockHeaderLookupFailure $ "doGetBlockHistory: not in db: " <>
+          sshow (bhi,bha)
+    _ -> internalError $ "doGetBlockHistory: expected single-row int result, got " <> sshow r
+
+doGetHistoricalLookup
+    :: FromJSON v
+    => Db
+    -> BlockHeader
+    -> Domain k v
+    -> RowKey
+    -> IO (Maybe (TxLog Value))
+doGetHistoricalLookup dbenv blockHeader d k = runBlockEnv dbenv $ do
+  callDb "doGetHistoricalLookup" $ \db -> do
+    endTxId <- getEndTxId db bHeight (_blockHash blockHeader)
+    latestEntry <- queryHistoryLookup db (domainTableName d) endTxId (convRowKey k)
+    return $! latestEntry
+  where
+    bHeight = _blockHeight blockHeader
+
+    queryHistoryLookup :: Database -> Utf8 -> Int64 -> Utf8 -> IO (Maybe (TxLog Value))
+    queryHistoryLookup db tableName e rowKeyName = do
+      let sql = "SELECT rowKey, rowdata FROM [" <> tableName <>
+                "] WHERE txid < ? AND rowkey = ? ORDER BY txid DESC LIMIT 1;"
+      r <- qry db sql
+           [SInt e, SText rowKeyName]
+           [RText, RBlob]
+      case r of
+        [[SText key, SBlob value]] -> Just <$> toTxLog d key value
+        [] -> pure Nothing
+        _ -> internalError $ "doGetHistoricalLookup: expected single-row result, got " <> sshow r

src/Chainweb/Pact/Backend/Types.hs

@@ -297,6 +297,8 @@ data Checkpointer = Checkpointer
     , _cpLookupProcessedTx :: !(P.PactHash -> IO (Maybe (T2 BlockHeight BlockHash)))
     , _cpGetBlockHistory :: !(
         forall k v . (FromJSON v) => BlockHeader -> Domain k v -> IO BlockTxHistory)
+    , _cpGetHistoricalLookup :: !(
+        forall k v . (FromJSON v) => BlockHeader -> Domain k v -> RowKey -> IO (Maybe (TxLog Value)))
     }
 
 data CheckpointEnv = CheckpointEnv

src/Chainweb/Pact/PactService.hs

@@ -33,6 +33,7 @@ module Chainweb.Pact.PactService
     , execLookupPactTxs
     , execPreInsertCheckReq
     , execBlockTxHistory
+    , execHistoricalLookup
     , initPactService
     , readCoinAccount
     , readAccountBalance
@@ -394,6 +395,10 @@ serviceRequests logFn memPoolAccess reqQ = do
               trace logFn "Chainweb.Pact.PactService.execBlockTxHistory" bh 1 $
                 tryOne "execBlockTxHistory" resultVar $
                 execBlockTxHistory bh d
+            HistoricalLookupMsg (HistoricalLookupReq bh d k resultVar) -> do
+              trace logFn "Chainweb.Pact.PactService.execHistoricalLookup" bh 1 $
+                tryOne "execHistoricalLookup" resultVar $
+                execHistoricalLookup bh d k
 
     toPactInternalError e = Left $ PactInternalError $ T.pack $ show e
 
@@ -1418,6 +1423,11 @@ execBlockTxHistory bh (Domain' d) = do
   !cp <- getCheckpointer
   liftIO $ _cpGetBlockHistory cp bh d
 
+execHistoricalLookup :: BlockHeader -> Domain' -> P.RowKey -> PactServiceM cas (Maybe (P.TxLog A.Value))
+execHistoricalLookup bh (Domain' d) k = do
+  !cp <- getCheckpointer
+  liftIO $ _cpGetHistoricalLookup cp bh d k
+
 execPreInsertCheckReq
     :: PayloadCasLookup cas
     => Vector ChainwebTransaction

src/Chainweb/Pact/Service/BlockValidation.hs

@@ -19,16 +19,19 @@ module Chainweb.Pact.Service.BlockValidation
 , lookupPactTxs
 , pactPreInsertCheck
 , pactBlockTxHistory
+, pactHistoricalLookup
 ) where
 
 
 import Control.Concurrent.MVar.Strict
 
+import Data.Aeson (Value)
 import Data.Tuple.Strict
 import Data.Vector (Vector)
 
 import Pact.Types.Command
 import Pact.Types.Hash
+import Pact.Types.Persistence (RowKey, TxLog)
 
 import Chainweb.BlockHash
 import Chainweb.BlockHeader
@@ -109,3 +112,16 @@ pactBlockTxHistory bh d reqQ = do
   let !msg = BlockTxHistoryMsg req
   addRequest reqQ msg
   return resultVar
+
+pactHistoricalLookup
+    :: BlockHeader
+    -> Domain'
+    -> RowKey
+    -> PactQueue
+    -> IO (MVar (Either PactException (Maybe (TxLog Value))))
+pactHistoricalLookup bh d k reqQ = do
+  resultVar <- newEmptyMVar
+  let !req = HistoricalLookupReq bh d k resultVar
+  let !msg = HistoricalLookupMsg req
+  addRequest reqQ msg
+  return resultVar

src/Chainweb/Pact/Service/Types.hs

@@ -113,6 +113,7 @@ data RequestMsg = NewBlockMsg NewBlockReq
                 | LookupPactTxsMsg LookupPactTxsReq
                 | PreInsertCheckMsg PreInsertCheckReq
                 | BlockTxHistoryMsg BlockTxHistoryReq
+                | HistoricalLookupMsg HistoricalLookupReq
                 | CloseMsg
                 deriving (Show)
 
@@ -170,6 +171,16 @@ instance Show BlockTxHistoryReq where
   show (BlockTxHistoryReq h d _) =
     "BlockTxHistoryReq@" ++ show h ++ ", " ++ show d
 
+data HistoricalLookupReq = HistoricalLookupReq
+  { _historicalLookupHeader :: !BlockHeader
+  , _historicalLookupDomain :: !Domain'
+  , _historicalLookupRowKey :: !RowKey
+  , _historicalLookupResult :: !(PactExMVar (Maybe (TxLog Value)))
+  }
+instance Show HistoricalLookupReq where
+  show (HistoricalLookupReq h d k _) =
+    "HistoricalLookupReq@" ++ show h ++ ", " ++ show d ++ ", " ++ show k
+
 data SpvRequest = SpvRequest
     { _spvRequestKey :: RequestKey
     , _spvTargetChainId :: Pact.ChainId

src/Chainweb/RestAPI.hs

@@ -241,8 +241,9 @@ someChainwebServer v dbs mr (HeaderStream hs) (Rosetta r) =
         <> PactAPI.somePactServers v pacts
         <> maybe mempty (Mining.someMiningServer v) mr
         <> maybe mempty (someHeaderStreamServer v) (bool Nothing cuts hs)
-        <> maybe mempty (bool mempty (someRosettaServer v concreteMs cutPeerDb) r) cuts
+        <> maybe mempty (bool mempty (someRosettaServer v payloads concreteMs cutPeerDb concreteCr) r) cuts
         -- TODO: not sure if passing the correct PeerDb here
+        -- TODO: simplify number of resources passing to rosetta
   where
     payloads = _chainwebServerPayloadDbs dbs
     blocks = _chainwebServerBlockHeaderDbs dbs
@@ -251,6 +252,7 @@ someChainwebServer v dbs mr (HeaderStream hs) (Rosetta r) =
     peers = _chainwebServerPeerDbs dbs
     mempools = _chainwebServerMempools dbs
     concreteMs = map (second (_chainResMempool . snd)) pacts
+    concreteCr = map (second snd) pacts
     cutPeerDb = fromJuste $ lookup CutNetwork peers
 
 chainwebApplication