'From Croqtober of 11 November 2005 [latest update: #126] on 12 January 2006 at 9:23:27 pm'!
Smalltalk renameClassNamed: #SlaveForVDesktopTablet as: #RfbServerMaker!
Object subclass: #RfbServerMaker
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Croquet-Atlanta'!

!RfbServerMaker commentStamp: 'strick 1/12/2006 00:52' prior: 0!
RFBServerServerClient is the squeak client object that makes HTTP requests to the RFBServerServer (currently an HTTP server written in Python), which allocates RFB servers for the sake of VDesktopTablet.

The four services available:

  * rpcEcho: aString        -- just for testing

  * rpcLaunchServerForDocumentUrl: aUrlString objectId: anIdString   
							-- request launching a new server (or connecting to existing one)

  * rpcListServers             -- status display

  * rpcShutdownAllServers       -- shut down everything

Configure the location of the server with these hardcoded methods, or define them to get from somewhere else:

  * httpServerHostAddress       -- answers the host address, as a string

  * httpServerPortNumber      -- answers the port number, as an Integer

Internally, requests are made with a HTTP GET command, with one verb '/echo', '/launch', '/list', or '/shutdown', and any arguments are in the query portion of the URL.
Results are in trivial XML, with either #answer tags or #error tags at the second level, e.g.
     '<results> <answer>42</answer> </results'
or
	'<failure> <error>Server cannot fork another process</error> </failure>'
!

Smalltalk renameClassNamed: #RfbServerServerClientTest as: #RfbServerMakerTests!
TestCase subclass: #RfbServerMakerTests
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Croquet-Atlanta'!

!RfbServerMakerTests commentStamp: 'strick 1/12/2006 01:12' prior: 0!
SUnit Tests for RfbServerServerClient.

PRINT IT:
	RfbServerServerClientTests buildSuite run


PREREQUISITE:

    An RfbServerServer (currently written in Python) must be running at the address returned by RfbServerServer>>httpServerHostAddress and RfbServerServer>>httpServerPortNumber.

!


!CroquetObjects class methodsFor: 'objects' stamp: 'strick 1/12/2006 15:57'!
makeDesktop: urlString
	
	| z |
"
	FileDirectory deleteFilePath: 'home.c3d.'.  HedgemineMorph new openInWorld
"
"
	^ self makeRFBViewer: urlString.
"
	z := VDesktopTablet new initialize.
	z modelUrl: urlString.
	^ z
! !

!CroquetObjects class methodsFor: 'objects' stamp: 'strick 1/12/2006 18:20'!
makeRFBViewer: relativePath
	| tm pageExtent teaWorld world morph client hostAddr hostPort socket displayNumber |
"
	FileDirectory deleteFilePath: 'home.c3d.'.  HedgemineMorph new openInWorld
"

	"strick TODO: a better way than hardwiring 800x600"
	pageExtent := 800@600.
	tm _ TMorphic new initializeOpaque: true extent: pageExtent; yourself.
	teaWorld _ TMorphMonitor new initializeWithWorld: nil extent: pageExtent; yourself.
	teaWorld eventsTo: tm.
	world := teaWorld world.

	displayNumber := 
	  RfbServerMaker	rpcLaunchServerForDocumentUrl: relativePath objectId: '00000'.

	hostAddr := NetNameResolver addressFromString: '127.0.0.1'.
	hostPort := 5901.
	hostAddr := NetNameResolver addressForName: RfbServerMaker httpServerHostAddress timeout: 8.
	hostPort := 5900 + displayNumber.



	client := RFBClient new.	
	client target: teaWorld. "????"
	morph := client asMorph.
	world addMorph: morph.

	socket _ RFBClientSocket newTCP.

	[
		socket connectTo: hostAddr port: hostPort.
		client connectTo: socket
	] on: Error do:[:ex| ex return].

	client isConnected ifFalse:[
		socket ifNotNil:[socket destroy].
		Transcript cr; show: 'RFB Client failed to connect.'; endEntry.
		Smalltalk beep.
	].

	morph bounds: world bounds.
	morph visible: true.
	
	^tm.

	

! !

!CroquetObjects class methodsFor: 'objects' stamp: 'strick 1/12/2006 21:09'!
makeRFBViewer: relativePath objectId: objectId
	| tm pageExtent teaWorld world morph client hostAddr hostPort socket displayNumber |
"
	FileDirectory deleteFilePath: 'home.c3d.'.  HedgemineMorph new openInWorld
"

	"strick TODO: a better way than hardwiring 800x600"
	pageExtent := 800@600.
	tm _ TMorphic new initializeOpaque: true extent: pageExtent; yourself.
	teaWorld _ TMorphMonitor new initializeWithWorld: nil extent: pageExtent; yourself.
	teaWorld eventsTo: tm.
	world := teaWorld world.
"<<
	hostAddr := NetNameResolver addressFromString: '127.0.0.1'.
	hostPort := 5901.
>>"
	displayNumber := 
	  RfbServerMaker new 
		rpcLaunchServerForDocumentUrl: relativePath objectId: objectId.

	hostAddr := NetNameResolver 
	  addressForName: RfbServerMaker new httpServerHostAddress timeout: 8.
	hostPort := 5900 + displayNumber.



	client := RFBClient new.	
	client target: teaWorld. "????"
	morph := client asMorph.
	world addMorph: morph.

	socket _ RFBClientSocket newTCP.

	[
		socket connectTo: hostAddr port: hostPort.
		client connectTo: socket
	] on: Error do:[:ex| ex return].

	client isConnected ifFalse:[
		socket ifNotNil:[socket destroy].
		Transcript cr; show: 'RFB Client failed to connect.'; endEntry.
		Smalltalk beep.
	].

	morph bounds: world bounds.
	morph visible: true.
	
	^tm.

	

! !

!CroquetObjects class methodsFor: 'objects' stamp: 'strick 1/9/2006 15:57'!
makeWebPage: url extent: pageExtent
	"Create a TMorphic containing nothing but a web page.
	Hack scamper not to show up - it's just *way* to ugly."
	| world scamper window page tm teaWorld |

	tm _ TMorphic new initializeOpaque: true extent: pageExtent.
	teaWorld _ TMorphMonitor new initializeWithWorld: nil extent: pageExtent.
	teaWorld eventsTo: tm.
	world := teaWorld world.
	scamper := Scamper new.
	window := scamper morphicWindow.
	world addMorph: window.
	page := window findA: WebPageMorph. "heh, heh"
	world addMorphFront: page.
	page bounds: world bounds.
	window visible: false.
	scamper jumpToUrl: url asUrl.
	^tm
! !


!RfbServerMaker methodsFor: 'as yet unclassified' stamp: 'strick 1/12/2006 01:02'!
getAnswersFromXml: xml
	
	| errorList answerList |

	"first, look for any #error tags"
	errorList := self getDataFromXml: xml withTag: #error.

	"if there are any, report them as error"
	(errorList size > 0) ifTrue: [
		self error:
			(errorList inject: 'request failed' into: [ :z :e | z, ' : ', e ]) 
	].

	"otherwise, look for answers"
	answerList := self getDataFromXml: xml withTag: #answer.

	"should always be at least one"
	(answerList size < 1) ifTrue: [
		self error: 'request failed: no answers'
	].

	"return the list of answers.  (if you expect only one, take first)"
	^ answerList
! !

!RfbServerMaker methodsFor: 'as yet unclassified' stamp: 'strick 1/10/2006 22:06'!
getDataFromXml: someXml withTag: aTag

	| z document | 

	z := OrderedCollection new. 

	document := XMLDOMParser
					parseDocumentFrom: 
						(ReadStream on: someXml).

	document tagsNamed: aTag do: [:x | 
		z add: x characterData
	].

	^ z! !

!RfbServerMaker methodsFor: 'as yet unclassified' stamp: 'strick 1/10/2006 20:44'!
httpGetWithAbsoluteUrl: anAbsoluteUrl

	"
	self new httpGetWithAbsoluteUrl: 'http://google.com/'
	"

	^ (Url absoluteFromText: anAbsoluteUrl) retrieveContents content! !

!RfbServerMaker methodsFor: 'as yet unclassified' stamp: 'strick 1/10/2006 21:58'!
httpGetWithPath: aPath 

	"aPath is of form  /verb?query=stuff

	self new httpGetWithPath: '/echo?wish=
	"

	| absoluteUrl |
	aPath first = $/ ifFalse: [
		self error: 'aPath should begin with /'
	].

	absoluteUrl := 'http://', self httpServerHostAddress, ':', self httpServerPortNumber asString, aPath.

	^ self httpGetWithAbsoluteUrl: absoluteUrl
! !

!RfbServerMaker methodsFor: 'as yet unclassified' stamp: 'strick 1/10/2006 21:21'!
httpServerHostAddress

	"EDIT THIS METHOD to find the HTTP server address"

	^ '127.0.0.1'! !

!RfbServerMaker methodsFor: 'as yet unclassified' stamp: 'strick 1/10/2006 20:34'!
httpServerPortNumber

	"EDIT THIS METHOD to find the HTTP server port.

	The suggested default is 5899, one less than 5900, where the RFB servers ports normally begin"

	^ 5899! !

!RfbServerMaker methodsFor: 'as yet unclassified' stamp: 'strick 1/12/2006 00:41'!
rpcEcho: stuff

	"A service of the RfbServerServer, for testing upness "

	| request reply |

	"The /echo verb expects one query thing named 'what' "

	request := '/echo?what=', stuff encodeForHTTP.

	reply := self httpGetWithPath: request.

	"expect only one answer, to take the first"

	^ (self getAnswersFromXml: reply) first! !

!RfbServerMaker methodsFor: 'as yet unclassified' stamp: 'strick 1/12/2006 00:41'!
rpcLaunchServerForDocumentUrl: aDocumentUrl objectId: anId

	| request reply |

	request := '/launch?id=', anId encodeForHTTP, '&url=', aDocumentUrl encodeForHTTP.

	reply := self httpGetWithPath: request.

	^ (self getAnswersFromXml: reply) first! !

!RfbServerMaker methodsFor: 'as yet unclassified' stamp: 'strick 1/12/2006 00:41'!
rpcListServers

	| request reply |

	request := '/list'.

	reply := self httpGetWithPath: request.

	^ self getAnswersFromXml: reply! !

!RfbServerMaker methodsFor: 'as yet unclassified' stamp: 'strick 1/12/2006 00:41'!
rpcShutdownAllServers

	| request reply |

	request := '/shutdown'.

	reply := self httpGetWithPath: request.

	self getAnswersFromXml: reply! !


!RfbServerMakerTests methodsFor: 'as yet unclassified' stamp: 'strick 1/12/2006 19:09'!
testBogus

	"
	self new testBogus
	"

	
"	self should: [
		RfbServerMaker new httpGetWithPath: '/bogus'
	] raise: Exception.
"
"
	| gotError |
	gotError := false.
	[
		RfbServerMaker new httpGetWithPath: '/bogus'
	] on: Exception do: [
		gotError := true
	].

	self assert: gotError.
"

"*********** I don't know how to write this negativd test *************"


	^ #ok! !

!RfbServerMakerTests methodsFor: 'as yet unclassified' stamp: 'strick 1/12/2006 18:21'!
testEcho

	"
	self new testEcho
	"

	| answer x |

	"The /echo verb should echo back the query stuff in some manner."

	x :=  'pb&j?=peanutButter+Jelly', (Character value: 1) asString, (Character value: 250) asString.

	answer := RfbServerMaker new rpcEcho: x.

	self assert: ( x = answer ).
 
	^ #ok! !

!RfbServerMakerTests methodsFor: 'as yet unclassified' stamp: 'strick 1/12/2006 19:06'!
testLaunch

	"
	self new testLaunch
	"

	| answer x |


	x :=  'http://www.google.com'.

	answer := RfbServerMaker new rpcLaunchServerForDocumentUrl: x objectId: 'testLaunch'.

	self assert: answer isAllDigits.
 
	^ #ok! !


!VObject methodsFor: 'actions' stamp: 'strick 1/10/2006 15:22'!
addChess
	self positionNewObject: CroquetObjects makeChess.! !

!VObject methodsFor: 'actions' stamp: 'hrs 12/21/2005 09:11'!
addText
	self positionNewObject: VText new.! !


!VComponent methodsFor: 'events' stamp: 'strick 1/10/2006 15:18'!
handleCharacter: c 
	| d p | 
	c = $c "cube" ifTrue: [^ self addCube].
	c = $d "dragger" ifTrue: [   "I'm not sure we need persistent draggers.
					Modal, non-replicated EditBoxes in the View may be sufficent."
		p _ self parent.
		p removeChild: self.
		(self isKindOf: VDragger)
			ifTrue: [
				d _ self contents.
				d localTransform: self localTransform. 
				d objectOwner: d.
				p addChild: d.
				]
			ifFalse: [
				d _ VDragger new.
				p addChild: d.
				d contents: self.
				].	
		^self.
		].
	c = $i "import" ifTrue: [^ self addImport.].
	c = $f "import" ifTrue: [^ self addImportFromFile.].
	c = $l "light" ifTrue: [self error: '', c, ' not implemented yet.'].
	c = $m "microphone" ifTrue: [self error: '', c, ' not implemented yet.'].
	c = $M ifTrue: [^ self addMirror].
	c = $r "room" ifTrue: [^ self addRoom].
	c = $t "text" ifTrue: [^ self addText].
	c = $w "world" ifTrue: [^self addWorld.].
	c = $v "video" ifTrue: [^ self addWebcam.].
	c = $x "chess" ifTrue: [ ^ self addChess ]
! !


!VDesktopTablet methodsFor: 'accessing' stamp: 'strick 1/12/2006 17:59'!
modelUrl: aUrlNameString
	"This should, in general, bring up the appropriate application through VNC.
	However, I think we broke VNC somewhere along the way. Maybe with the materials 
	changes? 

	But we can still handle web pages (sort of) using Squeak's Scamper browser
	and Flash using Squeak's flash player."

	| on morphic objectId |
	url _ aUrlNameString asUrl.

	self flag: #FIXME. "TWindow gets confused when we try to set contents: in the wrong state.
		It would be better to fix this properly rather than use this kludge."
		
	on _ self primitiveGeometry contentsOn.
	on ifTrue: [self primitiveGeometry primitiveCloseContents].

	true ifTrue: [ "************ RFB" 

		"<<objectId := self island asFarRef: model.
		objectId ifNil: [ objectId := model hash ] ifNotNil: [ objectId := objectId myName ].
		>>"
		objectId := model hash.
		morphic := CroquetObjects makeRFBViewer: url toText objectId: objectId asString.

	]
	ifFalse: [ "*************** Flash & Scamper " 

	(url path last asUppercase endsWith: '.SWF')
		ifTrue: [morphic _ CroquetObjects 
					makeFlashMorphicFromStream: url retrieveContents contentStream
					extent: 720@480.]
		ifFalse: [morphic _  CroquetObjects makeWebPage: url extent: 720@480].
	].

	"morphic inspect."
	self primitiveGeometry contents: morphic.

	on ifTrue: [self primitiveGeometry primitiveOpenContents].


! !

!VDesktopTablet methodsFor: 'accessing' stamp: 'strick 1/10/2006 08:00'!
url: aUrl
	url _ aUrl.
	model ifNil: [self modelUrl: aUrl] ifNotNil: [
		self error: 'TODO:strick thinks model is never set for this object....'.
		model future url: aUrl asString
	].! !

TDesktopTablet removeSelector: #initialize!
RfbServerMaker removeSelector: #echo:!
RfbServerMaker removeSelector: #httpGetAbsoluteUrl:!
RfbServerMaker removeSelector: #httpGetPath:!
RfbServerMaker removeSelector: #httpServerHost!
RfbServerMaker removeSelector: #httpServerPort!
RfbServerMaker removeSelector: #launchServerForDocumentUrl:!
RfbServerMaker removeSelector: #launchServerForDocumentUrl:objectId:!
RfbServerMaker removeSelector: #listServers!
RfbServerMaker removeSelector: #parseXmlAndReturnAnswers:!
RfbServerMaker removeSelector: #serverHost!
RfbServerMaker removeSelector: #shutdownAllServers!