------------------------------------------------------------------------------ -- Ada Web Server -- -- -- -- Copyright (C) 2008-2021, 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. -- ------------------------------------------------------------------------------ with Ada.Exceptions; with Ada.Streams; with Ada.Strings.Fixed; with Ada.Text_IO; with AWS.Client.HTTP_Utils; with AWS.Config.Set; with AWS.Exceptions; with AWS.Log; with AWS.Messages; with AWS.MIME; with AWS.Net; with AWS.Parameters; with AWS.Response; with AWS.Server.Log; with AWS.Server.Status; with AWS.Status; with AWS.Translator; with AWS.Utils; procedure Uplimit is use Ada; use Ada.Streams; use Ada.Text_IO; use AWS; function CB (Request : Status.Data) return Response.Data; HTTP : Server.HTTP; procedure Start_Server; procedure Problem (E : Ada.Exceptions.Exception_Occurrence; Log : in out AWS.Log.Object; Error : AWS.Exceptions.Data; Answer : in out Response.Data); -- Web exception handler -------- -- CB -- -------- function CB (Request : Status.Data) return Response.Data is use type Status.Protocol_State; URI : constant String := Status.URI (Request); Buffer : Stream_Element_Array (1 .. 10); Prev : Stream_Element_Array (1 .. 10) := (others => 0); Last : Stream_Element_Offset; Is_H2 : constant Boolean := Status.Protocol (Request) = Status.H2; Is_Up : constant Boolean := Status.Is_Body_Uploaded (Request); begin if URI in "/" | "/noup" then if URI = "/" then if not Is_Up then if Is_H2 or else Status.Parameter (Request, "c") = "y" then return Response.Continue; else AWS.Server.Get_Message_Body; end if; end if; elsif not Is_Up and then Status.Binary_Size (Request) = 0 then return Response.Build (MIME.Text_Plain, Utils.Image (Status.Content_Length (Request)) & " bytes of message body ignored.", Messages.S413); end if; loop Status.Read_Body (Request, Buffer, Last); if Buffer (1) = 0 or else (Prev (1) /= 0 and then Buffer /= Prev) then return Response.Build (MIME.Text_Plain, "Data trasfer error '" & AWS.Translator.To_String (Prev) & "' '" & AWS.Translator.To_String (Buffer) & ''' & Status.Binary_Size (Request)'Img & ' ' & Status.Protocol (Request)'Img, Messages.S500); end if; exit when Last < Buffer'Last; Prev := Buffer; end loop; return Response.Build (MIME.Text_Plain, URI & " ok server uploaded: " & Boolean'Image (Status.Is_Body_Uploaded (Request)) & ' ' & Utils.Image (Status.Binary_Size (Request)) & ' ' & Utils.Image (Status.Content_Length (Request)) & ' ' & AWS.Translator.To_String (Prev)); else Put_Line ("Unknown URI " & URI); return Response.Build (MIME.Text_HTML, URI & " not found", Messages.S404); end if; end CB; ------------- -- Problem -- ------------- procedure Problem (E : Ada.Exceptions.Exception_Occurrence; Log : in out AWS.Log.Object; Error : AWS.Exceptions.Data; Answer : in out Response.Data) is begin Put_Line ("!ERROR " & Ada.Exceptions.Exception_Information (E)); Answer := Response.Build (MIME.Text_HTML, "Server side exception " & Ada.Exceptions.Exception_Message (E)); end Problem; ------------ -- Server -- ------------ procedure Start_Server is Web_Config : Config.Object; begin Config.Set.Server_Port (Web_Config, 0); Config.Set.Upload_Directory (Web_Config, "./"); Config.Set.Upload_Size_Limit (Web_Config, 11_000); Config.Set.Max_Connection (Web_Config, 10); Server.Set_Unexpected_Exception_Handler (HTTP, Problem'Unrestricted_Access); -- Server.Log.Start_Error (HTTP, Put_Line'Access, "error"); Server.Start (HTTP, CB'Unrestricted_Access, Web_Config); Put_Line ("Server started"); New_Line; end Start_Server; ------------- -- Request -- ------------- Client : AWS.Client.HTTP_Connection; R : Response.Data; procedure Print is begin Put_Line ("=> " & Messages.Status_Line (Response.Status_Code (R)) & ' ' & Response.Message_Body (R)); end Print; use Ada.Strings.Fixed; begin Put_Line ("Start main, wait for server to start..."); Start_Server; AWS.Client.Create (Client, Server.Status.Local_URL (HTTP)); AWS.Client.Post (Client, R, 1000 * "0123456789", URI => "/noup"); Print; AWS.Client.Post (Client, R, 1100 * "abcdefghij", URI => "/noup"); Print; AWS.Client.Post (Client, R, 1200 * "ABCDEFGHIJ", URI => "/noup"); Print; AWS.Client.Post (Client, R, 1000 * "9876543210"); Print; AWS.Client.Post (Client, R, 1100 * "qwertyuiop"); Print; -- AWS.Client.HTTP_Utils.Debug_On := True; AWS.Client.Post (Client, R, 1200 * "QWERTYUIOP"); Print; AWS.Client.HTTP_Utils.Debug_On := False; AWS.Client.Post (Client, R, 1200 * "poiuytrewq", URI => "/?c=y"); Print; Server.Shutdown (HTTP); Put_Line ("Server stopped"); exception when E : others => Server.Shutdown (HTTP); Put_Line ("Main Error " & Ada.Exceptions.Exception_Information (E)); end Uplimit;