Anubis / Xlib

/*
 * Created by PyramIDE.
 * User: Totoro
 * Date: 29/06/2013
 * Time: 00:47
 * 
 */

read tools/base64.anubis
transmit tools/basis.anubis
read tools/connections.anubis
read system/convert.anubis
transmit system/string.anubis
read calexium_lib/web/CXM_common.anubis
read calexium_lib/web/CXM_http_get_common.anubis
read calexium_lib/web/CXM_multihost_http_server.anubis
transmit calexium_lib/web/CXM_xml_rpc_parser.anubis
transmit calexium_lib/web/CXM_xml_rpc_types.anubis

  
define XML_RPC_parameters sysinfo_params =
  parameters
  [
    parameter[int(1)],
    parameter[bool(true)],
    parameter[string("This is a string")],
    parameter[double(1.45)],
    parameter[datetime("date to do")],
    parameter[base64("Base 64 content")],
    parameter[struct(members([
                    member("1st member", int(2)),
                    member("2nd member", string("this is the 2nd string"))
                   ]))],
    parameter[array(array([
                  int(3),
                  string("3rd string")
                ]))]
  ].

define XML_RPC_parameters empty_param = parameters [].
  
public type XML_RPC_Result:
  cannot_resolve_server_name(DNS_Result),
  cannot_connect_to_server(NetworkConnectError),
  transmission_problem, 
  request_refused_by_server,
  ok(String response,                    // HTTP response line from the server
     List(HTTP_header) headers,          // HTTP headers received from the server
     String document).                   // The HTML document itself

public type XML_RPC_Auth:
  none,
  basic(String login, String password).
  
public type XML_RPC_client:
  xml_rpc_client(
    Connection    conn,
    XML_RPC_Auth  auth,
    String        url,
    String        user_agent,
    String        host).

define String 
  tab
  (
    Int position
  )=
  to_string(constant_byte_array(position * 2, ' ')).
  
define String format_struct(XML_RPC_struct structure, Int position).
define String format_array(XML_RPC_array array, Int position).

define String format_int_value      ( Word32 value) = "<value><i4>"+to_String(value)+"</i4></value>" + crlf.
define String format_boolean_value    ( Bool value) = "<value><boolean>"+to_String_value(value)+"</boolean></value>" + crlf.
define String format_string_value   ( String value) = "<value><string>"+value+"</string></value>" + crlf.
define String format_double_value    ( Float value) = "<value><double>"+float_to_string(value, 10)+"</double></value>" + crlf.
define String format_datetime_value ( String value) = "<value><dateTime.iso8601>"+value+"</dateTime.iso8601></value>" + crlf.
define String format_base64_value   ( String value) = "<value><base64>"+value+"</base64></value>" + crlf.
define String format_nil                            = "<value><nil/></value>" + crlf.


define String
  format_value
  (
    XML_RPC_value rpc_value,
    Int position
  )=
  with return = if rpc_value is
  {
    int(value)      then  format_int_value(value),
    bool(value)     then  format_boolean_value(value),
    string(value)   then  format_string_value(value),
    double(value)   then  format_double_value(value),
    datetime(value) then  format_datetime_value(value),
    base64(value)   then  format_base64_value(value),
    struct(value)   then  format_struct(value, position + 1),
    array(value)    then  format_array(value, position + 1),
    nil             then  format_nil
  },
  tab(position) + return.
  
  
define String 
  _format_struct
  (
    String                      so_far,
    List(XML_RPC_struct_member) members,
    Int                         position
  )=
  if members is
  {
    []        then so_far,
    [h . t]   then
      if h is member(name, val) then
        _format_struct( so_far + tab(position) + "<member>" + crlf +
                                 tab(position + 1)+"<name>"+name+"</name>" + crlf +
                                 format_value(val, position + 1) +
                                 tab(position + 1) + "</member>" + crlf, 
                        t,
                        position)
  }.
  
define String 
  format_struct
  (
    XML_RPC_struct struct,
    Int position
  ) =
  if struct is members(structure_members) then
  /*tab(position) +*/ "<struct>" + crlf +
  _format_struct("", structure_members, position+1)+
  tab(position + 1) + "</struct>" + crlf.

define String 
  _format_array
  (
    String              so_far,
    List(XML_RPC_value) values,
    Int                 position
  )=
  if values is
  {
    []        then so_far,
    [h . t]   then _format_array( so_far + format_value(h, position), t, position)
  }.
  
define String 
  format_array
  (
    XML_RPC_array arr,
    Int           position
  )
  =
  if arr is array(values) then
  /*tab(position) +*/ "<array>" + crlf +
  tab(position + 1) + "<data>" + crlf+
  _format_array("", values, position + 2)+
  tab(position+2)+"</data>" + crlf +
  tab(position + 1) + "</array>" + crlf.

public define String
  format_xml_rpc_values
  (
    List(XML_RPC_value) values,
    Int                 position,
    String              so_far
  )=
  if values is 
  {
    []        then so_far,
    [ h . t ] then 
      format_xml_rpc_values(t, position, so_far + format_value(h, position))
  }.

public define String
  format_xml_rpc_parameter
  (
    XML_RPC_parameter param,
    Int               position
  )=
  if param is parameter(values) then
      format_xml_rpc_values(values, position, "")
  .

  
define String
  _format_xml_rpc_parameters
  (
    String                  so_far,
    List(XML_RPC_parameter) params,
    Int position
  )=
  if params is
  {
    []        then so_far,
    [ h . t ] then
      _format_xml_rpc_parameters( so_far + tab(position) + "<param>" + crlf + 
                                           format_xml_rpc_parameter(h, position + 1) +
                                           tab(position+1) + "</param>" + crlf,
                                           t,
                                           position)
  }.
  
public define String
  format_xml_rpc_parameters
  (
    XML_RPC_parameters params,
    Int position
  )=
  if params is parameters(list_param) then
    tab(position)+"<params>" + crlf +
    _format_xml_rpc_parameters("", list_param, position+1) +
    tab(position+1)+"</params>".

public define String
  format_xml_rpc_fault
  (
    XML_RPC_value value,
    Int position
  )=
  tab(position)+"<fault>" + crlf +
    format_value(value, position+1) +
  tab(position+1)+"</fault>".
    
public define Bool
  accept_policy
    (
      Maybe(X509) suspect_certificate
    ) = true. 
    
public define Maybe(XML_RPC_client)
  xml_rpc_new_client
  (
    String        server_name,
    Bool          use_ssl,
    XML_RPC_Auth  auth,
    String        user_agent,
    String        host
  )=
  if separate_name_port(server_name, if use_ssl then 443 else 80) is (name, server_port) then 
  //
  // resolve server name and call 'https_get' with numeric server address:
  //
  with a = dns(name), 
    if a is     ok(server_addr) then
      //connect to server with right protocol
      if use_ssl then
        //println("SSL "+server_port+ " "+server_name);
        if open_SSL_connection(server_name, server_addr, server_port, accept_policy) is
        {
          error(msg)  then failure, 
          ok(conn)    then success(xml_rpc_client(ssl(conn), auth, server_name, user_agent, host))
        }
      else
        //println("TCP "+server_port+ " "+server_name);
        if (Result(NetworkConnectError,RWStream))connect(server_addr, server_port) is
        {
          error(e)   then   failure,
          ok(conn)   then   success(xml_rpc_client(tcp(conn), auth, server_name, user_agent, host))
        }
    else        
      failure.
define Maybe(XML_RPC_response)
  receive
  (
    Bool       print_dump,
    Connection conn
  )=
  //TODO find the header and content-lenght to get full length of answer
  
  if read(conn, 16384, 5) is
  {
    error     then println("Read error");failure,
    timeout   then println("Read timeout");failure,
    ok(ba)    then
      with xml_response = to_string(ba),
         typed_response =  xml_rpc_get_response(xml_response),
      (if print_dump then
      
        println("=== Server answer ==="+crlf + xml_response );
        println("=== XML_RPC Anubis interpretation ===");

        if typed_response is
        {
          failure         then println("Interpretation error"),
          success(result) then 
            if result is
            {
              ok(ok_res)    then println(format_xml_rpc_parameters(ok_res,1)),
              fault(fault)  then println(format_xml_rpc_fault(fault,1))
            }
           
        }
      else unique);
      typed_response
  }
  .
  
define Maybe(XML_RPC_response)
  receive_new
  (
    Bool       print_dump,
    Connection conn
  )=
  //TODO find the header and content-lenght to get full length of answer
  //construct a  buffered connection
  with b_con = buffered_connection(conn), 
  if skip_line(b_con) is
  {
    error(msg)        then print(format(msg));failure,
    ok(_)  then
      if read_http_headers(b_con) is
      {
        error(msg)  then print(format(msg));failure,
        ok(headers) then
          if get_body_size(headers) is
          {  
            error(msg)     then print(format(msg));failure,
            ok(body_size)  then  
              if read_http_body(b_con, body_size, constant_byte_array(0,0), 1000) is
              {
                error(msg) then print(format(msg));failure,
                ok(body)   then  
                  with xml_response = to_string(body),
                  with typed_response =  xml_rpc_get_response(xml_response),
                  (if print_dump then
                  
                    println("=== Server answer ==="+crlf + xml_response);
                    println("=== XML_RPC Anubis interpretation ===");
            
                    if typed_response is
                    {
                      failure         then println("Interpretation error"),
                      success(result) then 
                        if result is
                        {
                          ok(ok_res)    then println(format_xml_rpc_parameters(ok_res,1)),
                          fault(fault)  then println(format_xml_rpc_fault(fault,1))
                        }
                       
                    }
                  else unique);
                  typed_response
              }
           }
  }}
  .
  
public define Maybe(XML_RPC_response)
  xml_rpc_client_execute
  (
    Bool                print_dump,
    XML_RPC_client      client,
    String              url,
    String              method_name,
    XML_RPC_parameters  params
    //(XML-string)->$T  answer_handler  //convert the xml answer to anubis type
  )=  
  if client is xml_rpc_client(conn, auth, server_name, user_agent, host) then
  //execute the method on remote server
  // - 1 - Format the xml body to comply with XML RPC
    with body = "<?xml version=\"1.0\"?>" + crlf +
                tab(1)+"<methodCall>" + crlf +
                tab(2)+"<methodName>" + method_name +"</methodName>" + crlf +
                format_xml_rpc_parameters(params, 2) +
                tab(1)+"</methodCall>",
                
  // - 2 - Format the POST HTTP request
    with request = "POST "+url+" HTTP/1.1"+ crlf +      //HTTP/1.1 is very important because it allow to send multiple execute
                  "User-Agent: "+ user_agent + crlf +   //with only one connection (keep-alive is default in http 1.1)
                  "Host: " + server_name + crlf +
                  "Content-type: text/xml" + crlf +
                  if auth is 
                  {
                    none                then "",
                    basic(login, pass)  then "Authorization: Basic "+base64_encode(login+":"+pass)+ crlf
                  }+
                  "Content-length: " + length(body)+ crlf +

                  //format_headers(headers) +
                  crlf +
                  body,
                  
  // - 3 - send it to remote 

  //
  // Send the HTTP request, and receive the answer:
  //
  (if print_dump then 
   (
    print("----- request ----\n");
    print(request); 
    print("\n")
   ) else unique);
   
   if write(conn, to_byte_array(request)) is
    {
      failure     then   failure,
      success(_)  then   receive_new(print_dump, conn)
    }. 
   
  //wait the answer

  
global define One
  xml_rpc_test
  (
    List(String) args
  )=
  if xml_rpc_new_client("mail.calexium.com:33610", true, basic("admin","the secret passsword"), "Anubis XML-RPC", "127.0.0.1") is
  {
    failure             then println(" xml_rpc_test new client failure"),
    success(rpc_client) then
      forget(xml_rpc_client_execute(false, rpc_client, "/Settings", "list_domains", empty_param))
      //forget(xml_rpc_client_execute(true, rpc_client, "/Settings", "delete_domain", parameters([parameter[string("amisdefontainebleau.org")]])))
      //forget(xml_rpc_client_execute(true, rpc_client, "/Settings", "create_domain", empty_param))
  }.