'From Squeak3.2 of 11 July 2002 [latest update: #4956] on 6 September 2002 at 5:21:59 pm'! Object subclass: #XMLRPCDateTime instanceVariableNames: 'date time ' classVariableNames: '' poolDictionaries: '' category: 'Synerge-XML-RPC'! XMLRPCDateTime class instanceVariableNames: ''! Object subclass: #XMLRPCDecoder instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Synerge-XML-RPC'! Error subclass: #XMLRPCError instanceVariableNames: 'faultCode ' classVariableNames: '' poolDictionaries: '' category: 'XMLRPC-Server-Errors'! !XMLRPCError commentStamp: '' prior: 0! This is a generic error, it is raised if an unknown error has been detected.! XMLRPCError subclass: #XMLRPCClassNotFoundError instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'XMLRPC-Server-Errors'! !XMLRPCClassNotFoundError commentStamp: '' prior: 0! The request Class wasn't found! Object subclass: #XMLRPCErrorHandler instanceVariableNames: 'error ' classVariableNames: '' poolDictionaries: '' category: 'XMLRPC-Server'! !XMLRPCErrorHandler commentStamp: '' prior: 0! This is the error handler for XMLRPC errors! Object subclass: #XMLRPCHttpModule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'XMLRPC-Server'! !XMLRPCHttpModule commentStamp: '' prior: 0! This comanche module handles incoming requests for a XMLRPC server! XMLRPCHttpModule class instanceVariableNames: ''! XMLRPCError subclass: #XMLRPCMethodError instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'XMLRPC-Server-Errors'! XMLRPCError subclass: #XMLRPCRequestError instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'XMLRPC-Server-Errors'! !XMLRPCRequestError commentStamp: '' prior: 0! An error raised if a malformed request was found! XMLRPCError subclass: #XMLRPCReturnError instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'XMLRPC-Server-Errors'! !XMLRPCReturnError commentStamp: '' prior: 0! An error occured while encoding a methodresponse! Object subclass: #XMLRPCServerRequest instanceVariableNames: 'methodCall params targetURI ' classVariableNames: 'Receivers ' poolDictionaries: '' category: 'XMLRPC-Server'! !XMLRPCServerRequest commentStamp: '' prior: 0! This class holds all information about a XMLRPC request an coordinates the computation of a XMLRPC methodcall! XMLRPCServerRequest class instanceVariableNames: ''! Object subclass: #XMLRPCStandardValidator instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'XMLRPC-Server-Validation'! XMLRPCStandardValidator class instanceVariableNames: ''! !Array methodsFor: 'printing' stamp: 'M.F. 9/6/2002 17:15'! asXMLRPCString | r | r _ Text new. r append: ' '. self do: [:each | r append: each asXMLRPCString]. r append: ' '. ^ r asString! ! !Dictionary methodsFor: 'printing'! asXMLRPCString | r | r _ Text new. r append: ' '. self keysAndValuesDo: [:key :value | r append: ' ' , key asString , ' '. r append: value asXMLRPCString; append: ' ']. r append: ' '. ^ r asString! ! !False methodsFor: 'printing'! asXMLRPCString ^ '0 '! ! !Float methodsFor: 'printing'! asXMLRPCString ^ '' , self asString , ' '! ! !SmallInteger methodsFor: 'printing'! asXMLRPCString ^ '' , self asString , ' '! ! !Stream methodsFor: 'printing'! asXMLRPCString ^ '' , (Base64MimeConverter mimeEncode: self) contents , ' '! ! !String methodsFor: 'printing'! asXMLRPCString ^ '' , self asString , ' '! ! !True methodsFor: 'printing'! asXMLRPCString ^ '1 '! ! !XMLRPCDateTime methodsFor: 'as yet unclassified'! asXMLRPCString | m d | date monthIndex asString size = 1 ifTrue: [m _ '0' , date monthIndex asString] ifFalse: [m _ date monthIndex asString]. date dayOfMonth asString size = 1 ifTrue: [d _ '0' , date dayOfMonth asString] ifFalse: [d _ date dayOfMonth asString]. ^ '' , (date year asString , m , d , 'T' , time print24) , ' '! ! !XMLRPCDateTime methodsFor: 'as yet unclassified' stamp: 'chl 10/10/2001 00:12'! date ^ date! ! !XMLRPCDateTime methodsFor: 'as yet unclassified' stamp: 'chl 10/10/2001 00:13'! date: aDate date _ aDate! ! !XMLRPCDateTime methodsFor: 'as yet unclassified' stamp: 'chl 10/10/2001 00:12'! time ^ time! ! !XMLRPCDateTime methodsFor: 'as yet unclassified' stamp: 'chl 10/10/2001 00:12'! time: aTime time _ aTime! ! !XMLRPCDateTime class methodsFor: 'as yet unclassified' stamp: 'chl 10/10/2001 00:14'! fromDate: aDate time: aTime ^ self new date: aDate; time: aTime! ! !XMLRPCDecoder methodsFor: 'as yet unclassified'! decode: anXMLElement (anXMLElement entityAt: 'value') entities isEmpty ifTrue: [^ (anXMLElement entityAt: 'value') contentString]. ((anXMLElement entityAt: 'value') entities at: 1) key = 'string' ifTrue: [^ ((anXMLElement entityAt: 'value') entityAt: 'string') contentString]. ((anXMLElement entityAt: 'value') entities at: 1) key = 'i4' ifTrue: [^ SmallInteger readFrom: ((anXMLElement entityAt: 'value') entityAt: 'i4') contentString readStream]. ((anXMLElement entityAt: 'value') entities at: 1) key = 'int' ifTrue: [^ SmallInteger readFrom: ((anXMLElement entityAt: 'value') entityAt: 'int') contentString readStream]. ((anXMLElement entityAt: 'value') entities at: 1) key = 'double' ifTrue: [^ Float readFrom: ((anXMLElement entityAt: 'value') entityAt: 'double') contentString readStream]. ((anXMLElement entityAt: 'value') entities at: 1) key = 'base64' ifTrue: [^ Base64MimeConverter mimeDecodeToBytes: ((anXMLElement entityAt: 'value') entityAt: 'base64') contentString readStream]. ((anXMLElement entityAt: 'value') entities at: 1) key = 'dateTime.iso8601' ifTrue: [^ self decodeDateTime: ((anXMLElement entityAt: 'value') entityAt: 'dateTime.iso8601') contentString]. ((anXMLElement entityAt: 'value') entities at: 1) key = 'boolean' ifTrue: [((anXMLElement entityAt: 'value') entityAt: 'boolean') contentString = '1' ifTrue: [^ true] ifFalse: [^ false]]. ((anXMLElement entityAt: 'value') entities at: 1) key = 'array' ifTrue: [^ self decodeArray: anXMLElement]. ((anXMLElement entityAt: 'value') entities at: 1) key = 'struct' ifTrue: [^ self decodeStruct: anXMLElement]! ! !XMLRPCDecoder methodsFor: 'as yet unclassified' stamp: 'chl 10/9/2001 01:25'! decodeArray: anXMLElement | coll | coll _ OrderedCollection new. (((anXMLElement entityAt: 'value') entityAt: 'array') entityAt: 'data') entities do: [ :xmlElem | coll add: (self decode: (XMLDocument new addEntity: (xmlElem value))) ]. ^ coll asArray! ! !XMLRPCDecoder methodsFor: 'as yet unclassified' stamp: 'chl 10/12/2001 01:00'! decodeDateTime: aDT | d t | d _ Date newDay: (aDT copyFrom: 7 to: 8) asInteger month: (aDT copyFrom: 5 to: 6) asInteger year: (aDT copyFrom: 1 to: 4) asInteger. t _ Time readFrom: (aDT copyFrom: 10 to: 17) readStream. ^ XMLRPCDateTime fromDate: d time: t ! ! !XMLRPCDecoder methodsFor: 'as yet unclassified'! decodeStruct: anXMLElement | dict | dict _ Dictionary new. ((anXMLElement entityAt: 'value') entityAt: 'struct') entities keysAndValuesDo: [:key :val | dict at: (val value entityAt: 'name') contentString asSymbol put: (self decode: val value)]. ^ dict! ! !XMLRPCEncoder methodsFor: 'as yet unclassified'! encode: aValue ^ aValue asXMLRPCString ! ! !XMLRPCError methodsFor: 'accessing'! faultCode "Answer the receiver's 'faultCode'." ^ faultCode ifNil: [ ^0]! ! !XMLRPCError methodsFor: 'accessing' stamp: 'MFritsche 9/3/2002 19:46'! faultCode: anObject "Set the receiver's instance variable 'faultCode' to be anObject." faultCode := anObject! ! !XMLRPCClassNotFoundError methodsFor: 'as yet unclassified' stamp: 'MFritsche 9/3/2002 19:48'! faultCode ^ 1! ! !XMLRPCErrorHandler methodsFor: 'accessing'! error "Answer the receiver's 'error'." ^error! ! !XMLRPCErrorHandler methodsFor: 'accessing'! error: anObject "Set the receiver's instance variable 'error' to be anObject." error := anObject! ! !XMLRPCErrorHandler methodsFor: 'accessing'! errorMessage | str errorDict | errorDict _ Dictionary new. (error class canUnderstand: #faultCode) ifTrue: [errorDict at: #faultCode put: error faultCode] ifFalse: [errorDict at: #faultCode put: 10]. errorDict at: #faultString put: error messageText. str _ WriteStream on: (String new: 1000). str nextPutAll: ''; nextPutAll: errorDict asXMLRPCString; nextPutAll: ''. ^ str contents! ! !XMLRPCHttpModule methodsFor: 'as yet unclassified'! process: request | xrReq | [request contentType = MIMEDocument contentTypeXml ifFalse: [XMLRPCRequestError new signal: 'Request is not in text/xml']. xrReq _ XMLRPCServerRequest fromRequest: (request stream next: request contentLength). xrReq targetURI: request url. ^ xrReq methodResponse] on: Error do: [:e | ^ (XMLRPCErrorHandler new error: e) errorMessage]! ! !XMLRPCHttpModule class methodsFor: 'as yet unclassified'! initialize Smalltalk addToStartUpList: self after: AutoStart. Smalltalk addToShutDownList: self! ! !XMLRPCHttpModule class methodsFor: 'as yet unclassified'! serviceOn: aPort ^ ComancheNetService named: 'XMLRPC' onPort: aPort! ! !XMLRPCHttpModule class methodsFor: 'as yet unclassified'! shutDown self stop! ! !XMLRPCHttpModule class methodsFor: 'as yet unclassified'! start self startOn: 8200! ! !XMLRPCHttpModule class methodsFor: 'as yet unclassified'! startOn: aPort | service | self stop. service _ self serviceOn: aPort. service module: self new. service start! ! !XMLRPCHttpModule class methodsFor: 'as yet unclassified'! startUp self start! ! !XMLRPCHttpModule class methodsFor: 'as yet unclassified'! stop (ComancheNetService services at: 'XMLRPC' ifAbsent: []) ifNotNilDo: [:s | s unregister]! ! !XMLRPCMethodError methodsFor: 'as yet unclassified' stamp: 'MFritsche 9/3/2002 19:48'! faultCode ^ 2! ! !XMLRPCRequest methodsFor: 'as yet unclassified'! execute | s cmd crlf req list xmldoc | s _ HTTPSocket initHTTPSocket: endpoint ifError: 'XML-RPC Transport Layer Error'. crlf _ String crlf. req _ self build. cmd _ 'POST ' , endpoint fullPath , ' HTTP/1.0' , crlf , 'User-Agent: synerge SqXR' , crlf , 'Host: ' , endpoint authority , crlf , 'Content-type: text/xml' , crlf , 'Content-length: ' , req size asString , crlf , crlf , req. s sendCommand: cmd. list _ s getResponseUpTo: crlf , crlf ignoring: String cr. "list = header, CrLf, CrLf, beginningOfData" xmldoc _ XMLDOMParser parseDocumentFrom: (s getRestOfBuffer: (list at: 3)) contents readStream. ((xmldoc entityAt: 'methodResponse') entities at: 1) key = 'fault' ifTrue: [self error: 'XML-RPC error: ' , ((XMLRPCDecoder new decode: (XMLDocument new addEntity: ((xmldoc entityAt: 'methodResponse') entities at: 1) value)) at: 'faultString')]. ^ XMLRPCDecoder new decode: (((xmldoc entityAt: 'methodResponse') entityAt: 'params') entityAt: 'param')"^ cmd, crlf, '- - - ', crlf, (s getRestOfBuffer: (list at: 3)) contents."! ]style[(7 3 27 4 1 3 10 17 8 10 31 3 4 3 6 8 3 3 4 9 3 3 7 3 8 12 11 3 4 3 26 3 4 3 8 3 8 13 4 3 24 3 4 3 18 3 3 17 4 3 4 3 3 3 1 14 3 3 4 3 1 18 4 3 4 11 6 6 44 2 6 3 12 21 1 24 4 5 1 27 6 11 16 15 1 8 7 12 4 8 17 10 13 14 11 18 6 11 16 15 1 21 13 7 13 18 6 11 16 16 8 16 7 1 74)f1b,f1,f1cblue;i,f1,f1cblue;i,f1,f1cmagenta;,f1,f1cmagenta;,f1,f1c152050000,f1,f1cblue;i,f1,f1cmagenta;,f1,f1cblue;i,f1,f1cmagenta;,f1,f1cblue;i,f1,f1c152050000,f1,f1cmagenta;,f1,f1c152050000,f1,f1cblue;i,f1,f1c152050000,f1,f1cblue;i,f1,f1c152050000,f1,f1cmagenta;,f1,f1cblue;i,f1,f1c152050000,f1,f1cblue;i,f1,f1c152050000,f1,f1cblue;i,f1,f1cblue;i,f1,f1cblue;i,f1,f1cblue;i,f1,f1cblue;i,f1,f1cblue;i,f1,f1cblue;i,f1,f1cblue;i,f1,f1cblue;i,f1,f1cblue;i,f1,f1cmagenta;,f1,f1c255152000,f1,f1cblue;i,f1,f1cmagenta;,f1,f1cblue;i,f1,f1cblue;i,f1,f1c152050000,f1,f1cblue;i,f1,f1c152050000,f1,f1c152050000,f1,f1c152050000,f1,f1cmagenta;,f1,f1c152050000,f1,f1cmagenta;,f1,f1cmagenta;,f1,f1cblue;i,f1,f1c152050000,f1,f1c152050000,f1,f1c152050000,f1,f1cmagenta;,f1,f1cblue;i,f1,f1c152050000,f1,f1c152050000,f1,f1c152050000,f1,f1c255152000! ! !XMLRPCRequestError methodsFor: 'as yet unclassified' stamp: 'MFritsche 9/3/2002 19:49'! faultCode ^ 3! ! !XMLRPCReturnError methodsFor: 'as yet unclassified' stamp: 'MFritsche 9/3/2002 19:49'! faultCode ^ 4! ! !XMLRPCServerRequest methodsFor: 'accessing' stamp: 'MFritsche 9/5/2002 20:56'! methodCall "Answer the receiver's 'methodCall'." ^methodCall! ! !XMLRPCServerRequest methodsFor: 'accessing' stamp: 'MFritsche 9/5/2002 20:56'! methodCall: anObject "Set the receiver's instance variable 'methodCall' to be anObject." methodCall := anObject! ! !XMLRPCServerRequest methodsFor: 'accessing'! methodResponse | stream ret | stream _ WriteStream on: String new. stream nextPutAll: ''. [ret _ (Receivers at: methodCall asSymbol ifAbsent: [XMLRPCMethodError new signal: 'Serverside method not found']) xmlrpcMethodCall: self ] on: MessageNotUnderstood do: [:e | XMLRPCMethodError new signal: 'Message not understood by server class']. ret ifNil: [ret _ false]. [stream nextPutAll: ret asXMLRPCString] on: Error do: [XMLRPCReturnError new signal: 'Could not encode returned value "' , ret asString , '"']. stream nextPutAll: ''. ^ stream contents! ! !XMLRPCServerRequest methodsFor: 'accessing' stamp: 'MFritsche 9/5/2002 20:56'! params "Answer the receiver's 'params'." ^params! ! !XMLRPCServerRequest methodsFor: 'accessing'! params: anObject "Set the receiver's instance variable 'params' to be anObject." params := anObject! ! !XMLRPCServerRequest methodsFor: 'accessing' stamp: 'MFritsche 9/5/2002 20:56'! targetURI "Answer the receiver's 'targetURI'." ^targetURI! ! !XMLRPCServerRequest methodsFor: 'accessing' stamp: 'MFritsche 9/5/2002 20:56'! targetURI: anObject "Set the receiver's instance variable 'targetURI' to be anObject." targetURI := anObject! ! !XMLRPCServerRequest class methodsFor: 'as yet unclassified' stamp: 'MFritsche 9/5/2002 21:25'! addMethod: mthd realReceiver: clz Receivers at: mthd asSymbol put: clz! ! !XMLRPCServerRequest class methodsFor: 'as yet unclassified'! cleanUpReceiverDictionary " deletes references to obsolete classes from the 'Receivers' dictionary" | removeThem | removeThem _ Receivers select: [:each | each isObsolete]. removeThem keysDo: [:key | Receivers removeKey: key]! ! !XMLRPCServerRequest class methodsFor: 'as yet unclassified'! fromRequest: xmlString | xmldoc r parameters | r _ self new. parameters _ OrderedCollection new. xmldoc _ XMLDOMParser parseDocumentFrom: xmlString readStream. r methodCall: (((xmldoc entityAt: #methodCall) entities at: 1) value contents at: 1) string. [((xmldoc entityAt: #methodCall) entityAt: #params) entities do: [:each | parameters add: (XMLRPCDecoder new decode: each value)]] on: Error do: [XMLRPCRequestError new signal: 'Could not decode request']. r params: parameters. ^ r! ! !XMLRPCServerRequest class methodsFor: 'as yet unclassified' stamp: 'MFritsche 9/5/2002 21:24'! initialize Receivers _ Dictionary new.! ! !XMLRPCServerRequest class methodsFor: 'as yet unclassified' stamp: 'MFritsche 9/5/2002 21:26'! removeMethod: mthd Receivers removeKey: mthd asSymbol! ! !XMLRPCStandardValidator class methodsFor: 'as yet unclassified'! addTests "XMLRPCStandardValidator addTests" XMLRPCServerRequest addMethod: 'validator1.arrayOfStructsTest' realReceiver: self. XMLRPCServerRequest addMethod: 'validator1.countTheEntities' realReceiver: self. XMLRPCServerRequest addMethod: 'validator1.echoStructTest' realReceiver: self. XMLRPCServerRequest addMethod: 'validator1.easyStructTest' realReceiver: self. XMLRPCServerRequest addMethod: 'validator1.moderateSizeArrayCheck' realReceiver: self. XMLRPCServerRequest addMethod: 'validator1.nestedStructTest' realReceiver: self. XMLRPCServerRequest addMethod: 'validator1.simpleStructReturnTest' realReceiver: self. XMLRPCServerRequest addMethod: 'validator1.manyTypesTest' realReceiver: self! ! !XMLRPCStandardValidator class methodsFor: 'as yet unclassified'! arrayOfStructsTest: aCollection | ret | ret _ 0. aCollection first do: [:each | ret _ ret + (each at: 'curly')]. ^ ret! ! !XMLRPCStandardValidator class methodsFor: 'as yet unclassified' stamp: 'M.F. 9/6/2002 16:42'! countTheEntities: aCollection | ret string | ret _ Dictionary new. string _ aCollection first. ret at: 'ctLeftAngleBrackets' put: (string occurrencesOf: $<). ret at: 'ctRightAngleBrackets' put: (string occurrencesOf: $>). ret at: 'ctAmpersands' put: (string occurrencesOf: $&). ret at: 'ctApostrophes' put: (string occurrencesOf: $'). ret at: 'ctQuotes' put: (string occurrencesOf: $"). ^ ret! ! !XMLRPCStandardValidator class methodsFor: 'as yet unclassified'! easyStructTest: aCollection | ret | ret _ 0. aCollection first valuesDo: [ :each | ret _ ret + each ]. ^ret! ! !XMLRPCStandardValidator class methodsFor: 'as yet unclassified' stamp: 'M.F. 9/6/2002 16:41'! echoStructTest: aCollection ^ aCollection first! ! !XMLRPCStandardValidator class methodsFor: 'as yet unclassified'! manyTypesTest: aCollection | arr x | x _ 1. arr _ Array new: 6. aCollection do: [ :each | arr at: x put: each. x_x+1]. ^arr ! ! !XMLRPCStandardValidator class methodsFor: 'as yet unclassified'! moderateSizeArrayCheck: aCollection | arr | arr _ aCollection first. ^ (arr first), (arr last)! ! !XMLRPCStandardValidator class methodsFor: 'as yet unclassified'! nestedStructTest: aCollection | struct ret | struct _ aCollection first. ret _ 0. (((struct at: '2000') at: '04') at: '01') valuesDo: [ :each | ret _ ret + each]. ^ ret! ! !XMLRPCStandardValidator class methodsFor: 'as yet unclassified'! simpleStructReturnTest: aCollection | num dict | dict _ Dictionary new. num _ aCollection first. dict at: 'times10' put: num * 10; at: 'times100' put: num * 100; at: 'times1000' put: num * 1000. ^ dict! ! !XMLRPCStandardValidator class methodsFor: 'as yet unclassified'! xmlrpcMethodCall: request | mthd | mthd _ ((request methodCall findTokens: $.) last , ':') asSymbol. ^ XMLRPCStandardValidator perform: mthd with: request params! ! XMLRPCServerRequest initialize! XMLRPCHttpModule initialize!