Skip to content
This repository was archived by the owner on Apr 13, 2022. It is now read-only.

Commit df26deb

Browse files
airvinairvin
committed
Added fabcar example chaincode
Signed-off-by: Allison Irvin <allison.irvin@au1.ibm.com>
1 parent 7cec957 commit df26deb

File tree

2 files changed

+238
-0
lines changed

2 files changed

+238
-0
lines changed

‎examples/Fabcar.hs‎

Lines changed: 226 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,226 @@
1+
{-# LANGUAGE OverloadedStrings #-}
2+
{-# LANGUAGE DeriveGeneric #-}
3+
4+
-- peer chaincode invoke -n mycc -c '{"Args":["initLedger"]}' -C myc
5+
-- peer chaincode invoke -n mycc -c '{"Args":["createCar", "CAR10", "Ford", "Falcon", "White", "Al"]}' -C myc
6+
-- peer chaincode invoke -n mycc -c '{"Args":["queryCar", "CAR10"]}' -C myc
7+
8+
module Fabcar where
9+
10+
import GHC.Generics
11+
import Shim ( start
12+
, successPayload
13+
, errorPayload
14+
, ChaincodeStub(..)
15+
, ChaincodeStubInterface(..)
16+
, DefaultChaincodeStub
17+
)
18+
19+
import Peer.ProposalResponse as Pb
20+
21+
import Data.Aeson ( ToJSON
22+
, FromJSON
23+
, toEncoding
24+
, genericToEncoding
25+
, defaultOptions
26+
, encode
27+
, decode
28+
)
29+
30+
import Data.Text ( Text )
31+
32+
import qualified Data.ByteString as BS
33+
import qualified Data.ByteString.UTF8 as BSU
34+
import qualified Data.ByteString.Lazy as LBS
35+
36+
import Debug.Trace
37+
38+
main :: IO ()
39+
main = Shim.start chaincodeStub
40+
41+
data Car = Car {
42+
make :: Text,
43+
model :: Text,
44+
colour :: Text,
45+
owner :: Text
46+
} deriving (Generic, Show)
47+
48+
instance ToJSON Car where
49+
toEncoding = genericToEncoding defaultOptions
50+
51+
instance FromJSON Car
52+
53+
chaincodeStub :: ChaincodeStub
54+
chaincodeStub = ChaincodeStub {initFn = initFunc, invokeFn = invokeFunc}
55+
56+
initFunc :: DefaultChaincodeStub -> IO Pb.Response
57+
initFunc _ = pure $ successPayload Nothing
58+
59+
invokeFunc :: DefaultChaincodeStub -> IO Pb.Response
60+
invokeFunc s =
61+
let e = getFunctionAndParameters s
62+
in case e of
63+
Left _ -> pure $ errorPayload "Failed to get function"
64+
Right ("initLedger" , parameters) -> initLedger s parameters
65+
Right ("createCar" , parameters) -> createCar s parameters
66+
Right ("queryCar" , parameters) -> queryCar s parameters
67+
Right ("queryAllCars" , parameters) -> queryAllCars s parameters
68+
Right ("changeCarOwner", parameters) -> changeCarOwner s parameters
69+
Right (_, _) -> pure $ errorPayload "No matching function found"
70+
71+
initLedger :: DefaultChaincodeStub -> [Text] -> IO Pb.Response
72+
initLedger s _ =
73+
let
74+
cars
75+
= [ Car
76+
{ make = "Toyota"
77+
, model = "Prius"
78+
, colour = "blue"
79+
, owner = "Tomoko"
80+
}
81+
, Car {make = "Ford", model = "Mustang", colour = "red", owner = "Brad"}
82+
, Car
83+
{ make = "Hyundai"
84+
, model = "Tucson"
85+
, colour = "green"
86+
, owner = "Jin Soo"
87+
}
88+
, Car
89+
{ make = "Volkswagen"
90+
, model = "Passat"
91+
, colour = "yellow"
92+
, owner = "Max"
93+
}
94+
, Car {make = "Tesla", model = "S", colour = "black", owner = "Adriana"}
95+
, Car
96+
{ make = "Peugeot"
97+
, model = "205"
98+
, colour = "purple"
99+
, owner = "Michel"
100+
}
101+
, Car
102+
{ make = "Chery"
103+
, model = "S22L"
104+
, colour = "white"
105+
, owner = "Aarav"
106+
}
107+
, Car
108+
{ make = "Fiat"
109+
, model = "Punto"
110+
, colour = "violet"
111+
, owner = "Pari"
112+
}
113+
, Car
114+
{ make = "Tata"
115+
, model = "Nano"
116+
, colour = "indigo"
117+
, owner = "Valeria"
118+
}
119+
, Car
120+
{ make = "Holden"
121+
, model = "Barina"
122+
, colour = "brown"
123+
, owner = "Shotaro"
124+
}
125+
]
126+
keys =
127+
[ "CAR0"
128+
, "CAR1"
129+
, "CAR2"
130+
, "CAR3"
131+
, "CAR4"
132+
, "CAR5"
133+
, "CAR6"
134+
, "CAR7"
135+
, "CAR8"
136+
, "CAR9"
137+
, "CAR10"
138+
]
139+
in
140+
createCars s keys cars
141+
142+
createCars :: DefaultChaincodeStub -> [Text] -> [Car] -> IO Pb.Response
143+
createCars s keys cars = if length cars == 0
144+
then pure $ successPayload Nothing
145+
else
146+
let response = putState s (head keys) (LBS.toStrict $ encode $ head cars)
147+
in do
148+
e <- response
149+
case e of
150+
Left _ -> pure $ errorPayload "Failed to set asset"
151+
Right _ -> createCars s (tail keys) (tail cars)
152+
153+
createCar :: DefaultChaincodeStub -> [Text] -> IO Pb.Response
154+
createCar s params = if Prelude.length params == 5
155+
then
156+
let car = Car
157+
{ make = params !! 1
158+
, model = params !! 2
159+
, colour = params !! 3
160+
, owner = params !! 4
161+
}
162+
response = putState s (head params) (LBS.toStrict $ encode car)
163+
in do
164+
e <- response
165+
case e of
166+
Left _ -> pure $ errorPayload "Failed to set asset"
167+
Right _ -> pure $ successPayload Nothing
168+
else pure $ errorPayload "Incorrect number of arguments. Expecting 5"
169+
170+
queryCar :: DefaultChaincodeStub -> [Text] -> IO Pb.Response
171+
queryCar s params = if Prelude.length params == 1
172+
then
173+
let response = getState s (head params)
174+
in do
175+
e <- response
176+
case e of
177+
Left _ -> pure $ errorPayload "Failed to get asset"
178+
Right carBytes -> trace (BSU.toString carBytes)
179+
(pure $ successPayload $ Just carBytes)
180+
else pure $ errorPayload "Incorrect number of arguments. Expecting 1"
181+
182+
-- TODO: requires the getStateByRange stub function
183+
queryAllCars :: DefaultChaincodeStub -> [Text] -> IO Pb.Response
184+
queryAllCars _ _ = pure $ errorPayload "Not yet implemented"
185+
-- let
186+
-- startKey = "CAR0"
187+
-- endKey = "CAR999"
188+
-- response = getStateByRange s startKey endKey
189+
-- in do
190+
-- e <- response
191+
-- case e of
192+
-- Left _ -> pure $ errorPayload "Failed to get assets"
193+
-- Right carsBytes -> trace (BSU.toString carsBytes) (pure $ successPayload $ Just carsBytes)
194+
195+
changeCarOwner :: DefaultChaincodeStub -> [Text] -> IO Pb.Response
196+
changeCarOwner s params = if Prelude.length params == 2
197+
then do
198+
-- Check that the car already exists
199+
e <- getState s (head params)
200+
case e of
201+
Left _ -> pure $ errorPayload "Failed to get car"
202+
Right response -> if BS.length response == 0
203+
then pure $ errorPayload "Car not found"
204+
else
205+
-- Unmarshal the car
206+
let maybeCar = decode (LBS.fromStrict response) :: Maybe Car
207+
carOwner = head $ tail params
208+
in case maybeCar of
209+
Nothing -> pure $ errorPayload "Error decoding car"
210+
Just oldCar ->
211+
let newCar = carWithNewOwner oldCar carOwner
212+
carJson = LBS.toStrict $ encode newCar
213+
in do
214+
ee <- putState s (head params) carJson
215+
case ee of
216+
Left _ -> pure $ errorPayload "Failed to create car"
217+
Right _ -> pure $ successPayload Nothing
218+
else pure $ errorPayload "Incorrect arguments. Need a car name and new owner"
219+
220+
carWithNewOwner :: Car -> Text -> Car
221+
carWithNewOwner oldCar newOwner = Car
222+
{ make = make oldCar
223+
, model = model oldCar
224+
, colour = colour oldCar
225+
, owner = newOwner
226+
}

‎package.yaml‎

Lines changed: 12 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -59,6 +59,18 @@ executables:
5959
- -main-is Marbles
6060
dependencies:
6161
- fabric-chaincode-haskell
62+
fabcar-exe:
63+
main: Fabcar.hs
64+
source-dirs: examples
65+
ghc-options:
66+
- -threaded
67+
- -rtsopts
68+
- -with-rtsopts=-N
69+
- -Wall
70+
- -Wincomplete-uni-patterns
71+
- -main-is Fabcar
72+
dependencies:
73+
- fabric-chaincode-haskell
6274

6375
tests:
6476
fabric-chaincode-haskell-test:

0 commit comments

Comments
 (0)