libaws3.3.2-dev 3.3.2-2 / usr / share / ada / adainclude / aws / aws-log.adb

------------------------------------------------------------------------------
--                              Ada Web Server                              --
--                                                                          --
--                     Copyright (C) 2000-2014, 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   --
--  <http://www.gnu.org/licenses/>.                                         --
--                                                                          --
--  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;
with Ada.Command_Line;
with Ada.Directories;
with Ada.Strings.Fixed;
with Ada.Strings.Maps;
with Ada.Text_IO.C_Streams;

with GNAT.Calendar.Time_IO;

package body AWS.Log is

   procedure Check_Split (Log : in out Object; Now : Ada.Calendar.Time);
   --  Split log file if necessary

   procedure Write_Callback (Log : in out Object; Data : in out Fields_Table);
   --  Write extended format record to log file and prepare record for the next
   --  data. It is not allowed to use same Fields_Table with different extended
   --  logs.

   procedure Write_File (Log : in out Object; Data : in out Fields_Table);
   --  Write extended format record to log file and prepare record for the next
   --  data. It is not allowed to use same Fields_Table with different extended
   --  logs.

   procedure Write_Log
     (Log  : in out Object;
      Now  : Calendar.Time;
      Data : String);
   --  Write data into the log file, change log file depending on the log file
   --  split mode and Now.

   function Get_Position (File : Ada.Text_IO.File_Type) return Natural
     with Inline;
   --  Returns current write position in the text file

   -----------------
   -- Check_Split --
   -----------------

   procedure Check_Split (Log : in out Object; Now : Ada.Calendar.Time) is
      Keep_Split : Split_Mode;
   begin
      if (Log.Split = Daily
          and then Log.Current_Tag /= Calendar.Day (Now))
        or else
          (Log.Split = Monthly
           and then Log.Current_Tag /= Calendar.Month (Now))
      then
         --  Could not call Stop, because Stop would write to log again and
         --  it cause unlimited recursion.

         Text_IO.Close (Log.File);

         Start (Log             => Log,
                Split           => Log.Split,
                Size_Limit      => Log.Size_Limit,
                File_Directory  => To_String (Log.File_Directory),
                Filename_Prefix => To_String (Log.Filename_Prefix),
                Auto_Flush      => Log.Auto_Flush);

      elsif Log.Size_Limit > 0
        and then Get_Position (Log.File) > Log.Size_Limit
      then
         Keep_Split := Log.Split;

         Text_IO.Close (Log.File);

         Start (Log             => Log,
                Split           => Each_Run,
                Size_Limit      => Log.Size_Limit,
                File_Directory  => To_String (Log.File_Directory),
                Filename_Prefix => To_String (Log.Filename_Prefix),
                Auto_Flush      => Log.Auto_Flush);

         Log.Split := Keep_Split;
      end if;
   end Check_Split;

   --------------
   -- Filename --
   --------------

   function Filename (Log : Object) return String is
   begin
      if Text_IO.Is_Open (Log.File) then
         return Text_IO.Name (Log.File);
      elsif Log.Writer /= null then
         return To_String (Log.Writer_Name);
      else
         return "";
      end if;
   end Filename;

   --------------
   -- Finalize --
   --------------

   overriding procedure Finalize (Log : in out Object) is
   begin
      Stop (Log);
   end Finalize;

   -----------
   -- Flush --
   -----------

   procedure Flush (Log : in out Object) is
      use Text_IO;
   begin
      if Log.Writer /= null or else Log.Auto_Flush then
         return;
      end if;

      Log.Semaphore.Seize;

      if Is_Open (Log.File) then
         Flush (Log.File);
      end if;

      Log.Semaphore.Release;

   exception
      when others =>
         Log.Semaphore.Release;
         raise;
   end Flush;

   ------------------
   -- Get_Position --
   ------------------

   function Get_Position (File : Ada.Text_IO.File_Type) return Natural is
      use Ada.Text_IO.C_Streams;
   begin
      return Natural (ICS.ftell (C_Stream (File)));
   end Get_Position;

   ---------------
   -- Is_Active --
   ---------------

   function Is_Active (Log : Object) return Boolean is
   begin
      return Text_IO.Is_Open (Log.File) or else Log.Writer /= null;
   end Is_Active;

   ----------
   -- Mode --
   ----------

   function Mode (Log : Object) return Split_Mode is
   begin
      return Log.Split;
   end Mode;

   --------------------
   -- Register_Field --
   --------------------

   procedure Register_Field (Log : in out Object; Id : String) is
      Position : Strings_Positive.Cursor;
      Success  : Boolean;
   begin
      Log.Extended_Fields.Insert
        (Id, Natural (Log.Extended_Fields.Length) + 1, Position, Success);
   end Register_Field;

   ---------------
   -- Set_Field --
   ---------------

   procedure Set_Field
     (Log : Object; Data : in out Fields_Table; Id, Value : String)
   is
      Ext_Len  : constant Natural := Natural (Log.Extended_Fields.Length);
      Data_Len : constant Natural := Natural (Data.Values.Length);
   begin
      if Ext_Len = 0 then
         return;
      end if;

      if Data_Len = 0 then
         --  Fields record is not initialized. We have to define fields set
         --  with empty "-" values.

         for J in 1 .. Ext_Len loop
            Data.Values.Append ("-");
         end loop;

      elsif Data_Len /= Ext_Len then
         --  Looks like the record was used with different log file

         raise Constraint_Error;
      end if;

      declare
         CSN : constant Strings_Positive.Cursor :=
                 Log.Extended_Fields.Find (Id);
      begin
         if Value /= "" and then Strings_Positive.Has_Element (CSN) then
            Data.Values.Replace_Element
              (Strings_Positive.Element (CSN), Value);
         end if;
      end;
   end Set_Field;

   -----------------------
   -- Set_Header_Fields --
   -----------------------

   procedure Set_Header_Fields
     (Log    : Object;
      Data   : in out Fields_Table;
      Prefix : String;
      Header : AWS.Headers.List)
   is
      procedure Process (Name, Value : String);

      -------------
      -- Process --
      -------------

      procedure Process (Name, Value : String) is
      begin
         Set_Field
           (Log, Data, Prefix & '(' & Name & ')',
            AWS.Utils.Quote (Value, """"""));
      end Process;

   begin
      Header.Iterate_Names (", ", Process'Access);
   end Set_Header_Fields;

   -----------
   -- Start --
   -----------

   procedure Start
     (Log             : in out Object;
      Split           : Split_Mode := None;
      Size_Limit      : Natural    := 0;
      File_Directory  : String     := Not_Specified;
      Filename_Prefix : String     := Not_Specified;
      Auto_Flush      : Boolean    := False)
   is
      function Get_Prefix return String;
      --  Returns the prefix to use for the log filename

      function Log_Prefix (Prefix : String) return String;
      --  Returns the prefix to be added before the log filename. The returned
      --  value is the executable name without directory and filetype if Prefix
      --  is Not_Specified otherwise Prefix is returned.

      Now : constant Calendar.Time := Calendar.Clock;

      ----------------
      -- Get_Prefix --
      ----------------

      function Get_Prefix return String is
      begin
         if Split = None then
            return Utils.Normalized_Directory (File_Directory)
              & Log_Prefix (Filename_Prefix);
         else
            return Utils.Normalized_Directory (File_Directory)
              & Log_Prefix (Filename_Prefix) & '-'
              & GNAT.Calendar.Time_IO.Image (Now, "%Y-%m-%d");
         end if;
      end Get_Prefix;

      ----------------
      -- Log_Prefix --
      ----------------

      function Log_Prefix (Prefix : String) return String is

         function Prog_Name return String;
         --  Return current program name

         ---------------
         -- Prog_Name --
         ---------------

         function Prog_Name return String is
            Name  : constant String := Ada.Command_Line.Command_Name;
            First : Natural;
            Last  : Natural;
         begin
            First := Strings.Fixed.Index
              (Name, Strings.Maps.To_Set ("/\"), Going => Strings.Backward);

            if First = 0 then
               First := Name'First;
            else
               First := First + 1;
            end if;

            Last := Strings.Fixed.Index
              (Name (First .. Name'Last), ".", Strings.Backward);

            if Last = 0 then
               Last := Name'Last;
            else
               Last := Last - 1;
            end if;

            return Name (First .. Last);
         end Prog_Name;

      begin
         if Prefix = Not_Specified then
            return "";

         else
            declare
               K : constant Natural := Strings.Fixed.Index (Prefix, "@");
            begin
               if K = 0 then
                  return Prefix;
               else
                  return Prefix (Prefix'First .. K - 1)
                    & Prog_Name & Prefix (K + 1 .. Prefix'Last);
               end if;
            end;
         end if;
      end Log_Prefix;

      Prefix    : constant String := Get_Prefix;
      Filename  : Unbounded_String;
      Time_Part : String (1 .. 7);

   begin
      Log.Filename_Prefix      := To_Unbounded_String (Filename_Prefix);
      Log.File_Directory       := To_Unbounded_String (File_Directory);
      Log.Split                := Split;
      Log.Size_Limit           := Size_Limit;
      Log.Auto_Flush           := Auto_Flush;
      Log.Header_Written       := False;
      Log.Stop_Has_Been_Called := False;

      Filename := To_Unbounded_String (Prefix & ".log");

      case Split is
         when None =>
            null;

         when Each_Run =>
            if Directories.Exists (To_String (Filename)) then
               Time_Part := GNAT.Calendar.Time_IO.Image (Now, "-%H%M%S");

               Filename := To_Unbounded_String (Prefix & Time_Part & ".log");

               for K in 1 .. 99 loop
                  exit when not Directories.Exists (To_String (Filename));

                  Filename :=
                    To_Unbounded_String
                      (Prefix & Time_Part & '-' & Utils.Image (K) & ".log");
               end loop;
            end if;

         when Daily =>
            Log.Current_Tag := Ada.Calendar.Day (Now);

         when Monthly =>
            Log.Current_Tag := Ada.Calendar.Month (Now);
      end case;

      Text_IO.Open (Log.File, Text_IO.Append_File, To_String (Filename));

   exception
      when Text_IO.Name_Error =>
         Text_IO.Create (Log.File, Text_IO.Out_File, To_String (Filename));
   end Start;

   -----------
   -- Start --
   -----------

   procedure Start
     (Log    : in out Object;
      Writer : Callback;
      Name   : String) is
   begin
      Log.Writer               := Writer;
      Log.Writer_Name          := To_Unbounded_String (Name);
      Log.Header_Written       := False;
      Log.Stop_Has_Been_Called := False;
   end Start;

   ----------
   -- Stop --
   ----------

   procedure Stop (Log : in out Object) is
   begin
      if not Log.Stop_Has_Been_Called then
         if Log.Writer = null then
            if Text_IO.Is_Open (Log.File) then
               Write (Log, "Stop logging.");
               Text_IO.Close (Log.File);
            end if;
         else
            Log.Writer ("Stop logging.");
            Log.Writer := null;
         end if;
      end if;

      Log.Stop_Has_Been_Called := True;
   end Stop;

   -----------
   -- Write --
   -----------

   --  Here is the log format compatible with Apache:
   --
   --  127.0.0.1 - - [25/Apr/1998:15:37:29 +0200] "GET / HTTP/1.0" 200 1363
   --
   --  See http://httpd.apache.org/docs/trunk/logs.html

   procedure Write
     (Log          : in out Object;
      Connect_Stat : Status.Data;
      Answer       : Response.Data) is
   begin
      Write (Log, Connect_Stat,
             Response.Status_Code (Answer),
             Response.Content_Length (Answer));
   end Write;

   procedure Write
     (Log            : in out Object;
      Connect_Stat   : Status.Data;
      Status_Code    : Messages.Status_Code;
      Content_Length : Response.Content_Length_Type)
   is
      use type Response.Content_Length_Type;

      function Length_Image return String is
        (if Content_Length = Response.Undefined_Length
         then ""
         else Utils.Image (Content_Length)) with Inline;
   begin
      Write
        (Log, Connect_Stat, Messages.Image (Status_Code) & ' ' & Length_Image);
   end Write;

   procedure Write
     (Log          : in out Object;
      Connect_Stat : Status.Data;
      Data         : String)
   is
      Now : constant Calendar.Time := Calendar.Clock;

      function Authorization_Name return String with Inline;

      ------------------------
      -- Authorization_Name --
      ------------------------

      function Authorization_Name return String is
         Result : constant String := Status.Authorization_Name (Connect_Stat);
      begin
         if Result = "" then
            return "-";
         else
            return Result;
         end if;
      end Authorization_Name;

      Log_Message : constant String :=
                      AWS.Status.Peername (Connect_Stat)
                      & " - " & Authorization_Name
                      & " ["
                      & GNAT.Calendar.Time_IO.Image (Now, "%d/%b/%Y:%T")
                      & "] """
                      & Status.Method (Connect_Stat)
                      & ' '
                      & Status.URI (Connect_Stat) & " "
                      & Status.HTTP_Version (Connect_Stat) & """ "
                      & Data;

   begin
      if Log.Writer = null then
         Write_Log (Log, Now, Log_Message);
      else
         Log.Writer (Log_Message);
      end if;
   end Write;

   procedure Write (Log : in out Object; Data : String) is
      Now         : constant Calendar.Time := Calendar.Clock;
      Log_Message : constant String := "["
                      & GNAT.Calendar.Time_IO.Image
                        (Now, "%d/%b/%Y:%T") & "] " & Data;
   begin
      if Log.Writer = null then
         Write_Log (Log, Now, Log_Message);
      else
         Log.Writer (Log_Message);
      end if;
   end Write;

   --  Here is the extended log format:
   --
   --  #Version: 1.0
   --  #Date: 12-Jan-1996 00:00:00
   --  #Fields: time cs-method cs-uri
   --  00:34:23 GET /foo/bar.html

   procedure Write (Log : in out Object; Data : in out Fields_Table) is
   begin
      if Log.Writer = null then
         Write_File (Log, Data);
      else
         Write_Callback (Log, Data);
      end if;
   end Write;

   ----------------------
   --  Write_Callback  --
   ----------------------

   procedure Write_Callback
     (Log : in out Object; Data : in out Fields_Table)
   is
      use GNAT.Calendar.Time_IO;

      Length  : constant Natural := Natural (Log.Extended_Fields.Length);
      Message : Unbounded_String := Null_Unbounded_String;
      Now     : Ada.Calendar.Time;

      procedure Write_And_Clear (Position : SV.Cursor);

      ---------------------
      -- Write_And_Clear --
      ---------------------

      procedure Write_And_Clear (Position : SV.Cursor) is
      begin
         Utils.Append_With_Sep (Message, SV.Element (Position), Sep => " ");
         Data.Values.Replace_Element (Position, "-");
      end Write_And_Clear;

   begin
      if Length = 0 then
         --  It is not extended log
         return;
      end if;

      Now := Ada.Calendar.Clock;

      if not Log.Header_Written then
         Log.Header_Written := True;

         Log.Writer ("#Software: AWS (Ada Web Server) v" & Version);
         Log.Writer ("#Date: " & Image (Now, ISO_Date & " %T"));
         Log.Writer ("#Fields:");

         declare
            Fields : Unbounded_String := Null_Unbounded_String;
            Order  : array (1 .. Length) of Strings_Positive.Cursor;

            procedure Process (Position : Strings_Positive.Cursor);

            -------------
            -- Process --
            -------------

            procedure Process (Position : Strings_Positive.Cursor)
            is
            begin
               Order (Strings_Positive.Element (Position)) := Position;
            end Process;

         begin
            Log.Extended_Fields.Iterate (Process'Access);

            for J in Order'Range loop
               Append (Fields, ' ' & Strings_Positive.Key (Order (J)));
            end loop;

            Log.Writer (To_String (Fields));
         end;
      end if;

      --  Set date and time fields if the used does not fill it

      declare
         CSN : Strings_Positive.Cursor := Log.Extended_Fields.Find ("date");
         P   : Positive;
      begin
         if Strings_Positive.Has_Element (CSN) then
            P := Strings_Positive.Element (CSN);

            if Data.Values.Element (P) = "-" then
               Data.Values.Replace_Element (P, Image (Now, ISO_Date));
            end if;
         end if;

         CSN := Log.Extended_Fields.Find ("time");

         if Strings_Positive.Has_Element (CSN) then
            P := Strings_Positive.Element (CSN);

            if Data.Values.Element (P) = "-" then
               Data.Values.Replace_Element (P, Image (Now, "%T"));
            end if;
         end if;
      end;

      Data.Values.Iterate (Write_And_Clear'Access);
      Log.Writer (To_String (Message));
   end Write_Callback;

   ------------------
   --  Write_File  --
   ------------------

   procedure Write_File (Log : in out Object; Data : in out Fields_Table) is
      use GNAT.Calendar.Time_IO;

      Length      : constant Natural := Natural (Log.Extended_Fields.Length);
      Now         : Ada.Calendar.Time;
      First_Field : Boolean := True;

      procedure Write_And_Clear (Position : SV.Cursor);

      ---------------------
      -- Write_And_Clear --
      ---------------------

      procedure Write_And_Clear (Position : SV.Cursor) is
      begin
         if First_Field then
            First_Field := False;
            Text_IO.Put (Log.File, SV.Element (Position));
         else
            Text_IO.Put (Log.File, ' ' & SV.Element (Position));
         end if;

         Data.Values.Replace_Element (Position, "-");
      end Write_And_Clear;

   begin
      if Length = 0 then
         --  It is not extended log
         return;
      end if;

      Log.Semaphore.Seize;

      if Text_IO.Is_Open (Log.File) then
         Now := Ada.Calendar.Clock;

         Check_Split (Log, Now);

         if not Log.Header_Written then
            Log.Header_Written := True;

            Text_IO.Put_Line (Log.File, "#Version: 1.0");
            Text_IO.Put_Line
              (Log.File, "#Software: AWS (Ada Web Server) v" & Version);
            Text_IO.Put_Line
              (Log.File, "#Date: " & Image (Now, ISO_Date & " %T"));
            Text_IO.Put (Log.File, "#Fields:");

            declare
               Order : array (1 .. Length) of Strings_Positive.Cursor;

               procedure Process (Position : Strings_Positive.Cursor);

               -------------
               -- Process --
               -------------

               procedure Process (Position : Strings_Positive.Cursor) is
               begin
                  Order (Strings_Positive.Element (Position)) := Position;
               end Process;

            begin
               Log.Extended_Fields.Iterate (Process'Access);

               for J in Order'Range loop
                  Text_IO.Put
                    (Log.File, ' ' & Strings_Positive.Key (Order (J)));
               end loop;

               Text_IO.New_Line (Log.File);
            end;
         end if;

         --  Set date and time fields if the used does not fill it

         declare
            CSN : Strings_Positive.Cursor := Log.Extended_Fields.Find ("date");
            P   : Positive;
         begin
            if Strings_Positive.Has_Element (CSN) then
               P := Strings_Positive.Element (CSN);

               if Data.Values.Element (P) = "-" then
                  Data.Values.Replace_Element (P, Image (Now, ISO_Date));
               end if;
            end if;

            CSN := Log.Extended_Fields.Find ("time");

            if Strings_Positive.Has_Element (CSN) then
               P := Strings_Positive.Element (CSN);

               if Data.Values.Element (P) = "-" then
                  Data.Values.Replace_Element (P, Image (Now, "%T"));
               end if;
            end if;
         end;

         Data.Values.Iterate (Write_And_Clear'Access);

         Text_IO.New_Line (Log.File);

         if Log.Auto_Flush then
            Text_IO.Flush (Log.File);
         end if;
      end if;

      Log.Semaphore.Release;

   exception
      when others =>
         Log.Semaphore.Release;
         raise;
   end Write_File;

   ---------------
   -- Write_Log --
   ---------------

   procedure Write_Log
     (Log  : in out Object;
      Now  : Calendar.Time;
      Data : String) is
   begin
      Log.Semaphore.Seize;

      if Text_IO.Is_Open (Log.File) then

         Check_Split (Log, Now);

         Text_IO.Put_Line (Log.File, Data);

         if Log.Auto_Flush then
            Text_IO.Flush (Log.File);
         end if;
      end if;

      Log.Semaphore.Release;

   exception
      when others =>
         Log.Semaphore.Release;
         raise;
   end Write_Log;

end AWS.Log;