'From Squeak3.6 of ''6 October 2003'' [latest update: #5424] on 8 December 2003 at 5:28:58 pm'!
"Change Set: serverFixes-mir
Date: 8 December 2003
Author: Michael Rueger
Fixes problems with the update mechanism.
Changes to server directory do multiple command sequences are again possible."!
Object subclass: #ServerDirectory
instanceVariableNames: 'server directory type user passwordHolder group moniker altURL urlObject socket loaderUrl eToyUserListUrl eToyUserList keepAlive client '
classVariableNames: 'LocalEToyBaseFolderSpecs LocalEToyUserListUrls LocalProjectDirectories Servers '
poolDictionaries: ''
category: 'Network-RemoteDirectory'!
!FTPClient methodsFor: 'protocol' stamp: 'mir 12/8/2003 16:54'!
putFileStreamContents: fileStream as: fileNameOnServer
"FTP a file to the server."
self openPassiveDataConnection.
self sendCommand: 'STOR ', fileNameOnServer.
fileStream reset.
[self sendStreamContents: fileStream]
ensure: [self closeDataSocket].
self checkResponse.
self checkResponse.
! !
!FtpUrl methodsFor: 'downloading' stamp: 'mir 6/27/2003 19:42'!
retrieveContents
"currently assumes directories end in /, and things that don't end in / are files. Also, doesn't handle errors real well...."
| server contents pathString listing auth idx fileName serverName userName password |
pathString _ self pathString.
pathString _ pathString copyFrom: 2 to: pathString size. "remove the leading /"
pathString last = $/ ifTrue:["directory?!!"
fileName _ nil.
] ifFalse:[
fileName _ pathString copyFrom: (pathString lastIndexOf: $/)+1 to: pathString size.
pathString _ pathString copyFrom: 1 to: (pathString lastIndexOf: $/) - 1.
].
auth _ self authority.
idx _ auth indexOf: $@.
idx > 0 ifTrue:[
serverName _ (auth copyFrom: idx+1 to: auth size).
userName _ (auth copyFrom: 1 to: idx-1).
password _ nil.
] ifFalse:[
serverName _ auth.
userName _ 'anonymous'.
password _ 'SqueakUser'.
].
server _ ServerDirectory servers
detect:[:s| s isTypeFTP and:[s server asLowercase = serverName asLowercase]]
ifNone:[nil].
server ifNil:[
server _ ServerDirectory new.
server server: serverName.
] ifNotNil:[server _ server copy reset].
server user: userName.
password ifNotNil:[server password: password].
server directory: pathString.
fileName == nil ifFalse:[
"a file"
contents _ (server getFileNamed: fileName).
server sleep.
^MIMEDocument contentType: (MIMEDocument guessTypeFromName: self path last) content: contents].
"a directory?"
listing _ String streamContents: [ :stream |
stream nextPutAll: '
', self pathString, ''; cr.
stream nextPutAll: 'Listing for ', self pathString, '
'; cr.
stream nextPutAll: ''; cr.
server entries do: [ :entry |
stream nextPutAll: '- ';
nextPutAll: '';
nextPutAll: entry name;
nextPutAll: '';
cr ] ].
server sleep.
^MIMEDocument contentType: 'text/html' content: listing! !
!RemoteFileStream methodsFor: 'as yet unclassified' stamp: 'mir 12/8/2003 16:45'!
close
"Write if we have data to write. FTP files are always binary to preserve the data exactly. The binary/text (ascii) flag is just for tell how the bits are delivered from a read."
| keepRemoteFile |
remoteFile
ifNil: [^self].
[keepRemoteFile := remoteFile.
remoteFile := nil.
keepRemoteFile writable ifTrue: [
keepRemoteFile reset.
keepRemoteFile putFile: self named: keepRemoteFile fileName]]
ensure: [remoteFile := keepRemoteFile]! !
!ServerDirectory methodsFor: 'accessing' stamp: 'mir 12/8/2003 14:18'!
keepAlive: aBoolean
keepAlive := aBoolean! !
!ServerDirectory methodsFor: 'testing' stamp: 'mir 12/8/2003 12:28'!
keepAlive
keepAlive ifNil: [keepAlive := false].
^keepAlive! !
!ServerDirectory methodsFor: 'up/download' stamp: 'mir 12/8/2003 14:17'!
getDirectory
"Return a stream with a listing of the current server directory. (Later -- Use a proxy server if one has been registered.)"
| listing |
client := self openFTPClient.
[listing := client getDirectory]
ensure: [self quit].
^ReadStream on: listing! !
!ServerDirectory methodsFor: 'up/download' stamp: 'mir 12/8/2003 14:16'!
getFileList
"Return a stream with a list of files in the current server directory. (Later -- Use a proxy server if one has been registered.)"
| listing |
client := self openFTPClient.
[listing := client getFileList]
ensure: [self quit].
^ReadStream on: listing! !
!ServerDirectory methodsFor: 'up/download' stamp: 'mir 12/8/2003 14:17'!
getFileNamed: fileNameOnServer
"Just FTP a file from a server. Return contents.
(Later -- Use a proxy server if one has been registered.)"
| result |
client := self openFTPClient.
[result := client getFileNamed: fileNameOnServer]
ensure: [self quit].
^result! !
!ServerDirectory methodsFor: 'up/download' stamp: 'mir 12/8/2003 14:17'!
getFileNamed: fileNameOnServer into: dataStream httpRequest: requestString
"Just FTP a file from a server. Return a stream. (Later -- Use a proxy server if one has been registered.)"
| resp |
self isTypeFile ifTrue: [
dataStream nextPutAll:
(resp _ FileStream oldFileNamed: server,(self serverDelimiter asString),
self bareDirectory, (self serverDelimiter asString),
fileNameOnServer) contentsOfEntireFile.
dataStream dataIsValid.
^ resp].
self isTypeHTTP ifTrue: [
resp _ HTTPSocket httpGet: (self fullNameFor: fileNameOnServer)
args: nil accept: 'application/octet-stream' request: requestString.
resp class == String ifTrue: [^ dataStream]. "error, no data"
dataStream copyFrom: resp.
dataStream dataIsValid.
^ dataStream].
client _ self openFTPClient. "Open passive. Do everything up to RETR or STOR"
[client getFileNamed: fileNameOnServer into: dataStream]
ensure: [self quit].
dataStream dataIsValid.
! !
!ServerDirectory methodsFor: 'up/download' stamp: 'mir 12/8/2003 14:17'!
getOnlyBuffer: buffer from: fileNameOnServer
"Open ftp, fill the buffer, and close the connection. Only first part of a very long file."
| dataStream |
client := self openFTPClient.
dataStream := WriteStream on: buffer.
[client getPartial: buffer size fileNamed: fileNameOnServer into: dataStream]
ensure: [self quit].
^buffer! !
!ServerDirectory methodsFor: 'up/download' stamp: 'mir 12/8/2003 16:39'!
putFile: fileStream named: fileNameOnServer
"Just FTP a local fileStream to the server. (Later -- Use a proxy server if one has been registered.)"
client := self openFTPClient.
client binary.
[client putFileStreamContents: fileStream as: fileNameOnServer]
ensure: [self quit]! !
!ServerDirectory methodsFor: 'dis/connect' stamp: 'mir 12/8/2003 15:09'!
openFTPClient
| loginSuccessful what |
client
ifNotNil: [client isConnected
ifTrue: [^client]
ifFalse: [client := nil]].
client _ FTPClient openOnHostNamed: server.
loginSuccessful := false.
[loginSuccessful]
whileFalse: [
[loginSuccessful := true.
client loginUser: self user password: self password]
on: LoginFailedException
do: [:ex |
passwordHolder _ nil.
what _ (PopUpMenu labels: 'enter password\give up' withCRs)
startUpWithCaption: 'Would you like to try another password?'.
what = 1 ifFalse: [self error: 'Login failed.'. ^nil].
loginSuccessful := false]].
client changeDirectoryTo: directory.
^client! !
!ServerDirectory methodsFor: 'dis/connect' stamp: 'mir 12/8/2003 12:53'!
quit
"break the connection"
self keepAlive
ifFalse: [self quitClient]! !
!ServerDirectory methodsFor: 'dis/connect' stamp: 'mir 12/8/2003 12:53'!
quitClient
"break the connection"
client ifNotNil: [client quit].
client := nil! !
!ServerDirectory methodsFor: 'file directory' stamp: 'mir 12/8/2003 14:16'!
createDirectory: localName
"Create a new sub directory within the current one"
self isTypeFile ifTrue: [
^FileDirectory createDirectory: localName
].
client := self openFTPClient.
[client makeDirectory: localName]
ensure: [self quit].
! !
!ServerDirectory methodsFor: 'file directory' stamp: 'mir 12/8/2003 14:17'!
deleteDirectory: localName
"Delete the sub directory within the current one. Call needs to ask user to confirm."
self isTypeFile ifTrue: [
^FileDirectory deleteFileNamed: localName
].
"Is this the right command???"
client := self openFTPClient.
[client deleteDirectory: localName]
ensure: [self quit].
! !
!ServerDirectory methodsFor: 'file directory' stamp: 'mir 12/8/2003 14:17'!
deleteFileNamed: fullName
"Detete a remote file. fullName is directory path, and does include name of the server. Or it can just be a fileName."
| file |
file _ self asServerFileNamed: fullName.
file isTypeFile ifTrue: [
^ (FileDirectory forFileName: (file fileNameRelativeTo: self))
deleteFileNamed: file fileName
].
client := self openFTPClient.
[client deleteFileNamed: fullName]
ensure: [self quit].
! !
!ServerDirectory methodsFor: 'file directory' stamp: 'mir 12/8/2003 14:17'!
exists
"It is difficult to tell if a directory exists. This is ugly, but it works for writable directories. http: will fall back on ftp for this"
| probe success |
success _ false.
self isTypeFile ifTrue: [
self entries size > 0 ifTrue: [^ true].
probe _ self newFileNamed: 'withNoName23'.
probe ifNotNil: [
probe close.
probe directory deleteFileNamed: probe localName].
^success _ probe notNil].
[client := self openFTPClient.
[client pwd]
ensure: [self quit].
success := true]
on: Error
do: [:ex | ].
^success! !
!ServerDirectory methodsFor: 'file directory' stamp: 'mir 12/8/2003 14:17'!
rename: fullName toBe: newName
"Rename a remote file. fullName is just be a fileName, or can be directory path that includes name of the server. newName is just a fileName"
| file |
file _ self asServerFileNamed: fullName.
file isTypeFile ifTrue: [
(FileDirectory forFileName: (file fileNameRelativeTo: self))
rename: file fileName toBe: newName
].
client := self openFTPClient.
[client renameFileNamed: fullName to: newName]
ensure: [self quit].
! !
!ServerDirectory methodsFor: 'multi-action sessions' stamp: 'mir 12/8/2003 12:54'!
sleep
"If still connected, break the connection"
self quitClient.
self keepAlive: false! !
!ServerDirectory methodsFor: 'multi-action sessions' stamp: 'mir 12/8/2003 12:55'!
wakeUp
"Start a multi-action session: Open for FTP and keep the connection open"
self isTypeFTP
ifTrue: [client := self openFTPClient].
self keepAlive: true
! !
!ServerDirectory methodsFor: 'squeaklets' stamp: 'mir 12/8/2003 12:35'!
upLoadProject: projectName members: archiveMembers retry: aBool
| dir okay m dirName idx |
m _ archiveMembers detect:[:any| any fileName includes: $/] ifNone:[nil].
m == nil ifFalse:[
dirName _ m fileName copyUpTo: $/.
self createDirectory: dirName.
dir _ self directoryNamed: dirName].
archiveMembers do:[:entry|
ProgressNotification signal: '4:uploadingFile' extra:'(uploading ', entry fileName,'...)'.
idx _ entry fileName indexOf: $/.
okay _ (idx > 0
ifTrue:[
dir putFile: entry contentStream
named: (entry fileName copyFrom: idx+1 to: entry fileName size)
retry: aBool]
ifFalse:[
self putFile: entry contentStream
named: entry fileName
retry: aBool]).
(okay == false
or: [okay isString])
ifTrue: [
self inform: 'Upload for ' , entry fileName printString , ' did not succeed (', okay , ').'.
^false].
].
ProgressNotification signal: '4:uploadingFile' extra:''.
^true! !
!ServerDirectory methodsFor: 'updates' stamp: 'mir 12/8/2003 12:24'!
checkServersWithPrefix: prefix andParseListInto: listBlock
"Check that all servers are up and have the latest Updates.list.
Warn user when can't write to a server that can still be read.
The contents of updates.list is parsed into {{vers. {fileNames*}}*},
and returned via the listBlock."
| serverList updateLists listContents maxSize outOfDateServers |
serverList _ self serversInGroup.
serverList isEmpty
ifTrue: [^Array new].
updateLists := Dictionary new.
serverList do: [:updateServer |
[listContents := updateServer getFileNamed: prefix , 'updates.list'.
updateLists at: updateServer put: listContents]
on: Error
do: [:ex |
(PopUpMenu labels: 'Cancel entire update' withCRs)
startUpWithCaption: 'Server ', updateServer moniker,
' is unavailable.\Please consider phoning the administator.\' withCRs, listContents.
^Array new]].
maxSize := (updateLists collect: [:each | each size]) max.
outOfDateServers := updateLists keys select: [:updateServer |
(updateLists at: updateServer) size < maxSize].
outOfDateServers do: [:updateServer |
(self outOfDate: updateServer) ifTrue: [^Array new]].
listBlock value: (Utilities parseListContents: listContents).
serverList removeAll: outOfDateServers.
^serverList
! !
!ServerDirectory methodsFor: 'updates' stamp: 'mir 12/8/2003 11:58'!
exportUpdatesExcept: skipList
"Into the section of updates.list corresponding to this version,
copy all the fileNames in the named updates.list for this group
that are more recently numbered."
"
(ServerDirectory serverInGroupNamed: 'Disney Internal Updates*')
exportUpdatesExcept: #(3959).
"
| myServers updateStrm response seq indexPrefix listContents version versIndex lastNum expContents expVersIndex additions |
self openGroup.
indexPrefix _ (self groupName includes: $*)
ifTrue: [(self groupName findTokens: ' ') first] "special for internal updates"
ifFalse: ['']. "normal"
myServers _ self checkServersWithPrefix: indexPrefix
andParseListInto: [:x | listContents _ x].
myServers size = 0 ifTrue: [self closeGroup. ^ self].
version _ SystemVersion current version.
versIndex _ (listContents collect: [:pair | pair first]) indexOf: version.
versIndex = 0 ifTrue:
[self inform: 'There is no section in updates.list for your version'.
self closeGroup. ^ nil]. "abort"
versIndex < listContents size ifTrue:
[response _ (PopUpMenu labels: 'Make update from an older version\Cancel update' withCRs)
startUpWithCaption: 'This system, ', SystemVersion current version,
' is not the latest version'.
response = 1 ifFalse: [self closeGroup. ^ nil]]. "abort"
"Get the old export updates.list."
expContents _ Utilities parseListContents:
(myServers first getFileNamed: 'updates.list').
expVersIndex _ (expContents collect: [:pair | pair first]) indexOf: version.
expVersIndex = 0 ifTrue:
[self inform: 'There is no section in updates.list for your version'.
self closeGroup. ^ nil]. "abort"
lastNum _ (expContents at: expVersIndex) last isEmpty
ifTrue: [0] "no checking if the current list is empty"
ifFalse: [(expContents at: expVersIndex) last last initialIntegerOrNil].
"Save old copy of updates.list on local disk"
FileDirectory default deleteFileNamed: 'updates.list.bk'.
Utilities writeList: expContents toStream: (FileStream fileNamed: 'updates.list.bk').
"Append all fileNames in my list that are not in the export list"
additions _ OrderedCollection new.
(listContents at: versIndex) last do:
[:fileName | seq _ fileName initialIntegerOrNil.
(seq > lastNum and: [(skipList includes: seq) not]) ifTrue:
[additions addLast: fileName]].
expContents at: expVersIndex put:
{version. (expContents at: expVersIndex) last , additions}.
(self confirm: 'Do you really want to export ' , additions size printString , ' recent updates?')
ifFalse: [self closeGroup. ^ nil]. "abort"
"Write a new copy of updates.list on all servers..."
updateStrm _ ReadStream on:
(String streamContents: [:s | Utilities writeList: expContents toStream: s]).
myServers do:
[:aServer |
updateStrm reset.
aServer putFile: updateStrm named: 'updates.list' retry: true.
Transcript show: 'Update succeeded on server ', aServer moniker; cr].
self closeGroup.
Transcript cr; show: 'Be sure to test your new update!!'; cr.
! !
ServerDirectory removeSelector: #isAwake!
Object subclass: #ServerDirectory
instanceVariableNames: 'server directory type user passwordHolder group moniker altURL urlObject client loaderUrl eToyUserListUrl eToyUserList keepAlive '
classVariableNames: 'LocalEToyBaseFolderSpecs LocalEToyUserListUrls LocalProjectDirectories Servers '
poolDictionaries: ''
category: 'Network-RemoteDirectory'!