Mercurial Mercurial > hg > stx-goodies-monticello / diff
summary | shortlog | changelog | graph | tags | bookmarks | branches | files | changeset | file | latest | revisions | annotate | diff | comparison | raw | help
Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
MCHttpRepository.st
changeset 1053 86dccda75716
parent 1021 7ec8dc1c6c82
child 1069 5ea6b7f00935 
--- a/MCHttpRepository.st	Sun Aug 26 14:42:15 2018 +0200
+++ b/MCHttpRepository.st	Sun Aug 26 14:42:26 2018 +0200
@@ -8,24 +8,105 @@
 	instanceVariableNames:'location user password readerCache'
 	classVariableNames:''
 	poolDictionaries:''
-	category:'SCM-Monticello-Repositories'
+	category:'SCM-Monticello-RemoteRepositories'
 !
 
+!MCHttpRepository class methodsFor:'documentation'!
+
+documentation
+"
+    I am general http repository for monticello.
+    I support the general protocol for listing files in a remote repository.
+"
+! !
 
 !MCHttpRepository class methodsFor:'initialization'!
 
 clearPasswords
 	self allSubInstancesDo: [:ea | ea password: ''].
-
 ! !
 
 !MCHttpRepository class methodsFor:'instance creation'!
 
+basicFromUrl: aZnUrl
+	^ aZnUrl hasUsername
+		ifFalse: [ self location: aZnUrl location ]
+		ifTrue: [ (self repositoryClassFor: aZnUrl location) new
+				location: aZnUrl location;
+				user: aZnUrl username;
+				password: aZnUrl password;
+				yourself  ]
+!
+
+location: location
+	^ MCServerRegistry uniqueInstance 
+		repositoryAt: location credentialsDo: [ :username :password |
+			(self repositoryClassFor: location) new
+				location: location;
+				user: username;
+				password: password;
+				yourself ]
+!
+
 location: location user: user password: password
 	^ self new
 		location: location;
 		user: user;
 		password: password
+!
+
+pharoInboxRepository
+	^ self location: 'http://smalltalkhub.com/mc/Pharo/Pharo60Inbox/main'.
+!
+
+pharoRepository
+	^ self location: 'http://smalltalkhub.com/mc/Pharo/Pharo60/main'.
+!
+
+project: aProjectIdentifier
+	^ self location: self baseURL, aProjectIdentifier
+!
+
+repositoryClassFor: location
+	MCHttpRepository subclassesDo: [ :subclass | 
+		(subclass isResponsibleFor: location)
+			ifTrue: [ ^ subclass ]].
+	^ MCHttpRepository
+! !
+
+!MCHttpRepository class methodsFor:'*Komitter-Models'!
+
+pharoLocations
+	"Answer the locations for both pharo and pharo inbox repositories.
+	No commit should actually be pushed directly there"
+
+	^ #('http://smalltalkhub.com/mc/Pharo/Pharo60/main' 
+		'http://smalltalkhub.com/mc/Pharo/Pharo60/main/' 
+		'http://smalltalkhub.com/mc/Pharo/Pharo60Inbox/main'
+		'http://smalltalkhub.com/mc/Pharo/Pharo60Inbox/main/'
+		'http://smalltalkhub.com/mc/Pharo/Pharo50Inbox/main'
+		'http://smalltalkhub.com/mc/Pharo/Pharo50Inbox/main/')
+! !
+
+!MCHttpRepository class methodsFor:'*MonticelloGUI'!
+
+fillInTheBlankRequest
+	^ 'HTTP Repository:'
+			
+!
+
+morphicConfigure
+	^ self fillInTheBlankConfigure
+! !
+
+!MCHttpRepository class methodsFor:'accessing'!
+
+baseURL
+	^ ''
+!
+
+urlSchemes
+	^ #(http https)
 ! !
 
 !MCHttpRepository class methodsFor:'queries'!
@@ -39,7 +120,7 @@
 
 creationTemplateLocation: location user: user password: password
         ^
-'MCHttpRepository
+self name,'
         location: %1
         user: %2
         password: %3' 
@@ -48,14 +129,59 @@
             with: password storeString
 
     "Modified: / 16-09-2010 / 14:34:12 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+    "Modified: / 26-08-2018 / 14:28:47 / Claus Gittinger"
 !
 
 description
 	^ 'HTTP'
 ! !
 
+!MCHttpRepository class methodsFor:'testing'!
+
+isResponsibleFor: aURLString
+	"Override in subclasses to enable custom instances for certain URLs"
+	^ true
+! !
+
+!MCHttpRepository methodsFor:'*Komitter-Models'!
+
+isPrivatePharoRepository
+	
+	^ self class pharoLocations includes: self location
+!
+
+isRemote
+	^ self isPrivatePharoRepository not
+!
+
+koRemote
+
+	^ KomitHttpRemote new
+		remote: self;
+		yourself
+! !
+
+!MCHttpRepository methodsFor:'*metacello-mc'!
+
+asRepositorySpecFor: aMetacelloMCProject
+
+	^(aMetacelloMCProject repositorySpec)
+		description:  self description;
+	 	type: 'http';
+		yourself
+! !
+
 !MCHttpRepository methodsFor:'accessing'!
 
+credentials
+	^ MCServerCredentials user: self user password: self password
+!
+
+credentials: mcServerCredentials
+	self user: mcServerCredentials username.
+	self password: mcServerCredentials password.
+!
+
 location
       ^location 
 !
@@ -73,7 +199,7 @@
 password
         self userAndPasswordFromSettingsDo: [:usr :pwd | ^pwd].
 
-        self user isEmpty ifTrue: [^password].
+        self user isEmpty ifTrue: [^password ? ''].
 
         [password isEmpty] whileTrue: [
                 | answer dialog |
@@ -91,12 +217,19 @@
         ].
 
         ^ password
+
+    "Modified: / 26-08-2018 / 12:37:33 / Claus Gittinger"
 !
 
 password: passwordString
 	password := passwordString
 !
 
+project
+	"Return a project name"
+	^ (self location splitOn: $/) last
+!
+
 user
 	self userAndPasswordFromSettingsDo: [:usr :pwd | ^usr].
 	"not in settings"
@@ -107,11 +240,7 @@
 	user := userString
 ! !
 
-!MCHttpRepository methodsFor:'as yet unclassified'!
-
-asCreationTemplate
-	^self class creationTemplateLocation: location user: user password: password
-!
+!MCHttpRepository methodsFor:'actions'!
 
 parseFileNamesFromStream: aStream
 	| names fullName |
@@ -121,10 +250,32 @@
 		aStream upTo: $".
 		aStream atEnd ifFalse: [
 			fullName := aStream upTo: $".
-			names add: fullName unescapePercents]].
+			names add: fullName urlDecoded ]].
 	^ names
 !
 
+retryOnCredentialRequest: aBlock
+	aBlock	on: MCPermissionDenied do: [ :error | |credentials| 
+		credentials := MCCredentialsRequest 
+							signalUrl: self location
+							username: self user
+							password: self password.
+		credentials 
+			ifNotNil: [ 
+				self credentials: credentials.
+				^ self retryOnCredentialRequest: aBlock ]]
+!
+
+urlForFileNamed: aString
+	^ self locationWithTrailingSlash, aString urlEncoded
+! !
+
+!MCHttpRepository methodsFor:'as yet unclassified'!
+
+asCreationTemplate
+	^self class creationTemplateLocation: location user: user password: password
+!
+
 userAndPasswordFromSettingsDo: aBlock
 	"The mcSettings file in ExternalSettings preferenceDirectory should contain entries for each account:
 	
@@ -184,12 +335,94 @@
     "Created: / 14-09-2010 / 23:20:23 / Jan Vrany <jan.vrany@fit.cvut.cz>"
 ! !
 
-!MCHttpRepository methodsFor:'queries'!
+!MCHttpRepository methodsFor:'i/o'!
+
+cacheRawVersionNamed: aString stream: contents
+	"directly forward the contents to the cache repository. 
+	this avoids and unnecessary serialization step"
+	MCCacheRepository uniqueInstance 
+		writeStreamForFileNamed: aString 
+		replace: true 
+		do: [ :s| s nextPutAll: contents ]
+!
+
+displayProgress: label during: workBlock
+	| nextUpdateTime |
+	nextUpdateTime := 0.
+	^UIManager default displayProgress: label 
+		from: 0.0 to: 1.0 during:[:bar|
+			[workBlock value] on: HTTPProgress do:[:ex|
+				(ex total == nil or: [ex amount == nil]) ifFalse:[
+					(nextUpdateTime < Time millisecondClockValue 
+						or:[ex total = ex amount]) ifTrue:[
+							bar current: ex amount asFloat / ex total asFloat.
+							nextUpdateTime := Time millisecondClockValue + 100.
+					].
+				].
+				ex resume.
+			]
+		].
+!
+
+handleUnsuccessfulResponse: aZnResponse
+	(#(403 401) includes: aZnResponse code)
+		ifTrue: [ MCPermissionDenied signalFor: self ].
+	Error signal: 'Could not save version.'
+!
 
-urlForFileNamed: aString
-        ^ self locationWithTrailingSlash, aString utf8Encoded
+loadAllFileNames
+	| client |
+	self displayProgress: 'Loading all file names from ', self description during: [
+		client := self httpClient.
+		client
+			ifFail: [ :exception | 
+				(exception className beginsWith: 'Zn')
+					ifTrue: [ MCRepositoryError signal: 'Could not access ', self location, ': ', exception printString ]
+					ifFalse: [ exception pass ] ];
+			url: self locationWithTrailingSlash;
+			queryAt: 'C' put: 'M;O=D';	"legacy that some servers maybe expect"
+			get.
+		self assertNonBinaryResponse: client response ].
+	^ self parseFileNamesFromStream: client contents readStream
+! !
+
+!MCHttpRepository methodsFor:'private'!
+
+assertBinaryResponse: response 
+
+	response contentType isBinary ifFalse: [ 
+		MCRepositoryError signal: 'Expected a binary response instead of ', response contentType printString ].
+!
 
-    "Modified: / 14-09-2010 / 19:32:19 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+assertNonBinaryResponse: response 
+	
+	response contentType isBinary ifTrue: [ MCRepositoryError signal: 'Did not expect a binary response but got ', response contentType printString ].
+!
+
+entityStreamContents: aBlock
+	"Generate output in a buffer because we need the length"
+	
+	| stream |
+	stream := RWBinaryOrTextStream on: String new.
+	aBlock value: stream.
+	stream reset.
+	^ (ZnStreamingEntity type: ZnMimeType applicationOctetStream)
+		stream: stream;
+		contentLength: stream size;
+		yourself
+!
+
+httpClient
+	"Return a new, specifically configured instance of the HTTP client for internal use.
+	Note how we request GZIP compression and will signal progress."
+
+	^ ZnClient new
+		systemPolicy;
+		beOneShot;
+		username: self user password: self password;
+	
+		signalProgress: true;
+		yourself
 ! !
 
 !MCHttpRepository methodsFor:'required'!
@@ -219,9 +452,15 @@
     | response |
     response := HTTPInterface get: (self urlForFileNamed: aString) userName: self user password: self password.
     ^response responseCode == 200 
-        ifTrue: [aBlock value: response data readStream].
+        ifTrue: [
+            "/ self assertBinaryResponse: client response.
+            "immediately cache the version and avoid an unnecessary serialization"
+            "/ self cacheRawVersionNamed: aString stream: client contents ].
+            aBlock value: response data readStream.
+        ].
 
     "Modified: / 14-09-2010 / 19:38:21 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+    "Modified (format): / 26-08-2018 / 14:17:03 / Claus Gittinger"
 !
 
 writeStreamForFileNamed: aString replace: ignoreBoolean do: aBlock
@@ -239,6 +478,12 @@
 			ifFalse: [self error: response].
 ! !
 
+!MCHttpRepository methodsFor:'storing'!
+
+storeVersion: aVersion
+	self retryOnCredentialRequest: [ super storeVersion: aVersion ]
+! !
+
 !MCHttpRepository class methodsFor:'documentation'!
 
 version
hg/stx-goodies-monticello