Merge pull request #111 from ba-st/improvingTransactionsInRepositories

Improving transactions in repositories
ba-st · Sep 25, 2024 · e3606a6 · e3606a6
2 parents 46972d7 + 4a5de0a
commit e3606a6
Show file tree

Hide file tree

Showing 6 changed files with 186 additions and 48 deletions.
diff --git a/source/Sagan-Core-Tests/RepositoryBasedTest.class.st b/source/Sagan-Core-Tests/RepositoryBasedTest.class.st
@@ -603,12 +603,9 @@ RepositoryBasedTest >> testUpdateInSameSessionAsFetch [
 
 	stallone := self silvesterStallone.
 	self extraterrestrials
-		transact: [ self extraterrestrials
-				withOneMatching: [ :extraterrestrial | extraterrestrial firstName = 'John' ]
-				do: [ :lock | self extraterrestrials update: lock with: stallone ]
-				else: [ self fail ]
-			].
-
+		withOneMatching: [ :extraterrestrial | extraterrestrial firstName = 'John' ]
+		do: [ :lock | self extraterrestrials update: lock with: stallone ]
+		else: [ self fail ].
 	self assertTheOnlyOneInTheRepositoryIsSilvesterStallone
 ]
 
@@ -784,9 +781,8 @@ RepositoryBasedTest >> testWithOneWhereIsDoElse [
 RepositoryBasedTest >> updateExtraterrestrialMatching: aBlock with: aNewExtraterrestrial [
 
 	self extraterrestrials
-		transact: [ self extraterrestrials
-				withOneMatching: aBlock
-				do: [ :extraterrestrial | self extraterrestrials update: extraterrestrial with: aNewExtraterrestrial ]
-				else: [ self fail ]
-			]
+		withOneMatching: aBlock
+		do: [ :extraterrestrial |
+			self extraterrestrials update: extraterrestrial with: aNewExtraterrestrial ]
+		else: [ self fail ]
 ]
diff --git a/source/Sagan-Core/RepositoryBehavior.class.st b/source/Sagan-Core/RepositoryBehavior.class.st
@@ -131,9 +131,11 @@ RepositoryBehavior >> matchingCriteriaBuilder [
 { #category : 'management' }
 RepositoryBehavior >> purge: aDomainObject [
 
-	^ self
-		assertIncludes: aDomainObject;
-		purgeAfterCheckingInclusion: aDomainObject
+	^ self transact: [
+			  self
+				  assertIncludes: aDomainObject;
+				  purgeAfterCheckingInclusion: aDomainObject
+		  ]
 ]
 
 { #category : 'private - management' }
@@ -151,9 +153,11 @@ RepositoryBehavior >> purgeAllMatching: aCriteria [
 { #category : 'management' }
 RepositoryBehavior >> store: aDomainObject [
 
-	^ self
-		assertNoConflictsFor: aDomainObject;
-		storeAfterCheckingConflicts: aDomainObject
+	^ self transact: [
+			  self
+				  assertNoConflictsFor: aDomainObject;
+				  storeAfterCheckingConflicts: aDomainObject
+		  ]
 ]
 
 { #category : 'private - management' }
@@ -177,10 +181,12 @@ RepositoryBehavior >> update: aDomainObject executing: aBlock [
 { #category : 'management' }
 RepositoryBehavior >> update: aDomainObject with: anUpdatedDomainObject [
 
-	^ self
-		assertIncludes: aDomainObject;
-		assertNoConflictsFor: anUpdatedDomainObject excluding: aDomainObject;
-		updateAfterCheckingConflicts: aDomainObject with: anUpdatedDomainObject
+	^ self transact: [
+			  self
+				  assertIncludes: aDomainObject;
+				  assertNoConflictsFor: anUpdatedDomainObject excluding: aDomainObject;
+				  updateAfterCheckingConflicts: aDomainObject with: anUpdatedDomainObject
+		  ]
 ]
 
 { #category : 'private - management' }

diff --git a/source/Sagan-GemStone-Tests/GemStoneRepositoryProviderTest.class.st b/source/Sagan-GemStone-Tests/GemStoneRepositoryProviderTest.class.st
@@ -19,36 +19,46 @@ GemStoneRepositoryProviderTest >> pickTwoElementsFrom: aQuery [
 ]
 
 { #category : 'initialization' }
-GemStoneRepositoryProviderTest >> setUpRepositoryWith: aConflictCheckingStrategy [
+GemStoneRepositoryProviderTest >> setUpRepositoryProvidedBy: aGemStoneRepositoryProvider with: aConflictCheckingStrategy [
 
-	extraterrestrials := GemStoneRepositoryProvider new
+	extraterrestrials := aGemStoneRepositoryProvider
 		                     createRepositoryStoringObjectsOfType: Extraterrestrial
 		                     checkingConflictsAccordingTo: aConflictCheckingStrategy.
 	extraterrestrials configureWith: [ :repository |
-		repository
-			indexByEquality: 'firstName' typed: String;
-			indexByEquality: 'lastName' typed: String
+			repository
+				indexByEquality: 'firstName' typed: String;
+				indexByEquality: 'lastName' typed: String
 		].
 	ships := GemStoneRepositoryProvider new
 		         createRepositoryStoringObjectsOfType: Spaceship
 		         checkingConflictsAccordingTo: aConflictCheckingStrategy
 ]
 
+{ #category : 'initialization' }
+GemStoneRepositoryProviderTest >> setUpRepositoryWith: aConflictCheckingStrategy [
+
+	self setUpRepositoryProvidedBy: GemStoneRepositoryProvider new with: aConflictCheckingStrategy
+]
+
+{ #category : 'initialization' }
+GemStoneRepositoryProviderTest >> setUpSemaphorizedRepositoryWaitingOn: aSemaphore [
+
+	self
+		setUpRepositoryProvidedBy: ( SemaphorizedGemStoneRepositoryProvider waitingOn: aSemaphore )
+		with: DoNotCheckForConflictsStrategy new
+]
+
 { #category : 'tests' }
 GemStoneRepositoryProviderTest >> testExceptionsAbortTransactionsUntilHandled [
 
 	self assert: self extraterrestrials findAll isEmpty.
-
-	self extraterrestrials transact: [
-		[
+	[
 		self extraterrestrials store: self silvesterStallone.
 		self assertTheOnlyOneInTheRepositoryIsSilvesterStallone.
 		1 / 0
-		]
-			on: ZeroDivide
-			do: [ :ex | ex return ]
-		].
-
+	]
+		on: ZeroDivide
+		do: [ :ex | ex return ].
 	self assertTheOnlyOneInTheRepositoryIsSilvesterStallone
 ]
 
@@ -500,6 +510,40 @@ GemStoneRepositoryProviderTest >> testTransactionLevelWithUnhandledException [
 	self assert: System transactionLevel equals: baseLevel
 ]
 
+{ #category : 'tests' }
+GemStoneRepositoryProviderTest >> testUpdateWithWhileAbbortTransactionsAreSignaled [
+
+	| stallone semaphore previous |
+
+	previous := System transactionMode.
+	[
+		System transactionMode: #manualBegin.
+		semaphore := Semaphore new.
+		self setUpSemaphorizedRepositoryWaitingOn: semaphore.
+		stallone := self silvesterStallone.
+		self extraterrestrials store: stallone.
+		self
+			assert: self extraterrestrials findAll size equals: 1;
+			assert: ( self extraterrestrials findAll includes: stallone ).
+		[
+			self
+				updateExtraterrestrialMatching: [ :extraterrestrial | extraterrestrial firstName = 'Silvester' ]
+				with: self johnLock
+		] fork.
+		Processor yield.
+		System inTransaction ifFalse: [ System abortTransaction ].
+		semaphore signal.
+		Processor yield.
+		self assert: self extraterrestrials findAll size equals: 1.
+		self extraterrestrials
+			withOneMatching: [ :extraterrestrial | extraterrestrial firstName = 'John' ]
+			do: [ :john | self assert: john lastName equals: 'Lock' ]
+			else: [ self fail ].
+		self assert: ( self extraterrestrials findAllMatching: [ :extraterrestrial |
+					  extraterrestrial lastName = 'Stallone' ] ) isEmpty
+	] ensure: [ System transactionMode: previous ]
+]
+
 { #category : 'utility' }
 GemStoneRepositoryProviderTest >> withAllSpaceshipsMatching: aMatchingCriteria do: aOneArgBlock [
 

diff --git a/source/Sagan-GemStone-Tests/SemaphorizedGemStoneRepository.class.st b/source/Sagan-GemStone-Tests/SemaphorizedGemStoneRepository.class.st
@@ -0,0 +1,32 @@
+"
+This class is specifically created for testing transaction management in crud services of repostiories
+"
+Class {
+	#name : 'SemaphorizedGemStoneRepository',
+	#superclass : 'GemStoneRepository',
+	#instVars : [
+		'semaphore'
+	],
+	#category : 'Sagan-GemStone-Tests',
+	#package : 'Sagan-GemStone-Tests'
+}
+
+{ #category : 'instance creation' }
+SemaphorizedGemStoneRepository class >> checkingConflictsAccordingTo: aConflictCheckingStrategy waitingOn: aSemaphore [
+
+	^ self new initializeCheckingConflictsAccordingTo: aConflictCheckingStrategy waitingOn: aSemaphore
+]
+
+{ #category : 'initialization' }
+SemaphorizedGemStoneRepository >> initializeCheckingConflictsAccordingTo: aConflictCheckingStrategy waitingOn: aSemaphore [
+
+	self initializeCheckingConflictsAccordingTo: aConflictCheckingStrategy.
+	semaphore := aSemaphore
+]
+
+{ #category : 'private - management' }
+SemaphorizedGemStoneRepository >> synchronize: aDomainObject with: anUpdatedDomainObject [
+
+	super synchronize: aDomainObject with: anUpdatedDomainObject.
+	semaphore wait
+]
diff --git a/source/Sagan-GemStone-Tests/SemaphorizedGemStoneRepositoryProvider.class.st b/source/Sagan-GemStone-Tests/SemaphorizedGemStoneRepositoryProvider.class.st
@@ -0,0 +1,58 @@
+"
+This class is specifically created for testing transaction management in crud services of repostiories
+"
+Class {
+	#name : 'SemaphorizedGemStoneRepositoryProvider',
+	#superclass : 'RepositoryProvider',
+	#instVars : [
+		'semaphore'
+	],
+	#category : 'Sagan-GemStone-Tests',
+	#package : 'Sagan-GemStone-Tests'
+}
+
+{ #category : 'instance creation' }
+SemaphorizedGemStoneRepositoryProvider class >> waitingOn: aSemaphore [
+
+	^ self new initializeWaitingOn: aSemaphore
+]
+
+{ #category : 'building' }
+SemaphorizedGemStoneRepositoryProvider >> createRepositoryStoringObjectsOfType: aBusinessObjectClass
+	checkingConflictsAccordingTo: aConflictCheckingStrategy [
+
+
+	^ SemaphorizedGemStoneRepository
+		  checkingConflictsAccordingTo: aConflictCheckingStrategy
+		  waitingOn: semaphore
+]
+
+{ #category : 'controlling' }
+SemaphorizedGemStoneRepositoryProvider >> destroyRepositories [
+
+	IndexManager current removeAllIndexes
+]
+
+{ #category : 'initialization' }
+SemaphorizedGemStoneRepositoryProvider >> initializeWaitingOn: aSemaphore [
+
+	semaphore := aSemaphore
+]
+
+{ #category : 'controlling' }
+SemaphorizedGemStoneRepositoryProvider >> prepareForInitialPersistence [
+
+
+]
+
+{ #category : 'controlling' }
+SemaphorizedGemStoneRepositoryProvider >> prepareForShutDown [
+
+
+]
+
+{ #category : 'initialization' }
+SemaphorizedGemStoneRepositoryProvider >> reset [
+
+
+]
diff --git a/source/Sagan-GemStone/GemStoneRepository.class.st b/source/Sagan-GemStone/GemStoneRepository.class.st
@@ -127,14 +127,12 @@ GemStoneRepository >> matchingCriteriaBuilder [
 { #category : 'private - management' }
 GemStoneRepository >> purgeAfterCheckingInclusion: aDomainObject [
 
-	^ self transact: [
-		  contents remove: aDomainObject ifAbsent: [
-			  DataInconsistencyFound signal:
-				  ( '<1p> was expected to be found in the contents, but it was not.' expandMacrosWith:
-					    aDomainObject )
-			  ].
-		  aDomainObject
-		  ]
+	contents remove: aDomainObject ifAbsent: [
+			DataInconsistencyFound signal:
+				( '<1p> was expected to be found in the contents, but it was not.' expandMacrosWith:
+					  aDomainObject )
+		].
+	^ aDomainObject
 ]
 
 { #category : 'management' }
@@ -153,10 +151,14 @@ GemStoneRepository >> saganGemStoneIndexOptions [
 { #category : 'private - management' }
 GemStoneRepository >> storeAfterCheckingConflicts: aDomainObject [
 
-	^ self transact: [
-		  contents add: aDomainObject.
-		  aDomainObject
-		  ]
+	contents add: aDomainObject.
+	^ aDomainObject
+]
+
+{ #category : 'private - management' }
+GemStoneRepository >> synchronize: aDomainObject with: anUpdatedDomainObject [
+
+	aDomainObject synchronizeWith: anUpdatedDomainObject
 ]
 
 { #category : 'management' }
@@ -175,8 +177,8 @@ GemStoneRepository >> update: aMutableDomainObject executing: aBlock [
 GemStoneRepository >> updateAfterCheckingConflicts: aDomainObject with: anUpdatedDomainObject [
 
 	self purgeAfterCheckingInclusion: aDomainObject.
-	[ aDomainObject synchronizeWith: anUpdatedDomainObject ] ensure: [
-		self storeAfterCheckingConflicts: aDomainObject ].
+	[ self synchronize: aDomainObject with: anUpdatedDomainObject ] ensure: [
+			self storeAfterCheckingConflicts: aDomainObject ].
 	^ aDomainObject
 ]