File : adagio-security.adb


------------------------------------------------------------------------------

--                         ADAGIO - ADALID - AENEA.                         --

--                                                                          --

--                            Copyright (C) 2003                            --

--                                 A. Mosteo.                               --

--                                                                          --

--  Authors: A. Mosteo. (adagio@mosteo.com)                                 --

--                                                                          --

--  If you have any questions in regard to this software, please address    --

--  them to the above email.                                                --

--                                                                          --

--  This program 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 program 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.          --

--                                                                          --

--  You are not allowed to use any part of this code to develop a program   --

--  whose output would be used to harass or prosecute other users of the    --

--  networks Adagio connects with. All data collected with Adagio or a tool --

--  containing Adagio code about other network users must remain            --

--  confidential and cannot be made public by any mean, nor be used to      --

--  harass or legally prosecute these users.                                --

------------------------------------------------------------------------------

--  $Id: adagio-security.adb,v 1.4 2004/02/29 20:36:45 Jano Exp $


with Adagio.Globals.Options;
with Adagio.Misc;
with Adagio.Socket.Ip;
with Adagio.Trace;
with Binary_tree;
with Bit_arrays;
with Bit_arrays.Modular;
with Agpl.Dynamic_vector; use Agpl;

with Charles.Hash_string;
with Charles.Maps.Hashed.Strings.Unbounded;

with Strings.Fields;

with Gnat.Regexp;
with Gnat.Sockets;
use  Gnat;

package body Adagio.Security is

   use type Bit_arrays.Bit_array;

   ------------------------------------------------------------------------

   -- Binary addresses types                                             --

   ------------------------------------------------------------------------

   use type Ip_address.Family_type;

   type Byte is mod 2 ** 8;
   type Byte_array is array (Positive range <>) of Byte;

   package Byte_to_bit is new Bit_arrays.Modular (Byte);

   type Binary_address (Family : Ip_address.Family_type) is record
      Data : Byte_array (1 .. 16) := (others => 0);
   end record;

   type UABan is record
      Kind    : User_agent_ban_type;
      Pattern : Ustring;
      Regexp  : Gnat.Regexp.Regexp;
   end record;

   package UABan_list is new Dynamic_vector (UABan);
   use UABan_list;

   UABans : UABan_list.Object (First => 1);

   package Maps is new Charles.Maps.Hashed.Strings.Unbounded (
      Boolean, Charles.Hash_string, "=", "=");

   Country_bans : Maps.Container_type;
   use Maps;

   ------------------------------------------------------------------------

   -- Tree things                                                        --

   ------------------------------------------------------------------------

   type Node_data is record
      Mask_end : Boolean;
   end record;

   package Mask_trees is new Binary_tree (Node_data);

   Mask_tree : Mask_trees.Tree := 
      Mask_trees.Add_child (null, Mask_trees.Left, (Mask_end => false));

   Side_chooser : array (Boolean) of Mask_trees.Sides := 
      (false => Mask_trees.Left, true => Mask_trees.Right);

   ------------------

   -- To_bit_array --

   ------------------

   Dummy : Bit_arrays.Bit_array (1 .. 0);
   function To_bit_array (This : Binary_address) return Bit_arrays.Bit_array
   is
   begin
      case This.Family is
         when Sockets.Family_inet =>
            return 
               Byte_to_bit.To_bit_array_BE (This.Data (1)) &
               Byte_to_bit.To_bit_array_BE (This.Data (2)) &
               Byte_to_bit.To_bit_array_BE (This.Data (3)) &
               Byte_to_bit.To_bit_array_BE (This.Data (4));
         when others =>
            raise Unimplemented;
            return Dummy;
      end case;
   end To_bit_array;

   ---------------------

   -- Add_ban_to_tree --

   ---------------------

   procedure Add_ban_to_tree (
      This : in out Mask_trees.Tree; Addr, Mask : in Binary_address) 
   is
      use Bit_arrays;
      BA   : Bit_array := To_bit_array (Addr);
      MA   : Bit_array := To_bit_array (Mask);
      Pos  : Mask_trees.Node_access := This;
      Next : Mask_trees.Node_access;
      Side : Mask_trees.Sides;
      use Mask_trees;
   begin
      if BA'First /= MA'First then 
         raise Constraint_error;
      end if;
      for N in MA'Range loop
         exit when not MA (N);
         -- Earlier mask:

         if Get_data (Pos).Mask_end then
            return;
         end if;
         Side := Side_chooser (BA (N));
         Next := Get_child (Pos, Side);
         if Next = null then
            Next := Add_child (Pos, Side, (Mask_end => false));
         end if;
         Pos := Next;
      end loop;
      Set_data (Pos, (Mask_end => true));
   end Add_ban_to_tree;

   ---------------

   -- Is_banned --

   ---------------

   function Is_banned (This : in Mask_trees.Tree; Addr : in Binary_address)
      return Boolean
   is
      use Bit_arrays;
      use Mask_trees;
      BA   : Bit_array := To_bit_array (Addr);
      Pos  : Mask_trees.Node_access := This;
      Next : Mask_trees.Node_access;
   begin
      for N in BA'Range loop
         -- End of some mask, ban:

         if Get_data (Pos).Mask_end then
            return true;
         end if;
         Next := Get_child (Pos, Side_chooser (BA (N)));
         -- No way, no ban:

         if Next = null then
            return not Globals.Options.Security_policy_allow;
         end if;
         Pos := Next;
      end loop;
      -- All the way, ban:

      return Get_data (Pos).Mask_end;
   end Is_banned;

   ----------

   -- Mask --

   ----------

   function Mask (L, R : in Binary_address) return Binary_address is
      Result : Binary_address (L.Family);
      Last : array (Ip_address.Family_type) of Natural :=
         (Sockets.Family_inet => 4, Sockets.Family_inet6 => 16);
   begin
      if L.Family /= R.Family then
         raise Constraint_error;
      else
         for N in 1 .. Last (L.Family) loop
            Result.Data (N) := L.Data (N) and R.Data (N);
         end loop;
         return Result;
      end if;
   end Mask;

   -----------------------

   -- To_binary_address --

   -----------------------

   function To_binary_address (This : in Ip_address.Inet_addr_type)
      return Binary_address is
      Addr : Binary_address (This.Family);
      Img  : String := Sockets.Image  (This);
      use Strings.Fields;
      Sep  : Character;
      Last : Natural;
   begin
      case This.Family is
         when Sockets.Family_inet =>
            Sep  := '.';
            Last := 4;
         when Sockets.Family_inet6 =>
            Sep  := ':';
            Last := 16;
      end case;

      for N in 1 .. Last loop
         Addr.Data (N) := Byte'Value (Select_field (Img, N, Sep));
      end loop;

      return Addr;
   end To_binary_address;

   -----------------------

   -- To_binary_address --

   -----------------------

   -- Dotted address/mask

   function To_binary_address (This : in String) return Binary_address is
      Last : Natural;
      Addr : Binary_address (Sockets.Family_inet);
      Sep  : Character := '.';
      use Strings.Fields;
   begin
      if Misc.Contains (This, ".") then
         Last := 4;
         Sep  := '.';
      else
         raise Unimplemented;
      end if;

      for N in 1 .. Last loop
         Addr.Data (N) := Byte'Value (Select_field (This, N, Sep));
      end loop;

      return Addr;
   end To_binary_address;


   -----------

   -- Image --

   -----------

   function Image (This : in Binary_address) return String is
      Result : Ustring;
   begin
      case This.Family is
         when Sockets.Family_inet =>
            for N in 1 .. 4 loop
               Result := Result &
                  U (Misc.To_string (Natural (This.Data (N))));
               if N /= 4 then
                  Result := Result & '.';
               end if;
            end loop;
         when others =>
            raise Unimplemented;
      end case;
      return S (Result);
   end Image;

   ------------------

   -- Add_ban_rule --

   ------------------

   -- Dotted format

   procedure Add_ban_rule (Address : in String; Mask : in String) is
      A, M : Binary_address (Sockets.Family_inet);
   begin
      A := To_binary_address (Address);
      M := To_binary_address (Mask);
      if A /= Security.Mask (A, M) then
         Trace.Log ("Security.Add_ban_rule: Correcting incorrect range for" &
            " rule " & Mask & "/" & Address, Trace.Warning);
         A := Security.Mask (A, M);
      end if;
      Add_ban_to_tree (Mask_tree, A, M);
   end Add_ban_rule;

   ----------------

   -- Is_allowed --

   ----------------

   function Is_allowed (Address : in Ip_address.Inet_addr_type)
      return Boolean is
   begin
      return not Is_banned (Address);
   end Is_allowed;

   ---------------

   -- Is_banned --

   ---------------

   function Is_banned (Address : in Ip_address.Inet_addr_type)
      return Boolean 
   is
      Addr   : Binary_address := To_binary_address (Address);
      Img    : String         := Sockets.Image     (Address);
      Banned : Boolean;
   begin
      if Socket.Ip.Is_public (Img) and then
         Is_country_banned (Agpl.Geoip.Country_code_from_addr (Img)) 
      then
         return true;
      else
         Banned := Is_banned (Mask_tree, Addr);
         if Banned then
            Trace.Log ("Adagio.Security.Is_banned: IP ban detected", 
               Trace.Debug);
         end if;
         return Banned;
      end if;
   end;

   -------------------

   -- Add_ban_agent --

   -------------------

   procedure Add_ban_agent (
      Agent : in String; Kind : in User_agent_ban_type) is
      Rule : UABan;
   begin
      Rule.Kind    := Kind;
      Rule.Pattern := U (Misc.To_lower (Agent));
      Rule.Regexp  := Gnat.Regexp.Compile ("1*");
      begin
         if Kind = Regexp then
            Rule.Regexp :=
               Gnat.Regexp.Compile (
                  Agent,
                  Glob => true,
                  Case_sensitive => false);
         end if;
      exception
         when Gnat.Regexp.Error_in_regexp =>
            raise Syntax_error;
      end;

      Append (UABans, Rule);
      Trace.Log ("Added User-Agent ban: " & Rule.Kind'Img & "; " &
         S (Rule.Pattern));

   end Add_ban_agent;

   ---------------

   -- Is_banned --

   ---------------

   function Is_banned (Agent : in String) return Boolean is
   begin
      for N in 1 .. Last (UABans) loop
         declare
            Rule : UABan renames UABans.Vector (N);
         begin
            case Rule.Kind is
               when Regexp =>
                  if Gnat.Regexp.Match (Agent, Rule.Regexp) then
                     Trace.Log (
                        "Adagio.Security.Is_banned: Regexp Agent ban detected" &
                        " for " & Agent, Trace.Debug);
                     return true;
                  end if;
               when Substring =>
                  if Misc.Contains (Misc.To_lower (Agent), S (Rule.Pattern))
                  then
                     Trace.Log (
                        "Adagio.Security.Is_banned: Substr Agent ban detected" &
                        " for " & Agent, Trace.Debug);
                     return true;
                  end if;
            end case;
         end;
      end loop;

      return false;
   end Is_banned;

   ---------------------

   -- Add_country_ban --

   ---------------------

   procedure Add_country_ban (
      Country : in Agpl.Geoip.Country_code; Allow : in Boolean := false)
   is
      Pass : constant array (Boolean) of String (1 .. 7) := 
         (true => "allowed", false => "denied ");
   begin
      Insert (Country_bans, Misc.To_lower (Country), Allow);
      Trace.Log ("Adding country rule for " &
         Misc.To_upper (Country) & ": pass is " & Pass (Allow), 
         Trace.Informative);
   end Add_country_ban;

   -----------------------

   -- Is_country_banned --

   -----------------------

   function Is_country_banned (
      Country : in Agpl.Geoip.Country_code) return Boolean 
   is
      I : Iterator_type := Find (Country_bans, Misc.To_lower (Country));
   begin
      if I /= Back (Country_bans) then
         if not Element (I) then
            Trace.Log (
               "Adagio.Security.Is_banned: Country ban detected" &
               " for " & Country, Trace.Debug);
         else
            Trace.Log (
               "Adagio.Security.Is_banned: Country pass detected" &
               " for " & Country, Trace.Debug);
         end if;
         return not Element (I);
      else
         if not Globals.Options.Security_policy_allow then
            Trace.Log (
               "Adagio.Security.Is_banned: General policy applied (deny)" &
               " for " & Country, Trace.Debug);
         end if;
         return not Globals.Options.Security_policy_allow;
      end if;
   end Is_country_banned;

end Adagio.Security;