Merge pull request #2 from synopse/master

update from synopse/mormot
synopse · Apr 26, 2018 · 555bd37 · 555bd37
2 parents 6eabbe7 + 7ae4121
commit 555bd37
Show file tree

Hide file tree

Showing 12 changed files with 250 additions and 101 deletions.
diff --git a/SQLite3/Samples/31 - WebSockets/Project31WinHTTPEchoServer.dpr b/SQLite3/Samples/31 - WebSockets/Project31WinHTTPEchoServer.dpr
@@ -1,15 +1,16 @@
 program Project31WinHTTPEchoServer;
 
+{$I Synopse.inc}
+
+{$APPTYPE CONSOLE}
+
 uses
   {$I SynDprUses.inc} // use FastMM4 on older Delphi, or set FPC threads
   SysUtils,
-  Windows,
   SynZip,
   SynCrtSock,
   SynCommons;
 
-{$APPTYPE CONSOLE}
-
 type
   TSimpleWebsocketServer = class
   private
@@ -18,8 +19,8 @@ type
     function onHttpRequest(Ctxt: THttpServerRequest): cardinal;
     function onAccept(Ctxt: THttpServerRequest; var Conn: THttpApiWebSocketConnection): Boolean;
     procedure onConnect(const Conn: THttpApiWebSocketConnection );
-    procedure onMessage(const Conn: THttpApiWebSocketConnection; aBufferType: WEB_SOCKET_BUFFER_TYPE; aBuffer: Pointer; aBufferSize: ULONG);
-    procedure onDisconnect(const Conn: THttpApiWebSocketConnection ; aStatus: WEB_SOCKET_CLOSE_STATUS; aBuffer: Pointer; aBufferSize: ULONG);
+    procedure onMessage(const Conn: THttpApiWebSocketConnection; aBufferType: WEB_SOCKET_BUFFER_TYPE; aBuffer: Pointer; aBufferSize: Cardinal);
+    procedure onDisconnect(const Conn: THttpApiWebSocketConnection ; aStatus: WEB_SOCKET_CLOSE_STATUS; aBuffer: Pointer; aBufferSize: Cardinal);
   public
     constructor Create;
     destructor Destroy; override;
@@ -53,11 +54,11 @@ end;
 
 procedure TSimpleWebsocketServer.onConnect(const Conn: THttpApiWebSocketConnection);
 begin
-  Writeln('Connected ', Conn.index);
+  Writeln('New connection. Assigned connectionID=', Conn.index);
 end;
 
 procedure TSimpleWebsocketServer.onDisconnect(const Conn: THttpApiWebSocketConnection;
-  aStatus: WEB_SOCKET_CLOSE_STATUS; aBuffer: Pointer; aBufferSize: ULONG);
+  aStatus: WEB_SOCKET_CLOSE_STATUS; aBuffer: Pointer; aBufferSize: Cardinal);
 var
   str: RawUTF8;
 begin
@@ -78,53 +79,80 @@ begin
 end;
 
 procedure TSimpleWebsocketServer.onMessage(const Conn: THttpApiWebSocketConnection;
-  aBufferType: WEB_SOCKET_BUFFER_TYPE; aBuffer: Pointer; aBufferSize: ULONG);
+  aBufferType: WEB_SOCKET_BUFFER_TYPE; aBuffer: Pointer; aBufferSize: Cardinal);
 var
   str: RawUTF8;
 begin
   Conn.Send(aBufferType, aBuffer, aBufferSize);
 //  Conn.Protocol.Send(Conn.index, aBufferType, aBuffer, aBufferSize); //also work
   SetString(str, pUtf8Char(aBuffer), aBufferSize);
   if aBufferType = WEB_SOCKET_UTF8_MESSAGE_BUFFER_TYPE then
-    Writeln('UTF8 message from ', Conn.index, ' ',str)
+    Writeln('UTF8 message from ', Conn.index, ': ',str)
   else if aBufferType = WEB_SOCKET_UTF8_FRAGMENT_BUFFER_TYPE then
-    Writeln('UTF8 fragment from ', Conn.index, ' ',str)
+    Writeln('UTF8 fragment from ', Conn.index, ': ',str)
   else if (aBufferType = WEB_SOCKET_BINARY_MESSAGE_BUFFER_TYPE)
     or (aBufferType = WEB_SOCKET_BINARY_FRAGMENT_BUFFER_TYPE) then
     Writeln(aBufferType, ' from ', Conn.index, ' of length ', aBufferSize)
   else begin
-    Writeln(aBufferType, ' from ', Conn.index, ' ',str);
+    Writeln(aBufferType, ' from ', Conn.index, ': ',str);
   end;
 end;
 
 var
   _Server: TSimpleWebsocketServer;
   s: string;
+  idx: integer;
   MsgBuffer: RawUTF8;
   CloseReasonBuffer: RawUTF8;
 begin
-  MsgBuffer := 'Manual Message!';
-  CloseReasonBuffer := 'Manual Close!';
+  MsgBuffer := '';
+  CloseReasonBuffer := 'Connection closed by server';
   try
     _Server := TSimpleWebsocketServer.Create;
     try
       Writeln('WebSocket server is now listen on ws://localhost:8888/whatever');
       Writeln('HTTP server is now listen on http://localhost:8888/');
-      Writeln(' - point your browser to http://localhost:8888/ for initial page');
-      Writeln(' - type "close connectionID" to close existing webSocket connection');
-      Writeln(' - type "send  connectionID" to send text to specified WebCocket');
+      Writeln(' Point your browser to http://localhost:8888/ for initial page');
+      WriteLn('Type one of a commnad:');
+      Writeln(' - "close connectionID" to close existing webSocket connection');
+      Writeln(' - "sendto connectionID" to send text to specified WebCocket');
+      Writeln(' - "sendall" to send text to specified WebCocket');
       Writeln(' - press [Enter] to quit');
+      Writeln('Waiting for command:');
       repeat
         Readln(s);
         if Pos('close ', s) = 1 then begin
           s := SysUtils.Trim(Copy(s, 7, Length(s)));
           _Server.fServer.Protocols[0].Close(StrToIntDef(s, -1), WEB_SOCKET_SUCCESS_CLOSE_STATUS,
             Pointer(CloseReasonBuffer), length(CloseReasonBuffer));
-        end else if Pos('send ', s) = 1 then begin
-          s := SysUtils.Trim(Copy(s, 6, Length(s)));
-          _Server.fServer.Protocols[0].Send(StrToIntDef(s, -1), WEB_SOCKET_UTF8_MESSAGE_BUFFER_TYPE,
-             Pointer(MsgBuffer), length(MsgBuffer));
-        end;
+        end else if Pos('sendto ', s) = 1 then begin
+          s := SysUtils.Trim(Copy(s, 8, Length(s)));
+          idx := StrToIntDef(s, -1);
+          if (idx = -1 ) then
+            Writeln('Invalid connection ID. Usage: send connectionID (Example: send 0)')
+          else begin
+            Write('Type text to send: ');
+            Readln(MsgBuffer);
+            if _Server.fServer.Protocols[0].Send(
+              StrToIntDef(s, -1), WEB_SOCKET_UTF8_MESSAGE_BUFFER_TYPE,
+              Pointer(MsgBuffer), length(MsgBuffer)
+            ) then
+              WriteLn('Sent successfully. The message should appear in the client. Waiting for command:')
+            else
+              WriteLn('Error')
+          end;
+        end else if (s = 'sendall') then begin
+          Write('Type text to send: ');
+          Readln(MsgBuffer);
+          if _Server.fServer.Protocols[0].Broadcast(
+            WEB_SOCKET_UTF8_MESSAGE_BUFFER_TYPE,
+            Pointer(MsgBuffer), length(MsgBuffer)
+          ) then
+            WriteLn('Broadcast successfully. All clients should got a message. Waiting for command:')
+          else
+            WriteLn('Error')
+        end else if (s <> '') then
+          WriteLn('Invalid comand; Valid command are: close, sendto, sendall');
       until s = '';
     finally
       _Server.Free;
@@ -133,4 +161,4 @@ begin
     on E: Exception do
       Writeln(E.ClassName, ': ', E.Message);
   end;
-end.
+end.
diff --git a/SQLite3/Samples/31 - WebSockets/Project31WinHTTPEchoServer.lpi b/SQLite3/Samples/31 - WebSockets/Project31WinHTTPEchoServer.lpi
@@ -0,0 +1,71 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<CONFIG>
+  <ProjectOptions>
+    <Version Value="11"/>
+    <PathDelim Value="\"/>
+    <General>
+      <Flags>
+        <MainUnitHasUsesSectionForAllUnits Value="False"/>
+        <MainUnitHasCreateFormStatements Value="False"/>
+        <MainUnitHasTitleStatement Value="False"/>
+      </Flags>
+      <SessionStorage Value="InProjectDir"/>
+      <MainUnit Value="0"/>
+      <Title Value="Project31WinHTTPEchoServer"/>
+      <UseAppBundle Value="False"/>
+      <ResourceType Value="res"/>
+    </General>
+    <i18n>
+      <EnableI18N LFM="False"/>
+    </i18n>
+    <BuildModes Count="1">
+      <Item1 Name="Default" Default="True"/>
+    </BuildModes>
+    <PublishOptions>
+      <Version Value="2"/>
+    </PublishOptions>
+    <RunParams>
+      <FormatVersion Value="2"/>
+      <Modes Count="1">
+        <Mode0 Name="default"/>
+      </Modes>
+    </RunParams>
+    <RequiredPackages Count="1">
+      <Item1>
+        <PackageName Value="LCL"/>
+      </Item1>
+    </RequiredPackages>
+    <Units Count="1">
+      <Unit0>
+        <Filename Value="Project31WinHTTPEchoServer.dpr"/>
+        <IsPartOfProject Value="True"/>
+      </Unit0>
+    </Units>
+  </ProjectOptions>
+  <CompilerOptions>
+    <Version Value="11"/>
+    <PathDelim Value="\"/>
+    <SearchPaths>
+      <IncludeFiles Value="..\..\..;$(ProjOutDir)"/>
+      <OtherUnitFiles Value="..\..\.."/>
+    </SearchPaths>
+    <Parsing>
+      <SyntaxOptions>
+        <SyntaxMode Value="Delphi"/>
+      </SyntaxOptions>
+    </Parsing>
+  </CompilerOptions>
+  <Debugging>
+    <Exceptions Count="3">
+      <Item1>
+        <Name Value="EAbort"/>
+      </Item1>
+      <Item2>
+        <Name Value="ECodetoolError"/>
+      </Item2>
+      <Item3>
+        <Name Value="EFOpenError"/>
+      </Item3>
+    </Exceptions>
+  </Debugging>
+</CONFIG>
diff --git a/SQLite3/mORMot.pas b/SQLite3/mORMot.pas
@@ -3234,8 +3234,7 @@   TSQLPropInfo = class
     fPropertyIndex: integer;
     fFromRTTI: boolean;
     function GetNameDisplay: string; virtual;
-    /// those two protected methods allow custom storage of binary content
-    // as text
+    /// those two protected methods allow custom storage of binary content as text
     // - default implementation is to use hexa (ToSQL=true) or Base64 encodings
     procedure BinaryToText(var Value: RawUTF8; ToSQL: boolean; wasSQLString: PBoolean); virtual;
     procedure TextToBinary(Value: PUTF8Char; var result: RawByteString); virtual;
@@ -21397,11 +21396,13 @@ procedure TSQLPropInfo.GetFieldSQLVar(Instance: TObject; var aValue: TSQLVar;
       aValue.VDouble := GetExtended(pointer(temp));
     ftDate:
       aValue.VDateTime := Iso8601ToDateTime(temp);
-    ftBlob: begin
-      temp := BlobToTSQLRawBlob(temp);
-      aValue.VBlob := pointer(temp);
-      aValue.VBlobLen := length(temp);
-    end;
+    ftBlob:
+      if temp='' then
+        aValue.VType := ftNull else begin
+        temp := BlobToTSQLRawBlob(temp);
+        aValue.VBlob := pointer(temp);
+        aValue.VBlobLen := length(temp);
+      end;
     ftUTF8:
       aValue.VText := pointer(temp);
     else
@@ -23251,17 +23252,19 @@ procedure TSQLPropInfoRTTIDynArray.Serialize(Instance: TObject;
     temp: TTextWriterStackBuffer;
 begin
   GetDynArray(Instance,da);
-  if fObjArray<>nil then
-    with TJSONSerializer.CreateOwnedStream(temp) do
-    try
-      if ExtendedJson then
-        include(fCustomOptions,twoForceJSONExtended); // smaller content
-      AddDynArrayJSON(da);
-      SetText(RawUTF8(data));
-    finally
-      Free;
-    end else
-    data := da.SaveTo;
+  if da.Count=0 then
+    data := '' else
+    if fObjArray<>nil then
+      with TJSONSerializer.CreateOwnedStream(temp) do
+      try
+        if ExtendedJson then
+          include(fCustomOptions,twoForceJSONExtended); // smaller content
+        AddDynArrayJSON(da);
+        SetText(RawUTF8(data));
+      finally
+        Free;
+      end else
+      data := da.SaveTo;
 end;
 
 procedure TSQLPropInfoRTTIDynArray.CopySameClassProp(Source: TObject;
@@ -23414,14 +23417,16 @@ procedure TSQLPropInfoRTTIDynArray.GetFieldSQLVar(Instance: TObject;
 begin
   Serialize(Instance,temp,false);
   aValue.Options := [];
-  if fObjArray<>nil then begin
-    aValue.VType := ftUTF8; // JSON
-    aValue.VText := pointer(temp);
-  end else begin
-    aValue.VType := ftBlob; // binary
-    aValue.VBlob := pointer(temp);
-    aValue.VBlobLen := length(temp);
-  end;
+  if temp='' then
+    aValue.VType := ftNull else
+    if fObjArray<>nil then begin
+      aValue.VType := ftUTF8; // JSON
+      aValue.VText := pointer(temp);
+    end else begin
+      aValue.VType := ftBlob; // binary
+      aValue.VBlob := pointer(temp);
+      aValue.VBlobLen := length(temp);
+    end;
 end;
 
 function TSQLPropInfoRTTIDynArray.GetDynArrayElemType: PTypeInfo;
@@ -25886,8 +25891,10 @@ function TSQLTable.GetRowLengths(Field: integer; var LenStore: TSynTempBuffer):
     U: PPUTF8Char;
 begin
   result := 0;
-  if (self=nil) or (cardinal(Field)>cardinal(FieldCount)) or (fRowCount=0) then
+  if (self=nil) or (cardinal(Field)>cardinal(FieldCount)) or (fRowCount=0) then begin
+    LenStore.buf := nil; // avoid GPF in LenStore.Done
     exit;
+  end;
   U := @fResults[FieldCount+Field]; // start reading after first Row (= Field Names)
   len := LenStore.Init(fRowCount*SizeOf(len^));
   for i := 1 to fRowCount do begin
@@ -40552,8 +40559,9 @@ function TSQLRestServerURIContext.Authenticate: boolean;
           aSession := Server.fSessionAuthentication[i].RetrieveSession(self);
           if aSession<>nil then begin
             {$ifdef WITHLOG}
-            Log.Log(sllUserAuth,'%/% %',[aSession.User.LogonName,aSession.ID,
-              aSession.RemoteIP],self);
+            if (aSession.RemoteIP<>'') and (aSession.RemoteIP<>'127.0.0.1') then
+              Log.Log(sllUserAuth,'%/% %',[aSession.User.LogonName,aSession.ID,
+                aSession.RemoteIP],self);
             {$endif}
             result := true;
             exit;
@@ -40755,7 +40763,8 @@ procedure TSQLRestServerURIContext.ExecuteSOAByMethod;
       end;
       Stats.Processing := true;
     end;
-    Server.InternalLog('% %',[Name,Parameters],sllServiceCall);
+    if Parameters<>'' then
+      Server.InternalLog('% %',[Name,Parameters],sllServiceCall);
     CallBack(self);
     if Stats<>nil then begin
       QueryPerformanceCounter(timeEnd);
@@ -40919,8 +40928,9 @@ procedure TSQLRestServerURIContext.InternalExecuteSOAByInterface;
       if [smdVar,smdOut,smdResult]*HasSPIParams<>[] then
         include(ServiceExecutionOptions,optNoLogOutput);
     end;
-    {$ifdef WITHLOG}
-    if sllServiceCall in Log.GenericFamily.Level then
+    {$ifdef WITHLOG} // load method call and parameter values (if worth it)
+    if (sllServiceCall in Log.GenericFamily.Level) and (ServiceParameters<>nil) and
+       (PWord(ServiceParameters)^<>ord('[')+ord(']') shl 8) then
       if optNoLogInput in ServiceExecutionOptions then
         Log.Log(sllServiceCall,'%{}',
           [PServiceMethod(ServiceMethod)^.InterfaceDotMethodName],Server) else
@@ -62465,7 +62475,9 @@ initialization
   {$ifndef USENORMTOUPPER}
   pointer(@SQLFieldTypeComp[sftUTF8Text]) := @AnsiIComp;
   {$endif}
+  {$ifdef MSWINDOWS} // don't change the main process name under Linux
   SetThreadNameDefault(GetCurrentThreadID,'Main Thread');
+  {$endif}
   SetThreadNameInternal := SetThreadNameWithLog;
   StatusCodeToErrorMessage := StatusCodeToErrorMsgBasic;
   GarbageCollectorFreeAndNil(JSONCustomParsers,TSynDictionary.Create(

diff --git a/SQLite3/mORMotSQLite3.pas b/SQLite3/mORMotSQLite3.pas
@@ -466,6 +466,8 @@   TSQLRestServerDB = class(TSQLRestServer)
     /// used e.g. by IAdministratedDaemon to implement "pseudo-SQL" commands
     procedure AdministrationExecute(const DatabaseName,SQL: RawUTF8;
       var result: TServiceCustomAnswer); override;
+    /// retrieves the per-statement detailed timing, as a TDocVariantData
+    procedure ComputeDBStats(out result: variant);
 
     /// initialize the associated DB connection
     // - called by Create and on Backup/Restore just after DB.DBOpen
@@ -1297,6 +1299,24 @@ procedure TSQLRestServerDB.InternalStat(Ctxt: TSQLRestServerURIContext; W: TText
   end;
 end;
 
+procedure TSQLRestServerDB.ComputeDBStats(out result: variant);
+var i: integer;
+    ndx: TIntegerDynArray;
+    doc: TDocVariantData absolute result;
+begin
+  doc.Init(JSON_OPTIONS_FAST_EXTENDED,dvObject);
+  DB.Lock;
+  try
+    fStatementCache.SortCacheByTotalTime(ndx);
+    with fStatementCache do
+    for i := 0 to Count-1 do
+      with Cache[ndx[i]] do
+        doc.AddValue(StatementSQL,Timer.ComputeDetails);
+  finally
+    DB.UnLock;
+  end;
+end;
+
 function TSQLRestServerDB.MainEngineList(const SQL: RawUTF8; ForceAJAX: Boolean;
   ReturnedRowCount: PPtrInt): RawUTF8;
 var MS: TRawByteStringStream;