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

with Security.Contexts;
with Security.Controllers;

package AWA.Permissions.Controllers is

   --  ------------------------------
   --  Security Controller
   --  ------------------------------
   --  The Entity_Controller implements an entity based permission check.
   --  The controller is configured through an XML description.  It uses an SQL statement
   --  to verify that a permission is granted.
   --
   --  The SQL query can use the following query parameters:
   --
   --

   --
entity_type

   --
The entity type identifier defined by the entity permission

   --
entity_id

   --
The entity identifier which is associated with an ACL entry to check

   --
user_id

   --
The user identifier

   --

   type Entity_Controller (Len : Positive) is
   limited new Security.Controllers.Controller with record
      SQL    : String (1 .. Len);
      Entity : ADO.Entity_Type;
   end record;
   type Entity_Controller_Access is access all Entity_Controller'Class;

   --  Returns true if the user associated with the security context Context has
   --  the permission to access a database entity.  The security context contains some
   --  information about the entity to check and the permission controller will use an
   --  SQL statement to verify the permission.
   function Has_Permission (Handler : in Entity_Controller;
                            Context : in Security.Contexts.Security_Context'Class)
                            return Boolean;

end AWA.Permissions.Controllers;

-----------------------------------------------------------------------
--  awa-permissions-controllers -- Permission controllers
--  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.Contexts;
with Security.Controllers;

package AWA.Permissions.Controllers is

   --  ------------------------------
   --  Security Controller
   --  ------------------------------
   --  The Entity_Controller implements an entity based permission check.
   --  The controller is configured through an XML description.  It uses an SQL statement
   --  to verify that a permission is granted.
   --
   --  The SQL query can use the following query parameters:
   --
   --

   --
entity_type

   --
The entity type identifier defined by the entity permission

   --
entity_id

   --
The entity identifier which is associated with an ACL entry to check

   --
user_id

   --
The user identifier

   --

   type Entity_Controller (Len : Positive) is
   limited new Security.Controllers.Controller with record
      SQL    : String (1 .. Len);
      Entity : ADO.Entity_Type;
   end record;
   type Entity_Controller_Access is access all Entity_Controller'Class;

   --  Returns true if the user associated with the security context Context has
   --  the permission to access a database entity.  The security context contains some
   --  information about the entity to check and the permission controller will use an
   --  SQL statement to verify the permission.
   overriding
   function Has_Permission (Handler : in Entity_Controller;
                            Context : in Security.Contexts.Security_Context'Class;
                            Permission : in Security.Permissions.Permission'Class)
                            return Boolean;

end AWA.Permissions.Controllers;

Fix Has_Permission to have the Permission object


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

--  == Introduction ==
--  The *workspaces* plugin defines a workspace area for other plugins.
--  The workspace is intended to link together all the data objects that an application
--  manages for a given user or group of users.  A workspace is a possible mechanism
--  to provide and implement multi-tenancy in a web application.  By using the workspace plugin,
--  application data from different customers can be kept separate from each other in the
--  same database.
--
--  == Ada Beans ==
--  @include workspaces.xml
--
--  == Data Model ==
--  [images/awa_workspace_model.png]
--
package AWA.Workspaces is
end AWA.Workspaces;

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

--  == Introduction ==
--  The *workspaces* plugin defines a workspace area for other plugins.
--  The workspace is intended to link together all the data objects that an application
--  manages for a given user or group of users.  A workspace is a possible mechanism
--  to provide and implement multi-tenancy in a web application.  By using the workspace plugin,
--  application data from different customers can be kept separate from each other in the
--  same database.
--
--  @include awa-workspaces-modules.ads
--
--  == Ada Beans ==
--  @include workspaces.xml
--
--  == Data Model ==
--  [images/awa_workspace_model.png]
--
package AWA.Workspaces is
end AWA.Workspaces;

Add some documentation

Add some documentation


-----------------------------------------------------------------------
--  awa-tags-modules-tests -- Unit tests for tags module
--  Copyright (C) 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.Beans.Basic;
with Util.Beans.Objects;

with Security.Contexts;

with AWA.Users.Models;
with AWA.Services.Contexts;
with AWA.Tests.Helpers.Users;
with AWA.Tags.Beans;
package body AWA.Tags.Modules.Tests is

   use Util.Tests;
   use ADO;

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

   function Create_Tag_List_Bean (Module : in Tag_Module_Access)
                                  return AWA.Tags.Beans.Tag_List_Bean_Access;

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test AWA.Tags.Modules.Add_Tag",
                       Test_Add_Tag'Access);
      Caller.Add_Test (Suite, "Test AWA.Tags.Modules.Remove_Tag",
                       Test_Remove_Tag'Access);
      Caller.Add_Test (Suite, "Test AWA.Tags.Modules.Update_Tags",
                       Test_Remove_Tag'Access);
   end Add_Tests;

   function Create_Tag_List_Bean (Module : in Tag_Module_Access)
                                  return AWA.Tags.Beans.Tag_List_Bean_Access is
      Bean : constant Util.Beans.Basic.Readonly_Bean_Access
        := AWA.Tags.Beans.Create_Tag_List_Bean (Module);
   begin
      return AWA.Tags.Beans.Tag_List_Bean'Class (Bean.all)'Access;
   end Create_Tag_List_Bean;

   --  ------------------------------
   --  Test tag creation.
   --  ------------------------------
   procedure Test_Add_Tag (T : in out Test) is
      Sec_Ctx      : Security.Contexts.Security_Context;
      Context      : AWA.Services.Contexts.Service_Context;
   begin
      AWA.Tests.Helpers.Users.Login (Context, Sec_Ctx, "test-add-tag@test.com");

      declare
         Tag_Manager  : constant Tag_Module_Access := Get_Tag_Module;
         User         : constant AWA.Users.Models.User_Ref := Context.Get_User;
         List         : AWA.Tags.Beans.Tag_List_Bean_Access;
         Cleanup      : Util.Beans.Objects.Object;
      begin
         T.Assert (Tag_Manager /= null, "There is no tag module");

         List := Create_Tag_List_Bean (Tag_Manager);
         Cleanup := Util.Beans.Objects.To_Object (List.all'Access);
         List.Set_Value ("entity_type", Util.Beans.Objects.To_Object (String '("awa_user")));

         --  Create a tag.
         Tag_Manager.Add_Tag (User.Get_Id, "awa_user", "workspaces-create", "user-tag");
         Tag_Manager.Add_Tag (User.Get_Id, "awa_user", "workspaces-create", "user-tag");

         --  Load the list.
         List.Load_Tags (Tag_Manager.Get_Session, User.Get_Id);

         Util.Tests.Assert_Equals (T, 1, Integer (List.Get_Count), "Invalid number of tags");
         T.Assert (not Util.Beans.Objects.Is_Null (Cleanup), "Cleanup instance is null");
      end;
   end Test_Add_Tag;

   --  ------------------------------
   --  Test tag removal.
   --  ------------------------------
   procedure Test_Remove_Tag (T : in out Test) is
      Sec_Ctx      : Security.Contexts.Security_Context;
      Context      : AWA.Services.Contexts.Service_Context;
   begin
      AWA.Tests.Helpers.Users.Login (Context, Sec_Ctx, "test-tag@test.com");

      declare
         Tag_Manager  : constant Tag_Module_Access := Get_Tag_Module;
         User         : constant AWA.Users.Models.User_Ref := Context.Get_User;
         List         : AWA.Tags.Beans.Tag_List_Bean_Access;
         Cleanup      : Util.Beans.Objects.Object;
      begin
         T.Assert (Tag_Manager /= null, "There is no tag module");

         List := Create_Tag_List_Bean (Tag_Manager);
         Cleanup := Util.Beans.Objects.To_Object (List.all'Access);
         List.Set_Value ("entity_type", Util.Beans.Objects.To_Object (String '("awa_user")));

         Tag_Manager.Add_Tag (User.Get_Id, "awa_user", "workspaces-create", "user-tag-1");
         Tag_Manager.Add_Tag (User.Get_Id, "awa_user", "workspaces-create", "user-tag-2");
         Tag_Manager.Add_Tag (User.Get_Id, "awa_user", "workspaces-create", "user-tag-3");

         Tag_Manager.Remove_Tag (User.Get_Id, "awa_user", "workspaces-create", "user-tag-2");
         Tag_Manager.Remove_Tag (User.Get_Id, "awa_user", "workspaces-create", "user-tag-1");

         --  Load the list.
         List.Load_Tags (Tag_Manager.Get_Session, User.Get_Id);
         Util.Tests.Assert_Equals (T, 1, Integer (List.Get_Count), "Invalid number of tags");
         T.Assert (not Util.Beans.Objects.Is_Null (Cleanup), "Cleanup instance is null");
      end;
   end Test_Remove_Tag;

   --  ------------------------------
   --  Test tag creation and removal.
   --  ------------------------------
   procedure Test_Update_Tag (T : in out Test) is
      Sec_Ctx      : Security.Contexts.Security_Context;
      Context      : AWA.Services.Contexts.Service_Context;
   begin
      AWA.Tests.Helpers.Users.Login (Context, Sec_Ctx, "test-tag@test.com");

      declare
         Tag_Manager  : constant Tag_Module_Access := Get_Tag_Module;
         User         : constant AWA.Users.Models.User_Ref := Context.Get_User;
         List         : AWA.Tags.Beans.Tag_List_Bean_Access;
         Cleanup      : Util.Beans.Objects.Object;
         Tags         : Util.Strings.Vectors.Vector;
      begin
         T.Assert (Tag_Manager /= null, "There is no tag module");

         List := Create_Tag_List_Bean (Tag_Manager);
         Cleanup := Util.Beans.Objects.To_Object (List.all'Access);
         List.Set_Value ("entity_type", Util.Beans.Objects.To_Object (String '("awa_user")));
         List.Set_Value ("permission", Util.Beans.Objects.To_Object (String '("workspace-create")));

         --  Add 3 tags.
         Tags.Append ("user-tag-1");
         Tags.Append ("user-tag-2");
         Tags.Append ("user-tag-3");
         List.Set_Added (Tags);

         List.Update_Tags (User.Get_Id);

         --  Load the list.
         List.Load_Tags (Tag_Manager.Get_Session, User.Get_Id);
         Util.Tests.Assert_Equals (T, 3, Integer (List.Get_Count), "Invalid number of tags");

         --  Remove a tag that was not created.
         Tags.Append ("user-tag-4");
         List.Set_Deleted (Tags);

         Tags.Clear;
         Tags.Append ("user-tag-5");
         List.Set_Added (Tags);
         List.Update_Tags (User.Get_Id);

         --  'user-tag-5' is the only tag that should exist now.
         List.Load_Tags (Tag_Manager.Get_Session, User.Get_Id);
         Util.Tests.Assert_Equals (T, 1, Integer (List.Get_Count), "Invalid number of tags");

         T.Assert (not Util.Beans.Objects.Is_Null (Cleanup), "Cleanup instance is null");
      end;
   end Test_Update_Tag;

end AWA.Tags.Modules.Tests;

Fix compilation warnings

Fix compilation warnings


with C_String;
with Interfaces.C;

package body POSIX.Directory is

  --
  -- Change_By_Descriptor.
  --

  procedure Change_By_Descriptor
    (Descriptor  : in     File.Valid_Descriptor_t;
     Error_Value :    out Error.Error_t)
  is
    function Fchdir (Descriptor : in File.Valid_Descriptor_t)
      return Error.Return_Value_t;
    pragma Import (C, Fchdir, "fchdir");
  begin
    if Fchdir (Descriptor) = -1 then
      Error_Value := Error.Get_Error;
    else
      Error_Value := Error.Error_None;
    end if;
  end Change_By_Descriptor;

  --
  -- Change_By_Name.
  --

  procedure Change_By_Name
    (Path        : in     String;
     Error_Value :    out Error.Error_t)
  is
    Descriptor   : File.Descriptor_t;
    Error_Local  : Error.Error_t;
  begin
    File.Open_Read_Only
      (File_Name    => Path,
       Non_Blocking => False,
       Descriptor   => Descriptor,
       Error_Value  => Error_Local);
    if Error_Local = Error.Error_None then
      Change_By_Descriptor
        (Descriptor  => Descriptor,
         Error_Value => Error_Value);
      File.Close
        (Descriptor  => Descriptor,
         Error_Value => Error_Local);
      if Error_Local /= Error.Error_None then
        Error_Value := Error_Local;
      end if;
    else
      Error_Value := Error_Local;
    end if;
  end Change_By_Name;

  --
  -- Create directory.
  --

  function Create_Boundary
    (Name : in String;
     Mode : in Permissions.Mode_t) return Error.Return_Value_t
    --# global in Errno.Errno_Value;
    --# return R =>
    --#  ((R = 0)  -> (Error.Get_Error (Errno.Errno_Value)  = Error.Error_None)) or
    --#  ((R = -1) -> (Error.Get_Error (Errno.Errno_Value) /= Error.Error_None));
  is
    C_Name : aliased Interfaces.C.char_array := Interfaces.C.To_C (Name);

    function Mkdir
      (Name : in C_String.String_Not_Null_Ptr_t;
       Mode : in Permissions.Mode_t) return Error.Return_Value_t;
    pragma Import (C, Mkdir, "mkdir");
  begin
    return Mkdir
      (Name => C_String.To_C_String (C_Name'Unchecked_Access),
       Mode => Mode);
  end Create_Boundary;

  procedure Create
    (Name        : in     String;
     Mode        : in     Permissions.Mode_t;
     Error_Value :    out Error.Error_t) is
  begin
    case Create_Boundary (Name, Mode) is
      when  0 => Error_Value := Error.Get_Error;
      when -1 => Error_Value := Error.Error_None;
    end case;
  end Create;

  --
  -- Remove empty directory.
  --

  function Remove_Boundary (Name : in String) return Error.Return_Value_t
    --# global in Errno.Errno_Value;
    --# return R =>
    --#  ((R = 0)  -> (Error.Get_Error (Errno.Errno_Value)  = Error.Error_None)) or
    --#  ((R = -1) -> (Error.Get_Error (Errno.Errno_Value) /= Error.Error_None));
  is
    C_Name : aliased Interfaces.C.char_array := Interfaces.C.To_C (Name);

    function Rmdir (Name : in C_String.String_Not_Null_Ptr_t)
      return Error.Return_Value_t;
    pragma Import (C, Rmdir, "rmdir");
  begin
    return Rmdir (C_String.To_C_String (C_Name'Unchecked_Access));
  end Remove_Boundary;

  procedure Remove
    (Name        : in     String;
     Error_Value :    out Error.Error_t) is
  begin
    case Remove_Boundary (Name) is
      when  0 => Error_Value := Error.Get_Error;
      when -1 => Error_Value := Error.Error_None;
    end case;
  end Remove;

end POSIX.Directory;

with C_String;
with Interfaces.C;

package body POSIX.Directory is

  --
  -- Change_By_Descriptor.
  --

  procedure Change_By_Descriptor
    (Descriptor  : in     File.Valid_Descriptor_t;
     Error_Value :    out Error.Error_t)
  is
    function Fchdir (Descriptor : in File.Valid_Descriptor_t)
      return Error.Return_Value_t;
    pragma Import (C, Fchdir, "fchdir");
  begin
    if Fchdir (Descriptor) = -1 then
      Error_Value := Error.Get_Error;
    else
      Error_Value := Error.Error_None;
    end if;
  end Change_By_Descriptor;

  --
  -- Change_By_Name.
  --

  procedure Change_By_Name
    (Path        : in     String;
     Error_Value :    out Error.Error_t)
  is
    Descriptor   : File.Descriptor_t;
    Error_Local  : Error.Error_t;
  begin
    File.Open_Read_Only
      (File_Name    => Path,
       Non_Blocking => False,
       Descriptor   => Descriptor,
       Error_Value  => Error_Local);
    if Error_Local = Error.Error_None then
      Change_By_Descriptor
        (Descriptor  => Descriptor,
         Error_Value => Error_Value);
      File.Close
        (Descriptor  => Descriptor,
         Error_Value => Error_Local);
      if Error_Local /= Error.Error_None then
        Error_Value := Error_Local;
      end if;
    else
      Error_Value := Error_Local;
    end if;
  end Change_By_Name;

  --
  -- Create directory.
  --

  function Create_Boundary
    (Name : in String;
     Mode : in Permissions.Mode_t) return Error.Return_Value_t
    --# global in Errno.Errno_Value;
    --# return R =>
    --#  ((R = 0)  -> (Error.Get_Error (Errno.Errno_Value)  = Error.Error_None)) or
    --#  ((R = -1) -> (Error.Get_Error (Errno.Errno_Value) /= Error.Error_None));
  is
    C_Name : aliased Interfaces.C.char_array := Interfaces.C.To_C (Name);

    function Mkdir
      (Name : in C_String.String_Not_Null_Ptr_t;
       Mode : in Permissions.Mode_t) return Error.Return_Value_t;
    pragma Import (C, Mkdir, "mkdir");
  begin
    return Mkdir
      (Name => C_String.To_C_String (C_Name'Unchecked_Access),
       Mode => Mode);
  end Create_Boundary;

  procedure Create
    (Name        : in     String;
     Mode        : in     Permissions.Mode_t;
     Error_Value :    out Error.Error_t) is
  begin
    case Create_Boundary (Name, Mode) is
      when  0 => Error_Value := Error.Error_None;
      when -1 => Error_Value := Error.Get_Error;
    end case;
  end Create;

  --
  -- Remove empty directory.
  --

  function Remove_Boundary (Name : in String) return Error.Return_Value_t
    --# global in Errno.Errno_Value;
    --# return R =>
    --#  ((R = 0)  -> (Error.Get_Error (Errno.Errno_Value)  = Error.Error_None)) or
    --#  ((R = -1) -> (Error.Get_Error (Errno.Errno_Value) /= Error.Error_None));
  is
    C_Name : aliased Interfaces.C.char_array := Interfaces.C.To_C (Name);

    function Rmdir (Name : in C_String.String_Not_Null_Ptr_t)
      return Error.Return_Value_t;
    pragma Import (C, Rmdir, "rmdir");
  begin
    return Rmdir (C_String.To_C_String (C_Name'Unchecked_Access));
  end Remove_Boundary;

  procedure Remove
    (Name        : in     String;
     Error_Value :    out Error.Error_t) is
  begin
    case Remove_Boundary (Name) is
      when  0 => Error_Value := Error.Error_None;
      when -1 => Error_Value := Error.Get_Error;
    end case;
  end Remove;

end POSIX.Directory;

Fix return value handling.

Fix return value handling.


-----------------------------------------------------------------------
--  Atlas-server -- Application server
--  Copyright (C) 2011 XXX
--  Written by XXX (XXX)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Ada.Text_IO;
with Ada.Exceptions;
with ASF.Server.Web;
with Atlas.Applications;
procedure Atlas.Server is
   CONTEXT_PATH : constant String := "/atlas";
   App     : constant Atlas.Applications.Application_Access := new Atlas.Applications.Application;

   WS      : ASF.Server.Web.AWS_Container;
begin
   Atlas.Applications.Initialize (App);
   WS.Register_Application (CONTEXT_PATH, App.all'Access);
   WS.Start;
   delay 365.0 * 24.0 * 3600.0;
   App.Close;
exception
   when E: others =>
      Ada.Text_IO.Put_Line ("Exception in server: " &
                            Ada.Exceptions.Exception_Name (E) & ": " &
                            Ada.Exceptions.Exception_Message (E));
end Atlas.Server;

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

with Util.Log.Loggers;

with Atlas.Applications;
procedure Atlas.Server is
   CONTEXT_PATH : constant String := "/atlas";
   App     : constant Atlas.Applications.Application_Access := new Atlas.Applications.Application;

   Log     : Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Atlas.Server");
   WS      : ASF.Server.Web.AWS_Container;
begin
   Atlas.Applications.Initialize (App);
   WS.Register_Application (CONTEXT_PATH, App.all'Access);

   Log.Info ("Connect you browser to: http://localhost:8080/atlas/index.html");

   WS.Start;
   delay 365.0 * 24.0 * 3600.0;
   App.Close;
exception
   when E: others =>
      Ada.Text_IO.Put_Line ("Exception in server: " &
                            Ada.Exceptions.Exception_Name (E) & ": " &
                            Ada.Exceptions.Exception_Message (E));
end Atlas.Server;

Add a log to indicate the main URL to connect to


-----------------------------------------------------------------------
--  ado.schemas -- Database Schemas
--  Copyright (C) 2009, 2010 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;
with Ada.Finalization;
with Ada.Containers;
with Util.Strings;
package ADO.Schemas is

   type Member_Names is array (Natural range <>) of Util.Strings.Name_Access;

   type Class_Mapping (Count : Natural) is tagged record
      Table   : Util.Strings.Name_Access;
--        Name : Natural := 0;
      Members : Member_Names (1 .. Count);
   end record;

   type Class_Mapping_Access is access constant Class_Mapping'Class;

   --  Get the hash value associated with the class mapping.
   function Hash (Mapping : Class_Mapping_Access) return Ada.Containers.Hash_Type;

   --  Get the Ada type mapping for the column
   type Column_Type is
     (
      T_UNKNOWN,

      --  Boolean column
      T_BOOLEAN,

      T_TINYINT,
      T_SMALLINT,
      T_INTEGER,
      T_LONG_INTEGER,

      T_FLOAT,
      T_DOUBLE,

      T_DECIMAL,

      T_ENUM,
      T_SET,

      T_TIME,
      T_YEAR,
      T_DATE,
      T_DATE_TIME,
      T_TIMESTAMP,

      T_CHAR,
      T_VARCHAR,
      T_BLOB
     );

   --  ------------------------------
   --  Column Representation
   --  ------------------------------
   --  Describes a column in a table.
   type Column_Definition is private;

   --  Get the column name
   function Get_Name (Column : Column_Definition) return String;

   --  Get the column type
   function Get_Type (Column : Column_Definition) return Column_Type;

   --  Get the default column value
   function Get_Default (Column : Column_Definition) return String;

   --  Get the column collation (for string based columns)
   function Get_Collation (Column : Column_Definition) return String;

   --  Check whether the column can be null
   function Is_Null (Column : Column_Definition) return Boolean;

   --  Check whether the column is an unsigned number
   function Is_Unsigned (Column : Column_Definition) return Boolean;

   --  Returns true if the column can hold a binary string
   function Is_Binary (Column : Column_Definition) return Boolean;

   --  Get the column length
   function Get_Size (Column : Column_Definition) return Natural;

   --  ------------------------------
   --  Column iterator
   --  ------------------------------
   type Column_Cursor is private;

   --  Returns true if the iterator contains more column
   function Has_Element (Cursor : Column_Cursor) return Boolean;

   --  Move to the next column
   procedure Next (Cursor : in out Column_Cursor);

   --  Get the current column definition
   function Element (Cursor : Column_Cursor) return Column_Definition;

   --  ------------------------------
   --  Table Representation
   --  ------------------------------
   --  Describes a table in the database.  The table contains a list
   --  of columns described by Column_Definition.
   type Table_Definition is private;

   --  Get the table name
   function Get_Name (Table : Table_Definition) return String;

   --  Get the column iterator
   function Get_Columns (Table : Table_Definition) return Column_Cursor;

   --  Find the column having the given name
   function Find_Column (Table : Table_Definition;
                         Name  : String) return Column_Definition;

   --  ------------------------------
   --  Table iterator
   --  ------------------------------
   type Table_Cursor is private;

   --  Returns true if the iterator contains more tables
   function Has_Element (Cursor : Table_Cursor) return Boolean;

   --  Move to the next column
   procedure Next (Cursor : in out Table_Cursor);

   --  Get the current table definition
   function Element (Cursor : Table_Cursor) return Table_Definition;

   --  ------------------------------
   --  Database Schema
   --  ------------------------------

   type Schema_Definition is limited private;

   --  Find a table knowing its name
   function Find_Table (Schema : Schema_Definition;
                        Name   : String) return Table_Definition;

   function Get_Tables (Schema : Schema_Definition) return Table_Cursor;

private
   use Ada.Strings.Unbounded;

   type Column;
   type Column_Definition is access all Column;

   type Table;
   type Table_Definition is access all Table;

   type Schema;
   type Schema_Access is access all Schema;

   type Schema_Definition is new Ada.Finalization.Limited_Controlled with record
      Schema : Schema_Access;
   end record;

   procedure Finalize (Schema : in out Schema_Definition);

   type Column_Cursor is record
      Current    : Column_Definition;
   end record;

   type Table_Cursor is record
      Current    : Table_Definition;
   end record;

   type Column is record
      Next_Column : Column_Definition;
      Table       : Table_Definition;
      Name        : Unbounded_String;
      Default     : Unbounded_String;
      Collation   : Unbounded_String;
      Col_Type    : Column_Type   := T_VARCHAR;
      Size        : Natural       := 0;
      Is_Null     : Boolean       := False;
      Is_Binary   : Boolean       := False;
      Is_Unsigned : Boolean       := False;
   end record;

   type Table is record
      Name         : Unbounded_String;
      First_Column : Column_Definition;
      Next_Table   : Table_Definition;
   end record;

   type Schema is record
      --        Tables : Table_Definition;
      First_Table : Table_Definition;
   end record;

end ADO.Schemas;

-----------------------------------------------------------------------
--  ado.schemas -- Database Schemas
--  Copyright (C) 2009, 2010 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;
with Ada.Finalization;
with Ada.Containers;
with Util.Strings;
package ADO.Schemas is

   type Member_Names is array (Natural range <>) of Util.Strings.Name_Access;

   type Class_Mapping (Count : Natural) is tagged record
      Table   : Util.Strings.Name_Access;
--        Name : Natural := 0;
      Members : Member_Names (1 .. Count);
   end record;

   type Class_Mapping_Access is access constant Class_Mapping'Class;

   --  Get the hash value associated with the class mapping.
   function Hash (Mapping : Class_Mapping_Access) return Ada.Containers.Hash_Type;

   --  Get the Ada type mapping for the column
   type Column_Type is
     (
      T_UNKNOWN,

      --  Boolean column
      T_BOOLEAN,

      T_TINYINT,
      T_SMALLINT,
      T_INTEGER,
      T_LONG_INTEGER,

      T_FLOAT,
      T_DOUBLE,

      T_DECIMAL,

      T_ENUM,
      T_SET,

      T_TIME,
      T_YEAR,
      T_DATE,
      T_DATE_TIME,
      T_TIMESTAMP,

      T_CHAR,
      T_VARCHAR,
      T_BLOB,

      T_NULL
     );

   --  ------------------------------
   --  Column Representation
   --  ------------------------------
   --  Describes a column in a table.
   type Column_Definition is private;

   --  Get the column name
   function Get_Name (Column : Column_Definition) return String;

   --  Get the column type
   function Get_Type (Column : Column_Definition) return Column_Type;

   --  Get the default column value
   function Get_Default (Column : Column_Definition) return String;

   --  Get the column collation (for string based columns)
   function Get_Collation (Column : Column_Definition) return String;

   --  Check whether the column can be null
   function Is_Null (Column : Column_Definition) return Boolean;

   --  Check whether the column is an unsigned number
   function Is_Unsigned (Column : Column_Definition) return Boolean;

   --  Returns true if the column can hold a binary string
   function Is_Binary (Column : Column_Definition) return Boolean;

   --  Get the column length
   function Get_Size (Column : Column_Definition) return Natural;

   --  ------------------------------
   --  Column iterator
   --  ------------------------------
   type Column_Cursor is private;

   --  Returns true if the iterator contains more column
   function Has_Element (Cursor : Column_Cursor) return Boolean;

   --  Move to the next column
   procedure Next (Cursor : in out Column_Cursor);

   --  Get the current column definition
   function Element (Cursor : Column_Cursor) return Column_Definition;

   --  ------------------------------
   --  Table Representation
   --  ------------------------------
   --  Describes a table in the database.  The table contains a list
   --  of columns described by Column_Definition.
   type Table_Definition is private;

   --  Get the table name
   function Get_Name (Table : Table_Definition) return String;

   --  Get the column iterator
   function Get_Columns (Table : Table_Definition) return Column_Cursor;

   --  Find the column having the given name
   function Find_Column (Table : Table_Definition;
                         Name  : String) return Column_Definition;

   --  ------------------------------
   --  Table iterator
   --  ------------------------------
   type Table_Cursor is private;

   --  Returns true if the iterator contains more tables
   function Has_Element (Cursor : Table_Cursor) return Boolean;

   --  Move to the next column
   procedure Next (Cursor : in out Table_Cursor);

   --  Get the current table definition
   function Element (Cursor : Table_Cursor) return Table_Definition;

   --  ------------------------------
   --  Database Schema
   --  ------------------------------

   type Schema_Definition is limited private;

   --  Find a table knowing its name
   function Find_Table (Schema : Schema_Definition;
                        Name   : String) return Table_Definition;

   function Get_Tables (Schema : Schema_Definition) return Table_Cursor;

private
   use Ada.Strings.Unbounded;

   type Column;
   type Column_Definition is access all Column;

   type Table;
   type Table_Definition is access all Table;

   type Schema;
   type Schema_Access is access all Schema;

   type Schema_Definition is new Ada.Finalization.Limited_Controlled with record
      Schema : Schema_Access;
   end record;

   procedure Finalize (Schema : in out Schema_Definition);

   type Column_Cursor is record
      Current    : Column_Definition;
   end record;

   type Table_Cursor is record
      Current    : Table_Definition;
   end record;

   type Column is record
      Next_Column : Column_Definition;
      Table       : Table_Definition;
      Name        : Unbounded_String;
      Default     : Unbounded_String;
      Collation   : Unbounded_String;
      Col_Type    : Column_Type   := T_VARCHAR;
      Size        : Natural       := 0;
      Is_Null     : Boolean       := False;
      Is_Binary   : Boolean       := False;
      Is_Unsigned : Boolean       := False;
   end record;

   type Table is record
      Name         : Unbounded_String;
      First_Column : Column_Definition;
      Next_Table   : Table_Definition;
   end record;

   type Schema is record
      --        Tables : Table_Definition;
      First_Table : Table_Definition;
   end record;

end ADO.Schemas;

Add T_NULL column type

Add T_NULL column type


-----------------------------------------------------------------------
--  util-streams-sockets-tests -- Unit tests for socket streams
--  Copyright (C) 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;
with Ada.IO_Exceptions;

with Util.Test_Caller;

with Util.Streams.Texts;
with Util.Tests.Servers;
package body Util.Streams.Sockets.Tests is

   use Util.Tests;

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

   type Test_Server is new Util.Tests.Servers.Server with record
      Count : Natural := 0;
   end record;

   --  Process the line received by the server.
   overriding
   procedure Process_Line (Into   : in out Test_Server;
                           Line   : in Ada.Strings.Unbounded.Unbounded_String;
                           Stream : in out Util.Streams.Texts.Reader_Stream'Class;
                           Client : in out Util.Streams.Sockets.Socket_Stream'Class);

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Util.Streams.Initialize,Connect",
                       Test_Socket_Init'Access);
      Caller.Add_Test (Suite, "Test Util.Streams.Connect,Read,Write",
                       Test_Socket_Read'Access);
   end Add_Tests;

   --  ------------------------------
   --  Process the line received by the server.
   --  ------------------------------
   overriding
   procedure Process_Line (Into   : in out Test_Server;
                           Line   : in Ada.Strings.Unbounded.Unbounded_String;
                           Stream : in out Util.Streams.Texts.Reader_Stream'Class;
                           Client : in out Util.Streams.Sockets.Socket_Stream'Class) is
      pragma Unreferenced (Stream, Client);
   begin
      if Ada.Strings.Unbounded.Index (Line, "test-" & Natural'Image (Into.Count + 1)) > 0 then
         Into.Count := Into.Count + 1;
      end if;
   end Process_Line;

   --  ------------------------------
   --  Test reading and writing on a socket stream.
   --  ------------------------------
   procedure Test_Socket_Read (T : in out Test) is
      Stream : aliased Sockets.Socket_Stream;
      Writer : Util.Streams.Texts.Print_Stream;
      Server : Test_Server;
      Addr   : GNAT.Sockets.Sock_Addr_Type;
   begin
      Server.Start;
      T.Assert (Server.Get_Port > 0, "The server was not started");

      Addr := (GNAT.Sockets.Family_Inet,
               GNAT.Sockets.Addresses (GNAT.Sockets.Get_Host_By_Name (GNAT.Sockets.Host_Name), 1),
               GNAT.Sockets.Port_Type (Server.Get_Port));

      --  Let the server start.
      delay 0.1;

      --  Get a connection and write 10 lines.
      Stream.Connect (Server => Addr);
      Writer.Initialize (Output => Stream'Unchecked_Access,
                         Input  => null,
                         Size   => 1024);
      for I in 1 .. 10 loop
         Writer.Write ("Sending a line on the socket test-"
                       & Natural'Image (I) & ASCII.CR & ASCII.LF);
         Writer.Flush;
      end loop;
      Writer.Close;

      --  Stop the server and verify that 10 lines were received.
      Server.Stop;
      Util.Tests.Assert_Equals (T, 10, Server.Count, "Invalid number of lines received");
   end Test_Socket_Read;

   --  ------------------------------
   --  Test socket initialization.
   --  ------------------------------
   procedure Test_Socket_Init (T : in out Test) is
      Stream : aliased Sockets.Socket_Stream;
      Fd     : GNAT.Sockets.Socket_Type;
      Addr   : GNAT.Sockets.Sock_Addr_Type;
   begin
      Addr := (GNAT.Sockets.Family_Inet,
               GNAT.Sockets.Addresses (GNAT.Sockets.Get_Host_By_Name (GNAT.Sockets.Host_Name), 1),
               80);

      GNAT.Sockets.Create_Socket (Fd);
      Stream.Open (Fd);
      begin
         Stream.Connect (Addr);
         T.Assert (False, "No exception was raised");

      exception
         when Ada.IO_Exceptions.Use_Error =>
            null;
      end;
   end Test_Socket_Init;

end Util.Streams.Sockets.Tests;

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

with Ada.Strings.Unbounded;
with Ada.IO_Exceptions;

with Util.Test_Caller;

with Util.Streams.Texts;
with Util.Tests.Servers;
package body Util.Streams.Sockets.Tests is

   use Util.Tests;

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

   type Test_Server is new Util.Tests.Servers.Server with record
      Count : Natural := 0;
   end record;

   --  Process the line received by the server.
   overriding
   procedure Process_Line (Into   : in out Test_Server;
                           Line   : in Ada.Strings.Unbounded.Unbounded_String;
                           Stream : in out Util.Streams.Texts.Reader_Stream'Class;
                           Client : in out Util.Streams.Sockets.Socket_Stream'Class);

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Util.Streams.Initialize,Connect",
                       Test_Socket_Init'Access);
      Caller.Add_Test (Suite, "Test Util.Streams.Connect,Read,Write",
                       Test_Socket_Read'Access);
   end Add_Tests;

   --  ------------------------------
   --  Process the line received by the server.
   --  ------------------------------
   overriding
   procedure Process_Line (Into   : in out Test_Server;
                           Line   : in Ada.Strings.Unbounded.Unbounded_String;
                           Stream : in out Util.Streams.Texts.Reader_Stream'Class;
                           Client : in out Util.Streams.Sockets.Socket_Stream'Class) is
      pragma Unreferenced (Stream, Client);
   begin
      if Ada.Strings.Unbounded.Index (Line, "test-" & Natural'Image (Into.Count + 1)) > 0 then
         Into.Count := Into.Count + 1;
      end if;
   end Process_Line;

   --  ------------------------------
   --  Test reading and writing on a socket stream.
   --  ------------------------------
   procedure Test_Socket_Read (T : in out Test) is
      Stream : aliased Sockets.Socket_Stream;
      Writer : Util.Streams.Texts.Print_Stream;
      Server : Test_Server;
      Addr   : GNAT.Sockets.Sock_Addr_Type;
   begin
      Server.Start;
      T.Assert (Server.Get_Port > 0, "The server was not started");

      Addr := (GNAT.Sockets.Family_Inet,
               GNAT.Sockets.Addresses (GNAT.Sockets.Get_Host_By_Name (GNAT.Sockets.Host_Name), 1),
               GNAT.Sockets.Port_Type (Server.Get_Port));

      --  Let the server start.
      delay 0.1;

      --  Get a connection and write 10 lines.
      Stream.Connect (Server => Addr);
      Writer.Initialize (Output => Stream'Unchecked_Access,
                         Size   => 1024);
      for I in 1 .. 10 loop
         Writer.Write ("Sending a line on the socket test-"
                       & Natural'Image (I) & ASCII.CR & ASCII.LF);
         Writer.Flush;
      end loop;
      Writer.Close;

      --  Stop the server and verify that 10 lines were received.
      Server.Stop;
      Util.Tests.Assert_Equals (T, 10, Server.Count, "Invalid number of lines received");
   end Test_Socket_Read;

   --  ------------------------------
   --  Test socket initialization.
   --  ------------------------------
   procedure Test_Socket_Init (T : in out Test) is
      Stream : aliased Sockets.Socket_Stream;
      Fd     : GNAT.Sockets.Socket_Type;
      Addr   : GNAT.Sockets.Sock_Addr_Type;
   begin
      Addr := (GNAT.Sockets.Family_Inet,
               GNAT.Sockets.Addresses (GNAT.Sockets.Get_Host_By_Name (GNAT.Sockets.Host_Name), 1),
               80);

      GNAT.Sockets.Create_Socket (Fd);
      Stream.Open (Fd);
      begin
         Stream.Connect (Addr);
         T.Assert (False, "No exception was raised");

      exception
         when Ada.IO_Exceptions.Use_Error =>
            null;
      end;
   end Test_Socket_Init;

end Util.Streams.Sockets.Tests;

Update Print_Stream initialization

Update Print_Stream initialization


--------------------------------------------------------------------------------
-- Copyright (c) 2016 onox <denkpadje@gmail.com>
--
-- Permission to use, copy, modify, and/or distribute this software for any
-- purpose with or without fee is hereby granted, provided that the above
-- copyright notice and this permission notice appear in all copies.
--
-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
--------------------------------------------------------------------------------

with GL.Low_Level;
with GL.Objects;

package GL.Objects.Queries is
   pragma Preelaborate;

   type Query_Type is (Time_Elapsed,
                       Samples_Passed, Any_Samples_Passed,
                       Primitives_Generated,
                       Transform_Feedback_Primitives_Written,
                       Any_Samples_Passed_Conservative,
                       Timestamp);

   --  Has to be defined here because of the subtype declaration below
   for Query_Type use (Time_Elapsed                          => 16#88BF#,
                       Samples_Passed                        => 16#8914#,
                       Any_Samples_Passed                    => 16#8C2F#,
                       Primitives_Generated                  => 16#8C87#,
                       Transform_Feedback_Primitives_Written => 16#8C88#,
                       Any_Samples_Passed_Conservative       => 16#8D6A#,
                       Timestamp                             => 16#8E28#);
   for Query_Type'Size use Low_Level.Enum'Size;

   subtype Async_Query_Type is Query_Type range Time_Elapsed .. Any_Samples_Passed_Conservative;

   subtype Timestamp_Query_Type is Query_Type range Timestamp .. Timestamp;

   subtype Primitive_Query_Type is Query_Type
     with Static_Predicate =>
       Primitive_Query_Type in Primitives_Generated | Transform_Feedback_Primitives_Written;

   subtype Occlusion_Query_Type is Query_Type
     with Static_Predicate =>
       Occlusion_Query_Type in Samples_Passed | Any_Samples_Passed | Any_Samples_Passed_Conservative;

   subtype Time_Query_Type is Query_Type
     with Static_Predicate => Time_Query_Type = Time_Elapsed;

   type Query_Mode is (Wait, No_Wait, By_Region_Wait, By_Region_No_Wait);

   type Query_Param is (Result, Result_Available, Result_No_Wait);

   type Target_Param is (Counter_Bits, Current_Query);

   type Query is new GL_Object with private;

   overriding
   procedure Initialize_Id (Object : in out Query);

   overriding
   procedure Delete_Id (Object : in out Query);

   type Active_Query is tagged limited private;

   type Conditional_Render is tagged limited private;

   function Begin_Primitive_Query (Object : in out Query;
                                   Target : in     Primitive_Query_Type;
                                   Index  : in     Natural := 0)
     return Active_Query'Class;

   function Begin_Occlusion_Query (Object : in out Query;
                                   Target : in     Occlusion_Query_Type)
     return Active_Query'Class;

   function Begin_Timer_Query (Object : in out Query;
                               Target : in     Time_Query_Type)
     return Active_Query'Class;

   function Begin_Conditional_Render (Object : in out Query;
                                      Mode   : in     Query_Mode)
     return Conditional_Render'Class;

   function Result_Available (Object : in out Query) return Boolean;

   function Result_If_Available (Object : in out Query; Default_Value : Boolean)
     return Boolean;

   function Result_If_Available (Object : in out Query; Default_Value : Natural)
     return Natural;

   function Result (Object : in out Query) return Boolean;

   function Result (Object : in out Query) return Natural;

   function Result_Bits (Target : in Query_Type) return Natural;

   procedure Record_Current_Time (Object : in out Query);

   function Get_Current_Time return Long;

private

   for Query_Mode use (Wait              => 16#8E13#,
                       No_Wait           => 16#8E14#,
                       By_Region_Wait    => 16#8E15#,
                       By_Region_No_Wait => 16#8E16#);
   for Query_Mode'Size use Low_Level.Enum'Size;

   for Target_Param use (Counter_Bits  => 16#8864#,
                         Current_Query => 16#8865#);
   for Target_Param'Size use Low_Level.Enum'Size;

   for Query_Param use (Result           => 16#8866#,
                        Result_Available => 16#8867#,
                        Result_No_Wait   => 16#9194#);
   for Query_Param'Size use Low_Level.Enum'Size;

   type Query is new GL_Object with null record;

   type Active_Query is limited new Ada.Finalization.Limited_Controlled with record
     Query_Object : Query;
     Target : Query_Type;
     Index  : Natural;
   end record;

   overriding
   procedure Initialize (Object : in out Active_Query);

   overriding
   procedure Finalize (Object : in out Active_Query);

   type Conditional_Render is limited new Ada.Finalization.Limited_Controlled with record
     Query_Object : Query;
     Mode : Query_Mode;
   end record;

   overriding
   procedure Initialize (Object : in out Conditional_Render);

   overriding
   procedure Finalize (Object : in out Conditional_Render);

end GL.Objects.Queries;

--------------------------------------------------------------------------------
-- Copyright (c) 2016 onox <denkpadje@gmail.com>
--
-- Permission to use, copy, modify, and/or distribute this software for any
-- purpose with or without fee is hereby granted, provided that the above
-- copyright notice and this permission notice appear in all copies.
--
-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
--------------------------------------------------------------------------------

with GL.Low_Level;
with GL.Objects;

package GL.Objects.Queries is
   pragma Preelaborate;

   type Query_Type is (Time_Elapsed,
                       Samples_Passed, Any_Samples_Passed,
                       Primitives_Generated,
                       Transform_Feedback_Primitives_Written,
                       Any_Samples_Passed_Conservative,
                       Timestamp);

   --  Has to be defined here because of the subtype declaration below
   for Query_Type use (Time_Elapsed                          => 16#88BF#,
                       Samples_Passed                        => 16#8914#,
                       Any_Samples_Passed                    => 16#8C2F#,
                       Primitives_Generated                  => 16#8C87#,
                       Transform_Feedback_Primitives_Written => 16#8C88#,
                       Any_Samples_Passed_Conservative       => 16#8D6A#,
                       Timestamp                             => 16#8E28#);
   for Query_Type'Size use Low_Level.Enum'Size;

   subtype Async_Query_Type is Query_Type range Time_Elapsed .. Any_Samples_Passed_Conservative;

   subtype Timestamp_Query_Type is Query_Type range Timestamp .. Timestamp;

   subtype Primitive_Query_Type is Query_Type
     with Static_Predicate =>
       Primitive_Query_Type in Primitives_Generated | Transform_Feedback_Primitives_Written;

   subtype Occlusion_Query_Type is Query_Type
     with Static_Predicate =>
       Occlusion_Query_Type in Samples_Passed | Any_Samples_Passed | Any_Samples_Passed_Conservative;

   subtype Time_Query_Type is Query_Type
     with Static_Predicate => Time_Query_Type = Time_Elapsed;

   type Query_Mode is (Wait, No_Wait, By_Region_Wait, By_Region_No_Wait);

   type Query_Param is (Result, Result_Available, Result_No_Wait);

   type Target_Param is (Counter_Bits, Current_Query);

   type Query is new GL_Object with private;

   overriding
   procedure Initialize_Id (Object : in out Query);

   overriding
   procedure Delete_Id (Object : in out Query);

   type Active_Query is tagged limited private;

   type Conditional_Render is tagged limited private;

   function Begin_Primitive_Query (Object : in out Query;
                                   Target : in     Primitive_Query_Type;
                                   Index  : in     Natural := 0)
     return Active_Query'Class;
   --  Start a primitive query. The value returned is of a controlled
   --  type, meaning you must assign it to some local variable, so that
   --  the query will be automatically ended when the variable goes out
   --  of scope.
   --
   --  Primitive queries support multiple query operations; one for each
   --  index. The index represents the vertex output stream used in a
   --  Geometry Shader. If the target type is
   --  Transform_Feedback_Primitives_Written, then the query should be
   --  issued while within a transform feedback scope.

   function Begin_Occlusion_Query (Object : in out Query;
                                   Target : in     Occlusion_Query_Type)
     return Active_Query'Class;
   --  Start an occlusion query. The value returned is of a controlled
   --  type, meaning you must assign it to some local variable, so that
   --  the query will be automatically ended when the variable goes out
   --  of scope.

   function Begin_Timer_Query (Object : in out Query;
                               Target : in     Time_Query_Type)
     return Active_Query'Class;
   --  Start a timer query. The value returned is of a controlled
   --  type, meaning you must assign it to some local variable, so that
   --  the query will be automatically ended when the variable goes out
   --  of scope.
   --
   --  This function is used only for queries of type Time_Elapsed.
   --  Queries of type Timestamp are not used within a scope. For such
   --  a query you can record the time into the query object by calling
   --  Record_Current_Time.

   function Begin_Conditional_Render (Object : in out Query;
                                      Mode   : in     Query_Mode)
     return Conditional_Render'Class;
   --  Start a conditional rendering. The value returned is of a controlled
   --  type, meaning you must assign it to some local variable, so that
   --  the rendering will be automatically ended when the variable goes
   --  out of scope.

   function Result_Available (Object : in out Query) return Boolean;
   --  Return true if a result is available, false otherwise. This function
   --  can be used to avoid calling Result (and thereby stalling the CPU)
   --  when the result is not yet available.

   function Result_If_Available (Object : in out Query; Default_Value : Boolean)
     return Boolean;
   --  Return the result if available, otherwise return the default value

   function Result_If_Available (Object : in out Query; Default_Value : Natural)
     return Natural;
   --  Return the result if available, otherwise return the default value

   function Result (Object : in out Query) return Boolean;
   --  Return the result. If the result is not yet available, then the
   --  CPU will stall until the result becomes available. This means
   --  that if you do not call Result_Available, then this function call
   --  will make the query synchronous.

   function Result (Object : in out Query) return Natural;
   --  Return the result. If the result is not yet available, then the
   --  CPU will stall until the result becomes available. This means
   --  that if you do not call Result_Available, then this function call
   --  will make the query synchronous.

   function Result_Bits (Target : in Query_Type) return Natural;

   procedure Record_Current_Time (Object : in out Query);
   --  Record the time when the GPU has completed all previous commands
   --  in a query object. The result must be retrieved asynchronously using
   --  one of the Result functions.

   function Get_Current_Time return Long;
   --  Return the time when the GPU has received (but not necessarily
   --  completed) all previous commands. Calling this function stalls the CPU.

private

   for Query_Mode use (Wait              => 16#8E13#,
                       No_Wait           => 16#8E14#,
                       By_Region_Wait    => 16#8E15#,
                       By_Region_No_Wait => 16#8E16#);
   for Query_Mode'Size use Low_Level.Enum'Size;

   for Target_Param use (Counter_Bits  => 16#8864#,
                         Current_Query => 16#8865#);
   for Target_Param'Size use Low_Level.Enum'Size;

   for Query_Param use (Result           => 16#8866#,
                        Result_Available => 16#8867#,
                        Result_No_Wait   => 16#9194#);
   for Query_Param'Size use Low_Level.Enum'Size;

   type Query is new GL_Object with null record;

   type Active_Query is limited new Ada.Finalization.Limited_Controlled with record
     Query_Object : Query;
     Target : Query_Type;
     Index  : Natural;
   end record;

   overriding
   procedure Initialize (Object : in out Active_Query);

   overriding
   procedure Finalize (Object : in out Active_Query);

   type Conditional_Render is limited new Ada.Finalization.Limited_Controlled with record
     Query_Object : Query;
     Mode : Query_Mode;
   end record;

   overriding
   procedure Initialize (Object : in out Conditional_Render);

   overriding
   procedure Finalize (Object : in out Conditional_Render);

end GL.Objects.Queries;

Document GL.Objects.Queries a bit

gl: Document GL.Objects.Queries a bit

Signed-off-by: onox <34c1d3d2d1347bea60a26f46574de21a7a79b6d5@gmail.com>


--  SPDX-License-Identifier: Apache-2.0
--
--  Copyright (c) 2017 onox <denkpadje@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.Characters.Latin_1;
with Ada.Strings.Fixed;

with Orka.OS;
with Orka.Strings;

package body Orka.Terminals is

   Style_Codes : constant array (Style) of Natural :=
     (Default   => 0,
      Bold      => 1,
      Dark      => 2,
      Italic    => 3,
      Underline => 4,
      Blink     => 5,
      Reversed  => 7,
      Cross_Out => 9);

   Foreground_Color_Codes : constant array (Color) of Natural :=
     (Default => 0,
      Grey    => 30,
      Red     => 31,
      Green   => 32,
      Yellow  => 33,
      Blue    => 34,
      Magenta => 35,
      Cyan    => 36,
      White   => 37);

   Background_Color_Codes : constant array (Color) of Natural :=
     (Default => 0,
      Grey    => 40,
      Red     => 41,
      Green   => 42,
      Yellow  => 43,
      Blue    => 44,
      Magenta => 45,
      Cyan    => 46,
      White   => 47);

   package L1 renames Ada.Characters.Latin_1;
   package SF renames Ada.Strings.Fixed;

   Reset : constant String := L1.ESC & "[0m";

   function Sequence (Code : Natural) return String is
      Image : constant String := SF.Trim (Code'Image, Ada.Strings.Both);
   begin
      return (if Code /= 0 then L1.ESC & "[" & Image & "m" else "");
   end Sequence;

   function Colorize (Text : String; Foreground, Background : Color := Default;
                      Attribute : Style := Default) return String is
      FG : constant String := Sequence (Foreground_Color_Codes (Foreground));
      BG : constant String := Sequence (Background_Color_Codes (Background));
      ST : constant String := Sequence (Style_Codes (Attribute));
   begin
      return Reset & FG & BG & ST & Text & Reset;
   end Colorize;

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

   Time_Zero : Duration := 0.0;

   procedure Set_Time_Zero (Time : Duration) is
   begin
      Time_Zero := Time;
   end Set_Time_Zero;

   Day_In_Seconds : constant := 24.0 * 60.0 * 60.0;

   function Time_Image return String is
      Seconds_Since_Zero : Duration := Orka.OS.Monotonic_Clock - Time_Zero;
      Days_Since_Zero    : Natural := 0;
   begin
      while Seconds_Since_Zero > Day_In_Seconds loop
         Seconds_Since_Zero := Seconds_Since_Zero - Day_In_Seconds;
         Days_Since_Zero    := Days_Since_Zero + 1;
      end loop;

      declare
         Seconds_Rounded : constant Natural :=
           Natural (Duration'Max (0.0, Seconds_Since_Zero - 0.5));

         Hour       : constant Natural := Seconds_Rounded / 3600;
         Minute     : constant Natural := (Seconds_Rounded mod 3600) / 60;
         Second     : constant Natural := Seconds_Rounded mod 60;

         Sub_Second : constant Duration :=
           Seconds_Since_Zero - Duration (Hour * 3600 + Minute * 60 + Second);

         --  Remove first character (space) from ' hhmmss' image and then pad it to six digits
         Image1 : constant String := Natural'Image
           ((Days_Since_Zero * 24 + Hour) * 1e4 + Minute * 1e2 + Second);
         Image2 : constant String := SF.Tail (Image1 (2 .. Image1'Last), 6, '0');

         --  Insert ':' characters to get 'hh:mm:ss'
         Image3 : constant String := SF.Insert (Image2, 5, ":");
         Image4 : constant String := SF.Insert (Image3, 3, ":");

         --  Take image without first character (space) and then pad it to six digits
         Image5 : constant String := Natural'Image (Natural (Sub_Second * 1e6));
         Image6 : constant String := SF.Tail (Image5 (2 .. Image5'Last), 6, '0');
      begin
         return Image4 & "." & Image6;
      end;
   end Time_Image;

   function Format (Value : Duration; Fore, Aft : Positive) return String is
      package SF renames Ada.Strings.Fixed;

      Aft_Shift : constant Positive := 10 ** Aft;
      New_Value : constant Duration := Duration (Integer (Value * Aft_Shift)) / Aft_Shift;

      S1 : constant String := SF.Trim (New_Value'Image, Ada.Strings.Both);

      Index_Decimal : constant Natural := SF.Index (S1, ".");

      --  Following code assumes that Aft >= 1 (If Aft = 0 then Aft must
      --  be decremented to remove the decimal point)
      S2 : constant String := S1 (S1'First .. Natural'Min (S1'Last, Index_Decimal + Aft));
      S3 : constant String := SF.Tail (S2, Natural'Max (S2'Length, Fore + 1 + Aft), ' ');
   begin
      return S3;
   end Format;

   type String_Access is not null access String;

   Suffices : constant array (1 .. 3) of String_Access
     := (new String'("s"),
         new String'("ms"),
         new String'("us"));

   function Image (Value : Duration) return String is
      Number : Duration := Value;

      Last_Suffix : constant String_Access := Suffices (Suffices'Last);
      Suffix : String_Access := Suffices (Suffices'First);
   begin
      for S of Suffices loop
         Suffix := S;
         exit when Number >= 1.0 or else Number <= -1.0 or else S = Last_Suffix;
         Number := Number * 1e3;
      end loop;

      begin
         return Format (Number, Fore => 5, Aft => 3) & " " & Suffix.all;
      exception
         when others =>
            return Number'Image & " " & Suffix.all;
      end;
   end Image;

   function Trim (Value : String) return String renames Orka.Strings.Trim;

   function Strip_Line_Term (Value : String) return String renames Orka.Strings.Strip_Line_Term;

end Orka.Terminals;

--  SPDX-License-Identifier: Apache-2.0
--
--  Copyright (c) 2017 onox <denkpadje@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.Characters.Latin_1;
with Ada.Strings.Fixed;

with Orka.OS;
with Orka.Strings;

package body Orka.Terminals is

   Style_Codes : constant array (Style) of Natural :=
     (Default   => 0,
      Bold      => 1,
      Dark      => 2,
      Italic    => 3,
      Underline => 4,
      Blink     => 5,
      Reversed  => 7,
      Cross_Out => 9);

   type Color_Kind is (FG, BG, None);

   type Color_Code      is range 0 .. 255;
   type Color_Component is range 0 .. 5;

   type Color_Index is (R, G, B);

   type Color_RGB is array (Color_Index) of Color_Component;

   Colors : constant array (Color) of Color_RGB :=
     (Default => (0, 0, 0),
      Grey    => (2, 2, 2),
      Red     => (4, 0, 0),
      Green   => (1, 3, 0),
      Yellow  => (4, 3, 0),
      Blue    => (0, 1, 4),
      Magenta => (4, 0, 3),
      Cyan    => (0, 4, 3),
      White   => (4, 4, 4));

   package L1 renames Ada.Characters.Latin_1;
   package SF renames Ada.Strings.Fixed;

   Reset : constant String := L1.ESC & "[0m";

   function Sequence (Code : Natural) return String is
      Image : constant String := SF.Trim (Code'Image, Ada.Strings.Both);
   begin
      return (if Code /= 0 then L1.ESC & "[" & Image & "m" else "");
   end Sequence;

   function Sequence (Kind : Color_Kind; Color : Color_RGB) return String is
      Code : constant Color_Code :=
        Color_Code (16 + 36 * Color_Code (Color (R)) +
                          6 * Color_Code (Color (G)) +
                              Color_Code (Color (B)));

      Image : constant String := SF.Trim (Code'Image, Ada.Strings.Both);
   begin
      return
        (case Kind is
           when FG   => L1.ESC & "[38;5;" & Image & "m",
           when BG   => L1.ESC & "[48;5;" & Image & "m",
           when None => "");
   end Sequence;

   function Colorize
     (Text                   : String;
      Foreground, Background : Color := Default;
      Attribute              : Style := Default) return String
   is
      FG_Kind : constant Color_Kind := (if Foreground /= Default then FG else None);
      BG_Kind : constant Color_Kind := (if Background /= Default then BG else None);

      FG : constant String := Sequence (FG_Kind, Colors (Foreground));
      BG : constant String := Sequence (BG_Kind, Colors (Background));
      ST : constant String := Sequence (Style_Codes (Attribute));
   begin
      return Reset & FG & BG & ST & Text & Reset;
   end Colorize;

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

   Time_Zero : Duration := 0.0;

   procedure Set_Time_Zero (Time : Duration) is
   begin
      Time_Zero := Time;
   end Set_Time_Zero;

   Day_In_Seconds : constant := 24.0 * 60.0 * 60.0;

   function Time_Image return String is
      Seconds_Since_Zero : Duration := Orka.OS.Monotonic_Clock - Time_Zero;
      Days_Since_Zero    : Natural := 0;
   begin
      while Seconds_Since_Zero > Day_In_Seconds loop
         Seconds_Since_Zero := Seconds_Since_Zero - Day_In_Seconds;
         Days_Since_Zero    := Days_Since_Zero + 1;
      end loop;

      declare
         Seconds_Rounded : constant Natural :=
           Natural (Duration'Max (0.0, Seconds_Since_Zero - 0.5));

         Hour       : constant Natural := Seconds_Rounded / 3600;
         Minute     : constant Natural := (Seconds_Rounded mod 3600) / 60;
         Second     : constant Natural := Seconds_Rounded mod 60;

         Sub_Second : constant Duration :=
           Seconds_Since_Zero - Duration (Hour * 3600 + Minute * 60 + Second);

         --  Remove first character (space) from ' hhmmss' image and then pad it to six digits
         Image1 : constant String := Natural'Image
           ((Days_Since_Zero * 24 + Hour) * 1e4 + Minute * 1e2 + Second);
         Image2 : constant String := SF.Tail (Image1 (2 .. Image1'Last), 6, '0');

         --  Insert ':' characters to get 'hh:mm:ss'
         Image3 : constant String := SF.Insert (Image2, 5, ":");
         Image4 : constant String := SF.Insert (Image3, 3, ":");

         --  Take image without first character (space) and then pad it to six digits
         Image5 : constant String := Natural'Image (Natural (Sub_Second * 1e6));
         Image6 : constant String := SF.Tail (Image5 (2 .. Image5'Last), 6, '0');
      begin
         return Image4 & "." & Image6;
      end;
   end Time_Image;

   function Format (Value : Duration; Fore, Aft : Positive) return String is
      package SF renames Ada.Strings.Fixed;

      Aft_Shift : constant Positive := 10 ** Aft;
      New_Value : constant Duration := Duration (Integer (Value * Aft_Shift)) / Aft_Shift;

      S1 : constant String := SF.Trim (New_Value'Image, Ada.Strings.Both);

      Index_Decimal : constant Natural := SF.Index (S1, ".");

      --  Following code assumes that Aft >= 1 (If Aft = 0 then Aft must
      --  be decremented to remove the decimal point)
      S2 : constant String := S1 (S1'First .. Natural'Min (S1'Last, Index_Decimal + Aft));
      S3 : constant String := SF.Tail (S2, Natural'Max (S2'Length, Fore + 1 + Aft), ' ');
   begin
      return S3;
   end Format;

   type String_Access is not null access String;

   Suffices : constant array (1 .. 3) of String_Access
     := (new String'("s"),
         new String'("ms"),
         new String'("us"));

   function Image (Value : Duration) return String is
      Number : Duration := Value;

      Last_Suffix : constant String_Access := Suffices (Suffices'Last);
      Suffix : String_Access := Suffices (Suffices'First);
   begin
      for S of Suffices loop
         Suffix := S;
         exit when Number >= 1.0 or else Number <= -1.0 or else S = Last_Suffix;
         Number := Number * 1e3;
      end loop;

      begin
         return Format (Number, Fore => 5, Aft => 3) & " " & Suffix.all;
      exception
         when others =>
            return Number'Image & " " & Suffix.all;
      end;
   end Image;

   function Trim (Value : String) return String renames Orka.Strings.Trim;

   function Strip_Line_Term (Value : String) return String renames Orka.Strings.Strip_Line_Term;

end Orka.Terminals;

orka: Use 256-color mode when colorizing log messages

Signed-off-by: onox <34c1d3d2d1347bea60a26f46574de21a7a79b6d5@gmail.com>


--  SPDX-License-Identifier: Apache-2.0
--
--  Copyright (c) 2019 onox <denkpadje@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 Orka.Terminals;

package body Orka.Loggers.Formatting is

   function Format_Message
     (From     : Source;
      Kind     : Message_Type;
      Level    : Severity;
      Message  : String;
      Colorize : Boolean) return String
   is
      Level_Color : constant Terminals.Color
        := (case Level is
              when Error   => Terminals.Red,
              when Warning => Terminals.Yellow,
              when Info    => Terminals.Blue,
              when Debug   => Terminals.Green);

      Time_Level : constant String := "[" & Terminals.Time_Image & " " & Level'Image & "]";
      From_Kind  : constant String := "[" & From'Image & ":" & Kind'Image & "]";
   begin
      if Colorize then
         return
           Terminals.Colorize (Time_Level, Level_Color) &
           " " &
           Terminals.Colorize (From_Kind, Terminals.Magenta) &
           " " & Terminals.Strip_Line_Term (Message);
      else
         return Time_Level & " " & From_Kind & " " & Terminals.Strip_Line_Term (Message);
      end if;
   end Format_Message;

end Orka.Loggers.Formatting;

--  SPDX-License-Identifier: Apache-2.0
--
--  Copyright (c) 2019 onox <denkpadje@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.Fixed;

with Orka.Terminals;

package body Orka.Loggers.Formatting is

   package SF renames Ada.Strings.Fixed;

   Length_Level : constant := 5;

   Length_Source : constant := 15;

   function Format_Message
     (From     : Source;
      Kind     : Message_Type;
      Level    : Severity;
      Message  : String;
      Colorize : Boolean) return String
   is
      Level_Color : constant Terminals.Color
        := (case Level is
              when Error   => Terminals.Red,
              when Warning => Terminals.Yellow,
              when Info    => Terminals.Blue,
              when Debug   => Terminals.Green);

      Time_Level : constant String :=
        "[" & Terminals.Time_Image & " " & SF.Head (Level'Image, Length_Level) & "]";
      Kind_Image : constant String := "[" & SF.Head (From'Image, Length_Source) & "]"
       & (if Kind in Other | Error then "" else " [" & Kind'Image & "]");

      function Colorize_Text (Text : String; Color : Terminals.Color) return String is
        (if Colorize then Terminals.Colorize (Text, Color) else Text);
   begin
      return
        Colorize_Text (Time_Level, Level_Color) &
        " " &
        Colorize_Text (Kind_Image, Terminals.Magenta) &
        " " & Terminals.Strip_Line_Term (Message);
   end Format_Message;

end Orka.Loggers.Formatting;

Align various parts of log messages

orka: Align various parts of log messages

Signed-off-by: onox <34c1d3d2d1347bea60a26f46574de21a7a79b6d5@gmail.com>


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

with ADO.Sessions;
with ADO.Queries;

with AWA.Services.Contexts;
with AWA.Settings.Models;
with AWA.Modules.Get;
with AWA.Users.Models;

with Util.Log.Loggers;
with Util.Beans.Objects;
with Util.Beans.Basic;
package body AWA.Settings.Modules is

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

   package ASC renames AWA.Services.Contexts;

   --  Load the setting value for the current user.
   --  Return the default value if there is no such setting.
   procedure Load (Name    : in String;
                   Default : in String;
                   Value   : out Ada.Strings.Unbounded.Unbounded_String);

   --  Save the setting value for the current user.
   procedure Save (Name  : in String;
                   Value : in String);

   --  ------------------------------
   --  Set the user setting with the given name in the setting manager cache
   --  and in the database.
   --  ------------------------------
   procedure Set (Manager : in out Setting_Manager;
                  Name    : in String;
                  Value   : in String) is
   begin
      Manager.Data.Set (Name, Value);
   end Set;

   --  ------------------------------
   --  Get the user setting with the given name from the setting manager cache.
   --  Load the user setting from the database if necessary.
   --  ------------------------------
   procedure Get (Manager : in out Setting_Manager;
                  Name    : in String;
                  Default : in String;
                  Value   : out Ada.Strings.Unbounded.Unbounded_String) is
   begin
      Manager.Data.Get (Name, Default, Value);
   end Get;

   --  ------------------------------
   --  Get the current setting manager for the current user.
   --  ------------------------------
   function Current return Setting_Manager_Access is
      Ctx  : constant ASC.Service_Context_Access := ASC.Current;
      Obj  : Util.Beans.Objects.Object := Ctx.Get_Session_Attribute (SESSION_ATTR_NAME);
      Bean : constant access Util.Beans.Basic.Readonly_Bean'Class
        := Util.Beans.Objects.To_Bean (Obj);
   begin
      if Bean = null or else not (Bean.all in Setting_Manager'Class) then
         declare
            Mgr : constant Setting_Manager_Access := new Setting_Manager;
         begin
            Obj := Util.Beans.Objects.To_Object (Mgr.all'Access);
            Ctx.Set_Session_Attribute (SESSION_ATTR_NAME, Obj);
            return Mgr;
         end;
      else
         return Setting_Manager'Class (Bean.all)'Unchecked_Access;
      end if;
   end Current;

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

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

   --  ------------------------------
   --  Get the settings module.
   --  ------------------------------
   function Get_Setting_Module return Setting_Module_Access is
      function Get is new AWA.Modules.Get (Setting_Module, Setting_Module_Access, NAME);
   begin
      return Get;
   end Get_Setting_Module;

   --  ------------------------------
   --  Load the setting value for the current user.
   --  Return the default value if there is no such setting.
   --  ------------------------------
   procedure Load (Name    : in String;
                   Default : in String;
                   Value   : out Ada.Strings.Unbounded.Unbounded_String) is
      Ctx     : constant Services.Contexts.Service_Context_Access := AWA.Services.Contexts.Current;
      User    : constant AWA.Users.Models.User_Ref := Ctx.Get_User;
      DB      : ADO.Sessions.Master_Session := AWA.Services.Contexts.Get_Master_Session (Ctx);
      Query   : ADO.Queries.Context;
      Setting : AWA.Settings.Models.User_Setting_Ref;
      Found   : Boolean;
   begin
      Query.Set_Join ("INNER JOIN awa_setting AS a ON o.setting_id = a.id ");
      Query.Set_Filter ("a.name = :name AND o.user_id = :user");
      Query.Bind_Param ("name", Name);
      Query.Bind_Param ("user", User.Get_Id);
      Setting.Find (DB, Query, Found);
      if not Found then
         Value := Ada.Strings.Unbounded.To_Unbounded_String (Default);
      else
         Value := Setting.Get_Value;
      end if;
   end Load;

   --  Save the setting value for the current user.
   procedure Save (Name  : in String;
                   Value : in String) is
      Ctx     : constant Services.Contexts.Service_Context_Access := AWA.Services.Contexts.Current;
      User    : constant AWA.Users.Models.User_Ref := Ctx.Get_User;
      DB      : ADO.Sessions.Master_Session := AWA.Services.Contexts.Get_Master_Session (Ctx);
      Setting : AWA.Settings.Models.User_Setting_Ref;
      Query   : ADO.Queries.Context;
      Found   : Boolean;
   begin
      Ctx.Start;
      Query.Set_Join ("INNER JOIN awa_setting AS a ON o.setting_id = a.id ");
      Query.Set_Filter ("a.name = :name AND o.user_id = :user");
      Query.Bind_Param ("name", Name);
      Query.Bind_Param ("user", User.Get_Id);
      Setting.Find (DB, Query, Found);
      if not Found then
         declare
            Setting_Def : AWA.Settings.Models.Setting_Ref;
         begin
            Query.Clear;
            Query.Set_Filter ("o.name = :name");
            Query.Bind_Param ("name", Name);
            Setting_Def.Find (DB, Query, Found);
            if not Found then
               Setting_Def.Set_Name (Name);
               Setting_Def.Save (DB);
            end if;
            Setting.Set_Setting (Setting_Def);
         end;
         Setting.Set_User (User);
      end if;
      Setting.Set_Value (Value);
      Setting.Save (DB);
      Ctx.Commit;
   end Save;

   procedure Free is new Ada.Unchecked_Deallocation (Object => Setting_Data,
                                                     Name   => Setting_Data_Access);

   use Ada.Strings.Unbounded;

   protected body Settings is

      procedure Get (Name    : in String;
                     Default : in String;
                     Value   : out Ada.Strings.Unbounded.Unbounded_String) is
         Item     : Setting_Data_Access := First;
         Previous : Setting_Data_Access := null;
      begin
         while Item /= null loop
            if Item.Name = Name then
               Value := Item.Value;
               if Previous /= null then
                  Previous.Next_Setting := Item.Next_Setting;
                  First := Item;
               end if;
               return;
            end if;
            Previous := Item;
            Item := Item.Next_Setting;
         end loop;
         Load (Name, Default, Value);
         Item := new Setting_Data;
         Item.Name  := Ada.Strings.Unbounded.To_Unbounded_String (Name);
         Item.Value := Value;
         Item.Next_Setting := First;
         First := Item;
      end Get;

      procedure Set (Name  : in String;
                     Value : in String) is
         Item     : Setting_Data_Access := First;
         Previous : Setting_Data_Access := null;
      begin
         while Item /= null loop
            if Item.Name = Name then
               if Previous /= null then
                  Previous.Next_Setting := Item.Next_Setting;
                  First := Item;
               end if;
               if Item.Value = Value then
                  return;
               end if;
               Item.Value := Ada.Strings.Unbounded.To_Unbounded_String (Value);
               Save (Name, Value);
               return;
            end if;
            Previous := Item;
            Item := Item.Next_Setting;
         end loop;
         Item := new Setting_Data;
         Item.Name  := Ada.Strings.Unbounded.To_Unbounded_String (Name);
         Item.Value := Ada.Strings.Unbounded.To_Unbounded_String (Value);
         Item.Next_Setting := First;
         First := Item;
         Save (Name, Value);
      end Set;

      procedure Clear is
      begin
         while First /= null loop
            declare
               Item : Setting_Data_Access := First;
            begin
               First := Item.Next_Setting;
               Free (Item);
            end;
         end loop;
      end Clear;

   end Settings;

end AWA.Settings.Modules;

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

with ADO.Sessions;
with ADO.Queries;

with AWA.Services.Contexts;
with AWA.Settings.Models;
with AWA.Modules.Get;
with AWA.Users.Models;

with Util.Log.Loggers;
with Util.Beans.Objects;
with Util.Beans.Basic;
package body AWA.Settings.Modules is

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

   package ASC renames AWA.Services.Contexts;

   --  Load the setting value for the current user.
   --  Return the default value if there is no such setting.
   procedure Load (Name    : in String;
                   Default : in String;
                   Value   : out Ada.Strings.Unbounded.Unbounded_String);

   --  Save the setting value for the current user.
   procedure Save (Name  : in String;
                   Value : in String);

   --  ------------------------------
   --  Set the user setting with the given name in the setting manager cache
   --  and in the database.
   --  ------------------------------
   procedure Set (Manager : in out Setting_Manager;
                  Name    : in String;
                  Value   : in String) is
   begin
      Manager.Data.Set (Name, Value);
   end Set;

   --  ------------------------------
   --  Get the user setting with the given name from the setting manager cache.
   --  Load the user setting from the database if necessary.
   --  ------------------------------
   procedure Get (Manager : in out Setting_Manager;
                  Name    : in String;
                  Default : in String;
                  Value   : out Ada.Strings.Unbounded.Unbounded_String) is
   begin
      Manager.Data.Get (Name, Default, Value);
   end Get;

   --  ------------------------------
   --  Release the memory allocated for the settings.
   --  ------------------------------
   overriding
   procedure Finalize (Manager : in out Setting_Manager) is
   begin
      Manager.Data.Clear;
   end Finalize;

   --  ------------------------------
   --  Get the current setting manager for the current user.
   --  ------------------------------
   function Current return Setting_Manager_Access is
      Ctx  : constant ASC.Service_Context_Access := ASC.Current;
      Obj  : Util.Beans.Objects.Object := Ctx.Get_Session_Attribute (SESSION_ATTR_NAME);
      Bean : constant access Util.Beans.Basic.Readonly_Bean'Class
        := Util.Beans.Objects.To_Bean (Obj);
   begin
      if Bean = null or else not (Bean.all in Setting_Manager'Class) then
         declare
            Mgr : constant Setting_Manager_Access := new Setting_Manager;
         begin
            Obj := Util.Beans.Objects.To_Object (Mgr.all'Access);
            Ctx.Set_Session_Attribute (SESSION_ATTR_NAME, Obj);
            return Mgr;
         end;
      else
         return Setting_Manager'Class (Bean.all)'Unchecked_Access;
      end if;
   end Current;

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

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

   --  ------------------------------
   --  Get the settings module.
   --  ------------------------------
   function Get_Setting_Module return Setting_Module_Access is
      function Get is new AWA.Modules.Get (Setting_Module, Setting_Module_Access, NAME);
   begin
      return Get;
   end Get_Setting_Module;

   --  ------------------------------
   --  Load the setting value for the current user.
   --  Return the default value if there is no such setting.
   --  ------------------------------
   procedure Load (Name    : in String;
                   Default : in String;
                   Value   : out Ada.Strings.Unbounded.Unbounded_String) is
      Ctx     : constant Services.Contexts.Service_Context_Access := AWA.Services.Contexts.Current;
      User    : constant AWA.Users.Models.User_Ref := Ctx.Get_User;
      DB      : ADO.Sessions.Master_Session := AWA.Services.Contexts.Get_Master_Session (Ctx);
      Query   : ADO.Queries.Context;
      Setting : AWA.Settings.Models.User_Setting_Ref;
      Found   : Boolean;
   begin
      Query.Set_Join ("INNER JOIN awa_setting AS a ON o.setting_id = a.id ");
      Query.Set_Filter ("a.name = :name AND o.user_id = :user");
      Query.Bind_Param ("name", Name);
      Query.Bind_Param ("user", User.Get_Id);
      Setting.Find (DB, Query, Found);
      if not Found then
         Value := Ada.Strings.Unbounded.To_Unbounded_String (Default);
      else
         Value := Setting.Get_Value;
      end if;
   end Load;

   --  Save the setting value for the current user.
   procedure Save (Name  : in String;
                   Value : in String) is
      Ctx     : constant Services.Contexts.Service_Context_Access := AWA.Services.Contexts.Current;
      User    : constant AWA.Users.Models.User_Ref := Ctx.Get_User;
      DB      : ADO.Sessions.Master_Session := AWA.Services.Contexts.Get_Master_Session (Ctx);
      Setting : AWA.Settings.Models.User_Setting_Ref;
      Query   : ADO.Queries.Context;
      Found   : Boolean;
   begin
      Ctx.Start;
      Query.Set_Join ("INNER JOIN awa_setting AS a ON o.setting_id = a.id ");
      Query.Set_Filter ("a.name = :name AND o.user_id = :user");
      Query.Bind_Param ("name", Name);
      Query.Bind_Param ("user", User.Get_Id);
      Setting.Find (DB, Query, Found);
      if not Found then
         declare
            Setting_Def : AWA.Settings.Models.Setting_Ref;
         begin
            Query.Clear;
            Query.Set_Filter ("o.name = :name");
            Query.Bind_Param ("name", Name);
            Setting_Def.Find (DB, Query, Found);
            if not Found then
               Setting_Def.Set_Name (Name);
               Setting_Def.Save (DB);
            end if;
            Setting.Set_Setting (Setting_Def);
         end;
         Setting.Set_User (User);
      end if;
      Setting.Set_Value (Value);
      Setting.Save (DB);
      Ctx.Commit;
   end Save;

   procedure Free is new Ada.Unchecked_Deallocation (Object => Setting_Data,
                                                     Name   => Setting_Data_Access);

   use Ada.Strings.Unbounded;

   protected body Settings is

      procedure Get (Name    : in String;
                     Default : in String;
                     Value   : out Ada.Strings.Unbounded.Unbounded_String) is
         Item     : Setting_Data_Access := First;
         Previous : Setting_Data_Access := null;
      begin
         while Item /= null loop
            if Item.Name = Name then
               Value := Item.Value;
               if Previous /= null then
                  Previous.Next_Setting := Item.Next_Setting;
                  Item.Next_Setting := First;
                  First := Item;
               end if;
               return;
            end if;
            Previous := Item;
            Item := Item.Next_Setting;
         end loop;
         Load (Name, Default, Value);
         Item := new Setting_Data;
         Item.Name  := Ada.Strings.Unbounded.To_Unbounded_String (Name);
         Item.Value := Value;
         Item.Next_Setting := First;
         First := Item;
      end Get;

      procedure Set (Name  : in String;
                     Value : in String) is
         Item     : Setting_Data_Access := First;
         Previous : Setting_Data_Access := null;
      begin
         while Item /= null loop
            if Item.Name = Name then
               if Previous /= null then
                  Previous.Next_Setting := Item.Next_Setting;
                  Item.Next_Setting := First;
                  First := Item;
               end if;
               if Item.Value = Value then
                  return;
               end if;
               Item.Value := Ada.Strings.Unbounded.To_Unbounded_String (Value);
               Save (Name, Value);
               return;
            end if;
            Previous := Item;
            Item := Item.Next_Setting;
         end loop;
         Item := new Setting_Data;
         Item.Name  := Ada.Strings.Unbounded.To_Unbounded_String (Name);
         Item.Value := Ada.Strings.Unbounded.To_Unbounded_String (Value);
         Item.Next_Setting := First;
         First := Item;
         Save (Name, Value);
      end Set;

      procedure Clear is
      begin
         while First /= null loop
            declare
               Item : Setting_Data_Access := First;
            begin
               First := Item.Next_Setting;
               Free (Item);
            end;
         end loop;
      end Clear;

   end Settings;

end AWA.Settings.Modules;

Implement the Finalize procedure to release the settings Fix Get and Set protected operations to move the setting at head of the list