' 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