-----------------------------------------------------------------------
--  wiki-render-html -- Wiki HTML renderer
--  Copyright (C) 2011, 2012, 2013, 2015, 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 Wiki.Attributes;
with Wiki.Streams.Html;
with Wiki.Strings;

--  == HTML Renderer ==
--  The <tt>Text_Renderer</tt> allows to render a wiki document into a text content.
--  The formatting rules are ignored except for the paragraphs and sections.
package Wiki.Render.Html is

   --  ------------------------------
   --  Wiki to HTML renderer
   --  ------------------------------
   type Html_Renderer is new Renderer with private;

   --  Set the output stream.
   procedure Set_Output_Stream (Engine : in out Html_Renderer;
                                Stream : in Wiki.Streams.Html.Html_Output_Stream_Access);

   --  Set the link renderer.
   procedure Set_Link_Renderer (Document : in out Html_Renderer;
                                Links    : in Link_Renderer_Access);

   --  Render the node instance from the document.
   overriding
   procedure Render (Engine : in out Html_Renderer;
                     Doc    : in Wiki.Nodes.Document;
                     Node   : in Wiki.Nodes.Node_Type);

   --  Add a blockquote (<blockquote>).  The level indicates the blockquote nested level.
   --  The blockquote must be closed at the next header.
   procedure Add_Blockquote (Document : in out Html_Renderer;
                             Level    : in Natural);

   --  Add a list item (<li>).  Close the previous paragraph and list item if any.
   --  The list item will be closed at the next list item, next paragraph or next header.
   procedure Add_List_Item (Document : in out Html_Renderer;
                            Level    : in Positive;
                            Ordered  : in Boolean);

   --  Add a text block with the given format.
   procedure Add_Text (Engine   : in out Html_Renderer;
                       Text     : in Wiki.Strings.WString;
                       Format   : in Wiki.Format_Map);

   --  Render a text block that is pre-formatted.
   procedure Render_Preformatted (Engine : in out Html_Renderer;
                                  Text   : in Wiki.Strings.WString;
                                  Format : in Unbounded_Wide_Wide_String);

   --  Finish the document after complete wiki text has been parsed.
   overriding
   procedure Finish (Document : in out Html_Renderer);

private

   procedure Close_Paragraph (Document : in out Html_Renderer);
   procedure Open_Paragraph (Document : in out Html_Renderer);

   type List_Style_Array is array (1 .. 32) of Boolean;

   Default_Links : aliased Default_Link_Renderer;

   type Html_Renderer is new Renderer with record
      Output         : Wiki.Streams.Html.Html_Output_Stream_Access := null;
      Format         : Wiki.Format_Map := (others => False);
      Links          : Link_Renderer_Access := Default_Links'Access;
      Has_Paragraph  : Boolean := False;
      Need_Paragraph : Boolean := False;
      Has_Item       : Boolean := False;
      Current_Level  : Natural := 0;
      List_Styles    : List_Style_Array := (others => False);
      Quote_Level    : Natural := 0;
      Html_Level     : Natural := 0;
   end record;

   procedure Render_Tag (Engine : in out Html_Renderer;
                         Doc    : in Wiki.Nodes.Document;
                         Node   : in Wiki.Nodes.Node_Type);

   --  Render a section header in the document.
   procedure Render_Header (Engine : in out Html_Renderer;
                            Header : in Wiki.Strings.WString;
                            Level  : in Positive);

   --  Render a link.
   procedure Render_Link (Engine : in out Html_Renderer;
                          Doc    : in Wiki.Nodes.Document;
                          Title  : in Wiki.Strings.WString;
                          Attr   : in Wiki.Attributes.Attribute_List_Type);

   --  Render an image.
   procedure Render_Image (Engine : in out Html_Renderer;
                           Doc    : in Wiki.Nodes.Document;
                           Title  : in Wiki.Strings.WString;
                           Attr   : in Wiki.Attributes.Attribute_List_Type);

   --  Render a quote.
   procedure Render_Quote (Engine : in out Html_Renderer;
                           Doc    : in Wiki.Nodes.Document;
                           Title  : in Wiki.Strings.WString;
                           Attr   : in Wiki.Attributes.Attribute_List_Type);

end Wiki.Render.Html;

-----------------------------------------------------------------------
--  wiki-render-html -- Wiki HTML renderer
--  Copyright (C) 2011, 2012, 2013, 2015, 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 Wiki.Attributes;
with Wiki.Streams.Html;
with Wiki.Strings;

--  == HTML Renderer ==
--  The <tt>Text_Renderer</tt> allows to render a wiki document into a text content.
--  The formatting rules are ignored except for the paragraphs and sections.
package Wiki.Render.Html is

   --  ------------------------------
   --  Wiki to HTML renderer
   --  ------------------------------
   type Html_Renderer is new Renderer with private;

   --  Set the output stream.
   procedure Set_Output_Stream (Engine : in out Html_Renderer;
                                Stream : in Wiki.Streams.Html.Html_Output_Stream_Access);

   --  Set the link renderer.
   procedure Set_Link_Renderer (Document : in out Html_Renderer;
                                Links    : in Link_Renderer_Access);

   --  Render the node instance from the document.
   overriding
   procedure Render (Engine : in out Html_Renderer;
                     Doc    : in Wiki.Nodes.Document;
                     Node   : in Wiki.Nodes.Node_Type);

   --  Add a blockquote (<blockquote>).  The level indicates the blockquote nested level.
   --  The blockquote must be closed at the next header.
   procedure Add_Blockquote (Document : in out Html_Renderer;
                             Level    : in Natural);

   --  Render a list item (<li>).  Close the previous paragraph and list item if any.
   --  The list item will be closed at the next list item, next paragraph or next header.
   procedure Render_List_Item (Engine   : in out Html_Renderer;
                               Level    : in Positive;
                               Ordered  : in Boolean);

   --  Add a text block with the given format.
   procedure Add_Text (Engine   : in out Html_Renderer;
                       Text     : in Wiki.Strings.WString;
                       Format   : in Wiki.Format_Map);

   --  Render a text block that is pre-formatted.
   procedure Render_Preformatted (Engine : in out Html_Renderer;
                                  Text   : in Wiki.Strings.WString;
                                  Format : in Wiki.Strings.WString);

   --  Finish the document after complete wiki text has been parsed.
   overriding
   procedure Finish (Document : in out Html_Renderer);

private

   procedure Close_Paragraph (Document : in out Html_Renderer);
   procedure Open_Paragraph (Document : in out Html_Renderer);

   type List_Style_Array is array (1 .. 32) of Boolean;

   Default_Links : aliased Default_Link_Renderer;

   type Html_Renderer is new Renderer with record
      Output         : Wiki.Streams.Html.Html_Output_Stream_Access := null;
      Format         : Wiki.Format_Map := (others => False);
      Links          : Link_Renderer_Access := Default_Links'Access;
      Has_Paragraph  : Boolean := False;
      Need_Paragraph : Boolean := False;
      Has_Item       : Boolean := False;
      Current_Level  : Natural := 0;
      List_Styles    : List_Style_Array := (others => False);
      Quote_Level    : Natural := 0;
      Html_Level     : Natural := 0;
   end record;

   procedure Render_Tag (Engine : in out Html_Renderer;
                         Doc    : in Wiki.Nodes.Document;
                         Node   : in Wiki.Nodes.Node_Type);

   --  Render a section header in the document.
   procedure Render_Header (Engine : in out Html_Renderer;
                            Header : in Wiki.Strings.WString;
                            Level  : in Positive);

   --  Render a link.
   procedure Render_Link (Engine : in out Html_Renderer;
                          Doc    : in Wiki.Nodes.Document;
                          Title  : in Wiki.Strings.WString;
                          Attr   : in Wiki.Attributes.Attribute_List_Type);

   --  Render an image.
   procedure Render_Image (Engine : in out Html_Renderer;
                           Doc    : in Wiki.Nodes.Document;
                           Title  : in Wiki.Strings.WString;
                           Attr   : in Wiki.Attributes.Attribute_List_Type);

   --  Render a quote.
   procedure Render_Quote (Engine : in out Html_Renderer;
                           Doc    : in Wiki.Nodes.Document;
                           Title  : in Wiki.Strings.WString;
                           Attr   : in Wiki.Attributes.Attribute_List_Type);

end Wiki.Render.Html;

Rename Add_List_Item into Render_List_Item


-----------------------------------------------------------------------
--  Render Tests - Unit tests for ASF.Applications.Views
--  Copyright (C) 2009, 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.Text_IO;
with ASF.Applications.Main;
with ASF.Requests.Mockup;
with ASF.Responses.Mockup;
with Ada.Directories;

with Util.Test_Caller;
with Util.Files;
with Util.Measures;
package body ASF.Applications.Views.Tests is

   use Ada.Strings.Unbounded;

   overriding
   procedure Set_Up (T : in out Test) is
   begin
      null;
   end Set_Up;
   --  Set up performed before each test case

   --  Test loading of facelet file
   procedure Test_Load_Facelet (T : in out Test) is

      use ASF;
      use ASF.Contexts.Faces;

      App      : Applications.Main.Application;
--        H        : Applications.Views.View_Handler;

      View_Name   : constant String := To_String (T.File);
      Result_File : constant String := To_String (T.Result);
      Conf        : Applications.Config;
      App_Factory : Applications.Main.Application_Factory;
      Dir         : constant String := "regtests/files";
      Path        : constant String := Util.Tests.Get_Path (Dir);
   begin
      Conf.Load_Properties ("regtests/view.properties");
      Conf.Set ("view.dir", Path);
      App.Initialize (Conf, App_Factory);

      App.Set_Global ("function", "Test_Load_Facelet");
      for I in 1 .. 2 loop
         declare
            S : Util.Measures.Stamp;
            Req       : ASF.Requests.Mockup.Request;
            Rep       : ASF.Responses.Mockup.Response;
            Content   : Unbounded_String;
         begin

            Req.Set_Method ("GET");
            Req.Set_Path_Info (View_Name);
            Req.Set_Parameter ("file-name", To_String (T.Name));
            Req.Set_Header ("file", To_String (T.Name));
            App.Dispatch (Page     => View_Name,
                          Request  => Req,
                          Response => Rep);
            Util.Measures.Report (S, "Pass" & Integer'Image (I) & ": Render view "
                                  & View_Name);

            Rep.Read_Content (Content);
            Util.Files.Write_File (Result_File, Content);
            Util.Tests.Assert_Equal_Files (T       => T,
                                           Expect  => To_String (T.Expect),
                                           Test    => Result_File,
                                           Message => "Restore and render view");
         end;
      end loop;
   end Test_Load_Facelet;

   --  Test case name
   overriding
   function Name (T : Test) return Util.Tests.Message_String is
   begin
      return Util.Tests.Format ("Test " & To_String (T.Name));
   end Name;

   --  Perform the test.
   overriding
   procedure Run_Test (T : in out Test) is
   begin
      T.Test_Load_Facelet;
   end Run_Test;

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
      use Ada.Directories;

      Result_Dir  : constant String := "regtests/result/views";
      Dir         : constant String := "regtests/files/views";
      Expect_Dir  : constant String := "regtests/expect/views";
      Path        : constant String := Util.Tests.Get_Path (Dir);
      Expect_Path : constant String := Util.Tests.Get_Path (Expect_Dir);
      Result_Path : constant String := Util.Tests.Get_Test_Path (Result_Dir);
      Search      : Search_Type;
      Filter      : constant Filter_Type := (others => True);
      Ent         : Directory_Entry_Type;
   begin
      if Kind (Path) = Directory then
         Ada.Text_IO.Put_Line ("Cannot read test directory: " & Path);
      end if;

      Start_Search (Search, Directory => Path, Pattern => "*.xhtml", Filter => Filter);
      while More_Entries (Search) loop
         Get_Next_Entry (Search, Ent);
         declare
            Simple    : constant String := Simple_Name (Ent);
            Tst      : Test_Case_Access;
         begin
            if Simple /= "." and then Simple /= ".."
              and then Simple /= ".svn" then
               Tst := new Test;
               Tst.Name := To_Unbounded_String (Dir & "/" & Simple);
               Tst.File := To_Unbounded_String ("views/" & Simple);
               Tst.Expect := To_Unbounded_String (Expect_Path & "/" & Simple);
               Tst.Result := To_Unbounded_String (Result_Path & "/" & Simple);
               Suite.Add_Test (Tst);
            end if;
         end;
      end loop;
   end Add_Tests;

end ASF.Applications.Views.Tests;

-----------------------------------------------------------------------
--  Render Tests - Unit tests for ASF.Applications.Views
--  Copyright (C) 2009, 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.Text_IO;
with ASF.Applications.Main;
with ASF.Requests.Mockup;
with ASF.Responses.Mockup;
with Ada.Directories;

with Util.Test_Caller;
with Util.Files;
with Util.Measures;
package body ASF.Applications.Views.Tests is

   use Ada.Strings.Unbounded;

   overriding
   procedure Set_Up (T : in out Test) is
   begin
      null;
   end Set_Up;
   --  Set up performed before each test case

   --  Test loading of facelet file
   procedure Test_Load_Facelet (T : in out Test) is

      use ASF;
      use ASF.Contexts.Faces;

      App      : Applications.Main.Application;
--        H        : Applications.Views.View_Handler;

      View_Name   : constant String := To_String (T.File);
      Result_File : constant String := To_String (T.Result);
      Conf        : Applications.Config;
      App_Factory : Applications.Main.Application_Factory;
      Dir         : constant String := "regtests/files";
      Path        : constant String := Util.Tests.Get_Path (Dir);
   begin
      Conf.Load_Properties ("regtests/view.properties");
      Conf.Set ("view.dir", Path);
      App.Initialize (Conf, App_Factory);

      App.Set_Global ("function", "Test_Load_Facelet");
      for I in 1 .. 2 loop
         declare
            S : Util.Measures.Stamp;
            Req       : ASF.Requests.Mockup.Request;
            Rep       : ASF.Responses.Mockup.Response;
            Content   : Unbounded_String;
         begin

            Req.Set_Method ("GET");
            Req.Set_Path_Info (View_Name);
            Req.Set_Parameter ("file-name", To_String (T.Name));
            Req.Set_Header ("file", To_String (T.Name));
            App.Dispatch (Page     => View_Name,
                          Request  => Req,
                          Response => Rep);
            Util.Measures.Report (S, "Pass" & Integer'Image (I) & ": Render view "
                                  & View_Name);

            Rep.Read_Content (Content);
            Util.Files.Write_File (Result_File, Content);
            Util.Tests.Assert_Equal_Files (T       => T,
                                           Expect  => To_String (T.Expect),
                                           Test    => Result_File,
                                           Message => "Restore and render view");
         end;
      end loop;
   end Test_Load_Facelet;

   --  Test case name
   overriding
   function Name (T : Test) return Util.Tests.Message_String is
   begin
      return Util.Tests.Format ("Test " & To_String (T.Name));
   end Name;

   --  Perform the test.
   overriding
   procedure Run_Test (T : in out Test) is
   begin
      T.Test_Load_Facelet;
   end Run_Test;

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
      use Ada.Directories;

      Result_Dir  : constant String := "regtests/result/views";
      Dir         : constant String := "regtests/files/views";
      Expect_Dir  : constant String := "regtests/expect/views";
      Path        : constant String := Util.Tests.Get_Path (Dir);
      Expect_Path : constant String := Util.Tests.Get_Path (Expect_Dir);
      Result_Path : constant String := Util.Tests.Get_Test_Path (Result_Dir);
      Search      : Search_Type;
      Filter      : constant Filter_Type := (others => True);
      Ent         : Directory_Entry_Type;
   begin
      if Kind (Path) = Directory then
         Ada.Text_IO.Put_Line ("Cannot read test directory: " & Path);
      end if;

      Start_Search (Search, Directory => Path, Pattern => "*.xhtml", Filter => Filter);
      while More_Entries (Search) loop
         Get_Next_Entry (Search, Ent);
         declare
            Simple    : constant String := Simple_Name (Ent);
            Tst      : Test_Case_Access;
         begin
            if Simple /= "." and then Simple /= ".."
              and then Simple /= ".svn" then
               Tst := new Test;
               Tst.Name := To_Unbounded_String (Dir & "/" & Simple);
               Tst.File := To_Unbounded_String ("views/" & Simple);
               Tst.Expect := To_Unbounded_String (Expect_Path & "/" & Simple);
               Tst.Result := To_Unbounded_String (Result_Path & "/" & Simple);
               Suite.Add_Test (Tst.all'Access);
            end if;
         end;
      end loop;
   end Add_Tests;

end ASF.Applications.Views.Tests;

Fix compilation when Ahven is used as a test framework


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

with Util.Test_Caller;
with Util.Measures;

with ASF.Applications;
with ASF.Streams;
with ASF.Requests.Mockup;
with ASF.Responses.Mockup;
package body ASF.Servlets.Tests is

   use Util.Tests;

   procedure Do_Get (Server   : in Test_Servlet1;
                     Request  : in out Requests.Request'Class;
                     Response : in out Responses.Response'Class) is
      pragma Unreferenced (Server);

      Output : ASF.Streams.Print_Stream := Response.Get_Output_Stream;
   begin
      Output.Write ("URI: " & Request.Get_Request_URI);
      Response.Set_Status (Responses.SC_OK);
   end Do_Get;

   procedure Do_Post (Server   : in Test_Servlet2;
                      Request  : in out Requests.Request'Class;
                      Response : in out Responses.Response'Class) is
   begin
      null;
   end Do_Post;

   S1 : aliased Test_Servlet1;
   S2 : aliased Test_Servlet2;

   --  ------------------------------
   --  Test request dispatcher and servlet invocation
   --  ------------------------------
   procedure Test_Request_Dispatcher (T : in out Test) is
      Ctx : Servlet_Registry;

      S1  : aliased Test_Servlet1;
   begin
      Ctx.Add_Servlet ("Faces", S1'Unchecked_Access);

      Ctx.Add_Mapping (Pattern => "*.jsf", Name => "Faces");

      declare
         Dispatcher : constant Request_Dispatcher
           := Ctx.Get_Request_Dispatcher (Path => "/home/test.jsf");
         Req        : ASF.Requests.Mockup.Request;
         Resp       : ASF.Responses.Mockup.Response;
         Result     : Unbounded_String;
      begin
         T.Assert (Dispatcher.Mapping /= null, "No mapping found");

         Req.Set_Request_URI ("test1");
         Req.Set_Method ("GET");
         Forward (Dispatcher, Req, Resp);

         --  Check the response after the Test_Servlet1.Do_Get method execution.
         Resp.Read_Content (Result);
         Assert_Equals (T, ASF.Responses.SC_OK, Resp.Get_Status, "Invalid status");
         Assert_Equals (T, "URI: test1", Result, "Invalid content");

         Req.Set_Method ("POST");
         Forward (Dispatcher, Req, Resp);

         Assert_Equals (T, ASF.Responses.SC_METHOD_NOT_ALLOWED, Resp.Get_Status,
                        "Invalid status for an operation not implemented");

      end;
   end Test_Request_Dispatcher;

   --  ------------------------------
   --  Test add servlet
   --  ------------------------------
   procedure Test_Add_Servlet (T : in out Test) is
      Ctx : Servlet_Registry;

      S1  : aliased Test_Servlet1;
   begin
      Ctx.Add_Servlet ("Faces", S1'Unchecked_Access);

      Assert_Equals (T, "Faces", S1.Get_Name, "Invalid name for the servlet");

      begin
         Ctx.Add_Servlet ("Faces", S1'Unchecked_Access);
         T.Assert (False, "No exception raised if the servlet is registered several times");

      exception
         when Servlet_Error =>
            null;
      end;
   end Test_Add_Servlet;

   --  ------------------------------
   --  Test getting a resource path
   --  ------------------------------
   procedure Test_Get_Resource (T : in out Test) is
      Ctx : Servlet_Registry;

      Conf  : Applications.Config;
      S1    : aliased Test_Servlet1;
      Dir   : constant String := "regtests/files";
      Path  : constant String := Util.Tests.Get_Path (Dir);
   begin
      Conf.Load_Properties ("regtests/view.properties");
      Conf.Set ("view.dir", Path);
      Ctx.Set_Init_Parameters (Conf);
      Ctx.Add_Servlet ("Faces", S1'Unchecked_Access);

      --  Resource exist, check the returned path.
      declare
         P : constant String := Ctx.Get_Resource ("/tests/form-text.xhtml");
      begin
         Assert_Matches (T, ".*/regtests/files/tests/form-text.xhtml",
                         P, "Invalid resource path");
      end;

      --  Resource does not exist
      declare
         P : constant String := Ctx.Get_Resource ("/tests/form-text-missing.xhtml");
      begin
         Assert_Equals (T, "", P, "Invalid resource path for missing resource");
      end;
   end Test_Get_Resource;

   --  ------------------------------
   --  Check that the mapping for the given URI matches the server.
   --  ------------------------------
   procedure Check_Mapping (T      : in out Test;
                            Ctx    : in Servlet_Registry;
                            URI    : in String;
                            Server : in Servlet_Access) is
      Map : constant Mapping_Access := Ctx.Find_Mapping (URI);
   begin
      if Map = null then
         T.Assert (Server = null, "No mapping returned for URI: " & URI);
      else
         T.Assert (Server /= null, "A mapping is returned for URI: " & URI);
         T.Assert (Map.Servlet = Server, "Invalid mapping returned for URI: " & URI);
      end if;
   end Check_Mapping;

   --  ------------------------------
   --  Test session creation.
   --  ------------------------------
   procedure Test_Create_Servlet (T : in out Test) is
      Ctx : Servlet_Registry;

      Map : Mapping_Access;
   begin
      Ctx.Add_Servlet (Name => "Faces", Server => S1'Access);
      Ctx.Add_Servlet (Name => "Text", Server => S2'Access);

      Ctx.Add_Mapping (Pattern => "*.jsf", Name => "Faces");
      Ctx.Add_Mapping (Pattern => "*.html", Name => "Faces");
      Ctx.Add_Mapping (Pattern => "*.txt", Name => "Text");

      --  Ctx.Add_Mapping (Pattern => "/server", Server => S2'Access);
      Ctx.Add_Mapping (Pattern => "/server/john/*", Server => S2'Access);
      Ctx.Add_Mapping (Pattern => "/server/info", Server => S1'Access);
      Ctx.Add_Mapping (Pattern => "/server/list", Server => S1'Access);
      Ctx.Add_Mapping (Pattern => "/server/list2", Server => S2'Access);
      Ctx.Add_Mapping (Pattern => "/1/2/3/4/5/6/7/8/9/server/list2", Server => S2'Access);
      Ctx.Add_Mapping (Pattern => "/1/2/3/4/5/6/7/8/A/server/list2", Server => S1'Access);

      Ctx.Mappings.Dump_Map (" ");

      T.Check_Mapping (Ctx, "/joe/black/joe.jsf", S1'Access);
      T.Check_Mapping (Ctx, "/joe/black/joe.txt", S2'Access);
      T.Check_Mapping (Ctx, "/server/info", S1'Access);
      T.Check_Mapping (Ctx, "/server/list2", S2'Access);
      T.Check_Mapping (Ctx, "/1/2/3/4/5/6/7/8/9/server/list2", S2'Access);
      T.Check_Mapping (Ctx, "/1/2/3/4/5/6/7/8/A/server/list2", S1'Access);

      declare
         St : Util.Measures.Stamp;
      begin
         for I in 1 .. 1000 loop
            Map := Ctx.Find_Mapping (URI => "/joe/black/joe.jsf");
         end loop;
         Util.Measures.Report (St, "Find 1000 mapping (extension)");
      end;

      T.Assert (Map /= null, "No mapping for 'joe.jsf'");
      T.Assert (Map.Servlet /= null, "No servlet for mapping for 'joe.jsf'");
      T.Assert (Map.Servlet = S1'Access, "Invalid servlet");
      --        Util.Measures.Report (St, "10 Session create");

      declare
         St : Util.Measures.Stamp;
      begin
         for I in 1 .. 1000 loop
            Map := Ctx.Find_Mapping (URI => "/1/2/3/4/5/6/7/8/9/server/list2");
         end loop;
         Util.Measures.Report (St, "Find 1000 mapping (path)");
      end;

      T.Assert (Map /= null, "No mapping for '/server/john/joe.jsf'");
      T.Assert (Map.Servlet /= null, "No servlet for mapping for 'joe.jsf'");
      T.Assert (Map.Servlet = S2'Access, "Invalid servlet");
      --        Util.Measures.Report (St, "10 Session create");

   end Test_Create_Servlet;

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

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

   begin
      --  To document what is tested, register the test methods for each
      --  operation that is tested.
      Caller.Add_Test (Suite, "Test ASF.Servlets.Add_Mapping,Find_Mapping",
                       Test_Create_Servlet'Access);
      Caller.Add_Test (Suite, "Test ASF.Servlets.Add_Servlet",
                       Test_Add_Servlet'Access);
      Caller.Add_Test (Suite, "Test ASF.Servlets.Get_Request_Dispatcher",
                       Test_Request_Dispatcher'Access);
      Caller.Add_Test (Suite, "Test ASF.Servlets.Get_Resource",
                       Test_Get_Resource'Access);
   end Add_Tests;

end ASF.Servlets.Tests;

-----------------------------------------------------------------------
--  Sessions Tests - Unit tests for ASF.Sessions
--  Copyright (C) 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.
-----------------------------------------------------------------------

with Util.Test_Caller;
with Util.Measures;

with ASF.Applications;
with ASF.Streams;
with ASF.Requests.Mockup;
with ASF.Responses.Mockup;
package body ASF.Servlets.Tests is

   use Util.Tests;

   procedure Do_Get (Server   : in Test_Servlet1;
                     Request  : in out Requests.Request'Class;
                     Response : in out Responses.Response'Class) is
      pragma Unreferenced (Server);

      Output : ASF.Streams.Print_Stream := Response.Get_Output_Stream;
   begin
      Output.Write ("URI: " & Request.Get_Request_URI);
      Response.Set_Status (Responses.SC_OK);
   end Do_Get;

   procedure Do_Post (Server   : in Test_Servlet2;
                      Request  : in out Requests.Request'Class;
                      Response : in out Responses.Response'Class) is
   begin
      null;
   end Do_Post;

   S1 : aliased Test_Servlet1;
   S2 : aliased Test_Servlet2;

   --  ------------------------------
   --  Check that the request is done on the good servlet and with the correct servlet path
   --  and path info.
   --  ------------------------------
   procedure Check_Request (T            : in out Test;
                            Ctx          : in Servlet_Registry;
                            URI          : in String;
                            Servlet_Path : in String;
                            Path_Info    : in String) is
      Dispatcher : constant Request_Dispatcher
        := Ctx.Get_Request_Dispatcher (Path => URI);
      Req        : ASF.Requests.Mockup.Request;
      Resp       : ASF.Responses.Mockup.Response;
      Result     : Unbounded_String;
   begin
      T.Assert (Dispatcher.Mapping /= null, "No mapping found");

      Req.Set_Request_URI ("test1");
      Req.Set_Method ("GET");
      Forward (Dispatcher, Req, Resp);

      Assert_Equals (T, Servlet_Path, Req.Get_Servlet_Path, "Invalid servlet path");
      Assert_Equals (T, Path_Info, Req.Get_Path_Info,
                     "The request path info is invalid");

      --  Check the response after the Test_Servlet1.Do_Get method execution.
      Resp.Read_Content (Result);
      Assert_Equals (T, ASF.Responses.SC_OK, Resp.Get_Status, "Invalid status");
      Assert_Equals (T, "URI: test1", Result, "Invalid content");

      Req.Set_Method ("POST");
      Forward (Dispatcher, Req, Resp);

      Assert_Equals (T, ASF.Responses.SC_METHOD_NOT_ALLOWED, Resp.Get_Status,
                     "Invalid status for an operation not implemented");
   end Check_Request;

   --  ------------------------------
   --  Test request dispatcher and servlet invocation
   --  ------------------------------
   procedure Test_Request_Dispatcher (T : in out Test) is
      Ctx : Servlet_Registry;

      S1  : aliased Test_Servlet1;
   begin
      Ctx.Add_Servlet ("Faces", S1'Unchecked_Access);

      Ctx.Add_Mapping (Pattern => "*.jsf", Name => "Faces");

      Ctx.Add_Mapping (Pattern => "/p1/p2/p3/*", Name => "Faces");

      Check_Request (T, Ctx, "/home/test.jsf", "", "/home/test.jsf");
   end Test_Request_Dispatcher;

   --  ------------------------------
   --  Test mapping and servlet path on a request.
   --  ------------------------------
   procedure Test_Servlet_Path (T : in out Test) is
      Ctx : Servlet_Registry;

      S1  : aliased Test_Servlet1;
   begin
      Ctx.Add_Servlet ("Faces", S1'Unchecked_Access);

      Ctx.Add_Mapping (Pattern => "*.jsf", Name => "Faces");

      Ctx.Add_Mapping (Pattern => "/p1/p2/p3/*", Name => "Faces");

      Check_Request (T, Ctx, "/p1/p2/p3/home/test.html", "/p1/p2/p3", "/home/test.html");
   end Test_Servlet_Path;

   --  ------------------------------
   --  Test add servlet
   --  ------------------------------
   procedure Test_Add_Servlet (T : in out Test) is
      Ctx : Servlet_Registry;

      S1  : aliased Test_Servlet1;
   begin
      Ctx.Add_Servlet ("Faces", S1'Unchecked_Access);

      Assert_Equals (T, "Faces", S1.Get_Name, "Invalid name for the servlet");

      begin
         Ctx.Add_Servlet ("Faces", S1'Unchecked_Access);
         T.Assert (False, "No exception raised if the servlet is registered several times");

      exception
         when Servlet_Error =>
            null;
      end;
   end Test_Add_Servlet;

   --  ------------------------------
   --  Test getting a resource path
   --  ------------------------------
   procedure Test_Get_Resource (T : in out Test) is
      Ctx : Servlet_Registry;

      Conf  : Applications.Config;
      S1    : aliased Test_Servlet1;
      Dir   : constant String := "regtests/files";
      Path  : constant String := Util.Tests.Get_Path (Dir);
   begin
      Conf.Load_Properties ("regtests/view.properties");
      Conf.Set ("view.dir", Path);
      Ctx.Set_Init_Parameters (Conf);
      Ctx.Add_Servlet ("Faces", S1'Unchecked_Access);

      --  Resource exist, check the returned path.
      declare
         P : constant String := Ctx.Get_Resource ("/tests/form-text.xhtml");
      begin
         Assert_Matches (T, ".*/regtests/files/tests/form-text.xhtml",
                         P, "Invalid resource path");
      end;

      --  Resource does not exist
      declare
         P : constant String := Ctx.Get_Resource ("/tests/form-text-missing.xhtml");
      begin
         Assert_Equals (T, "", P, "Invalid resource path for missing resource");
      end;
   end Test_Get_Resource;

   --  ------------------------------
   --  Check that the mapping for the given URI matches the server.
   --  ------------------------------
   procedure Check_Mapping (T      : in out Test;
                            Ctx    : in Servlet_Registry;
                            URI    : in String;
                            Server : in Servlet_Access) is
      Map : constant Mapping_Access := Ctx.Find_Mapping (URI);
   begin
      if Map = null then
         T.Assert (Server = null, "No mapping returned for URI: " & URI);
      else
         T.Assert (Server /= null, "A mapping is returned for URI: " & URI);
         T.Assert (Map.Servlet = Server, "Invalid mapping returned for URI: " & URI);
      end if;
   end Check_Mapping;

   --  ------------------------------
   --  Test session creation.
   --  ------------------------------
   procedure Test_Create_Servlet (T : in out Test) is
      Ctx : Servlet_Registry;

      Map : Mapping_Access;
   begin
      Ctx.Add_Servlet (Name => "Faces", Server => S1'Access);
      Ctx.Add_Servlet (Name => "Text", Server => S2'Access);

      Ctx.Add_Mapping (Pattern => "*.jsf", Name => "Faces");
      Ctx.Add_Mapping (Pattern => "*.html", Name => "Faces");
      Ctx.Add_Mapping (Pattern => "*.txt", Name => "Text");

      --  Ctx.Add_Mapping (Pattern => "/server", Server => S2'Access);
      Ctx.Add_Mapping (Pattern => "/server/john/*", Server => S2'Access);
      Ctx.Add_Mapping (Pattern => "/server/info", Server => S1'Access);
      Ctx.Add_Mapping (Pattern => "/server/list", Server => S1'Access);
      Ctx.Add_Mapping (Pattern => "/server/list2", Server => S2'Access);
      Ctx.Add_Mapping (Pattern => "/1/2/3/4/5/6/7/8/9/server/list2", Server => S2'Access);
      Ctx.Add_Mapping (Pattern => "/1/2/3/4/5/6/7/8/A/server/list2", Server => S1'Access);

      Ctx.Mappings.Dump_Map (" ");

      T.Check_Mapping (Ctx, "/joe/black/joe.jsf", S1'Access);
      T.Check_Mapping (Ctx, "/joe/black/joe.txt", S2'Access);
      T.Check_Mapping (Ctx, "/server/info", S1'Access);
      T.Check_Mapping (Ctx, "/server/list2", S2'Access);
      T.Check_Mapping (Ctx, "/1/2/3/4/5/6/7/8/9/server/list2", S2'Access);
      T.Check_Mapping (Ctx, "/1/2/3/4/5/6/7/8/A/server/list2", S1'Access);

      declare
         St : Util.Measures.Stamp;
      begin
         for I in 1 .. 1000 loop
            Map := Ctx.Find_Mapping (URI => "/joe/black/joe.jsf");
         end loop;
         Util.Measures.Report (St, "Find 1000 mapping (extension)");
      end;

      T.Assert (Map /= null, "No mapping for 'joe.jsf'");
      T.Assert (Map.Servlet /= null, "No servlet for mapping for 'joe.jsf'");
      T.Assert (Map.Servlet = S1'Access, "Invalid servlet");
      --        Util.Measures.Report (St, "10 Session create");

      declare
         St : Util.Measures.Stamp;
      begin
         for I in 1 .. 1000 loop
            Map := Ctx.Find_Mapping (URI => "/1/2/3/4/5/6/7/8/9/server/list2");
         end loop;
         Util.Measures.Report (St, "Find 1000 mapping (path)");
      end;

      T.Assert (Map /= null, "No mapping for '/server/john/joe.jsf'");
      T.Assert (Map.Servlet /= null, "No servlet for mapping for 'joe.jsf'");
      T.Assert (Map.Servlet = S2'Access, "Invalid servlet");
      --        Util.Measures.Report (St, "10 Session create");

   end Test_Create_Servlet;

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

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

   begin
      --  To document what is tested, register the test methods for each
      --  operation that is tested.
      Caller.Add_Test (Suite, "Test ASF.Servlets.Add_Mapping,Find_Mapping",
                       Test_Create_Servlet'Access);
      Caller.Add_Test (Suite, "Test ASF.Servlets.Add_Servlet",
                       Test_Add_Servlet'Access);
      Caller.Add_Test (Suite, "Test ASF.Servlets.Get_Request_Dispatcher",
                       Test_Request_Dispatcher'Access);
      Caller.Add_Test (Suite, "Test ASF.Servlets.Get_Resource",
                       Test_Get_Resource'Access);
      Caller.Add_Test (Suite, "Test ASF.Requests.Get_Servlet_Path",
                       Test_Servlet_Path'Access);
   end Add_Tests;

end ASF.Servlets.Tests;

Add a unit test to check the request servlet path


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

   Tests : aliased Util.Tests.Test_Suite;

   function Suite return Util.Tests.Access_Test_Suite is
      Ret : constant Util.Tests.Access_Test_Suite := Tests'Access;
   begin
      Security.OpenID.Tests.Add_Tests (Ret);
      Security.Permissions.Tests.Add_Tests (Ret);
      Security.Policies.Tests.Add_Tests (Ret);
      return Ret;
   end Suite;

end Security.Testsuite;

-----------------------------------------------------------------------
--  Security testsuite - Ada Security Test suite
--  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 Security.OpenID.Tests;
with Security.Permissions.Tests;
with Security.Policies.Tests;
with Security.OAuth.JWT.Tests;
package body Security.Testsuite is

   Tests : aliased Util.Tests.Test_Suite;

   function Suite return Util.Tests.Access_Test_Suite is
      Ret : constant Util.Tests.Access_Test_Suite := Tests'Access;
   begin
      Security.OAuth.JWT.Tests.Add_Tests (Ret);
      Security.OpenID.Tests.Add_Tests (Ret);
      Security.Permissions.Tests.Add_Tests (Ret);
      Security.Policies.Tests.Add_Tests (Ret);
      return Ret;
   end Suite;

end Security.Testsuite;

Add the new unit tests

Add the new unit tests


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

with Util.Log.Loggers;
with Util.Serialize.Mappers.Record_Mapper;

with Security.Controllers;
with Security.Controllers.Roles;

package body Security.Policies.Roles is

   use Util.Log;

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

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

   --  ------------------------------
   --  Get the role name.
   --  ------------------------------
   function Get_Role_Name (Manager : in Role_Policy;
                           Role    : in Role_Type) return String is
      use type Ada.Strings.Unbounded.String_Access;
   begin
      if Manager.Names (Role) = null then
         return "";
      else
         return Manager.Names (Role).all;
      end if;
   end Get_Role_Name;

   --  ------------------------------
   --  Find the role type associated with the role name identified by Name.
   --  Raises Invalid_Name if there is no role type.
   --  ------------------------------
   function Find_Role (Manager : in Role_Policy;
                       Name    : in String) return Role_Type is
      use type Ada.Strings.Unbounded.String_Access;
   begin
      Log.Debug ("Searching role {0}", Name);

      for I in Role_Type'First .. Manager.Next_Role loop
         exit when Manager.Names (I) = null;
         if Name = Manager.Names (I).all then
            return I;
         end if;
      end loop;

      Log.Debug ("Role {0} not found", Name);
      raise Invalid_Name;
   end Find_Role;

   --  ------------------------------
   --  Create a role
   --  ------------------------------
   procedure Create_Role (Manager : in out Role_Policy;
                          Name    : in String;
                          Role    : out Role_Type) is
   begin
      Role := Manager.Next_Role;
      Log.Info ("Role {0} is {1}", Name, Role_Type'Image (Role));

      if Manager.Next_Role = Role_Type'Last then
         Log.Error ("Too many roles allocated.  Number of roles is {0}",
                    Role_Type'Image (Role_Type'Last));
      else
         Manager.Next_Role := Manager.Next_Role + 1;
      end if;
      Manager.Names (Role) := new String '(Name);
   end Create_Role;

   --  ------------------------------
   --  Get or build a permission type for the given name.
   --  ------------------------------
   procedure Add_Role_Type (Manager   : in out Role_Policy;
                            Name      : in String;
                            Result    : out Role_Type) is
   begin
      Result := Manager.Find_Role (Name);

   exception
      when Invalid_Name =>
         Manager.Create_Role (Name, Result);
   end Add_Role_Type;

   type Config_Fields is (FIELD_NAME, FIELD_ROLE, FIELD_ROLE_PERMISSION, FIELD_ROLE_NAME);

   type Controller_Config_Access is access all Controller_Config;

   procedure Set_Member (Into  : in out Controller_Config;
                         Field : in Config_Fields;
                         Value : in Util.Beans.Objects.Object);

   --  ------------------------------
   --  Called while parsing the XML policy file when the <name>, <role> and <role-permission>
   --  XML entities are found.  Create the new permission when the complete permission definition
   --  has been parsed and save the permission in the security manager.
   --  ------------------------------
   procedure Set_Member (Into  : in out Controller_Config;
                         Field : in Config_Fields;
                         Value : in Util.Beans.Objects.Object) is
      use Security.Controllers.Roles;
   begin
      case Field is
         when FIELD_NAME =>
            Into.Name := Value;

         when FIELD_ROLE =>
            declare
               Role : constant String := Util.Beans.Objects.To_String (Value);
            begin
               Into.Roles (Into.Count + 1) := Into.Manager.Find_Role (Role);
               Into.Count := Into.Count + 1;

            exception
               when Permissions.Invalid_Name =>
                  raise Util.Serialize.Mappers.Field_Error with "Invalid role: " & Role;
            end;

         when FIELD_ROLE_PERMISSION =>
            if Into.Count = 0 then
               raise Util.Serialize.Mappers.Field_Error with "Missing at least one role";
            end if;
            declare
               Name : constant String := Util.Beans.Objects.To_String (Into.Name);
               Perm : constant Role_Controller_Access
                 := new Role_Controller '(Count => Into.Count,
                                          Roles => Into.Roles (1 .. Into.Count));
            begin
               Into.Manager.Add_Permission (Name, Perm.all'Access);
               Into.Count := 0;
            end;

         when FIELD_ROLE_NAME =>
            declare
               Name : constant String := Util.Beans.Objects.To_String (Value);
               Role : Role_Type;
            begin
               Into.Manager.Add_Role_Type (Name, Role);
            end;
      end case;
   end Set_Member;

   package Config_Mapper is
     new Util.Serialize.Mappers.Record_Mapper (Element_Type        => Controller_Config,
                                               Element_Type_Access => Controller_Config_Access,
                                               Fields              => Config_Fields,
                                               Set_Member          => Set_Member);

   Mapper : aliased Config_Mapper.Mapper;

   --  ------------------------------
   --  Setup the XML parser to read the role-permission description.  For example:
   --
   --  <security-role>
   --    <role-name>admin</role-name>
   --  </security-role>
   --  <role-permission>
   --     <name>create-workspace</name>
   --     <role>admin</role>
   --     <role>manager</role>
   --  </role-permission>
   --
   --  This defines a permission create-workspace that will be granted if the
   --  user has either the admin or the manager role.
   --  ------------------------------

   procedure Set_Reader_Config (Policy : in out Role_Policy;
                                Reader : in out Util.Serialize.IO.XML.Parser) is
      Config : Controller_Config_Access := new Controller_Config;
   begin
      Reader.Add_Mapping ("policy-rules", Mapper'Access);
      Reader.Add_Mapping ("module", Mapper'Access);
      Config.Manager := Policy'Unchecked_Access;
      Config_Mapper.Set_Context (Reader, Config);
   end Set_Reader_Config;

begin
   Mapper.Add_Mapping ("role-permission", FIELD_ROLE_PERMISSION);
   Mapper.Add_Mapping ("role-permission/name", FIELD_NAME);
   Mapper.Add_Mapping ("role-permission/role", FIELD_ROLE);
   Mapper.Add_Mapping ("security-role/role-name", FIELD_ROLE_NAME);
end Security.Policies.Roles;

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

with Util.Log.Loggers;
with Util.Serialize.Mappers.Record_Mapper;

with Security.Controllers;
with Security.Controllers.Roles;

package body Security.Policies.Roles is

   use Util.Log;

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

   --  ------------------------------
   --  Get the role name.
   --  ------------------------------
   function Get_Role_Name (Manager : in Role_Policy;
                           Role    : in Role_Type) return String is
      use type Ada.Strings.Unbounded.String_Access;
   begin
      if Manager.Names (Role) = null then
         return "";
      else
         return Manager.Names (Role).all;
      end if;
   end Get_Role_Name;

   --  ------------------------------
   --  Find the role type associated with the role name identified by Name.
   --  Raises Invalid_Name if there is no role type.
   --  ------------------------------
   function Find_Role (Manager : in Role_Policy;
                       Name    : in String) return Role_Type is
      use type Ada.Strings.Unbounded.String_Access;
   begin
      Log.Debug ("Searching role {0}", Name);

      for I in Role_Type'First .. Manager.Next_Role loop
         exit when Manager.Names (I) = null;
         if Name = Manager.Names (I).all then
            return I;
         end if;
      end loop;

      Log.Debug ("Role {0} not found", Name);
      raise Invalid_Name;
   end Find_Role;

   --  ------------------------------
   --  Create a role
   --  ------------------------------
   procedure Create_Role (Manager : in out Role_Policy;
                          Name    : in String;
                          Role    : out Role_Type) is
   begin
      Role := Manager.Next_Role;
      Log.Info ("Role {0} is {1}", Name, Role_Type'Image (Role));

      if Manager.Next_Role = Role_Type'Last then
         Log.Error ("Too many roles allocated.  Number of roles is {0}",
                    Role_Type'Image (Role_Type'Last));
      else
         Manager.Next_Role := Manager.Next_Role + 1;
      end if;
      Manager.Names (Role) := new String '(Name);
   end Create_Role;

   --  ------------------------------
   --  Get or build a permission type for the given name.
   --  ------------------------------
   procedure Add_Role_Type (Manager   : in out Role_Policy;
                            Name      : in String;
                            Result    : out Role_Type) is
   begin
      Result := Manager.Find_Role (Name);

   exception
      when Invalid_Name =>
         Manager.Create_Role (Name, Result);
   end Add_Role_Type;

   type Config_Fields is (FIELD_NAME, FIELD_ROLE, FIELD_ROLE_PERMISSION, FIELD_ROLE_NAME);

   type Controller_Config_Access is access all Controller_Config;

   procedure Set_Member (Into  : in out Controller_Config;
                         Field : in Config_Fields;
                         Value : in Util.Beans.Objects.Object);

   --  ------------------------------
   --  Called while parsing the XML policy file when the <name>, <role> and <role-permission>
   --  XML entities are found.  Create the new permission when the complete permission definition
   --  has been parsed and save the permission in the security manager.
   --  ------------------------------
   procedure Set_Member (Into  : in out Controller_Config;
                         Field : in Config_Fields;
                         Value : in Util.Beans.Objects.Object) is
      use Security.Controllers.Roles;
   begin
      case Field is
         when FIELD_NAME =>
            Into.Name := Value;

         when FIELD_ROLE =>
            declare
               Role : constant String := Util.Beans.Objects.To_String (Value);
            begin
               Into.Roles (Into.Count + 1) := Into.Manager.Find_Role (Role);
               Into.Count := Into.Count + 1;

            exception
               when Permissions.Invalid_Name =>
                  raise Util.Serialize.Mappers.Field_Error with "Invalid role: " & Role;
            end;

         when FIELD_ROLE_PERMISSION =>
            if Into.Count = 0 then
               raise Util.Serialize.Mappers.Field_Error with "Missing at least one role";
            end if;
            declare
               Name : constant String := Util.Beans.Objects.To_String (Into.Name);
               Perm : constant Role_Controller_Access
                 := new Role_Controller '(Count => Into.Count,
                                          Roles => Into.Roles (1 .. Into.Count));
            begin
               Into.Manager.Add_Permission (Name, Perm.all'Access);
               Into.Count := 0;
            end;

         when FIELD_ROLE_NAME =>
            declare
               Name : constant String := Util.Beans.Objects.To_String (Value);
               Role : Role_Type;
            begin
               Into.Manager.Add_Role_Type (Name, Role);
            end;
      end case;
   end Set_Member;

   package Config_Mapper is
     new Util.Serialize.Mappers.Record_Mapper (Element_Type        => Controller_Config,
                                               Element_Type_Access => Controller_Config_Access,
                                               Fields              => Config_Fields,
                                               Set_Member          => Set_Member);

   Mapper : aliased Config_Mapper.Mapper;

   --  ------------------------------
   --  Setup the XML parser to read the role-permission description.  For example:
   --
   --  <security-role>
   --    <role-name>admin</role-name>
   --  </security-role>
   --  <role-permission>
   --     <name>create-workspace</name>
   --     <role>admin</role>
   --     <role>manager</role>
   --  </role-permission>
   --
   --  This defines a permission create-workspace that will be granted if the
   --  user has either the admin or the manager role.
   --  ------------------------------

   procedure Set_Reader_Config (Policy : in out Role_Policy;
                                Reader : in out Util.Serialize.IO.XML.Parser) is
      Config : Controller_Config_Access := new Controller_Config;
   begin
      Reader.Add_Mapping ("policy-rules", Mapper'Access);
      Reader.Add_Mapping ("module", Mapper'Access);
      Config.Manager := Policy'Unchecked_Access;
      Config_Mapper.Set_Context (Reader, Config);
   end Set_Reader_Config;

begin
   Mapper.Add_Mapping ("role-permission", FIELD_ROLE_PERMISSION);
   Mapper.Add_Mapping ("role-permission/name", FIELD_NAME);
   Mapper.Add_Mapping ("role-permission/role", FIELD_ROLE);
   Mapper.Add_Mapping ("security-role/role-name", FIELD_ROLE_NAME);
end Security.Policies.Roles;

Update the comments and logger

Update the comments and logger


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

with Ada.Strings.Unbounded;

--  == Role Based Security Policy ==
--  The <tt>Security.Policies.Roles</tt> package implements a role based security policy.
--
--  === Policy creation ===
--  An instance of the <tt>Role_Policy</tt> must be created and registered in the policy manager.
--  Get or declare the following variables:
--
--    Manager : Security.Policies.Policy_Manager;
--    Policy  : Security.Policies.Roles.Role_Policy_Access;
--
--  Create the role policy and register it in the policy manager as follows:
--
--    Policy := new Role_Policy;
--    Manager.Add_Policy (Policy.all'Access);
--
--  === Policy Configuration ===
--  A role is represented by a name in security configuration files.  A role based permission
--  is associated with a list of roles.  The permission is granted if the user has one of these
--  roles.  When the role based policy is registered in the policy manager, the following
--  XML configuration is used:
--
--    <security-role>
--      <role-name>admin</role-name>
--    </security-role>
--    <security-role>
--      <role-name>manager</role-name>
--    </security-role>
--    <role-permission>
--      <name>create-workspace</name>
--      <role>admin</role>
--      <role>manager</role>
--    </role-permission>
--
--  This definition declares two roles: <tt>admin</tt> and <tt>manager</tt>
--  It defines a permission create-workspace that will be granted if the
--  user has either the admin or the manager role.
--
--  Each role is identified by a name in the configuration file.  It is represented by
--  a <tt>Role_Type</tt>.  To provide an efficient implementation, the <tt>Role_Type</tt>
--  is represented as an integer with a limit of 64 different roles.
--
--  === Assigning roles to users ===
--  A <tt>Security_Context</tt> must be associated with a set of roles before checking the
--  permission.  This is done by using the <tt>Set_Role_Context</tt> operation:
--
--     Security.Policies.Roles.Set_Role_Context (Security.Contexts.Current, "admin");
--
package Security.Policies.Roles is

   NAME : constant String := "Role-Policy";

   --  Each role is represented by a Role_Type number to provide a fast
   --  and efficient role check.
   type Role_Type is new Natural range 0 .. 63;
   for Role_Type'Size use 8;

   type Role_Type_Array is array (Positive range <>) of Role_Type;

   --  The Role_Map represents a set of roles which are assigned to a user.
   --  Each role is represented by a boolean in the map.  The implementation is limited
   --  to 64 roles (the number of different permissions can be higher).
   type Role_Map is array (Role_Type'Range) of Boolean;
   pragma Pack (Role_Map);

   --  ------------------------------
   --  Role principal context
   --  ------------------------------
   --  The <tt>Role_Principal_Context</tt> interface must be implemented by the user
   --  <tt>Principal</tt> to be able to use the role based policy.   The role based policy
   --  controller will first check that the <tt>Principal</tt> implements that interface.
   --  It uses the <tt>Get_Roles</tt> function to get the current roles assigned to the user.
   type Role_Principal_Context is limited interface;
   function Get_Roles (User : in Role_Principal_Context) return Role_Map is abstract;

   --  ------------------------------
   --  Policy context
   --  ------------------------------
   --  The Role_Policy_Context gives security context information that the role
   --  based policy can use to verify the permission.
   type Role_Policy_Context is new Policy_Context with record
      Roles : Role_Map;
   end record;
   type Role_Policy_Context_Access is access all Role_Policy_Context'Class;

   --  Set the roles which are assigned to the user in the security context.
   --  The role policy will use these roles to verify a permission.
   procedure Set_Role_Context (Context : in out Security.Contexts.Security_Context'Class;
                               Roles   : in Role_Map);

   --  Set the roles which are assigned to the user in the security context.
   --  The role policy will use these roles to verify a permission.
   procedure Set_Role_Context (Context : in out Security.Contexts.Security_Context'Class;
                               Roles   : in String);

   --  ------------------------------
   --  Role based policy
   --  ------------------------------
   type Role_Policy is new Policy with private;
   type Role_Policy_Access is access all Role_Policy'Class;

   Invalid_Name : exception;

   --  Get the policy name.
   overriding
   function Get_Name (From : in Role_Policy) return String;

   --  Find the role type associated with the role name identified by Name.
   --  Raises Invalid_Name if there is no role type.
   function Find_Role (Manager : in Role_Policy;
                       Name    : in String) return Role_Type;

   --  Get the role name.
   function Get_Role_Name (Manager : in Role_Policy;
                           Role    : in Role_Type) return String;

   --  Create a role
   procedure Create_Role (Manager : in out Role_Policy;
                          Name    : in String;
                          Role    : out Role_Type);

   --  Get or add a role type for the given name.
   procedure Add_Role_Type (Manager   : in out Role_Policy;
                            Name      : in String;
                            Result    : out Role_Type);

   --  Set the roles specified in the <tt>Roles</tt> parameter.  Each role is represented by
   --  its name and multiple roles are separated by ','.
   --  Raises Invalid_Name if a role was not found.
   procedure Set_Roles (Manager : in Role_Policy;
                        Roles   : in String;
                        Into    : out Role_Map);

   --  Setup the XML parser to read the role-permission description.
   overriding
   procedure Prepare_Config (Policy : in out Role_Policy;
                             Reader : in out Util.Serialize.IO.XML.Parser);

   --  Finalize the policy manager.
   overriding
   procedure Finalize (Policy : in out Role_Policy);

   --  Get the role policy associated with the given policy manager.
   --  Returns the role policy instance or null if it was not registered in the policy manager.
   function Get_Role_Policy (Manager : in Security.Policies.Policy_Manager'Class)
                             return Role_Policy_Access;

private

   type Role_Name_Array is
     array (Role_Type'Range) of Ada.Strings.Unbounded.String_Access;

   type Role_Policy is new Policy with record
      Names        : Role_Name_Array;
      Next_Role    : Role_Type := Role_Type'First;
   end record;

   type Controller_Config is record
      Name    : Util.Beans.Objects.Object;
      Roles   : Role_Type_Array (1 .. Integer (Role_Type'Last));
      Count   : Natural := 0;
      Manager : Role_Policy_Access;
   end record;

end Security.Policies.Roles;

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

with Ada.Strings.Unbounded;

--  == Role Based Security Policy ==
--  The <tt>Security.Policies.Roles</tt> package implements a role based security policy.
--  In this policy, users are assigned one or several roles and permissions are
--  associated with roles.  A permission is granted if the user has one of the roles required
--  by the permission.
--
--  === Policy creation ===
--  An instance of the <tt>Role_Policy</tt> must be created and registered in the policy manager.
--  Get or declare the following variables:
--
--    Manager : Security.Policies.Policy_Manager;
--    Policy  : Security.Policies.Roles.Role_Policy_Access;
--
--  Create the role policy and register it in the policy manager as follows:
--
--    Policy := new Role_Policy;
--    Manager.Add_Policy (Policy.all'Access);
--
--  === Policy Configuration ===
--  A role is represented by a name in security configuration files.  A role based permission
--  is associated with a list of roles.  The permission is granted if the user has one of these
--  roles.  When the role based policy is registered in the policy manager, the following
--  XML configuration is used:
--
--    <security-role>
--      <role-name>admin</role-name>
--    </security-role>
--    <security-role>
--      <role-name>manager</role-name>
--    </security-role>
--    <role-permission>
--      <name>create-workspace</name>
--      <role>admin</role>
--      <role>manager</role>
--    </role-permission>
--
--  This definition declares two roles: <tt>admin</tt> and <tt>manager</tt>
--  It defines a permission create-workspace that will be granted if the
--  user has either the admin or the manager role.
--
--  Each role is identified by a name in the configuration file.  It is represented by
--  a <tt>Role_Type</tt>.  To provide an efficient implementation, the <tt>Role_Type</tt>
--  is represented as an integer with a limit of 64 different roles.
--
--  === Assigning roles to users ===
--  A <tt>Security_Context</tt> must be associated with a set of roles before checking the
--  permission.  This is done by using the <tt>Set_Role_Context</tt> operation:
--
--     Security.Policies.Roles.Set_Role_Context (Security.Contexts.Current, "admin");
--
package Security.Policies.Roles is

   NAME : constant String := "Role-Policy";

   --  Each role is represented by a Role_Type number to provide a fast
   --  and efficient role check.
   type Role_Type is new Natural range 0 .. 63;
   for Role_Type'Size use 8;

   type Role_Type_Array is array (Positive range <>) of Role_Type;

   --  The Role_Map represents a set of roles which are assigned to a user.
   --  Each role is represented by a boolean in the map.  The implementation is limited
   --  to 64 roles (the number of different permissions can be higher).
   type Role_Map is array (Role_Type'Range) of Boolean;
   pragma Pack (Role_Map);

   --  ------------------------------
   --  Role principal context
   --  ------------------------------
   --  The <tt>Role_Principal_Context</tt> interface must be implemented by the user
   --  <tt>Principal</tt> to be able to use the role based policy.   The role based policy
   --  controller will first check that the <tt>Principal</tt> implements that interface.
   --  It uses the <tt>Get_Roles</tt> function to get the current roles assigned to the user.
   type Role_Principal_Context is limited interface;
   function Get_Roles (User : in Role_Principal_Context) return Role_Map is abstract;

   --  ------------------------------
   --  Policy context
   --  ------------------------------
   --  The Role_Policy_Context gives security context information that the role
   --  based policy can use to verify the permission.
   type Role_Policy_Context is new Policy_Context with record
      Roles : Role_Map;
   end record;
   type Role_Policy_Context_Access is access all Role_Policy_Context'Class;

   --  Set the roles which are assigned to the user in the security context.
   --  The role policy will use these roles to verify a permission.
   procedure Set_Role_Context (Context : in out Security.Contexts.Security_Context'Class;
                               Roles   : in Role_Map);

   --  Set the roles which are assigned to the user in the security context.
   --  The role policy will use these roles to verify a permission.
   procedure Set_Role_Context (Context : in out Security.Contexts.Security_Context'Class;
                               Roles   : in String);

   --  ------------------------------
   --  Role based policy
   --  ------------------------------
   type Role_Policy is new Policy with private;
   type Role_Policy_Access is access all Role_Policy'Class;

   Invalid_Name : exception;

   --  Get the policy name.
   overriding
   function Get_Name (From : in Role_Policy) return String;

   --  Find the role type associated with the role name identified by Name.
   --  Raises Invalid_Name if there is no role type.
   function Find_Role (Manager : in Role_Policy;
                       Name    : in String) return Role_Type;

   --  Get the role name.
   function Get_Role_Name (Manager : in Role_Policy;
                           Role    : in Role_Type) return String;

   --  Create a role
   procedure Create_Role (Manager : in out Role_Policy;
                          Name    : in String;
                          Role    : out Role_Type);

   --  Get or add a role type for the given name.
   procedure Add_Role_Type (Manager   : in out Role_Policy;
                            Name      : in String;
                            Result    : out Role_Type);

   --  Set the roles specified in the <tt>Roles</tt> parameter.  Each role is represented by
   --  its name and multiple roles are separated by ','.
   --  Raises Invalid_Name if a role was not found.
   procedure Set_Roles (Manager : in Role_Policy;
                        Roles   : in String;
                        Into    : out Role_Map);

   --  Setup the XML parser to read the role-permission description.
   overriding
   procedure Prepare_Config (Policy : in out Role_Policy;
                             Reader : in out Util.Serialize.IO.XML.Parser);

   --  Finalize the policy manager.
   overriding
   procedure Finalize (Policy : in out Role_Policy);

   --  Get the role policy associated with the given policy manager.
   --  Returns the role policy instance or null if it was not registered in the policy manager.
   function Get_Role_Policy (Manager : in Security.Policies.Policy_Manager'Class)
                             return Role_Policy_Access;

private

   type Role_Name_Array is
     array (Role_Type'Range) of Ada.Strings.Unbounded.String_Access;

   type Role_Policy is new Policy with record
      Names        : Role_Name_Array;
      Next_Role    : Role_Type := Role_Type'First;
   end record;

   type Controller_Config is record
      Name    : Util.Beans.Objects.Object;
      Roles   : Role_Type_Array (1 .. Integer (Role_Type'Last));
      Count   : Natural := 0;
      Manager : Role_Policy_Access;
   end record;

end Security.Policies.Roles;

Document the role based policy

Document the role based policy


------------------------------------------------------------------------------
--                        Bareboard drivers examples                        --
--                                                                          --
--                     Copyright (C) 2015-2016, AdaCore                     --
--                                                                          --
-- This library is free software;  you can redistribute it and/or modify it --
-- under terms of the  GNU General Public License  as published by the Free --
-- Software  Foundation;  either version 3,  or (at your  option) any later --
-- version. This library is distributed in the hope that it will be useful, --
-- but WITHOUT ANY WARRANTY;  without even the implied warranty of MERCHAN- --
-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.                            --
--                                                                          --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception,   --
-- version 3.1, as published by the Free Software Foundation.               --
--                                                                          --
-- You should have received a copy of the GNU General Public License and    --
-- a copy of the GCC Runtime Library Exception along with this program;     --
-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
-- <http://www.gnu.org/licenses/>.                                          --
--                                                                          --
------------------------------------------------------------------------------

package Trains with
  SPARK_Mode
is
   --  the railroad is composed of a set of one-way tracks, where each track
   --  joins two locations. A track has a length that is a multiple of an
   --  elementary distance.

   Num_Locations : constant := 39;

   type Location is new Positive range 1 .. Num_Locations;

   type Track is record
      From   : Location;
      To     : Location;
      Length : Positive;
   end record;

   Num_Tracks : constant := 51;

   type Track_Opt_Id is new Natural range 0 .. Num_Tracks;
   subtype Track_Id is Track_Opt_Id range 1 .. Num_Tracks;

   No_Track_Id : constant Track_Opt_Id := 0;

   --  example railroad going around between locations 1 to 5, with additional
   --  tracks from 1 to 3, 2 to 5 and 3 to 5.
   Tracks : array (Track_Id) of Track := (others => (1, 1, 1));

   --  the map of previous tracks records for each location the tracks that
   --  precede it. This information should be consistent with the one in
   --  Tracks.

   Max_Num_Previous_Tracks : constant := 3;

   type Prev_Id is range 1 .. Max_Num_Previous_Tracks;
   type Track_Ids is array (Prev_Id) of Track_Opt_Id;

   Previous_Tracks : array (Location) of Track_Ids := (others => (0, 0, 0));

   --  the railroad should respect the property that no track precedes itself

   function No_Track_Precedes_Itself return Boolean is
      (for all Track in Track_Id =>
          (for all Id in Prev_Id =>
              Previous_Tracks (Tracks (Track).From) (Id) /= Track));

   --  a train is identified by its unique identifier. The position of each
   --  train is given by the starting track it's in (Track_Begin) and the
   --  position in this track (Pos_Begin), with the ending track it's in
   --  (Track_End) which can be the same as the starting track. A train
   --  can never be on three tracks.

   Max_Num_Trains : constant := 20;

   type Trains_Count is new Natural range 0 .. Max_Num_Trains;

   subtype Train_Id is Trains_Count range 1 .. Max_Num_Trains;

   Cur_Num_Trains : Trains_Count := 0;

   type Train_Position is record
      Track_Begin : Track_Id;
      Pos_Begin   : Natural;
      Track_End   : Track_Id;
   end record;

   Trains : array (Train_Id) of Train_Position;

   function Entering_A_Track (Position : Train_Position) return Boolean is
      (Position.Track_Begin /= Position.Track_End and then
       (for some Id in Prev_Id =>
             Position.Track_End =
               Previous_Tracks (Tracks (Position.Track_Begin).From) (Id)));

   function Inside_A_Track (Position : Train_Position) return Boolean is
      (Position.Track_Begin = Position.Track_End);

   --  it should always hold that there is at most one train in every track
   --  segment

   function One_Train_At_Most_Per_Track return Boolean is
      (for all Train in Train_Id range 1 .. Cur_Num_Trains =>
         (for all Other_Train in Train_Id range 1 .. Cur_Num_Trains =>
             (if Other_Train /= Train then
                Trains (Train).Track_Begin /= Trains (Other_Train).Track_Begin
              and then
                Trains (Train).Track_Begin /= Trains (Other_Train).Track_End
              and then
                 Trains (Train).Track_End /= Trains (Other_Train).Track_Begin
              and then
                Trains (Train).Track_End /= Trains (Other_Train).Track_End)));

   --  at each instant, the behavior of the train depends on the value of the
   --  signal on the track it's in and on the track ahead

   type Signal is (Green, Orange, Red);

   Track_Signals : array (Track_Id) of Signal;

   --  the signal should be Red on every track on which there is a train, and
   --  Orange on every previous track, unless already Red on that track.

   function Occupied_Tracks_On_Red return Boolean is
      (for all Train in Train_Id range 1 .. Cur_Num_Trains =>
         Track_Signals (Trains (Train).Track_Begin) = Red and then
         Track_Signals (Trains (Train).Track_End) = Red);

   --  Return the Id'th track that precedes the ending track of the train
   function Get_Previous_Track
     (Position : Train_Position;
      Id       : Prev_Id) return Track_Opt_Id
   is
      (Previous_Tracks (Tracks (Position.Track_End).From) (Id));

   --  Return the Id'th track that precedes the starting track of the train,
   --  provided it is different from the ending track of the train
   function Get_Other_Previous_Track
     (Position : Train_Position;
      Id       : Prev_Id) return Track_Opt_Id
   is
      (if Previous_Tracks (Tracks (Position.Track_Begin).From) (Id) =
           Position.Track_End
       then
          No_Track_Id
       else
          Previous_Tracks (Tracks (Position.Track_Begin).From) (Id));

   function Is_Previous_Track
     (Position : Train_Position;
      Track    : Track_Id) return Boolean
   is
      (for some Id in Prev_Id =>
         Track = Get_Previous_Track (Position, Id)
           or else
         Track = Get_Other_Previous_Track (Position, Id));

   function Previous_Tracks_On_Orange_Or_Red return Boolean is
      (for all Train in Train_Id range 1 .. Cur_Num_Trains =>
         (for all Id in Prev_Id =>
            (if Get_Previous_Track (Trains (Train), Id) /= No_Track_Id then
               Track_Signals (Get_Previous_Track (Trains (Train), Id)) in
                 Orange | Red)
              and then
            (if Get_Other_Previous_Track (Trains (Train), Id) /= No_Track_Id
             then
               Track_Signals (Get_Other_Previous_Track (Trains (Train), Id)) in
                 Orange | Red)));

   function Safe_Signaling return Boolean is
      (Occupied_Tracks_On_Red and then
       Previous_Tracks_On_Orange_Or_Red);

   --  valid movements of trains can be of 3 kinds:
   --    . moving inside one or two tracks
   --    . entering a new track
   --    . leaving a track

   --  The following functions correspond each to one of these kinds of
   --  movements. Function Valid_Move returns whether a movement is among
   --  these 3 kinds.

   function Moving_Inside_Current_Tracks
     (Cur_Position : Train_Position;
      New_Position : Train_Position) return Boolean
   is
      (Cur_Position.Track_Begin = New_Position.Track_Begin and then
       Cur_Position.Track_End = New_Position.Track_End);

   function Moving_To_A_New_Track
     (Cur_Position : Train_Position;
      New_Position : Train_Position) return Boolean
   is
      (Inside_A_Track (Cur_Position) and then
       Entering_A_Track (New_Position) and then
       Cur_Position.Track_Begin = New_Position.Track_End);

   function Moving_Away_From_Current_Track
     (Cur_Position : Train_Position;
      New_Position : Train_Position) return Boolean
   is
      (Entering_A_Track (Cur_Position) and then
       Inside_A_Track (New_Position) and then
       Cur_Position.Track_Begin = New_Position.Track_End);

   function Valid_Move
     (Cur_Position : Train_Position;
      New_Position : Train_Position) return Boolean
   is
      --  either the train keeps moving in the current tracks
      (Moving_Inside_Current_Tracks (Cur_Position, New_Position)
         or else
      --  or the train was inside a track and enters a new track
       Moving_To_A_New_Track (Cur_Position, New_Position)
         or else
      --  or the train was entering a track and leaves the previous one
       Moving_Away_From_Current_Track (Cur_Position, New_Position));

   --  moving the train ahead along a valid movement can result in:
   --    . Full_Speed: the movement was performed, the position of the train
   --                  (Trains) and the signals (Track_Signals) have been
   --                  updated, and the train can continue full speed.
   --    . Slow_Down:  Same as Full_Speed, but the train is entering an Orange
   --                  track and should slow down.
   --    . Keep_Going: Same as Full_Speed, but the train should keep its
   --                  current speed.
   --    . Stop:       No movement performed, the train should stop here,
   --                  prior to entering a Red track.

   type Move_Result is (Full_Speed, Slow_Down, Keep_Going, Stop);

   procedure Move
     (Train        : Train_Id;
      New_Position : Train_Position;
      Result       : out Move_Result)
   with
     Global => (Input  => (Cur_Num_Trains, Previous_Tracks, Tracks),
                In_Out => (Trains, Track_Signals)),
     Pre  => Train in 1 .. Cur_Num_Trains and then
             Valid_Move (Trains (Train), New_Position) and then
             One_Train_At_Most_Per_Track and then
             Safe_Signaling,
     Post => One_Train_At_Most_Per_Track and then
             Safe_Signaling;

end Trains;

------------------------------------------------------------------------------
--                        Bareboard drivers examples                        --
--                                                                          --
--                     Copyright (C) 2015-2016, AdaCore                     --
--                                                                          --
-- This library is free software;  you can redistribute it and/or modify it --
-- under terms of the  GNU General Public License  as published by the Free --
-- Software  Foundation;  either version 3,  or (at your  option) any later --
-- version. This library is distributed in the hope that it will be useful, --
-- but WITHOUT ANY WARRANTY;  without even the implied warranty of MERCHAN- --
-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.                            --
--                                                                          --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception,   --
-- version 3.1, as published by the Free Software Foundation.               --
--                                                                          --
-- You should have received a copy of the GNU General Public License and    --
-- a copy of the GCC Runtime Library Exception along with this program;     --
-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
-- <http://www.gnu.org/licenses/>.                                          --
--                                                                          --
------------------------------------------------------------------------------

package Trains with
  SPARK_Mode
is
   --  the railroad is composed of a set of one-way tracks, where each track
   --  joins two locations. A track has a length that is a multiple of an
   --  elementary distance.

   Num_Locations : constant := 39;

   type Location is new Positive range 1 .. Num_Locations;

   type Track is record
      From   : Location;
      To     : Location;
      Length : Positive;
   end record;

   Num_Tracks : constant := 51;

   type Track_Opt_Id is new Natural range 0 .. Num_Tracks;
   subtype Track_Id is Track_Opt_Id range 1 .. Num_Tracks;

   No_Track_Id : constant Track_Opt_Id := 0;

   --  example railroad going around between locations 1 to 5, with additional
   --  tracks from 1 to 3, 2 to 5 and 3 to 5.
   Tracks : array (Track_Id) of Track := (others => (1, 1, 1));

   --  the map of previous tracks records for each location the tracks that
   --  precede it. This information should be consistent with the one in
   --  Tracks.

   Max_Num_Previous_Tracks : constant := 3;

   type Prev_Id is range 1 .. Max_Num_Previous_Tracks;
   type Track_Ids is array (Prev_Id) of Track_Opt_Id;

   Previous_Tracks : array (Location) of Track_Ids := (others => (0, 0, 0));

   --  the railroad should respect the property that no track precedes itself

   function No_Track_Precedes_Itself return Boolean is
      (for all Track in Track_Id =>
          (for all Id in Prev_Id =>
              Previous_Tracks (Tracks (Track).From) (Id) /= Track));

   --  a train is identified by its unique identifier. The position of each
   --  train is given by the starting track it's in (Track_Begin) and the
   --  position in this track (Pos_Begin), with the ending track it's in
   --  (Track_End) which can be the same as the starting track. A train
   --  can never be on three tracks.

   Max_Num_Trains : constant := 20;

   type Trains_Count is new Natural range 0 .. Max_Num_Trains;

   subtype Train_Id is Trains_Count range 1 .. Max_Num_Trains;

   Cur_Num_Trains : Trains_Count := 0;

   type Train_Position is record
      Track_Begin : Track_Id;
      Pos_Begin   : Natural;
      Track_End   : Track_Id;
   end record;

   Trains : array (Train_Id) of Train_Position;

   function Entering_A_Track (Position : Train_Position) return Boolean is
      (Position.Track_Begin /= Position.Track_End and then
       (for some Id in Prev_Id =>
             Position.Track_End =
               Previous_Tracks (Tracks (Position.Track_Begin).From) (Id)));

   function Inside_A_Track (Position : Train_Position) return Boolean is
      (Position.Track_Begin = Position.Track_End);

   --  it should always hold that there is at most one train in every track
   --  segment

   function One_Train_At_Most_Per_Track return Boolean is
      (for all Train in Train_Id range 1 .. Cur_Num_Trains =>
         (for all Other_Train in Train_Id range 1 .. Cur_Num_Trains =>
             (if Other_Train /= Train then
                Trains (Train).Track_Begin /= Trains (Other_Train).Track_Begin
              and then
                Trains (Train).Track_Begin /= Trains (Other_Train).Track_End
              and then
                 Trains (Train).Track_End /= Trains (Other_Train).Track_Begin
              and then
                Trains (Train).Track_End /= Trains (Other_Train).Track_End)));

   --  at each instant, the behavior of the train depends on the value of the
   --  signal on the track it's in and on the track ahead

   type Signal is (Green, Orange, Red);

   Track_Signals : array (Track_Id) of Signal;

   --  the signal should be Red on every track on which there is a train, and
   --  Orange on every previous track, unless already Red on that track.

   function Occupied_Tracks_On_Red return Boolean is
      (for all Train in Train_Id range 1 .. Cur_Num_Trains =>
         Track_Signals (Trains (Train).Track_Begin) = Red and then
         Track_Signals (Trains (Train).Track_End) = Red);

   --  Return the Id'th track that precedes the ending track of the train
   function Get_Previous_Track
     (Position : Train_Position;
      Id       : Prev_Id) return Track_Opt_Id
   is
      (Previous_Tracks (Tracks (Position.Track_End).From) (Id));

   --  Return the Id'th track that precedes the starting track of the train,
   --  provided it is different from the ending track of the train
   function Get_Other_Previous_Track
     (Position : Train_Position;
      Id       : Prev_Id) return Track_Opt_Id
   is
      (if Previous_Tracks (Tracks (Position.Track_Begin).From) (Id) =
           Position.Track_End
       then
          No_Track_Id
       else
          Previous_Tracks (Tracks (Position.Track_Begin).From) (Id));

   function Is_Previous_Track
     (Position : Train_Position;
      Track    : Track_Id) return Boolean
   is
      (for some Id in Prev_Id =>
         Track = Get_Previous_Track (Position, Id)
           or else
         Track = Get_Other_Previous_Track (Position, Id));

   function Previous_Tracks_On_Orange_Or_Red return Boolean is
      (for all Train in Train_Id range 1 .. Cur_Num_Trains =>
         (for all Id in Prev_Id =>
            (if Get_Previous_Track (Trains (Train), Id) /= No_Track_Id then
               Track_Signals (Get_Previous_Track (Trains (Train), Id)) in
                 Orange | Red)
              and then
            (if Get_Other_Previous_Track (Trains (Train), Id) /= No_Track_Id
             then
               Track_Signals (Get_Other_Previous_Track (Trains (Train), Id)) in
                 Orange | Red)));

   function Safe_Signaling return Boolean is
      (Occupied_Tracks_On_Red and then
       Previous_Tracks_On_Orange_Or_Red);

   --  valid movements of trains can be of 3 kinds:
   --    . moving inside one or two tracks
   --    . entering a new track
   --    . leaving a track

   --  The following functions correspond each to one of these kinds of
   --  movements. Function Valid_Move returns whether a movement is among
   --  these 3 kinds.

   function Moving_Inside_Current_Tracks
     (Cur_Position : Train_Position;
      New_Position : Train_Position) return Boolean
   is
      (Cur_Position.Track_Begin = New_Position.Track_Begin and then
       Cur_Position.Track_End = New_Position.Track_End);

   function Moving_To_A_New_Track
     (Cur_Position : Train_Position;
      New_Position : Train_Position) return Boolean
   is
      (Inside_A_Track (Cur_Position) and then
       Entering_A_Track (New_Position) and then
       Cur_Position.Track_Begin = New_Position.Track_End);

   function Moving_Away_From_Current_Track
     (Cur_Position : Train_Position;
      New_Position : Train_Position) return Boolean
   is
      (Entering_A_Track (Cur_Position) and then
       Inside_A_Track (New_Position) and then
       Cur_Position.Track_Begin = New_Position.Track_End);

   function Valid_Move
     (Cur_Position : Train_Position;
      New_Position : Train_Position) return Boolean
   is
      --  either the train keeps moving in the current tracks
      (Moving_Inside_Current_Tracks (Cur_Position, New_Position)
         or else
      --  or the train was inside a track and enters a new track
       Moving_To_A_New_Track (Cur_Position, New_Position)
         or else
      --  or the train was entering a track and leaves the previous one
       Moving_Away_From_Current_Track (Cur_Position, New_Position));

   --  moving the train ahead along a valid movement can result in:
   --    . Full_Speed: the movement was performed, the position of the train
   --                  (Trains) and the signals (Track_Signals) have been
   --                  updated, and the train can continue full speed.
   --    . Slow_Down:  Same as Full_Speed, but the train is entering an Orange
   --                  track and should slow down.
   --    . Keep_Going: Same as Full_Speed, but the train should keep its
   --                  current speed.
   --    . Stop:       No movement performed, the train should stop here,
   --                  prior to entering a Red track.

   type Move_Result is (Full_Speed, Slow_Down, Keep_Going, Stop);

   procedure Move
     (Train        : Train_Id;
      New_Position : Train_Position;
      Result       : out Move_Result)
   with
     Global => (Input  => (Cur_Num_Trains, Previous_Tracks, Tracks),
                In_Out => (Trains, Track_Signals)),
     Pre  => Train <= Cur_Num_Trains and then
             Valid_Move (Trains (Train), New_Position) and then
             One_Train_At_Most_Per_Track and then
             Safe_Signaling,
     Post => One_Train_At_Most_Per_Track and then
             Safe_Signaling;

end Trains;

Fix a compilation warning in the Trains demo