'From Squeakland 3.1.3905 [latest update: #14] on 20 April 2001 at 6:56:41 pm'! "Change Set: httpServer Date: 20 April 2001 Author: Michael Rueger Adds support for project servers with ftp upload and http only download. The web server needs to be able to list the contents of the directory in Unix style ls -l format when given the URL for a directory. The simplest solution is to configure the server to invoke ls -l from the index.cgi script."! ServerDirectory subclass: #ProjectSwikiServer instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Network-Kernel'! ProjectSwikiServer subclass: #HTTPServerDirectory instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Network-Kernel'! ProjectSwikiServer subclass: #SuperSwikiServer instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Network-Kernel'! !FileList2 methodsFor: 'as yet unclassified' stamp: 'mir 4/16/2001 17:42'! limitedSuperSwikiDirectoryList | dir nameToShow dirList | dirList _ OrderedCollection new. ServerDirectory serverNames do: [ :n | dir _ ServerDirectory serverNamed: n. dir isProjectSwiki ifTrue: [ nameToShow _ n. dirList add: ((dir directoryWrapperClass with: dir name: nameToShow model: self) balloonText: dir realUrl) ]. ]. {Project squeakletDirectory} do: [ :each | dirList add: (FileDirectoryWrapper with: each name: each localName model: self) ]. ^dirList! ! !FileList2 methodsFor: 'as yet unclassified' stamp: 'mir 4/16/2001 17:42'! limitedSuperSwikiPublishDirectoryList | dir nameToShow dirList | dirList _ OrderedCollection new. ServerDirectory serverNames do: [ :n | dir _ ServerDirectory serverNamed: n. dir isProjectSwiki ifTrue: [ nameToShow _ n. dirList add: ((dir directoryWrapperClass with: dir name: nameToShow model: self) balloonText: dir realUrl) ]. ]. ^dirList! ! !HTTPClient class methodsFor: 'utilities' stamp: 'mir 4/13/2001 12:43'! getDirectoryListing: dirListURL | answer ftpEntries | answer _ self httpPostDocument: dirListURL args: Dictionary new. answer isString ifTrue: [^self error: 'Listing failed: ' , answer] ifFalse: [answer _ answer content]. answer first == $< ifTrue: [self error: 'Listing failed: ' , answer]. ftpEntries _ answer findTokens: SimpleClientSocket crLf. ^ ftpEntries collect:[:ftpEntry | ServerDirectory parseFTPEntry: ftpEntry] thenSelect: [:entry | entry notNil]! ! !HTTPClient class methodsFor: 'post/get'! httpPostDocument: url args: argsDict | argString stream content | ^self isRunningInBrowser ifTrue: [ argString _ argsDict ifNotNil: [argString _ HTTPSocket argString: argsDict] ifNil: ['']. stream _ FileStream post: argString , ' ' url: url , argString ifError: [self error: 'Error in post to ' , url printString]. stream position: 0. content _ stream upToEnd. stream close. MIMEDocument content: content] ifFalse: [HTTPSocket httpPostDocument: url args: argsDict]! ! !HTTPClient class methodsFor: 'post/get' stamp: 'mir 3/6/2001 12:10'! httpPostMultipart: url args: argsDict " do multipart/form-data encoding rather than x-www-urlencoded " ^self isRunningInBrowser ifTrue: [self pluginHttpPostMultipart: url args: argsDict] ifFalse: [HTTPSocket httpPostMultipart: url args: argsDict accept: nil request: '']! ! !HTTPClient class methodsFor: 'private' stamp: 'mir 3/7/2001 14:45'! pluginHttpPostMultipart: url args: argsDict | mimeBorder argsStream crLf fieldValue resultStream result | " do multipart/form-data encoding rather than x-www-urlencoded " crLf _ SimpleClientSocket crLf. mimeBorder _ '----squeak-', Time millisecondClockValue printString, '-stuff-----'. "encode the arguments dictionary" argsStream _ WriteStream on: String new. argsDict associationsDo: [:assoc | assoc value do: [ :value | "print the boundary" argsStream nextPutAll: '--', mimeBorder, crLf. " check if it's a non-text field " argsStream nextPutAll: 'Content-disposition: form-data; name="', assoc key, '"'. (value isKindOf: MIMEDocument) ifFalse: [fieldValue _ value] ifTrue: [argsStream nextPutAll: ' filename="', value url pathForFile, '"', crLf, 'Content-Type: ', value contentType. fieldValue _ (value content ifNil: [(FileStream fileNamed: value url pathForFile) contentsOfEntireFile] ifNotNil: [value content]) asString]. " Transcript show: 'field=', key, '; value=', fieldValue; cr. " argsStream nextPutAll: crLf, crLf, fieldValue, crLf. ]]. argsStream nextPutAll: '--', mimeBorder, '--'. resultStream _ FileStream post: ('ACCEPT: text/html', crLf, 'User-Agent: Squeak 3.1', crLf, 'Content-type: multipart/form-data; boundary=', mimeBorder, crLf, 'Content-length: ', argsStream contents size printString, crLf, crLf, argsStream contents) url: url ifError: [^'Error in post ' url toText]. "get the header of the reply" result _ resultStream ifNil: [''] ifNotNil: [resultStream upToEnd]. ^MIMEDocument content: result! ! !HTTPLoader methodsFor: 'requests' stamp: 'mir 4/16/2001 17:48'! retrieveContentsFor: url | request | request _ self class httpRequestClass for: url in: self. self addRequest: request. ^request contents! ! !HTTPSocket class methodsFor: 'get the page' stamp: 'mir 3/7/2001 14:49'! httpPostMultipart: url args: argsDict accept: mimeType request: requestString " do multipart/form-data encoding rather than x-www-urlencoded " " by Bolot Kerimbaev, 1998 " " this version is a memory hog: puts the whole file in memory " "bolot 12/14/2000 18:28 -- minor fixes to make it comply with RFC 1867" | serverName serverAddr s header length bare page list firstData aStream port argsStream specifiedServer type newUrl mimeBorder fieldValue | Socket initializeNetwork. "parse url" bare _ (url asLowercase beginsWith: 'http://') ifTrue: [url copyFrom: 8 to: url size] ifFalse: [url]. serverName _ bare copyUpTo: $/. specifiedServer _ serverName. (serverName includes: $:) ifFalse: [ port _ self defaultPort ] ifTrue: [ port _ (serverName copyFrom: (serverName indexOf: $:) + 1 to: serverName size) asNumber. serverName _ serverName copyUpTo: $:. ]. page _ bare copyFrom: (bare indexOf: $/) to: bare size. page size = 0 ifTrue: [page _ '/']. HTTPProxyServer ifNotNil: [ page _ 'http://', serverName, ':', port printString, page. "put back together" serverName _ HTTPProxyServer. port _ HTTPProxyPort]. mimeBorder _ '----squeak-georgia-tech-', Time millisecondClockValue printString, '-csl-cool-stuff-----'. "encode the arguments dictionary" argsStream _ WriteStream on: String new. argsDict associationsDo: [:assoc | assoc value do: [ :value | "print the boundary" argsStream nextPutAll: '--', mimeBorder, CrLf. " check if it's a non-text field " argsStream nextPutAll: 'Content-disposition: multipart/form-data; name="', assoc key, '"'. (value isKindOf: MIMEDocument) ifFalse: [fieldValue _ value] ifTrue: [argsStream nextPutAll: ' filename="', value url pathForFile, '"', CrLf, 'Content-Type: ', value contentType. fieldValue _ (value content ifNil: [(FileStream fileNamed: value url pathForFile) contentsOfEntireFile] ifNotNil: [value content]) asString]. " Transcript show: 'field=', key, '; value=', fieldValue; cr. " argsStream nextPutAll: CrLf, CrLf, fieldValue, CrLf. ]]. argsStream nextPutAll: '--', mimeBorder, '--'. "make the request" self retry: [serverAddr _ NetNameResolver addressForName: serverName timeout: 20. serverAddr ~~ nil] asking: 'Trouble resolving server name. Keep trying?' ifGiveUp: [^ 'Could not resolve the server named: ', serverName]. s _ HTTPSocket new. s connectTo: serverAddr port: port. s waitForConnectionUntil: self standardDeadline. Transcript cr; show: serverName, ':', port asString; cr. s sendCommand: 'POST ', page, ' HTTP/1.1', CrLf, (mimeType ifNotNil: ['ACCEPT: ', mimeType, CrLf] ifNil: ['']), 'ACCEPT: text/html', CrLf, "Always accept plain text" HTTPBlabEmail, "may be empty" requestString, "extra user request. Authorization" 'User-Agent: Squeak 1.31', CrLf, 'Content-type: multipart/form-data; boundary=', mimeBorder, CrLf, 'Content-length: ', argsStream contents size printString, CrLf, 'Host: ', specifiedServer, CrLf. "blank line automatically added" s sendCommand: argsStream contents. "get the header of the reply" list _ s getResponseUpTo: CrLf, CrLf. "list = header, CrLf, CrLf, beginningOfData" header _ list at: 1. "Transcript show: page; cr; show: argsStream contents; cr; show: header; cr." firstData _ list at: 3. "dig out some headers" s header: header. length _ s getHeader: 'content-length'. length ifNotNil: [ length _ length asNumber ]. type _ s getHeader: 'content-type'. s responseCode first = $3 ifTrue: [ "redirected - don't re-post automatically" "for now, just do a GET, without discriminating between 301/302 codes" newUrl _ s getHeader: 'location'. newUrl ifNotNil: [ (newUrl beginsWith: 'http://') ifFalse: [ (newUrl beginsWith: '/') ifTrue: [newUrl _ (bare copyUpTo: $/), newUrl] ifFalse: [newUrl _ url, newUrl. self flag: #todo "should do a relative URL"] ]. Transcript show: 'redirecting to: ', newUrl; cr. s destroy. ^self httpGetDocument: newUrl "for some codes, may do: ^self httpPostMultipart: newUrl args: argsDict accept: mimeType request: requestString"] ]. aStream _ s getRestOfBuffer: firstData totalLength: length. s responseCode = '401' ifTrue: [^ header, aStream contents]. s destroy. "Always OK to destroy!!" ^ MIMEDocument contentType: type content: aStream contents url: url! ! !HTTPSocket class methodsFor: 'utilities' stamp: 'mir 4/13/2001 12:39'! httpPostDocument: url args: argsDict accept: mimeType request: requestString "like httpGET, except it does a POST instead of a GET. POST allows data to be uploaded" | s header length page list firstData aStream type newUrl httpUrl argString | Socket initializeNetwork. httpUrl _ Url absoluteFromText: url. page _ httpUrl fullPath. "add arguments" argString _ argsDict ifNotNil: [argString _ self argString: argsDict] ifNil: ['']. page _ page, argString. s _ HTTPSocket new. s _ self initHTTPSocket: httpUrl wait: (self deadlineSecs: 30) ifError: [:errorString | ^errorString]. Transcript cr; show: url; cr. s sendCommand: 'POST ', page, ' HTTP/1.0', CrLf, (mimeType ifNotNil: ['ACCEPT: ', mimeType, CrLf] ifNil: ['']), 'ACCEPT: text/html', CrLf, "Always accept plain text" HTTPBlabEmail, "may be empty" requestString, "extra user request. Authorization" 'User-Agent: Squeak 1.31', CrLf, 'Content-type: application/x-www-form-urlencoded', CrLf, 'Content-length: ', argString size printString, CrLf, 'Host: ', httpUrl authority, CrLf. "blank line automatically added" s sendCommand: argString. "get the header of the reply" list _ s getResponseUpTo: CrLf, CrLf ignoring: (String with: CR). "list = header, CrLf, CrLf, beginningOfData" header _ list at: 1. "Transcript show: page; cr; show: argsStream contents; cr; show: header; cr." firstData _ list at: 3. "dig out some headers" s header: header. length _ s getHeader: 'content-length'. length ifNotNil: [ length _ length asNumber ]. type _ s getHeader: 'content-type'. s responseCode first = $3 ifTrue: [ newUrl _ s getHeader: 'location'. newUrl ifNotNil: [ Transcript show: 'Response: ' , s responseCode. Transcript show: ' redirecting to: ', newUrl; cr. s destroy. "^self httpPostDocument: newUrl args: argsDict accept: mimeType" ^self httpGetDocument: newUrl accept: mimeType ] ]. aStream _ s getRestOfBuffer: firstData totalLength: length. s responseCode = '401' ifTrue: [^ header, aStream contents]. s destroy. "Always OK to destroy!!" ^ MIMEDocument contentType: type content: aStream contents url: url! ! !Project methodsFor: 'file in/out' stamp: 'mir 3/6/2001 12:42'! serverList | servers server | "Take my list of server URLs and return a list of ServerDirectories to write on." urlList isEmptyOrNil ifTrue: [^ nil]. servers _ OrderedCollection new. urlList do: [:url | server _ ServerDirectory serverForURL: url. server ifNotNil: [servers add: server]]. ^servers isEmpty ifTrue: [nil] ifFalse: [servers]! ! !Project methodsFor: 'resources' stamp: 'mir 4/13/2001 12:47'! resourceUrl "compose my base url for resources on the server" | firstURL serverList | serverList _ self serverList. serverList isEmptyOrNil ifTrue: [^'']. firstURL _ serverList first altUrl. firstURL last == $/ ifFalse: [firstURL _ firstURL, '/']. ^ firstURL, self resourceDirectoryName ! ! !Project class methodsFor: 'squeaklet on server' stamp: 'mir 4/17/2001 17:47'! fromUrl: urlString "Load the project, and make a thumbnail to it in the current project. Replace the old one if necessary. Project fromUrl: 'http://www.squeak.org/Squeak2.0/2.7segments/Squeak_Easy.pr.gz'. " | pair projName proj triple serverDir projectFilename url serverUrl | Project canWeLoadAProjectNow ifFalse: [^ self]. "serverFile _ HTTPLoader default contentStreamFor: urlString." url _ Url absoluteFromText: urlString. projectFilename _ url path last. triple _ Project parseProjectFileName: projectFilename unescapePercents. projName _ triple first. (proj _ Project named: projName) ifNotNil: ["it appeared" ^ ProjectEntryNotification signal: proj]. serverUrl _ (url copy path: (url path copyWithout: url path last)) toText. serverDir _ ServerDirectory serverForURL: serverUrl. pair _ self mostRecent: projectFilename onServer: serverDir. "Pair first is name exactly as it is on the server" pair first ifNil: [^self openBlankProjectNamed: projName]. ProjectLoading installRemoteNamed: pair first from: serverDir named: projName in: CurrentProject.! ! !ServerDirectory methodsFor: 'file directory' stamp: 'mir 4/13/2001 12:41'! entries "Return a collection of directory entries for the files and directories in this directory. Each entry is a five-element array: ( )." | dir ftpEntries | "We start with ftp directory entries of the form... d--------- 1 owner group 0 Apr 27 22:01 blasttest ---------- 1 owner group 93812 Jul 21 1997 COMMAND.COM 1 2 3 4 5 6 7 8 9 -- token index" self isTypeFile ifTrue: [ urlObject isAbsolute ifFalse: [urlObject default]. ^ (FileDirectory on: urlObject pathForDirectory) entries ]. dir _ self getDirectory. (dir respondsTo: #contentsOfEntireFile) ifFalse: [^ #()]. ftpEntries _ dir contentsOfEntireFile findTokens: FTPSocket crLf. "ftpEntries inspect." ^ ftpEntries collect:[:ftpEntry | self class parseFTPEntry: ftpEntry] thenSelect: [:entry | entry notNil]! ! !ServerDirectory methodsFor: 'squeaklets' stamp: 'mir 4/20/2001 17:26'! upLoadProject: projectName members: archiveMembers retry: aBool | dir okay so m dirName idx | m _ archiveMembers detect:[:any| any fileName includes: $/] ifNone:[nil]. m == nil ifFalse:[ dirName _ m fileName copyUpTo: $/. self createDirectory: dirName. so _ socket. socket _ nil. dir _ self directoryNamed: dirName. socket _ so]. 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: 'testing' stamp: 'mir 4/16/2001 17:41'! isProjectSwiki ^false! ! !ProjectSwikiServer methodsFor: 'testing' stamp: 'mir 4/16/2001 17:42'! isProjectSwiki ^true! ! !ProjectSwikiServer methodsFor: 'initialize' stamp: 'mir 4/20/2001 18:43'! wakeUp! ! !HTTPServerDirectory methodsFor: 'file directory' stamp: 'mir 4/20/2001 18:44'! directoryNames | dirNames projectNames entries | "Return a collection of names for the subdirectories of this directory but filter out project directories." entries _ self entries. dirNames _ (entries select: [:entry | entry at: 4]) collect: [:entry | entry first]. projectNames _ Set new. entries do: [:entry | ((entry at: 4) not and: ['*.pr' match: entry first]) ifTrue: [projectNames add: (entry first copyFrom: 1 to: entry first size-3)]]. ^dirNames reject: [:each | projectNames includes: each] ! ! !HTTPServerDirectory methodsFor: 'file directory' stamp: 'mir 4/20/2001 18:43'! entries ^HTTPClient getDirectoryListing: self dirListUrl! ! !HTTPServerDirectory methodsFor: 'file directory' stamp: 'mir 4/20/2001 18:26'! fileNames "Return a collection of names for the files (but not directories) in this directory." "(ServerDirectory serverNamed: 'UIUCArchive') fileNames" self dirListUrl ifNil: [^self error: 'No URL set for fetching the directory listing.' ]. ^(self entries select: [:entry | (entry at: 4) not]) collect: [:entry | entry first] ! ! !HTTPServerDirectory methodsFor: 'file directory' stamp: 'mir 4/16/2001 17:54'! oldFileNamed: aName | contents | contents _ HTTPLoader default retrieveContentsFor: (self altUrl , '/' , aName). ^(SwikiPseudoFileStream with: contents content) reset; directory: self; localName: aName; yourself ! ! !HTTPServerDirectory methodsFor: 'accessing' stamp: 'mir 4/16/2001 18:02'! dirListUrl ^self altUrl! ! !HTTPServerDirectory methodsFor: 'accessing' stamp: 'mir 4/16/2001 18:02'! directoryNamed: localFileName | newDir | newDir _ super directoryNamed: localFileName. newDir altUrl: (self altUrl , '/' , localFileName). ^newDir! ! !ServerDirectory class methodsFor: 'misc' stamp: 'mir 4/13/2001 12:41'! parseFTPEntry: ftpEntry | tokens longy dateInSeconds thisYear thisMonth | thisYear _ Date today year. thisMonth _ Date today monthIndex. tokens _ ftpEntry findTokens: ' '. tokens size = 8 ifTrue: [((tokens at: 6) size ~= 3 and: [(tokens at: 5) size = 3]) ifTrue: ["Fix for case that group is blank (relies on month being 3 chars)" tokens _ tokens copyReplaceFrom: 4 to: 3 with: {'blank'}]]. tokens size >= 9 ifFalse:[^nil]. ((tokens at: 6) size ~= 3 and: [(tokens at: 5) size = 3]) ifTrue: ["Fix for case that group is blank (relies on month being 3 chars)" tokens _ tokens copyReplaceFrom: 4 to: 3 with: {'blank'}]. tokens size > 9 ifTrue: [longy _ tokens at: 9. 10 to: tokens size do: [:i | longy _ longy , ' ' , (tokens at: i)]. tokens at: 9 put: longy]. dateInSeconds _ self secondsForDay: (tokens at: 7) month: (tokens at: 6) yearOrTime: (tokens at: 8) thisMonth: thisMonth thisYear: thisYear. ^DirectoryEntry name: (tokens at: 9) "file name" creationTime: dateInSeconds "creation date" modificationTime: dateInSeconds "modification time" isDirectory: tokens first first = $d "is-a-directory flag" fileSize: tokens fifth asNumber "file size" ! ! !ServerDirectory class methodsFor: 'misc' stamp: 'mir 4/13/2001 12:44'! secondsForDay: dayToken month: monthToken yearOrTime: ytToken thisMonth: thisMonth thisYear: thisYear | ftpDay ftpMonth pickAYear jDateToday trialJulianDate | ftpDay _ dayToken asNumber. ftpMonth _ Date indexOfMonth: monthToken. (ytToken includes: $:) ifFalse: [ ^(Date newDay: ftpDay month: ftpMonth year: ytToken asNumber) asSeconds ]. jDateToday _ Date today dayOfYear. trialJulianDate _ (Date newDay: ftpDay month: ftpMonth year: thisYear) dayOfYear. "Date has no year if within six months (do we need to check the day, too?)" "Well it appear to be pickier than that... it isn't just 6 months or 6 months and the day of the month, put perhaps the julian date AND the time as well. I don't know what the precise standard is, but this seems to produce better results" pickAYear _ (jDateToday - trialJulianDate) > 182 ifTrue: [ thisYear + 1 "his clock could be ahead of ours??" ] ifFalse: [ pickAYear _ (trialJulianDate - jDateToday) > 182 ifTrue: [ thisYear - 1 ] ifFalse: [ thisYear ]. ]. ^(Date newDay: ftpDay month: ftpMonth year: pickAYear) asSeconds + (Time readFrom: (ReadStream on: ytToken)) asSeconds ! ! !ServerDirectory class methodsFor: 'available servers' stamp: 'mir 4/20/2001 16:59'! serverForURL: aURL | serversForURL server urlPath serverPath relPath | serversForURL _ Servers values select: [:each | aURL beginsWith: each realUrl]. serversForURL isEmpty ifTrue: [^nil]. server _ serversForURL first. urlPath _ aURL asUrl path. (urlPath isEmpty not and: [urlPath last isEmpty]) ifTrue: [urlPath removeLast]. serverPath _ server realUrl asUrl path. urlPath size < serverPath size ifTrue: [^nil]. relPath _ String new. serverPath size +1 to: urlPath size do: [:i | relPath _ relPath , '/' , (urlPath at: i)]. ^relPath isEmpty ifTrue: [server] ifFalse: [server directoryNamed: (relPath copyFrom: 2 to: relPath size)]! ! SuperSwikiServer removeSelector: #wakeUp! ServerDirectory removeSelector: #parseFTPEntry:! ServerDirectory removeSelector: #secondsForDay:month:yearOrTime:thisMonth:thisYear:! "Postscript:" | server | server _ HTTPServerDirectory new. server type: #ftp; server: 'www.squeakland.org'; user: 'sqland'; directory: 'projects'; altUrl: 'http://www.squeakland.org/projects'. ServerDirectory addServer: server named: 'Squeakland-Projects'. !