unit cgiDM;

{$mode ObjFPC}{$H+}

interface

uses
  Classes, SysUtils, nnz_data_components, frxClass, nnzDBClient,DB,extTypes;

type

  { TNIDBDM }

  TNIDBDM = class(TDataModule)
    frxReport1: TfrxReport;
    nnzQuery1: TnnzQuery;
    procedure DataModuleCreate(Sender: TObject);
    procedure DataModuleDestroy(Sender: TObject);
  private
    fcon: TnnzConnection;
    fMid: integer;
    fLogin: string;
    fID: TGUID;
    fLastConnectTime: TDateTime;
    flogger: TLogger;
    class function DeleteLastChar(const St: String; const CharCount: integer=1): String;
  public

    class function FloatAsSQL(Value: Double): String;
    class function PeriodAsSQL(BegDate, EndDate: TDateTime): string;
    class function DateAsSQL(Date: TDateTime): String;
    class function DateTimeAsSQL(Stamp: TDateTime): String;
    class function CurrencyAsSQL(Value: Currency): string;
    class function VariantAsSQL(const Value: Variant): String;
    class function BooleanAsSQL(Value: Boolean): String;
    class function StringAsSQL(const St: String): String;
    class function StringAsJSON(const St: String): String;
    class function StreamAsSQL(s: TStream): String;
    class function BytesAsSQL(const data: array of byte; dataSize: integer): string;
    class function IntArrayAsSQL(const data: array of integer): string;
    class procedure UpdateWithArguments(var code: string; const Arguments: TStrings);
    property logger: TLogger read flogger write flogger;
    property connection: TnnzConnection read fCon;
    function CheckConnection: boolean;
    function QueryValue(ASQL: string; Default: string=''): string;
    function QueryIntValue(ASQL: string): integer;
    function GetData(ASQL: string): TDataSet;
    function CheckUser(const login,password: string; out UserID: integer): boolean;
    procedure OpenConnection;
    procedure log(ALevel: TLogLevel; Sender: TObject; msg: string);
    procedure LogError(Sender: TObject; e: Exception; msg: string);
    procedure ExecuteSQL(ASQL: string);
    constructor CreateWithLogger(ALogger: TLogger);
  end;

var
  NIDBDM: TNIDBDM;

implementation
uses
  variants,LazUTF8;
{$R *.lfm}

{ TNIDBDM }

procedure TNIDBDM.DataModuleCreate(Sender: TObject);
begin
  log(mtDebug,sender,'TnnzConnection.Create');
  fcon := TnnzConnection.Create(self);

end;

procedure TNIDBDM.DataModuleDestroy(Sender: TObject);
begin
  log(mtDebug,sender,'destroy');
  fcon.Connected:=false;
  fcon.free;
end;

class function TNIDBDM.DeleteLastChar(const St: String;
  const CharCount: integer): String;
begin
  Result := utf8Copy(St, 1, utf8Length(St) - CharCount);
end;

class function TNIDBDM.FloatAsSQL(Value: Double): String;
var
  fs: TFormatSettings;
begin
  fs.DecimalSeparator := '.';
  Result := FloatToStr(Value, fs);
end;


class function TNIDBDM.PeriodAsSQL(BegDate, EndDate: TDateTime): string;
begin
  if (BegDate <= 2) and (EndDate <= 2) then
    Result := '>=''1900-01-01'''
  else
    Result := 'BETWEEN ' + DateAsSQL(BegDate) + ' AND ' + DateAsSQL(EndDate);
end;


class function TNIDBDM.DateAsSQL(Date: TDateTime): String;
begin
  if FormatSettings.ShortMonthNames[1] <> 'JAN' then
  begin
    FormatSettings.ShortMonthNames[1] := 'JAN';
    // без этого дурит MSSQL7/MSSQL2000, который не понимает
    FormatSettings.ShortMonthNames[2] := 'FEB'; // дату в формате '13 окт 1999'
    FormatSettings.ShortMonthNames[3] := 'MAR';
    FormatSettings.ShortMonthNames[4] := 'APR';
    FormatSettings.ShortMonthNames[5] := 'MAY';
    FormatSettings.ShortMonthNames[6] := 'JUN';
    FormatSettings.ShortMonthNames[7] := 'JUL';
    FormatSettings.ShortMonthNames[8] := 'AUG';
    FormatSettings.ShortMonthNames[9] := 'SEP';
    FormatSettings.ShortMonthNames[10] := 'OCT';
    FormatSettings.ShortMonthNames[11] := 'NOV';
    FormatSettings.ShortMonthNames[12] := 'DEC';
  end;
  if Date < 2 then
    Date := 2; // приводим к 1 января 1900 - это ноль для SMALLDATETIME
  Result := QuotedStr(FormatDateTime('yyyy-mm-dd', Date));
end;
class function TNIDBDM.DateTimeAsSQL(Stamp: TDateTime): String;
begin
    // Result := FloatToStr(Real(Stamp) - 2); старый вариант - ldm
  Result := '';
  DateTimeToString(Result, 'hh:nn:ss', Stamp);
  Result := DeleteLastChar(DateAsSQL(Stamp)) + ' ' + Result + '''';
end;

class function TNIDBDM.CurrencyAsSQL(Value: Currency): string;
begin
  Result := StringAsSQL(CurrToStr(Value));
end;

class function TNIDBDM.VariantAsSQL(const Value: Variant): String;
var
  Stream: TStringStream;
begin
  case VarType(Value) of
    varNull:
      Result := 'NULL';
    varEmpty:
      Result := 'NULL';
    varSmallInt, varInteger, varShortInt, varByte, varWord, varLongWord,
      varInt64, varUInt64:
      Result := VarToStr(Value);
    varSingle, varCurrency:
      Result := CurrencyAsSQL(Value);
    varDouble:
      Result := FloatAsSQL(Value);
    varDate:
      Result := DateAsSQL(Value);
    varOleStr:
      begin
        Stream := TStringStream.Create(Value);
        try
          Result := StreamAsSQL(Stream);
        finally
          Stream.Free;
        end;
      end;
    varBoolean:
      Result := BooleanAsSQL(Value);
    varString, varUString:
      Result := StringAsSQL(Value);
  else
    raise Exception.Create('VariantAsSQL: Неверный тип ' + VarToStr(Value));
  end;
end;

class function TNIDBDM.BooleanAsSQL(Value: Boolean): String;
begin
  if value then result := 'true' else result := 'false';
end;


class function TNIDBDM.StreamAsSQL(s: TStream): String;
var
  i: Integer;
  b: Byte;
begin
  result := 'null';
  if s.size=0 then exit;
  //Result := '0x'; //MySQL
  Result := 'E''\\x';  //PostgreSQL
  s.Position := 0;
  for i := 1 to s.Size do
  begin
    s.Read(b, 1);
    Result := Result + IntToHex(b, 2);
  end;
  result := result +'''';
end;

class function TNIDBDM.BytesAsSQL(const data: array of byte;
  dataSize: integer): string;
var
  i: integer;
  b: byte;
begin
  result := 'null';
  if datasize=0 then exit;
  Result := 'E''\\x';  //PostgreSQL
  for i := 0 to dataSize-1 do
    begin
      b := data[i];
      Result := Result + IntToHex(b, 2);
    end;
  result := result +'''';
end;


class function TNIDBDM.IntArrayAsSQL(const data: array of integer): string;
var
  i: integer;
begin
  if length(data)=0 then
    result := 'ARRAY[]::integer[]'
  else
    begin
      result := inttostr(data[low(data)]);
      for i := low(data)+1 to high(data) do
        result := result +','+inttostr(data[i]);
      result := format('ARRAY[%s]::integer[]',[result]);
    end;
end;

class procedure TNIDBDM.UpdateWithArguments(var code: string;
  const Arguments: TStrings);
var
  i: integer;
  s,v: string;
begin
  for i := 0 to Arguments.Count-1 do
    begin
      s := Arguments.Names[i];
      v := Arguments.Values[s];
      Code := StringReplace(Code,'{s#'+s+'}',  TNidbDM.StringAsSQL(v),[rfReplaceAll]);
      Code := StringReplace(Code,'{d#'+s+'}',TNidbDM.StringAsSQL(v),[rfReplaceAll]);
      Code := StringReplace(Code,'{#'+s+'}',v,[rfReplaceAll]);
    end;
end;

function TNIDBDM.CheckConnection: boolean;
begin
  if not connection.Connected then
    OpenConnection;
  try
    connection.ExecuteSQL('SELECT 1');
    result := true;
  except
    connection.Close(true);
    OpenConnection;
    result := false;
  end;
end;




class function TNIDBDM.StringAsSQL(const St: String): String;
var
  len,i: Cardinal;
  c: Char;
  hasSpecial: boolean;
begin
//  Result := QuotedStr(StringReplace(St, '\', '\\',
//    [rfReplaceAll, rfIgnoreCase]));
  Result:='';
  len:=Length(St);
  hasSpecial := false;
  for i:=1 to len do begin
    c:=St[i];
    hasSpecial := hasSpecial or (c in [#0,'''','"','\',#8,#10,#13,#9,#26]);
    case(c) of
      #0:  Result:=Result+'\0';
      '''','"','\':  Result:=Result+'\'+c;
      #8:   Result:=Result+'\b';
      #10:  Result:=Result+'\n';
      #13:  Result:=Result+'\r';
      #9:   Result:=Result+'\t';
      #26:  Result:=Result+'\Z';
    else
      Result:=Result+c;
    end;
  end;
  Result:=''''+Result+'''';
  if hasSpecial  then Result :='E'+Result;

end;

class function TNIDBDM.StringAsJSON(const St: String): String;
begin
  result := st;
  result := UTF8StringReplace(result,'\','\\',[rfReplaceAll]);
  result := UTF8StringReplace(result,'"','\"',[rfReplaceAll]);
end;


function TNIDBDM.QueryValue(ASQL: string; Default: string): string;
begin
  log(mtDebug,self,'QueryValue'#13#10+ASQL);
  CheckConnection;
  with TnnzQuery.Create(self) do
    try
      Connection := fcon;
      SQL.Text:=ASQL;
      Open;
      if not eof and not Fields[0].IsNull then result := Fields[0].AsString else result := Default;
    finally
      free;
    end;
end;

function TNIDBDM.QueryIntValue(ASQL: string): integer;
begin
  log(mtDebug,self,'QueryIntValue'#13#10+ASQL);
  CheckConnection;
  with TnnzQuery.Create(self) do
    try
      Connection := fcon;
      SQL.Text:=ASQL;
      Open;
      if not eof then result := Fields[0].AsInteger else result := 0;
    finally
      free;
    end;
end;


function TNIDBDM.GetData(ASQL: string): TDataSet;
begin
  log(mtDebug,self,'getData '#13#10+ASQL);
  CheckConnection;
  result := TnnzQuery.Create(self);
  with result as TnnzQuery do
    begin
      Connection := fcon;
      SQL.Text:=ASQL;
      Open;

    end;
end;

function TNIDBDM.CheckUser(const login, password: string; out UserID: integer
  ): boolean;
begin
  log(mtInfo,self,'CheckUser '+login);
  UserID := QueryIntValue(format('Select coalesce((select min(p.mid) from people p where login=%s and password=%s),0) ',[StringAsSQL(login),StringAsSQl(password)]));
  result := UserID>0;
end;

procedure TNIDBDM.OpenConnection;
begin
  log(mtDebug,self,'OpenConnection');
  fcon.Connected:=true;
  fcon.Identify;
end;

procedure TNIDBDM.log(ALevel: TLogLevel; Sender: TObject; msg: string);
begin
  if assigned(flogger) then
    flogger(ALevel,Sender,msg);
end;

procedure TNIDBDM.LogError(Sender: TObject; e: Exception; msg: string);
begin
  log(mtERROR,Sender,'!!ERROT at '+msg+#13#10+e.ClassName+#13#10+e.message);
end;

procedure TNIDBDM.ExecuteSQL(ASQL: string);
begin
  log(mtDebug,self,'ExecuteSQL '+ASQL);
  CheckConnection;
  connection.ExecuteSQL(ASQL);
end;

constructor TNIDBDM.CreateWithLogger(ALogger: TLogger);
begin
  fLogger := ALogger;
  log(mtDebug,nil,'TNIDBDM.Create');
  inherited Create(nil);
end;

end.