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.25 2003/12/31 16:04:54 obry Exp $

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

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;
with SOAP.XML;

package body SOAP.Message.XML is

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

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

   Max_Object_Size : constant := 2_048;
   --  This is the maximum number of items in a record or an array supported
   --  by this implementation.

   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
     (Name : in String;
      N    : in DOM.Core.Node)
      return Types.Object'Class;

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

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

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

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

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

   function Parse_Time_Instant
     (Name : in String;
      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
     (Name : in String;
      N    : in DOM.Core.Node;
      S    : in State)
      return Types.Object'Class;

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

   function Parse_Enumeration
     (Name : in String;
      N    : in DOM.Core.Node)
      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;

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

   begin
      Open (XML'Unrestricted_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;

   function Load_Response
     (XML : in Unbounded_String)
      return Message.Response.Object'Class
   is
      S : String_Access := new String (1 .. Length (XML));
   begin
      --  Copy XML content to local S string
      for I in 1 .. Length (XML) loop
         S (I) := Element (XML, I);
      end loop;

      declare
         Result : constant Message.Response.Object'Class
           := Load_Response (S.all);
      begin
         Free (S);
         return Result;
      end;
   end Load_Response;

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

   function Parse_Array
     (Name : in String;
      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;

      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
     (Name : in String;
      N    : in DOM.Core.Node)
      return Types.Object'Class
   is
      use type DOM.Core.Node;

      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
     (Name : in String;
      N    : in DOM.Core.Node)
      return Types.Object'Class
   is
      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
     (Name : in String;
      N    : in DOM.Core.Node)
      return Types.Object'Class
   is
      Value : constant DOM.Core.Node := First_Child (N);
   begin
      return Types.D (Long_Long_Float'Value (Node_Value (Value)), Name);
   end Parse_Double;

   -----------------------
   -- Parse_Enumeration --
   -----------------------

   function Parse_Enumeration
     (Name : in String;
      N    : in DOM.Core.Node)
      return Types.Object'Class is
   begin
      return Types.E
        (Node_Value (First_Child (N)),
         Utils.No_NS (SOAP.XML.Get_Attr_Value (N, "type")),
         Name);
   end Parse_Enumeration;

   --------------------
   -- 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
     (Name : in String;
      N    : in DOM.Core.Node)
      return Types.Object'Class
   is
      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
     (Name : in String;
      N    : in DOM.Core.Node)
      return Types.Object'Class
   is
      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);

      Ref  : constant DOM.Core.Node           := SOAP.XML.Get_Ref (N);
      Atts : constant DOM.Core.Named_Node_Map := Attributes (Ref);

      --------------
      -- 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;

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

   begin
      if To_String (S.Wrapper_Name) = "Fault" then
         return Parse_String (Name, Ref);

      else
         if XSI_Type = null and then S.A_State in Void .. A_Undefined then
            --  No xsi:type attribute found

            if S_Type /= null
              and then First_Child (Ref).Node_Type = DOM.Core.Text_Node
            then
               --  Not xsi:type but a type information, the child being a text
               --  node, this is an enumeration.

               return Parse_Enumeration (Name, Ref);

            elsif First_Child (Ref) /= null
              and then First_Child (Ref).Node_Type = DOM.Core.Text_Node
            then
               --  No xsi:type and no type information.
               --  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 (Name, Ref);

            else
               --  This is a type defined in a schema, either a SOAP record
               --  or an enumeration, enumerations will be checked into
               --  Parse record.
               --  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 (Name, Ref, S);
            end if;

         else
            case S.A_State is
               when A_Int =>
                  return Parse_Int (Name, Ref);

               when A_Float =>
                  return Parse_Float (Name, Ref);

               when A_Double =>
                  return Parse_Double (Name, Ref);

               when A_String =>
                  return Parse_String (Name, Ref);

               when A_Boolean =>
                  return Parse_Boolean (Name, Ref);

               when A_Time_Instant =>
                  return Parse_Time_Instant (Name, Ref);

               when A_Base64 =>
                  return Parse_Base64 (Name, Ref);

               when Void | A_Undefined =>

                  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 (Name, Ref);

                        elsif xsd = Types.XML_Float then
                           return Parse_Float (Name, Ref);

                        elsif xsd = Types.XML_Double then
                           return Parse_Double (Name, Ref);

                        elsif xsd = Types.XML_String then
                           return Parse_String (Name, Ref);

                        elsif xsd = Types.XML_Boolean then
                           return Parse_Boolean (Name, Ref);

                        elsif xsd = Types.XML_Time_Instant then
                           return Parse_Time_Instant (Name, Ref);

                        elsif xsd = Types.XML_Base64 then
                           return Parse_Base64 (Name, Ref);

                        elsif Is_Array then
                           return Parse_Array (Name, Ref, 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 (Name, Ref, S);
                        end if;
                     end;
                  end if;
            end case;
         end if;
      end if;
   end Parse_Param;

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

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

      OS : Types.Object_Set (1 .. Max_Object_Size);
      K  : Natural := 0;

      Field : DOM.Core.Node := SOAP.XML.Get_Ref (N);
   begin
      if Name /= Local_Name (N)
        and then First_Child (Field).Node_Type = DOM.Core.Text_Node
      then
         --  This is not a record after all, it is an enumeration with an href
         --  A record can't have a text child node.
         return Types.E
           (Node_Value (First_Child (Field)),
            Utils.No_NS (SOAP.XML.Get_Attr_Value (Field, "xsi:type")),
            Name);

      else
         Field := First_Child (Field);

         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 if;
   end Parse_Record;

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

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

      L : DOM.Core.Node_List := Child_Nodes (N);
      S : Unbounded_String;
      P : DOM.Core.Node;
   begin
      for I in 0 .. Length (L) - 1 loop
         P := Item (L, I);
         if P.Node_Type = DOM.Core.Text_Node then
            Append (S, Node_Value (P));
         end if;
      end loop;

      return Types.S (S, Name);
   end Parse_String;

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

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

      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;