'From Croqtober of 11 November 2005 [latest update: #159] on 19 February 2006 at 7:17:18 pm'!
MTablet subclass: #MDesktopTablet
	instanceVariableNames: 'urlString desktopId '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Croquet-MVCR'!
Object subclass: #RFBClient
	instanceVariableNames: 'target image socket sendLock state process protocolMinor serverExtent serverFormat serverName updateRequestPending currentCursor savedCursor hasCursor modifierState zlibStream logClient complained '
	classVariableNames: 'CommandKeySym CtrlKeySym DefaultEncoding Enable8Bit EnableExpandOnBell EnableExpandOnConnection EnableShared EnableViewOnly EnableXCursor Encodings FastUpdate KeySyms MessageTypes ModifierMap OptionKeySym ProtocolMajor ProtocolMinor RfbEncodingAuto RfbEncodingCoRRE RfbEncodingCopyRect RfbEncodingHextile RfbEncodingLastRect RfbEncodingPointerPos RfbEncodingRRE RfbEncodingRaw RfbEncodingRichCursor RfbEncodingTight RfbEncodingXCursor RfbEncodingZRLE RfbEncodingZlib RfbEncodingZlibHex ShiftKeySym '
	poolDictionaries: 'EventSensorConstants '
	category: 'RFB-Viewer'!
TMorphic subclass: #TXrfbMorphic
	instanceVariableNames: 'XrfbClient '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Croquet-Xrfb'!
VTablet subclass: #VDesktopTablet
	instanceVariableNames: 'url desktopId '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Croquet-MVCR'!
AlignmentMorphBob1 subclass: #XrfbBasePanelMorph
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Croquet-Xrfb'!

!XrfbBasePanelMorph commentStamp: 'strick 2/11/2006 00:56' prior: 0!
XrfbBasePanelMorph is the base for the Control Panel and Server Configuration

!

RFBClient subclass: #XrfbClient
	instanceVariableNames: 'password '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Croquet-Xrfb'!
XrfbBasePanelMorph subclass: #XrfbControlPanelMorph
	instanceVariableNames: 'listButton cleanButton shutdownButton textArea '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Croquet-Xrfb'!

!XrfbControlPanelMorph commentStamp: 'strick 2/10/2006 23:10' prior: 0!
XrfbControlPanel --

A Morph for controlling the Xrfb Desktop Server daemon.

(* Much of this code stolen from TLoginMorph.  Thanks y'all. *)!

Error subclass: #XrfbHttpReplyException
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Croquet-Xrfb'!
XrfbBasePanelMorph subclass: #XrfbServerConfigMorph
	instanceVariableNames: 'hostBox portBox passwordBox '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Croquet-Xrfb'!
Object subclass: #XrfbServerMaker
	instanceVariableNames: 'outerMorph teaWorld world '
	classVariableNames: 'HttpServerHostAddress HttpServerPassword HttpServerPortNumber '
	poolDictionaries: ''
	category: 'Croquet-Xrfb'!

!XrfbServerMaker commentStamp: 'strick 1/17/2006 01:11' prior: 0!
RFBServerMaker is the squeak client object that makes HTTP requests to the VncServer.py (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>'
!

TestCase subclass: #XrfbServerMakerTests
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Croquet-Xrfb'!

!XrfbServerMakerTests commentStamp: 'strick 1/17/2006 01:14' prior: 0!
SUnit Tests for RfbServerMaker.

PRINT IT:
	RfbServerMakerTests buildSuite run


PREREQUISITE:

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

!


!CroquetObjects class methodsFor: 'objects' stamp: 'strick 2/8/2006 21:39'!
makeDesktop: urlString
	
	^ VDesktopTablet new
		initialize ;
		modelUrl: urlString desktopId: nil ;   "random id will be assigned"
		yourself
! !

!CroquetObjects class methodsFor: 'objects' stamp: 'strick 2/11/2006 04:05'!
makeRFBViewer: url objectId: objectId
	| tm pageExtent teaWorld world morph client hostAddr hostPort socket displayNumber 
		msg textMorph  |
"
	FileDirectory deleteFilePath: 'home.c3d.'.  HedgemineMorph new openInWorld
"

	"strick TODO: a better way than hardwiring 800x600"
	pageExtent := 800@600.

	tm _ TXrfbMorphic new initializeOpaque: true extent: pageExtent; yourself.
	teaWorld _ TMorphMonitor new initializeWithWorld: nil extent: pageExtent; yourself.
	teaWorld eventsTo: tm.
	world := teaWorld world.


	Transcript cr; show: 'makeRFBViewer: ', url, ' objectId: ', objectId.

	[
		displayNumber := 
		  XrfbServerMaker new 
			rpcLaunchServerForDocumentUrl: url objectId: objectId.
	] on: XrfbHttpReplyException do: [ :ex | 
		"Could not talk to Xrfb Server -- bad host, port, password, or it is not running"

		textMorph := TextMorph new
			beAllFont: ((TextStyle named: #ComicBold) fontOfSize: 32);
			backgroundColor: Color yellow;
			crAction: (MessageSend receiver: self selector: #yourself);
			extent: pageExtent;
			contentsWrapped: url, '
==================================
',ex messageText asText;
			setBalloonText: 'This decribes the error received when trying to connect to the Xrfb Desktop Server';
			centered;
			yourself.

		world addMorph: textMorph.
		^ tm
	].

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

		socket _ RFBClientSocket newTCP.
		socket connectTo: hostAddr port: hostPort.


		client := XrfbClient new
			setPassword: XrfbServerMaker new httpServerPassword;
			yourself.
		client target: teaWorld. "????"
		tm xrfbClient: client.   "<-----"
		morph := client asMorph.
		morph beSticky.
		world addMorph: morph.

	] on: Error do: [  :ex | 

			msg := url, '
==================================
An error occurred while trying to connect to the Xvnc desktop
at host ', hostAddr asString, ' port ', hostPort asString, '
---------------
', ex asString, '
---------------
', ex messageText.

		textMorph := TextMorph new
			beAllFont: ((TextStyle named: #ComicBold) fontOfSize: 32);
			backgroundColor: Color yellow;
			crAction: (MessageSend receiver: self selector: #yourself);
			extent: pageExtent;
			contentsWrapped: msg asText;
			setBalloonText: 'This decribes the error received when trying to connect to the Xrfb Desktop Server';
			centered;
			yourself.

		world addMorph: textMorph.
		^ tm
	].


	client connectTo: socket.

	client isConnected ifFalse:[

		" a little cleanup "
		socket ifNotNil:[socket destroy].
		morph delete.

		msg := url, '
==================================
RFBClient failed to connect.'.
		textMorph := TextMorph new
			beAllFont: ((TextStyle named: #ComicBold) fontOfSize: 32);
			backgroundColor: Color yellow;
			crAction: (MessageSend receiver: self selector: #yourself);
			extent: pageExtent;
			contentsWrapped: msg asText;
			setBalloonText: 'This decribes the error received when trying to connect to the Xrfb Desktop Server';
			centered;
			yourself.

		world addMorph: textMorph.
		^ tm
	].

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

	

! !


!HedgemineMenuBar methodsFor: 'menu' stamp: 'strick 2/11/2006 00:36'!
menuBarToolsMenu
	| menu morph |
	morph := TeapotMorph current.
	menu := CMenu new.

	menu add: 'Paste from clipboard to space' target: self action: #paste.
	menu addSeparator.

	menu add: 'Toggle Video' target: self action: #menuToggleVideo disabled: true.
	menu add: 'Snapshot' target: self action: #menuSnapshot disabled: false.
	menu add: 'Toggle Full Screen' target: morph action: #toggleFullScreen disabled: false.
	menu add: 'Terrain Tool' target: self action: #terrainTool disabled: true.

	menu add: 'Toggle Audio Chat' target: self action: #menuToggleAudio disabled: true.
	menu add: 'New Chat Window' target: self action: #chatWindow disabled: false.
	menu add: 'Xrfb Desktops Control Panel' target: self action: #xrfbControlPanel disabled: false.

	^menu
! !

!HedgemineMenuBar methodsFor: 'menu' stamp: 'strick 2/11/2006 01:35'!
xrfbControlPanel

	XrfbControlPanelMorph new openInWorld comeToFront! !


!MObject methodsFor: '*Strick' stamp: 'strick 2/19/2006 15:02'!
printOn: aStream 
	| aName |
	super printOn: aStream.
	(aName := self knownName) notNil 
		ifTrue: [aStream nextPutAll: '<' , aName , '>'].
	aStream nextPutAll: '('.
	aStream
		print: self identityHash;
		nextPutAll: ')'! !


!MDesktopTablet methodsFor: 'accessing' stamp: 'strick 2/8/2006 18:44'!
desktopId

	^ desktopId! !

!MDesktopTablet methodsFor: 'accessing' stamp: 'strick 2/8/2006 20:19'!
desktopId: anId

	desktopId := anId.

	
	Transcript cr; show: 'MDesktopTablet>>desktopId <- ', desktopId.! !

!MDesktopTablet methodsFor: 'accessing' stamp: 'strick 2/19/2006 16:07'!
url: aString
	urlString _ aString.


	Transcript cr; show: self asString, ' >>url <- ', aString.! !

!MDesktopTablet methodsFor: 'initialize' stamp: 'strick 2/19/2006 18:57'!
initializeView
	| tmpLabel |
	self flag: #FIXME. "There's a bug in TWindow that I don't understand and which we need
	to fix. It get's all confused about the #contents and #rectFront if they're not set in
	the right order when in the right state.  My temporary hack workaround is let the 
	label remain unitialized by super initializeView, and then set it ourselves after the url."


	Transcript cr; show: '###  MDesktopTablet ', self asString, ' initializeView ', Time millisecondClockValue asString, ' ###'.



	tmpLabel _ label. label _ nil.

	super initializeView.
	view modelUrl: self url desktopId: self desktopId.

	label _ tmpLabel.
	view modelLabel: label.

	! !


!RFBClient methodsFor: 'sending' stamp: 'strick 2/16/2006 17:36'!
sendData: aMessage
	"Send aMessage to the server.  Assure mutually-exclusive access to the socket."

	complained ifNil: [

	   sendLock critical:
		[[socket sendData: aMessage]
			on: Exception
			do: [:ex| 
					complained := true.
					self log: ex printString; abort]]
	].

! !


!Socket methodsFor: 'waiting' stamp: 'strick 2/19/2006 18:55'!
waitForSendDoneFor: timeout
	"Wait up until the given deadline for the current send operation to complete. Return true if it completes by the deadline, false if not."

	| sendDone deadline |
	deadline := Socket deadlineSecs: timeout.
	[self isConnected & (sendDone _ self primSocketSendDone: socketHandle) not
			"Connection end and final data can happen fast, so test in this order"
		and: [Time millisecondClockValue < deadline]] whileTrue: [
			self writeSemaphore waitTimeoutMSecs: (deadline - Time millisecondClockValue)].

	sendDone ifFalse: [
		Transcript cr; show: 
			 'DEADLINE=', deadline asString, ' NOW=', Time millisecondClockValue asString.
	].

	^ sendDone! !


!RFBSocket methodsFor: 'running' stamp: 'strick 2/19/2006 18:59'!
runSafely: aBlock
	"Repeatedly execute aBlock until the connection failes or an error is signaled.  If debugging is enabled in RFBServer, open a debugger on the error context for the purposes of developer enlightenment."

	[[[self isValid and: [self isConnected]] whileTrue: aBlock]
			on: Error
			do: [:ex |
				Transcript cr; show: Time millisecondClockValue asString, ' RFB: caught ' , ex printString.
				RFBServer debugging
					ifTrue:
						[Transcript endEntry.
						 self halt]]]
		ensure: [self closeAndDestroy]! !


!TFarRef methodsFor: 'accessing' stamp: 'strick 2/19/2006 17:42'!
printOn: aStream 
	| |
	super printOn: aStream.

	aStream 
		nextPutAll: '(';
		print: myValue asString;
		nextPutAll: ')'.
! !


!TObject methodsFor: '*Strick' stamp: 'strick 2/19/2006 15:00'!
printOn: aStream 
	| aName |
	super printOn: aStream.
	(aName := self knownName) notNil 
		ifTrue: [aStream nextPutAll: '<' , aName , '>'].
	aStream nextPutAll: '('.
	aStream
		print: self identityHash;
		nextPutAll: ')'! !


!TDesktopTablet methodsFor: 'as yet unclassified' stamp: 'strick 2/15/2006 17:56'!
removePortalFrames

	Transcript cr; show: '###  TDesktopTablet removePortalFrames ###'.

	^ super removePortalFrames
! !


!TXrfbMorphic methodsFor: 'as yet unclassified' stamp: 'Ryan 2/11/2006 03:40'!
handleEvent2D: someEvent pointer: pointer
	"Transcript cr; show: 'SomeEvent: ', someEvent, 'pointer: ',pointer."

	"super handleEvent2D: someEvent pointer: pointer."
	someEvent isMouse ifTrue: [
		XrfbClient processModifiers: someEvent buttons.
		XrfbClient sendPointerEvent: someEvent buttons position: someEvent position.
	].
	someEvent isKeyboard ifTrue: [
		someEvent type == #keyDown
			ifTrue:[XrfbClient keyDown: someEvent].
		someEvent type == #keystroke
			ifTrue:[XrfbClient keyStroke: someEvent].
		someEvent type == #keyUp
			ifTrue:[XrfbClient keyUp: someEvent].
].! !

!TXrfbMorphic methodsFor: 'as yet unclassified' stamp: 'Ryan 2/11/2006 03:33'!
xrfbClient: anXrfbClient
	XrfbClient _ anXrfbClient.! !


!TranscriptStream methodsFor: 'access' stamp: 'strick 2/19/2006 15:34'!
characterLimit
	"Tell the views how much to retain on screen"
	^ 99999 "strick<<20000"! !


!VObject methodsFor: 'actions' stamp: 'strick 2/8/2006 22:15'!
addDesktop: url
	| tablet |
	tablet _ VDesktopTablet new.

	tablet modelUrl: url desktopId: nil.

	( url asString beginsWith: 'desktop:' ) ifTrue: [
		tablet label: 'Desktop'
	] ifFalse: [
		tablet label: (url authority isEmpty ifTrue: [url path last] ifFalse: [url authority]).
	].

	self positionNewObject: tablet.! !

!VObject methodsFor: 'actions' stamp: 'strick 2/8/2006 22:11'!
addImport: url
	| extension | 
	url ifNil: [^nil].  "cancelled"

	(url asString beginsWith: 'desktop:') ifFalse: [

	extension _ url path last asUppercase.   "Should really use MIME type..."

	((extension endsWith: '.BMP') 
		or: [extension endsWith: '.JPG']
		or: [extension endsWith: '.GIF']
		or: [extension endsWith: '.PNG']) ifTrue: [^self addMaterial: url].

	"Should handle .WAV, .MP3, etc. here."
	((extension endsWith: '.WAV') 
		or: [extension endsWith: '.MP3']
		or: [extension endsWith: '.AIF']) ifTrue: [^self addSound: url].

	(extension endsWith: '.TEA') ifTrue: [^self importMesh: url as: #tea].
	(extension endsWith: '.MDL') ifTrue: [^self importMesh: url as: #mdl].
	((extension endsWith: '.WRL')
		or: [extension endsWith: '.VRML']) ifTrue: [^self importMesh: url as: #vrml].
	(extension endsWith: '.ASE') ifTrue: [^self importMesh: url as: #ase].

	].

	"If we can't import the content 'natively', then ask some OS desktop to do it for us."

	"Note that the contents of the URL are not really imported into Croquet. The only thing we
	persist within Croquet is the URL namestring. If the server specified by the URL goes away,
     we loose."
	self addDesktop: url.
	! !


!VDesktopTablet methodsFor: 'initialize' stamp: 'strick 2/16/2006 17:33'!
initializeModel: aModel recurseWith: sel
	"Answer all of the promises to wait for to ensure that the model is completely (recursively) initialized."
	| promises |


	Transcript cr; show: '###  VDesktopTablet ', self asString, ' initializeModel: ', aModel asString, ' recurseWith: ', sel asString, ' ###'.


	promises := super initializeModel: aModel recurseWith: sel.
	promises add: (aModel future url: self url asString).
	promises add: (aModel future desktopId: self desktopId).
	^ promises! !

!VDesktopTablet methodsFor: 'accessing' stamp: 'strick 2/16/2006 17:56'!
asString

	^ super asString, '(', self identityHashPrintString, ')'! !

!VDesktopTablet methodsFor: 'accessing' stamp: 'strick 2/8/2006 18:49'!
desktopId

	^ desktopId! !

!VDesktopTablet methodsFor: 'accessing' stamp: 'strick 2/16/2006 17:55'!
modelUrl: aUrlNameString desktopId: anId

	| on morphic |


	Transcript cr; show: '###  VDesktopTablet ', self asString, ' modelUrl: ', aUrlNameString asString, ' desktopId: ', anId asString, ' ###'.



	url _ aUrlNameString asUrl.
	anId ifNotNil: [ desktopId := anId ].
	desktopId ifNil: [ self setRandomDesktopId ].

	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: [ "************ NEW: with Xrfb " 

		morphic := CroquetObjects makeRFBViewer: url toText objectId: desktopId asString.

	] ifFalse: [ "*************** OLD: with 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 2/8/2006 20:17'!
setRandomDesktopId

	desktopId := (UUIDGenerator default generateRandomBitsOfLength: 64) asString.

	Transcript cr; show: 'VDesktopTablet>>setRandomDesktopId <- ', desktopId.
! !

!VDesktopTablet methodsFor: 'finalization' stamp: 'strick 2/15/2006 17:36'!
closeContents

	Transcript cr; show: '###  VDesktopTablet closeContents ###'.

	^ super closeContents
! !

!VDesktopTablet methodsFor: 'finalization' stamp: 'strick 2/15/2006 16:37'!
destroy

	Transcript cr; show: '###  VDesktopTablet destroy ###'.

	^ super destroy
! !

!VDesktopTablet methodsFor: 'finalization' stamp: 'strick 2/15/2006 16:55'!
finalize

"
  Smalltalk garbageCollect.
"

	Transcript cr; show: '###  VDesktopTablet finalize ###'.

	^ super finalize
! !

!VDesktopTablet methodsFor: 'finalization' stamp: 'strick 2/15/2006 16:49'!
removeAll

	Transcript cr; show: '###  VDesktopTablet removeAll ###'.

	^ super removeAll
! !

!VDesktopTablet methodsFor: 'finalization' stamp: 'strick 2/16/2006 17:58'!
removePortalFrames

	Transcript cr; show: '###  VDesktopTablet ', self asString, ' removePortalFrames ###'.

	^ super removePortalFrames
! !

!VDesktopTablet methodsFor: 'as yet unclassified' stamp: 'strick 2/19/2006 15:40'!
copyToClipboard

	Transcript cr; show: '@ ', self asString, ' copyToClipboard BEGIN'.
	super copyToClipboard.
	Transcript cr; show: '@ ', self asString, ' copyToClipboard END'.! !

!VDesktopTablet methodsFor: 'as yet unclassified' stamp: 'strick 2/19/2006 15:42'!
pasteFromClipboard

	Transcript cr; show: '@ ', self asString, ' pasteFromClipboard BEGIN'.
	super pasteFromClipboard.
	Transcript cr; show: '@ ', self asString, ' pasteFromClipboard END'.! !


!XrfbBasePanelMorph methodsFor: 'as yet unclassified' stamp: 'strick 2/11/2006 01:00'!
buttonColor

	^color darker! !

!XrfbBasePanelMorph methodsFor: 'as yet unclassified' stamp: 'strick 2/11/2006 00:57'!
buttonNamed: aString action: aSymbol color: aColor help: helpString

	| f col |
	f _ SimpleButtonMorph new
		target: self;
		label: aString font: self myFont;
		color: aColor;
		actionSelector: aSymbol;
		setBalloonText: helpString.
	f width: 10 * aString size + 10.
	f cornerStyle: #square.
	f color: (Color r: 0.95 g: 0.95 b: 1.0).
	f borderStyle: (BorderStyle raised width: 2).
	col _ (self inAColumn: {f}) hResizing: #spaceFill.
	^col! !

!XrfbBasePanelMorph methodsFor: 'as yet unclassified' stamp: 'strick 2/11/2006 01:39'!
closeButton

	^self
		buttonNamed: 'X' 
		action: #delete
		color: self buttonColor 
		help: 'Close the Control Panel'! !

!XrfbBasePanelMorph methodsFor: 'as yet unclassified' stamp: 'strick 2/11/2006 00:59'!
initialize
"
  self new openInWorld
"

	| fs |
	super initialize.
	self beSticky.
	fs _ GradientFillStyle ramp: {0.0 -> (Color r: 0.8 g: 0.8 b: 1.0). 1.0 -> (Color white) }.
	self vResizing: #shrinkWrap.
	self hResizing: #shrinkWrap.
	color _ Color paleYellow.
	borderWidth _ 4.
	borderColor _ #complexRaised.
	self layoutInset: (4@6).
	self rebuild: ' '.
	fs origin: bounds origin.
	fs direction: 0@self fullBounds height.
	self fillStyle: fs.! !

!XrfbBasePanelMorph methodsFor: 'as yet unclassified' stamp: 'strick 2/11/2006 01:02'!
maker

	^ XrfbServerMaker new! !

!XrfbBasePanelMorph methodsFor: 'as yet unclassified' stamp: 'strick 2/11/2006 01:02'!
myFont

	^(TextStyle named: #ComicBold) fontOfSize: 16! !


!XrfbClient methodsFor: 'as yet unclassified' stamp: 'strick 2/19/2006 18:27'!
abort

	self zork.

	super abort.! !

!XrfbClient methodsFor: 'as yet unclassified' stamp: 'strick 2/15/2006 16:21'!
disconnect
	"Close the new connection.

	In our super, it uses #inform: and #confirm: -- we omit those, and just abort if connected.
	"

	self isConnected ifTrue: [
		self abort
	]
! !

!XrfbClient methodsFor: 'as yet unclassified' stamp: 'strick 2/7/2006 16:31'!
requestPassword: label

	"the challenge-response encryption ALTERS the string
	it is passed, so we must create a new String instance here.

	This seems to do it."

	^ '', password.

! !

!XrfbClient methodsFor: 'as yet unclassified' stamp: 'strick 2/7/2006 16:28'!
setPassword: aString

	password := aString! !


!XrfbControlPanelMorph methodsFor: 'as yet unclassified' stamp: 'strick 2/11/2006 00:23'!
cleanButton

	^self
		buttonNamed: 'Clean up' 
		action: #doClean
		color: self buttonColor 
		help: 'Cleanup unused desktops on the Xrfb Desktop Server'! !

!XrfbControlPanelMorph methodsFor: 'as yet unclassified' stamp: 'strick 2/11/2006 01:40'!
configureButton

	^self
		buttonNamed: 'Configure...' 
		action: #doConfigure
		color: self buttonColor 
		help: 'Configure the hostname, port number, and shared password for the server'! !

!XrfbControlPanelMorph methodsFor: 'as yet unclassified' stamp: 'strick 2/11/2006 19:28'!
doClean

	self doSomething: 'clean'
! !

!XrfbControlPanelMorph methodsFor: 'as yet unclassified' stamp: 'strick 2/11/2006 01:47'!
doConfigure

	XrfbServerConfigMorph new openInWorld comeToFront.

	self rebuild: '...'
! !

!XrfbControlPanelMorph methodsFor: 'as yet unclassified' stamp: 'strick 2/11/2006 19:27'!
doList

	self doSomething: 'list'
! !

!XrfbControlPanelMorph methodsFor: 'as yet unclassified' stamp: 'strick 2/11/2006 19:28'!
doShutdown

	self doSomething: 'shutdown'
! !

!XrfbControlPanelMorph methodsFor: 'as yet unclassified' stamp: 'strick 2/11/2006 19:32'!
doSomething: what

	"set a message while we are working"
	self rebuild: '... sending request: ', what, ' ...' .
	self refreshWorld.

	"do the work"
	self rebuild: (self maker doSomething: what)
! !

!XrfbControlPanelMorph methodsFor: 'as yet unclassified' stamp: 'strick 2/10/2006 22:55'!
listButton

	^self
		buttonNamed: 'List Desktops' 
		action: #doList 
		color: self buttonColor 
		help: 'List all desktops and connections on the Xrfb Desktop Server'! !

!XrfbControlPanelMorph methodsFor: 'as yet unclassified' stamp: 'strick 2/11/2006 03:57'!
rebuild: someText

	| label |

	label := '  Desktops on ', XrfbServerMaker new httpServerHostAddress asString.

	self removeAllMorphs.

	self addARow: { 
		self closeButton.
		(StringMorph contents: label ) lock 
	}.

	self addARow: { 
		self listButton.
		self cleanButton.
		self configureButton.
		self shutdownButton.
	}.

	self addARow: { 
		(textArea := TextMorph new

			beAllFont: self myFont;
			crAction: (MessageSend receiver: self selector: #doOK);
			extent: 600@40;
			contentsWrapped: someText asText;
			setBalloonText: 'Results are displayed here.'
		)
	}.

! !

!XrfbControlPanelMorph methodsFor: 'as yet unclassified' stamp: 'strick 2/11/2006 00:12'!
shutdownButton

	^self
		buttonNamed: 'SHUTDOWN ALL!!' 
		action: #doShutdown
		color: self buttonColor 
		help: 'Forcibly shutdown all desktops on the Xrfb Desktop Server, dropping any connections from clients'! !


!XrfbServerConfigMorph methodsFor: 'as yet unclassified' stamp: 'strick 2/11/2006 01:14'!
cancelButton

	^self
		buttonNamed: 'Cancel' 
		action: #delete
		color: self buttonColor 
		help: 'Don''t make changes'! !

!XrfbServerConfigMorph methodsFor: 'as yet unclassified' stamp: 'strick 2/11/2006 01:48'!
doOK

	| p |


	self maker httpServerHostAddress: hostBox contents asString.

	p := portBox contents asString asInteger.
	p ifNotNil: [ self maker httpServerPortNumber: p].

	self maker httpServerPassword: passwordBox contents asString.

	self delete.

! !

!XrfbServerConfigMorph methodsFor: 'as yet unclassified' stamp: 'strick 2/11/2006 01:13'!
okButton

	^self
		buttonNamed: 'OK' 
		action: #doOK
		color: self buttonColor 
		help: 'Accept Changes'! !

!XrfbServerConfigMorph methodsFor: 'as yet unclassified' stamp: 'strick 2/11/2006 01:36'!
rebuild: ignoredText

	| label |

	label := '  Configure the Xrfb Desktop Server'.

	self removeAllMorphs.

	self addARow: {
		(StringMorph contents: label ) lock 
	}.

	self addARow: {
		(StringMorph contents: 'Server Hostname or IP Address:' font: self myFont) lock.
	}.
	(self addARow: {
		(hostBox _ TextMorph new
			beAllFont: self myFont;
			crAction: (MessageSend receiver: self selector: #doOK);
			extent: 236@20;
			contentsWrapped: self maker httpServerHostAddress;
			setBalloonText: 'Enter the hostname or IP address of the Xrfb Desktop Server'
			).
	}) color: Color white; borderColor: Color black; borderWidth: 1.

	self addARow: {
		(StringMorph contents: 'TCP Port Number: (default is 5899)' font: self myFont) lock.
	}.
	(self addARow: {
		(portBox _ TextMorph new
			beAllFont: self myFont;
			crAction: (MessageSend receiver: self selector: #doOK);
			extent: 236@20;
			contentsWrapped: self maker httpServerPortNumber asString;
			setBalloonText: 'Enter the TCP port of the Xrfb Desktop Server (usually 5899)'
			).
	}) color: Color white; borderColor: Color black; borderWidth: 1.

	self addARow: {
		(StringMorph contents: 'Password:' font: self myFont) lock.
	}.
	(self addARow: {
		(passwordBox _ TextMorph new
			beAllFont: (StrikeFont passwordFontSize: 16);
			crAction: (MessageSend receiver: self selector: #doOK);
			extent: 236@20;
			contentsWrapped: self maker httpServerPassword;
			setBalloonText: 'Enter the shared password for the server'
			).
	}) color: Color white; borderColor: Color black; borderWidth: 1.


	self addARow: {
		self okButton.
		self cancelButton.
	}.
! !


!XrfbServerMaker methodsFor: 'as yet unclassified' stamp: 'strick 2/14/2006 22:45'!
desktopForUrl: url objectId: objectId
	| pageExtent  morph client hostAddr hostPort socket displayNumber 
		msg textMorph  |


	"strick TODO: a better way than hardwiring 800x600"
	pageExtent := 800@600.

	outerMorph _ TXrfbMorphic new initializeOpaque: true extent: pageExtent; yourself.
	teaWorld _ TMorphMonitor new initializeWithWorld: nil extent: pageExtent; yourself.
	teaWorld eventsTo: outerMorph.
	world := teaWorld world.


	Transcript cr; show: 'makeRFBViewer: ', url, ' objectId: ', objectId.

	[
		displayNumber := 
		  XrfbServerMaker new 
			rpcLaunchServerForDocumentUrl: url objectId: objectId.
	] on: Error do: [ :ex | 
		"Could not talk to Xrfb Server -- bad host, port, password, or it is not running --
		or error fetching URL"

		textMorph := TextMorph new
			beAllFont: ((TextStyle named: #ComicBold) fontOfSize: 32);
			backgroundColor: Color yellow;
			crAction: (MessageSend receiver: self selector: #yourself);
			extent: pageExtent;
			contentsWrapped: url, '
==================================
',ex messageText asText;
			setBalloonText: 'This decribes the error received when trying to connect to the Xrfb Desktop Server';
			centered;
			yourself.

		world addMorph: textMorph.
		^ outerMorph
	].

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

		socket _ RFBClientSocket newTCP.
		socket connectTo: hostAddr port: hostPort.


		client := XrfbClient new
			setPassword: XrfbServerMaker new httpServerPassword;
			yourself.
		client target: teaWorld. "????"
		outerMorph xrfbClient: client.   "<-----"
		morph := client asMorph.
		morph beSticky.
		world addMorph: morph.

	] on: Error do: [  :ex | 

			msg := url, '
==================================
An error occurred while trying to connect to the Xvnc desktop
at host ', hostAddr asString, ' port ', hostPort asString, '
---------------
', ex asString, '
---------------
', ex messageText.

		textMorph := TextMorph new
			beAllFont: ((TextStyle named: #ComicBold) fontOfSize: 32);
			backgroundColor: Color yellow;
			crAction: (MessageSend receiver: self selector: #yourself);
			extent: pageExtent;
			contentsWrapped: msg asText;
			setBalloonText: 'This decribes the error received when trying to connect to the Xrfb Desktop Server';
			centered;
			yourself.

		world addMorph: textMorph.
		^ outerMorph
	].


	client connectTo: socket.

	client isConnected ifFalse:[

		" a little cleanup "
		socket ifNotNil:[socket destroy].
		morph delete.

		msg := url, '
==================================
RFBClient failed to connect.'.
		textMorph := TextMorph new
			beAllFont: ((TextStyle named: #ComicBold) fontOfSize: 32);
			backgroundColor: Color yellow;
			crAction: (MessageSend receiver: self selector: #yourself);
			extent: pageExtent;
			contentsWrapped: msg asText;
			setBalloonText: 'This decribes the error received when trying to connect to the Xrfb Desktop Server';
			centered;
			yourself.

		world addMorph: textMorph.
		^ outerMorph
	].

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

	

! !

!XrfbServerMaker methodsFor: 'as yet unclassified' stamp: 'strick 2/11/2006 03:56'!
doSomething: aVerb


	| request reply answers infos errors text |

	request := '/', aVerb.

	reply := self httpGetWithCommand: request.

	[
		answers := self getDataFromXml: reply withTag: #answer.
		infos := self getDataFromXml: reply withTag: #info.
		errors := self getDataFromXml: reply withTag: #error.
	] on: XrfbHttpReplyException do: [ :ex |
		errors := { ex messageText }
	].

	text := 'ANSWERS: ', answers asString, '
INFOS: ', infos asString, '
ERRORS: ', errors asString.

	text := ''.
	answers ifNotNil: [ answers do: [ :x | text := text, x asString, String cr ] ].
	infos ifNotNil: [ infos do: [ :x | text := text, '-- ', x asString, String cr ] ].
	errors ifNotNil: [ errors do: [ :x | text := text, '***ERROR*** ', x asString, String cr ] ].

	( text = '' ) ifTrue: [ text = 'OKAY.' ].
 
	^ text.
! !

!XrfbServerMaker 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
! !

!XrfbServerMaker methodsFor: 'as yet unclassified' stamp: 'strick 2/11/2006 02:49'!
getDataFromXml: someXml withTag: aTag

	| z document | 

	z := OrderedCollection new. 

	[
		document := XMLDOMParser
					parseDocumentFrom: 
						(ReadStream on: someXml).
	] on: SAXException do: [ :ex |
		XrfbHttpReplyException new signal: 
				'An error occurred while trying to contact the Xrfb Desktop Server.
------------------------------------------
Most likely, either the Xrfb server is not running,
it is not reachable due to a firewall,
or the Host, Port, or Password is not configured correctly.
(Use the menu "Tools" >> "Xrfb Desktops Control Panel" >> "Configure" )
-------------------------------------------
',  someXml.
		^ nil
	].

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

	^ z! !

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

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

	^ (Url absoluteFromText: anAbsoluteUrl) retrieveContents content! !

!XrfbServerMaker methodsFor: 'as yet unclassified' stamp: 'strick 2/6/2006 23:51'!
httpGetWithCommand: aCommand 

	"aCommand is of form  /verb?query=stuff

	self new httpGetWithCommand: '/echo?wish=
	"

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

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

	^ self httpGetWithAbsoluteUrl: absoluteUrl
! !

!XrfbServerMaker methodsFor: 'as yet unclassified' stamp: 'strick 2/11/2006 01:19'!
httpServerHostAddress

	^ HttpServerHostAddress ifNil: [ '127.0.0.1' ]! !

!XrfbServerMaker methodsFor: 'as yet unclassified' stamp: 'strick 2/11/2006 01:17'!
httpServerHostAddress: newAddress

	HttpServerHostAddress := newAddress! !

!XrfbServerMaker methodsFor: 'as yet unclassified' stamp: 'strick 2/11/2006 01:20'!
httpServerPassword

	^ HttpServerPassword ifNil: [ 'zzzzzz' ]! !

!XrfbServerMaker methodsFor: 'as yet unclassified' stamp: 'strick 2/11/2006 01:17'!
httpServerPassword: newPassword

	HttpServerPassword := newPassword

	! !

!XrfbServerMaker methodsFor: 'as yet unclassified' stamp: 'strick 2/11/2006 01:21'!
httpServerPortNumber

	^ HttpServerPortNumber ifNil: [ 5899 ]
! !

!XrfbServerMaker methodsFor: 'as yet unclassified' stamp: 'strick 2/11/2006 01:18'!
httpServerPortNumber: newPortNumber

	HttpServerPortNumber := newPortNumber! !

!XrfbServerMaker methodsFor: 'as yet unclassified' stamp: 'strick 2/10/2006 23:15'!
rpcCleanServers

	| request reply |

	request := '/clean'.

	reply := self httpGetWithCommand: request.

	^ self getAnswersFromXml: reply! !

!XrfbServerMaker methodsFor: 'as yet unclassified' stamp: 'strick 2/6/2006 23:28'!
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 httpGetWithCommand: request.

	"expect only one answer, to take the first"

	^ (self getAnswersFromXml: reply) first! !

!XrfbServerMaker methodsFor: 'as yet unclassified' stamp: 'strick 2/6/2006 23:28'!
rpcLaunchServerForDocumentUrl: aDocumentUrl objectId: anId

	| request reply |

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

	reply := self httpGetWithCommand: request.

	^ (self getAnswersFromXml: reply) first! !

!XrfbServerMaker methodsFor: 'as yet unclassified' stamp: 'strick 2/6/2006 23:28'!
rpcListServers

	| request reply |

	request := '/list'.

	reply := self httpGetWithCommand: request.

	^ self getAnswersFromXml: reply! !

!XrfbServerMaker methodsFor: 'as yet unclassified' stamp: 'strick 2/6/2006 23:28'!
rpcShutdownAllServers

	| request reply |

	request := '/shutdown'.

	reply := self httpGetWithCommand: request.

	self getAnswersFromXml: reply! !


!XrfbServerMakerTests 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! !

!XrfbServerMakerTests methodsFor: 'as yet unclassified' stamp: 'strick 2/2/2006 23:36'!
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 := XrfbServerMaker new rpcEcho: x.

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

!XrfbServerMakerTests methodsFor: 'as yet unclassified' stamp: 'strick 2/6/2006 23:30'!
testLaunch

	"
	self new testLaunch
	"

	| answer x |


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

	answer := XrfbServerMaker new rpcLaunchServerForDocumentUrl: x objectId: 'testId'.

	self assert: answer isAllDigits.
 
	^ #ok! !

!XrfbServerMakerTests methodsFor: 'as yet unclassified' stamp: 'strick 2/7/2006 16:39'!
testSetPassword

	self assert:
		'abcdefg' = (
			XrfbClient new
				setPassword: 'abc','defg';
				requestPassword: 'sample label for user'
		) 
! !

VDesktopTablet removeSelector: #modelUrl:!
VDesktopTablet removeSelector: #url:!