'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!