mORMot Open Source

Option Explicit

  Dim gSessionIDasHex As String
  Dim gPrivateSaltHash As Long
  Dim gPreviousTix As Long

'Format number as a 4 Byte hex
Private Function To4ByteHex(aNr As Long) As String

  Dim AsHex As String
  
  AsHex = Hex(aNr)
  To4ByteHex = Right("00000000" + AsHex, 8)
End Function

Private Function Authenticate(ByVal aServer, aModel As String, ByVal aUsername, aPassword As String) As Boolean

  Dim MyRequest As WinHttpRequest
  Dim Response As String
  Dim ServerNonce As String
  Dim PasswordHashHexa As String
  Dim SessionPassWordSha256 As String
  Dim ClientNonce As String
  Dim s, i As Integer
  
  Set MyRequest = New WinHttpRequest
    
  gSessionID = 0
  gSessionIDasHex = ""
  gPrivateSaltHash = 0
  
  'First request ServerNonce for username
  MyRequest.Open "GET", aServer + "/" + aModel + "/Auth?username=" + aUsername
  MyRequest.Send
  If MyRequest.Status <> 200 Then
    Debug.Print MyRequest.ResponseText
    Authenticate = False
  Else
    Response = MyRequest.ResponseText
  
    'Authenticate and create session
    ServerNonce = Mid(Response, InStr(Response, ":") + 2, 64)
    ClientNonce = SHA256("TestingCLient")
    PasswordHashHexa = SHA256("salt" + aPassword)
    SessionPassWordSha256 = SHA256(aModel + ServerNonce + ClientNonce + aUsername + PasswordHashHexa)
  
    MyRequest.Open "GET", aServer + "/" + aModel + "/auth?userName=" + aUsername + "&PassWord=" + SessionPassWordSha256 + "&ClientNonce=" + ClientNonce
    MyRequest.Send
    If MyRequest.Status <> 200 Then
      Debug.Print MyRequest.ResponseText
      Authenticate = False
    Else
      s = InStr(MyRequest.ResponseText, ":")
      i = InStr(MyRequest.ResponseText, ",")
      
      'gPrivateSalt is "<SessionID>+<PrivateKey>"
      gPrivateSalt = Mid(MyRequest.ResponseText, s + 2, i - s - 3)
      i = InStr(gPrivateSalt, "+")
      gSessionID = Val(Left(gPrivateSalt, i - 1))
      gSessionIDasHex = To4ByteHex(gSessionID)
      
      gPrivateSaltHash = AddCrc32(PasswordHashHexa, AddCrc32(gPrivateSalt))
      
      Authenticate = True
    End If
  End If
    
End Function

'Construct the signature to add to the url,
Public Function SignUrl(Url As String) As String
  SignUrl = SignUrlEx(Url, gSessionIDasHex, gPrivateSaltHash)
End Function

Public Function SignUrlEx(ByVal Url As String, ByVal SessionIDAsHex As String, ByVal PrivateSaltHash As Long) As String

Dim Sig As String
Dim Tix As Long
Dim Timestamp As String

  Sig = "session_signature=" + SessionIDAsHex
  Tix = Timer * 100
  
  '//Must be larger then prvious request
  If Tix <= gPreviousTix Then
    Tix = gPreviousTix + 1
  End If
  gPreviousTix = Tix
  
  Timestamp = To4ByteHex(Tix)
  Sig = Sig + Timestamp
  
  Sig = Sig + To4ByteHex(GetCrc32(AddCrc32(Url, AddCrc32(Timestamp, PrivateSaltHash))))
    
  If InStr(Url, "?") > 0 Then
    SignUrlEx = Url + "&" + Sig
  Else
    SignUrlEx = Url + "?" + Sig
  End If
  
End Function

Public Sub TestUrl()
  Dim MyRequest As WinHttpRequest
  Dim Response As String
  Dim Server As String
  Dim Model As String
  Dim Url As String
   
  Set MyRequest = New WinHttpRequest
  
  Server = "http://localhost:8080"
  Model = "root"
  
  If Authenticate(Server, Model, "User", "synopse") Then
  
    Url = Model + "/SampleRecord"
    MyRequest.Open "Get", Server + "/" + SignUrl(Url)
    MyRequest.Send
    Debug.Print MyRequest.ResponseText
    
    Url = Model + "/SampleRecord/2"
    MyRequest.Open "Get", Server + "/" + SignUrl(Url)
    MyRequest.Send
    Debug.Print MyRequest.ResponseText
  
  End If
End Sub

GetVariantFromJSON(Val,wasString,Value{$ifndef UNICODE},ForceWideString{$endif});

        Client2 := TSQLRestClientDB.Create(Model,nil,'testpass.db3',TSQLRestServerDB,false,password);
        try
          Client2.Server.DB.Synchronous := smOff;
          Client2.Server.DB.WALMode := true;
          Client2.Server.CreateMissingTables;
          Check(Client2.TransactionBegin(TSQLRecordPeople));
          Check(Client2.BatchStart(TSQLRecordPeople));
          Check(Client2.BatchSend(Res)=200);
          Client2.Commit;
        finally
          Client2.Free;
        end;

  Model.TableProps[0].SQLTableName

  Model.TableProps[0].ExternalTableName

var
  lModel : TLCSServerModel; //Descendant of TSQLModel, nothing new here
  lConnProp: TSQLDBNexusDBConnectionProperties;
begin
  lModel := TLCSServerModel.Create(BASE_MODEL_URI);
  lConnProp := TSQLDBNexusDBConnectionProperties.Create('', '.\ServerDB', '', '');
  VirtualTableExternalRegisterAll(lModel, lConnProp);

  if not lConnProp.DatabaseExists then
    lConnProp.CreateDatabase;

  inherited Create(lModel, 'ServerDB.db3', True);
  CreateMissingTables;

  FServerModel := lModel;
  FServerConnProp := lConnProp;


  FRestServers := TDictionary<RawUTF8,TSQLRestServerDB>.Create;

  FHttpServer := TSQLite3HttpServer.Create(cPort, [Self]);
  ServiceRegister(TLCSServer,[TypeInfo(ILCSServer)],sicShared);

function TLCSServer.OpenDatabase(aConnectionString: RawUTF8; var URI: RawUTF8; aCreate: boolean = false): Boolean;
var
  lConProp: TSQLDBConnectionProperties;
  lRestServerDB: TSQLRestServerDB;
  lModel: TLCSModel;
  iCreateDB: ICanCreateDatabase;
begin
  Result := False;
  if aConnectionString <> '' then
  begin

    //Determine database type and protocol
    lConProp := CreateConnectionProperties(aConnectionString);

    if Supports(lConProp, ICanCreatedatabase, ICreateDB) then
      if not ICreateDB.DatabaseExists then
        if aCreate then
          ICreateDB.CreateDatabase
        else
          Exit;

    if lConProp <> nil then
    begin
      //Create separate TSQLRestSeverDB object for this database

      lModel := TLCSModel.Create(URI);
      VirtualTableExternalRegisterAll(lModel, lConProp);
      lRestServerDB := TLCSRestDB.Create(lModel, UTF8ToString(URI) + '.db3', True);
      lModel.Owner := lRestServerDB; //Make Restserver destroy model

      lRestServerDB.CreateMissingTables;

      //Register the new restServer with the http server, using a new URI, and add it to list of RestServers
      LCSRestServer.RegisterDatabase(lRestServerDB);

      Result := true;
    end;
  end;
end; {- TLCSServer.OpenDatabase }

procedure TLCSServerTest.TestOpenDatabaseAccess;
var
  lDBUri: RawUTF8;
  lWB: TSQLWorkbaseObject;
  lClient :  TSQLite3HttpClient;
  lModel: TLCSModel;
const
  cNewFolder = '..\..\UnitTest\NexusDBServerTest12';
begin
  FModel := TLCSModel.Create(BASE_MODEL_URI);
  FClient := TSQLite3HttpClient.Create('localhost','888',FModel);
  CheckTrue(FClient.SetUser('Admin', 'synopse'), 'Authentication failed');
  FClient.ServiceRegister([TypeInfo(ILCSServer)],sicShared);

  FClient.Services[cLCSServerURI].Get(FLcsInterface);
  CheckNotNull(FLcsInterface, 'LCS Interface not retrieved from server');
  lDBUri := 'TestDB12';
  lClient := nil;
  lModel := nil;
  try
    CheckTrue(FLcsInterface.OpenDatabase(cNewFolder, lDBUri, True));
    lModel := TLCSModel.Create(lDBUri);

    lClient := TSQLite3HttpClient.Create('localhost', '888', lModel);
    CheckTrue(lCLient.SetUser('Admin', 'synopse'));

    lWB := TSQLWorkbaseObject.Create;
    try
      lWB.ID := 0;
      lWB.Name := 'Blabla';
      Check( lClient.Add(lWB, True) > 0, ' Adding workbaseobject failed.');
    finally
      lWB.Free;
    end;

  finally
    Delete_Tree(cNewFolder);
    lClient.Free;
    lModel.Free;
  end;
end;

  Query := fProperties.NewThreadSafeStatementPrepared(SQLFormat,Args,ExpectResults);

type
  ILCSServer = interface(IInvokable)
  ['{D54E257A-A26D-4F69-8998-4D3646137828}']
    {1 open the database as specified in the connectionstring, return if this was succesfull - return the root URI of
        the associated TSQLRestServer in var param URI - aConnectionstring contains all info needed to connect using
        <protocol>://server/name syntax - if aCreate is true than create the database if it doent exist }
    function OpenDatabase(aConnectionString: RawUTF8; var URI: RawUTF8; aCreate: boolean = false): Boolean;
    function CloseDatabase(const aURI: RawUTF8): boolean;
  end;