Allow using instance creation methods when reading NeoJSON objects

source/Stargate-Examples-Tests/PetOrdersRESTfulControllerTest.class.st

@@ -48,6 +48,15 @@ PetOrdersRESTfulControllerTest >> createOrder [
 		within: self newHttpRequestContext
 ]
 
+{ #category : 'private - support' }
+PetOrdersRESTfulControllerTest >> createOverlyComplexOrder [
+
+	^ resourceController
+		  createOrderBasedOn: ( self requestToPOSTAsOverlyComplexOrder:
+				    '{"date":"2018-10-24T18:05:46.418Z","pet":{"alternativeName":"Fido","itsType":"Dog","theStatus":"happy"}}' )
+		  within: self newHttpRequestContext
+]
+
 { #category : 'private - support' }
 PetOrdersRESTfulControllerTest >> getFirstOrderAndWithJsonDo: aBlock [
 
@@ -117,6 +126,12 @@ PetOrdersRESTfulControllerTest >> requestToPOSTAsOrder: json [
 	^ self requestToPOST: json as: resourceController orderVersion1dot0dot0MediaType
 ]
 
+{ #category : 'private - HTTP requests' }
+PetOrdersRESTfulControllerTest >> requestToPOSTAsOverlyComplexOrder: json [
+
+	^ self requestToPOST: json as: resourceController overlyComplexOrderVersion1dot0dot0MediaType
+]
+
 { #category : 'private - HTTP requests' }
 PetOrdersRESTfulControllerTest >> requestToPUTComment: aComment on: aSubresourceUrl at: aCommentIndex forOrder: anOrderId conditionalTo: anETag [
 
@@ -500,6 +515,27 @@ PetOrdersRESTfulControllerTest >> testOrderCreationWhenDecodingFailsDueToMissing
 		raise: HTTPClientError badRequest withMessageText: 'Missing required keys (#pet)'
 ]
 
+{ #category : 'tests - orders' }
+PetOrdersRESTfulControllerTest >> testOverlyComplexOrderCreation [
+
+	| response order |
+
+	response := self createOverlyComplexOrder.
+
+	self
+		assert: response isSuccess;
+		assert: response status equals: 201;
+		assertUrl: response location equals: 'https://petstore.example.com/orders/1';
+		assert: response hasEntity;
+		assert: orderRepository count equals: 1.
+	order := orderRepository findAll first.
+	self
+		assert: order pet name equals: 'Fido';
+		assert: order pet type equals: 'Dog';
+		assert: order pet status equals: 'HAPPY';
+		assert: order date equals: '2018-10-24T18:05:46.418Z'
+]
+
 { #category : 'tests' }
 PetOrdersRESTfulControllerTest >> testRoutes [
 

source/Stargate-Examples/PetOrdersRESTfulController.class.st

@@ -113,32 +113,55 @@ PetOrdersRESTfulController >> completeTemplate [
 { #category : 'private' }
 PetOrdersRESTfulController >> configureOrderDecodingOn: reader [
 
-	^ reader
-		  for: PetOrder strictDo: [ :mapping |
-			  mapping
-				  mapInstVar: #date;
-				  mapProperty: #pet
-				  setter: [ :order :url |
-					  LanguagePlatform current atInstanceVariableNamed: 'pet' on: order put: url asUrl ]
-			  ];
-		  nextAs: PetOrder
+	reader for: #Url customDo: [ :mapping | mapping decoder: [ :string | string asUrl ] ].
+	reader for: PetOrder createInstanceUsing: [ :mapping |
+		mapping
+			mapProperty: #date;
+			mapProperty: #pet as: #Url.
+		mapping mapCreationSending: #for:on: withArguments: { #pet. #date }
+		].
+
+	^ reader nextAs: PetOrder
 ]
 
 { #category : 'private' }
 PetOrdersRESTfulController >> configureOrderEncodingOn: writer within: requestContext [
 
 	writer
+		for: Pet do: [ :mapping | mapping mapInstVars ];
 		for: ZnUrl customDo: [ :mapping | mapping encoder: [ :url | url printString ] ];
-		for: #Order
-			do: [ :mapping | 
+		for: #Order do: [ :mapping |
 			mapping
 				mapProperty: #pet getter: #pet;
-				mapProperty: #name getter: #date;
+				mapProperty: #date getter: #date;
 				mapProperty: #status getter: [ :object | requestContext objectUnder: #status ];
 				mapAsHypermediaControls: [ :order | requestContext hypermediaControlsFor: order ]
 			]
 ]
 
+{ #category : 'private' }
+PetOrdersRESTfulController >> configureOverlyComplexOrderDecodingOn: reader [
+
+	reader for: #Status customDo: [ :mapping | mapping decoder: [ :string | string asUppercase ] ].
+	reader for: Pet createInstanceUsing: [ :mapping |
+		mapping
+			mapProperty: #alternativeName;
+			mapProperty: #itsType;
+			mapProperty: #theStatus as: #Status.
+		mapping
+			mapCreationSending: #named:ofType:withStatus:
+			withArguments: { #alternativeName. #itsType. #theStatus }
+		].
+	reader for: PetOrder createInstanceUsing: [ :mapping |
+		mapping
+			mapProperty: #date;
+			mapProperty: #pet as: Pet.
+		mapping mapCreationSending: #for:on: withArguments: { #pet. #date }
+		].
+
+	^ reader nextAs: PetOrder
+]
+
 { #category : 'API - comments' }
 PetOrdersRESTfulController >> createCommentBasedOn: httpRequest within: requestContext [
 
@@ -316,23 +339,29 @@ PetOrdersRESTfulController >> initializeCommentsRequestHandler [
 PetOrdersRESTfulController >> initializeOrdersRequestHandler [
 
 	ordersRequestHandler := RESTfulRequestHandlerBuilder new
-		handling: 'orders'
-			locatingResourcesWith: [ :order :requestContext | ordersRepository identifierOf: order ]
-			extractingIdentifierWith: [ :httpRequest | self identifierIn: httpRequest ];
-		beHypermediaDrivenBy:
-				[ :builder :order :requestContext :orderLocation | self affect: builder withMediaControlsFor: order locatedAt: orderLocation ];
-		whenAccepting: self orderVersion1dot0dot0MediaType
-			decodeFromJsonApplying: [ :json :reader | self configureOrderDecodingOn: reader ];
-		whenResponding: self orderVersion1dot0dot0MediaType
-			encodeToJsonApplying: [ :resource :requestContext :writer | self configureOrderEncodingOn: writer within: requestContext ]
-			as: #Order;
-		createEntityTagHashing: [ :hasher :order :requestContext | 
-			hasher
-				include: ( ordersRepository identifierOf: order );
-				include: ( ordersRepository lastModificationOf: order )
-			];
-		directCachingWith: [ :caching | caching beAvailableFor: 1 minute ];
-		build
+		                        handling: 'orders'
+		                        locatingResourcesWith: [ :order :requestContext |
+			                        ordersRepository identifierOf: order ]
+		                        extractingIdentifierWith: [ :httpRequest | self identifierIn: httpRequest ];
+		                        beHypermediaDrivenBy: [ :builder :order :requestContext :orderLocation |
+			                        self affect: builder withMediaControlsFor: order locatedAt: orderLocation ];
+		                        whenAccepting: self orderVersion1dot0dot0MediaType
+		                        decodeFromJsonApplying: [ :json :reader |
+			                        self configureOrderDecodingOn: reader ];
+		                        whenAccepting: self overlyComplexOrderVersion1dot0dot0MediaType
+		                        decodeFromJsonApplying: [ :json :reader |
+			                        self configureOverlyComplexOrderDecodingOn: reader ];
+		                        whenResponding: self orderVersion1dot0dot0MediaType
+		                        encodeToJsonApplying: [ :resource :requestContext :writer |
+			                        self configureOrderEncodingOn: writer within: requestContext ]
+		                        as: #Order;
+		                        createEntityTagHashing: [ :hasher :order :requestContext |
+			                        hasher
+				                        include: ( ordersRepository identifierOf: order );
+				                        include: ( ordersRepository lastModificationOf: order )
+			                        ];
+		                        directCachingWith: [ :caching | caching beAvailableFor: 1 minute ];
+		                        build
 ]
 
 { #category : 'initialization' }
@@ -370,6 +399,12 @@ PetOrdersRESTfulController >> orderVersion1dot0dot0MediaType [
 	^ self jsonMediaType: 'order' vendoredBy: 'stargate' version: '1.0.0'
 ]
 
+{ #category : 'private' }
+PetOrdersRESTfulController >> overlyComplexOrderVersion1dot0dot0MediaType [
+
+	^ self jsonMediaType: 'overly-complex-order' vendoredBy: 'stargate' version: '1.0.0'
+]
+
 { #category : 'private' }
 PetOrdersRESTfulController >> requestHandler [
 

source/Stargate-NeoJSON-Extensions/InstanceCreationMapping.class.st

@@ -0,0 +1,81 @@
+"
+I am NeoJSONStrictObjectMapping, I'm equivalent to NeoJSONObjectMapping but more strict.
+I will fail on reading properties of an object if some of the mapped properties are missing in the incoming JSON.
+
+"
+Class {
+	#name : 'InstanceCreationMapping',
+	#superclass : 'NeoJSONObjectMapping',
+	#instVars : [
+		'instanceCreationSelector',
+		'argumentNames'
+	],
+	#category : 'Stargate-NeoJSON-Extensions',
+	#package : 'Stargate-NeoJSON-Extensions'
+}
+
+{ #category : 'private' }
+InstanceCreationMapping >> errorDescriptionForMissing: propertyNames [
+
+	^ String streamContents: [ :stream |
+		  stream
+			  nextPutAll: 'Missing required keys';
+			  space;
+			  nextPut: $(.
+		  propertyNames
+			  do: [ :propertyName |
+				  stream
+					  nextPut: $#;
+					  nextPutAll: propertyName
+				  ]
+			  separatedBy: [
+				  stream
+					  nextPut: $,;
+					  space
+				  ].
+		  stream nextPut: $)
+		  ]
+]
+
+{ #category : 'mapping' }
+InstanceCreationMapping >> mapCreationSending: anInstanceCreationSelector withArguments: anArgumentCollection [
+
+	instanceCreationSelector := anInstanceCreationSelector.
+	argumentNames := anArgumentCollection
+]
+
+{ #category : 'mapping' }
+InstanceCreationMapping >> mapProperty: aKey [
+
+	^ self
+		  mapProperty: aKey
+		  getter: [ :object |  ]
+		  setter: [ :arguments :value | arguments at: aKey put: value ]
+]
+
+{ #category : 'mapping' }
+InstanceCreationMapping >> mapProperty: aKey as: aValueSchema [
+
+	( self mapProperty: aKey ) valueSchema: aValueSchema
+]
+
+{ #category : 'parsing' }
+InstanceCreationMapping >> readFrom: jsonReader [
+
+	| argumentByName arguments missingArguments |
+
+	argumentByName := Dictionary new.
+	jsonReader parseMapKeysDo: [ :key |
+		( self propertyNamed: key ifAbsent: [ nil ] )
+			ifNil: [ "read, skip & ignore value" jsonReader next ]
+			ifNotNil: [ :mapping | mapping readObject: argumentByName from: jsonReader ]
+		].
+
+	missingArguments := OrderedCollection new.
+	arguments := argumentNames collect: [ :argumentName |
+		             argumentByName at: argumentName ifAbsent: [ missingArguments add: argumentName ] ].
+	missingArguments ifNotEmpty: [
+		jsonReader error: ( self errorDescriptionForMissing: missingArguments ) ].
+
+	^ subjectClass perform: instanceCreationSelector withArguments: arguments
+]

source/Stargate-NeoJSON-Extensions/NeoJSONReader.extension.st

@@ -1,5 +1,15 @@
 Extension { #name : 'NeoJSONReader' }
 
+{ #category : '*Stargate-NeoJSON-Extensions' }
+NeoJSONReader >> for: schemaName createInstanceUsing: block [
+
+	| mapping |
+
+	mapping := self instanceCreationMappingFor: schemaName.
+	block value: mapping.
+	^ mapping
+]
+
 { #category : '*Stargate-NeoJSON-Extensions' }
 NeoJSONReader >> for: schemaName strictDo: block [
 
@@ -10,6 +20,16 @@ NeoJSONReader >> for: schemaName strictDo: block [
 	^ mapping
 ]
 
+{ #category : '*Stargate-NeoJSON-Extensions' }
+NeoJSONReader >> instanceCreationMappingFor: smalltalkClass [
+
+	^ self mappings at: smalltalkClass ifAbsentPut: [
+		  InstanceCreationMapping new
+			  subjectClass: smalltalkClass;
+			  yourself
+		  ]
+]
+
 { #category : '*Stargate-NeoJSON-Extensions' }
 NeoJSONReader >> strictMappingFor: smalltalkClass [