'From etoys3.0 of 7 March 2008 [latest update: #2055] on 18 July 2008 at 12:48:53 am'!
"Change Set:		tubes-bf
Date:			7 July 2008
Author:			BertF (jhbuild)

- use telepathy tubes
- put buddies in a flap"!

AbstractLauncher subclass: #SugarLauncher
	instanceVariableNames: 'sharedActivity tubes buddies buddiesLock tubesLock '
	classVariableNames: 'Current UISema '
	poolDictionaries: ''
	category: 'Sugar'!
Object subclass: #SugarTube
	instanceVariableNames: 'id service buddy address'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Sugar'!

!ConnectionQueue methodsFor: 'public' stamp: 'bf 7/4/2008 18:29'!
portNumberOrNil
	"Answer nil while actual port has not been established"
	^ portNumber isCollection
		ifFalse: [portNumber]! !


!EToyListenerMorph methodsFor: 'as yet unclassified' stamp: 'bf 7/4/2008 19:27'!
listeningPort
	^self class listeningPort! !


!EToyPeerToPeer methodsFor: 'sending' stamp: 'bf 7/17/2008 20:11'!
makeOptionalHeader
	"Optional header format is '(key:value;key:value)' and it must not contain spaces. This is designed to be backwards-compatible with old receivers who receive a header as anything up to a space, but only actually use an initial size integer"

	| args p t |
	args := OrderedCollection new.

	p := EToyListenerMorph listeningPort.
	(p notNil and: [p ~= self class eToyCommunicationsPorts first])
		ifTrue: [args add: 'port:', p asString].

	t := SugarLauncher current listeningTube.
	t ifNotNil: [args add: 'tube:', t asString].

	^args isEmpty
		ifTrue: ['']
		ifFalse: [String streamContents: [:strm |
			strm nextPut: $(.
			args
				do: [:arg | strm nextPutAll: arg]
				separatedBy: [strm nextPut: $;].
			strm nextPut: $)]].
! !

!EToyPeerToPeer methodsFor: 'listening' stamp: 'bf 7/4/2008 18:29'!
listeningPort
	^connectionQueue portNumberOrNil! !

!EToyPeerToPeer methodsFor: 'receiving' stamp: 'bf 7/17/2008 01:56'!
parseOptionalHeader: aString
	"header used to be just an integer, was extended to have optional parameters (see makeOptionalHeader)"

	(((aString copyAfter: $() copyUpTo: $)) findTokens: $;) do: [:item |
		(item beginsWith: 'port:')
			ifTrue: [self receivedPort: (item copyAfter: $:)].
		(item beginsWith: 'tube:')
			ifTrue: [self receivedTube: (item copyAfter: $:)].]! !

!EToyPeerToPeer methodsFor: 'receiving' stamp: 'bf 7/17/2008 22:18'!
receivedTube: aString
	"Sender offers a tube for talking back. Get the tube's address."
	| addr |
	addr := SugarLauncher current socketAddressForTube: aString.
	addr ifNotNil: [remoteSocketAddress := addr]! !


!NebraskaServer methodsFor: 'networking' stamp: 'bf 7/4/2008 18:29'!
listeningPort
	^listenQueue portNumberOrNil! !


!NebraskaServerMorph class methodsFor: 'as yet unclassified' stamp: 'bf 7/4/2008 18:16'!
serveWorld: aWorld
	"Check to make sure things won't crash. See Mantis #0000519"
	^aWorld isSafeToServe ifTrue:[
		self serveWorld: aWorld onPort: NebraskaServer defaultPorts]
	! !

!NebraskaServerMorph class methodsFor: 'as yet unclassified' stamp: 'bf 7/4/2008 18:14'!
serveWorld: aWorld onPort: aPortNumber

	| server |
	server := NebraskaServer serveWorld: aWorld onPort: aPortNumber.
	(self new) openInWorld: aWorld.
	^server
	"server acceptNullConnection"		"server acceptPhonyConnection."
! !


!SugarBuddy methodsFor: 'actions' stamp: 'bf 7/17/2008 20:58'!
makeBadge
	| badge font ext |
	badge := EToySenderMorph new
		userName: nick 
		userPicture: (self xoFormExtent: 61@53 background: Color veryVeryLightGray) 
		userEmail: 'who@where.net' 
		userIPAddress: ip;
		color: Color veryVeryLightGray;
		borderColor: Color gray.
	badge setProperty: #buddy toValue: self.
	#( tellAFriend emailAddress  startTelemorphic ipAddress  checkOnAFriend )
		do: [:ea | badge hideField: ea].
	font := Preferences standardEToysFont.
	ext := (font widthOf: $m) + 2 @ font height.
	badge allMorphsDo: [:m |
		(m respondsTo: #font:) ifTrue: [m font: font].
		(m class == SimpleButtonMorph) ifTrue: [m extent: ext]].
	^ badge.! !


!SugarLauncher methodsFor: 'presence' stamp: 'bf 7/18/2008 00:10'!
badgeFlap
	"This finds or creates a flap to hold badges"

	| aFlapTab outer leftStrip rightStrip holder |
	aFlapTab := Flaps globalFlapTab: 'Buddies'.
	aFlapTab ifNotNil: [^aFlapTab].

	aFlapTab := FlapTab new.
	aFlapTab assureExtension visible: false.
	aFlapTab setProperty: #rigidThickness toValue: true.

	outer := AlignmentMorph newRow.
	outer assureExtension visible: false.
	outer clipSubmorphs: true.
	outer beTransparent.
	outer vResizing: #spaceFill; hResizing: #spaceFill.
	outer layoutInset: 0; cellInset: 0; borderWidth: 0.
	outer setProperty: #wantsHaloFromClick toValue: false.

	leftStrip := Morph new beTransparent.  "This provides space for tabs to be seen."
	leftStrip layoutInset: 0; cellInset: 0; borderWidth: 0.
	leftStrip width:  20.
	leftStrip hResizing: #rigid; vResizing: #spaceFill.
	outer addMorphBack: leftStrip.   

	rightStrip := AlignmentMorph newColumn.
	rightStrip color: (Color green veryMuchLighter alpha:  0.2).
	rightStrip layoutInset: 0; cellInset: 0; borderWidth: 0.
	rightStrip setProperty: #wantsHaloFromClick toValue: false.
	outer addMorphBack: rightStrip.
	outer clipSubmorphs: true.
	
	holder := Morph new.
	holder name: 'Buddies' translated.
	holder position: 0@100.
	holder layoutPolicy: TableLayout new.
	holder color: Color red muchLighter;
		listDirection: #topToBottom;
		hResizing: #shrinkWrap;
		vResizing: #shrinkWrap;
		cellInset: 10;
		layoutInset: 10.

	rightStrip addMorphBack: holder.
	holder beSticky.

	aFlapTab referent ifNotNil: [aFlapTab referent delete].
	aFlapTab referent: outer.
	aFlapTab setName: 'Buddies' translated edge: #left color: Color red muchLighter.
	ActiveWorld addMorphFront: aFlapTab.
	aFlapTab adaptToWorld: ActiveWorld.
	aFlapTab computeEdgeFraction.

	aFlapTab position: (outer left @ outer top).
	outer extent: (200 @ ActiveWorld height).

	outer beFlap: true.
	outer beTransparent.

	aFlapTab referent hide.
	aFlapTab referentMargin: 0@75.

	outer beSticky.
	leftStrip beSticky.
	rightStrip beSticky.

	aFlapTab applyThickness: 200.
	aFlapTab fitOnScreen.
	aFlapTab referent show.
	aFlapTab show.
	aFlapTab makeFlapCompact: true.
	aFlapTab setToPopOutOnDragOver:  false.
	Flaps addGlobalFlap: aFlapTab.
	ActiveWorld addGlobalFlaps.
	ScriptingSystem cleanUpFlapTabsOnLeft.

	^aFlapTab! !

!SugarLauncher methodsFor: 'presence' stamp: 'bf 7/17/2008 00:34'!
badgeFor: aBuddy
	^self badgeHolder submorphs
		detect: [:m |
			(m isKindOf: EToySenderMorph) and: [
				(m valueOfProperty: #buddy) = aBuddy]]
		ifNone: [nil]
! !

!SugarLauncher methodsFor: 'presence' stamp: 'bf 7/18/2008 00:11'!
badgeHolder
	"This finds or creates a flap to hold badges"

	^self badgeFlap referent submorphNamed: 'Buddies'
! !

!SugarLauncher methodsFor: 'presence' stamp: 'bf 7/11/2008 21:55'!
buddies
	sharedActivity ifNil: [^Dictionary new].
	buddies ifNil: [self setupBuddies].
	^buddies! !

!SugarLauncher methodsFor: 'presence' stamp: 'bf 7/15/2008 23:23'!
buddiesLock
	^buddiesLock ifNil: [buddiesLock := Semaphore forMutualExclusion]! !

!SugarLauncher methodsFor: 'presence' stamp: 'bf 7/18/2008 00:14'!
buddyJoined: buddyProxy
	"possibly sent via DBus in background process"
	| properties buddy |
	properties := buddyProxy getProperties.
	(properties at: #owner ifAbsent: [false]) == true ifTrue: [^self].
	self buddiesLock critical: [
		(buddies includesKey: (properties at: #key)) ifTrue: [^self].
		buddy := SugarBuddy fromDictionary: properties.
		buddies at: buddy key put: buddy].
	WorldState addDeferredUIMessage: [
		self badgeHolder addMorph: buddy makeBadge.
		self showBadges]! !

!SugarLauncher methodsFor: 'presence' stamp: 'bf 7/17/2008 23:26'!
buddyLeft: buddyProxy
	"sent via DBus in background process"
	| key buddy badge |
	key := buddyProxy getProperties at: #key.
	buddy := self buddiesLock critical: [
		buddies removeKey: key ifAbsent: [^self]].
	WorldState addDeferredUIMessage: [
		badge := self badgeFor: buddy.
		badge ifNotNil: [badge delete]].! !

!SugarLauncher methodsFor: 'presence' stamp: 'bf 7/17/2008 23:40'!
deleteBadges
	| flapTab |
	flapTab := (Flaps globalFlapTab: 'Buddies') ifNil: [^self].
	Flaps removeFlapTab: flapTab keepInList: false.
! !

!SugarLauncher methodsFor: 'presence' stamp: 'bf 7/11/2008 21:18'!
enableSharedActivitySignals
	sharedActivity onBuddyJoinedSend: #buddyJoined: to: self.
	sharedActivity onBuddyLeftSend: #buddyLeft: to: self.
! !

!SugarLauncher methodsFor: 'presence' stamp: 'bf 7/16/2008 02:22'!
joinSharedActivity
	"join a shared activity on startup"
	Utilities informUser: 'Looking for shared activity ...' translated
		during: [
			[sharedActivity := self presence getActivityById: self activityId]
				ifError: [^sharedActivity := nil]].

	Utilities informUser: 'Joining activity ...' translated
		during: [
			[sharedActivity join] ifError: [^sharedActivity := nil] .
			self setupBuddies.
			self setupTubes.
			self enableSharedActivitySignals.
			SugarNavigatorBar current ifNotNilDo: [:bar | bar joinSharedActivity].
		].

! !

!SugarLauncher methodsFor: 'presence' stamp: 'bf 7/16/2008 00:51'!
leaveSharedActivity
	sharedActivity ifNotNil: [
		sharedActivity leaveAsync.
		sharedActivity := nil.
		self buddiesLock critical: [buddies := nil].
		self deleteBadges].
! !

!SugarLauncher methodsFor: 'presence' stamp: 'bf 7/18/2008 00:13'!
setupBuddies
	self badgeFlap.
	self buddiesLock critical: [buddies := Dictionary new].
	sharedActivity getJoinedBuddies do: [:each |
		self buddyJoined: each].
! !

!SugarLauncher methodsFor: 'presence' stamp: 'bf 7/16/2008 02:38'!
share
	sharedActivity ifNotNil: [^self].

	sharedActivity := self presence
		shareActivity: self activityId
		with: self bundleId
		with: (self titleFromProject: Project current) squeakToUtf8
		with: Dictionary new. "due to bug 4660 we can't pass properties directly"
	sharedActivity setProperties: ({'private' -> false} as: Dictionary).
	self setupBuddies.
	self enableSharedActivitySignals.
	self setupTubes.
! !

!SugarLauncher methodsFor: 'presence' stamp: 'bf 7/18/2008 00:12'!
showBadges
	self badgeFlap openFully! !

!SugarLauncher methodsFor: 'telepathy' stamp: 'bf 7/7/2008 15:18'!
getChannels
	^[:tpService :tpConn :tpChannels |
		tpChannels collect: [:channel |
			TelepathyChannel
				connection: tpConn dbusConnection
				busName: tpService
				objectPath: channel dbusPath]
	] valueWithArguments: sharedActivity getChannels! !

!SugarLauncher methodsFor: 'telepathy' stamp: 'bf 7/7/2008 15:11'!
getTubesChannel
	^self getChannels detect: [:channel |
		channel getChannelType = 'org.freedesktop.Telepathy.Channel.Type.Tubes']! !

!SugarLauncher methodsFor: 'telepathy' stamp: 'bf 7/17/2008 22:36'!
listeningTube
	"our own tube id"
	^tubes ifNotNil: [tubes keyAtValue: nil ifAbsent:[]]! !

!SugarLauncher methodsFor: 'telepathy' stamp: 'bf 7/17/2008 22:28'!
newTube: aTubeId initiator: anInitiatorId type: aType service: aServiceName parameters: aDictionary state: aState
	"possibly sent via DBus in background process"

	self tubesLock critical: [
		| key buddy tube |
		(tubes includesKey: aTubeId) ifTrue: [^self]. "our own tube"
		key := aDictionary at: #buddy.
		buddy := buddies at: key ifAbsent: [key].
		(tube := SugarTube new)
			id: aTubeId;
			service: aServiceName;
			buddy: buddy.
		tubes at: aTubeId put: tube].
	self tubeChanged: aTubeId state: aState.
! !

!SugarLauncher methodsFor: 'telepathy' stamp: 'bf 7/7/2008 15:15'!
offerStreamTube: tcpServiceName inBackgroundOnPort: aBlock
	[
		| port |
		[port := aBlock value.
		port isNil] whileTrue: [(Delay forMilliseconds: 100) wait].
		self offerStreamTube: tcpServiceName port: port.
	] forkAt: Processor lowIOPriority
		named: 'offer stream tube'! !

!SugarLauncher methodsFor: 'telepathy' stamp: 'bf 7/17/2008 22:37'!
offerStreamTube: tcpServiceName port: anInteger
	self tubesLock critical: [
		| tubeId |
		tubeId := self getTubesChannel
			offerStreamTube: tcpServiceName
			with: {#buddy -> self ownerBuddy key} "params"
			with: TelepathyChannel socketAddressTypeIPv4
			with: ({'127.0.0.1'. anInteger} asDBusArgumentSignature: '(sq)')
			with: 0 "accessControl"
			with: 0. "accessControlParam".
		tubes at: tubeId put: nil "mark as our own"]! !

!SugarLauncher methodsFor: 'telepathy' stamp: 'bf 7/16/2008 00:55'!
setupTubes
	| tubesChannel |
	self tubesLock critical: [tubes := Dictionary new].
	tubesChannel := self getTubesChannel.
	tubesChannel listTubes do: [:tubeArgs |
		self perform: #newTube:initiator:type:service:parameters:state:
			withArguments: tubeArgs].
	tubesChannel
		onNewTubeSend: #newTube:initiator:type:service:parameters:state: to: self;
		onTubeStateChangedSend: #tubeChanged:state: to: self; 
		onTubeClosedSend: #tubeClosed: to: self.
! !

!SugarLauncher methodsFor: 'telepathy' stamp: 'bf 7/17/2008 22:36'!
socketAddressForTube: tubeId
	| tube |
	tube := tubesLock critical: [tubes ifNotNil: [
		tubes at: tubeId asInteger ifAbsent: []]].
	^tube ifNotNil: [tube address]! !

!SugarLauncher methodsFor: 'telepathy' stamp: 'bf 7/17/2008 22:26'!
tubeChanged: tubeId state: tubeState
	"sent via DBus in background process"
	| socket tube |
	(tubeState = TelepathyChannel tubeStateLocalPending and: [(tubes at: tubeId) service = 'sqk-etoy-p2p'])
		ifTrue: [
			socket := self getTubesChannel
				acceptStreamTube: tubeId with: TelepathyChannel socketAddressTypeIPv4 with: 0 with: 0.
			self tubesLock critical: [
				tube := tubes at: tubeId.
				tube address: socket first, ':', socket second asString].
			WorldState addDeferredUIMessage: [
				(self badgeFor: tube buddy) ipAddress: tube address].
		].! !

!SugarLauncher methodsFor: 'telepathy' stamp: 'bf 7/17/2008 22:35'!
tubeClosed: tubeId
	"sent via DBus in background process"
	| tube |
	tube := self tubesLock critical: [tubes removeKey: tubeId ifAbsent: [^self]].
	tube ifNotNil: [
		WorldState addDeferredUIMessage: [
			(self badgeFor: tube buddy) ifNotNilDo: [:badge |
				badge ipAddress: 'tube closed']]].! !

!SugarLauncher methodsFor: 'telepathy' stamp: 'bf 7/15/2008 23:23'!
tubesLock
	^tubesLock ifNil: [tubesLock := Semaphore forMutualExclusion]! !


!SugarNavigatorBar methodsFor: 'sharing' stamp: 'bf 7/7/2008 23:33'!
joinSharedActivity
	self startP2P.
	SugarLibrary default recolorButton: shareButton for: 'share' baseColor: self color highLightColor: self highlightColor.
! !

!SugarNavigatorBar methodsFor: 'sharing' stamp: 'bf 7/7/2008 23:32'!
startNebraska

	| nebraska |
	ActiveWorld remoteServer: nil.
	ActiveWorld submorphs do: [:e | (e isMemberOf: NebraskaServerMorph) ifTrue: [e delete]].
	nebraska := NebraskaServerMorph serveWorld.
	SugarLauncher current
		offerStreamTube: 'sqk-nebraska'
		inBackgroundOnPort: [nebraska listeningPort].
! !

!SugarNavigatorBar methodsFor: 'sharing' stamp: 'bf 7/7/2008 23:33'!
startP2P
	listener ifNotNil: [listener stopListening].
	listener ifNil: [listener := SugarListenerMorph new].
	listener position: -200@-200.
	ActiveWorld addMorphBack: listener.
	listener startListening.
	SugarLauncher current
		offerStreamTube: 'sqk-etoy-p2p'
		inBackgroundOnPort: [listener listeningPort].
! !

!SugarNavigatorBar methodsFor: 'sharing' stamp: 'bf 7/7/2008 23:42'!
startSharing
	SugarLauncher current share.
	self startP2P.
	"self startNebraska."
	SugarLibrary default recolorButton: shareButton for: 'share' baseColor: self color highLightColor: self highlightColor.
! !

!SugarNavigatorBar methodsFor: 'the actions' stamp: 'bf 7/7/2008 20:11'!
shareMenu

	| menu item ext |
	menu _ MenuMorph new.
	ext _ 200@50.
	#((stopSharing makePrivateLabelIn:) (startSharing makeMyNeighborhoodLabelIn:) "(shareThisWorld makeBadgeLabelIn:)") do: [:pair |
		
		item _ MenuItemMorph new
			contents: '';
			target: self;
			selector: pair first;
			arguments: #().
		item color: Color black.
		item addMorph: (self perform: pair second with: ext).
		item setProperty: #minHeight toValue: ext y.
		item fitContents.
		item extent: ext.
		item setProperty: #selectionFillStyle toValue: (Color gray alpha: 0.5).
		menu addMorphBack: item.
	].
	menu color: Color black.
	menu borderColor: Color white.
	^ menu invokeModalAt: shareButton position + (10@20) in: ActiveWorld allowKeyboard: false.! !


!SugarTube methodsFor: 'accessing' stamp: 'bf 7/17/2008 22:29'!
address
	^ address! !

!SugarTube methodsFor: 'accessing' stamp: 'bf 7/17/2008 22:30'!
address: aString
	address := aString! !

!SugarTube methodsFor: 'accessing' stamp: 'bf 7/18/2008 00:24'!
buddy
	buddy isString ifTrue: [
		buddy := SugarLauncher current buddies at: buddy].
	^ buddy! !

!SugarTube methodsFor: 'accessing' stamp: 'bf 7/17/2008 22:30'!
buddy: aBuddy
	buddy := aBuddy! !

!SugarTube methodsFor: 'accessing' stamp: 'bf 7/17/2008 22:30'!
id
	^ id! !

!SugarTube methodsFor: 'accessing' stamp: 'bf 7/17/2008 22:30'!
id: anInteger
	id := anInteger! !

!SugarTube methodsFor: 'accessing' stamp: 'bf 7/17/2008 22:31'!
service
	^ service! !

!SugarTube methodsFor: 'accessing' stamp: 'bf 7/17/2008 22:31'!
service: aString
	service := aString! !


!SugarNavigatorBar reorganize!
('initialization' addButtons configureForSqueakland findButtonAppearance inAColumn: inARow: initialize makeTheButtons makeTheSimpleButtons makeTheSimpleButtonsSqueakland paintButtonInitialExplanation putUpInitialBalloonHelp setSuppliesBehind sugarLib: suppliesButtonInitialExplanation wantsHaloForSubmorphs:)
('morphic interaction' checkForResize naviHeightWithFullUpdate: naviHeight: resizeButtonsAndTabTo: step)
('buttons creation' availableDisplayModes balloonTextForMode: buttonFind buttonLanguage buttonPaint buttonShare buttonStop buttonUndo buttonZoom chooseScreenSetting makeButton:balloonText:for: setupSuppliesFlap spacer: stringForDisplayModeIs:)
('button actions' changeDisplayModeTo: changeVirtualScreenMode currentDisplayMode doNewPainting quitSqueak shareThisWorld stopSqueak toggleSupplies)
('event handling' handlesMouseOver: morphicLayerNumber setEdge: undoButtonAppearance wantsDroppedMorph:event: zoomButtonAppearance)
('sharing' getBadge joinSharedActivity startNebraska startP2P startSharing stopSharing)
('accessing' buttonHeight color: color:highLightColor: highLightColor highLightColor: makeGray makeGreen oldHeight sugarLib)
('help flap' buildAndOpenHelpFlap toggleHelp)
('the actions' makeBadgeLabelIn: makeMyNeighborhoodLabelIn: makePrivateLabelIn: makeProjectNameLabel previousProject projectName projectNameChanged: projectNameFieldBalloonHelp publishProject resizeProjectNameField shareMenu)
!

SugarLauncher removeSelector: #handleBuddyJoined:!
SugarLauncher removeSelector: #handleBuddyLeft:!
SugarLauncher removeSelector: #makeBadges!
SugarLauncher removeSelector: #tubes!
AbstractLauncher subclass: #SugarLauncher
	instanceVariableNames: 'sharedActivity buddies buddiesLock tubes tubesLock'
	classVariableNames: 'Current UISema'
	poolDictionaries: ''
	category: 'Sugar'!

!SugarLauncher reorganize!
('*dbus-tools')
('running' shutDown startUp)
('commands' active: quit save takeScreenshot welcome:)
('bundling' bundleIcon bundleIconTemplate bundleInfoTemplate bundleInfoTitle:version:bundle:script:icon: bundleScriptTemplate bundle: bundle:as:title:version:id:icon:)
('accessing' activityId bundleId bundlePath dataStore ownerBuddy presence)
('dbus')
('events' windowEvent:)
('datastore' createJournalEntryFor:filename:mimetype: findJournalEntries:properties: getFile: handleStream:mimetype:titled: makeJournalEntryFor:filename:mimetype: propertiesFrom: resumeJournalEntry: titleFromProject: updateJournalEntry: updateJournalEntry:for:filename:mimetype:)
('presence' badgeFlap badgeFor: badgeHolder buddies buddiesLock buddyJoined: buddyLeft: deleteBadges enableSharedActivitySignals joinSharedActivity leaveSharedActivity setupBuddies share showBadges)
('telepathy' getChannels getTubesChannel listeningTube newTube:initiator:type:service:parameters:state: offerStreamTube:inBackgroundOnPort: offerStreamTube:port: setupTubes socketAddressForTube: tubeChanged:state: tubeClosed: tubesLock)
('testing' isRunningInRainbow isRunningInSugar isShared)
('chooser')
('as yet unclassified' bundleScript:)
!

EToyListenerMorph class removeSelector: #listeningTube!