------------------------------------------------------------------------------ -- G N A T C O L L -- -- -- -- Copyright (C) 2005-2018, 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 -- -- . -- -- -- ------------------------------------------------------------------------------ with Ada.Unchecked_Conversion; with Ada.Unchecked_Deallocation; with Interfaces.C; with GNAT.Sockets; with GNATCOLL.SQL.Postgres.Builder; with GNATCOLL.SQL.Postgres.Gnade; with GNATCOLL.Utils; use GNATCOLL.Utils; package body GNATCOLL.SQL.Postgres is N_OID : aliased constant String := "OID"; Comparison_Regexp : aliased constant String := " ~* "; type Query_Postgres_Contents is new Query_Contents with record Base : SQL_Query; Extra : SQL_PG_Extension_Access; end record; overriding procedure Free (Self : in out Query_Postgres_Contents); overriding function To_String (Self : Query_Postgres_Contents; Format : Formatter'Class) return Unbounded_String; overriding procedure Auto_Complete (Self : in out Query_Postgres_Contents; Auto_Complete_From : Boolean := True; Auto_Complete_Group_By : Boolean := True); -- Supports adding a suffix string to the base_query type SQL_PG_For_Update is new SQL_PG_Extension with record Tables : SQL_Table_List := Empty_Table_List; -- List of updated tables (empty means ALL tables in query) No_Wait : Boolean := False; -- Set True if NO WAIT end record; overriding function To_String (Self : SQL_PG_For_Update; Format : Formatter'Class) return Unbounded_String; -- Extensions for UPDATE type SQL_PG_Returning is new SQL_PG_Extension with record Returning : SQL_Field_List; end record; overriding function To_String (Self : SQL_PG_Returning; Format : Formatter'Class) return Unbounded_String; -- Extensions for SELECT type Postgres_Engine is new Database_Engine with null record; overriding function Setup (Engine : Postgres_Engine; Options : Name_Values.Map; Errors : access Error_Reporter'Class) return Database_Description; ---------- -- Free -- ---------- overriding procedure Free (Self : in out Query_Postgres_Contents) is procedure Unchecked_Free is new Ada.Unchecked_Deallocation (SQL_PG_Extension'Class, SQL_PG_Extension_Access); begin Unchecked_Free (Self.Extra); Free (Query_Contents (Self)); end Free; --------------- -- To_String -- --------------- overriding function To_String (Self : Query_Postgres_Contents; Format : Formatter'Class) return Unbounded_String is begin return To_String (Self.Base, Format) & To_String (Self.Extra.all, Format); end To_String; ------------------- -- Auto_Complete -- ------------------- overriding procedure Auto_Complete (Self : in out Query_Postgres_Contents; Auto_Complete_From : Boolean := True; Auto_Complete_Group_By : Boolean := True) is begin Auto_Complete (Self.Base, Auto_Complete_From, Auto_Complete_Group_By); end Auto_Complete; ----------- -- Setup -- ----------- function Setup (Database : String; User : String := ""; Host : String := ""; Password : String := ""; Port : Integer := -1; SSL : SSL_Mode := Allow; Cache_Support : Boolean := True; Errors : access Error_Reporter'Class := null) return Database_Description is Result : Postgres_Description_Access; begin Result := new Postgres_Description (Caching => Cache_Support, Errors => Errors); Result.SSL := SSL; Result.Dbname := To_XString (Database); Result.User := To_XString (User); Result.Password := To_XString (Password); Result.Port := Port; Result.Host := To_XString (Host); return Database_Description (Result); end Setup; ----------- -- Setup -- ----------- overriding function Setup (Engine : Postgres_Engine; Options : Name_Values.Map; Errors : access Error_Reporter'Class) return Database_Description is pragma Unreferenced (Engine); type Setup_Parameters is (Database, User, Host, Password, Port, SSL, Caching); Params : array (Setup_Parameters) of Name_Values.Cursor; function Value (P : Setup_Parameters; Default : String) return String is (if Name_Values.Has_Element (Params (P)) then Name_Values.Element (Params (P)) else Default); begin for C in Options.Iterate loop Params (Setup_Parameters'Value (Name_Values.Key (C))) := C; end loop; return Setup (Database => Value (Database, ""), User => Value (User, ""), Host => Value (Host, ""), Password => Value (Password, ""), Port => Integer'Value (Value (Port, "-1")), SSL => SSL_Mode'Value (Value (SSL, "Allow")), Cache_Support => Boolean'Value (Value (Caching, "True")), Errors => Errors); end Setup; ---------------------- -- Build_Connection -- ---------------------- overriding function Build_Connection (Self : access Postgres_Description) return Database_Connection is DB : Database_Connection; begin DB := GNATCOLL.SQL.Postgres.Builder.Build_Connection (Self); Reset_Connection (DB); return DB; end Build_Connection; -------------- -- Notifies -- -------------- procedure Notifies (DB : Database_Connection; Message : out Notification; Done : out Boolean) is begin Builder.To_Native (DB).Notifies (Message, Done); end Notifies; ------------------- -- Consume_Input -- ------------------- procedure Consume_Input (DB : Database_Connection) is DBG : constant access Gnade.Database'Class := Builder.To_Native (DB); begin if not DBG.Consume_Input then DB.Set_Failure (DBG.Error); end if; end Consume_Input; -------------------- -- Wait_For_Input -- -------------------- function Wait_For_Input (DB : Database_Connection; Timeout : Duration := Duration'Last) return Boolean is use GNAT.Sockets; function To_Ada is new Ada.Unchecked_Conversion (Interfaces.C.int, Socket_Type); DBG : constant access Gnade.Database'Class := Builder.To_Native (DB); Sel : Selector_Type; Soc : constant Socket_Type := To_Ada (DBG.Socket); St : Selector_Status; SS : Socket_Set_Type; SE : Socket_Set_Type; Rq : Request_Type (N_Bytes_To_Read); begin if DBG.Is_Non_Blocking then raise Program_Error with "Non blocking connection is not supported"; end if; Set (SS, Soc); Create_Selector (Sel); Check_Selector (Sel, R_Socket_Set => SS, W_Socket_Set => SE, Status => St, Timeout => Duration'Min (Forever, Timeout)); Close_Selector (Sel); if St = Completed then Control_Socket (Soc, Rq); if Rq.Size = 0 then -- Socket ready to read but without data available mean socket -- closed by peer. DB.Set_Failure ("Connection closed on PostgreSQL server side"); return False; end if; if not DBG.Consume_Input then DB.Set_Failure (DBG.Error); return False; end if; return True; end if; return False; end Wait_For_Input; --------------- -- OID_Field -- --------------- function OID_Field (Table : SQL_Table'Class) return SQL_Field_Integer is begin return SQL_Field_Integer' (Table => Table.Table_Name, Instance => Table.Instance, Instance_Index => Table.Instance_Index, Name => N_OID'Access); end OID_Field; ------------ -- Regexp -- ------------ function Regexp (Self : Text_Fields.Field'Class; Str : String) return SQL_Criteria is begin return Compare (Self, Expression (Str), Comparison_Regexp'Access); end Regexp; ---------------- -- For_Update -- ---------------- function For_Update (Tables : SQL_Table_List := Empty_Table_List; No_Wait : Boolean := False) return SQL_PG_Extension'Class is begin return SQL_PG_For_Update'(Tables => Tables, No_Wait => No_Wait); end For_Update; --------------- -- Returning -- --------------- function Returning (Fields : SQL_Field_List) return SQL_PG_Extension'Class is begin return SQL_PG_Returning'(Returning => Fields); end Returning; --------- -- "&" -- --------- function "&" (Query : SQL_Query; Extension : SQL_PG_Extension'Class) return SQL_Query is Data : Query_Postgres_Contents; Q : SQL_Query; begin if Query.Get.all in Query_Postgres_Contents'Class then -- Merge the information with what has already been set. -- For now, assume that Extension is the same type as was -- already set, since we have a single extension for Update -- and a single extension for Select. Any other combination -- is invalid. if Extension in SQL_PG_For_Update'Class then declare Orig : SQL_PG_For_Update'Class renames SQL_PG_For_Update'Class (Query_Postgres_Contents'Class (Query.Get.all).Extra.all); begin Orig.Tables := Orig.Tables & SQL_PG_For_Update'Class (Extension).Tables; Orig.No_Wait := Orig.No_Wait or else SQL_PG_For_Update'Class (Extension).No_Wait; end; else declare Orig : SQL_PG_Returning'Class renames SQL_PG_Returning'Class (Query_Postgres_Contents'Class (Query.Get.all).Extra.all); begin Orig.Returning := Orig.Returning & SQL_PG_Returning'Class (Extension).Returning; end; end if; return Query; else Data.Base := Query; Data.Extra := new SQL_PG_Extension'Class'(Extension); Q.Set (Data); return Q; end if; end "&"; --------------- -- To_String -- --------------- overriding function To_String (Self : SQL_PG_For_Update; Format : Formatter'Class) return Unbounded_String is Result : Unbounded_String; begin Append (Result, " FOR UPDATE"); if Self.Tables /= Empty_Table_List then Append (Result, " OF "); Append (Result, To_String (Self.Tables, Format)); end if; if Self.No_Wait then Append (Result, " NO WAIT"); end if; return Result; end To_String; --------------- -- To_String -- --------------- overriding function To_String (Self : SQL_PG_Returning; Format : Formatter'Class) return Unbounded_String is Result : Unbounded_String; begin Append (Result, " RETURNING "); Append (Result, To_String (Self.Returning, Format, Long => True)); return Result; end To_String; --------------------------- -- Get_Connection_String -- --------------------------- function Get_Connection_String (Description : Database_Description; With_Password : Boolean) return String is Descr : constant Postgres_Description_Access := Postgres_Description_Access (Description); Str : XString; procedure Escape (Value : XString); procedure Escape (Value : XString) is begin for C of Value loop if C = ''' or else C = '\' then Str.Append ('\'); end if; Str.Append (C); end loop; end Escape; begin Str.Append ("dbname='"); Escape (Descr.Dbname); Str.Append ('''); if Descr.User /= Null_XString then Str.Append (" user='"); Escape (Descr.User); Str.Append ('''); end if; if Descr.Host /= Null_XString then Str.Append (" host='"); Escape (Descr.Host); Str.Append ('''); end if; if Descr.Port /= -1 then Str.Append (" port=" & Image (Descr.Port, Min_Width => 1)); end if; if With_Password and then Descr.Password /= Null_XString then Str.Append (" password='"); Escape (Descr.Password); Str.Append ('''); end if; case Descr.SSL is when Disable => Str.Append (" sslmode=disable"); when Allow => Str.Append (" sslmode=allow"); when Prefer => Str.Append (" sslmode=prefer"); when Require => Str.Append (" sslmode=require"); end case; return Str.To_String; end Get_Connection_String; end GNATCOLL.SQL.Postgres;