File : soap/soap-message-xml.adb


------------------------------------------------------------------------------
--                              Ada Web Server                              --
--                                                                          --
--                         Copyright (C) 2000-2003                          --
--                                ACT-Europe                                --
--                                                                          --
--  Authors: Dmitriy Anisimkov - Pascal Obry                                --
--                                                                          --
--  This library 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 2 of the License, or (at   --
--  your option) any later version.                                         --
--                                                                          --
--  This library 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 library; if not, write to the Free Software Foundation, --
--  Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.          --
--                                                                          --
--  As a special exception, if other files instantiate generics from this   --
--  unit, or you link this unit with other files to produce an executable,  --
--  this  unit  does not  by itself cause  the resulting executable to be   --
--  covered by the GNU General Public License. This exception does not      --
--  however invalidate any other reasons why the executable file  might be  --
--  covered by the  GNU Public License.                                     --
------------------------------------------------------------------------------

--  $Id: soap-message-xml.adb,v 1.21 2003/06/18 13:43:48 obry Exp $

with Ada.Strings.Unbounded;
with Ada.Strings.Fixed;
with Ada.Exceptions;
with Ada.Calendar;

with Input_Sources.Strings;
with Unicode.CES.Utf8;
with DOM.Core.Nodes;
with Sax.Readers;

with SOAP.Message.Reader;
with SOAP.Message.Response.Error;
with SOAP.Types;
with SOAP.Utils;

package body SOAP.Message.XML is

   use Ada;
   use Ada.Strings.Unbounded;
   use DOM.Core.Nodes;
   use SOAP.Message.Reader;

   NL         : constant String := ASCII.CR & ASCII.LF;

   Max_Object_Size : constant := 250;

   XML_Header : constant String := "<?xml version='1.0' encoding='UTF-8'?>";

   URL_Enc    : constant String := "http://schemas.xmlsoap.org/soap/encoding/";
   URL_Env    : constant String := "http://schemas.xmlsoap.org/soap/envelope/";
   URL_xsd    : constant String := "http://www.w3.org/1999/XMLSchema";
   URL_xsi    : constant String := "http://www.w3.org/1999/XMLSchema-instance";

   Start_Env  : constant String := "<SOAP-ENV:Envelope";
   End_Env    : constant String := "</SOAP-ENV:Envelope>";

   Header     : constant String
     := Start_Env & ' '
     & "SOAP-ENV:encodingStyle=""" & URL_Enc & """ "
     & "xmlns:SOAP-ENC=""" & URL_Enc & """ "
     & "xmlns:SOAP-ENV=""" & URL_Env & """ "
     & "xmlns:xsd=""" & URL_xsd & """ "
     & "xmlns:xsi=""" & URL_xsi & """>";

   Start_Body : constant String := "<SOAP-ENV:Body>";
   End_Body   : constant String := "</SOAP-ENV:Body>";

   type Array_State is (Void, A_Undefined, A_Int, A_Float, A_Double, A_String,
                        A_Boolean, A_Time_Instant, A_Base64);

   type State is record
      Name_Space   : Unbounded_String;
      Wrapper_Name : Unbounded_String;
      Parameters   : SOAP.Parameters.List;
      A_State      : Array_State := Void;
   end record;

   procedure Parse_Envelope (N : in DOM.Core.Node; S : in out State);

   procedure Parse_Document (N : in DOM.Core.Node; S : in out State);

   procedure Parse_Body     (N : in DOM.Core.Node; S : in out State);

   procedure Parse_Wrapper  (N : in DOM.Core.Node; S : in out State);

   function Parse_Int       (N : in DOM.Core.Node) return Types.Object'Class;

   function Parse_Float     (N : in DOM.Core.Node) return Types.Object'Class;

   function Parse_Double    (N : in DOM.Core.Node) return Types.Object'Class;

   function Parse_String    (N : in DOM.Core.Node) return Types.Object'Class;

   function Parse_Boolean   (N : in DOM.Core.Node) return Types.Object'Class;

   function Parse_Base64    (N : in DOM.Core.Node) return Types.Object'Class;

   function Parse_Time_Instant
     (N : in DOM.Core.Node)
      return Types.Object'Class;

   function Parse_Param
     (N        : in DOM.Core.Node;
      S        : in State)
      return Types.Object'Class;

   function Parse_Array
     (N : in DOM.Core.Node;
      S : in State)
      return Types.Object'Class;

   function Parse_Record
     (N : in DOM.Core.Node;
      S : in State)
      return Types.Object'Class;

   procedure Error (Node : in DOM.Core.Node; Message : in String);
   pragma No_Return (Error);
   --  Raises SOAP_Error with the Message as exception message.

   -----------
   -- Error --
   -----------

   procedure Error (Node : in DOM.Core.Node; Message : in String) is
      Name : constant String := Local_Name (Node);
   begin
      Exceptions.Raise_Exception (SOAP_Error'Identity, Name & " - " & Message);
   end Error;

   -----------
   -- Image --
   -----------

   function Image (O : in Object'Class) return String is
   begin
      return To_String (XML.Image (O));
   end Image;

   -----------
   -- Image --
   -----------

   function Image (O : in Object'Class) return Unbounded_String is
      Message_Body : Unbounded_String;
   begin
      --  Header

      Append (Message_Body, XML_Header & NL);
      Append (Message_Body, Header & NL);

      --  Body

      Append (Message_Body, Start_Body & NL);

      --  Wrapper

      Append (Message_Body, Message.XML_Image (O));

      --  End of Body and Envelope

      Append (Message_Body, End_Body & NL);
      Append (Message_Body, End_Env & NL);

      return Message_Body;
   end Image;

   ------------------
   -- Load_Payload --
   ------------------

   function Load_Payload (XML : in String) return Message.Payload.Object is
      use Input_Sources.Strings;

      Str     : aliased String := XML;

      Source  : String_Input;
      Reader  : Tree_Reader;
      S       : State;
      Doc     : DOM.Core.Document;

   begin
      Open (Str'Unchecked_Access,
            Unicode.CES.Utf8.Utf8_Encoding,
            Source);

      --  If True, xmlns:* attributes will be reported in Start_Element
      Set_Feature (Reader, Sax.Readers.Namespace_Prefixes_Feature, True);
      Set_Feature (Reader, Sax.Readers.Validation_Feature, False);

      Parse (Reader, Source);
      Close (Source);

      Doc := Get_Tree (Reader);

      Parse_Document (Doc, S);

      Free (Doc);

      return Message.Payload.Build
        (To_String (S.Wrapper_Name), S.Parameters, To_String (S.Name_Space));
   end Load_Payload;

   -------------------
   -- Load_Response --
   -------------------

   function Load_Response
     (XML : in String)
      return Message.Response.Object'Class
   is
      use Input_Sources.Strings;

      Str     : aliased String := XML;

      Source  : String_Input;
      Reader  : Tree_Reader;
      S       : State;
      Doc     : DOM.Core.Document;

   begin
      Open (Str'Unchecked_Access,
            Unicode.CES.Utf8.Utf8_Encoding,
            Source);

      --  If True, xmlns:* attributes will be reported in Start_Element
      Set_Feature (Reader, Sax.Readers.Namespace_Prefixes_Feature, True);
      Set_Feature (Reader, Sax.Readers.Validation_Feature, False);

      Parse (Reader, Source);
      Close (Source);

      Doc := Get_Tree (Reader);

      Parse_Document (Doc, S);

      Free (Doc);

      if SOAP.Parameters.Exist (S.Parameters, "faultcode") then
         return Message.Response.Error.Build
           (Faultcode   =>
              Message.Response.Error.Faultcode
               (String'(SOAP.Parameters.Get (S.Parameters, "faultcode"))),
            Faultstring => SOAP.Parameters.Get (S.Parameters, "faultstring"));
      else
         return Message.Response.Object'
           (S.Name_Space, S.Wrapper_Name, S.Parameters);
      end if;

   exception
      when E : others =>
         return Message.Response.Error.Build
           (Faultcode   => Message.Response.Error.Client,
            Faultstring => Exceptions.Exception_Message (E));
   end Load_Response;

   -----------------
   -- Parse_Array --
   -----------------

   function Parse_Array
     (N : in DOM.Core.Node;
      S : in State)
      return Types.Object'Class
   is
      use type DOM.Core.Node;
      use SOAP.Types;

      function A_State (A_Type : in String) return Array_State;
      --  Returns the Array_State given the SOAP-ENC:arrayType value.

      -------------
      -- A_State --
      -------------

      function A_State (A_Type : in String) return Array_State is
         N : constant Positive := Strings.Fixed.Index (A_Type, "[");
         T : constant String   := A_Type (A_Type'First .. N - 1);
      begin
         if T = Types.XML_Int then
            return A_Int;

         elsif T = Types.XML_Float then
            return A_Float;

         elsif T = Types.XML_Double then
            return A_Double;

         elsif T = Types.XML_String then
            return A_String;

         elsif T = Types.XML_Boolean then
            return A_Boolean;

         elsif T = Types.XML_Time_Instant then
            return A_Time_Instant;

         elsif T = Types.XML_Base64 then
            return A_Base64;

         elsif T = Types.XML_Undefined then
            return A_Undefined;

         else
            return A_Undefined;
         end if;
      end A_State;

      Name     : constant String := Local_Name (N);
      OS       : Types.Object_Set (1 .. Max_Object_Size);
      K        : Natural := 0;

      Field    : DOM.Core.Node;

      Atts     : constant DOM.Core.Named_Node_Map := Attributes (N);

      XSI_Type : constant DOM.Core.Node
        := Get_Named_Item (Atts, "xsi:type");

      A_Name   : constant String
        := Utils.NS (Node_Value (XSI_Type)) & ":arrayType";
      --  Attribute name

      A_Type : constant Array_State
        := A_State (Node_Value (Get_Named_Item (Atts, A_Name)));

   begin
      Field := First_Child (N);

      while Field /= null loop
         K := K + 1;
         OS (K) := +Parse_Param
           (Field, (S.Name_Space, S.Wrapper_Name, S.Parameters, A_Type));

         Field := Next_Sibling (Field);
      end loop;

      return Types.A (OS (1 .. K), Name);
   end Parse_Array;

   ------------------
   -- Parse_Base64 --
   ------------------

   function Parse_Base64 (N : in DOM.Core.Node) return Types.Object'Class is
      use type DOM.Core.Node;

      Name  : constant String := Local_Name (N);
      Value : DOM.Core.Node;
   begin
      Normalize (N);
      Value := First_Child (N);

      if Value = null then
         --  No node found, this is an empty Base64 content
         return Types.B64 ("", Name);

      else
         return Types.B64 (Node_Value (Value), Name);
      end if;
   end Parse_Base64;

   ----------------
   -- Parse_Body --
   ----------------

   procedure Parse_Body (N : in DOM.Core.Node; S : in out State) is
   begin
      Parse_Wrapper (First_Child (N), S);
   end Parse_Body;

   -------------------
   -- Parse_Boolean --
   -------------------

   function Parse_Boolean (N : in DOM.Core.Node) return Types.Object'Class is
      Name  : constant String        := Local_Name (N);
      Value : constant DOM.Core.Node := First_Child (N);
   begin
      if Node_Value (Value) = "1"
        or else Node_Value (Value) = "true"
        or else Node_Value (Value) = "TRUE"
      then
         return Types.B (True, Name);
      else
         return Types.B (False, Name);
      end if;
   end Parse_Boolean;

   --------------------
   -- Parse_Document --
   --------------------

   procedure Parse_Document (N : in DOM.Core.Node; S : in out State) is
      NL : constant DOM.Core.Node_List := Child_Nodes (N);
   begin
      if Length (NL) = 1 then
         Parse_Envelope (First_Child (N), S);
      else
         Error (N, "Document must have a single node, found "
                & Natural'Image (Length (NL)));
      end if;
   end Parse_Document;

   ------------------
   -- Parse_Double --
   ------------------

   function Parse_Double (N : in DOM.Core.Node) return Types.Object'Class is
      Name  : constant String        := Local_Name (N);
      Value : constant DOM.Core.Node := First_Child (N);
   begin
      return Types.D (Long_Long_Float'Value (Node_Value (Value)), Name);
   end Parse_Double;

   --------------------
   -- Parse_Envelope --
   --------------------

   procedure Parse_Envelope (N : in DOM.Core.Node; S : in out State) is
      NL : constant DOM.Core.Node_List := Child_Nodes (N);
   begin
      if Length (NL) = 1 then
         Parse_Body (First_Child (N), S);
      else
         Error (N, "Envelope must have a single node, found "
                & Natural'Image (Length (NL)));
      end if;
   end Parse_Envelope;

   -----------------
   -- Parse_Float --
   -----------------

   function Parse_Float (N : in DOM.Core.Node) return Types.Object'Class is
      Name  : constant String        := Local_Name (N);
      Value : constant DOM.Core.Node := First_Child (N);
   begin
      return Types.F (Long_Float'Value (Node_Value (Value)), Name);
   end Parse_Float;

   ---------------
   -- Parse_Int --
   ---------------

   function Parse_Int (N : in DOM.Core.Node) return Types.Object'Class is
      Name  : constant String        := Local_Name (N);
      Value : constant DOM.Core.Node := First_Child (N);
   begin
      return Types.I (Integer'Value (Node_Value (Value)), Name);
   end Parse_Int;

   -----------------
   -- Parse_Param --
   -----------------

   function Parse_Param
     (N        : in DOM.Core.Node;
      S        : in State)
      return Types.Object'Class
   is
      use type DOM.Core.Node;
      use type DOM.Core.Node_Types;

      function Is_Array return Boolean;
      --  Returns True if N is an array node

      Name : constant String                  := Local_Name (N);
      Atts : constant DOM.Core.Named_Node_Map := Attributes (N);

      --------------
      -- Is_Array --
      --------------

      function Is_Array return Boolean is
         XSI_Type : constant DOM.Core.Node
           := Get_Named_Item (Atts, "xsi:type");
         xsd : constant String := Node_Value (XSI_Type);
      begin
         --  ???
         return Utils.No_NS (xsd) = "Array"
           and then Get_Named_Item
                      (Atts, Utils.NS (xsd) & ":arrayType") /= null;
      end Is_Array;

   begin
      if To_String (S.Wrapper_Name) = "Fault" then
         return Parse_String (N);

      else
         if Length (Atts) = 0 and then S.A_State in Void .. A_Undefined then
            --  No attribute found.

            if First_Child (N) /= null
              and then First_Child (N).Node_Type = DOM.Core.Text_Node
            then
               --  Children are some kind of text data, so this is a data node
               --  with no type information. Note that this code is to
               --  workaround an interoperability problem with Microsoft SOAP
               --  implementation based on WSDL were the type information is
               --  not provided into the payload but only on the WSDL file. As
               --  AWS/SOAP is not WSDL compliant at this point we treat
               --  undefined type as string values, it is up to the developper
               --  to convert the string to the right type. Note that this
               --  code is only there to parse data received from a SOAP
               --  server. AWS/SOAP always send type information into the
               --  payload.
               --  ??? If payload xsi:type information becomes mandatory this
               --  conditional section should be removed.

               return Parse_String (N);

            else
               --  This is a SOAP record, we have no attribute and no type
               --  defined. We have a single tag "<name>" which can only be
               --  the start or a record.

               return Parse_Record (N, S);
            end if;

         else
            case S.A_State is
               when A_Int =>
                  return Parse_Int (N);

               when A_Float =>
                  return Parse_Float (N);

               when A_Double =>
                  return Parse_Double (N);

               when A_String =>
                  return Parse_String (N);

               when A_Boolean =>
                  return Parse_Boolean (N);

               when A_Time_Instant =>
                  return Parse_Time_Instant (N);

               when A_Base64 =>
                  return Parse_Base64 (N);

               when Void | A_Undefined =>

                  declare
                     XSI_Type : constant DOM.Core.Node
                       := Get_Named_Item (Atts, "xsi:type");
                  begin
                     if XSI_Type = null then
                        declare
                           N : constant DOM.Core.Node
                             := Get_Named_Item (Atts, "xsi:null");
                        begin
                           if N = null then
                              Error (Parse_Param.N,
                                     "Wrong or unsupported type");
                           else
                              return Types.N (Name);
                           end if;
                        end;

                     else

                        declare
                           xsd : constant String := Node_Value (XSI_Type);
                        begin
                           if xsd = Types.XML_Int then
                              return Parse_Int (N);

                           elsif xsd = Types.XML_Float then
                              return Parse_Float (N);

                           elsif xsd = Types.XML_Double then
                              return Parse_Double (N);

                           elsif xsd = Types.XML_String then
                              return Parse_String (N);

                           elsif xsd = Types.XML_Boolean then
                              return Parse_Boolean (N);

                           elsif xsd = Types.XML_Time_Instant then
                              return Parse_Time_Instant (N);

                           elsif xsd = Types.XML_Base64 then
                              return Parse_Base64 (N);

                           elsif Is_Array then
                              return Parse_Array (N, S);

                           else
                              --  Not a known basic type, let's try to parse a
                              --  record object. This implemtation does not
                              --  support schema so there is no way to check
                              --  for the real type here.

                              return Parse_Record (N, S);
                           end if;
                        end;
                     end if;
                  end;
            end case;
         end if;
      end if;
   end Parse_Param;

   ------------------
   -- Parse_Record --
   ------------------

   function Parse_Record
     (N : in DOM.Core.Node;
      S : in State)
      return Types.Object'Class
   is
      use type DOM.Core.Node;
      use SOAP.Types;

      Name  : constant String := Local_Name (N);
      OS    : Types.Object_Set (1 .. Max_Object_Size);
      K     : Natural := 0;

      Field : DOM.Core.Node;
   begin
      Field := First_Child (N);

      while Field /= null loop
         K := K + 1;
         OS (K) := +Parse_Param (Field, S);

         Field := Next_Sibling (Field);
      end loop;

      return Types.R (OS (1 .. K), Name);
   end Parse_Record;

   ------------------
   -- Parse_String --
   ------------------

   function Parse_String (N : in DOM.Core.Node) return Types.Object'Class is
      use type DOM.Core.Node;

      Name  : constant String := Local_Name (N);
      Value : DOM.Core.Node;
   begin
      Normalize (N);
      Value := First_Child (N);

      if Value = null then
         --  No node found, this is an empty string.
         return Types.S ("", Name);

      else
         return Types.S (Node_Value (Value), Name);
      end if;
   end Parse_String;

   ------------------------
   -- Parse_Time_Instant --
   ------------------------

   function Parse_Time_Instant
     (N : in DOM.Core.Node)
      return Types.Object'Class
   is
      use Ada.Calendar;

      Name  : constant String        := Local_Name (N);
      Value : constant DOM.Core.Node := First_Child (N);
      TI    : constant String        := Node_Value (Value);

      T     : Time;
   begin
      --  timeInstant format is CCYY-MM-DDThh:mm:ss[[+|-]hh:mm | Z]

      T := Time_Of (Year    => Year_Number'Value (TI (1 .. 4)),
                    Month   => Month_Number'Value (TI (6 .. 7)),
                    Day     => Day_Number'Value (TI (9 .. 10)),
                    Seconds => Duration (Natural'Value (TI (12 .. 13)) * 3600
                                           + Natural'Value (TI (15 .. 16)) * 60
                                           + Natural'Value (TI (18 .. 19))));

      if TI'Last = 19                           -- No timezone
        or else
          (TI'Last = 20 and then TI (20) = 'Z') --  GMT timezone
        or else
          TI'Last < 22                          -- No enough timezone data
      then
         return Types.T (T, Name);
      else
         return Types.T (T, Name, Types.TZ'Value (TI (20 .. 22)));
      end if;
   end Parse_Time_Instant;

   -------------------
   -- Parse_Wrapper --
   -------------------

   procedure Parse_Wrapper (N : in DOM.Core.Node; S : in out State) is
      use type SOAP.Parameters.List;

      function Prefix return String;
      --  Returns node prefix (with a ':' in front) if a prefix is used for
      --  the node N.

      NL   : constant DOM.Core.Node_List      := Child_Nodes (N);
      Name : constant String                  := Local_Name (N);
      Atts : constant DOM.Core.Named_Node_Map := Attributes (N);

      ------------
      -- Prefix --
      ------------

      function Prefix return String is
         Prefix : constant String := DOM.Core.Nodes.Prefix (N);
      begin
         if Prefix = "" then
            return "";
         else
            return ':' & Prefix;
         end if;
      end Prefix;

   begin
      if Length (Atts) /= 0 then
         declare
            use type DOM.Core.Node;

            xmlns : constant DOM.Core.Node
              := Get_Named_Item (Atts, "xmlns" & Prefix);
         begin
            if xmlns /= null then
               S.Name_Space := To_Unbounded_String (Node_Value (xmlns));
            end if;
         end;
      end if;

      S.Wrapper_Name := To_Unbounded_String (Name);

      for K in 0 .. Length (NL) - 1 loop
         S.Parameters := S.Parameters & Parse_Param (Item (NL, K), S);
      end loop;
   end Parse_Wrapper;

end SOAP.Message.XML;