Merge pull request #30 from hyperledger-labs/iterator-methods

Nick Waywood · web-flow · commit 9594e82371a9 · 2020-09-15T10:26:47.000+10:00
Iterator methods
diff --git a/examples/fabcar/Fabcar.hs b/examples/fabcar/Fabcar.hs
diff --git a/examples/marbles/Marbles.hs b/examples/marbles/Marbles.hs
@@ -16,6 +16,7 @@ import           Data.Aeson                       ( FromJSON
 import qualified Data.ByteString                  as BS
 import qualified Data.ByteString.Lazy             as LBS
 import qualified Data.ByteString.UTF8             as BSU
+import           Data.Char                        ( chr )
 import           Data.Text                        ( Text, append, pack, unpack )
 import qualified Data.Text.Encoding               as TSE
 import qualified Data.Text.Lazy                   as TL
@@ -92,7 +93,6 @@ invokeFunc s =
             --   queryMarblesWithPagination s parameters
             Right (fn, _) -> pure $ errorPayload (pack ("Invoke did not find function: " ++ unpack fn))
 
--- TODO: implement CreateCompositeKey to index the marble by color
 initMarble :: DefaultChaincodeStub -> [Text] -> IO Pb.Response
 initMarble s params =
     if Prelude.length params == 4
@@ -101,12 +101,19 @@ initMarble s params =
                  response <- getState s (head params)
                  -- Check if marble already exists
                  if BS.length response /= 0
-                     then throwError $ Error $ "This marble already exists: " ++ (unpack $ head params)
-                     else 
-                         -- marshal marble to JSON
-                         let marbleJSON = LBS.toStrict $ encode (parseMarble params)
-                         in
-                             putState s (head params) marbleJSON)
+                     then throwError $ Error $ "This marble already exists: " ++ unpack (head params)
+                     else let
+                              -- marshal marble to JSON
+                              marbleJSON = LBS.toStrict $ encode (parseMarble params)
+                              indexName = "color~name"
+                              nullCharByteString = BSU.fromString [ chr 0 ]
+                          in
+                              do
+                                  -- we don't care about the response of putState in the success case
+                                  _ <- putState s (head params) marbleJSON
+                                  colorNameIndexKey
+                                      <- ExceptT $ pure $ createCompositeKey s indexName [ params !! 1, params !! 0 ]
+                                  putState s colorNameIndexKey nullCharByteString)
     else pure $ errorPayload "Incorrect arguments. Need a marble name, color, size and owner"
 
 transferMarble :: DefaultChaincodeStub -> [Text] -> IO Pb.Response
diff --git a/examples/sacc/Sacc.hs b/examples/sacc/Sacc.hs
diff --git a/hie.yaml b/hie.yaml
@@ -3,13 +3,13 @@ cradle:
         - path: "./src"
           component: "fabric-chaincode-haskell:lib"
 
-        - path: "./examples/Fabcar.hs"
+        - path: "./examples/fabcar/Fabcar.hs"
           component: "fabric-chaincode-haskell:exe:fabcar-exe"
 
-        - path: "./examples/Sacc.hs"
+        - path: "./examples/sacc/Sacc.hs"
           component: "fabric-chaincode-haskell:exe:sacc-exe"
 
-        - path: "./examples/Marbles.hs"
+        - path: "./examples/marbles/Marbles.hs"
           component: "fabric-chaincode-haskell:exe:marbles-exe"
 
         - path: "./test"
diff --git a/package.yaml b/package.yaml
@@ -1,10 +1,10 @@
-name:                fabric-chaincode-haskell
-version:             0.1.0.0
-github:              "nwaywood/fabric-chaincode-haskell"
-license:             Apache-2
-author:              "Nick Waywood, Allison Irvin"
-maintainer:          "n.waywood@gmail.com"
-copyright:           "2020 Nick Waywood"
+name: fabric-chaincode-haskell
+version: 0.1.0.0
+github: "nwaywood/fabric-chaincode-haskell"
+license: Apache-2
+author: "Nick Waywood, Allison Irvin"
+maintainer: "n.waywood@gmail.com"
+copyright: "2020 Nick Waywood"
 
 # Metadata used when publishing your package
 # synopsis:            Short description of your package
@@ -13,75 +13,75 @@ copyright:           "2020 Nick Waywood"
 # To avoid duplicated efforts in documentation and dealing with the
 # complications of embedding Haddock markup inside cabal files, it is
 # common to point users to the README.md file.
-description:         Please see the README on GitHub at <https://github.com/nwaywood/fabric-chaincode-haskell>
+description: Please see the README on GitHub at <https://github.com/nwaywood/fabric-chaincode-haskell>
 
 dependencies:
-  - base >= 4.7 && < 5
-  - grpc-haskell-core
-  - grpc-haskell
-  - proto3-suite
-  - proto3-wire
-  - vector
-  - bytestring
-  - text
-  - deepseq
-  - containers
-  - utf8-string
-  - aeson
-  - mtl
+    - base >= 4.7 && < 5
+    - grpc-haskell-core
+    - grpc-haskell
+    - proto3-suite
+    - proto3-wire
+    - vector
+    - bytestring
+    - text
+    - deepseq
+    - containers
+    - utf8-string
+    - aeson
+    - mtl
 
 library:
-  source-dirs:
-    - src
-    - protos-hs
+    source-dirs:
+        - src
+        - protos-hs
 
 executables:
-  sacc-exe:
-    main:                Sacc.hs
-    source-dirs:         examples
-    ghc-options:
-    - -threaded
-    - -rtsopts
-    - -with-rtsopts=-N
-    - -Wall
-    - -Wincomplete-uni-patterns
-    - -main-is Sacc
-    dependencies:
-    - fabric-chaincode-haskell
-  marbles-exe:
-    main:                Marbles.hs
-    source-dirs:         examples
-    ghc-options:
-    - -threaded
-    - -rtsopts
-    - -with-rtsopts=-N
-    - -Wall
-    - -Wincomplete-uni-patterns
-    - -main-is Marbles
-    dependencies:
-    - fabric-chaincode-haskell
-  fabcar-exe:
-    main:                Fabcar.hs
-    source-dirs:         examples
-    ghc-options:
-    - -threaded
-    - -rtsopts
-    - -with-rtsopts=-N
-    - -Wall
-    - -Wincomplete-uni-patterns
-    - -main-is Fabcar
-    dependencies:
-    - fabric-chaincode-haskell
+    sacc-exe:
+        main: Sacc.hs
+        source-dirs: examples/sacc
+        ghc-options:
+            - -threaded
+            - -rtsopts
+            - -with-rtsopts=-N
+            - -Wall
+            - -Wincomplete-uni-patterns
+            - -main-is Sacc
+        dependencies:
+            - fabric-chaincode-haskell
+    marbles-exe:
+        main: Marbles.hs
+        source-dirs: examples/marbles
+        ghc-options:
+            - -threaded
+            - -rtsopts
+            - -with-rtsopts=-N
+            - -Wall
+            - -Wincomplete-uni-patterns
+            - -main-is Marbles
+        dependencies:
+            - fabric-chaincode-haskell
+    fabcar-exe:
+        main: Fabcar.hs
+        source-dirs: examples/fabcar
+        ghc-options:
+            - -threaded
+            - -rtsopts
+            - -with-rtsopts=-N
+            - -Wall
+            - -Wincomplete-uni-patterns
+            - -main-is Fabcar
+        dependencies:
+            - fabric-chaincode-haskell
 
 tests:
-  fabric-chaincode-haskell-test:
-    main:                Spec.hs
-    source-dirs:         test
-    ghc-options:
-      - -threaded
-      - -rtsopts
-      - -with-rtsopts=-N
-    dependencies:
-      - fabric-chaincode-haskell
-      - tasty
-      - tasty-hunit
+    fabric-chaincode-haskell-test:
+        main: Spec.hs
+        source-dirs: test
+        ghc-options:
+            - -threaded
+            - -rtsopts
+            - -with-rtsopts=-N
+        dependencies:
+            - fabric-chaincode-haskell
+            - tasty
+            - tasty-hunit
diff --git a/src/Interfaces.hs b/src/Interfaces.hs
@@ -124,7 +124,8 @@ class ChaincodeStubInterface ccs where
     -- Call Close() on the returned StateQueryIteratorInterface object when done.
     -- The query is re-executed during validation phase to ensure result set
     -- has not changed since transaction endorsement (phantom reads detected).
-    -- getStateByPartialCompositeKey :: ccs -> String -> [String] -> Either Error StateQueryIterator
+    getStateByPartialCompositeKey :: ccs -> Text -> [Text] -> ExceptT Error IO StateQueryIterator
+
     -- GetStateByPartialCompositeKeyWithPagination queries the state in the ledger based on
     -- a given partial composite key. This function returns an iterator
     -- which can be used to iterate over the composite keys whose
@@ -143,18 +144,22 @@ class ChaincodeStubInterface ccs where
     -- code point). See related functions SplitCompositeKey and CreateCompositeKey.
     -- Call Close() on the returned StateQueryIteratorInterface object when done.
     -- This call is only supported in a read only transaction.
-    -- getStateByPartialCompositeKeyWithPagination :: ccs -> String -> [String] -> Int32 -> String -> Either Error (StateQueryIterator, Pb.QueryResponseMetadata)
+    getStateByPartialCompositeKeyWithPagination
+        :: ccs -> Text -> [Text] -> Int -> Text -> ExceptT Error IO (StateQueryIterator, Pb.QueryResponseMetadata)
+
     -- CreateCompositeKey combines the given `attributes` to form a composite
     -- key. The objectType and attributes are expected to have only valid utf8
     -- strings and should not contain U+0000 (nil byte) and U+10FFFF
     -- (biggest and unallocated code point).
     -- The resulting composite key can be used as the key in PutState().
-    -- createCompositeKey :: ccs -> String -> [String] -> Either Error String
+    createCompositeKey :: ccs -> Text -> [Text] -> Either Error Text
+
     -- SplitCompositeKey splits the specified key into attributes on which the
     -- composite key was formed. Composite keys found during range queries
     -- or partial composite key queries can therefore be split into their
     -- composite parts.
-    -- splitCompositeKey :: ccs -> String -> Either Error (String, [String])
+    splitCompositeKey :: ccs -> Text -> Either Error (Text, [Text])
+
     -- GetQueryResult performs a "rich" query against a state database. It is
     -- only supported for state databases that support rich query,
     -- e.g.CouchDB. The query string is in the native syntax
@@ -170,7 +175,8 @@ class ChaincodeStubInterface ccs where
     -- be detected at validation/commit time.  Applications susceptible to this
     -- should therefore not use GetQueryResult as part of transactions that update
     -- ledger, and should limit use to read-only chaincode operations.
-    -- getQueryResult :: ccs -> String -> Either Error StateQueryIterator
+    getQueryResult :: ccs -> Text -> ExceptT Error IO StateQueryIterator
+
     -- GetQueryResultWithPagination performs a "rich" query against a state database.
     -- It is only supported for state databases that support rich query,
     -- e.g., CouchDB. The query string is in the native syntax
@@ -184,7 +190,9 @@ class ChaincodeStubInterface ccs where
     -- can be used as a value to the bookmark argument. Otherwise, an empty string
     -- must be passed as bookmark.
     -- This call is only supported in a read only transaction.
-    -- getQueryResultWithPagination :: ccs -> String -> Int32 -> String -> Either Error (StateQueryIterator, Pb.QueryResponseMetadata)
+    getQueryResultWithPagination
+        :: ccs -> Text -> Int -> Text -> ExceptT Error IO (StateQueryIterator, Pb.QueryResponseMetadata)
+
     -- GetHistoryForKey returns a history of key values across time.
     -- For each historic key update, the historic value and associated
     -- transaction id and timestamp are returned. The timestamp is the
@@ -197,7 +205,9 @@ class ChaincodeStubInterface ccs where
     -- detected at validation/commit time. Applications susceptible to this
     -- should therefore not use GetHistoryForKey as part of transactions that
     -- update ledger, and should limit use to read-only chaincode operations.
-    -- getHistoryForKey :: ccs -> Either Error HistoryQueryIterator
+    -- TODO: value should be HistoryQueryIterator
+    getHistoryForKey :: ccs -> Text -> ExceptT Error IO StateQueryIterator
+
     -- GetPrivateData returns the value of the specified `key` from the specified
     -- `collection`. Note that GetPrivateData doesn't read data from the
     -- private writeset, which has not been committed to the `collection`. In
diff --git a/src/Stub.hs b/src/Stub.hs
@@ -6,14 +6,14 @@ module Stub where
 
 import qualified Common.Common                    as Pb
 
-import           Control.Monad.Except             ( ExceptT(..), runExceptT )
+import           Control.Monad.Except             ( ExceptT(..), runExceptT, throwError )
 
--- import           Data.Int                      (fromIntegral)
 import           Data.Bifunctor
 import           Data.ByteString                  as BS
 import qualified Data.ByteString.Lazy             as LBS
+import           Data.Char                        ( chr )
 import           Data.IORef                       ( modifyIORef, newIORef, readIORef, writeIORef )
-import           Data.Text
+import           Data.Text                        as TS
 import           Data.Text.Encoding
 import           Data.Text.Lazy                   as TL
 import           Data.Vector                      as Vector ( (!), Vector, empty, foldr, length, toList )
@@ -137,13 +137,6 @@ instance ChaincodeStubInterface DefaultChaincodeStub where
                     Right _ -> pure ()
                 listenForResponse (recvStream ccs)
 
-      --
-      -- -- setStateValidationParameter :: ccs -> String -> [ByteString] -> Maybe Error
-      -- setStateValidationParameter ccs key parameters = Right notImplemented
-      --
-      -- -- getStateValiationParameter :: ccs -> String -> Either Error [ByteString]
-      -- getStateValiationParameter ccs key = Left notImplemented
-      --
     -- TODO: Implement better error handling/checks etc
     -- getStateByRange :: ccs -> Text -> Text -> IO (Either Error StateQueryIterator)
     getStateByRange ccs startKey endKey =
@@ -173,7 +166,37 @@ instance ChaincodeStubInterface DefaultChaincodeStub where
                     Right _ -> pure ()
                 runExceptT $ ExceptT (listenForResponse (recvStream ccs)) >>= (bsToSqiAndMeta ccs)
 
-  -- TODO : implement all these interface functions
+    -- TODO: This is the next TODO! Implement these 7 function because they are needed in marbles.hs
+    -- getStateByPartialCompositeKey :: ccs -> Text -> [Text] -> Either Error StateQueryIterator
+    getStateByPartialCompositeKey ccs objectType keys = throwError $ Error "not implemented"
+
+    --getStateByPartialCompositeKeyWithPagination :: ccs -> Text -> [Text] -> Int32 -> Text -> Either Error (StateQueryIterator, Pb.QueryResponseMetadata)
+    getStateByPartialCompositeKeyWithPagination ccs objectType keys pageSize bookmark =
+        throwError $ Error "not implemented"
+
+    --createCompositeKey :: ccs -> Text -> [Text] -> Either Error Text
+    createCompositeKey ccs objectType keys =
+        let keysString = Prelude.foldr (\key acc -> acc ++ TS.unpack key ++ nullCodepoint) "" keys
+            nullCodepoint = [ chr 0 ]
+        in
+            -- TODO: Check that objectTypes and keys are all valid utf8 strings
+            Right $ TS.pack $ "\x00" ++ TS.unpack objectType ++ nullCodepoint ++ keysString
+
+    --splitCompositeKey :: ccs -> Text -> Either Error (Text, [Text])
+    splitCompositeKey ccs key =
+        -- key has the form \x00objectTypeU+0000keyU+0000key etc so we use `tail key` to ignore the \x00 char
+        -- and then split on the unicode codepoint U+0000 to extract the objectType and keys
+        let keys = TS.splitOn (TS.singleton $ chr 0) (TS.tail key) in Right (Prelude.head keys, Prelude.tail keys)
+
+    --getQueryResult :: ccs -> Text -> Either Error StateQueryIterator
+    getQueryResult ccs query = throwError $ Error "not implemented"
+
+    --getQueryResultWithPagination :: ccs -> Text -> Int32 -> Text -> Either Error (StateQueryIterator, Pb.QueryResponseMetadata)
+    getQueryResultWithPagination ccs key pageSize bookmark = throwError $ Error "not implemented"
+
+    --getHistoryForKey :: ccs -> Text -> Either Error HistoryQueryIterator
+    getHistoryForKey ccs key = throwError $ Error "not implemented"
+
 instance StateQueryIteratorInterface StateQueryIterator where
     -- TODO: remove the IO from this function (possibly with the State monad)
       -- hasNext :: sqi -> IO Bool
@@ -184,6 +207,7 @@ instance StateQueryIteratorInterface StateQueryIterator where
         pure $ (currentLoc < Prelude.length (Pb.queryResponseResults queryResponse))
             || (Pb.queryResponseHasMore queryResponse)
 
+    -- TODO : implement close function (need to do anything here in haskell?)
     -- close :: sqi -> IO (Maybe Error)
     close _ = pure Nothing
 
@@ -296,28 +320,6 @@ fetchNextQueryResult sqi = do
                     Left err -> error ("Error while streaming: " ++ show err)
                     Right _ -> pure ()
                 runExceptT $ ExceptT (listenForResponse (recvStream $ sqiChaincodeStub sqi)) >>= bsToQueryResponse
---
--- -- getStateByPartialCompositeKey :: ccs -> String -> [String] -> Either Error StateQueryIterator
--- getStateByPartialCompositeKey ccs objectType keys  = Left notImplemented
---
--- --getStateByPartialCompositeKeyWithPagination :: ccs -> String -> [String] -> Int32 -> String -> Either Error (StateQueryIterator, Pb.QueryResponseMetadata)
--- getStateByPartialCompositeKeyWithPagination ccs objectType keys pageSize bookmark = Left notImplemented
---
--- --createCompositeKey :: ccs -> String -> [String] -> Either Error String
--- createCompositeKey ccs objectType keys = Left notImplemented
---
--- --splitCompositeKey :: ccs -> String -> Either Error (String, [String])
--- splitCompositeKey ccs key = Left notImplemented
---
--- --getQueryResult :: ccs -> String -> Either Error StateQueryIterator
--- getQueryResult ccs query = Left notImplemented
---
--- --getQueryResultWithPagination :: ccs -> String -> Int32 -> String -> Either Error (StateQueryIterator, Pb.QueryResponseMetadata)
--- getQueryResultWithPagination ccs key pageSize bookmark = Left notImplemented
---
--- --getHistoryForKey :: ccs -> String -> Either Error HistoryQueryIterator
--- getHistoryForKey ccs key = Left notImplemented
---
 -- --getPrivateData :: ccs -> String -> String -> Either Error ByteString
 -- getPrivateData ccs collection key = Left notImplemented
 --
