357 lines
7.5 KiB
Text
357 lines
7.5 KiB
Text
' Gambas class file
|
|
|
|
'***************************************************************************
|
|
'
|
|
' RpcServer.class
|
|
'
|
|
' (c)2005 - Daniel Campos Fernández
|
|
'
|
|
' XML-RPC Component
|
|
'
|
|
' Realizado para la Junta de Extremadura.
|
|
' Consejería de Educación Ciencia y Tecnología.
|
|
' Proyecto gnuLinEx
|
|
'
|
|
' This program Is free software; you can redistribute it And / Or modify
|
|
' it under the terms OF the GNU General PUBLIC License AS published by
|
|
' the Free Software Foundation; either version 1, Or (at your option)
|
|
' any later version.
|
|
'
|
|
' This program Is distributed IN the hope that it will be useful,
|
|
' but WITHOUT ANY WARRANTY; WITHOUT even the implied WARRANTY OF
|
|
' MERCHANTABILITY Or FITNESS FOR A PARTICULAR PURPOSE.See the
|
|
' GNU General PUBLIC License FOR more details.
|
|
'
|
|
' You should have received a COPY OF the GNU General PUBLIC License
|
|
' along WITH this program; IF Not, WRITE TO the Free Software
|
|
' Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
|
|
'
|
|
'***************************************************************************
|
|
Export
|
|
|
|
Private Methods As Object[]
|
|
Private miniSrv As MiniServer
|
|
Private CurrIndex As Integer
|
|
|
|
Property Read Count As Integer
|
|
Property Read Listening As Boolean
|
|
|
|
Event RemoteCall(Method As String, Params As Variant[])
|
|
|
|
Function Count_Read() As Integer
|
|
|
|
Return Methods.Count()
|
|
|
|
End
|
|
|
|
Function Listening_Read() As Boolean
|
|
|
|
If miniSrv Then Return True
|
|
Return False
|
|
|
|
End
|
|
|
|
|
|
Public Sub Unregister(methodName As String)
|
|
|
|
Dim Bucle As Integer
|
|
|
|
If CurrIndex <> - 1 Then
|
|
Error.Raise("Unable to Unregister a function in a RemoteCall event")
|
|
Return
|
|
End If
|
|
|
|
For Bucle = 0 To Methods.Count - 1
|
|
|
|
If Methods[Bucle].MethodName = MethodName Then
|
|
|
|
Methods[Bucle] = Null
|
|
Methods.Remove(Bucle)
|
|
Return
|
|
|
|
End If
|
|
|
|
Next
|
|
|
|
End
|
|
|
|
|
|
Public Sub Register(remoteFunction As RpcFunction)
|
|
|
|
Dim Bucle As Integer
|
|
|
|
If remoteFunction.MethodName = "system.listMethods" Then
|
|
Error.Raise("system.listMethods is a reserved keyword")
|
|
Return
|
|
End If
|
|
|
|
If remoteFunction.MethodName = "system.methodSignature" Then
|
|
Error.Raise("system.methodSignature is a reserved keyword")
|
|
Return
|
|
End If
|
|
|
|
If remoteFunction.MethodName = "system.methodHelp" Then
|
|
Error.Raise("system.methodHelp is a reserved keyword")
|
|
Return
|
|
End If
|
|
|
|
If remoteFunction = Null Then
|
|
Error.Raise("Null function")
|
|
Return
|
|
End If
|
|
|
|
For Bucle = 0 To Methods.Count - 1
|
|
|
|
If Methods[Bucle] = remoteFunction Then
|
|
Error.Raise("Function already registered")
|
|
Return
|
|
End If
|
|
|
|
If Methods[Bucle].methodName = remoteFunction.methodName Then
|
|
Error.Raise("Function already registered")
|
|
Return
|
|
End If
|
|
|
|
Next
|
|
|
|
Methods.Add(remoteFunction)
|
|
|
|
|
|
|
|
End
|
|
|
|
Public Sub Listen(Port As Integer, MaxConn As Integer)
|
|
|
|
If Port < 1 Or Port > 65535 Then
|
|
Error.Raise("Invalid port number")
|
|
Return
|
|
End If
|
|
|
|
If MaxConn < 0 Then
|
|
Error.Raise("Invalid maximum connections number")
|
|
Return
|
|
End If
|
|
|
|
If miniSrv Then miniSrv = Null
|
|
miniSrv = New MiniServer As "miniSrv"
|
|
Try miniSrv.Listen(Port, MaxConn)
|
|
If Error Then
|
|
miniSrv = Null
|
|
Error.Raise("Unable to listen at port " & Port)
|
|
End If
|
|
|
|
End
|
|
|
|
Public Sub Stop()
|
|
|
|
If miniSrv Then
|
|
miniSrv.Close()
|
|
miniSrv = Null
|
|
End If
|
|
|
|
End
|
|
|
|
|
|
Public Sub SetReply(Data As Variant)
|
|
|
|
Dim Xml As New XmlWriter
|
|
|
|
If CurrIndex = - 1 Then
|
|
Error.Raise("No remote function available")
|
|
Return
|
|
End If
|
|
|
|
Xml.Open("", True)
|
|
Xml.StartElement("methodResponse")
|
|
Xml.StartElement("params")
|
|
Xml.StartElement("param")
|
|
If Not Tools.AddValue(Xml, Data, Methods[CurrIndex].ReturnType) Then
|
|
miniSrv.SetReply(tools.FaultReply(8, "internal server error"))
|
|
Error.Raise("Invalid type conversion")
|
|
Return
|
|
End If
|
|
|
|
miniSrv.SetReply(Xml.EndDocument())
|
|
|
|
|
|
|
|
|
|
End
|
|
|
|
|
|
Public Sub miniSrv_ProcessData(Data As String)
|
|
|
|
Dim Xml As New XmlReader
|
|
Dim hPar As New Variant[]
|
|
Dim hP As RpcAtom
|
|
Dim Counter As Integer
|
|
|
|
Xml = New XmlReader
|
|
Xml.FromString(Data)
|
|
|
|
tools.Find(Xml, "methodCall")
|
|
Try Xml.Read()
|
|
If Not tools.Find(Xml, "params") Then
|
|
miniSrv.SetReply(tools.FaultReply(4, "params field not found"))
|
|
CurrIndex = - 1
|
|
Return
|
|
End If
|
|
|
|
Try Xml.Read()
|
|
|
|
Do While True
|
|
|
|
'If Xml.Node.Type = XmlReaderNodeType.EndElement Then Break
|
|
If Not Tools.Find(Xml, "param") Then Break
|
|
hP = Tools.GetParam(Xml)
|
|
If hP = Null Then
|
|
miniSrv.SetReply(tools.FaultReply(5, "malformed parameters"))
|
|
CurrIndex = - 1
|
|
Return
|
|
End If
|
|
|
|
hPar.Add(hP.Data)
|
|
If Methods[CurrIndex].Count < hPar.Count Then
|
|
miniSrv.SetReply(tools.FaultReply(6, "too many parameters"))
|
|
CurrIndex = - 1
|
|
Return
|
|
End If
|
|
If hP.Type <> Methods[CurrIndex][Counter] Then
|
|
miniSrv.SetReply(tools.FaultReply(7, "wrong parameter type"))
|
|
CurrIndex = - 1
|
|
Return
|
|
End If
|
|
|
|
Counter = Counter + 1
|
|
|
|
Loop
|
|
|
|
miniSrv.SetReply(tools.FaultReply(9, "Unknown error"))
|
|
|
|
If methods[CurrIndex].MethodName = "system.listMethods" Then
|
|
System_ListMethods()
|
|
Else If methods[CurrIndex].MethodName = "system.methodHelp" Then
|
|
System_methodHelp(hPar[0])
|
|
Else If methods[CurrIndex].MethodName = "system.methodSignature" Then
|
|
System_methodSignature(hPar[0])
|
|
Else
|
|
Raise RemoteCall(Methods[CurrIndex].MethodName, hPar)
|
|
End If
|
|
|
|
CurrIndex = - 1
|
|
End
|
|
|
|
|
|
Public Sub miniSrv_GotData(Data As String)
|
|
|
|
Dim Xml As New XmlReader
|
|
Dim Bucle As Integer
|
|
|
|
Xml = New XmlReader
|
|
Xml.FromString(Data)
|
|
|
|
If Not tools.Find(Xml, "methodCall") Then
|
|
Stop Event
|
|
Return
|
|
End If
|
|
Try Xml.Read()
|
|
If Not tools.Find(Xml, "methodName") Then
|
|
Stop Event
|
|
Return
|
|
End If
|
|
Do While True
|
|
Try Xml.Read()
|
|
If Xml.Node.Type = XmlReaderNodetype.Element Then
|
|
Stop Event
|
|
Return
|
|
End If
|
|
If Xml.Node.Type = XmlReaderNodeType.EndElement Then
|
|
Stop Event
|
|
Return
|
|
End If
|
|
If Xml.Node.Type = XmlReaderNodeType.Text Then
|
|
|
|
For Bucle = 0 To Methods.Count - 1
|
|
If Methods[Bucle].methodName = Xml.Node.Value Then
|
|
CurrIndex = bucle
|
|
Return
|
|
End If
|
|
Next
|
|
|
|
Stop Event
|
|
Return
|
|
|
|
End If
|
|
Loop
|
|
|
|
End
|
|
|
|
Public Sub _New()
|
|
|
|
Dim Rpc As RpcFunction
|
|
|
|
CurrIndex = - 1
|
|
Methods = New Object[]
|
|
|
|
Rpc = New RpcFunction("system.listMethods", Null, XmlRpc.xArray)
|
|
Methods.Add(Rpc)
|
|
Rpc = New RpcFunction("system.methodHelp", [XmlRpc.xString], XmlRpc.xString)
|
|
Methods.Add(Rpc)
|
|
Rpc = New RpcFunction("system.methodSignature", [XmlRpc.xString], XmlRpc.xArray)
|
|
Methods.Add(Rpc)
|
|
|
|
|
|
End
|
|
|
|
Private Sub System_ListMethods()
|
|
|
|
Dim Arr As New RpcArray
|
|
Dim Bucle As Integer
|
|
|
|
For Bucle = 0 To Methods.Count - 1
|
|
Arr.Add(Methods[Bucle].MethodName, XmlRpc.xString)
|
|
Next
|
|
|
|
SetReply(Arr)
|
|
|
|
End
|
|
|
|
Private Sub System_methodHelp(Data As String)
|
|
|
|
Dim Bucle As Integer
|
|
|
|
Data = Trim(Data)
|
|
|
|
For Bucle = 0 To Methods.Count - 1
|
|
If Methods[Bucle].MethodName = Data Then
|
|
SetReply(Methods[Bucle].Help)
|
|
Return
|
|
End If
|
|
Next
|
|
|
|
miniSrv.SetReply(tools.FaultReply("2", "Unknown method"))
|
|
|
|
End
|
|
|
|
Private Sub System_methodSignature(Data As String)
|
|
|
|
Dim Bucle As Integer
|
|
Dim B2 As Integer
|
|
Dim xArr As New RpcArray
|
|
|
|
Data = Trim(Data)
|
|
|
|
For Bucle = 0 To Methods.Count - 1
|
|
If Methods[Bucle].MethodName = Data Then
|
|
xArr.Add(XmlRpc.ToString(Methods[Bucle].ReturnType), XmlRpc.xString)
|
|
For B2 = 0 To Methods[Bucle].Count - 1
|
|
xArr.Add(XmlRpc.ToString(Methods[Bucle][B2]), XmlRpc.xString)
|
|
Next
|
|
SetReply(xArr)
|
|
Return
|
|
End If
|
|
Next
|
|
|
|
miniSrv.SetReply(tools.FaultReply("2", "Unknown method"))
|
|
|
|
End
|