------------------------------------------------------------------------------ -- Ada Web Server -- -- -- -- Copyright (C) 2000-2022, AdaCore -- -- -- -- This library is free software; you can redistribute it and/or modify -- -- it under terms of the GNU General Public License as published by the -- -- Free Software Foundation; either version 3, 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. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are -- -- granted additional permissions described in the GCC Runtime Library -- -- Exception, version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- . -- -- -- -- 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. -- ------------------------------------------------------------------------------ pragma Ada_2012; with Ada.Calendar.Arithmetic; with Ada.Calendar.Formatting; with Ada.Calendar.Time_Zones; with Ada.Calendar; with Ada.Characters.Handling; with Ada.Strings.Fixed; with Ada.Strings.Maps.Constants; with Ada.Unchecked_Deallocation; with Unicode.CES.Basic_8bit; with Unicode.CES.Utf8; with AWS.Utils; with SOAP.Message.XML; package body SOAP.Utils is Last_Character_Index : constant Unicode_Char := Character'Pos (Character'Last); Utf8_Map : Utf8_Map_Callback := Default_Utf8_Mapping'Access; --------- -- Any -- --------- function Any (V : Types.XSD_Any_Type; Name : String := "item"; Type_Name : String := Types.XML_String; NS : Name_Space.Object := Name_Space.No_Name_Space) return Types.XSD_Any_Type is begin return SOAP.Types.Any (Types.Object'Class (V), Name, Type_Name, NS); end Any; ------- -- C -- ------- function C (V : Character; Name : String := "item"; Type_Name : String := "Character"; NS : Name_Space.Object := Name_Space.No_Name_Space) return Types.XSD_String is begin return Types.S (String'(1 => V), Name, Type_Name, NS); end C; -------------------------- -- Default_Utf8_Mapping -- -------------------------- function Default_Utf8_Mapping (C : Unicode_Char) return Character is pragma Unreferenced (C); Invalid_Utf8_Character : constant Character := '?'; begin return Invalid_Utf8_Character; end Default_Utf8_Mapping; -------------- -- Duration -- -------------- function Duration (D, Name : String; Type_Name : String := Types.XML_Duration) return Types.XSD_Duration is use Ada; use Ada.Calendar; use Ada.Calendar.Arithmetic; use type Strings.Maps.Character_Set; subtype S_Duration is Standard.Duration; Numeric_Set : constant Strings.Maps.Character_Set := Strings.Maps.Constants.Decimal_Digit_Set or Strings.Maps.To_Set ("."); Minute : constant := 60; Hour : constant := 60 * Minute; Base : constant Calendar.Time := Calendar.Clock; Negative : constant Boolean := D (D'First) = '-'; Next : Calendar.Time; B_Year : Calendar.Year_Number; B_Month : Positive; B_Day : Calendar.Day_Number; B_Seconds : Standard.Duration; Time_Mode : Boolean := False; N_Day : Calendar.Arithmetic.Day_Count := 0; Seconds : S_Duration := 0.0; K : Positive := D'First + (if Negative then 2 else 1); L : Natural; begin Calendar.Split (Base, B_Year, B_Month, B_Day, B_Seconds); -- Parse XSD duration while K < D'Last loop -- Time separator found, skip it if D (K) = 'T' then Time_Mode := True; K := K + 1; end if; -- Check for next non-digit character, all chunk are [K] where -- K is a letter specifiying the actual part of the duration. L := Strings.Fixed.Index (D, From => K, Set => Numeric_Set, Test => Strings.Outside); exit when L = 0; declare Value : constant S_Duration := S_Duration'Value (D (K .. L - 1)); Key : constant Character := D (L); begin case Key is when 'Y' => B_Year := B_Year + Natural (Value); when 'M' => if Time_Mode then Seconds := Seconds + S_Duration (Value * Minute); else B_Month := B_Month + Natural (Value); while B_Month > 12 loop B_Year := B_Year + 1; B_Month := B_Month - 12; end loop; end if; when 'D' => N_Day := Calendar.Arithmetic.Day_Count (Value); when 'H' => Seconds := Seconds + Value * Hour; when 'S' => Seconds := Seconds + Value; when others => null; end case; end; K := L + 1; end loop; -- Now compute the date startinig from base and adding the duration -- First we take into accound the Year and Month and keep the other -- parameters. Next := Calendar.Time_Of (B_Year, B_Month, B_Day, B_Seconds); -- Then we need to add the Second and Day count Next := Next + N_Day; Next := Next + Seconds; declare Result : Standard.Duration := Next - Base; begin if Negative then Result := -Result; end if; return Types.D (Result, Name, Type_Name); end; end Duration; ------------ -- Encode -- ------------ procedure Encode (S : Unbounded_String; Result : in out Unbounded_String) is Ch : Character; begin for K in 1 .. Length (S) loop Ch := Element (S, K); case Ch is when '<' => Append (Result, "<"); when '>' => Append (Result, ">"); when '&' => Append (Result, "&"); when ''' => Append (Result, "'"); when '"' => Append (Result, """); when Character'Val (0) .. Character'Val (31) => Append (Result, "&#"); Append (Result, AWS.Utils.Image (Natural (Character'Pos (Ch)))); Append (Result, ';'); when others => Append (Result, Ch); end case; end loop; end Encode; function Encode (Str : String) return String is Result : Unbounded_String; begin Encode (To_Unbounded_String (Str), Result); return To_String (Result); end Encode; --------------- -- From_Utf8 -- --------------- function From_Utf8 (Str : String) return String is A : String_Access := From_Utf8 (Str); R : constant String := A.all; begin Free (A); return R; end From_Utf8; function From_Utf8 (Str : Unbounded_String) return Unbounded_String is use type Unicode_Char; Idx : Integer := 1; Buf : String (1 .. 6); Buf_Last : Integer := 0; Ch32 : Unicode_Char; W : Integer; Result : Unbounded_String; begin loop while Idx <= Length (Str) and then Buf_Last < Buf'Last loop Buf (Buf_Last + 1) := Element (Str, Idx); Idx := Idx + 1; Buf_Last := Buf_Last + 1; end loop; exit when Buf_Last = 0; W := 1; Unicode.CES.Utf8.Read (Buf, W, Ch32); W := W - 1; Buf_Last := Buf_Last - W; for I in 1 .. Buf_Last loop Buf (I) := Buf (I + W); end loop; if Ch32 > Last_Character_Index then Append (Result, Utf8_Map (Ch32)); else Append (Result, Character'Val (Ch32)); end if; end loop; return Result; end From_Utf8; function From_Utf8 (Str : String) return String_Access is use type Unicode_Char; Result : String_Access := new String (1 .. 2000); Last : Integer := 0; procedure Append (Ch : Character) with Inline; -- Append Ch into Result, adjust Result size if needed procedure Adjust_Result with Inline; -- Adjust final Result to the right size ------------------- -- Adjust_Result -- ------------------- procedure Adjust_Result is Old : String_Access; begin if Last /= Result'Last then Old := Result; Result := new String (1 .. Last); Result.all := Old (1 .. Last); Free (Old); end if; end Adjust_Result; ------------ -- Append -- ------------ procedure Append (Ch : Character) is Old : String_Access; begin if Last >= Result'Last then Old := Result; Result := new String (1 .. Old'Last * 2); Result (1 .. Old'Last) := Old.all; Free (Old); end if; Last := Last + 1; Result (Last) := Ch; end Append; Idx : Integer := Str'First; Buf : String (1 .. 6); Buf_Last : Integer := 0; Ch32 : Unicode_Char; W : Integer; begin loop while Idx <= Str'Last and then Buf_Last < Buf'Last loop Buf (Buf_Last + 1) := Str (Idx); Idx := Idx + 1; Buf_Last := Buf_Last + 1; end loop; exit when Buf_Last = 0; W := 1; Unicode.CES.Utf8.Read (Buf, W, Ch32); W := W - 1; Buf_Last := Buf_Last - W; for I in 1 .. Buf_Last loop Buf (I) := Buf (I + W); end loop; if Ch32 > Last_Character_Index then Append (Utf8_Map (Ch32)); else Append (Character'Val (Ch32)); end if; end loop; Adjust_Result; return Result; end From_Utf8; --------- -- Get -- --------- function Get (Item : Types.Object'Class) return Unbounded_String is begin return To_Unbounded_String (String'(Types.Get (Item))); end Get; function Get (Item : Types.Object'Class) return Character is Str : constant String := String'(Types.Get (Item)); begin -- Str is empty if passed as optional parameter (xsi:nil) if Str'Length = 0 then return ASCII.NUL; else return Str (Str'First); end if; end Get; function Get (Item : Types.Object'Class) return String is Enum : constant Types.SOAP_Enumeration := Types.SOAP_Enumeration (Item); begin return Types.Image (Enum); end Get; -------------------------- -- Is_Ada_Reserved_Word -- -------------------------- function Is_Ada_Reserved_Word (Name : String) return Boolean is N : constant String := Ada.Characters.Handling.To_Lower (Name); begin if N in "abort" | "else" | "new" | "return" | "abs" | "elsif" | "not" | "reverse" | "abstract" | "end" | "null" | "accept" | "entry" | "select" | "access" | "exception" | "separate" | "aliased" | "exit" | "of" | "subtype" | "all" | "or" | "and" | "for" | "others" | "tagged" | "array" | "function" | "out" | "task" | "at" | "terminate" | "generic" | "package" | "then" | "begin" | "goto" | "pragma" | "type" | "body" | "private" | "if" | "procedure" | "case" | "in" | "protected" | "until" | "constant" | "is" | "use" | "raise" | "declare" | "range" | "when" | "delay" | "limited" | "record" | "while" | "delta" | "loop" | "rem" | "with" | "digits" | "renames" | "do" | "mod" | "requeue" | "xor" | "synchronized" | "overriding" | "interface" | "some" then return True; else return False; end if; end Is_Ada_Reserved_Word; ----------- -- No_NS -- ----------- function No_NS (Name : String) return String is K : constant Natural := Ada.Strings.Fixed.Index (Name, ":"); begin if K = 0 then return Name; else return Name (K + 1 .. Name'Last); end if; end No_NS; -------- -- NS -- -------- function NS (Name : String) return String is K : constant Natural := Ada.Strings.Fixed.Index (Name, ":"); begin if K = 0 then return ""; else return Name (Name'First .. K - 1); end if; end NS; ------------------- -- Safe_Pointers -- ------------------- package body Safe_Pointers is procedure Unchecked_Free is new Ada.Unchecked_Deallocation (T, T_Access); procedure Unchecked_Free is new Ada.Unchecked_Deallocation (Natural, Ref_Counter); ------------ -- Adjust -- ------------ overriding procedure Adjust (SP : in out Safe_Pointer) is begin SP.Ref.all := SP.Ref.all + 1; end Adjust; -------------- -- Finalize -- -------------- overriding procedure Finalize (SP : in out Safe_Pointer) is Ref : Ref_Counter := SP.Ref; begin -- Ensure call is idempotent SP.Ref := null; if Ref /= null then Ref.all := Ref.all - 1; if Ref.all = 0 then Unchecked_Free (SP.Item); Unchecked_Free (Ref); end if; end if; end Finalize; ---------------- -- Initialize -- ---------------- overriding procedure Initialize (SP : in out Safe_Pointer) is begin SP.Ref := new Natural'(1); end Initialize; ---------------------- -- To_Safe_Pointer -- ---------------------- function To_Safe_Pointer (Item : T) return Safe_Pointer is begin return (Ada.Finalization.Controlled with new T'(Item), new Natural'(1)); end To_Safe_Pointer; end Safe_Pointers; ------------------ -- Set_Utf8_Map -- ------------------ procedure Set_Utf8_Map (Callback : Utf8_Map_Callback) is begin Utf8_Map := Callback; end Set_Utf8_Map; ------------------ -- SOAP_Wrapper -- ------------------ function SOAP_Wrapper (Request : AWS.Status.Data; Schema : WSDL.Schema.Definition := WSDL.Schema.Empty) return AWS.Response.Data is SOAPAction : constant String := AWS.Status.SOAPAction (Request); begin if SOAPAction /= No_SOAPAction then declare Payload_Data : constant Unbounded_String := AWS.Status.Payload (Request); Payload : constant Message.Payload.Object := Message.XML.Load_Payload (Payload_Data, Schema => Schema); begin return SOAP_CB (SOAPAction, Payload, Request); end; else raise Constraint_Error; end if; end SOAP_Wrapper; --------- -- Tag -- --------- function Tag (Name : String; Start : Boolean) return String is begin if Start then return '<' & Name & '>'; else return "'; end if; end Tag; ------------------ -- Time_Instant -- ------------------ function Time_Instant (TI, Name : String; Type_Name : String := Types.XML_Time_Instant) return Types.XSD_Time_Instant is use Ada; use Ada.Calendar; use Ada.Calendar.Formatting; use type Ada.Calendar.Time_Zones.Time_Offset; -- A time-zone starts with either + | - or Z TZ_Pattern : constant Strings.Maps.Character_Set := Strings.Maps.To_Set ("+-Z"); -- A time-instant string may start with a minus sign to specify a year -- Before Common Era. We do not support such date here and so we just -- skip the minus sign if present. Also not that a plus sign is not -- allowed. First : constant Positive := (if TI'Length > 1 and then TI (TI'First) = '-' then TI'First + 1 else TI'First); subtype Year_Range is Positive range First .. First + 3; subtype Month_Range is Positive range First + 5 .. First + 6; subtype Day_Range is Positive range First + 8 .. First + 9; subtype Hour_Range is Positive range First + 11 .. First + 12; subtype Minute_Range is Positive range First + 14 .. First + 15; subtype Second_Range is Positive range First + 17 .. First + 18; -- If we have franctional second skip them TZ_Start : constant Natural := Strings.Fixed.Index (TI, TZ_Pattern, From => Second_Range'Last); TZ_First : constant Positive := (if TZ_Start /= 0 then TZ_Start else TI'Last + 1); subtype TZ_Type_Range is Positive range TZ_First .. TZ_First; subtype TZ_Hour_Range is Positive range TZ_First + 1 .. TZ_First + 2; subtype TZ_Minute_Range is Positive range TZ_First + 4 .. TZ_First + 5; T : Types.Local_Time; TZ : Time_Zones.Time_Offset := 0; Sub_Second : Second_Duration := 0.0; begin -- timeInstant format is (-)CCYY-MM-DDThh:mm:ss(.sss)[[+|-]hh:mm | Z] -- Check if an optional fractional second part is present if Second_Range'Last + 1 < TZ_Type_Range'First then Sub_Second := Second_Duration'Value (TI (Second_Range'Last + 1 .. TZ_Type_Range'First - 1)); end if; -- Check if a time-zone is specified if TI'Last >= TZ_Type_Range'Last then -- Time zone specified if TI'Last >= TZ_Hour_Range'Last then TZ := Time_Zones.Time_Offset'Value (TI (TZ_Hour_Range)) * 60; if TI'Last = TZ_Minute_Range'Last then TZ := TZ + Time_Zones.Time_Offset'Value (TI (TZ_Minute_Range)); end if; if TI (TZ_Type_Range) = "-" then TZ := -TZ; end if; end if; end if; T := Time_Of (Year => Year_Number'Value (TI (Year_Range)), Month => Month_Number'Value (TI (Month_Range)), Day => Day_Number'Value (TI (Day_Range)), Hour => Hour_Number'Value (TI (Hour_Range)), Minute => Minute_Number'Value (TI (Minute_Range)), Second => Second_Number'Value (TI (Second_Range)), Sub_Second => Sub_Second, Time_Zone => TZ); return Types.T (T, Name, Type_Name => Type_Name); end Time_Instant; ------------- -- To_Name -- ------------- function To_Name (Q_Name : String) return String is use Ada; begin return Strings.Fixed.Translate (Q_Name, Strings.Maps.To_Mapping (":", "_")); end To_Name; ------------------- -- To_Object_Set -- ------------------- function To_Object_Set (From : T_Array; NS : Name_Space.Object) return Types.Object_Set is use SOAP.Types; Result : Types.Object_Set (From'Range); begin for K in From'Range loop Result (K) := +Get (From (K), Name => E_Name, Type_Name => Type_Name, NS => NS); end loop; return Result; end To_Object_Set; --------------------- -- To_Object_Set_C -- --------------------- function To_Object_Set_C (From : T_Array; NS : Name_Space.Object) return Types.Object_Set is use SOAP.Types; Result : Types.Object_Set (1 .. Integer (From'Last)); begin for K in From'Range loop Result (Integer (K)) := +Get (From (K), Name => E_Name, Type_Name => Type_Name, NS => NS); end loop; return Result; end To_Object_Set_C; --------------------- -- To_Object_Set_V -- --------------------- function To_Object_Set_V (From : Vector.Vector; NS : Name_Space.Object) return Types.Object_Set is use SOAP.Types; Result : Types.Object_Set (1 .. Integer (From.Length)); begin for K in Result'Range loop Result (K) := +Get (From (K), Name => E_Name, Type_Name => Type_Name, NS => NS); end loop; return Result; end To_Object_Set_V; ---------------- -- To_T_Array -- ---------------- function To_T_Array (From : Types.Object_Set) return T_Array is use SOAP.Types; Result : T_Array (From'Range); begin for K in From'Range loop Result (K) := Get (-From (K)); end loop; return T_Array'(Result); end To_T_Array; ------------------ -- To_T_Array_C -- ------------------ function To_T_Array_C (From : Types.Object_Set) return T_Array is use SOAP.Types; Result : T_Array; begin for K in Result'Range loop Result (K) := Get (-From (Integer (K))); end loop; return Result; end To_T_Array_C; ------------- -- To_Utf8 -- ------------- function To_Utf8 (Str : String) return String is begin return Unicode.CES.Utf8.From_Utf32 (Unicode.CES.Basic_8bit.To_Utf32 (Str)); end To_Utf8; function To_Utf8 (Str : Unbounded_String) return Unbounded_String is Chars : String (1 .. 6); Idx : Integer; Result : Unbounded_String; begin for I in 1 .. Length (Str) loop Idx := 0; Unicode.CES.Utf8.Encode (Character'Pos (Element (Str, I)), Chars, Idx); Append (Result, Chars (1 .. Idx)); end loop; return Result; end To_Utf8; --------------- -- To_Vector -- --------------- function To_Vector (From : Types.Object_Set) return Vector.Vector is use SOAP.Types; Result : Vector.Vector; begin for K in From'Range loop Result.Append (Get (-From (K))); end loop; return Result; end To_Vector; -------- -- US -- -------- function US (V : Unbounded_String; Name : String := "item"; Type_Name : String := Types.XML_String; NS : Name_Space.Object := Name_Space.No_Name_Space) return Types.XSD_String is begin return Types.S (To_String (V), Name, Type_Name, NS); end US; ------- -- V -- ------- function V (O : Types.XSD_String) return Unbounded_String is begin return To_Unbounded_String (Types.V (O)); end V; function V (O : Types.XSD_String) return Character is begin return Types.V (O) (1); end V; ------------- -- With_NS -- ------------- function With_NS (NS, Name : String) return String is use Ada; K : Natural; begin if NS = "" then return Name; else K := Strings.Fixed.Index (Name, ":"); if K = 0 then K := Name'First; else K := K + 1; end if; return NS & ':' & Name (K .. Name'Last); end if; end With_NS; end SOAP.Utils;