--  This file is covered by the Internet Software Consortium (ISC) License
--  Reference: ../License.txt

with File_Operations;
with PortScan.Log;
with Parameters;
with Unix;
with Ada.Characters.Latin_1;
with Ada.Directories;
with Ada.Exceptions;

package body PortScan.Tests is

   package FOP renames File_Operations;
   package LOG renames PortScan.Log;
   package PM  renames Parameters;
   package LAT renames Ada.Characters.Latin_1;
   package DIR renames Ada.Directories;
   package EX  renames Ada.Exceptions;

   --------------------------------------------------------------------------------------------
   --  exec_phase_check_plist
   --------------------------------------------------------------------------------------------
   function exec_check_plist
     (specification : PSP.Portspecs;
      log_handle    : TIO.File_Type;
      phase_name    : String;
      seq_id        : port_id;
      rootdir       : String) return Boolean
   is
      passed_check : Boolean := True;
      namebase     : constant String := specification.get_namebase;
      directory_list : entry_crate.Map;
      dossier_list   : entry_crate.Map;
   begin
      LOG.log_phase_begin (log_handle, phase_name);
      TIO.Put_Line (log_handle, "====> Checking for package manifest issues");

      if not ingest_manifests (specification  => specification,
                               log_handle     => log_handle,
                               directory_list => directory_list,
                               dossier_list   => dossier_list,
                               seq_id         => seq_id,
                               namebase       => namebase,
                               rootdir        => rootdir)
      then
         passed_check := False;
      end if;

      if orphaned_directories_detected (log_handle     => log_handle,
                                        directory_list => directory_list,
                                        namebase       => namebase,
                                        rootdir        => rootdir)
      then
         passed_check := False;
      end if;

      if missing_directories_detected (log_handle, directory_list) then
         passed_check := False;
      end if;

      if orphaned_files_detected (log_handle, dossier_list, namebase, rootdir) then
         passed_check := False;
      end if;

      if missing_files_detected (log_handle, dossier_list) then
         passed_check := False;
      end if;

      if passed_check then
         TIO.Put_Line (log_handle, "====> No manifest issues found");
      end if;

      LOG.log_phase_end (log_handle);
      return passed_check;
   end exec_check_plist;

   --------------------------------------------------------------------------------------------
   --  ingest_manifests
   --------------------------------------------------------------------------------------------
   function ingest_manifests
     (specification  : PSP.Portspecs;
      log_handle     : TIO.File_Type;
      directory_list : in out entry_crate.Map;
      dossier_list   : in out entry_crate.Map;
      seq_id         : port_id;
      namebase       : String;
      rootdir        : String) return Boolean
   is
      procedure eat_plist (position : subpackage_crate.Cursor);
      procedure insert_directory (directory : String; subpackage : HT.Text);

      result   : Boolean := True;

      procedure insert_directory (directory : String; subpackage : HT.Text)
      is
         numsep : Natural := HT.count_char (directory, LAT.Solidus);
         canvas : HT.Text := HT.SUS (directory);
      begin
         for x in 1 .. numsep + 1 loop
            declare
               paint      : String := HT.USS (canvas);
               my_new_rec : entry_record := (subpackage, False);
            begin
               if paint /= "" then
                  if not directory_list.Contains (canvas) then
                     directory_list.Insert (canvas, my_new_rec);
                  end if;
                  canvas := HT.SUS (HT.head (paint, "/"));
               end if;
            end;
         end loop;
      end insert_directory;

      procedure eat_plist (position : subpackage_crate.Cursor)
      is
         subpackage    : HT.Text := subpackage_crate.Element (position).subpackage;
         manifest_file : String := "/construction/" & namebase & "/.manifest." &
                         HT.USS (subpackage) & ".mktmp";
         contents      : String := FOP.get_file_contents (rootdir & manifest_file);
         identifier    : constant String := HT.USS (subpackage) & " manifest: ";

         markers : HT.Line_Markers;
      begin
         HT.initialize_markers (contents, markers);
         loop
            exit when not HT.next_line_present (contents, markers);
            declare
               line      : constant String := HT.extract_line (contents, markers);
               line_text : HT.Text := HT.SUS (line);
               new_rec   : entry_record := (subpackage, False);
            begin
               if HT.leads (line, "@comment ") then
                  null;
               elsif HT.leads (line, "@terminfo") then
                  null;
               elsif HT.leads (line, "@dir ") then
                  declare
                     dir      : String := line (line'First + 5 .. line'Last);
                     dir_text : HT.Text := HT.SUS (dir);
                  begin
                     if directory_list.Contains (dir_text) then
                        result := False;
                        declare
                           spkg : String := HT.USS (directory_list.Element (dir_text).subpackage);
                        begin
                           if spkg /= "" then
                              TIO.Put_Line
                                (log_handle,
                                 "Redundant @dir symbol, " & identifier & dir &
                                   " will already be created by the " & spkg & " manifest");
                           else
                              TIO.Put_Line
                                (log_handle,
                                 "Redundant @dir symbol, " & identifier & dir &
                                   " will already be created by another manifest");
                           end if;
                        end;
                     else
                        insert_directory (dir, subpackage);
                     end if;
                  end;
               else
                  declare
                     modline : String  := modify_file_if_necessary (line);
                     ml_text : HT.Text := HT.SUS (modline);
                  begin
                     if dossier_list.Contains (ml_text) then
                        result := False;
                        declare
                           spkg : String := HT.USS (dossier_list.Element (ml_text).subpackage);
                        begin
                           TIO.Put_Line
                             (log_handle,
                              "Duplicate file entry, " & identifier & modline &
                                " already present in " & spkg & " manifest");
                        end;
                     else
                        dossier_list.Insert (ml_text, new_rec);
                        declare
                           plistdir : String := DIR.Containing_Directory (modline);
                        begin
                           insert_directory (plistdir, subpackage);
                        end;
                     end if;
                  end;
               end if;
            end;
         end loop;
      exception
         when issue : others =>
            TIO.Put_Line (log_handle, "check-plist error: " & EX.Exception_Message (issue));
      end eat_plist;
   begin
      all_ports (seq_id).subpackages.Iterate (eat_plist'Access);
      return result;
   end ingest_manifests;

   --------------------------------------------------------------------------------------------
   --  directory_excluded
   --------------------------------------------------------------------------------------------
   function directory_excluded (candidate : String) return Boolean
   is
      --  mandatory candidate has ${STAGEDIR}/ stripped (no leading slash)
      rawlbase  : constant String  := HT.USS (PM.configuration.dir_localbase);
      localbase : constant String  := rawlbase (rawlbase'First + 1 .. rawlbase'Last);
      lblen     : constant Natural := localbase'Length;
   begin
      if candidate = localbase then
         return True;
      end if;
      if not HT.leads (candidate, localbase & "/") then
         --  This should never happen
         return False;
      end if;

      declare
         shortcan : String := candidate (candidate'First + lblen + 1 .. candidate'Last);
      begin
         if shortcan = "bin" or else
           shortcan = "etc" or else
           shortcan = "etc/rc.d" or else
           shortcan = "include" or else
           shortcan = "lib" or else
           shortcan = "lib/pkgconfig" or else
           shortcan = "libdata" or else
           shortcan = "libexec" or else
           shortcan = "sbin" or else
           shortcan = "share" or else
           shortcan = "www"
         then
            return True;
         end if;
         if not HT.leads (shortcan, "share/") then
            return False;
         end if;
      end;

      declare
         shortcan : String := candidate (candidate'First + lblen + 7 .. candidate'Last);
      begin
         if shortcan = "doc" or else
           shortcan = "examples" or else
           shortcan = "info" or else
           shortcan = "locale" or else
           shortcan = "man" or else
           shortcan = "nls"
         then
            return True;
         end if;
         if shortcan'Length /= 8 or else
           not HT.leads (shortcan, "man/man")
         then
            return False;
         end if;
         case shortcan (shortcan'Last) is
            when '1' .. '9' | 'l' | 'n' => return True;
            when others => return False;
         end case;
      end;
   end directory_excluded;

   --------------------------------------------------------------------------------------------
   --  orphaned_directories_detected
   --------------------------------------------------------------------------------------------
   function orphaned_directories_detected
     (log_handle     : TIO.File_Type;
      directory_list : in out entry_crate.Map;
      namebase       : String;
      rootdir        : String) return Boolean
   is
      rawlbase  : constant String  := HT.USS (PM.configuration.dir_localbase);
      localbase : constant String  := rawlbase (rawlbase'First + 1 .. rawlbase'Last);
      stagedir  : String := rootdir & "/construction/" & namebase & "/stage";
      command   : String := rootdir & "/usr/bin/find " & stagedir & " -type d -printf " &
                  LAT.Quotation & "%P\n" & LAT.Quotation;
      status    : Integer;
      comres    : String := HT.USS (Unix.piped_command (command, status));
      markers   : HT.Line_Markers;
      lblen     : constant Natural := localbase'Length;
      result    : Boolean := False;
      errprefix : constant String := "Orphaned directory detected: ";
   begin
      if status /= 0 then
         TIO.Put_Line ("orphaned_directories_detected: command error: " & comres);
         return True;
      end if;
      HT.initialize_markers (comres, markers);
      loop
         exit when not HT.next_line_present (comres, markers);
         declare
            line      : constant String := HT.extract_line (comres, markers);
            line_text : HT.Text := HT.SUS (line);
         begin
            if line /= "" then
               if HT.leads (line, localbase) then
                  declare
                     plist_dir : HT.Text := HT.SUS (line (line'First + lblen + 1 .. line'Last));
                  begin
                     if directory_list.Contains (plist_dir) then
                        directory_list.Update_Element (Position => directory_list.Find (plist_dir),
                                                       Process  => mark_verified'Access);
                     else
                        if not directory_excluded (line) then
                           TIO.Put_Line (log_handle, errprefix & line);
                           result := True;
                        end if;
                     end if;
                  end;
               else
                  if directory_list.Contains (line_text) then
                     directory_list.Update_Element (Position => directory_list.Find (line_text),
                                                    Process  => mark_verified'Access);
                  else
                     TIO.Put_Line (log_handle, errprefix & line);
                     result := True;
                  end if;
               end if;
            end if;
         end;
      end loop;
      return result;
   end orphaned_directories_detected;

   --------------------------------------------------------------------------------------------
   --  mark_verified
   --------------------------------------------------------------------------------------------
   procedure mark_verified (key : HT.Text; Element : in out entry_record) is
   begin
      Element.verified := True;
   end mark_verified;

   --------------------------------------------------------------------------------------------
   --  missing_directories_detected
   --------------------------------------------------------------------------------------------
   function missing_directories_detected
     (log_handle     : TIO.File_Type;
      directory_list : in out entry_crate.Map) return Boolean
   is
      procedure check (position : entry_crate.Cursor);

      result : Boolean := False;

      procedure check (position : entry_crate.Cursor)
      is
         rec       : entry_record renames entry_crate.Element (position);
         plist_dir : String := HT.USS (entry_crate.Key (position));
      begin
         if not rec.verified then
            TIO.Put_Line
              (log_handle,
               "Directory " & plist_dir & " listed on " & HT.USS (rec.subpackage) &
                 " manifest is not present in the stage directory.");
            result := True;
         end if;
      end check;
   begin
      directory_list.Iterate (check'Access);
      return result;
   end missing_directories_detected;

   --------------------------------------------------------------------------------------------
   --  missing_files_detected
   --------------------------------------------------------------------------------------------
   function missing_files_detected
     (log_handle   : TIO.File_Type;
      dossier_list : in out entry_crate.Map) return Boolean
   is
      procedure check (position : entry_crate.Cursor);

      result : Boolean := False;

      procedure check (position : entry_crate.Cursor)
      is
         rec        : entry_record renames entry_crate.Element (position);
         plist_file : String := HT.USS (entry_crate.Key (position));
      begin
         if not rec.verified then
            TIO.Put_Line
              (log_handle,
               "File " & plist_file & " listed on " & HT.USS (rec.subpackage) &
                 " manifest is not present in the stage directory.");
            result := True;
         end if;
      end check;
   begin
      dossier_list.Iterate (check'Access);
      return result;
   end missing_files_detected;

   --------------------------------------------------------------------------------------------
   --  orphaned_files_detected
   --------------------------------------------------------------------------------------------
   function orphaned_files_detected
     (log_handle     : TIO.File_Type;
      dossier_list   : in out entry_crate.Map;
      namebase       : String;
      rootdir        : String) return Boolean
   is
      rawlbase  : constant String  := HT.USS (PM.configuration.dir_localbase);
      localbase : constant String  := rawlbase (rawlbase'First + 1 .. rawlbase'Last);
      stagedir  : String := rootdir & "/construction/" & namebase & "/stage";
      command   : String := rootdir & "/usr/bin/find " & stagedir &
                  " \( -type f -o -type l \) -printf " &
                  LAT.Quotation & "%P\n" & LAT.Quotation;
      status    : Integer;
      comres    : String := HT.USS (Unix.piped_command (command, status));
      markers   : HT.Line_Markers;
      lblen     : constant Natural := localbase'Length;
      result    : Boolean := False;
      errprefix : constant String := "Orphaned file detected: ";
   begin
      if status /= 0 then
         TIO.Put_Line ("orphaned_files_detected: command error: " & comres);
         return True;
      end if;
      HT.initialize_markers (comres, markers);
      loop
         exit when not HT.next_line_present (comres, markers);
         declare
            line      : constant String := HT.extract_line (comres, markers);
            line_text : HT.Text := HT.SUS (line);
         begin
            if line /= "" then
               if HT.leads (line, localbase) then
                  declare
                     plist_file : HT.Text := HT.SUS (line (line'First + lblen + 1 .. line'Last));
                  begin
                     if dossier_list.Contains (plist_file) then
                        dossier_list.Update_Element (Position => dossier_list.Find (plist_file),
                                                     Process  => mark_verified'Access);
                     else
                        TIO.Put_Line (log_handle, errprefix & line);
                        result := True;
                     end if;
                  end;
               else
                  if dossier_list.Contains (line_text) then
                     dossier_list.Update_Element (Position => dossier_list.Find (line_text),
                                                  Process  => mark_verified'Access);
                  else
                     TIO.Put_Line (log_handle, errprefix & line);
                     result := True;
                  end if;
               end if;
            end if;
         end;
      end loop;
      return result;
   end orphaned_files_detected;

   --------------------------------------------------------------------------------------------
   --  modify_file_if_necessary
   --------------------------------------------------------------------------------------------
   function modify_file_if_necessary (original : String) return String
   is
      function strip_raw_localbase (wrkstr : String) return String;
      function strip_raw_localbase (wrkstr : String) return String
      is
         rawlbase : constant String  := HT.USS (PM.configuration.dir_localbase) & "/";
      begin
         if HT.leads (wrkstr, rawlbase) then
            return wrkstr (wrkstr'First + rawlbase'Length .. wrkstr'Last);
         else
            return wrkstr;
         end if;
      end strip_raw_localbase;
   begin
      if HT.leads (original, "@info ") then
         return strip_raw_localbase (original (original'First + 6 .. original 'Last));
      else
         return original;
      end if;
   end modify_file_if_necessary;

end PortScan.Tests;

--  This file is covered by the Internet Software Consortium (ISC) License
--  Reference: ../License.txt

with File_Operations;
with PortScan.Log;
with Parameters;
with Unix;
with Ada.Characters.Latin_1;
with Ada.Directories;
with Ada.Exceptions;

package body PortScan.Tests is

   package FOP renames File_Operations;
   package LOG renames PortScan.Log;
   package PM  renames Parameters;
   package LAT renames Ada.Characters.Latin_1;
   package DIR renames Ada.Directories;
   package EX  renames Ada.Exceptions;

   --------------------------------------------------------------------------------------------
   --  exec_phase_check_plist
   --------------------------------------------------------------------------------------------
   function exec_check_plist
     (specification : PSP.Portspecs;
      log_handle    : TIO.File_Type;
      phase_name    : String;
      seq_id        : port_id;
      rootdir       : String) return Boolean
   is
      passed_check : Boolean := True;
      namebase     : constant String := specification.get_namebase;
      directory_list : entry_crate.Map;
      dossier_list   : entry_crate.Map;
   begin
      LOG.log_phase_begin (log_handle, phase_name);
      TIO.Put_Line (log_handle, "====> Checking for package manifest issues");

      if not ingest_manifests (specification  => specification,
                               log_handle     => log_handle,
                               directory_list => directory_list,
                               dossier_list   => dossier_list,
                               seq_id         => seq_id,
                               namebase       => namebase,
                               rootdir        => rootdir)
      then
         passed_check := False;
      end if;

      if orphaned_directories_detected (log_handle     => log_handle,
                                        directory_list => directory_list,
                                        namebase       => namebase,
                                        rootdir        => rootdir)
      then
         passed_check := False;
      end if;

      if missing_directories_detected (log_handle, directory_list) then
         passed_check := False;
      end if;

      if orphaned_files_detected (log_handle, dossier_list, namebase, rootdir) then
         passed_check := False;
      end if;

      if missing_files_detected (log_handle, dossier_list) then
         passed_check := False;
      end if;

      if passed_check then
         TIO.Put_Line (log_handle, "====> No manifest issues found");
      end if;

      LOG.log_phase_end (log_handle);
      return passed_check;
   end exec_check_plist;

   --------------------------------------------------------------------------------------------
   --  ingest_manifests
   --------------------------------------------------------------------------------------------
   function ingest_manifests
     (specification  : PSP.Portspecs;
      log_handle     : TIO.File_Type;
      directory_list : in out entry_crate.Map;
      dossier_list   : in out entry_crate.Map;
      seq_id         : port_id;
      namebase       : String;
      rootdir        : String) return Boolean
   is
      procedure eat_plist (position : subpackage_crate.Cursor);
      procedure insert_directory (directory : String; subpackage : HT.Text);

      result   : Boolean := True;

      procedure insert_directory (directory : String; subpackage : HT.Text)
      is
         numsep : Natural := HT.count_char (directory, LAT.Solidus);
         canvas : HT.Text := HT.SUS (directory);
      begin
         for x in 1 .. numsep + 1 loop
            declare
               paint      : String := HT.USS (canvas);
               my_new_rec : entry_record := (subpackage, False);
            begin
               if paint /= "" then
                  if not directory_list.Contains (canvas) then
                     directory_list.Insert (canvas, my_new_rec);
                  end if;
                  canvas := HT.SUS (HT.head (paint, "/"));
               end if;
            end;
         end loop;
      end insert_directory;

      procedure eat_plist (position : subpackage_crate.Cursor)
      is
         subpackage    : HT.Text := subpackage_crate.Element (position).subpackage;
         manifest_file : String := "/construction/" & namebase & "/.manifest." &
                         HT.USS (subpackage) & ".mktmp";
         contents      : String := FOP.get_file_contents (rootdir & manifest_file);
         identifier    : constant String := HT.USS (subpackage) & " manifest: ";

         markers : HT.Line_Markers;
      begin
         HT.initialize_markers (contents, markers);
         loop
            exit when not HT.next_line_present (contents, markers);
            declare
               line      : constant String := HT.extract_line (contents, markers);
               line_text : HT.Text := HT.SUS (line);
               new_rec   : entry_record := (subpackage, False);
            begin
               if HT.leads (line, "@comment ") then
                  null;
               elsif HT.leads (line, "@terminfo") then
                  null;
               elsif HT.leads (line, "@dir ") then
                  declare
                     dir      : String := line (line'First + 5 .. line'Last);
                     dir_text : HT.Text := HT.SUS (dir);
                  begin
                     if directory_list.Contains (dir_text) then
                        result := False;
                        declare
                           spkg : String := HT.USS (directory_list.Element (dir_text).subpackage);
                        begin
                           if spkg /= "" then
                              TIO.Put_Line
                                (log_handle,
                                 "Redundant @dir symbol, " & identifier & dir &
                                   " will already be created by the " & spkg & " manifest");
                           else
                              TIO.Put_Line
                                (log_handle,
                                 "Redundant @dir symbol, " & identifier & dir &
                                   " will already be created by another manifest");
                           end if;
                        end;
                     else
                        insert_directory (dir, subpackage);
                     end if;
                  end;
               else
                  declare
                     modline : String  := modify_file_if_necessary (line);
                     ml_text : HT.Text := HT.SUS (modline);
                  begin
                     if dossier_list.Contains (ml_text) then
                        result := False;
                        declare
                           spkg : String := HT.USS (dossier_list.Element (ml_text).subpackage);
                        begin
                           TIO.Put_Line
                             (log_handle,
                              "Duplicate file entry, " & identifier & modline &
                                " already present in " & spkg & " manifest");
                        end;
                     else
                        dossier_list.Insert (ml_text, new_rec);
                        declare
                           plistdir : String := DIR.Containing_Directory (modline);
                        begin
                           insert_directory (plistdir, subpackage);
                        end;
                     end if;
                  end;
               end if;
            end;
         end loop;
      exception
         when issue : others =>
            TIO.Put_Line (log_handle, "check-plist error: " & EX.Exception_Message (issue));
      end eat_plist;
   begin
      all_ports (seq_id).subpackages.Iterate (eat_plist'Access);
      return result;
   end ingest_manifests;

   --------------------------------------------------------------------------------------------
   --  directory_excluded
   --------------------------------------------------------------------------------------------
   function directory_excluded (candidate : String) return Boolean
   is
      --  mandatory candidate has ${STAGEDIR}/ stripped (no leading slash)
      rawlbase  : constant String  := HT.USS (PM.configuration.dir_localbase);
      localbase : constant String  := rawlbase (rawlbase'First + 1 .. rawlbase'Last);
      lblen     : constant Natural := localbase'Length;
   begin
      if candidate = localbase then
         return True;
      end if;
      if not HT.leads (candidate, localbase & "/") then
         --  This should never happen
         return False;
      end if;

      declare
         shortcan : String := candidate (candidate'First + lblen + 1 .. candidate'Last);
      begin
         if shortcan = "bin" or else
           shortcan = "etc" or else
           shortcan = "etc/rc.d" or else
           shortcan = "include" or else
           shortcan = "lib" or else
           shortcan = "lib/pkgconfig" or else
           shortcan = "libdata" or else
           shortcan = "libexec" or else
           shortcan = "sbin" or else
           shortcan = "share" or else
           shortcan = "www"
         then
            return True;
         end if;
         if not HT.leads (shortcan, "share/") then
            return False;
         end if;
      end;

      declare
         shortcan : String := candidate (candidate'First + lblen + 7 .. candidate'Last);
      begin
         if shortcan = "doc" or else
           shortcan = "examples" or else
           shortcan = "info" or else
           shortcan = "locale" or else
           shortcan = "man" or else
           shortcan = "nls"
         then
            return True;
         end if;
         if shortcan'Length /= 8 or else
           not HT.leads (shortcan, "man/man")
         then
            return False;
         end if;
         case shortcan (shortcan'Last) is
            when '1' .. '9' | 'l' | 'n' => return True;
            when others => return False;
         end case;
      end;
   end directory_excluded;

   --------------------------------------------------------------------------------------------
   --  orphaned_directories_detected
   --------------------------------------------------------------------------------------------
   function orphaned_directories_detected
     (log_handle     : TIO.File_Type;
      directory_list : in out entry_crate.Map;
      namebase       : String;
      rootdir        : String) return Boolean
   is
      rawlbase  : constant String  := HT.USS (PM.configuration.dir_localbase);
      localbase : constant String  := rawlbase (rawlbase'First + 1 .. rawlbase'Last);
      stagedir  : String := rootdir & "/construction/" & namebase & "/stage";
      command   : String := rootdir & "/usr/bin/find " & stagedir & " -type d -printf " &
                  LAT.Quotation & "%P\n" & LAT.Quotation;
      status    : Integer;
      comres    : String := HT.USS (Unix.piped_command (command, status));
      markers   : HT.Line_Markers;
      lblen     : constant Natural := localbase'Length;
      result    : Boolean := False;
      errprefix : constant String := "Orphaned directory detected: ";
   begin
      if status /= 0 then
         TIO.Put_Line ("orphaned_directories_detected: command error: " & comres);
         return True;
      end if;
      HT.initialize_markers (comres, markers);
      loop
         exit when not HT.next_line_present (comres, markers);
         declare
            line      : constant String := HT.extract_line (comres, markers);
            line_text : HT.Text := HT.SUS (line);
         begin
            if line /= "" then
               if HT.leads (line, localbase) then
                  declare
                     plist_dir : HT.Text := HT.SUS (line (line'First + lblen + 1 .. line'Last));
                  begin
                     if directory_list.Contains (plist_dir) then
                        directory_list.Update_Element (Position => directory_list.Find (plist_dir),
                                                       Process  => mark_verified'Access);
                     else
                        if not directory_excluded (line) then
                           TIO.Put_Line (log_handle, errprefix & line);
                           result := True;
                        end if;
                     end if;
                  end;
               else
                  if directory_list.Contains (line_text) then
                     directory_list.Update_Element (Position => directory_list.Find (line_text),
                                                    Process  => mark_verified'Access);
                  else
                     TIO.Put_Line (log_handle, errprefix & line);
                     result := True;
                  end if;
               end if;
            end if;
         end;
      end loop;
      return result;
   end orphaned_directories_detected;

   --------------------------------------------------------------------------------------------
   --  mark_verified
   --------------------------------------------------------------------------------------------
   procedure mark_verified (key : HT.Text; Element : in out entry_record) is
   begin
      Element.verified := True;
   end mark_verified;

   --------------------------------------------------------------------------------------------
   --  missing_directories_detected
   --------------------------------------------------------------------------------------------
   function missing_directories_detected
     (log_handle     : TIO.File_Type;
      directory_list : in out entry_crate.Map) return Boolean
   is
      procedure check (position : entry_crate.Cursor);

      result : Boolean := False;

      procedure check (position : entry_crate.Cursor)
      is
         rec       : entry_record renames entry_crate.Element (position);
         plist_dir : String := HT.USS (entry_crate.Key (position));
      begin
         if not rec.verified then
            TIO.Put_Line
              (log_handle,
               "Directory " & plist_dir & " listed on " & HT.USS (rec.subpackage) &
                 " manifest is not present in the stage directory.");
            result := True;
         end if;
      end check;
   begin
      directory_list.Iterate (check'Access);
      return result;
   end missing_directories_detected;

   --------------------------------------------------------------------------------------------
   --  missing_files_detected
   --------------------------------------------------------------------------------------------
   function missing_files_detected
     (log_handle   : TIO.File_Type;
      dossier_list : in out entry_crate.Map) return Boolean
   is
      procedure check (position : entry_crate.Cursor);

      result : Boolean := False;

      procedure check (position : entry_crate.Cursor)
      is
         rec        : entry_record renames entry_crate.Element (position);
         plist_file : String := HT.USS (entry_crate.Key (position));
      begin
         if not rec.verified then
            TIO.Put_Line
              (log_handle,
               "File " & plist_file & " listed on " & HT.USS (rec.subpackage) &
                 " manifest is not present in the stage directory.");
            result := True;
         end if;
      end check;
   begin
      dossier_list.Iterate (check'Access);
      return result;
   end missing_files_detected;

   --------------------------------------------------------------------------------------------
   --  orphaned_files_detected
   --------------------------------------------------------------------------------------------
   function orphaned_files_detected
     (log_handle     : TIO.File_Type;
      dossier_list   : in out entry_crate.Map;
      namebase       : String;
      rootdir        : String) return Boolean
   is
      rawlbase  : constant String  := HT.USS (PM.configuration.dir_localbase);
      localbase : constant String  := rawlbase (rawlbase'First + 1 .. rawlbase'Last);
      stagedir  : String := rootdir & "/construction/" & namebase & "/stage";
      command   : String := rootdir & "/usr/bin/find " & stagedir &
                  " \( -type f -o -type l \) -printf " &
                  LAT.Quotation & "%P\n" & LAT.Quotation;
      status    : Integer;
      comres    : String := HT.USS (Unix.piped_command (command, status));
      markers   : HT.Line_Markers;
      lblen     : constant Natural := localbase'Length;
      result    : Boolean := False;
      errprefix : constant String := "Orphaned file detected: ";
   begin
      if status /= 0 then
         TIO.Put_Line ("orphaned_files_detected: command error: " & comres);
         return True;
      end if;
      HT.initialize_markers (comres, markers);
      loop
         exit when not HT.next_line_present (comres, markers);
         declare
            line      : constant String := HT.extract_line (comres, markers);
            line_text : HT.Text := HT.SUS (line);
         begin
            if line /= "" then
               if HT.leads (line, localbase) then
                  declare
                     plist_file : HT.Text := HT.SUS (line (line'First + lblen + 1 .. line'Last));
                  begin
                     if dossier_list.Contains (plist_file) then
                        dossier_list.Update_Element (Position => dossier_list.Find (plist_file),
                                                     Process  => mark_verified'Access);
                     else
                        TIO.Put_Line (log_handle, errprefix & line);
                        result := True;
                     end if;
                  end;
               else
                  if dossier_list.Contains (line_text) then
                     dossier_list.Update_Element (Position => dossier_list.Find (line_text),
                                                  Process  => mark_verified'Access);
                  else
                     TIO.Put_Line (log_handle, errprefix & line);
                     result := True;
                  end if;
               end if;
            end if;
         end;
      end loop;
      return result;
   end orphaned_files_detected;

   --------------------------------------------------------------------------------------------
   --  modify_file_if_necessary
   --------------------------------------------------------------------------------------------
   function modify_file_if_necessary (original : String) return String
   is
      function strip_raw_localbase (wrkstr : String) return String;
      function strip_raw_localbase (wrkstr : String) return String
      is
         rawlbase : constant String  := HT.USS (PM.configuration.dir_localbase) & "/";
      begin
         if HT.leads (wrkstr, rawlbase) then
            return wrkstr (wrkstr'First + rawlbase'Length .. wrkstr'Last);
         else
            return wrkstr;
         end if;
      end strip_raw_localbase;
   begin
      if HT.leads (original, "@info ") then
         return strip_raw_localbase (original (original'First + 6 .. original 'Last));
      elsif HT.leads (original, "@sample ") then
         return strip_raw_localbase (original (original'First + 8 .. original 'Last));
      else
         return original;
      end if;
   end modify_file_if_necessary;

end PortScan.Tests;

Support @sample keyword

Support @sample keyword


-----------------------------------------------------------------------
--  util-commands-drivers -- Support to make command line tools
--  Copyright (C) 2017, 2018, 2019 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Util.Log;
with Util.Commands.Parsers;
private with Ada.Strings.Unbounded;
private with Ada.Containers.Indefinite_Ordered_Maps;

--  == Command line driver ==
--  The `Util.Commands.Drivers` generic package provides a support to build command line
--  tools that have different commands identified by a name.  It defines the `Driver_Type`
--  tagged record that provides a registry of application commands.  It gives entry points
--  to register commands and execute them.
--
--  The `Context_Type` package parameter defines the type for the `Context` parameter
--  that is passed to the command when it is executed.  It can be used to provide
--  application specific context to the command.
--
--  The `Config_Parser` describes the parser package that will handle the analysis of
--  command line options.  To use the GNAT options parser, it is possible to use the
--  `Util.Commands.Parsers.GNAT_Parser` package.
generic
   --  The command execution context.
   type Context_Type (<>) is limited private;
   with package Config_Parser is new Util.Commands.Parsers.Config_Parser (<>);
   Driver_Name : String := "Drivers";
package Util.Commands.Drivers is

   subtype Config_Type is Config_Parser.Config_Type;

   --  A simple command handler executed when the command with the given name is executed.
   type Command_Handler is not null access procedure (Name    : in String;
                                                      Args    : in Argument_List'Class;
                                                      Context : in out Context_Type);

   --  A more complex command handler that has a command instance as context.
   type Command_Type is abstract tagged limited private;
   type Command_Access is access all Command_Type'Class;

   --  Get the description associated with the command.
   function Get_Description (Command : in Command_Type) return String;

   --  Get the name used to register the command.
   function Get_Name (Command : in Command_Type) return String;

   --  Execute the command with the arguments.  The command name is passed with the command
   --  arguments.
   procedure Execute (Command   : in out Command_Type;
                      Name      : in String;
                      Args      : in Argument_List'Class;
                      Context   : in out Context_Type) is abstract;

   --  Setup the command before parsing the arguments and executing it.
   procedure Setup (Command : in out Command_Type;
                    Config  : in out Config_Type;
                    Context : in out Context_Type) is null;

   --  Write the help associated with the command.
   procedure Help (Command   : in out Command_Type;
                   Name      : in String;
                   Context   : in out Context_Type) is abstract;

   --  Write the command usage.
   procedure Usage (Command : in out Command_Type;
                    Name    : in String;
                    Context : in out Context_Type);

   --  Print a message for the command.  The level indicates whether the message is an error,
   --  warning or informational.  The command name can be used to known the originator.
   --  The <tt>Log</tt> operation is redirected to the driver's <tt>Log</tt> procedure.
   procedure Log (Command : in Command_Type;
                  Level   : in Util.Log.Level_Type;
                  Name    : in String;
                  Message : in String);

   type Help_Command_Type is new Command_Type with private;

   --  Execute the help command with the arguments.
   --  Print the help for every registered command.
   overriding
   procedure Execute (Command   : in out Help_Command_Type;
                      Name      : in String;
                      Args      : in Argument_List'Class;
                      Context   : in out Context_Type);

   --  Write the help associated with the command.
   overriding
   procedure Help (Command   : in out Help_Command_Type;
                   Name      : in String;
                   Context   : in out Context_Type);

   type Driver_Type is tagged limited private;

   --  Report the command usage.
   procedure Usage (Driver  : in Driver_Type;
                    Args    : in Argument_List'Class;
                    Context : in out Context_Type;
                    Name    : in String := "");

   --  Set the driver description printed in the usage.
   procedure Set_Description (Driver      : in out Driver_Type;
                              Description : in String);

   --  Set the driver usage printed in the usage.
   procedure Set_Usage (Driver  : in out Driver_Type;
                        Usage   : in String);

   --  Register the command under the given name.
   procedure Add_Command (Driver  : in out Driver_Type;
                          Name    : in String;
                          Command : in Command_Access);

   procedure Add_Command (Driver      : in out Driver_Type;
                          Name        : in String;
                          Description : in String;
                          Command     : in Command_Access);

   --  Register the command under the given name.
   procedure Add_Command (Driver      : in out Driver_Type;
                          Name        : in String;
                          Description : in String;
                          Handler     : in Command_Handler);

   --  Find the command having the given name.
   --  Returns null if the command was not found.
   function Find_Command (Driver : in Driver_Type;
                          Name   : in String) return Command_Access;

   --  Execute the command registered under the given name.
   procedure Execute (Driver  : in Driver_Type;
                      Name    : in String;
                      Args    : in Argument_List'Class;
                      Context : in out Context_Type);

   --  Print a message for the command.  The level indicates whether the message is an error,
   --  warning or informational.  The command name can be used to known the originator.
   procedure Log (Driver  : in Driver_Type;
                  Level   : in Util.Log.Level_Type;
                  Name    : in String;
                  Message : in String);

private

   package Command_Maps is
     new Ada.Containers.Indefinite_Ordered_Maps (Key_Type     => String,
                                                 Element_Type => Command_Access,
                                                 "<"          => "<");

   type Command_Type is abstract tagged limited record
      Driver      : access Driver_Type'Class;
      Name        : Ada.Strings.Unbounded.Unbounded_String;
      Description : Ada.Strings.Unbounded.Unbounded_String;
   end record;

   type Help_Command_Type is new Command_Type with null record;

   type Handler_Command_Type is new Command_Type with record
      Handler : Command_Handler;
   end record;

   --  Execute the command with the arguments.
   overriding
   procedure Execute (Command   : in out Handler_Command_Type;
                      Name      : in String;
                      Args      : in Argument_List'Class;
                      Context   : in out Context_Type);

   --  Write the help associated with the command.
   overriding
   procedure Help (Command   : in out Handler_Command_Type;
                   Name      : in String;
                   Context   : in out Context_Type);

   type Driver_Type is tagged limited record
      List  : Command_Maps.Map;
      Desc  : Ada.Strings.Unbounded.Unbounded_String;
      Usage : Ada.Strings.Unbounded.Unbounded_String;
   end record;

end Util.Commands.Drivers;

-----------------------------------------------------------------------
--  util-commands-drivers -- Support to make command line tools
--  Copyright (C) 2017, 2018, 2019 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Util.Log;
with Util.Commands.Parsers;
private with Ada.Strings.Unbounded;
private with Ada.Containers.Ordered_Sets;

--  == Command line driver ==
--  The `Util.Commands.Drivers` generic package provides a support to build command line
--  tools that have different commands identified by a name.  It defines the `Driver_Type`
--  tagged record that provides a registry of application commands.  It gives entry points
--  to register commands and execute them.
--
--  The `Context_Type` package parameter defines the type for the `Context` parameter
--  that is passed to the command when it is executed.  It can be used to provide
--  application specific context to the command.
--
--  The `Config_Parser` describes the parser package that will handle the analysis of
--  command line options.  To use the GNAT options parser, it is possible to use the
--  `Util.Commands.Parsers.GNAT_Parser` package.
generic
   --  The command execution context.
   type Context_Type (<>) is limited private;
   with package Config_Parser is new Util.Commands.Parsers.Config_Parser (<>);
   Driver_Name : String := "Drivers";
package Util.Commands.Drivers is

   subtype Config_Type is Config_Parser.Config_Type;

   --  A simple command handler executed when the command with the given name is executed.
   type Command_Handler is not null access procedure (Name    : in String;
                                                      Args    : in Argument_List'Class;
                                                      Context : in out Context_Type);

   --  A more complex command handler that has a command instance as context.
   type Command_Type is abstract tagged limited private;
   type Command_Access is access all Command_Type'Class;

   --  Get the description associated with the command.
   function Get_Description (Command : in Command_Type) return String;

   --  Get the name used to register the command.
   function Get_Name (Command : in Command_Type) return String;

   --  Execute the command with the arguments.  The command name is passed with the command
   --  arguments.
   procedure Execute (Command   : in out Command_Type;
                      Name      : in String;
                      Args      : in Argument_List'Class;
                      Context   : in out Context_Type) is abstract;

   --  Setup the command before parsing the arguments and executing it.
   procedure Setup (Command : in out Command_Type;
                    Config  : in out Config_Type;
                    Context : in out Context_Type) is null;

   --  Write the help associated with the command.
   procedure Help (Command   : in out Command_Type;
                   Name      : in String;
                   Context   : in out Context_Type) is abstract;

   --  Write the command usage.
   procedure Usage (Command : in out Command_Type;
                    Name    : in String;
                    Context : in out Context_Type);

   --  Print a message for the command.  The level indicates whether the message is an error,
   --  warning or informational.  The command name can be used to known the originator.
   --  The <tt>Log</tt> operation is redirected to the driver's <tt>Log</tt> procedure.
   procedure Log (Command : in Command_Type;
                  Level   : in Util.Log.Level_Type;
                  Name    : in String;
                  Message : in String);

   type Help_Command_Type is new Command_Type with private;

   --  Execute the help command with the arguments.
   --  Print the help for every registered command.
   overriding
   procedure Execute (Command   : in out Help_Command_Type;
                      Name      : in String;
                      Args      : in Argument_List'Class;
                      Context   : in out Context_Type);

   --  Write the help associated with the command.
   overriding
   procedure Help (Command   : in out Help_Command_Type;
                   Name      : in String;
                   Context   : in out Context_Type);

   type Driver_Type is tagged limited private;

   --  Report the command usage.
   procedure Usage (Driver  : in Driver_Type;
                    Args    : in Argument_List'Class;
                    Context : in out Context_Type;
                    Name    : in String := "");

   --  Set the driver description printed in the usage.
   procedure Set_Description (Driver      : in out Driver_Type;
                              Description : in String);

   --  Set the driver usage printed in the usage.
   procedure Set_Usage (Driver  : in out Driver_Type;
                        Usage   : in String);

   --  Register the command under the given name.
   procedure Add_Command (Driver  : in out Driver_Type;
                          Name    : in String;
                          Command : in Command_Access);

   procedure Add_Command (Driver      : in out Driver_Type;
                          Name        : in String;
                          Description : in String;
                          Command     : in Command_Access);

   --  Register the command under the given name.
   procedure Add_Command (Driver      : in out Driver_Type;
                          Name        : in String;
                          Description : in String;
                          Handler     : in Command_Handler);

   --  Find the command having the given name.
   --  Returns null if the command was not found.
   function Find_Command (Driver : in Driver_Type;
                          Name   : in String) return Command_Access;

   --  Execute the command registered under the given name.
   procedure Execute (Driver  : in Driver_Type;
                      Name    : in String;
                      Args    : in Argument_List'Class;
                      Context : in out Context_Type);

   --  Print a message for the command.  The level indicates whether the message is an error,
   --  warning or informational.  The command name can be used to known the originator.
   procedure Log (Driver  : in Driver_Type;
                  Level   : in Util.Log.Level_Type;
                  Name    : in String;
                  Message : in String);

private

   type Command_Type is abstract tagged limited record
      Driver      : access Driver_Type'Class;
      Name        : Ada.Strings.Unbounded.Unbounded_String;
      Description : Ada.Strings.Unbounded.Unbounded_String;
   end record;

   function "<" (Left, Right : in Command_Access) return Boolean is
      (Ada.Strings.Unbounded."<" (Left.Name, Right.Name));

   package Command_Sets is
     new Ada.Containers.Ordered_Sets (Element_Type => Command_Access,
                                      "<"          => "<",
                                      "="          => "=");

   type Help_Command_Type is new Command_Type with null record;

   type Handler_Command_Type is new Command_Type with record
      Handler : Command_Handler;
   end record;

   --  Execute the command with the arguments.
   overriding
   procedure Execute (Command   : in out Handler_Command_Type;
                      Name      : in String;
                      Args      : in Argument_List'Class;
                      Context   : in out Context_Type);

   --  Write the help associated with the command.
   overriding
   procedure Help (Command   : in out Handler_Command_Type;
                   Name      : in String;
                   Context   : in out Context_Type);

   type Driver_Type is tagged limited record
      List  : Command_Sets.Set;
      Desc  : Ada.Strings.Unbounded.Unbounded_String;
      Usage : Ada.Strings.Unbounded.Unbounded_String;
   end record;

end Util.Commands.Drivers;

Change the implementation to use an Ordered_Set instead of an Indefinite_Hashed_Map


-----------------------------------------------------------------------
--  awa-workspaces-module -- Module workspaces
--  Copyright (C) 2011, 2012, 2013 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------

with Ada.Calendar;

with AWA.Users.Models;
with AWA.Modules.Beans;
with AWA.Permissions.Services;

with ADO.SQL;
with Util.Log.Loggers;
with AWA.Users.Modules;
with AWA.Workspaces.Beans;
package body AWA.Workspaces.Modules is

   package ASC renames AWA.Services.Contexts;

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Awa.Workspaces.Module");

   package Register is new AWA.Modules.Beans (Module => Workspace_Module,
                                              Module_Access => Workspace_Module_Access);

   --  ------------------------------
   --  Initialize the workspaces module.
   --  ------------------------------
   overriding
   procedure Initialize (Plugin : in out Workspace_Module;
                         App    : in AWA.Modules.Application_Access;
                         Props  : in ASF.Applications.Config) is
   begin
      Log.Info ("Initializing the workspaces module");

      --  Register here any bean class, servlet, filter.
      Register.Register (Plugin => Plugin,
                         Name   => "AWA.Workspaces.Beans.Workspaces_Bean",
                         Handler => AWA.Workspaces.Beans.Create_Workspaces_Bean'Access);
      Register.Register (Plugin => Plugin,
                         Name   => "AWA.Workspaces.Beans.Member_List_Bean",
                         Handler => AWA.Workspaces.Beans.Create_Member_List_Bean'Access);
      Register.Register (Plugin => Plugin,
                         Name   => "AWA.Workspaces.Beans.Invitation_Bean",
                         Handler => AWA.Workspaces.Beans.Create_Invitation_Bean'Access);

      AWA.Modules.Module (Plugin).Initialize (App, Props);

      Plugin.User_Manager := AWA.Users.Modules.Get_User_Manager;
      --  Add here the creation of manager instances.
   end Initialize;

   --  ------------------------------
   --  Get the current workspace associated with the current user.
   --  If the user has not workspace, create one.
   --  ------------------------------
   procedure Get_Workspace (Session   : in out ADO.Sessions.Master_Session;
                            Context   : in AWA.Services.Contexts.Service_Context_Access;
                            Workspace : out AWA.Workspaces.Models.Workspace_Ref) is
      User    : constant AWA.Users.Models.User_Ref := Context.Get_User;
      WS      : AWA.Workspaces.Models.Workspace_Ref;
      Member  : AWA.Workspaces.Models.Workspace_Member_Ref;
      Query   : ADO.SQL.Query;
      Found   : Boolean;
   begin
      if User.Is_Null then
         Log.Error ("There is no current user.  The workspace cannot be identified");
         Workspace := AWA.Workspaces.Models.Null_Workspace;
         return;
      end if;

      --  Find the workspace associated with the current user.
      Query.Add_Param (User.Get_Id);
      Query.Set_Filter ("o.owner_id = ?");
      WS.Find (Session, Query, Found);
      if Found then
         Workspace := WS;
         return;
      end if;

      --  Create a workspace for this user.
      WS.Set_Owner (User);
      WS.Set_Create_Date (Ada.Calendar.Clock);
      WS.Save (Session);

      --  Create the member instance for this user.
      Member.Set_Workspace (WS);
      Member.Set_Member (User);
      Member.Set_Role ("Owner");
      Member.Set_Join_Date (ADO.Nullable_Time '(Is_Null => False, Value => WS.Get_Create_Date));
      Member.Save (Session);

      --  And give full control of the workspace for this user
      AWA.Permissions.Services.Add_Permission (Session => Session,
                                               User    => User.Get_Id,
                                               Entity  => WS);

      Workspace := WS;
   end Get_Workspace;

   --  ------------------------------
   --  Load the invitation from the access key and verify that the key is still valid.
   --  ------------------------------
   procedure Load_Invitation (Module     : in Workspace_Module;
                              Key        : in String;
                              Invitation : in out AWA.Workspaces.Models.Invitation_Ref'Class;
                              Inviter    : in out AWA.Users.Models.User_Ref) is
      use type Ada.Calendar.Time;

      Ctx    : constant ASC.Service_Context_Access := AWA.Services.Contexts.Current;
      DB     : ADO.Sessions.Master_Session := AWA.Services.Contexts.Get_Master_Session (Ctx);
      Query  : ADO.SQL.Query;
      DB_Key : AWA.Users.Models.Access_Key_Ref;
      Found  : Boolean;
   begin
      Log.Debug ("Loading invitation from key {0}", Key);

      Query.Set_Filter ("o.access_key = :key");
      Query.Bind_Param ("key", Key);
      DB_Key.Find (DB, Query, Found);
      if not Found then
         Log.Info ("Invitation key {0} does not exist");
         raise Not_Found;
      end if;
      if DB_Key.Get_Expire_Date < Ada.Calendar.Clock then
         Log.Info ("Invitation key {0} has expired");
         raise Not_Found;
      end if;
      Query.Set_Filter ("o.invitee_id = :user");
      Query.Bind_Param ("user", DB_Key.Get_User.Get_Id);
      Invitation.Find (DB, Query, Found);
      if not Found then
         Log.Warn ("Invitation key {0} has been withdawn");
         raise Not_Found;
      end if;
      Inviter := AWA.Users.Models.User_Ref (Invitation.Get_Inviter);
   end Load_Invitation;

   --  ------------------------------
   --  Accept the invitation identified by the access key.
   --  ------------------------------
   procedure Accept_Invitation (Module     : in Workspace_Module;
                                Key        : in String) is
      use type Ada.Calendar.Time;
      use type ADO.Identifier;

      Ctx          : constant ASC.Service_Context_Access := AWA.Services.Contexts.Current;
      User         : constant AWA.Users.Models.User_Ref := Ctx.Get_User;
      DB           : ADO.Sessions.Master_Session := AWA.Services.Contexts.Get_Master_Session (Ctx);
      Query        : ADO.SQL.Query;
      DB_Key       : AWA.Users.Models.Access_Key_Ref;
      Found        : Boolean;
      Invitation   : AWA.Workspaces.Models.Invitation_Ref;
      Invitee_Id   : ADO.Identifier;
      Workspace_Id : ADO.Identifier;
      Member       : AWA.Workspaces.Models.Workspace_Member_Ref;
      User_Member  : AWA.Workspaces.Models.Workspace_Member_Ref;
      Now          : constant Ada.Calendar.Time := Ada.Calendar.Clock;
   begin
      Log.Debug ("Accept invitation with key {0}", Key);
      Ctx.Start;

      --  Get the access key and verify its validity.
      Query.Set_Filter ("o.access_key = :key");
      Query.Bind_Param ("key", Key);
      DB_Key.Find (DB, Query, Found);
      if not Found then
         Log.Info ("Invitation key {0} does not exist", Key);
         raise Not_Found;
      end if;
      if DB_Key.Get_Expire_Date < Now then
         Log.Info ("Invitation key {0} has expired", Key);
         raise Not_Found;
      end if;

      --  Find the invitation associated with the access key.
      Invitee_Id := DB_Key.Get_User.Get_Id;
      Query.Set_Filter ("o.invitee_id = :user");
      Query.Bind_Param ("user", Invitee_Id);
      Invitation.Find (DB, Query, Found);
      if not Found then
         Log.Warn ("Invitation key {0} has been withdawn", Key);
         raise Not_Found;
      end if;
      Workspace_Id := Invitation.Get_Workspace.Get_Id;

      --  Update the workspace member relation.
      Query.Clear;
      Query.Set_Filter ("o.member_id = ? AND o.workspace_id = ?");
      Query.Add_Param (Invitee_Id);
      Query.Add_Param (Workspace_Id);
      Member.Find (DB, Query, Found);
      if not Found then
         Log.Warn ("Invitation key {0} has been withdawn", Key);
         raise Not_Found;
      end if;
      Member.Set_Join_Date (ADO.Nullable_Time '(Is_Null => False,
                                                Value   => Now));
      Invitation.Set_Acceptance_Date (ADO.Nullable_Time '(Is_Null => False,
                                                          Value   => Now));

      --  The user who received the invitation is different from the user who is
      --  logged and accepted the validation.   Since the key is verified, this is
      --  the same user but the user who accepted the invitation registered using
      --  another email address.
      if Invitee_Id /= User.Get_Id then
         --  Check whether the user is not already part of the workspace.
         Query.Clear;
         Query.Set_Filter ("o.member_id = ? AND o.workspace_id = ?");
         Query.Add_Param (User.Get_Id);
         Query.Add_Param (Workspace_Id);
         User_Member.Find (DB, Query, Found);
         if Found then
            Member.Delete (DB);
            Invitation.Delete (DB);
            Log.Info ("Invitation accepted by user who is already a member");
         else
            Member.Set_Member (User);
            Log.Info ("Invitation accepted by user with another email address");
         end if;
         Invitation.Set_Invitee (User);
      end if;
      if not Member.Is_Null then
         Member.Save (DB);
      end if;
      DB_Key.Delete (DB);
      if not Invitation.Is_Null then
         Invitation.Save (DB);
      end if;
      Ctx.Commit;
   end Accept_Invitation;

   --  ------------------------------
   --  Send the invitation to the user.
   --  ------------------------------
   procedure Send_Invitation (Module     : in Workspace_Module;
                              Invitation : in out AWA.Workspaces.Models.Invitation_Ref'Class) is
      use type ADO.Identifier;

      Ctx     : constant ASC.Service_Context_Access := AWA.Services.Contexts.Current;
      DB      : ADO.Sessions.Master_Session := AWA.Services.Contexts.Get_Master_Session (Ctx);
      User    : constant AWA.Users.Models.User_Ref := Ctx.Get_User;
      WS      : AWA.Workspaces.Models.Workspace_Ref;
      Query   : ADO.SQL.Query;
      Found   : Boolean;
      Key     : AWA.Users.Models.Access_Key_Ref;
      Email   : AWA.Users.Models.Email_Ref;
      Invitee : AWA.Users.Models.User_Ref;
      Invit   : AWA.Workspaces.Models.Invitation_Ref;
      Member  : AWA.Workspaces.Models.Workspace_Member_Ref;
      Email_Address : constant String := Invitation.Get_Email;
   begin
      Log.Info ("Sending invitation to {0}", Email_Address);

      Ctx.Start;
      if User.Is_Null then
         Log.Error ("There is no current user.  The workspace cannot be identified");
         return;
      end if;

      --  Find the workspace associated with the current user.
      Query.Add_Param (User.Get_Id);
      Query.Set_Filter ("o.owner_id = ?");
      WS.Find (DB, Query, Found);
      if not Found then
         return;
      end if;

      Query.Clear;
      Query.Set_Filter ("o.email = ?");
      Query.Add_Param (Email_Address);
      Email.Find (DB, Query, Found);
      if not Found then
         Email.Set_User_Id (0);
         Email.Set_Email (Email_Address);
         Email.Save (DB);
         Invitee.Set_Email (Email);
         Invitee.Set_Name (Email_Address);
         Invitee.Save (DB);
         Email.Set_User_Id (Invitee.Get_Id);
         Email.Save (DB);
      else
         Invitee.Load (DB, Email.Get_User_Id);
      end if;

      --  Create the workspace member relation.
      Query.Clear;
      Query.Set_Filter ("o.member_id = ? AND o.workspace_id = ?");
      Query.Add_Param (Invitee.Get_Id);
      Query.Add_Param (WS.Get_Id);
      Member.Find (DB, Query, Found);
      if not Found then
         Member.Set_Member (Invitee);
         Member.Set_Workspace (WS);
         Member.Set_Role ("Invited");
         Member.Save (DB);
      end if;

      --  Check for a previous invitation for the user and delete it.
      Query.Set_Filter ("o.invitee_id = ? AND o.workspace_id = ?");
      Invit.Find (DB, Query, Found);
      if Found then
         Key := AWA.Users.Models.Access_Key_Ref (Invit.Get_Access_Key);
         Key.Delete (DB);
         if not Invitation.Is_Inserted or else Invit.Get_Id /= Invitation.Get_Id then
            Invit.Delete (DB);
         end if;
      end if;
      Key := AWA.Users.Models.Access_Key_Ref (Invitation.Get_Access_Key);
      Module.User_Manager.Create_Access_Key (Invitee, Key, 365 * 86400.0, DB);
      Key.Save (DB);
      Invitation.Set_Access_Key (Key);
      Invitation.Set_Inviter (User);
      Invitation.Set_Invitee (Invitee);
      Invitation.Set_Workspace (WS);
      Invitation.Set_Create_Date (Ada.Calendar.Clock);
      Invitation.Save (DB);

      --  Send the email with the reset password key
      declare
         Event : AWA.Events.Module_Event;
      begin
         Event.Set_Parameter ("key", Key.Get_Access_Key);
         Event.Set_Parameter ("email", Email_Address);
         Event.Set_Parameter ("name", Invitee.Get_Name);
         Event.Set_Parameter ("message", Invitation.Get_Message);
         Event.Set_Parameter ("inviter", User.Get_Name);
         Event.Set_Event_Kind (Invite_User_Event.Kind);
         Module.Send_Event (Event);
      end;

      Ctx.Commit;
   end Send_Invitation;

end AWA.Workspaces.Modules;

-----------------------------------------------------------------------
--  awa-workspaces-module -- Module workspaces
--  Copyright (C) 2011, 2012, 2013, 2017 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------

with Ada.Calendar;

with AWA.Users.Models;
with AWA.Modules.Beans;
with AWA.Permissions.Services;

with ADO.SQL;
with Util.Log.Loggers;
with AWA.Users.Modules;
with AWA.Workspaces.Beans;
package body AWA.Workspaces.Modules is

   use type ADO.Identifier;

   package ASC renames AWA.Services.Contexts;

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Awa.Workspaces.Module");

   package Register is new AWA.Modules.Beans (Module => Workspace_Module,
                                              Module_Access => Workspace_Module_Access);

   --  ------------------------------
   --  Initialize the workspaces module.
   --  ------------------------------
   overriding
   procedure Initialize (Plugin : in out Workspace_Module;
                         App    : in AWA.Modules.Application_Access;
                         Props  : in ASF.Applications.Config) is
   begin
      Log.Info ("Initializing the workspaces module");

      --  Register here any bean class, servlet, filter.
      Register.Register (Plugin => Plugin,
                         Name   => "AWA.Workspaces.Beans.Workspaces_Bean",
                         Handler => AWA.Workspaces.Beans.Create_Workspaces_Bean'Access);
      Register.Register (Plugin => Plugin,
                         Name   => "AWA.Workspaces.Beans.Member_List_Bean",
                         Handler => AWA.Workspaces.Beans.Create_Member_List_Bean'Access);
      Register.Register (Plugin => Plugin,
                         Name   => "AWA.Workspaces.Beans.Invitation_Bean",
                         Handler => AWA.Workspaces.Beans.Create_Invitation_Bean'Access);

      AWA.Modules.Module (Plugin).Initialize (App, Props);

      Plugin.User_Manager := AWA.Users.Modules.Get_User_Manager;
      --  Add here the creation of manager instances.
   end Initialize;

   --  ------------------------------
   --  Get the current workspace associated with the current user.
   --  If the user has not workspace, create one.
   --  ------------------------------
   procedure Get_Workspace (Session   : in out ADO.Sessions.Master_Session;
                            Context   : in AWA.Services.Contexts.Service_Context_Access;
                            Workspace : out AWA.Workspaces.Models.Workspace_Ref) is
      User    : constant AWA.Users.Models.User_Ref := Context.Get_User;
      WS      : AWA.Workspaces.Models.Workspace_Ref;
      Member  : AWA.Workspaces.Models.Workspace_Member_Ref;
      Query   : ADO.SQL.Query;
      Found   : Boolean;
   begin
      if User.Is_Null then
         Log.Error ("There is no current user.  The workspace cannot be identified");
         Workspace := AWA.Workspaces.Models.Null_Workspace;
         return;
      end if;

      --  Find the workspace associated with the current user.
      Query.Add_Param (User.Get_Id);
      Query.Set_Filter ("o.owner_id = ?");
      WS.Find (Session, Query, Found);
      if Found then
         Workspace := WS;
         return;
      end if;

      --  Create a workspace for this user.
      WS.Set_Owner (User);
      WS.Set_Create_Date (Ada.Calendar.Clock);
      WS.Save (Session);

      --  Create the member instance for this user.
      Member.Set_Workspace (WS);
      Member.Set_Member (User);
      Member.Set_Role ("Owner");
      Member.Set_Join_Date (ADO.Nullable_Time '(Is_Null => False, Value => WS.Get_Create_Date));
      Member.Save (Session);

      --  And give full control of the workspace for this user
      AWA.Permissions.Services.Add_Permission (Session   => Session,
                                               User      => User.Get_Id,
                                               Entity    => WS,
                                               Workspace => WS.Get_Id);

      Workspace := WS;
   end Get_Workspace;

   --  ------------------------------
   --  Load the invitation from the access key and verify that the key is still valid.
   --  ------------------------------
   procedure Load_Invitation (Module     : in Workspace_Module;
                              Key        : in String;
                              Invitation : in out AWA.Workspaces.Models.Invitation_Ref'Class;
                              Inviter    : in out AWA.Users.Models.User_Ref) is
      use type Ada.Calendar.Time;

      Ctx    : constant ASC.Service_Context_Access := AWA.Services.Contexts.Current;
      DB     : ADO.Sessions.Master_Session := AWA.Services.Contexts.Get_Master_Session (Ctx);
      Query  : ADO.SQL.Query;
      DB_Key : AWA.Users.Models.Access_Key_Ref;
      Found  : Boolean;
   begin
      Log.Debug ("Loading invitation from key {0}", Key);

      Query.Set_Filter ("o.access_key = :key");
      Query.Bind_Param ("key", Key);
      DB_Key.Find (DB, Query, Found);
      if not Found then
         Log.Info ("Invitation key {0} does not exist");
         raise Not_Found;
      end if;
      if DB_Key.Get_Expire_Date < Ada.Calendar.Clock then
         Log.Info ("Invitation key {0} has expired");
         raise Not_Found;
      end if;
      Query.Set_Filter ("o.invitee_id = :user");
      Query.Bind_Param ("user", DB_Key.Get_User.Get_Id);
      Invitation.Find (DB, Query, Found);
      if not Found then
         Log.Warn ("Invitation key {0} has been withdawn");
         raise Not_Found;
      end if;
      Inviter := AWA.Users.Models.User_Ref (Invitation.Get_Inviter);
   end Load_Invitation;

   --  ------------------------------
   --  Accept the invitation identified by the access key.
   --  ------------------------------
   procedure Accept_Invitation (Module     : in Workspace_Module;
                                Key        : in String) is
      use type Ada.Calendar.Time;

      Ctx          : constant ASC.Service_Context_Access := AWA.Services.Contexts.Current;
      User         : constant AWA.Users.Models.User_Ref := Ctx.Get_User;
      DB           : ADO.Sessions.Master_Session := AWA.Services.Contexts.Get_Master_Session (Ctx);
      Query        : ADO.SQL.Query;
      DB_Key       : AWA.Users.Models.Access_Key_Ref;
      Found        : Boolean;
      Invitation   : AWA.Workspaces.Models.Invitation_Ref;
      Invitee_Id   : ADO.Identifier;
      Workspace_Id : ADO.Identifier;
      Member       : AWA.Workspaces.Models.Workspace_Member_Ref;
      User_Member  : AWA.Workspaces.Models.Workspace_Member_Ref;
      Now          : constant Ada.Calendar.Time := Ada.Calendar.Clock;
   begin
      Log.Debug ("Accept invitation with key {0}", Key);
      Ctx.Start;

      --  Get the access key and verify its validity.
      Query.Set_Filter ("o.access_key = :key");
      Query.Bind_Param ("key", Key);
      DB_Key.Find (DB, Query, Found);
      if not Found then
         Log.Info ("Invitation key {0} does not exist", Key);
         raise Not_Found;
      end if;
      if DB_Key.Get_Expire_Date < Now then
         Log.Info ("Invitation key {0} has expired", Key);
         raise Not_Found;
      end if;

      --  Find the invitation associated with the access key.
      Invitee_Id := DB_Key.Get_User.Get_Id;
      Query.Set_Filter ("o.invitee_id = :user");
      Query.Bind_Param ("user", Invitee_Id);
      Invitation.Find (DB, Query, Found);
      if not Found then
         Log.Warn ("Invitation key {0} has been withdawn", Key);
         raise Not_Found;
      end if;
      Workspace_Id := Invitation.Get_Workspace.Get_Id;

      --  Update the workspace member relation.
      Query.Clear;
      Query.Set_Filter ("o.member_id = ? AND o.workspace_id = ?");
      Query.Add_Param (Invitee_Id);
      Query.Add_Param (Workspace_Id);
      Member.Find (DB, Query, Found);
      if not Found then
         Log.Warn ("Invitation key {0} has been withdawn", Key);
         raise Not_Found;
      end if;
      Member.Set_Join_Date (ADO.Nullable_Time '(Is_Null => False,
                                                Value   => Now));
      Invitation.Set_Acceptance_Date (ADO.Nullable_Time '(Is_Null => False,
                                                          Value   => Now));

      --  The user who received the invitation is different from the user who is
      --  logged and accepted the validation.   Since the key is verified, this is
      --  the same user but the user who accepted the invitation registered using
      --  another email address.
      if Invitee_Id /= User.Get_Id then
         --  Check whether the user is not already part of the workspace.
         Query.Clear;
         Query.Set_Filter ("o.member_id = ? AND o.workspace_id = ?");
         Query.Add_Param (User.Get_Id);
         Query.Add_Param (Workspace_Id);
         User_Member.Find (DB, Query, Found);
         if Found then
            Member.Delete (DB);
            Invitation.Delete (DB);
            Log.Info ("Invitation accepted by user who is already a member");
         else
            Member.Set_Member (User);
            Log.Info ("Invitation accepted by user with another email address");
         end if;
         Invitation.Set_Invitee (User);
      end if;
      if not Member.Is_Null then
         Member.Save (DB);
      end if;
      DB_Key.Delete (DB);
      if not Invitation.Is_Null then
         Invitation.Save (DB);
      end if;
      Ctx.Commit;
   end Accept_Invitation;

   --  ------------------------------
   --  Send the invitation to the user.
   --  ------------------------------
   procedure Send_Invitation (Module     : in Workspace_Module;
                              Invitation : in out AWA.Workspaces.Models.Invitation_Ref'Class) is

      Ctx     : constant ASC.Service_Context_Access := AWA.Services.Contexts.Current;
      DB      : ADO.Sessions.Master_Session := AWA.Services.Contexts.Get_Master_Session (Ctx);
      User    : constant AWA.Users.Models.User_Ref := Ctx.Get_User;
      WS      : AWA.Workspaces.Models.Workspace_Ref;
      Query   : ADO.SQL.Query;
      Found   : Boolean;
      Key     : AWA.Users.Models.Access_Key_Ref;
      Email   : AWA.Users.Models.Email_Ref;
      Invitee : AWA.Users.Models.User_Ref;
      Invit   : AWA.Workspaces.Models.Invitation_Ref;
      Member  : AWA.Workspaces.Models.Workspace_Member_Ref;
      Email_Address : constant String := Invitation.Get_Email;
   begin
      Log.Info ("Sending invitation to {0}", Email_Address);

      Ctx.Start;
      if User.Is_Null then
         Log.Error ("There is no current user.  The workspace cannot be identified");
         return;
      end if;

      --  Find the workspace associated with the current user.
      Query.Add_Param (User.Get_Id);
      Query.Set_Filter ("o.owner_id = ?");
      WS.Find (DB, Query, Found);
      if not Found then
         return;
      end if;

      Query.Clear;
      Query.Set_Filter ("o.email = ?");
      Query.Add_Param (Email_Address);
      Email.Find (DB, Query, Found);
      if not Found then
         Email.Set_User_Id (0);
         Email.Set_Email (Email_Address);
         Email.Save (DB);
         Invitee.Set_Email (Email);
         Invitee.Set_Name (Email_Address);
         Invitee.Save (DB);
         Email.Set_User_Id (Invitee.Get_Id);
         Email.Save (DB);
      else
         Invitee.Load (DB, Email.Get_User_Id);
      end if;

      --  Create the workspace member relation.
      Query.Clear;
      Query.Set_Filter ("o.member_id = ? AND o.workspace_id = ?");
      Query.Add_Param (Invitee.Get_Id);
      Query.Add_Param (WS.Get_Id);
      Member.Find (DB, Query, Found);
      if not Found then
         Member.Set_Member (Invitee);
         Member.Set_Workspace (WS);
         Member.Set_Role ("Invited");
         Member.Save (DB);
      end if;

      --  Check for a previous invitation for the user and delete it.
      Query.Set_Filter ("o.invitee_id = ? AND o.workspace_id = ?");
      Invit.Find (DB, Query, Found);
      if Found then
         Key := AWA.Users.Models.Access_Key_Ref (Invit.Get_Access_Key);
         Key.Delete (DB);
         if not Invitation.Is_Inserted or else Invit.Get_Id /= Invitation.Get_Id then
            Invit.Delete (DB);
         end if;
      end if;
      Key := AWA.Users.Models.Access_Key_Ref (Invitation.Get_Access_Key);
      Module.User_Manager.Create_Access_Key (Invitee, Key, 365 * 86400.0, DB);
      Key.Save (DB);
      Invitation.Set_Access_Key (Key);
      Invitation.Set_Inviter (User);
      Invitation.Set_Invitee (Invitee);
      Invitation.Set_Workspace (WS);
      Invitation.Set_Create_Date (Ada.Calendar.Clock);
      Invitation.Save (DB);

      --  Send the email with the reset password key
      declare
         Event : AWA.Events.Module_Event;
      begin
         Event.Set_Parameter ("key", Key.Get_Access_Key);
         Event.Set_Parameter ("email", Email_Address);
         Event.Set_Parameter ("name", Invitee.Get_Name);
         Event.Set_Parameter ("message", Invitation.Get_Message);
         Event.Set_Parameter ("inviter", User.Get_Name);
         Event.Set_Event_Kind (Invite_User_Event.Kind);
         Module.Send_Event (Event);
      end;

      Ctx.Commit;
   end Send_Invitation;

   --  ------------------------------
   --  Delete the member from the workspace.  Remove the invitation if there is one.
   --  ------------------------------
   procedure Delete_Member (Module       : in Workspace_Module;
                            User_Id      : in ADO.Identifier;
                            Workspace_Id : in ADO.Identifier) is

      Ctx          : constant ASC.Service_Context_Access := AWA.Services.Contexts.Current;
      DB           : ADO.Sessions.Master_Session := AWA.Services.Contexts.Get_Master_Session (Ctx);
      User         : constant AWA.Users.Models.User_Ref := Ctx.Get_User;
      Query        : ADO.SQL.Query;
      Found        : Boolean;
      Key          : AWA.Users.Models.Access_Key_Ref;
      Member       : AWA.Workspaces.Models.Workspace_Member_Ref;
      Invitation   : AWA.Workspaces.Models.Invitation_Ref;
   begin
      Log.Info ("Delete user member {0}", ADO.Identifier'Image (User_Id));

      if User.Get_Id = User_Id then
         Log.Warn ("Refusing to delete the current user");
         return;
      end if;
      Ctx.Start;

      --  Get the workspace member instance for the user and remove it.
      Query.Set_Filter ("o.member_id = ? AND o.workspace_id = ?");
      Query.Add_Param (User_Id);
      Query.Add_Param (Workspace_Id);
      Member.Find (DB, Query, Found);
      if Found then
         Member.Delete (DB);
      end if;

      --  Get the invitation and remove it.
      Query.Set_Filter ("o.invitee_id = ? AND o.workspace_id = ?");
      Invitation.Find (DB, Query, Found);
      if Found then
         Key := AWA.Users.Models.Access_Key_Ref (Invitation.Get_Access_Key);
         Key.Delete (DB);
         Invitation.Delete (DB);
      end if;

      --  Remove all permissions assigned to the user in the workspace.
      AWA.Permissions.Services.Delete_Permissions (DB, User_Id, Workspace_Id);
      Ctx.Commit;
   end Delete_Member;

end AWA.Workspaces.Modules;

Implement the Delete_Member procedure to withraw an invitation, remove the user from the workspace and delete all the permissions for that user/workspace pair


-----------------------------------------------------------------------
--  security -- Security
--  Copyright (C) 2010, 2011, 2012 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------

--  == Introduction ==
--  The <tt>Security</tt> package provides a security framework that allows
--  an application to use OpenID or OAuth security frameworks.  This security
--  framework was first developed within the Ada Server Faces project.
--  This package defines abstractions that are close or similar to Java
--  security package.
--
--  The security framework uses the following abstractions:
--
--  === Policy and policy manager ===
--  The <tt>Policy</tt> defines and implements the set of security rules that specify how to
--  protect the system or resources.  The <tt>Policy_Manager</tt> maintains the security policies.
--
--  === Principal ===
--  The <tt>Principal</tt> is the entity that can be authenticated.  A principal is obtained
--  after successful authentication of a user or of a system through an authorization process.
--  The OpenID or OAuth authentication processes generate such security principal.
--
--  === Permission ===
--  The <tt>Permission</tt> represents an access to a system or application resource.
--  A permission is checked by using the security policy manager.  The policy manager uses a
--  security controller to enforce the permission.
--
--  === Security Context ===
--  The <tt>Security_Context</tt> holds the contextual information that the security controller
--  can use to verify the permission.  The security context is associated with a principal and
--  a set of policy context.
--
--  == Overview ==
--  An application will create a security policy manager and register one or several security
--  policies (yellow).  The framework defines a simple role based security policy and an URL
--  security policy intended to provide security in web applications.  The security policy manager
--  reads some security policy configuration file which allows the security policies to configure
--  and create the security controllers.  These controllers will enforce the security according
--  to the application security rules.  All these components are built only once when
--  an application starts.
--
--  A user is authenticated through an authentication system which creates a <tt>Principal</tt>
--  instance that identifies the user (green).  The security framework provides two authentication
--  systems: OpenID and OAuth.
--
--  [http://ada-security.googlecode.com/svn/wiki/ModelOverview.png]
--
--  When a permission must be enforced, a security context is created and linked to the
--  <tt>Principal</tt> instance (blue).  Additional security policy context can be added depending
--  on the application context.  To check the permission, the security policy manager is called
--  and it will ask a security controller to verify the permission.
--
--  The framework allows an application to plug its own security policy, its own policy context,
--  its own principal and authentication mechanism.
--
--  @include security-permissions.ads
--
--  == Principal ==
--  A principal is created by using either the [Security_Auth OpenID],
--  the [Security_OAuth OAuth] or another authentication mechanism.  The authentication produces
--  an object that must implement the <tt>Principal</tt> interface.  For example:
--
--    P : Security.Auth.Principal_Access := Security.Auth.Create_Principal (Auth);
--
--  or
--
--    P : Security.OAuth.Clients.Access_Token_Access := Security.OAuth.Clients.Create_Access_Token
--
--  The principal is then stored in a security context.
--
--  @include security-contexts.ads
--
--  [Security_Policies Security Policies]
--  [Security_Auth OpenID]
--  [Security_OAuth OAuth]
--
package Security is

   pragma Preelaborate;

   --  ------------------------------
   --  Principal
   --  ------------------------------
   type Principal is limited interface;
   type Principal_Access is access all Principal'Class;

   --  Get the principal name.
   function Get_Name (From : in Principal) return String is abstract;

end Security;

-----------------------------------------------------------------------
--  security -- Security
--  Copyright (C) 2010, 2011, 2012, 2015 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------

--  == Introduction ==
--  The <tt>Security</tt> package provides a security framework that allows
--  an application to use OpenID or OAuth security frameworks.  This security
--  framework was first developed within the Ada Server Faces project.
--  This package defines abstractions that are close or similar to Java
--  security package.
--
--  The security framework uses the following abstractions:
--
--  === Policy and policy manager ===
--  The <tt>Policy</tt> defines and implements the set of security rules that specify how to
--  protect the system or resources.  The <tt>Policy_Manager</tt> maintains the security policies.
--
--  === Principal ===
--  The <tt>Principal</tt> is the entity that can be authenticated.  A principal is obtained
--  after successful authentication of a user or of a system through an authorization process.
--  The OpenID or OAuth authentication processes generate such security principal.
--
--  === Permission ===
--  The <tt>Permission</tt> represents an access to a system or application resource.
--  A permission is checked by using the security policy manager.  The policy manager uses a
--  security controller to enforce the permission.
--
--  === Security Context ===
--  The <tt>Security_Context</tt> holds the contextual information that the security controller
--  can use to verify the permission.  The security context is associated with a principal and
--  a set of policy context.
--
--  == Overview ==
--  An application will create a security policy manager and register one or several security
--  policies (yellow).  The framework defines a simple role based security policy and an URL
--  security policy intended to provide security in web applications.  The security policy manager
--  reads some security policy configuration file which allows the security policies to configure
--  and create the security controllers.  These controllers will enforce the security according
--  to the application security rules.  All these components are built only once when
--  an application starts.
--
--  A user is authenticated through an authentication system which creates a <tt>Principal</tt>
--  instance that identifies the user (green).  The security framework provides two authentication
--  systems: OpenID and OAuth.
--
--  [images/ModelOverview.png]
--
--  When a permission must be enforced, a security context is created and linked to the
--  <tt>Principal</tt> instance (blue).  Additional security policy context can be added depending
--  on the application context.  To check the permission, the security policy manager is called
--  and it will ask a security controller to verify the permission.
--
--  The framework allows an application to plug its own security policy, its own policy context,
--  its own principal and authentication mechanism.
--
--  @include security-permissions.ads
--
--  == Principal ==
--  A principal is created by using either the [Security_Auth OpenID],
--  the [Security_OAuth OAuth] or another authentication mechanism.  The authentication produces
--  an object that must implement the <tt>Principal</tt> interface.  For example:
--
--    P : Security.Auth.Principal_Access := Security.Auth.Create_Principal (Auth);
--
--  or
--
--    P : Security.OAuth.Clients.Access_Token_Access := Security.OAuth.Clients.Create_Access_Token
--
--  The principal is then stored in a security context.
--
--  @include security-contexts.ads
--
--  [Security_Policies Security Policies]
--  [Security_Auth OpenID]
--  [Security_OAuth OAuth]
--
package Security is

   pragma Preelaborate;

   --  ------------------------------
   --  Principal
   --  ------------------------------
   type Principal is limited interface;
   type Principal_Access is access all Principal'Class;

   --  Get the principal name.
   function Get_Name (From : in Principal) return String is abstract;

end Security;

Update the documentation

Update the documentation