------------------------------------------------------------------------------ -- Ada Web Server -- -- -- -- Copyright (C) 2007-2021, AdaCore -- -- -- -- This 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 software 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 -- -- distributed with this software; see file COPYING3. If not, go -- -- to http://www.gnu.org/licenses for a complete copy of the license. -- ------------------------------------------------------------------------------ with Ada.Exceptions; with Ada.Environment_Variables; with Ada.Text_IO; with Ada.Strings.Fixed; with AWS.Client; with AWS.Parameters; with AWS.Server.Status; with AWS.Response; with AWS.Status; with AWS.MIME; with AWS.URL; with AWS.Utils; procedure URL_Object is use Ada; use AWS; WS : Server.HTTP; function CB (Request : Status.Data) return Response.Data is U : constant URL.Object := Status.URI (Request); P : constant Parameters.List := Status.Parameters (Request); URL_Image : String := URL.URL (U); Port : constant Positive := Server.Status.Port (WS); Port_Image : constant String := Utils.Image (Port); Port_Idx : constant Natural := Strings.Fixed.Index (URL_Image, ':' & Port_Image & '/'); begin Strings.Fixed.Replace_Slice (URL_Image, Port_Idx + 1, Port_Idx + Port_Image'Length, "port"); Text_IO.Put_Line ("p1=" & Parameters.Get (P, "p1")); Text_IO.Put_Line ("p2=" & Parameters.Get (P, "p2")); Text_IO.Put_Line ("----------------------"); Text_IO.Put_Line ("p1=" & Status.Parameter (Request, "p1")); Text_IO.Put_Line ("p2=" & Status.Parameter (Request, "p2")); Text_IO.Put_Line ("----------------------"); Text_IO.Put_Line ("URI = " & Status.URI (Request)); Text_IO.Put_Line ("URL = " & URL_Image); Text_IO.Put_Line ("Query = " & URL.Query (U)); Text_IO.Put_Line ("Path = " & URL.Path (U)); Text_IO.Put_Line ("Pathname = " & URL.Pathname (U)); Text_IO.Put_Line ("File = " & URL.File (U)); Text_IO.Put_Line ("Parameters = " & URL.Parameters (U)); Text_IO.Put_Line ("Server_Name = " & URL.Server_Name (U)); if URL.Port (U) /= Port or else URL.Port (U) /= Port_Image then Text_IO.Put_Line ("URL.Port error"); end if; return Response.Build (MIME.Text_HTML, "not used"); exception when E : others => Text_IO.Put_Line (Ada.Exceptions.Exception_Information (E)); return Response.Build (MIME.Text_HTML, "error"); end CB; procedure Test_Relative_Resolution (Base : String; URI : String; Expected : String) is use Ada.Strings.Fixed; use AWS.URL; Len : Integer; Pad : Integer; URI_O : AWS.URL.Object; Base_O : AWS.URL.Object; Result : AWS.URL.Object; begin URI_O := Parse (URI, Check_Validity => False); Base_O := Parse (Base, Check_Validity => False); Result := Resolve (URI_O, Base_O); if URI'Length > 20 then Len := URI'Length; Pad := 0; else Len := 20; Pad := 20 - URI'Length; end if; Text_IO.Put_Line (URI & (Pad * ' ') & " -> " & AWS.URL.URL (Result)); if AWS.URL.URL (Result) /= Expected then Text_IO.Put_Line ("FAILURE" & ((Len - 13) * ' ') & "Expected: " & Expected); Text_IO.Put_Line ("* " & AWS.URL.URL (Base_O)); Text_IO.Put_Line (" Protocol = " & Protocol_Name (Base_O)); Text_IO.Put_Line (" Host = " & Host (Base_O)); Text_IO.Put_Line (" Abs_Path = " & Abs_Path (Base_O)); Text_IO.Put_Line (" Path = " & Path (Base_O)); Text_IO.Put_Line (" File = " & File (Base_O)); Text_IO.Put_Line ("* " & AWS.URL.URL (URI_O)); Text_IO.Put_Line (" Protocol = " & Protocol_Name (URI_O)); Text_IO.Put_Line (" Host = " & Host (URI_O)); Text_IO.Put_Line (" Abs_Path = " & Abs_Path (URI_O)); Text_IO.Put_Line (" Path = " & Path (URI_O)); Text_IO.Put_Line (" File = " & File (URI_O)); Text_IO.New_Line; end if; exception when E : others => if Ada.Environment_Variables.Exists ("debug_aws_test") then Text_IO.Put_Line (Ada.Exceptions.Exception_Information (E)); else -- Do not show stack locations if not requested: Text_IO.Put_Line ("Exception name: " & Ada.Exceptions.Exception_Name (E)); Text_IO.Put_Line ("Message: " & Ada.Exceptions.Exception_Message (E)); Text_IO.New_Line; end if; end Test_Relative_Resolution; begin Server.Start (WS, "url_object", CB'Unrestricted_Access, Port => 0); Text_IO.Put_Line ("started"); Ada.Text_IO.Flush; declare URL : constant String := AWS.Server.Status.Local_URL (WS); R : Response.Data; begin R := Client.Get (URL & "/get_it?p1=1&p2=toto"); R := Client.Get (URL & "/get_it/disk.html?p1=0956&p2=uuu"); end; Server.Shutdown (WS); Text_IO.Put_Line ("shutdown"); Text_IO.New_Line; Text_IO.Put_Line ("------------------------------------------------------"); Text_IO.Put_Line ("Testing Relative URL Resolution - RFC 2557 Section 5.2"); declare Base : constant String := "http://a/b/c/d;p?q=q"; begin -- '=' were added to query strings because AWS.Parameters cannot handle -- arbitrary query strings. Text_IO.New_Line; Text_IO.Put_Line ("Base: " & Base); Text_IO.Put_Line ("----------------------"); Text_IO.New_Line; Text_IO.Put_Line ("Normal Examples:"); Test_Relative_Resolution (Base, "g:h", "g:h"); Test_Relative_Resolution (Base, "g", "http://a/b/c/g"); Test_Relative_Resolution (Base, "./g", "http://a/b/c/g"); Test_Relative_Resolution (Base, "g/", "http://a/b/c/g/"); Test_Relative_Resolution (Base, "/g", "http://a/g"); -- Test_Relative_Resolution (Base, "//g", "http://g"); Test_Relative_Resolution (Base, "//g/", "http://g/"); Test_Relative_Resolution (Base, "?y=y", "http://a/b/c/d;p?y=y"); Test_Relative_Resolution (Base, "g?y=y", "http://a/b/c/g?y=y"); Test_Relative_Resolution (Base, "#s", "http://a/b/c/d;p?q=q#s"); Test_Relative_Resolution (Base, "g#s", "http://a/b/c/g#s"); Test_Relative_Resolution (Base, "g?y=y#s", "http://a/b/c/g?y=y#s"); Test_Relative_Resolution (Base, ";x", "http://a/b/c/;x"); Test_Relative_Resolution (Base, "g;x", "http://a/b/c/g;x"); Test_Relative_Resolution (Base, "g;x?y=y#s", "http://a/b/c/g;x?y=y#s"); Test_Relative_Resolution (Base, "", "http://a/b/c/d;p?q=q"); Test_Relative_Resolution (Base, ".", "http://a/b/c/"); Test_Relative_Resolution (Base, "./", "http://a/b/c/"); Test_Relative_Resolution (Base, "..", "http://a/b/"); Test_Relative_Resolution (Base, "../", "http://a/b/"); Test_Relative_Resolution (Base, "../g", "http://a/b/g"); Test_Relative_Resolution (Base, "../..", "http://a/"); Test_Relative_Resolution (Base, "../../", "http://a/"); Test_Relative_Resolution (Base, "../../g", "http://a/g"); Text_IO.New_Line; Text_IO.Put_Line ("Too much '..':"); Test_Relative_Resolution (Base, "../../../g", "http://a/g"); Test_Relative_Resolution (Base, "../../../../g", "http://a/g"); Text_IO.New_Line; Text_IO.Put_Line ("Do not remove '.' and '..' in path components:"); Test_Relative_Resolution (Base, "/./g", "http://a/g"); Test_Relative_Resolution (Base, "/../g", "http://a/g"); Test_Relative_Resolution (Base, "g.", "http://a/b/c/g."); Test_Relative_Resolution (Base, ".g", "http://a/b/c/.g"); Test_Relative_Resolution (Base, "g..", "http://a/b/c/g.."); Test_Relative_Resolution (Base, "..g", "http://a/b/c/..g"); Text_IO.New_Line; Text_IO.Put_Line ("Unnecessary '.' and '..':"); Test_Relative_Resolution (Base, "./../g", "http://a/b/g"); Test_Relative_Resolution (Base, "./g/.", "http://a/b/c/g/"); Test_Relative_Resolution (Base, "g/./h", "http://a/b/c/g/h"); Test_Relative_Resolution (Base, "g/../h", "http://a/b/c/h"); Test_Relative_Resolution (Base, "g;x=1/./y", "http://a/b/c/g;x=1/y"); Test_Relative_Resolution (Base, "g;x=1/../y", "http://a/b/c/y"); Text_IO.New_Line; Text_IO.Put_Line ("Separate query and fragment:"); Test_Relative_Resolution (Base, "g?y=/./x", "http://a/b/c/g?y=/./x"); Test_Relative_Resolution (Base, "g?y=/../x", "http://a/b/c/g?y=/../x"); Test_Relative_Resolution (Base, "g#s/./x", "http://a/b/c/g#s/./x"); Test_Relative_Resolution (Base, "g#s/../x", "http://a/b/c/g#s/../x"); Text_IO.New_Line; Text_IO.Put_Line ("No scheme in relative URI (strict):"); Test_Relative_Resolution (Base, "http:g", "http:g"); end; end URL_Object;