* Merging revisions r42273,r42276,r42277,r42278,r42279,r42285,r42295,r42296,r42297,r42298,r42298,r42299,r42300 from trunk:

------------------------------------------------------------------------
    r42273 | michael | 2019-06-23 00:38:02 +0200 (Sun, 23 Jun 2019) | 1 line
    
    * Fix setusessl
    ------------------------------------------------------------------------
    r42276 | lacak | 2019-06-23 20:02:38 +0200 (Sun, 23 Jun 2019) | 1 line
    
    fcl-db: sqldb: add connection charset aliases "win1250" (Firebird) and "cp1250" (MySQL) (although unicode is preferred nowadays and these SBCS are just a remnant of the past)
    ------------------------------------------------------------------------
    r42277 | michael | 2019-06-24 09:18:34 +0200 (Mon, 24 Jun 2019) | 1 line
    
    * Correctly handle use in restmodule: use pathinfo to configure dispatcher
    ------------------------------------------------------------------------
    r42278 | michael | 2019-06-24 09:22:02 +0200 (Mon, 24 Jun 2019) | 1 line
    
    * Smarter handling of DispatchOptions options
    ------------------------------------------------------------------------
    r42279 | michael | 2019-06-24 09:51:45 +0200 (Mon, 24 Jun 2019) | 1 line
    
    * Allow using of connection charset if none is specified at DB level (bug ID 35755)
    ------------------------------------------------------------------------
    r42285 | michael | 2019-06-26 10:34:47 +0200 (Wed, 26 Jun 2019) | 1 line
    
    * Allow generators in sqlite in 3.0.4
    ------------------------------------------------------------------------
    r42295 | michael | 2019-06-27 13:33:26 +0200 (Thu, 27 Jun 2019) | 1 line
    
    * Better CORS handling: return origin if available and allowed domains not set (* will prohibit credentials)
    ------------------------------------------------------------------------
    r42296 | michael | 2019-06-27 13:37:38 +0200 (Thu, 27 Jun 2019) | 1 line
    
    * Better CORS handling: return origin if available and allowed domains not set (fix compilation)
    ------------------------------------------------------------------------
    r42297 | michael | 2019-06-27 14:42:34 +0200 (Thu, 27 Jun 2019) | 1 line
    
    * Better CORS handling: return origin if available and allowed domains not set (activate using option)
    ------------------------------------------------------------------------
    r42298 | michael | 2019-06-27 18:13:15 +0200 (Thu, 27 Jun 2019) | 1 line
    
    * Fix ISODateTime constant, trailing quote
    ------------------------------------------------------------------------
    r42298 | michael | 2019-06-27 18:13:15 +0200 (Thu, 27 Jun 2019) | 1 line
    
    * Fix ISODateTime constant, trailing quote
    ------------------------------------------------------------------------
    r42299 | michael | 2019-06-27 18:13:55 +0200 (Thu, 27 Jun 2019) | 1 line
    
    * Better code documentation for processql, add %OPTIONALWHERE%
    ------------------------------------------------------------------------
    r42300 | michael | 2019-06-27 18:14:40 +0200 (Thu, 27 Jun 2019) | 1 line
    
    * Some fixes in parameter handling
    ------------------------------------------------------------------------

git-svn-id: branches/fixes_3_2@42432 -

packages/fcl-db/src/sqldb/interbase/ibconnection.pp

@@ -61,6 +61,7 @@ type
     FDatabaseInfo          : TDatabaseInfo;
     FDialect               : integer;
     FBlobSegmentSize       : word; //required for backward compatibilty; not used
+    FUseConnectionCharSetIfNone: Boolean;
 
     procedure ConnectFB;
 
@@ -132,6 +133,7 @@ type
     property Params;
     property OnLogin;
     Property Port stored false;
+    Property UseConnectionCharSetIfNone : Boolean Read FUseConnectionCharSetIfNone Write FUseConnectionCharSetIfNone;
   end;
   
   { TIBConnectionDef }
@@ -988,7 +990,8 @@ begin
         TransType, TransLen, TransPrec);
 
       // [var]char or blob column character set NONE or OCTETS overrides connection charset
-      if ((TransType in [ftString, ftFixedChar]) and (PSQLVar^.sqlsubtype and $FF in [CS_NONE,CS_BINARY])) or
+      if (((TransType in [ftString, ftFixedChar]) and (PSQLVar^.sqlsubtype and $FF in [CS_NONE,CS_BINARY])) and not UseConnectionCharSetIfNone)
+         or
          ((TransType = ftMemo) and (PSQLVar^.relname_length>0) and (PSQLVar^.sqlname_length>0) and (GetBlobCharset(@PSQLVar^.relname,@PSQLVar^.sqlname) in [CS_NONE,CS_BINARY])) then
         FieldDefs.Add(PSQLVar^.AliasName, TransType, TransLen, TransPrec, (PSQLVar^.sqltype and 1)=0, False, i+1, CP_NONE)
       else

packages/fcl-db/src/sqldb/sqldb.pp

@@ -1246,6 +1246,8 @@ begin
       FCodePage := CP_UTF8;
     'win1250','cp1250':
       FCodePage := 1250;
+    'win1251','cp1251':
+      FCodePage := 1251;
     'win1252','cp1252','latin1','iso8859_1':
       FCodePage := 1252;
     else

packages/fcl-web/src/base/custhttpapp.pp

@@ -197,7 +197,7 @@ end;
 
 function TCustomHTTPApplication.GetUseSSL: Boolean;
 begin
-
+  Result:=HTTPHandler.UseSSL;
 end;
 
 procedure TCustomHTTPApplication.SetHostName(AValue: String);

packages/fcl-web/src/restbridge/sqldbrestbridge.pp

@@ -27,7 +27,8 @@ Type
                            rdoCustomView,          // Expose custom view /customview
                            rdoHandleCORS,          // Handle CORS requests
                            rdoAccessCheckNeedsDB,  // Authenticate after connection to database was made.
-                           rdoConnectionResource   // Enable connection managament through /_connection[/:Conn] resource
+                           rdoConnectionResource,   // Enable connection managament through /_connection[/:Conn] resource
+                           rdoEmptyCORSDomainToOrigin // if CORSAllowedOrigins is empty CORS requests will mirror Origin instead of *
                            // rdoServerInfo        // Enable querying server info through /_serverinfo  resource
                            );
 
@@ -308,7 +309,7 @@ Type
     // General HTTP handling
     procedure DoRegisterRoutes; virtual;
     procedure DoHandleEvent(IsBefore : Boolean;IO: TRestIO); virtual;
-    function ResolvedCORSAllowedOrigins: String; virtual;
+    function ResolvedCORSAllowedOrigins(aRequest: TRequest): String; virtual;
     procedure HandleCORSRequest(aConnection: TSQLDBRestConnection; IO: TRestIO); virtual;
     procedure HandleResourceRequest(aConnection : TSQLDBRestConnection; IO: TRestIO); virtual;
     procedure DoHandleRequest(IO: TRestIO); virtual;
@@ -322,6 +323,7 @@ Type
     procedure HandleMetadataRequest(aRequest : TRequest; aResponse : TResponse);
     procedure HandleConnRequest(aRequest : TRequest; aResponse : TResponse);
     procedure HandleRequest(aRequest : TRequest; aResponse : TResponse);
+    Procedure VerifyPathInfo(aRequest : TRequest);
     Function ExposeDatabase(Const aType,aHostName,aDatabaseName,aUserName,aPassword : String; aTables : Array of String; aMinFieldOpts : TRestFieldOptions = []) : TSQLDBRestConnection;
     Function ExposeDatabase(Const aType,aHostName,aDatabaseName,aUserName,aPassword : String; aTables : TStrings = nil; aMinFieldOpts : TRestFieldOptions = []) : TSQLDBRestConnection;
     Function ExposeConnection(aOwner : TComponent; Const aConnection : TSQLDBRestConnection; aTables : TStrings = nil; aMinFieldOpts : TRestFieldOptions = []) : TSQLDBRestSchema;
@@ -409,7 +411,7 @@ Const
 
 implementation
 
-uses fpjsonrtti, DateUtils, bufdataset, sqldbrestjson, sqldbrestconst;
+uses uriparser, fpjsonrtti, DateUtils, bufdataset, sqldbrestjson, sqldbrestconst;
 
 Type
 
@@ -492,9 +494,16 @@ end;
 
 procedure TSQLDBRestDispatcher.SetDispatchOptions(AValue: TRestDispatcherOptions);
 
+Var
+  DeleteConnection : Boolean;
+
 begin
+  DeleteConnection:=(rdoConnectionInURL in FDispatchOptions) and Not (rdoConnectionInURL in aValue);
   if (rdoConnectionResource in aValue) then
-    Include(aValue,rdoConnectionInURL);
+    if DeleteConnection then // if user disables rdoConnectionInURL, we disable rdoConnectionResource.
+      exclude(aValue,rdoConnectionResource)
+    else // else we include rdoConnectionInURL...
+      Include(aValue,rdoConnectionInURL);
   if FDispatchOptions=AValue then Exit;
   FDispatchOptions:=AValue;
 end;
@@ -1617,12 +1626,33 @@ begin
     end
 end;
 
-function TSQLDBRestDispatcher.ResolvedCORSAllowedOrigins: String;
+function TSQLDBRestDispatcher.ResolvedCORSAllowedOrigins(aRequest : TRequest): String;
+
+Var
+  URl : String;
+  uri : TURI;
 
 begin
   Result:=FCORSAllowedOrigins;
   if Result='' then
-     Result:='*';
+    begin
+    // Sent with CORS request
+    Result:=aRequest.GetCustomHeader('Origin');
+    if (Result='') and (rdoEmptyCORSDomainToOrigin in DispatchOptions) then
+      begin
+      // Fallback
+      URL:=aRequest.Referer;
+      if (URL<>'') then
+        begin
+        uri:=ParseURI(URL,'http',0);
+        Result:=Format('%s://%s',[URI.Protocol,URI.Host]);
+        if (URI.Port<>0) then
+          Result:=Result+':'+IntToStr(URI.Port);
+        end;
+      end;
+    end;
+  if Result='' then
+    Result:='*';
 end;
 
 procedure TSQLDBRestDispatcher.HandleCORSRequest(aConnection : TSQLDBRestConnection; IO : TRestIO);
@@ -1644,7 +1674,7 @@ begin
     end
   else
     begin
-    IO.Response.SetCustomHeader('Access-Control-Allow-Origin',ResolvedCORSAllowedOrigins);
+    IO.Response.SetCustomHeader('Access-Control-Allow-Origin',ResolvedCORSAllowedOrigins(IO.Request));
     S:=IO.Resource.GetHTTPAllow;
     IO.Response.SetCustomHeader('Access-Control-Allow-Methods',S);
     IO.Response.SetCustomHeader('Access-Control-Allow-Headers','x-requested-with, content-type, authorization');
@@ -1684,7 +1714,7 @@ begin
         Conn.OnLog:=@IO.DoSQLLog;
         end;
       if (rdoHandleCORS in DispatchOptions) then
-        IO.Response.SetCustomHeader('Access-Control-Allow-Origin',ResolvedCORSAllowedOrigins);
+        IO.Response.SetCustomHeader('Access-Control-Allow-Origin',ResolvedCORSAllowedOrigins(IO.Request));
       if not AuthenticateRequest(IO,True) then
         exit;
       if Not CheckResourceAccess(IO) then
@@ -2002,6 +2032,42 @@ begin
   end;
 end;
 
+procedure TSQLDBRestDispatcher.VerifyPathInfo(aRequest: TRequest);
+Var
+  Full,Path : String;
+  BasePaths : TStringArray;
+  I : Integer;
+
+begin
+  // Check & discard basepath parts of the URL
+  Path:=aRequest.GetNextPathInfo;
+  Full:=BasePath;
+  BasePaths:=Full.Split('/',TStringSplitOptions.ExcludeEmpty);
+  I:=0;
+  While (I<Length(BasePaths)) and SameText(Path,BasePaths[i]) do
+    begin
+    inc(I);
+    Path:=aRequest.GetNextPathInfo;
+    end;
+  if (I<Length(BasePaths)) then
+    Raise ESQLDBRest.Create(400,'NOT FOUND');
+  // Path1 is now either connection or resource
+  if (rdoConnectionInURL in DispatchOptions) then
+    begin
+    // Both /metadata and /connection/metadata are possible
+    if not ((rdoExposeMetadata in DispatchOptions) and SameText(Path,Strings.getRestString(rpMetadataResourceName))) then
+      begin
+      aRequest.RouteParams['connection']:=Path;
+      Path:=aRequest.GetNextPathInfo;
+      end;
+    end;
+  aRequest.RouteParams['resource']:=Path;
+  // Next part is ID
+  Path:=aRequest.GetNextPathInfo;
+  if (Path<>'') then
+    aRequest.RouteParams['ID']:=Path;
+end;
+
 function TSQLDBRestDispatcher.ExposeDatabase(const aType, aHostName, aDatabaseName, aUserName, aPassword: String;
   aTables: array of String; aMinFieldOpts: TRestFieldOptions): TSQLDBRestConnection;
 

packages/fcl-web/src/restbridge/sqldbrestconst.pp

@@ -52,7 +52,7 @@ Resourcestring
 
 Const
   DefaultAuthenticationRealm = 'REST API Server';
-  ISODateTimeFormat = 'YYYY"-"mm"-"dd"T"hh":"nn":"ss"';
+  ISODateTimeFormat = 'YYYY"-"mm"-"dd"T"hh":"nn":"ss';
   ISODateFormat = ISODateTimeFormat;
   ISOTimeFormat = '"0000-00-00T"hh":"nn":"ss"';
 

packages/fcl-web/src/restbridge/sqldbrestdata.pp

@@ -64,7 +64,8 @@ Type
     function FindFieldForParam(aOperation: TRestOperation; P: TParam): TSQLDBRestField; virtual;
     function BuildFieldList(ForceAll : Boolean): TRestFieldPairArray; virtual;
     function CreateQuery(aSQL: String): TSQLQuery; virtual;
-    procedure FillParams(aOperation: TRestOperation; aQuery: TSQLQuery; FilteredFields: TRestFilterPairArray); virtual;
+    procedure FillParams(aOperation: TRestOperation; aParams: TParams;
+      FilteredFields: TRestFilterPairArray); virtual;
     function GetDatasetForResource(aFieldList: TRestFieldPairArray; Singleton : Boolean): TDataset; virtual;
     function GetOrderByFieldArray: TRestFieldOrderPairArray;
     function GetOrderBy: UTF8String;virtual;
@@ -388,7 +389,12 @@ end;
 procedure TSQLDBRestDBHandler.SetParamFromData(P: TParam; F: TSQLDBRestField;
   D: TJSONData);
 
+Var
+  S : String;
+
 begin
+  if Assigned(D) then
+    S:=D.AsString;
   if not Assigned(D) then
     P.Clear
   else if Assigned(F) then
@@ -434,7 +440,7 @@ begin
     Result:=FResource.Fields.FindByFieldName(N);
 end;
 
-procedure TSQLDBRestDBHandler.FillParams(aOperation : TRestOperation; aQuery: TSQLQuery;FilteredFields : TRestFilterPairArray);
+procedure TSQLDBRestDBHandler.FillParams(aOperation : TRestOperation; aParams: TParams;FilteredFields : TRestFilterPairArray);
 
 Var
   I : Integer;
@@ -452,19 +458,21 @@ begin
     F:=FF.Field;
     if FF.Operation<>rfNull then
       begin
-      P:=aQuery.Params.FindParam(FilterParamPrefix[FF.Operation]+F.FieldName);
+      P:=aParams.FindParam(FilterParamPrefix[FF.Operation]+F.FieldName);
-      if not Assigned(P) then
+      // If there is no %where% macro, the parameter can be absent
-        Raise ESQLDBRest.CreateFmt(IO.RestStatuses.GetStatusCode(rsError),SErrFilterParamNotFound,[F.PublicName]);
+      if Assigned(P) then
-      if Assigned(FF.ValueParam) then
-        P.Value:=FF.ValueParam.Value
-      else
         begin
-        D:=TJSONString.Create(FF.Value);
+        if Assigned(FF.ValueParam) then
-        try
+          P.Value:=FF.ValueParam.Value
-          SetParamFromData(P,F,D)
+        else
-        finally
+          begin
-          D.Free;
+          D:=TJSONString.Create(FF.Value);
-        end;
+          try
+            SetParamFromData(P,F,D)
+          finally
+            D.Free;
+          end;
+          end;
         end;
       end;
     end;
@@ -477,9 +485,9 @@ begin
   else
     Sources:=AllVariableSources;
   end;
-  For I:=0 to aQuery.Params.Count-1 do
+  For I:=0 to aParams.Count-1 do
     begin
-    P:=aQuery.Params[i];
+    P:=aParams[i];
     if P.IsNull then
       try
         D:=Nil;
@@ -654,7 +662,7 @@ begin
   Q:=CreateQuery(SQL);
   Try
     Q.UsePrimaryKeyAsKey:=False;
-    FillParams(roGet,Q,WhereFilterList);
+    FillParams(roGet,Q.Params,WhereFilterList);
     Result:=Q;
   except
     Q.Free;
@@ -715,6 +723,23 @@ function TSQLDBRestDBHandler.GetGeneratorValue(const aGeneratorName: String
   ): Int64;
 
 begin
+{$IFDEF VER3_0_4}
+  // The 'get next value' SQL in 3.0.4 is wrong, so we need to do this sep
+  if (IO.Connection is TSQLConnector) and SameText((IO.Connection as TSQLConnector).ConnectorType,'Sqlite3') then
+    begin
+    With CreateQuery('SELECT seq+1 FROM sqlite_sequence WHERE name=:aName') do
+      Try
+        ParamByName('aName').AsString:=aGeneratorName;
+        Open;
+        if (EOF and BOF) then
+          DatabaseErrorFmt('Generator %s does not exist',[aGeneratorName]);
+        Result:=Fields[0].asLargeint;
+      Finally
+        Free;
+      end;
+    end
+  else
+{$ENDIF}
   Result:=IO.Connection.GetNextValue(aGeneratorName,1);
 end;
 
@@ -870,7 +895,7 @@ begin
   if not IO.RESTInput.SelectObject(0) then
     raise ESQLDBRest.Create(IO.RestStatuses.GetStatusCode(rsInvalidParam), SErrNoResourceDataFound);
   InsertNewRecord;
-  // Now build response
+  // Now build response. We can imagine not doing a select again, and simply supply back the fields as sent...
   FieldList:=BuildFieldList(False);
   D:=GetDatasetForResource(FieldList,True);
   try
@@ -887,6 +912,7 @@ procedure TSQLDBRestDBHandler.UpdateExistingRecord(OldData : TDataset);
 Var
   S : TSQLStatement;
   SQl : String;
+  WhereFilterList : TRestFilterPairArray;
 
 begin
   if (OldData=ExternalDataset) then
@@ -902,13 +928,14 @@ begin
     end
   else
     begin
-    SQL:=FResource.GetResolvedSQl(skUpdate,'','','');
+    SQL:=FResource.GetResolvedSQl(skUpdate,GetIDWhere(WhereFilterList) ,'','');
     S:=TSQLStatement.Create(Self);
     try
       S.Database:=IO.Connection;
       S.Transaction:=IO.Transaction;
       S.SQL.Text:=SQL;
       SetPostParams(S.Params,OldData.Fields);
+      FillParams(roGet,S.Params,WhereFilterList);
       // Give user a chance to look at it.
       FResource.CheckParams(io.RestContext,roPut,S.Params);
       S.Execute;
@@ -976,6 +1003,7 @@ begin
     // Now build response
     if D<>ExternalDataset then
       begin;
+      // Now build response. We can imagine not doing a select again, and simply supply back the fields as sent...
       FreeAndNil(D);
       D:=GetDatasetForResource(FieldList,True);
       FieldList:=BuildFieldList(False);
@@ -1026,7 +1054,7 @@ begin
     SQL:=FResource.GetResolvedSQl(skDelete,aWhere,'');
     Q:=CreateQuery(SQL);
     try
-      FillParams(roDelete,Q,FilteredFields);
+      FillParams(roDelete,Q.Params,FilteredFields);
       Q.ExecSQL;
       if Q.RowsAffected<>1 then
         DoNotFound;

packages/fcl-web/src/restbridge/sqldbrestmodule.pp

@@ -17,6 +17,7 @@ Type
     procedure SetDispatcher(AValue: TSQLDBRestDispatcher);
   Protected
     Procedure Notification(AComponent: TComponent; Operation: TOperation); override;
+    procedure ConfigureDispatcherFromRequest(Disp: TSQLDBRestDispatcher; aRequest: TRequest); virtual;
     Function FindDispatcher : TSQLDBRestDispatcher; virtual;
   Public
     constructor Create(AOwner: TComponent); override;
@@ -28,7 +29,7 @@ Type
 
 implementation
 
-uses sqldbrestconst;
+uses sqldbrestschema, sqldbrestconst;
 
 { TSQLDBRestModule }
 
@@ -39,7 +40,10 @@ begin
     FDispatcher.RemoveFreeNotification(Self);
   FDispatcher:=AValue;
   if Assigned(Dispatcher) then
+    begin
+    FDispatcher.Active:=False;
     FDispatcher.FreeNotification(Self);
+    end;
 end;
 
 procedure TSQLDBRestModule.Notification(AComponent: TComponent; Operation: TOperation);
@@ -61,6 +65,12 @@ begin
   inherited Create(AOwner);
 end;
 
+procedure TSQLDBRestModule.ConfigureDispatcherFromRequest(Disp : TSQLDBRestDispatcher; aRequest : TRequest);
+
+begin
+  Disp.VerifyPathInfo(aRequest);
+end;
+
 procedure TSQLDBRestModule.HandleRequest(ARequest: TRequest; AResponse: TResponse);
 
 Var
@@ -69,7 +79,11 @@ Var
 begin
   Disp:=FindDispatcher;
   If assigned(Disp) then
+    begin
+    Disp.Active:=False;
+    ConfigureDispatcherFromRequest(Disp,aRequest);
     Disp.HandleRequest(aRequest,aResponse)
+    end
   else
     Raise EHTTP.Create(SErrNoRESTDispatcher);
 end;

packages/fcl-web/src/restbridge/sqldbrestschema.pp

@@ -1079,7 +1079,7 @@ Const
 
 Const
   Wheres = [flWhereKey];
-  Colons = Wheres + [flInsertParams];
+  Colons = Wheres + [flInsertParams,flUpdate];
   UseEqual = Wheres+[flUpdate];
 
 Var
@@ -1178,16 +1178,29 @@ Var
 
 begin
   Result:=aSQL;
+
+  // from tables %FULLWHERE%
   if (aWhere<>'') then
     S:='WHERE '+aWhere
   else
     S:='';
   Result:=StringReplace(Result,'%FULLWHERE%',S,[rfReplaceAll]);
+
+  // from tables WHERE %REQUIREDWHERE%
   if (aWhere<>'') then
     S:=aWhere
   else
     S:='(1=0)';
   Result:=StringReplace(Result,'%REQUIREDWHERE%',S,[rfReplaceAll]);
+
+  // from tables WHERE X=Y %OPTIONALWHERE%
+  if (aWhere<>'') then
+    S:='AND ('+aWhere+')'
+  else
+    S:='';
+  Result:=StringReplace(Result,'%OPTIONALWHERE%',S,[rfReplaceAll]);
+
+  // from tables WHERE X=Y AND %WHERE%
   if (aWhere<>'') then
     S:='('+aWhere+')'
   else