-----------------------------------------------------------------------
--  security-permissions -- Definition of permissions
--  Copyright (C) 2010, 2011 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.Containers.Indefinite_Hashed_Maps;
with Ada.Strings.Hash;

with Util.Log.Loggers;

--  The <b>Security.Permissions</b> package defines the different permissions that can be
--  checked by the access control manager.
package body Security.Permissions is

   use Util.Log;

   --  ------------------------------
   --  Permission Manager
   --  ------------------------------

   --  The logger
   Log : constant Loggers.Logger := Loggers.Create ("Security.Permissions");

   --  A global map to translate a string to a permission index.
   package Permission_Maps is
     new Ada.Containers.Indefinite_Hashed_Maps (Key_Type        => String,
                                                Element_Type    => Permission_Index,
                                                Hash            => Ada.Strings.Hash,
                                                Equivalent_Keys => "=",
                                                "="             => "=");

   protected type Global_Index is
      --  Get the permission index
      function Get_Permission_Index (Name : in String) return Permission_Index;

      --  Get the last permission index registered in the global permission map.
      function Get_Last_Permission_Index return Permission_Index;

      procedure Add_Permission (Name  : in String;
                                Index : out Permission_Index);
   private
      Map        : Permission_Maps.Map;
      Next_Index : Permission_Index := Permission_Index'First;
   end Global_Index;

   protected body Global_Index is
      function Get_Permission_Index (Name : in String) return Permission_Index is
         Pos : constant Permission_Maps.Cursor := Map.Find (Name);
      begin
         if Permission_Maps.Has_Element (Pos) then
            return Permission_Maps.Element (Pos);
         else
            raise Invalid_Name with "There is no permission '" & Name & "'";
         end if;
      end Get_Permission_Index;

      --  Get the last permission index registered in the global permission map.
      function Get_Last_Permission_Index return Permission_Index is
      begin
         return Next_Index;
      end Get_Last_Permission_Index;

      procedure Add_Permission (Name  : in String;
                                Index : out Permission_Index) is
         Pos : constant Permission_Maps.Cursor := Map.Find (Name);
      begin
         if Permission_Maps.Has_Element (Pos) then
            Index := Permission_Maps.Element (Pos);
         else
            Index := Next_Index;
            Log.Debug ("Creating permission index {1} for {0}",
                       Name, Permission_Index'Image (Index));
            Map.Insert (Name, Index);
            Next_Index := Next_Index + 1;
         end if;
      end Add_Permission;

   end Global_Index;

   Permission_Indexes : Global_Index;

   --  ------------------------------
   --  Get the permission index associated with the name.
   --  ------------------------------
   function Get_Permission_Index (Name : in String) return Permission_Index is
   begin
      return Permission_Indexes.Get_Permission_Index (Name);
   end Get_Permission_Index;

   --  ------------------------------
   --  Get the last permission index registered in the global permission map.
   --  ------------------------------
   function Get_Last_Permission_Index return Permission_Index is
   begin
      return Permission_Indexes.Get_Last_Permission_Index;
   end Get_Last_Permission_Index;

   --  ------------------------------
   --  Add the permission name and allocate a unique permission index.
   --  ------------------------------
   procedure Add_Permission (Name  : in String;
                             Index : out Permission_Index) is
   begin
      Permission_Indexes.Add_Permission (Name, Index);
   end Add_Permission;

   package body Permission_ACL is
      P : Permission_Index;

      function Permission return Permission_Index is
      begin
         return P;
      end Permission;

   begin
      Add_Permission (Name => Name, Index => P);
   end Permission_ACL;

end Security.Permissions;

-----------------------------------------------------------------------
--  security-permissions -- Definition of permissions
--  Copyright (C) 2010, 2011 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.Containers.Indefinite_Hashed_Maps;
with Ada.Strings.Hash;

with Util.Log.Loggers;

--  The <b>Security.Permissions</b> package defines the different permissions that can be
--  checked by the access control manager.
package body Security.Permissions is

   use Util.Log;

   --  ------------------------------
   --  Permission Manager
   --  ------------------------------

   --  The logger
   Log : constant Loggers.Logger := Loggers.Create ("Security.Permissions");

   --  A global map to translate a string to a permission index.
   package Permission_Maps is
     new Ada.Containers.Indefinite_Hashed_Maps (Key_Type        => String,
                                                Element_Type    => Permission_Index,
                                                Hash            => Ada.Strings.Hash,
                                                Equivalent_Keys => "=",
                                                "="             => "=");

   protected type Global_Index is
      --  Get the permission index
      function Get_Permission_Index (Name : in String) return Permission_Index;

      --  Get the last permission index registered in the global permission map.
      function Get_Last_Permission_Index return Permission_Index;

      procedure Add_Permission (Name  : in String;
                                Index : out Permission_Index);
   private
      Map        : Permission_Maps.Map;
      Next_Index : Permission_Index := Permission_Index'First;
   end Global_Index;

   protected body Global_Index is
      function Get_Permission_Index (Name : in String) return Permission_Index is
         Pos : constant Permission_Maps.Cursor := Map.Find (Name);
      begin
         if Permission_Maps.Has_Element (Pos) then
            return Permission_Maps.Element (Pos);
         else
            raise Invalid_Name with "There is no permission '" & Name & "'";
         end if;
      end Get_Permission_Index;

      --  Get the last permission index registered in the global permission map.
      function Get_Last_Permission_Index return Permission_Index is
      begin
         return Next_Index;
      end Get_Last_Permission_Index;

      procedure Add_Permission (Name  : in String;
                                Index : out Permission_Index) is
         Pos : constant Permission_Maps.Cursor := Map.Find (Name);
      begin
         if Permission_Maps.Has_Element (Pos) then
            Index := Permission_Maps.Element (Pos);
         else
            Index := Next_Index;
            Log.Debug ("Creating permission index {1} for {0}",
                       Name, Permission_Index'Image (Index));
            Map.Insert (Name, Index);
            Next_Index := Next_Index + 1;
         end if;
      end Add_Permission;

   end Global_Index;

   Permission_Indexes : Global_Index;

   --  ------------------------------
   --  Get the permission index associated with the name.
   --  ------------------------------
   function Get_Permission_Index (Name : in String) return Permission_Index is
   begin
      return Permission_Indexes.Get_Permission_Index (Name);
   end Get_Permission_Index;

   --  ------------------------------
   --  Get the last permission index registered in the global permission map.
   --  ------------------------------
   function Get_Last_Permission_Index return Permission_Index is
   begin
      return Permission_Indexes.Get_Last_Permission_Index;
   end Get_Last_Permission_Index;

   --  ------------------------------
   --  Add the permission name and allocate a unique permission index.
   --  ------------------------------
   procedure Add_Permission (Name  : in String;
                             Index : out Permission_Index) is
   begin
      Permission_Indexes.Add_Permission (Name, Index);
   end Add_Permission;

   package body Definition is
      P : Permission_Index;

      function Permission return Permission_Index is
      begin
         return P;
      end Permission;

   begin
      Add_Permission (Name => Name, Index => P);
   end Definition;

end Security.Permissions;

Rename Permission_ACL into Definition

Rename Permission_ACL into Definition


-----------------------------------------------------------------------
--  awa-questions-tests -- Unit tests for questions module
--  Copyright (C) 2018 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.Test_Caller;
with Util.Strings;

with Servlet.Streams;
with ASF.Requests.Mockup;
with ASF.Responses.Mockup;
with ASF.Tests;
with AWA.Tests.Helpers.Users;

package body AWA.Questions.Tests is

   use Ada.Strings.Unbounded;
   use AWA.Tests;

   package Caller is new Util.Test_Caller (Test, "Questions");

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test AWA.Questions.Beans.Load_List (Anonymous)",
                       Test_Anonymous_Access'Access);
      Caller.Add_Test (Suite, "Test AWA.Questions.Beans.Save",
                       Test_Create_Question'Access);
      Caller.Add_Test (Suite, "Test AWA.Questions.Beans.Load (missing)",
                       Test_Missing_Page'Access);
   end Add_Tests;

   --  ------------------------------
   --  Get some access on the wiki as anonymous users.
   --  ------------------------------
   procedure Verify_Anonymous (T     : in out Test;
                               Page  : in String;
                               Title : in String) is
      function Get_Link (Title : in String) return String;

      Request   : ASF.Requests.Mockup.Request;
      Reply     : ASF.Responses.Mockup.Response;

      function Get_Link (Title : in String) return String is
         Stream  : Servlet.Streams.Print_Stream := Reply.Get_Output_Stream;
         Content : Ada.Strings.Unbounded.Unbounded_String;
      begin
         Reply.Read_Content (Content);
         Stream.Write (Content);
         return AWA.Tests.Helpers.Extract_Link (To_String (Content), Title);
      end Get_Link;

   begin
      ASF.Tests.Do_Get (Request, Reply, "/questions/list.html",
                        "question-list.html");
      ASF.Tests.Assert_Contains (T, "<title>Questions</title>", Reply,
                                 "Questions list page is invalid");

      ASF.Tests.Do_Get (Request, Reply, "/questions/tags/tag",
                        "question-list-tagged.html");
      ASF.Tests.Assert_Contains (T, "<title>Questions</title>", Reply,
                                 "Questions tag page is invalid");

      if Page'Length > 0 then
         ASF.Tests.Do_Get (Request, Reply, "/questions/view/" & Page,
                           "question-page-" & Page & ".html");
         ASF.Tests.Assert_Contains (T, Title, Reply,
                                    "Question page " & Page & " is invalid");
         ASF.Tests.Assert_Contains (T, "<h2>" & Title & "</h2>", Reply,
                                    "Question page " & Page & " is invalid");
         ASF.Tests.Assert_Matches (T, ".input type=.hidden. name=.question-id. "
                                   & "value=.[0-9]+. id=.question-id.../input", Reply,
                                    "Question page " & Page & " is invalid");
      end if;
   end Verify_Anonymous;

   --  ------------------------------
   --  Verify that the question list contains the given question.
   --  ------------------------------
   procedure Verify_List_Contains (T     : in out Test;
                                   Id    : in String;
                                   Title : in String) is
      Request   : ASF.Requests.Mockup.Request;
      Reply     : ASF.Responses.Mockup.Response;
   begin
      ASF.Tests.Do_Get (Request, Reply, "/questions/list.html",
                        "question-list-recent.html");
      ASF.Tests.Assert_Contains (T, "Questions", Reply,
                                 "List of questions page is invalid");
      ASF.Tests.Assert_Contains (T, "/questions/view/" & Id, Reply,
                                 "List of questions page does not reference the page");
      ASF.Tests.Assert_Contains (T, Title, Reply,
                                 "List of questions page does not contain the question");

   end Verify_List_Contains;

   --  ------------------------------
   --  Test access to the question as anonymous user.
   --  ------------------------------
   procedure Test_Anonymous_Access (T : in out Test) is
   begin
      T.Verify_Anonymous ("", "");
   end Test_Anonymous_Access;

   --  ------------------------------
   --  Test creation of question by simulating web requests.
   --  ------------------------------
   procedure Test_Create_Question (T : in out Test) is
      procedure Create_Question (Title : in String);

      Request   : ASF.Requests.Mockup.Request;
      Reply     : ASF.Responses.Mockup.Response;
      Uuid      : constant String := Util.Tests.Get_Uuid;

      procedure Create_Question (Title : in String) is
      begin
         Request.Set_Parameter ("post", "1");
         Request.Set_Parameter ("title", Title);
         Request.Set_Parameter ("text", "# Main title" & ASCII.LF
                                & "* The question content." & ASCII.LF
                                & "* Second item." & ASCII.LF);
         Request.Set_Parameter ("save", "1");
         ASF.Tests.Do_Post (Request, Reply, "/questions/ask.html", "questions-ask.html");

         T.Question_Ident := Helpers.Extract_Redirect (Reply, "/asfunit/questions/view/");

         Util.Tests.Assert_Matches (T, "[0-9]+$", To_String (T.Question_Ident),
                                   "Invalid redirect after question creation");

         --  Remove the 'question' bean from the request so that we get a new instance
         --  for the next call.
         Request.Remove_Attribute ("question");
      end Create_Question;

   begin
      AWA.Tests.Helpers.Users.Login ("test-question@test.com", Request);

      Create_Question ("Question 1 page title1");
      T.Verify_List_Contains (To_String (T.Question_Ident), "Question 1 page title1");
      T.Verify_Anonymous (To_String (T.Question_Ident), "Question 1 page title1");

      Create_Question ("Question 2 page title2");
      T.Verify_List_Contains (To_String (T.Question_Ident), "Question 2 page title2");
      T.Verify_Anonymous (To_String (T.Question_Ident), "Question 2 page title2");

      Create_Question ("Question 3 page title3");
      T.Verify_List_Contains (To_String (T.Question_Ident), "Question 3 page title3");
      T.Verify_Anonymous (To_String (T.Question_Ident), "Question 3 page title3");

   end Test_Create_Question;

   --  ------------------------------
   --  Test getting a wiki page which does not exist.
   --  ------------------------------
   procedure Test_Missing_Page (T : in out Test) is
      Request   : ASF.Requests.Mockup.Request;
      Reply     : ASF.Responses.Mockup.Response;
   begin
      ASF.Tests.Do_Get (Request, Reply, "/questions/view.html?id=12345678",
                        "question-page-missing.html");
      ASF.Tests.Assert_Matches (T, "<title>Question not found</title>", Reply,
                                "Question page title '12345678' is invalid",
                                ASF.Responses.SC_NOT_FOUND);
      ASF.Tests.Assert_Matches (T, "question.*removed", Reply,
                                "Question page content '12345678' is invalid",
                                ASF.Responses.SC_NOT_FOUND);
   end Test_Missing_Page;

end AWA.Questions.Tests;

-----------------------------------------------------------------------
--  awa-questions-tests -- Unit tests for questions module
--  Copyright (C) 2018 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.Test_Caller;
with Util.Strings;

with Servlet.Streams;
with ASF.Requests.Mockup;
with ASF.Responses.Mockup;
with ASF.Tests;
with AWA.Tests.Helpers.Users;

package body AWA.Questions.Tests is

   use Ada.Strings.Unbounded;
   use AWA.Tests;

   package Caller is new Util.Test_Caller (Test, "Questions");

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test AWA.Questions.Beans.Load_List (Anonymous)",
                       Test_Anonymous_Access'Access);
      Caller.Add_Test (Suite, "Test AWA.Questions.Beans.Save",
                       Test_Create_Question'Access);
      Caller.Add_Test (Suite, "Test AWA.Questions.Beans.Load (missing)",
                       Test_Missing_Page'Access);
      Caller.Add_Test (Suite, "Test AWA.Questions.Beans.Save (answer)",
                       Test_Answer_Question'Access);
   end Add_Tests;

   --  ------------------------------
   --  Get some access on the wiki as anonymous users.
   --  ------------------------------
   procedure Verify_Anonymous (T     : in out Test;
                               Page  : in String;
                               Title : in String) is
      function Get_Link (Title : in String) return String;

      Request   : ASF.Requests.Mockup.Request;
      Reply     : ASF.Responses.Mockup.Response;

      function Get_Link (Title : in String) return String is
         Stream  : Servlet.Streams.Print_Stream := Reply.Get_Output_Stream;
         Content : Ada.Strings.Unbounded.Unbounded_String;
      begin
         Reply.Read_Content (Content);
         Stream.Write (Content);
         return AWA.Tests.Helpers.Extract_Link (To_String (Content), Title);
      end Get_Link;

   begin
      ASF.Tests.Do_Get (Request, Reply, "/questions/list.html",
                        "question-list.html");
      ASF.Tests.Assert_Contains (T, "<title>Questions</title>", Reply,
                                 "Questions list page is invalid");

      ASF.Tests.Do_Get (Request, Reply, "/questions/tags/tag",
                        "question-list-tagged.html");
      ASF.Tests.Assert_Contains (T, "<title>Questions</title>", Reply,
                                 "Questions tag page is invalid");

      if Page'Length > 0 then
         ASF.Tests.Do_Get (Request, Reply, "/questions/view/" & Page,
                           "question-page-" & Page & ".html");
         ASF.Tests.Assert_Contains (T, Title, Reply,
                                    "Question page " & Page & " is invalid");
         ASF.Tests.Assert_Matches (T, ".input type=.hidden. name=.question-id. "
                                   & "value=.[0-9]+. id=.question-id.../input", Reply,
                                    "Question page " & Page & " is invalid");
      end if;
   end Verify_Anonymous;

   --  ------------------------------
   --  Verify that the question list contains the given question.
   --  ------------------------------
   procedure Verify_List_Contains (T     : in out Test;
                                   Id    : in String;
                                   Title : in String) is
      Request   : ASF.Requests.Mockup.Request;
      Reply     : ASF.Responses.Mockup.Response;
   begin
      ASF.Tests.Do_Get (Request, Reply, "/questions/list.html",
                        "question-list-recent.html");
      ASF.Tests.Assert_Contains (T, "Questions", Reply,
                                 "List of questions page is invalid");
      ASF.Tests.Assert_Contains (T, "/questions/view/" & Id, Reply,
                                 "List of questions page does not reference the page");
      ASF.Tests.Assert_Contains (T, Title, Reply,
                                 "List of questions page does not contain the question");

   end Verify_List_Contains;

   --  ------------------------------
   --  Test access to the question as anonymous user.
   --  ------------------------------
   procedure Test_Anonymous_Access (T : in out Test) is
   begin
      T.Verify_Anonymous ("", "");
   end Test_Anonymous_Access;

   --  ------------------------------
   --  Test creation of question by simulating web requests.
   --  ------------------------------
   procedure Test_Create_Question (T : in out Test) is
      procedure Create_Question (Title : in String);

      Request   : ASF.Requests.Mockup.Request;
      Reply     : ASF.Responses.Mockup.Response;
      Uuid      : constant String := Util.Tests.Get_Uuid;

      procedure Create_Question (Title : in String) is
      begin
         Request.Set_Parameter ("post", "1");
         Request.Set_Parameter ("title", Title);
         Request.Set_Parameter ("text", "# Main title" & ASCII.LF
                                & "* The question content." & ASCII.LF
                                & "* Second item." & ASCII.LF);
         Request.Set_Parameter ("save", "1");
         ASF.Tests.Do_Post (Request, Reply, "/questions/ask.html", "questions-ask.html");

         T.Question_Ident := Helpers.Extract_Redirect (Reply, "/asfunit/questions/view/");

         Util.Tests.Assert_Matches (T, "[0-9]+$", To_String (T.Question_Ident),
                                   "Invalid redirect after question creation");

         --  Remove the 'question' bean from the request so that we get a new instance
         --  for the next call.
         Request.Remove_Attribute ("question");
      end Create_Question;

   begin
      AWA.Tests.Helpers.Users.Login ("test-question@test.com", Request);

      Create_Question ("Question 1 page title1");
      T.Verify_List_Contains (To_String (T.Question_Ident), "Question 1 page title1");
      T.Verify_Anonymous (To_String (T.Question_Ident), "Question 1 page title1");

      Create_Question ("Question 2 page title2");
      T.Verify_List_Contains (To_String (T.Question_Ident), "Question 2 page title2");
      T.Verify_Anonymous (To_String (T.Question_Ident), "Question 2 page title2");

      Create_Question ("Question 3 page title3");
      T.Verify_List_Contains (To_String (T.Question_Ident), "Question 3 page title3");
      T.Verify_Anonymous (To_String (T.Question_Ident), "Question 3 page title3");

   end Test_Create_Question;

   --  ------------------------------
   --  Test getting a wiki page which does not exist.
   --  ------------------------------
   procedure Test_Missing_Page (T : in out Test) is
      Request   : ASF.Requests.Mockup.Request;
      Reply     : ASF.Responses.Mockup.Response;
   begin
      ASF.Tests.Do_Get (Request, Reply, "/questions/view.html?id=12345678",
                        "question-page-missing.html");
      ASF.Tests.Assert_Matches (T, "<title>Question not found</title>", Reply,
                                "Question page title '12345678' is invalid",
                                ASF.Responses.SC_NOT_FOUND);
      ASF.Tests.Assert_Matches (T, "question.*removed", Reply,
                                "Question page content '12345678' is invalid",
                                ASF.Responses.SC_NOT_FOUND);
   end Test_Missing_Page;

   --  ------------------------------
   --  Test answer of question by simulating web requests.
   --  ------------------------------
   procedure Test_Answer_Question (T : in out Test) is
      procedure Create_Answer (Content : in String);

      Request   : ASF.Requests.Mockup.Request;
      Reply     : ASF.Responses.Mockup.Response;

      procedure Create_Answer (Content : in String) is
      begin
         Request.Set_Parameter ("post", "1");
         Request.Set_Parameter ("question-id", To_String (T.Question_Ident));
         Request.Set_Parameter ("answer-id", "");
         Request.Set_Parameter ("text", Content);
         Request.Set_Parameter ("save", "1");
         ASF.Tests.Do_Post (Request, Reply, "/questions/forms/answer-form.html",
                            "questions-answer.html");

         ASF.Tests.Assert_Contains (T, "/questions/view/" &  To_String (T.Question_Ident),
                                    Reply,
                                    "Answer response is invalid");

         --  Remove the 'question' bean from the request so that we get a new instance
         --  for the next call.
         Request.Remove_Attribute ("answer");
      end Create_Answer;

   begin
      AWA.Tests.Helpers.Users.Login ("test-answer@test.com", Request);

      Create_Answer ("Answer content 1");
      T.Verify_Anonymous (To_String (T.Question_Ident), "Answer content 1");

      Create_Answer ("Answer content 2");
      T.Verify_Anonymous (To_String (T.Question_Ident), "Answer content 1");
      T.Verify_Anonymous (To_String (T.Question_Ident), "Answer content 2");

      Create_Answer ("Answer content 3");
      T.Verify_Anonymous (To_String (T.Question_Ident), "Answer content 1");
      T.Verify_Anonymous (To_String (T.Question_Ident), "Answer content 2");
      T.Verify_Anonymous (To_String (T.Question_Ident), "Answer content 3");

   end Test_Answer_Question;

end AWA.Questions.Tests;

Implement Test_Answer_Question to check answering a question


-----------------------------------------------------------------------
--  util-properties-json -- read json files into properties
--  Copyright (C) 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 Util.Serialize.IO.JSON;
with Util.Stacks;
with Util.Beans.Objects;
package body Util.Properties.JSON is

   type Natural_Access is access all Natural;

   package Length_Stack is new Util.Stacks (Element_Type        => Natural,
                                            Element_Type_Access => Natural_Access);

   type Parser is new Util.Serialize.IO.JSON.Parser with record
      Base_Name        : Ada.Strings.Unbounded.Unbounded_String;
      Lengths          : Length_Stack.Stack;
      Separator        : Ada.Strings.Unbounded.Unbounded_String;
      Separator_Length : Natural;
   end record;

   --  Start a new object associated with the given name.  This is called when
   --  the '{' is reached.  The reader must be updated so that the next
   --  Set_Member procedure will associate the name/value pair on the
   --  new object.
   overriding
   procedure Start_Object (Handler : in out Parser;
                           Name    : in String);

   --  Finish an object associated with the given name.  The reader must be
   --  updated to be associated with the previous object.
   overriding
   procedure Finish_Object (Handler : in out Parser;
                            Name    : in String);

   overriding
   procedure Start_Array (Handler : in out Parser;
                          Name    : in String);

   overriding
   procedure Finish_Array (Handler : in out Parser;
                           Name    : in String;
                           Count   : in Natural);

   --  -----------------------
   --  Start a new object associated with the given name.  This is called when
   --  the '{' is reached.  The reader must be updated so that the next
   --  Set_Member procedure will associate the name/value pair on the
   --  new object.
   --  -----------------------
   overriding
   procedure Start_Object (Handler : in out Parser;
                           Name    : in String) is
   begin
      if Name'Length > 0 then
         Ada.Strings.Unbounded.Append (Handler.Base_Name, Name);
         Ada.Strings.Unbounded.Append (Handler.Base_Name, Handler.Separator);
         Length_Stack.Push (Handler.Lengths);
         Length_Stack.Current (Handler.Lengths).all := Name'Length + Handler.Separator_Length;
      end if;
   end Start_Object;

   --  -----------------------
   --  Finish an object associated with the given name.  The reader must be
   --  updated to be associated with the previous object.
   --  -----------------------
   overriding
   procedure Finish_Object (Handler : in out Parser;
                            Name    : in String) is
      Len : constant Natural := Ada.Strings.Unbounded.Length (Handler.Base_Name);
   begin
      if Name'Length > 0 then
         Ada.Strings.Unbounded.Delete (Handler.Base_Name,
                                       Len - Name'Length - Handler.Separator_Length + 1, Len);
      end if;
   end Finish_Object;

   overriding
   procedure Start_Array (Handler : in out Parser;
                          Name    : in String) is
   begin
      Handler.Start_Object (Name);
      Util.Serialize.IO.JSON.Parser (Handler).Start_Array (Name);
   end Start_Array;

   overriding
   procedure Finish_Array (Handler : in out Parser;
                           Name    : in String;
                           Count   : in Natural) is
   begin
      Parser'Class (Handler).Set_Member ("length", Util.Beans.Objects.To_Object (Count));
      Handler.Finish_Object (Name);
      Util.Serialize.IO.JSON.Parser (Handler).Finish_Array (Name, Count);
   end Finish_Array;

   --  -----------------------
   --  Parse the JSON content and put the flattened content in the property manager.
   --  -----------------------
   procedure Parse_JSON (Manager : in out Util.Properties.Manager'Class;
                         Content : in String;
                         Flatten_Separator : in String := ".") is

      type Local_Parser is new Parser with record
         Manager : access Util.Properties.Manager'Class;
      end record;

      --  Set the name/value pair on the current object.  For each active mapping,
      --  find whether a rule matches our name and execute it.
      overriding
      procedure Set_Member (Handler   : in out Local_Parser;
                            Name      : in String;
                            Value     : in Util.Beans.Objects.Object;
                            Attribute : in Boolean := False);

      --  -----------------------
      --  Set the name/value pair on the current object.  For each active mapping,
      --  find whether a rule matches our name and execute it.
      --  -----------------------
      overriding
      procedure Set_Member (Handler   : in out Local_Parser;
                            Name      : in String;
                            Value     : in Util.Beans.Objects.Object;
                            Attribute : in Boolean := False) is
         pragma Unreferenced (Attribute);
      begin
         Handler.Manager.Set (Ada.Strings.Unbounded.To_String (Handler.Base_Name) & Name,
                              Util.Beans.Objects.To_String (Value));
      end Set_Member;

      P : Local_Parser;
   begin
      P.Separator        := Ada.Strings.Unbounded.To_Unbounded_String (Flatten_Separator);
      P.Separator_Length := Flatten_Separator'Length;
      P.Manager          := Manager'Access;
      P.Parse_String (Content);
      if P.Has_Error then
         raise Util.Serialize.IO.Parse_Error;
      end if;
   end Parse_JSON;

   --  -----------------------
   --  Read the JSON file into the property manager.
   --  The JSON content is flatten into Flatten the JSON content and add the properties.
   --  -----------------------
   procedure Read_JSON (Manager : in out Util.Properties.Manager'Class;
                        Path    : in String;
                        Flatten_Separator : in String := ".") is

      type Local_Parser is new Parser with record
         Manager : access Util.Properties.Manager'Class;
      end record;

      --  Set the name/value pair on the current object.  For each active mapping,
      --  find whether a rule matches our name and execute it.
      overriding
      procedure Set_Member (Handler   : in out Local_Parser;
                            Name      : in String;
                            Value     : in Util.Beans.Objects.Object;
                            Attribute : in Boolean := False);

      --  -----------------------
      --  Set the name/value pair on the current object.  For each active mapping,
      --  find whether a rule matches our name and execute it.
      --  -----------------------
      overriding
      procedure Set_Member (Handler   : in out Local_Parser;
                            Name      : in String;
                            Value     : in Util.Beans.Objects.Object;
                            Attribute : in Boolean := False) is
         pragma Unreferenced (Attribute);
      begin
         Handler.Manager.Set (Ada.Strings.Unbounded.To_String (Handler.Base_Name) & Name,
                              Util.Beans.Objects.To_String (Value));
      end Set_Member;

      P : Local_Parser;
   begin
      P.Manager   := Manager'Access;
      P.Separator := Ada.Strings.Unbounded.To_Unbounded_String (Flatten_Separator);
      P.Separator_Length := Flatten_Separator'Length;
      P.Parse (Path);
      if P.Has_Error then
         raise Util.Serialize.IO.Parse_Error;
      end if;
   end Read_JSON;

end Util.Properties.JSON;

-----------------------------------------------------------------------
--  util-properties-json -- read json files into properties
--  Copyright (C) 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 Util.Serialize.IO.JSON;
with Util.Stacks;
with Util.Beans.Objects;
package body Util.Properties.JSON is

   type Natural_Access is access all Natural;

   package Length_Stack is new Util.Stacks (Element_Type        => Natural,
                                            Element_Type_Access => Natural_Access);

   type Parser is abstract limited new Util.Serialize.IO.Reader with record
      Base_Name        : Ada.Strings.Unbounded.Unbounded_String;
      Lengths          : Length_Stack.Stack;
      Separator        : Ada.Strings.Unbounded.Unbounded_String;
      Separator_Length : Natural;
   end record;

   --  Start a new object associated with the given name.  This is called when
   --  the '{' is reached.  The reader must be updated so that the next
   --  Set_Member procedure will associate the name/value pair on the
   --  new object.
   overriding
   procedure Start_Object (Handler : in out Parser;
                           Name    : in String);

   --  Finish an object associated with the given name.  The reader must be
   --  updated to be associated with the previous object.
   overriding
   procedure Finish_Object (Handler : in out Parser;
                            Name    : in String);

   overriding
   procedure Start_Array (Handler : in out Parser;
                          Name    : in String);

   overriding
   procedure Finish_Array (Handler : in out Parser;
                           Name    : in String;
                           Count   : in Natural);

   --  Report an error while parsing the input stream.  The error message will be reported
   --  on the logger associated with the parser.  The parser will be set as in error so that
   --  the Has_Error function will return True after parsing the whole file.
   procedure Error (Handler : in out Parser;
                    Message : in String);

   --  -----------------------
   --  Start a new object associated with the given name.  This is called when
   --  the '{' is reached.  The reader must be updated so that the next
   --  Set_Member procedure will associate the name/value pair on the
   --  new object.
   --  -----------------------
   overriding
   procedure Start_Object (Handler : in out Parser;
                           Name    : in String) is
   begin
      if Name'Length > 0 then
         Ada.Strings.Unbounded.Append (Handler.Base_Name, Name);
         Ada.Strings.Unbounded.Append (Handler.Base_Name, Handler.Separator);
         Length_Stack.Push (Handler.Lengths);
         Length_Stack.Current (Handler.Lengths).all := Name'Length + Handler.Separator_Length;
      end if;
   end Start_Object;

   --  -----------------------
   --  Finish an object associated with the given name.  The reader must be
   --  updated to be associated with the previous object.
   --  -----------------------
   overriding
   procedure Finish_Object (Handler : in out Parser;
                            Name    : in String) is
      Len : constant Natural := Ada.Strings.Unbounded.Length (Handler.Base_Name);
   begin
      if Name'Length > 0 then
         Ada.Strings.Unbounded.Delete (Handler.Base_Name,
                                       Len - Name'Length - Handler.Separator_Length + 1, Len);
      end if;
   end Finish_Object;

   overriding
   procedure Start_Array (Handler : in out Parser;
                          Name    : in String) is
   begin
      Handler.Start_Object (Name);
--      Util.Serialize.IO.JSON.Parser (Handler).Start_Array (Name);
   end Start_Array;

   overriding
   procedure Finish_Array (Handler : in out Parser;
                           Name    : in String;
                           Count   : in Natural) is
   begin
      Parser'Class (Handler).Set_Member ("length", Util.Beans.Objects.To_Object (Count));
      Handler.Finish_Object (Name);
--      Util.Serialize.IO.JSON.Parser (Handler).Finish_Array (Name, Count);
   end Finish_Array;

   --  Report an error while parsing the input stream.  The error message will be reported
   --  on the logger associated with the parser.  The parser will be set as in error so that
   --  the Has_Error function will return True after parsing the whole file.
   procedure Error (Handler : in out Parser;
                    Message : in String) is
   begin
      null;
   end Error;

   --  -----------------------
   --  Parse the JSON content and put the flattened content in the property manager.
   --  -----------------------
   procedure Parse_JSON (Manager : in out Util.Properties.Manager'Class;
                         Content : in String;
                         Flatten_Separator : in String := ".") is

      type Local_Parser is new Parser with record
         Manager : access Util.Properties.Manager'Class;
      end record;

      --  Set the name/value pair on the current object.  For each active mapping,
      --  find whether a rule matches our name and execute it.
      overriding
      procedure Set_Member (Handler   : in out Local_Parser;
                            Name      : in String;
                            Value     : in Util.Beans.Objects.Object;
                            Attribute : in Boolean := False);

      --  -----------------------
      --  Set the name/value pair on the current object.  For each active mapping,
      --  find whether a rule matches our name and execute it.
      --  -----------------------
      overriding
      procedure Set_Member (Handler   : in out Local_Parser;
                            Name      : in String;
                            Value     : in Util.Beans.Objects.Object;
                            Attribute : in Boolean := False) is
         pragma Unreferenced (Attribute);
      begin
         Handler.Manager.Set (Ada.Strings.Unbounded.To_String (Handler.Base_Name) & Name,
                              Util.Beans.Objects.To_String (Value));
      end Set_Member;

      P : Local_Parser;
      R : Util.Serialize.IO.JSON.Parser;
   begin
      P.Separator        := Ada.Strings.Unbounded.To_Unbounded_String (Flatten_Separator);
      P.Separator_Length := Flatten_Separator'Length;
      P.Manager          := Manager'Access;
      R.Parse_String (Content, P);
      if R.Has_Error then
         raise Util.Serialize.IO.Parse_Error;
      end if;
   end Parse_JSON;

   --  -----------------------
   --  Read the JSON file into the property manager.
   --  The JSON content is flatten into Flatten the JSON content and add the properties.
   --  -----------------------
   procedure Read_JSON (Manager : in out Util.Properties.Manager'Class;
                        Path    : in String;
                        Flatten_Separator : in String := ".") is

      type Local_Parser is new Parser with record
         Manager : access Util.Properties.Manager'Class;
      end record;

      --  Set the name/value pair on the current object.  For each active mapping,
      --  find whether a rule matches our name and execute it.
      overriding
      procedure Set_Member (Handler   : in out Local_Parser;
                            Name      : in String;
                            Value     : in Util.Beans.Objects.Object;
                            Attribute : in Boolean := False);

      --  -----------------------
      --  Set the name/value pair on the current object.  For each active mapping,
      --  find whether a rule matches our name and execute it.
      --  -----------------------
      overriding
      procedure Set_Member (Handler   : in out Local_Parser;
                            Name      : in String;
                            Value     : in Util.Beans.Objects.Object;
                            Attribute : in Boolean := False) is
         pragma Unreferenced (Attribute);
      begin
         Handler.Manager.Set (Ada.Strings.Unbounded.To_String (Handler.Base_Name) & Name,
                              Util.Beans.Objects.To_String (Value));
      end Set_Member;

      P : Local_Parser;
      R : Util.Serialize.IO.JSON.Parser;
   begin
      P.Manager   := Manager'Access;
      P.Separator := Ada.Strings.Unbounded.To_Unbounded_String (Flatten_Separator);
      P.Separator_Length := Flatten_Separator'Length;
      R.Parse (Path, P);
      if R.Has_Error then
         raise Util.Serialize.IO.Parse_Error;
      end if;
   end Read_JSON;

end Util.Properties.JSON;

Update the JSON properties parser to the new parser/mapper interfaces


-----------------------------------------------------------------------
--  bkp-files -- File and directories
--  Copyright (C) 2014 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 Ada.Strings.Unbounded;
with Util.Encoders.SHA1;
with ADO;
package Babel.Files is

   NO_IDENTIFIER : constant ADO.Identifier := ADO.NO_IDENTIFIER;

   subtype File_Identifier is ADO.Identifier;
   subtype Directory_Identifier is ADO.Identifier;
   subtype File_Size is Long_Long_Integer;
   type File_Mode is mod 2**16;
   type Uid_Type is mod 2**16;
   type Gid_Type is mod 2**16;

   type File_Type is private;
   type File_Type_Array is array (Positive range <>) of File_Type;
   type File_Type_Array_Access is access all File_Type_Array;

   type Directory_Type is private;
   type Directory_Type_Array is array (Positive range <>) of Directory_Type;
   type Directory_Type_Array_Access is access all Directory_Type_Array;

   NO_DIRECTORY : constant Directory_Type;
   NO_FILE      : constant File_Type;

   type Status_Type is mod 2**16;

   --  The file was modified.
   FILE_MODIFIED : constant Status_Type := 16#0001#;

   --  There was some error while processing this file.
   FILE_ERROR    : constant Status_Type := 16#8000#;

   --  The SHA1 signature for the file is known and valid.
   FILE_HAS_SHA1 : constant Status_Type := 16#0002#;

   --  Allocate a File_Type entry with the given name for the directory.
   function Allocate (Name : in String;
                      Dir  : in Directory_Type) return File_Type;

   --  Allocate a Directory_Type entry with the given name for the directory.
   function Allocate (Name : in String;
                      Dir  : in Directory_Type) return Directory_Type;

   type File (Len : Positive) is record
      Id     : File_Identifier := NO_IDENTIFIER;
      Size   : File_Size       := 0;
      Dir    : Directory_Type  := NO_DIRECTORY;
      Mode   : File_Mode       := 8#644#;
      User   : Uid_Type        := 0;
      Group  : Gid_Type        := 0;
      Status : Status_Type     := 0;
      Date   : Ada.Calendar.Time;
      SHA1   : Util.Encoders.SHA1.Hash_Array;
      Name   : aliased String (1 .. Len);
   end record;

   --  Return true if the file was modified and need a backup.
   function Is_Modified (Element : in File_Type) return Boolean;

   --  Set the file as modified.
   procedure Set_Modified (Element : in File_Type);

   --  Set the SHA1 signature that was computed for this file.
   --  If the computed signature is different from the current signature,
   --  the FILE_MODIFIED flag is set on the file.  The FILE_HAS_SHA1 flag
   --  is set on the file.
   procedure Set_Signature (Element   : in File_Type;
                            Signature : in Util.Encoders.SHA1.Hash_Array);

   --  Set the file size.  If the new size is different, the FILE_MODIFIED
   --  flag is set on the file.
   procedure Set_Size (Element : in File_Type;
                       Size    : in File_Size);

   --  Return the path for the file.
   function Get_Path (Element : in File_Type) return String;

   --  Return the path for the directory.
   function Get_Path (Element : in Directory_Type) return String;

   --  Return the SHA1 signature computed for the file.
   function Get_SHA1 (Element : in File_Type) return String;

   type File_Container is limited interface;

   --  Add the file with the given name in the container.
   procedure Add_File (Into    : in out File_Container;
                       Element : in File_Type) is abstract;

   --  Add the directory with the given name in the container.
   procedure Add_Directory (Into    : in out File_Container;
                            Element : in Directory_Type) is abstract;

   --  Create a new file instance with the given name in the container.
   function Create (Into : in File_Container;
                    Name : in String) return File_Type is abstract;

   --  Create a new directory instance with the given name in the container.
   function Create (Into : in File_Container;
                    Name : in String) return Directory_Type is abstract;

   --  Find the file with the given name in this file container.
   --  Returns NO_FILE if the file was not found.
   function Find (From : in File_Container;
                  Name : in String) return File_Type is abstract;

   --  Find the directory with the given name in this file container.
   --  Returns NO_DIRECTORY if the directory was not found.
   function Find (From : in File_Container;
                  Name : in String) return Directory_Type is abstract;

   type Default_Container is new File_Container with private;

   --  Add the file with the given name in the container.
   overriding
   procedure Add_File (Into    : in out Default_Container;
                       Element : in File_Type);

   --  Add the directory with the given name in the container.
   overriding
   procedure Add_Directory (Into    : in out Default_Container;
                            Element : in Directory_Type);

   --  Create a new file instance with the given name in the container.
   overriding
   function Create (Into : in Default_Container;
                    Name : in String) return File_Type;

   --  Create a new directory instance with the given name in the container.
   overriding
   function Create (Into : in Default_Container;
                    Name : in String) return Directory_Type;

   --  Find the file with the given name in this file container.
   --  Returns NO_FILE if the file was not found.
   overriding
   function Find (From : in Default_Container;
                  Name : in String) return File_Type;

   --  Find the directory with the given name in this file container.
   --  Returns NO_DIRECTORY if the directory was not found.
   overriding
   function Find (From : in Default_Container;
                  Name : in String) return Directory_Type;

private

   type Directory (Len : Positive) is record
      Id       : Directory_Identifier := NO_IDENTIFIER;
      Parent   : Directory_Type;
      Mode     : File_Mode := 8#755#;
      User     : Uid_Type  := 0;
      Group    : Gid_Type  := 0;
      Files    : File_Type_Array_Access;
      Children : Directory_Type_Array_Access;
      Path     : Ada.Strings.Unbounded.Unbounded_String;
      Name     : aliased String (1 .. Len);
   end record;

   type File_Type is access all File;

   type Directory_Type is access all Directory;

   type Default_Container is new Babel.Files.File_Container with record
      Current : Directory_Type;
   end record;

   NO_DIRECTORY : constant Directory_Type := null;
   NO_FILE      : constant File_Type := null;

end Babel.Files;

-----------------------------------------------------------------------
--  bkp-files -- File and directories
--  Copyright (C) 2014 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 Ada.Strings.Unbounded;
with Ada.Containers.Vectors;

with Util.Encoders.SHA1;
with ADO;
package Babel.Files is

   NO_IDENTIFIER : constant ADO.Identifier := ADO.NO_IDENTIFIER;

   subtype File_Identifier is ADO.Identifier;
   subtype Directory_Identifier is ADO.Identifier;
   subtype File_Size is Long_Long_Integer;
   type File_Mode is mod 2**16;
   type Uid_Type is mod 2**16;
   type Gid_Type is mod 2**16;

   type File_Type is private;
   type File_Type_Array is array (Positive range <>) of File_Type;
   type File_Type_Array_Access is access all File_Type_Array;

   type Directory_Type is private;
   type Directory_Type_Array is array (Positive range <>) of Directory_Type;
   type Directory_Type_Array_Access is access all Directory_Type_Array;

   NO_DIRECTORY : constant Directory_Type;
   NO_FILE      : constant File_Type;

   type Status_Type is mod 2**16;

   --  The file was modified.
   FILE_MODIFIED : constant Status_Type := 16#0001#;

   --  There was some error while processing this file.
   FILE_ERROR    : constant Status_Type := 16#8000#;

   --  The SHA1 signature for the file is known and valid.
   FILE_HAS_SHA1 : constant Status_Type := 16#0002#;

   --  Allocate a File_Type entry with the given name for the directory.
   function Allocate (Name : in String;
                      Dir  : in Directory_Type) return File_Type;

   --  Allocate a Directory_Type entry with the given name for the directory.
   function Allocate (Name : in String;
                      Dir  : in Directory_Type) return Directory_Type;

   type File (Len : Positive) is record
      Id     : File_Identifier := NO_IDENTIFIER;
      Size   : File_Size       := 0;
      Dir    : Directory_Type  := NO_DIRECTORY;
      Mode   : File_Mode       := 8#644#;
      User   : Uid_Type        := 0;
      Group  : Gid_Type        := 0;
      Status : Status_Type     := 0;
      Date   : Ada.Calendar.Time;
      SHA1   : Util.Encoders.SHA1.Hash_Array;
      Name   : aliased String (1 .. Len);
   end record;

   --  Return true if the file was modified and need a backup.
   function Is_Modified (Element : in File_Type) return Boolean;

   --  Set the file as modified.
   procedure Set_Modified (Element : in File_Type);

   --  Set the SHA1 signature that was computed for this file.
   --  If the computed signature is different from the current signature,
   --  the FILE_MODIFIED flag is set on the file.  The FILE_HAS_SHA1 flag
   --  is set on the file.
   procedure Set_Signature (Element   : in File_Type;
                            Signature : in Util.Encoders.SHA1.Hash_Array);

   --  Set the file size.  If the new size is different, the FILE_MODIFIED
   --  flag is set on the file.
   procedure Set_Size (Element : in File_Type;
                       Size    : in File_Size);

   --  Return the path for the file.
   function Get_Path (Element : in File_Type) return String;

   --  Return the path for the directory.
   function Get_Path (Element : in Directory_Type) return String;

   --  Return the SHA1 signature computed for the file.
   function Get_SHA1 (Element : in File_Type) return String;

   type File_Container is limited interface;

   --  Add the file with the given name in the container.
   procedure Add_File (Into    : in out File_Container;
                       Element : in File_Type) is abstract;

   --  Add the directory with the given name in the container.
   procedure Add_Directory (Into    : in out File_Container;
                            Element : in Directory_Type) is abstract;

   --  Create a new file instance with the given name in the container.
   function Create (Into : in File_Container;
                    Name : in String) return File_Type is abstract;

   --  Create a new directory instance with the given name in the container.
   function Create (Into : in File_Container;
                    Name : in String) return Directory_Type is abstract;

   --  Find the file with the given name in this file container.
   --  Returns NO_FILE if the file was not found.
   function Find (From : in File_Container;
                  Name : in String) return File_Type is abstract;

   --  Find the directory with the given name in this file container.
   --  Returns NO_DIRECTORY if the directory was not found.
   function Find (From : in File_Container;
                  Name : in String) return Directory_Type is abstract;

   type Default_Container is new File_Container with private;

   --  Add the file with the given name in the container.
   overriding
   procedure Add_File (Into    : in out Default_Container;
                       Element : in File_Type);

   --  Add the directory with the given name in the container.
   overriding
   procedure Add_Directory (Into    : in out Default_Container;
                            Element : in Directory_Type);

   --  Create a new file instance with the given name in the container.
   overriding
   function Create (Into : in Default_Container;
                    Name : in String) return File_Type;

   --  Create a new directory instance with the given name in the container.
   overriding
   function Create (Into : in Default_Container;
                    Name : in String) return Directory_Type;

   --  Find the file with the given name in this file container.
   --  Returns NO_FILE if the file was not found.
   overriding
   function Find (From : in Default_Container;
                  Name : in String) return File_Type;

   --  Find the directory with the given name in this file container.
   --  Returns NO_DIRECTORY if the directory was not found.
   overriding
   function Find (From : in Default_Container;
                  Name : in String) return Directory_Type;

private

   type File_Type is access all File;

   type Directory (Len : Positive) is record
      Id       : Directory_Identifier := NO_IDENTIFIER;
      Parent   : Directory_Type;
      Mode     : File_Mode := 8#755#;
      User     : Uid_Type  := 0;
      Group    : Gid_Type  := 0;
      Files    : File_Type_Array_Access;
      Children : Directory_Type_Array_Access;
      Path     : Ada.Strings.Unbounded.Unbounded_String;
      Name     : aliased String (1 .. Len);
   end record;

   type Directory_Type is access all Directory;

   package File_Vectors is new
     Ada.Containers.Vectors (Index_Type   => Positive,
                             Element_Type => File_Type,
                             "="          => "=");

   package Directory_Vectors is new
     Ada.Containers.Vectors (Index_Type   => Positive,
                             Element_Type => Directory_Type,
                             "="          => "=");

   type Default_Container is new Babel.Files.File_Container with record
      Current : Directory_Type;
      Files   : File_Vectors.Vector;
      Dirs    : Directory_Vectors.Vector;
   end record;

   NO_DIRECTORY : constant Directory_Type := null;
   NO_FILE      : constant File_Type := null;

end Babel.Files;

Define the File_Vectors and Directory_Vectors packages


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

package Definitions is

   pragma Pure;

   raven_version_major : constant String := "1";
   raven_version_minor : constant String := "02";
   copyright_years     : constant String := "2015-2018";

   raven_tool        : constant String := "ravenadm";
   variant_standard  : constant String := "standard";
   contact_nobody    : constant String := "nobody";
   contact_automaton : constant String := "automaton";
   dlgroup_main      : constant String := "main";
   dlgroup_none      : constant String := "none";
   options_none      : constant String := "none";
   options_all       : constant String := "all";
   broken_all        : constant String := "all";
   boolean_yes       : constant String := "yes";
   homepage_none     : constant String := "none";
   spkg_complete     : constant String := "complete";
   spkg_docs         : constant String := "docs";
   spkg_examples     : constant String := "examples";
   ports_default     : constant String := "floating";
   default_ssl       : constant String := "libressl";
   default_mysql     : constant String := "oracle-5.7";
   default_lua       : constant String := "5.3";
   default_perl      : constant String := "5.28";
   default_pgsql     : constant String := "10";
   default_php       : constant String := "7.2";
   default_python3   : constant String := "3.7";
   default_ruby      : constant String := "2.5";
   default_tcltk     : constant String := "8.6";
   default_firebird  : constant String := "2.5";
   default_compiler  : constant String := "gcc7";
   compiler_version  : constant String := "7.3.0";
   previous_compiler : constant String := "7.2.0";
   binutils_version  : constant String := "2.30";
   previous_binutils : constant String := "2.29.1";
   arc_ext           : constant String := ".tzst";
   jobs_per_cpu      : constant := 2;

   type supported_opsys is (dragonfly, freebsd, netbsd, openbsd, sunos, linux, macos);
   type supported_arch  is (x86_64, i386, aarch64);

   type cpu_range is range 1 .. 32;
   type scanners  is range cpu_range'First .. cpu_range'Last;
   type builders  is range cpu_range'First .. cpu_range'Last * jobs_per_cpu;
   type count_type is (total, success, failure, ignored, skipped);

   --  Modify following with post-patch sed accordingly
   platform_type  : constant supported_opsys := dragonfly;
   host_localbase : constant String := "/raven";
   host_pkg8      : constant String := host_localbase & "/sbin/pkg-static";
   ravenexec      : constant String := host_localbase & "/libexec/ravenexec";

end Definitions;

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

package Definitions is

   pragma Pure;

   raven_version_major : constant String := "1";
   raven_version_minor : constant String := "03";
   copyright_years     : constant String := "2015-2018";

   raven_tool        : constant String := "ravenadm";
   variant_standard  : constant String := "standard";
   contact_nobody    : constant String := "nobody";
   contact_automaton : constant String := "automaton";
   dlgroup_main      : constant String := "main";
   dlgroup_none      : constant String := "none";
   options_none      : constant String := "none";
   options_all       : constant String := "all";
   broken_all        : constant String := "all";
   boolean_yes       : constant String := "yes";
   homepage_none     : constant String := "none";
   spkg_complete     : constant String := "complete";
   spkg_docs         : constant String := "docs";
   spkg_examples     : constant String := "examples";
   ports_default     : constant String := "floating";
   default_ssl       : constant String := "libressl";
   default_mysql     : constant String := "oracle-5.7";
   default_lua       : constant String := "5.3";
   default_perl      : constant String := "5.28";
   default_pgsql     : constant String := "10";
   default_php       : constant String := "7.2";
   default_python3   : constant String := "3.7";
   default_ruby      : constant String := "2.5";
   default_tcltk     : constant String := "8.6";
   default_firebird  : constant String := "2.5";
   default_compiler  : constant String := "gcc7";
   compiler_version  : constant String := "7.3.0";
   previous_compiler : constant String := "7.2.0";
   binutils_version  : constant String := "2.30";
   previous_binutils : constant String := "2.29.1";
   arc_ext           : constant String := ".tzst";
   jobs_per_cpu      : constant := 2;

   type supported_opsys is (dragonfly, freebsd, netbsd, openbsd, sunos, linux, macos);
   type supported_arch  is (x86_64, i386, aarch64);

   type cpu_range is range 1 .. 32;
   type scanners  is range cpu_range'First .. cpu_range'Last;
   type builders  is range cpu_range'First .. cpu_range'Last * jobs_per_cpu;
   type count_type is (total, success, failure, ignored, skipped);

   --  Modify following with post-patch sed accordingly
   platform_type  : constant supported_opsys := dragonfly;
   host_localbase : constant String := "/raven";
   host_pkg8      : constant String := host_localbase & "/sbin/pkg-static";
   ravenexec      : constant String := host_localbase & "/libexec/ravenexec";

end Definitions;

Bump version to 1.03

Bump version to 1.03

This fixes GITHUB_PRIVATE regression.
Requires related fixes in sites.sh and raven.sequence.mk


-----------------------------------------------------------------------
--  Security-permissions-tests - Unit tests for Security.Permissions
--  Copyright (C) 2011 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.Tests;

package Security.Permissions.Tests is

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite);

   type Test is new Util.Tests.Test with null record;

   --  Test Add_Permission and Get_Permission_Index
   procedure Test_Add_Permission (T : in out Test);

   --  Test Create_Role and Get_Role_Name
   procedure Test_Create_Role (T : in out Test);

   --  Test Has_Permission
   procedure Test_Has_Permission (T : in out Test);

   --  Test reading policy files
   procedure Test_Read_Policy (T : in out Test);

   --  Test reading policy files and using the <role-permission> controller
   procedure Test_Role_Policy (T : in out Test);

      --  Read the policy file <b>File</b> and perform a test on the given URI
   --  with a user having the given role.
   procedure Check_Policy (T     : in out Test;
                           File  : in String;
                           Role  : in String;
                           URI   : in String);

   type Test_Principal is new Principal with record
      Name  : Util.Strings.String_Ref;
      Roles : Role_Map := (others => False);
   end record;

   --  Returns true if the given permission is stored in the user principal.
   function Has_Role (User : in Test_Principal;
                      Role : in Role_Type) return Boolean;

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

end Security.Permissions.Tests;

-----------------------------------------------------------------------
--  Security-permissions-tests - Unit tests for Security.Permissions
--  Copyright (C) 2011 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.Tests;

package Security.Permissions.Tests is

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite);

   type Test is new Util.Tests.Test with null record;

   --  Test Add_Permission and Get_Permission_Index
   procedure Test_Add_Permission (T : in out Test);

end Security.Permissions.Tests;

Remove the policy specific unit tests

Remove the policy specific unit tests


-----------------------------------------------------------------------
--  ado-utils-serialize -- Utility operations for JSON/XML serialization
--  Copyright (C) 2016 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.Serialize.IO;
with ADO.Objects;

package ADO.Utils.Serialize is

   --  Write the entity to the serialization stream (JSON/XML).
   procedure Write_Entity (Stream : in out Util.Serialize.IO.Output_Stream'Class;
                           Name   : in String;
                           Value  : in ADO.Identifier);

   --  Write the entity to the serialization stream (JSON/XML).
   procedure Write_Entity (Stream : in out Util.Serialize.IO.Output_Stream'Class;
                           Name   : in String;
                           Value  : in ADO.Objects.Object_Key);

end ADO.Utils.Serialize;

-----------------------------------------------------------------------
--  ado-utils-serialize -- Utility operations for JSON/XML serialization
--  Copyright (C) 2016, 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.Serialize.IO;
with ADO.Objects;
with ADO.Statements;

package ADO.Utils.Serialize is

   --  Write the entity to the serialization stream (JSON/XML).
   procedure Write_Entity (Stream : in out Util.Serialize.IO.Output_Stream'Class;
                           Name   : in String;
                           Value  : in ADO.Identifier);

   --  Write the entity to the serialization stream (JSON/XML).
   procedure Write_Entity (Stream : in out Util.Serialize.IO.Output_Stream'Class;
                           Name   : in String;
                           Value  : in ADO.Objects.Object_Key);

   --  Write the SQL query results to the serialization stream (JSON/XML).
   procedure Write_Query (Stream : in out Util.Serialize.IO.Output_Stream'Class;
                          Name   : in String;
                          Query  : in out ADO.Statements.Query_Statement);

end ADO.Utils.Serialize;

Declare Write_Query procedure to serialize the result of a Query_Statement


-----------------------------------------------------------------------
--  asf-views -- Views
--  Copyright (C) 2009, 2010, 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.
-----------------------------------------------------------------------

--  The ASF.Views package defines the abstractions to represent
--  an XHTML view that can be instantiated to create the JSF component
--  tree.  The ASF.Views are read only once and they are shared
--  by the JSF component trees that are instantiated from it.
--
--  The XHTML view is read using a SAX parser which creates nodes
--  and attributes to represent the view.
--
--  The ASF.Views is composed of nodes represented by Tag_Node
--  and attributes represented by Tag_Attribute.  In a sense, this
--  is very close to an XML DOM tree.
package ASF.Views is

   --  ------------------------------
   --  Source line information
   --  ------------------------------
   type File_Info (<>) is limited private;
   type File_Info_Access is access all File_Info;

   --  Create a File_Info record to identify the file whose path is Path
   --  and whose relative path portion starts at Relative_Position.
   function Create_File_Info (Path              : in String;
                              Relative_Position : in Natural) return File_Info_Access;

   --  Get the relative path name
   function Relative_Path (File : in File_Info) return String;

   type Line_Info is private;

   --  Get the line number
   function Line (Info : in Line_Info) return Natural;
   pragma Inline (Line);

   --  Get the source file
   function File (Info : in Line_Info) return String;
   pragma Inline (File);

private
   type File_Info (Length : Natural) is limited record
      Relative_Pos : Natural;
      Path         : String (1 .. Length);
   end record;

   NO_FILE : aliased File_Info := File_Info '(Length => 0, Path => "", Relative_Pos => 0);

   type Line_Info is record
      Line   : Natural := 0;
      Column : Natural := 0;
      File   : File_Info_Access := NO_FILE'Access;
   end record;

end ASF.Views;

-----------------------------------------------------------------------
--  asf-views -- Views
--  Copyright (C) 2009, 2010, 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.
-----------------------------------------------------------------------

--  The ASF.Views package defines the abstractions to represent
--  an XHTML view that can be instantiated to create the JSF component
--  tree.  The ASF.Views are read only once and they are shared
--  by the JSF component trees that are instantiated from it.
--
--  The XHTML view is read using a SAX parser which creates nodes
--  and attributes to represent the view.
--
--  The ASF.Views is composed of nodes represented by Tag_Node
--  and attributes represented by Tag_Attribute.  In a sense, this
--  is very close to an XML DOM tree.
package ASF.Views is

   pragma Preelaborate;

   --  ------------------------------
   --  Source line information
   --  ------------------------------
   type File_Info (<>) is limited private;
   type File_Info_Access is access all File_Info;

   --  Create a File_Info record to identify the file whose path is Path
   --  and whose relative path portion starts at Relative_Position.
   function Create_File_Info (Path              : in String;
                              Relative_Position : in Natural) return File_Info_Access;

   --  Get the relative path name
   function Relative_Path (File : in File_Info) return String;

   type Line_Info is private;

   --  Get the line number
   function Line (Info : in Line_Info) return Natural;
   pragma Inline (Line);

   --  Get the source file
   function File (Info : in Line_Info) return String;
   pragma Inline (File);

private
   type File_Info (Length : Natural) is limited record
      Relative_Pos : Natural;
      Path         : String (1 .. Length);
   end record;

   NO_FILE : aliased File_Info := File_Info '(Length => 0, Path => "", Relative_Pos => 0);

   type Line_Info is record
      Line   : Natural := 0;
      Column : Natural := 0;
      File   : File_Info_Access := NO_FILE'Access;
   end record;

end ASF.Views;

Make the package Preelaborate

Make the package Preelaborate


-----------------------------------------------------------------------
--  import_country -- Read a Country csv file to update the database
--  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.Text_IO;
with Ada.Command_Line;
with Ada.Strings.Hash;
with Ada.Containers.Indefinite_Hashed_Maps;

with ADO;
with ADO.SQL;
with ADO.Drivers;
with ADO.Sessions;
with ADO.Statements;
with ADO.Sessions.Factory;

with Util.Strings;
with Util.Log.Loggers;
with Util.Serialize.IO.CSV;

with AWA.Countries.Models;
procedure Import_Country is

   use Ada.Text_IO;
   use Util.Serialize.IO.CSV;
   use AWA.Countries.Models;
   use Ada.Containers;

   use Util.Log;

   Log : constant Loggers.Logger := Loggers.Create ("Import_Country");

   Country : AWA.Countries.Models.Country_Ref;
   DB      : ADO.Sessions.Master_Session;

   package Country_Map is
     new Ada.Containers.Indefinite_Hashed_Maps (Key_Type        => String,
                                                Element_Type    => AWA.Countries.Models.Country_Ref,
                                                Hash            => Ada.Strings.Hash,
                                                Equivalent_Keys => "=");

   package Neighbors_Map is
     new Ada.Containers.Indefinite_Hashed_Maps (Key_Type        => String,
                                                Element_Type    => String,
                                                Hash            => Ada.Strings.Hash,
                                                Equivalent_Keys => "=");

   Countries : Country_Map.Map;
   Neighbors : Neighbors_Map.Map;

   type CSV_Parser is new Util.Serialize.IO.CSV.Parser with null record;

   overriding
   procedure Set_Cell (Parser : in out CSV_Parser;
                       Value  : in String;
                       Row    : in Util.Serialize.IO.CSV.Row_Type;
                       Column : in Util.Serialize.IO.CSV.Column_Type);

   overriding
   procedure Set_Cell (Parser : in out CSV_Parser;
                       Value  : in String;
                       Row    : in Util.Serialize.IO.CSV.Row_Type;
                       Column : in Util.Serialize.IO.CSV.Column_Type) is
      pragma Unreferenced (Parser, Row);

      Query : ADO.SQL.Query;
      Found : Boolean;
   begin
      case Column is
         when 1 =>
            --  The ISO code is unique, find the country
            Query.Bind_Param (1, Value);
            Query.Set_Filter ("iso_code = ?");
            Country.Find (DB, Query, Found);
            if not Found then
               --  Build a new country object
               Country := AWA.Countries.Models.Null_Country;
               Country.Set_Iso_Code (Value);
            end if;
            Countries.Insert (Value, Country);

         when 2 =>
            --              Ada.Text_IO.Put_Line ("ISO3: " & Value);
            null;

         when 3 =>
            --              Ada.Text_IO.Put_Line ("ISON: " & Value);
            null;

         when 4 =>
            --              Ada.Text_IO.Put_Line ("FIPS: " & Value);
            null;

            --  Country name
         when 5 =>
            Country.Set_Name (Value);

         when 6 =>
            --              Ada.Text_IO.Put_Line ("Capital: " & Value);
            null;

         when 7 | 8 => -- Area, Population
            null;

            --  Country continent
         when 9 =>
            Country.Set_Continent (Value);

            --  Country TLD
         when 10 =>
            Country.Set_Tld (Value);

            --  Country CurrencyCode
         when 11 =>
            Country.Set_Currency_Code (Value);

            --  Country CurrencyName
         when 12 =>
            Country.Set_Currency (Value);

         when 13 | 14 => --  Phone, postal code format
            null;

         when 15 =>
            --              Ada.Text_IO.Put_Line ("Postal regex: " & Value);
            null;

            --  Country languages
         when 16 =>
            Country.Set_Languages (Value);

            --  Country unique geonameid
         when 17 =>
            if Value /= "" then
               Country.Set_Geonameid (Integer'Value (Value));
            end if;

         when 18 =>
            Country.Save (DB);
            Neighbors.Insert (Country.Get_Iso_Code, Value);

         when 19 => --  EquivalentFipsCode
            null;

         when others =>
            null;

      end case;

   exception
      when E : others =>
         Log.Error ("Column " & Util.Serialize.IO.CSV.Column_Type'Image (Column)
                    & " value: " & Value, E, True);
         raise;
   end Set_Cell;

   procedure Build_Neighbors is
      Stmt : ADO.Statements.Delete_Statement
        := DB.Create_Statement (AWA.Countries.Models.COUNTRY_NEIGHBOR_TABLE);
      Iter : Neighbors_Map.Cursor := Neighbors.First;
      Count : Natural := 0;
   begin
      Stmt.Execute;

      while Neighbors_Map.Has_Element (Iter) loop
         declare
            Name : constant String := Neighbors_Map.Key (Iter);
            List : constant String := Neighbors_Map.Element (Iter);
            Pos  : Natural := List'First;
            N    : Natural;
         begin
            Country := Countries.Element (Name);
            while Pos < List'Last loop
               N := Util.Strings.Index (List, ',', Pos);
               if N = 0 then
                  N := List'Last;
               else
                  N := N - 1;
               end if;
               if Pos < N and then Countries.Contains (List (Pos .. N)) then
                  declare
                     Neighbor : AWA.Countries.Models.Country_Neighbor_Ref;
                  begin
                     Neighbor.Set_Neighbor_Of (Country);
                     Neighbor.Set_Neighbor (Countries.Element (List (Pos .. N)));
                     Neighbor.Save (DB);
                     Count := Count + 1;
                  end;
               else
                  Ada.Text_IO.Put_Line ("Country not found: " & List (Pos .. N));
               end if;
               Pos := N + 2;
            end loop;
         end;
         Neighbors_Map.Next (Iter);
      end loop;
      Ada.Text_IO.Put_Line ("Created " & Natural'Image (Count) & " country neighbors");
   end Build_Neighbors;

   Count   : constant Natural := Ada.Command_Line.Argument_Count;
   Factory : ADO.Sessions.Factory.Session_Factory;
   Parser  : CSV_Parser;
begin
   Util.Log.Loggers.Initialize ("log4j.properties");
   if Count /= 1 then
      Ada.Text_IO.Put_Line ("Usage: import_country file");
      return;
   end if;

   --  Initialize the database drivers.
   ADO.Drivers.Initialize ("am.properties");

   --  Initialize the session factory to connect to the
   --  database defined by 'ado.database' property.
   Factory.Create (ADO.Drivers.Get_Config ("ado.database"));

   DB := Factory.Get_Master_Session;
   DB.Begin_Transaction;

   declare
      File : constant String := Ada.Command_Line.Argument (1);
   begin
      Parser.Set_Comment_Separator ('#');
      Parser.Set_Field_Separator (ASCII.HT);
      Parser.Parse (File);

      Ada.Text_IO.Put_Line ("Found " & Count_Type'Image (Countries.Length) & " countries");
      Build_Neighbors;
   end;
   DB.Commit;
end Import_Country;

-----------------------------------------------------------------------
--  import_country -- Read a Country csv file to update the database
--  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.Text_IO;
with Ada.Command_Line;
with Ada.Strings.Hash;
with Ada.Containers.Indefinite_Hashed_Maps;

with ADO;
with ADO.SQL;
with ADO.Drivers;
with ADO.Sessions;
with ADO.Statements;
with ADO.Sessions.Factory;

with Util.Strings;
with Util.Log.Loggers;
with Util.Serialize.IO.CSV;

with AWA.Countries.Models;
procedure Import_Country is

   use Ada.Text_IO;
   use Util.Serialize.IO.CSV;
   use AWA.Countries.Models;
   use Ada.Containers;

   use Util.Log;

   Log : constant Loggers.Logger := Loggers.Create ("Import_Country");

   Country : AWA.Countries.Models.Country_Ref;
   DB      : ADO.Sessions.Master_Session;

   package Country_Map is
     new Ada.Containers.Indefinite_Hashed_Maps (Key_Type        => String,
                                                Element_Type    => AWA.Countries.Models.Country_Ref,
                                                Hash            => Ada.Strings.Hash,
                                                Equivalent_Keys => "=");

   package Neighbors_Map is
     new Ada.Containers.Indefinite_Hashed_Maps (Key_Type        => String,
                                                Element_Type    => String,
                                                Hash            => Ada.Strings.Hash,
                                                Equivalent_Keys => "=");

   Countries : Country_Map.Map;
   Neighbors : Neighbors_Map.Map;

   type CSV_Parser is new Util.Serialize.IO.CSV.Parser with null record;

   overriding
   procedure Set_Cell (Parser : in out CSV_Parser;
                       Value  : in String;
                       Row    : in Util.Serialize.IO.CSV.Row_Type;
                       Column : in Util.Serialize.IO.CSV.Column_Type);

   overriding
   procedure Set_Cell (Parser : in out CSV_Parser;
                       Value  : in String;
                       Row    : in Util.Serialize.IO.CSV.Row_Type;
                       Column : in Util.Serialize.IO.CSV.Column_Type) is
      pragma Unreferenced (Parser, Row);

      Query : ADO.SQL.Query;
      Found : Boolean;
   begin
      case Column is
         when 1 =>
            --  The ISO code is unique, find the country
            Query.Bind_Param (1, Value);
            Query.Set_Filter ("iso_code = ?");
            Country.Find (DB, Query, Found);
            if not Found then
               --  Build a new country object
               Country := AWA.Countries.Models.Null_Country;
               Country.Set_Iso_Code (Value);
            end if;
            Countries.Insert (Value, Country);

         when 2 =>
            --              Ada.Text_IO.Put_Line ("ISO3: " & Value);
            null;

         when 3 =>
            --              Ada.Text_IO.Put_Line ("ISON: " & Value);
            null;

         when 4 =>
            --              Ada.Text_IO.Put_Line ("FIPS: " & Value);
            null;

            --  Country name
         when 5 =>
            Country.Set_Name (Value);

         when 6 =>
            --              Ada.Text_IO.Put_Line ("Capital: " & Value);
            null;

         when 7 | 8 => -- Area, Population
            null;

            --  Country continent
         when 9 =>
            Country.Set_Continent (Value);

            --  Country TLD
         when 10 =>
            Country.Set_Tld (Value);

            --  Country CurrencyCode
         when 11 =>
            Country.Set_Currency_Code (Value);

            --  Country CurrencyName
         when 12 =>
            Country.Set_Currency (Value);

         when 13 | 14 => --  Phone, postal code format
            null;

         when 15 =>
            --              Ada.Text_IO.Put_Line ("Postal regex: " & Value);
            null;

            --  Country languages
         when 16 =>
            Country.Set_Languages (Value);

            --  Country unique geonameid
         when 17 =>
            if Value /= "" then
               Country.Set_Geonameid (Integer'Value (Value));
            end if;

         when 18 =>
            Country.Save (DB);
            Neighbors.Insert (Country.Get_Iso_Code, Value);

         when 19 => --  EquivalentFipsCode
            null;

         when others =>
            null;

      end case;

   exception
      when E : others =>
         Log.Error ("Column " & Util.Serialize.IO.CSV.Column_Type'Image (Column)
                    & " value: " & Value, E, True);
         raise;
   end Set_Cell;

   procedure Build_Neighbors is
      Stmt : ADO.Statements.Delete_Statement
        := DB.Create_Statement (AWA.Countries.Models.COUNTRY_NEIGHBOR_TABLE);
      Iter : Neighbors_Map.Cursor := Neighbors.First;
      Count : Natural := 0;
   begin
      Stmt.Execute;

      while Neighbors_Map.Has_Element (Iter) loop
         declare
            Name : constant String := Neighbors_Map.Key (Iter);
            List : constant String := Neighbors_Map.Element (Iter);
            Pos  : Natural := List'First;
            N    : Natural;
         begin
            Country := Countries.Element (Name);
            while Pos < List'Last loop
               N := Util.Strings.Index (List, ',', Pos);
               if N = 0 then
                  N := List'Last;
               else
                  N := N - 1;
               end if;
               if Pos < N and then Countries.Contains (List (Pos .. N)) then
                  declare
                     Neighbor : AWA.Countries.Models.Country_Neighbor_Ref;
                  begin
                     Neighbor.Set_Neighbor_Of (Country);
                     Neighbor.Set_Neighbor (Countries.Element (List (Pos .. N)));
                     Neighbor.Save (DB);
                     Count := Count + 1;
                  end;
               else
                  Ada.Text_IO.Put_Line ("Country not found: " & List (Pos .. N));
               end if;
               Pos := N + 2;
            end loop;
         end;
         Neighbors_Map.Next (Iter);
      end loop;
      Ada.Text_IO.Put_Line ("Created " & Natural'Image (Count) & " country neighbors");
   end Build_Neighbors;

   Count   : constant Natural := Ada.Command_Line.Argument_Count;
   Factory : ADO.Sessions.Factory.Session_Factory;
   Parser  : CSV_Parser;
begin
   if Count /= 2 then
      Ada.Text_IO.Put_Line ("Usage: import_country config file");
      return;
   end if;

   declare
      Config : constant String := Ada.Command_Line.Argument (1);
   begin
      Util.Log.Loggers.Initialize (Config);

      --  Initialize the database drivers.
      ADO.Drivers.Initialize (Config);

      --  Initialize the session factory to connect to the
      --  database defined by 'ado.database' property.
      Factory.Create (ADO.Drivers.Get_Config ("database"));
   end;

   DB := Factory.Get_Master_Session;
   DB.Begin_Transaction;

   declare
      File : constant String := Ada.Command_Line.Argument (2);
   begin
      Parser.Set_Comment_Separator ('#');
      Parser.Set_Field_Separator (ASCII.HT);
      Parser.Parse (File);

      Ada.Text_IO.Put_Line ("Found " & Count_Type'Image (Countries.Length) & " countries");
      Build_Neighbors;
   end;
   DB.Commit;
end Import_Country;

Update the usage of the import tool

Update the usage of the import tool