' Gambas class file

'***************************************************************************
' 
' RpcClient.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 Method As RpcFunction
Private hHttp As HPost
Private hMode As Integer
Private sUrl As String
Private isFault As Boolean

Public Const offLine As Integer = 0
Public Const httpSync As Integer = 1
Public Const httpAsync As Integer = 2

Property Mode As Integer
Property URL As String
Property Read RpcMethod As RpcFunction

Event Reply(Data As Variant)
Event BadReply(Code As String)


Sub URL_Write(Vl As String)

  If hHttp Then
    If hHttp.Http.Status > 0 Then
      Error.Raise("Still active")
      Return
    End If
  End If

  If hHttp Then hHttp = Null
  sURL = Trim(Vl)

End

Function URL_Read() As String

  Return sURL

End



Sub Mode_Write(Vl As Integer)

  If hHttp Then
    If hHttp.Http.Status > 0 Then
      Error.Raise("Still active")
      Return
    End If
  End If

  If vl >= 0 And vl < 3 Then
    hMode = vl
  End If

  If vl = 0 Then hHttp = Null

End

Function Mode_Read() As Integer

  Return hMode

End

Function RpcMethod_Read() As RpcFunction

  Return Method

End


Public Sub _New(remoteFunction As RpcFunction)

  hMode = RpcClient.httpSync
  If remoteFunction = Null Then Error.Raise("Invalid RpcFunction object")
  Method = remoteFunction

End

Private Function testXML(sCad As String) As Integer

  Dim Xml As New XmlReader

  Try Xml.FromString(sCad)
  If Error Then Return 1

  Do While Not Xml.Eof
    Try Xml.Read()

    If Error Then Return 1


    If Not Xml.Eof Then
      If Xml.Node.Type = XmlReaderNodeType.Element Then
        Select Case Xml.Node.Name
          Case "methodResponse"
          Case "fault"
          Case "params"
          Case "param"
          Case "i4"
          Case "int"
          Case "boolean"
          Case "string"
          Case "double"
          Case "dateTime.iso8601"
          Case "base64"
          Case "struct"
          Case "array"
          Case "data"
          Case "member"
          Case "value"
          Case "name"
          Default
            Return 2
        End Select
      End If
    End If

  Loop

  Return 0

End

Public Function EvalReply(sCad As String) As Variant

  Dim hAtom As RpcAtom

  If hHttp Then
    If hHttp.Http.Status > 0 Then
      Error.Raise("Still active")
      Return
    End If
  End If

  Try hAtom = extractReply(sCad)
  If Error Then
    Error.Raise(Error.Text)
    Return Null
  End If

  If isFault Then
    '//TODO ERROR
    Error.Raise("server")
    Return Null
  End If

  If hAtom = Null Then
    If Method.ReturnType = Null Then Return Null
    Error.Raise("Invalid return type, wanted VOID, got " & XmlRpc.ToString(hAtom.Type))
  End If

  If Method.ReturnType <> hAtom.Type Then
    Error.Raise("Invalid return type, wanted " & XmlRpc.ToString(Method.ReturnType) & ", got " & XmlRpc.ToString(hAtom.Type))
    Return
  End If

  Return hAtom.Data

End


Private Function extractReply(sCad As String) As RpcAtom

  Dim Xml As New XmlReader
  Dim hAtom As RpcAtom

  isFault = False
  Select Case testXML(sCad)
    Case 1
      Error.Raise("Invalid XML data")
      Return Null
    Case 2
      Error.Raise("Invalid XML-RPC format")
      Return Null
  End Select

  Xml.FromString(sCad)
  If Tools.Find(Xml, "methodResponse") = False Then
    Error.Raise("Invalid XML-RPC format")
    Return Null
  End If

  Do While True
    If Not Xml.Eof Then Xml.Read()
    If Xml.Eof Then Break
    If Xml.Node.Type = XmlReaderNodeType.Element Then

      Select Case Xml.Node.Name
        Case "params"
          Do While True
            Xml.Read()
            Select Case Xml.Node.Type
              Case XmlReaderNodeType.EndElement
                Return Null
              Case XmlReaderNodeType.Element
                If Xml.Node.Name = "param" Then
                  Xml.Read()
                  hAtom = Tools.GetParam(Xml)
                  If hAtom = Null Then
                    Error.Raise("Invalid XML-RPC format")
                    Return Null
                  End If
                  Return hAtom
                Else
                  Error.Raise("Invalid XML-RPC format")
                  Return Null
                End If
            End Select

          Loop

        Case "fault"
          isFault = True
        Default
          Break
      End Select

    End If
  Loop

  Error.Raise("Invalid XML-RPC format")
  Return Null

End

Public Sub hHttp_GotData(Data As String)

  Dim Dt As Variant

  If Last = Null Then
    Error.Raise("Invalid method call")
    Return
  End If

  If Me.Mode = RpcClient.httpAsync Then
    Try Dt = EvalReply(Data)
    If Error Then
      Raise BadReply(Error.Text)
      Return
    End If
    Raise Reply(Dt)

  End If

End

Public Sub hHttp_GotError()

  If Last = Null Then
    Error.Raise("Invalid method call")
    Return
  End If

  If Me.Mode = RpcClient.httpAsync Then Raise BadReply("Unable to contact server, or bad reply from server")

End


Public Function Call(Data As Variant[]) As Variant

  Dim Xml As New XmlWriter
  Dim Bucle As Integer
  Dim sCad As String
  Dim sData As String

  If hHttp Then
    If hHttp.Http.Status > 0 Then
      Error.Raise("Still active")
      Return
    End If
  End If

  If Method = Null Then
    Error.Raise("Invalid RpcFunction object")
    Return
  End If

  If Data = Null Then
    If Method.Count <> 0 Then
      Error.Raise("Wrong parameters number")
      Return
    End If
  Else
    If Method.Count <> Data.Count Then
      Error.Raise("Wrong parameters number")
      Return
    End If
  End If

  Xml.Open("")
  Xml.StartElement("methodCall")
  Xml.Element("methodName", Method.MethodName)
  Xml.StartElement("params")
  For Bucle = 0 To Method.Count - 1

    Xml.StartElement("param")
    If Not Tools.AddValue(Xml, Data[Bucle], Method[Bucle]) Then
      Xml.EndDocument()
      Error.Raise("Invalid parameter " & Bucle + 1 & " Type : " & XmlRpc.ToString(Method[Bucle]))
      Return
    End If
    Xml.EndElement()

  Next
  Xml.EndElement()

  If hMode = RpcClient.offline Then Return Xml.EndDocument()

  If sURL = "" Then
    Error.Raise("Invalid URL")
    Return
  End If

  If hHttp = Null Then hHttp = New HPost(sURL) As "hHttp"

  If hMode = RpcClient.httpSync Then
    hHttp.Mode = False
  Else
    hHttp.Mode = True
  End If

  sData = Xml.EndDocument()
  
  If Right(sData) <> "\n" Then sData &= "\n"
  
  sData = Replace(sData, "\n", "\r\n")

  sCad = hHttp.PostData(sData)

  If hMode = RpcClient.httpSync Then
    If sCad = "" Then
      Error.Raise("Unable to contact server, or bad reply from server")
      Return Null
    End If
    Return EvalReply(sCad)
  End If

  Return Null

End