'From Squeak3.2 of 11 July 2002 [latest update: #4956] on 6 September 2002 at 12:30:47 am'! Object subclass: #XMLRPCDecoder instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Synerge-XML-RPC'! Error subclass: #XMLRPCError instanceVariableNames: 'faultCode ' classVariableNames: '' poolDictionaries: '' category: 'XMLRPC-Server-Errors'! !XMLRPCError commentStamp: 'MFritsche 9/5/2002 20:25' 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: 'MFritsche 9/5/2002 20:36' prior: 0! The request Class wasn't found! Object subclass: #XMLRPCErrorHandler instanceVariableNames: 'error ' classVariableNames: '' poolDictionaries: '' category: 'XMLRPC-Server'! !XMLRPCErrorHandler commentStamp: 'MFritsche 9/5/2002 20:37' prior: 0! This is the error handler for XMLRPC errors! Object subclass: #XMLRPCHttpModule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'XMLRPC-Server'! !XMLRPCHttpModule commentStamp: 'MFritsche 9/5/2002 20:37' 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'! Object subclass: #XMLRPCRequest instanceVariableNames: 'methodCall params targetURI ' classVariableNames: 'Receivers ' poolDictionaries: '' category: 'XMLRPC-Server'! !XMLRPCRequest commentStamp: 'MFritsche 9/5/2002 20:38' prior: 0! This class holds all information about a XMLRPC request an coordinates the computation of a XMLRPC methodcall! XMLRPCError subclass: #XMLRPCRequestError instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'XMLRPC-Server-Errors'! !XMLRPCRequestError commentStamp: 'MFritsche 9/5/2002 20:26' prior: 0! An error raised if a malformed request was found! XMLRPCError subclass: #XMLRPCReturnError instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'XMLRPC-Server-Errors'! !XMLRPCReturnError commentStamp: 'MFritsche 9/5/2002 20:26' prior: 0! An error occured while encoding a methodresponse! Object subclass: #XMLRPCStandardValidator instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'XMLRPC-Server-Validation'! XMLRPCStandardValidator class instanceVariableNames: ''! !Array methodsFor: 'printing'! 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) , ' '! ! !XMLRPCDecoder methodsFor: 'as yet unclassified' stamp: 'chl 10/12/2001 01:20'! 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' stamp: 'chl 10/9/2001 01:39'! decodeStruct: anXMLElement | dict | dict _ Dictionary new. ((anXMLElement entityAt: 'value') entityAt: 'struct') entities keysAndValuesDo: [:key :val | dict at: (((val value) entityAt: 'name') contentString) put: (self decode: val value) ]. ^ dict! ! !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' stamp: 'MFritsche 9/3/2002 17:18'! error "Answer the receiver's 'error'." ^error! ! !XMLRPCErrorHandler methodsFor: 'accessing' stamp: 'MFritsche 9/3/2002 17:18'! 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 _ XMLRPCRequest fromRequest: (request stream next: request contentLength). xrReq targetURI: request url. ^ xrReq methodResponse] "on: Error do: [:e | ^ (XMLRPCErrorHandler new error: e) errorMessage]" value! ! !XMLRPCHttpModule class methodsFor: 'as yet unclassified' stamp: 'MFritsche 9/3/2002 21:13'! initialize Smalltalk addToStartUpList: self after: AutoStart. Smalltalk addToShutDownList: self! ! !XMLRPCHttpModule class methodsFor: 'as yet unclassified' stamp: 'MFritsche 9/3/2002 21:13'! serviceOn: aPort ^ ComancheNetService named: 'XMLRPC' onPort: aPort! ! !XMLRPCHttpModule class methodsFor: 'as yet unclassified' stamp: 'MFritsche 9/3/2002 21:13'! shutDown self stop! ! !XMLRPCHttpModule class methodsFor: 'as yet unclassified' stamp: 'MFritsche 9/3/2002 21:13'! start self startOn: 8200! ! !XMLRPCHttpModule class methodsFor: 'as yet unclassified' stamp: 'MFritsche 9/3/2002 21:13'! startOn: aPort | service | self stop. service _ self serviceOn: aPort. service module: self new. service start! ! !XMLRPCHttpModule class methodsFor: 'as yet unclassified' stamp: 'MFritsche 9/3/2002 21:14'! startUp self start! ! !XMLRPCHttpModule class methodsFor: 'as yet unclassified' stamp: 'MFritsche 9/3/2002 21:14'! 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: 'accessing' stamp: 'MFritsche 9/5/2002 20:56'! methodCall "Answer the receiver's 'methodCall'." ^methodCall! ! !XMLRPCRequest methodsFor: 'accessing' stamp: 'MFritsche 9/5/2002 20:56'! methodCall: anObject "Set the receiver's instance variable 'methodCall' to be anObject." methodCall := anObject! ! !XMLRPCRequest methodsFor: 'accessing'! methodResponse | stream ret | stream _ WriteStream on: (String new: 1000). stream nextPutAll: ''. [ret _ (Receivers at: methodCall asSymbol) xmlrpcMethodCall: self] " on: MessageNotUnderstood do: [:e | XMLRPCMethodError new signal: 'Message not understood by server class']." value. 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! ! !XMLRPCRequest methodsFor: 'accessing' stamp: 'MFritsche 9/5/2002 20:56'! params "Answer the receiver's 'params'." ^params! ! !XMLRPCRequest methodsFor: 'accessing' stamp: 'MFritsche 9/5/2002 20:56'! params: anObject "Set the receiver's instance variable 'params' to be anObject." params := anObject! ! !XMLRPCRequest methodsFor: 'accessing' stamp: 'MFritsche 9/5/2002 20:56'! targetURI "Answer the receiver's 'targetURI'." ^targetURI! ! !XMLRPCRequest methodsFor: 'accessing' stamp: 'MFritsche 9/5/2002 20:56'! targetURI: anObject "Set the receiver's instance variable 'targetURI' to be anObject." targetURI := anObject! ! !XMLRPCRequest class methodsFor: 'as yet unclassified' stamp: 'MFritsche 9/5/2002 21:25'! addMethod: mthd realReceiver: clz Receivers at: mthd asSymbol put: clz! ! !XMLRPCRequest 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]! ! !XMLRPCRequest 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! ! !XMLRPCRequest class methodsFor: 'as yet unclassified' stamp: 'MFritsche 9/5/2002 21:24'! initialize Receivers _ Dictionary new.! ! !XMLRPCRequest class methodsFor: 'as yet unclassified' stamp: 'MFritsche 9/5/2002 21:26'! removeMethod: mthd Receivers removeKey: mthd asSymbol! ! !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! ! !XMLRPCStandardValidator class methodsFor: 'as yet unclassified'! addTests "XMLRPCStandardValidator addTests" XMLRPCRequest addMethod: 'validator1.arrayOfStructsTest' realReceiver: self. XMLRPCRequest addMethod: 'validator1.countTheEntities' realReceiver: self. XMLRPCRequest addMethod: 'validator1.echoStructTest' realReceiver: self. XMLRPCRequest addMethod: 'validator1.easyStructTest' realReceiver: self. XMLRPCRequest addMethod: 'validator1.moderateSizeArrayCheck' realReceiver: self. XMLRPCRequest addMethod: 'validator1.nestedStructTest' realReceiver: self. XMLRPCRequest addMethod: 'validator1.simpleStructReturnTest' realReceiver: self. XMLRPCRequest 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'! 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' stamp: 'MFritsche 9/5/2002 22:31'! easyStructTest: aCollection | ret | ret _ 0. aCollection first valuesDo: [ :each | ret _ ret + each ]. ^ret! ! !XMLRPCStandardValidator class methodsFor: 'as yet unclassified' stamp: 'MFritsche 9/5/2002 22:32'! echoStructTest: aCollection ^ aCollection first! ! !XMLRPCStandardValidator class methodsFor: 'as yet unclassified' stamp: 'MFritsche 9/5/2002 22:33'! 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' stamp: 'MFritsche 9/5/2002 22:37'! 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' stamp: 'MFritsche 9/5/2002 22:39'! simpleStructReturnTest: aCollection | num dict | dict _ Dictionary new. num _ aCollection first. dict at: '10times' put: num * 10; at: '100times' put: num * 100; at: '1000times' put: num * 1000. ^ dict! ! !XMLRPCStandardValidator class methodsFor: 'as yet unclassified'! xmlrpcMethodCall: request | mthd | mthd _ ((request methodCall findTokens: $.) last , ':') asSymbol. Transcript show: mthd; cr. ^ XMLRPCStandardValidator perform: mthd with: request params! ! XMLRPCRequest initialize! XMLRPCRequest class removeSelector: #request:! XMLRPCHttpModule initialize!