mORMot Open Source

function TSQLRestServer.Auth(var aParams: TSQLRestServerCallBackParams): Integer;

procedure CreateNewSession(var User: TSQLAuthUser; var aParams: TSQLRestServerCallBackParams);
var Session: TAuthSession;
begin
  Session := TAuthSession.Create(self,User);
  try
    aParams.Resp := JSONEncode(['result',Session.fPrivateSalt,'logonname',User.LogonName]);
    User := nil; // will be freed by TAuthSession.Destroy
    if fSessions=nil then
      fSessions := TObjectList.Create;
    fSessions.Add(Session);
    Session := nil; // will be freed by fSessions
  finally
    Session.Free;
  end;
end;

var aUserName, aPassWord, aClientNonce, aSalt: RawUTF8;
    User: TSQLAuthUser;
    aSessionID: cardinal;
    i: integer;
{$ifdef SSPIAUTH}
    SecCtxId: Cardinal;
    InDataEnc: RawUTF8;
    CtxArr: TDynArray;
    Now: QWord;
    SecCtxIdx: Integer;
    OutData: RawByteString;
{$endif}
begin
  result := HTML_NOTFOUND;
  if not UrlDecodeNeedParameters(aParams.Parameters,'UserName') then
    exit;
  EnterCriticalSection(fSessionCriticalSection);
  try
    if UrlDecodeNeedParameters(aParams.Parameters,'Session') then begin
      // GET ModelRoot/auth?UserName=...&Session=... -> release session
      while aParams.Parameters<>nil do begin
        UrlDecodeValue(aParams.Parameters,'USERNAME=',aUserName);
        UrlDecodeCardinal(aParams.Parameters,'SESSION=',aSessionID,@aParams.Parameters);
      end;
      if (fSessions<>nil) and 
         // allow only to delete its own session - ticket [7723fa7ebd]
         (aSessionID=aParams.Context.Session) then
      for i := 0 to fSessions.Count-1 do
        with TAuthSession(fSessions.List[i]) do
        if fIDCardinal=aSessionID then begin
          SessionDelete(i);
          result := HTML_SUCCESS; // mark success
          break;
        end;
      exit; // unknown session -> error 404
    end else
    if UrlDecodeNeedParameters(aParams.Parameters,'PassWord,ClientNonce') then begin
      // GET ModelRoot/auth?UserName=...&PassWord=...&ClientNonce=... -> handshaking
      while aParams.Parameters<>nil do begin
        UrlDecodeValue(aParams.Parameters,'USERNAME=',aUserName);
        UrlDecodeValue(aParams.Parameters,'PASSWORD=',aPassWord);
        UrlDecodeValue(aParams.Parameters,'CLIENTNONCE=',aClientNonce,@aParams.Parameters);
      end;
      User := TSQLAuthUser.Create(self,'LogonName=?',[aUserName]);
      try
        if User.fID=0 then
          exit; // unknown user -> error 404
        // check if match TSQLRestClientURI.SetUser() algorithm
        aSalt := aClientNonce+User.LogonName+User.PasswordHashHexa;
        if (aPassWord<>SHA256(Model.Root+Nonce(false)+aSalt)) and
           // if didn't try with current nonce, try with previous 5 minutes nonce
           (aPassWord<>SHA256(Model.Root+Nonce(true)+aSalt)) then
          Exit;
        // now client is authenticated -> create a session
        CreateNewSession(User,aParams);
      finally
        User.Free;
      end;
{$ifdef SSPIAUTH}
    end else
    if UrlDecodeNeedParameters(aParams.Parameters,'ID,DATA') then begin
      // GET ModelRoot/auth?UserName=&id=...&data=... -> windows SSPI auth
      while aParams.Parameters<>nil do begin
        UrlDecodeCardinal(aParams.Parameters,'ID=',SecCtxId);
        UrlDecodeValue(aParams.Parameters,'DATA=',InDataEnc,@aParams.Parameters);
      end;
      EnterCriticalSection(fSSPIAuthCriticalSection);
      try
        CtxArr.Init(TypeInfo(TSecContexts), fSSPIAuthContexts);
        // check for outdated auth context
        Now := GetTickCount;
//        for i := High(fSSPIAuthContexts) downto 0 do
//          if (Now>QWord(fSSPIAuthContexts[i].Created)+QWord(30000)) or
//             (fSSPIAuthContexts[i].Created<Int64Rec(Now).Lo) then begin
//            // outdated or 49 days GetTickCount value rollback
//            FreeSecContext(fSSPIAuthContexts[i]);
//            CtxArr.Delete(i);
//          end;
        for i := High(fSSPIAuthContexts) downto 0 do
            if Now < fSSPIAuthContexts[i].Created then // 32 bit overflow occured
              fSSPIAuthContexts[i].Created := Now else
            if Now>QWord(fSSPIAuthContexts[i].Created)+QWord(30000) then begin
            // free outdated context
            FreeSecContext(fSSPIAuthContexts[i]);
            CtxArr.Delete(i);
          end;

        // if no auth context specified, create a new one
        SecCtxIdx := -1;
        if SecCtxId <> 0 then begin
          for i := 0 to High(fSSPIAuthContexts) do
            if fSSPIAuthContexts[i].ID = SecCtxId then begin
              SecCtxIdx := i;
              break;
            end;
          // invalid or outdated id
          if SecCtxIdx<0 then
            exit;
        end;
        if SecCtxIdx<0 then begin
          // 1st call: create SecCtxId 
          if High(fSSPIAuthContexts)>MAXSSPIAUTHCONTEXTS then begin
            {$ifdef WITHLOG}
            SQLite3Log.Family.SynLog.Log(sllUserAuth,
              'Too many Windows Authenticated session in pending state: MAXSSPIAUTHCONTEXTS=%',
              [MAXSSPIAUTHCONTEXTS],self);
            {$endif}
            exit;
          end;
          SecCtxIdx := CtxArr.New; // add a new entry to fSSPIAuthContexts[]
          InvalidateSecContext(fSSPIAuthContexts[SecCtxIdx]);
          fSSPIAuthContexts[SecCtxIdx].ID := fSSPIAuthCounter;
          Inc(fSSPIAuthCounter);
        end;
//        // call SSPI provider
        if ServerSSPIAuth(fSSPIAuthContexts[SecCtxIdx], Base64ToBin(InDataEnc), OutData) then begin
          aParams.Resp := JSONEncode(['result','','id',fSSPIAuthContexts[SecCtxIdx].ID,
            'data',BinToBase64(OutData)]);
          Result := HTML_SUCCESS;
          exit; // 1st call: send back OutData to the client
        end;
        // 2nd call: user was authenticated -> release used context
        ServerSSPIAuthUser(fSSPIAuthContexts[SecCtxIdx], aUserName);
        {$ifdef WITHLOG}
        SQLite3Log.Family.SynLog.Log(sllUserAuth,
          'Windows Authentication success for %',[aUserName],self);
        {$endif}
        FreeSecContext(fSSPIAuthContexts[SecCtxIdx]);
        CtxArr.Delete(SecCtxIdx);
      finally
        LeaveCriticalSection(fSSPIAuthCriticalSection);
      end;
      if aUserName = '' then
        exit;
      // now client is authenticated -> create a session for aUserName
      User := TSQLAuthUser.Create(self,'LogonName=?',[aUserName]);
      try
        if User.fID=0 then
          exit;
        CreateNewSession(User,aParams);
      finally
        User.Free;
      end;
{$endif}
    end else
      // only UserName=... -> return hexadecimal nonce content valid for 5 minutes
      aParams.Resp := JSONEncodeResult([Nonce(false)]);
  finally
    LeaveCriticalSection(fSessionCriticalSection);
  end;
  result := HTML_SUCCESS;
end;

procedure TFrmToolBarMain.FormCreate(Sender: TObject);
begin
....
 resultLogin := ShowLogin(currentClient,GetUserFromWindows); //read user and domain of my pc
.....
end;

function TFrmToolBarMain.ShowLogin(var ADatabase:TSQLRestClientUri;UserName:String;Password:String=''):Boolean;
var
  aUserName,aDomain:string;
begin
   result := false;
   if Assigned(ADatabase.SessionUser) and (sametext(ADatabase.SessionUser.LogonName,UserName)) then
         result := true;
  //read user and domain of my pc
   if not(result) and  GetCurrentUserAndDomain(aUserName,aDomain) then
   begin
      if sametext(UserName,aUserName) then
        result := ADatabase.SetUser('' ,'')
   end;

   if not(result) and  TLoginForm.Login('Accesso','Inserire i dati d''accesso',UserName,Password,true,'') then
   begin
           result := ADatabase.SetUser(UserName ,PassWord);
   end;
end;

...
     // now client is authenticated -> create a session for aUserName
      User := TSQLAuthUser.Create(self,'LogonName=?',[aUserName]);
      try
        if User.fID=0 then
          exit;
        CreateNewSession(User,aParams);
      finally
        User.Free;
      end;

var
  APassword:String;
  AAuthUser:TSQLAuthUser;
begin
   if Assigned(CurrentClient) and  Assigned(CurrentClient.SessionUser) then
   begin
      try
      AAuthUser := TSQLAuthUser.Create(CurrentClient, 'LogonName=?', [CurrentClient.SessionUser.LogonName]);
      if AAuthUser.ID>0 then
      begin
        APassword := Dialogs.InputBox('Change password', 'New password:','');
        if length(trim(APassword))>0 then
        begin

          AAuthUser.PasswordPlain := APassword;
          CurrentClient.Update(AAuthUser);

        end;
      end;
      finally
        AAuthUser.Free;
      end;
   end;
end;

fHandleAuthentication := (fAuthUserIndex>=0) and (fAuthGroupIndex>=0);

  if aHandleUserAuthentication and (not (fAuthUserIndex>=0) and (fAuthGroupIndex>=0)) then begin
    // we need both AuthUser+AuthGroup tables for authentication -> create now
    if fAuthUserIndex<0 then
      aModel.AddTable(TSQLAuthUser,@fAuthUserIndex);
    if fAuthGroupIndex<0 then
      aModel.AddTable(TSQLAuthGroup,@fAuthGroupIndex);
    fHandleAuthentication := true;
  end;

procedure TFrmServerManage.SessionClose(LogonName:RawUTF8;SessionID:cardinal);
var tmp: RawUTF8;
begin
  if (Client<>nil) and (Client.SessionUser<>nil) then begin
    // notify session closed to server
    Client.CallBackGet('auth',['UserName',LogonName,'Session',SessionID],tmp);

  end;
end;

function TSQLRestClientURI.SetUser(const aUserName, aPassword: RawUTF8;
  aHashedPassword: Boolean=false): boolean;
var aNonce, aClientNonce, aSessionKey: RawUTF8;
    i: integer;
    U: TSQLAuthUser;
begin
  result := false;
  if self=nil then
    exit;
  fSessionID := 0;
  fSessionIDHexa8 := '';
  fSessionPrivateKey := 0;
  FreeAndNil(fSessionUser);
  if (self=nil) or (aUserName='') then
    exit;
  U := TSQLAuthUser.Create;
  try
    U.LogonName := trim(aUserName);
    if aHashedPassword then
      U.PasswordHashHexa := aPassword else
      U.PasswordPlain := aPassword; // PasswordHashHexa := SHA256('salt'+aPassword);
    aNonce := CallBackGetResult('auth',['UserName',U.LogonName]);
    if aNonce='' then
      exit;
    aClientNonce := SHA256(NowToString);
    aSessionKey := CallBackGetResult('auth',['UserName',U.LogonName,'Password',
       Sha256(Model.Root+aNonce+aClientNonce+U.LogonName+U.PasswordHashHexa),
       'ClientNonce',aClientNonce]);
    i := PosEx(RawUTF8('+'),aSessionKey,1);
    if i=0 then
      exit; // expect SessionID+HexaSessionPrivateKey
    fSessionID := GetCardinal(pointer(aSessionKey));
    if fSessionID=0 then
      exit;
    fSessionIDHexa8 := CardinalToHex(fSessionID);
    fSessionPrivateKey := crc32(crc32(0,Pointer(aSessionKey),length(aSessionKey)),
      pointer(U.PasswordHashHexa),length(U.PasswordHashHexa));
    fSessionUser := U;
    OnSuccessfulAuthentication(U);
    U := nil;
    result := true;

  finally
    U.Free;

  end;
end;

procedure TFrmToolBarMain.OnSuccessfulAuthentication(AuthUser:TSQLAuthUser);
var
  U : TSQLAuthUser;
begin
  if Assigned(CurrentUser) then currentUser.Free;
  try
     U := TSQLAuthUser.Create(CurrentClient, 'LogonName=:("%"):', [AuthUser.LogonName]);
     CurrentUser := TSQLUser.Create(CurrentClient, 'AuthUserID=:("%"):', [U.ID]);
     if Assigned(CurrentUser) then
     begin
     CurrentUser.AuthUser := U;
     CurrentUser.EnabledManagement := CurrentUser.IsAdmin(CurrentClient);
     CurrentUser.EnabledSupervisor := CurrentUser.IsSupervisor(CurrentClient);
     end;
     SetActions(currentUser,false,nil); //this i setting my main menu
     if Assigned(CurrentClient) then
        Caption:= format('%s - %s',  [format(AppName, [GetVersion(Application.ExeName)]),  CurrentClient.SessionUser.LogonName ])
     else
        Caption:= format(AppName, [GetVersion(Application.ExeName)]);
  finally

  end;
end;

TSQLUser = Class(TSQLFile)
public
AuthUser :TSQLAuthUser //that I use for the connection?
end