gnatcoll-db/sql/gnatcoll-sql-inspect.ads

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

--  This package provides introspection capabilities in databases.
--  In particular, they deal with querying the database schema either from an
--  existing (and running) database, or via files. They can also be used to
--  load initial data in a database.
--
--  See also GNATCOLL.SQL.Exec.Foreach_Table for lower-level iterators.
--
--  Most types in this package are smart pointers, that will automatically be
--  deallocated when needed, so you do not need to worry about memory
--  management in this package.

pragma Ada_2012;
private with Ada.Containers.Vectors;
with Ada.Containers.Indefinite_Vectors;
with Ada.Containers.Indefinite_Ordered_Maps;
with Ada.Containers.Indefinite_Hashed_Sets;
with Ada.Strings.Equal_Case_Insensitive;
with Ada.Strings.Hash_Case_Insensitive;
with GNATCOLL.SQL.Exec;           use GNATCOLL.SQL.Exec;
with GNATCOLL.VFS;
with GNAT.Regexp;                 use GNAT.Regexp;
private with GNATCOLL.Refcount;
private with GNAT.Strings;

package GNATCOLL.SQL.Inspect is
   --  Work around issue with the Ada containers: the tampering checks
   --  mean that the container might be corrupted if used from multiple
   --  tasks, even in read-only.
   --  pragma Suppress (Tampering_Check);

   type Table_Description is tagged private;
   type Field is tagged private;
   type Field_List is tagged private;

   type Field_Mapping is abstract tagged null record;
   type Field_Mapping_Access is access all Field_Mapping'Class;
   --  A Field_Mapping describes how a SQL type (found in a database schema)
   --  is mapped to an Ada field type (given as a string, since the
   --  purpose is to generate code) and to parameter types.

   package String_Sets is new Ada.Containers.Indefinite_Hashed_Sets
     (String, Ada.Strings.Hash_Case_Insensitive,
      Ada.Strings.Equal_Case_Insensitive,
      Ada.Strings.Equal_Case_Insensitive);

   function Type_To_SQL
     (Self         : Field_Mapping;
      Format       : access Formatter'Class := null;
      For_Database : Boolean := True) return String
      is abstract;
   --  How this field type should be encoded in the schema description.
   --
   --  If For_Database is True, the returned value can be used in a "CREATE
   --  TABLE" statement. Otherwise, it is the name of the Ada field type,
   --  possibly qualified with the package name.
   --
   --  Format is not needed when For_Database is False

   function Type_From_SQL
     (Self : in out Field_Mapping; Str : String) return Boolean
     is abstract;
   --  If Str is a possible string representation of Self, initialize Self
   --  and set Matched to True.
   --  Str is always lower cased.

   function Parameter_Type
     (Self : Field_Mapping) return SQL_Parameter_Type'Class is abstract;
   --  Return the type of parameters for fields of type.
   --  This returns an uninitialized value, which is only used to pass a
   --  valid encoding string to the database, as in "?1" or "$1::integer".

   procedure Register_Field_Mapping (Self : Field_Mapping'Class);
   --  Register a new field type, so that users can create their own field
   --  types.

   type Field_Mapping_Text is new Field_Mapping with record
      Max_Length : Integer := Integer'Last;
   end record;
   overriding function Type_To_SQL
     (Self         : Field_Mapping_Text;
      Format       : access Formatter'Class := null;
      For_Database : Boolean := True) return String with Inline;
   overriding function Type_From_SQL
     (Self : in out Field_Mapping_Text; Str : String) return Boolean;
   overriding function Parameter_Type
     (Self : Field_Mapping_Text) return SQL_Parameter_Type'Class
     is (SQL_Parameter_Text'(others => <>));

   generic
      SQL_Type       : String;
      Ada_Field_Mapping : String;
      type Param_Type is new SQL_Parameter_Type with private;
   package Simple_Field_Mappings is
      --  Helper to create simple field types.
      --  When the database schema contains the given SQL_Type, it is mapped
      --  to field of type Ada_Field_Mapping in the generated code.
      --
      --  You do not need to call Register_Field_Mapping for types defined via
      --  this package.
      --
      --  These assume they map to a single SQL type. If this isn't the case
      --  you should override Type_From_SQL.

      type Simple_Field_Mapping is new Field_Mapping with null record;
      overriding function Type_To_SQL
        (Self         : Simple_Field_Mapping;
         Format       : access Formatter'Class := null;
         For_Database : Boolean := True) return String with Inline;
      overriding function Type_From_SQL
        (Self : in out Simple_Field_Mapping; Str : String) return Boolean
        is (Str = SQL_Type);
      overriding function Parameter_Type
        (Self : Simple_Field_Mapping) return SQL_Parameter_Type'Class;
   end Simple_Field_Mappings;

   type Field_Mapping_Integer is new Field_Mapping with null record;
   overriding function Type_To_SQL
     (Self         : Field_Mapping_Integer;
      Format       : access Formatter'Class := null;
      For_Database : Boolean := True) return String with Inline;
   overriding function Type_From_SQL
     (Self : in out Field_Mapping_Integer; Str : String) return Boolean;
   overriding function Parameter_Type
     (Self : Field_Mapping_Integer) return SQL_Parameter_Type'Class
     is (SQL_Parameter_Integer'(others => <>));

   type Field_Mapping_Autoincrement is
      new Field_Mapping_Integer with null record;
   overriding function Type_To_SQL
     (Self         : Field_Mapping_Autoincrement;
      Format       : access Formatter'Class := null;
      For_Database : Boolean := True) return String
     is (if For_Database
         then Format.Field_Type_Autoincrement
         else "SQL_Field_Integer");
   overriding function Type_From_SQL
     (Self : in out Field_Mapping_Autoincrement; Str : String) return Boolean
     is (Str = "autoincrement");
   --  These types are always mapped to an integer in all DBMS,
   --  even though they might be created with a different name like
   --  "SERIAL" and "INTEGER AUTOINCREMENT".

   type Field_Mapping_Timestamp is new Field_Mapping with null record;
   overriding function Type_To_SQL
     (Self         : Field_Mapping_Timestamp;
      Format       : access Formatter'Class := null;
      For_Database : Boolean := True) return String with Inline;
   overriding function Type_From_SQL
     (Self : in out Field_Mapping_Timestamp; Str : String) return Boolean
   is
     (Str in "timestamp without time zone"
           | "timestamp with time zone"
           | "timestamp"
           | "datetime");
   overriding function Parameter_Type
     (Self : Field_Mapping_Timestamp) return SQL_Parameter_Type'Class
     is (SQL_Parameter_Time'(others => <>));

   type Field_Mapping_Float is new Field_Mapping with null record;
   overriding function Type_To_SQL
     (Self         : Field_Mapping_Float;
      Format       : access Formatter'Class := null;
      For_Database : Boolean := True) return String with Inline;
   overriding function Type_From_SQL
     (Self : in out Field_Mapping_Float; Str : String) return Boolean;
   overriding function Parameter_Type
     (Self : Field_Mapping_Float) return SQL_Parameter_Type'Class
     is (SQL_Parameter_Float'(others => <>));

   type Field_Mapping_Money is new Field_Mapping with null record;
   overriding function Type_To_SQL
     (Self         : Field_Mapping_Money;
      Format       : access Formatter'Class := null;
      For_Database : Boolean := True) return String
     is (if For_Database
         then Format.Field_Type_Money
         else "SQL_Field_Money");
   overriding function Type_From_SQL
     (Self : in out Field_Mapping_Money; Str : String) return Boolean
     is (Str = "money");
   overriding function Parameter_Type
     (Self : Field_Mapping_Money) return SQL_Parameter_Type'Class
     is (SQL_Parameter_Money'(others => <>));

   Invalid_Type : exception;
   --  Raise by Read_Schema when some unknown type is used.

   function From_SQL (SQL_Type : String) return Field_Mapping_Access;
   --  Convert a SQL type to a field type, or raise Invalid_Type

   function Quote_Keyword (Str : String) return String;
   --  If Str is a keyword (or special token) for the DBMS, surround it with
   --  quotes. Otherwise, return Str as is

   ------------
   -- Fields --
   ------------
   --  The fields in a table

   No_Field : constant Field;

   function Id (Self : Field) return Positive;
   --  A unique Id for this field, which is not guaranteed to be the same the
   --  next time you query the schema from a running database.

   function Name (Self : Field) return String;
   --  The name of the field (normalized)

   function Description (Self : Field) return String;
   --  Any comment associated with the field

   function Get_Table (Self : Field) return Table_Description'Class;
   --  The table to which the field belongs

   function Get_Type (Self : Field) return Field_Mapping_Access;
   --  The type of the field.
   --  If the field is a foreign key, this returns the type of the field it
   --  points to, unless a specific type was set.

   procedure Set_Active (Self : in out Field; Active : Boolean);
   function Is_Active (Self : Field) return Boolean;
   --  A special marker that indicates whether special treatment should be
   --  done on a field.
   --  By default, all fields are marked as active, but you could use this
   --  marker to filter out some fields. See Is_Active for tables.

   function Can_Be_Null (Self : Field) return Boolean;
   --  Whether the field can be null

   function Default (Self : Field) return String;
   --  The default value for this field.
   --  This is untyped data, so needs to be analyzed using the field type as
   --  appropriate.

   function Is_PK (Self : Field) return Boolean;
   --  Whether this field is part of the primary key for the table

   function Is_FK (Self : Field) return Field;
   --  If Self is a foreign key, returns the field it points to.
   --  Otherwise, returns No_Field.

   ------------
   -- Tables --
   ------------
   --  The following type represents a table in a database. It provides
   --  introspection capabilities (list of fields,...).

   No_Table : constant Table_Description;

   function Id (Self : Table_Description) return Positive;
   --  A unique Id for the table.
   --  This id is only valid for this session, ie the same table might have a
   --  different id the next time you start your application or retrieve the
   --  schema from a database.

   function Name (Self : Table_Description) return String;
   --  The name of the table (normalized).
   --  We recommend that this name be a plural (like "Objects"), and reserve
   --  the use of singular names for rows.

   function Row_Name (Self : Table_Description) return String;
   --  The name for an object read from the table.
   --  By default, this will be the same as the table's name, but it is often
   --  useful to use singular names instead, in particular when Ada code is
   --  automatically generated from the database schema.

   function Description (Self : Table_Description) return String;
   --  Any comment set for this table.

   function Get_Kind (Self : Table_Description) return Relation_Kind;
   --  Whether Self is an actual table or a view

   function Is_Abstract (Self : Table_Description) return Boolean;
   --  Whether the table is "abstract".
   --  This never occurs when a schema is read from an existing database, since
   --  all tables there are concrete. However, when a schema is defined through
   --  a text file, it might be useful to declare an abstract table for use as
   --  the parent of other concrete tables, to share fields.
   --  This concept is similar to the use of abstract root types in a tagged
   --  type hierarchy.

   procedure Set_Active (Self : in out Table_Description; Active : Boolean);
   function Is_Active (Self : Table_Description) return Boolean;
   --  A special marker that indicates whether special treatment should be
   --  done on a table.
   --  By default, all tables are marked as active, but you could use this
   --  marker to filter out some tables. For instance, when you generate code
   --  from the database schema, the user might want to ignore some tables.
   --  You would mark this table as inactive.

   function Super_Table (Self : Table_Description) return Table_Description;
   --  If the table derives from an abstract table (see Is_Abstract), this will
   --  return that other table. All fields from that other tables are also
   --  valid for Self.

   procedure For_Each_Field
     (Self              : Table_Description;
      Callback          : access procedure (F : in out Field);
      Include_Inherited : Boolean := False);
   --  For all fields in the table, calls Callback.
   --  By default, the fields inherited from an abstract table are not list,
   --  you need to set Include_Inherited to True if you want to access them.

   procedure For_Each_FK
     (Self     : Table_Description;
      Callback : access procedure
        (From, To : Field; Id : Natural; Ambiguous : Boolean));
   --  For all foreign keys that reference another table from Self.
   --  For instance:
   --     CREATE TABLE person
   --        (father INTEGER REFERENCES person(id),
   --         mother INTEGER REFERENCES person(id),
   --         field1 INTEGER,
   --         field2 INTEGER,
   --         FOREIGN KEY (field1, field2) REFERENCES registers(f, m));
   --
   --  would result in four calls to Callback:
   --     * (From=person.father,  To=person.id,   Id=1)
   --     * (From=person.mother,  To=person.id,   Id=2)
   --     * (From=person.field1,  To=registers.f, Id=3)
   --     * (From=person.field2,  To=registers.m, Id=3)
   --
   --  The Id can be used to group foreign keys together to know which ones are
   --  part of the same tuple.
   --
   --  Ambiguous is set to True if there are multiple different foreign keys to
   --  the same table, as is the case for ids 1 and 2 in the above example

   function Field_From_Name
     (Self  : Table_Description'Class; Name  : String) return Field;
   --  Return the field with the specified name.
   --  This also looks for the field in the table we inherit from.

   function Get_PK (Self : Table_Description'Class) return Field;
   --  Assuming there is a single primary key in the table, returns it.
   --  Otherwise, returns No_Field

   ------------
   -- Schema --
   ------------
   --  The whole schema for the database, including all tables

   type DB_Schema is private;
   --  The schema of a database.
   --  This describes all the tables, their fields, the foreign key references,
   --  and various other attributes of the database. This can be queried from
   --  an existing database, or loaded from text files.

   No_Schema : constant DB_Schema;

   Invalid_Table : exception;

   function Get_Table
     (Self : DB_Schema; Name : String) return Table_Description;
   --  Retrieve a table description by name.
   --  Invalid_Table is raised if there is no such table

   procedure For_Each_Table
     (Self     : DB_Schema;
      Callback : access procedure (T : in out Table_Description);
      Alphabetical : Boolean := True);
   --  For all tables in the database, calls Callback.
   --  The order is either alphabetical, or in the order used in the textual
   --  model description.

   ---------------
   -- Schema IO --
   ---------------

   type Schema_IO is abstract tagged null record;
   --  An object to read and write a schema to various media

   function Read_Schema (Self : Schema_IO) return DB_Schema is abstract;
   --  Retrieve the database schema

   procedure Write_Schema (Self : Schema_IO; Schema : DB_Schema) is abstract;
   --  Write the schema

   type DB_Schema_IO is new Schema_IO with record
      DB : Database_Connection;
      Filter : Regexp;
   end record;
   overriding function Read_Schema (Self : DB_Schema_IO) return DB_Schema;
   overriding procedure Write_Schema
     (Self : DB_Schema_IO; Schema : DB_Schema);
   --  Read or write the schema to a live database.
   --  "Writing" to the database means creating the appropriate tables and
   --  views (if DB is set, otherwise output statements to stdout)

   type File_Schema_IO is new Schema_IO with record
      DB   : Database_Connection;
      File : GNATCOLL.VFS.Virtual_File;
      Omit_Schema : String_Sets.Set;
   end record;
   overriding function Read_Schema (Self : File_Schema_IO) return DB_Schema;
   function Read_Schema
     (Self : File_Schema_IO; Data : String) return DB_Schema;
   overriding procedure Write_Schema
     (Self : File_Schema_IO; Schema : DB_Schema);
   procedure Write_Schema
     (Self   : File_Schema_IO;
      Schema : DB_Schema;
      Puts   : access procedure (S : String);
      Align_Columns : Boolean := True;
      Show_Comments : Boolean := True);
   --  Read or write the schema from a file.
   --  See GNATCOLL documentation for the format of this file.
   --  This will write to Puts parameter if the Self.File is No_File

   function New_Schema_IO
     (File : GNATCOLL.VFS.Virtual_File) return File_Schema_IO'Class;
   function New_Schema_IO (DB : Database_Connection) return DB_Schema_IO'Class;
   --  Return a new schema io. This is similar to creating a variable and
   --  assigning its File or DB field, but is easier to use:
   --      Schema := New_Schema_IO (Create ("file.txt")).Read_Schema;

   Invalid_File : exception;

   procedure Load_Data
     (DB     : access Database_Connection_Record'Class;
      File   : GNATCOLL.VFS.Virtual_File;
      Schema : DB_Schema := No_Schema;
      Replace_Newline : Boolean := True);
   procedure Load_Data
     (DB       : access Database_Connection_Record'Class;
      Data     : String;
      Schema   : DB_Schema := No_Schema;
      Location : String := "data";
      Replace_Newline : Boolean := True);
   --  Load data from a file or from memory into the database.
   --  This should be used for initial fixtures when you create a new database,
   --  so in general after a call to Write_Schema.
   --  The format of the file is documented in the GNATCOLL documentation.
   --  The exact commands used for the actual insertion depends on the DBMS
   --  backend, and are optimized as much as possible.
   --  The schema must be specified if your input file potentially includes
   --  cross-references between tables (values starting with "&").
   --
   --  You need to call Commit_Or_Rollback to actually commit the data into the
   --  database, so that a single transaction is used for all data loading when
   --  there are multiple files to load.
   --
   --  If Replace_Newline is True, then a "\n" string will be replaced by an
   --  actual ASCII.LF when stored in the database.

   procedure Load_Data
     (File   : GNATCOLL.VFS.Virtual_File;
      Puts   : access procedure (S : String));
   --  Load the initial data from File, and dumps it to Output without
   --  pretty-printing or comments.

private
   use GNATCOLL.Refcount;

   type Abstract_Table_Description is tagged null record;
   procedure Free (Self : in out Abstract_Table_Description) is null;
   procedure Free_Dispatch (Self : in out Abstract_Table_Description'Class);
   package Tables_Ref
      is new Shared_Pointers (Abstract_Table_Description'Class, Free_Dispatch);
   type Table_Description is new Tables_Ref.Ref with null record;

   ------------
   -- Fields --
   ------------

   type Field_Properties is record
      PK       : Boolean := False;
      Not_Null : Boolean := False;  --  (true for a PK, implicitly)
      Unique   : Boolean := False;  --  Unique field
      Indexed  : Boolean := False;  --  Do we need an index ?
      Noindex  : Boolean := False;  --  Force disabling of indexes
      Case_Insensitive : Boolean := False;
   end record;
   --  The various properties that can be set for a field in a table.

   type Field_Description is record
      Name        : GNAT.Strings.String_Access;
      Typ         : Field_Mapping_Access;
      Id          : Positive;
      Description : GNAT.Strings.String_Access;
      Default     : GNAT.Strings.String_Access;
      Props       : Field_Properties;
      FK          : Boolean;  --  Whether this is part of a foreign key
      Table       : Tables_Ref.Weak_Ref;
      Active      : Boolean := True;
   end record;

   procedure Free (Self : in out Field_Description);

   package Fields_Ref is new Shared_Pointers (Field_Description, Free);
   type Field is new Fields_Ref.Ref with null record;

   No_Field : constant Field := (Fields_Ref.Null_Ref with null record);

   package Field_Lists is new Ada.Containers.Vectors (Natural, Field);
   type Field_List is new Field_Lists.Vector with null record;

   Empty_Field_List : constant Field_List :=
     (Field_Lists.Empty_Vector with null record);

   type Field_Pair is record
      From : Field;
      To   : Field;  --  No field if pointing to foreign primary key
   end record;
   package Pair_Lists is new Ada.Containers.Vectors (Natural, Field_Pair);

   type Foreign_Key_Description is record
      To_Table        : Tables_Ref.Weak_Ref;
      --  Needed, since a pair.To might be No_Field, in which case we would
      --  not have this info.

      Revert_Name     : GNAT.Strings.String_Access;
      Fields          : Pair_Lists.Vector;
      Ambiguous       : Boolean;
   end record;
   --  A foreign key from one table to another
   --      From_Table (From_Attributes) REFERENCES To_Table (To_Attributes)
   --  Ambiguous is set to True when a To_Table (To_Attribute) tuple appear in
   --  several foreign keys e.g.
   --     (who_contact) REFERENCES contact(id)
   --     (contact)     REFERENCES contact(id)

   procedure Free (Self : in out Foreign_Key_Description);

   package Foreign_Refs is new Shared_Pointers (Foreign_Key_Description, Free);
   type Foreign_Key is new Foreign_Refs.Ref with null record;

   function To_Table (FK : Foreign_Key) return Table_Description'Class;
   --  The table that is referenced by the foreign key

   package Foreign_Keys is new Ada.Containers.Vectors
     (Natural, Foreign_Key);

   package String_Lists is new Ada.Containers.Indefinite_Vectors
     (Natural, String);

   -----------------------
   -- Table_Description --
   -----------------------

   type Table_Description_Record is new Abstract_Table_Description with record
      Name        : GNAT.Strings.String_Access := null;
      Row         : GNAT.Strings.String_Access := null;  --  possibly null

      Kind        : Relation_Kind := Kind_Table;
      Id          : Positive := 1;
      Description : GNAT.Strings.String_Access := null;
      Fields      : Field_List := Empty_Field_List;
      Is_Abstract : Boolean := False;
      FK          : Foreign_Keys.Vector := Foreign_Keys.Empty_Vector;

      Indexes     : String_Lists.Vector;
      --  The list of multi-column indexes (that are declared in their own line
      --  in the table description). This contains strings like:
      --     "field1,field2,field3|index_name"

      Uniques     : String_Lists.Vector;
      --  The list of multi-column unique constraints (that are declared in
      --  their own line in the table description). This contains strings like:
      --     "field1,field2,field3|constraint_name"

      Active      : Boolean := True;

      Has_PK      : Boolean := False;
      --  Whether the table has a primary key

      Super_Table : Table_Description :=
         (Tables_Ref.Null_Ref with null record);
      --  The table from which we inherit fields
   end record;

   type TDR is access all Table_Description_Record'Class;
   for TDR'Size use Standard'Address_Size;
   for TDR'Storage_Pool use Tables_Ref.Element_Access'Storage_Pool;
   overriding procedure Free (Self : in out Table_Description_Record);

   package Tables_Maps is new Ada.Containers.Indefinite_Ordered_Maps
     (String, Table_Description, "<", "=");
   package Tables_Lists is new Ada.Containers.Indefinite_Vectors
     (Index_Type => Natural, Element_Type => String);

   ------------
   -- Schema --
   ------------

   type DB_Schema is record
      Tables  : Tables_Maps.Map;

      Ordered_Tables : Tables_Lists.Vector;
      --  In the order in which the user defined them in the description file.
   end record;

   No_Schema : constant DB_Schema :=
     (Tables         => Tables_Maps.Empty_Map,
      Ordered_Tables => Tables_Lists.Empty_Vector);

   No_Table : constant Table_Description :=
     (Tables_Ref.Null_Ref with null record);
end GNATCOLL.SQL.Inspect;