idsslopenssl.pas

ssl implementation（delphi）

    except
    end;
    if VerifiedOK and (Ok > 0) then begin
      Result := 1;
    end
    else begin
      Result := 0;
    end;

  //  Result := Ok; // testing
  finally
    LockVerifyCB.Leave;
  end;
end;

//////////////////////////////////////////////////////
//   TIdSSLOptions
///////////////////////////////////////////////////////

procedure TIdSSLOptions.AssignTo(ASource: TPersistent);
begin
  if ASource is TIdSSLOptions then
    with TIdSSLOptions(ASource) do begin
      RootCertFile := Self.RootCertFile;
      CertFile := Self.CertFile;
      KeyFile := Self.KeyFile;
      Method := Self.Method;
      Mode := Self.Mode;
      VerifyMode := Self.VerifyMode;
      VerifyDepth := Self.VerifyDepth;
      VerifyDirs := Self.VerifyDirs;
      CipherList := Self.CipherList;
    end
  else
    inherited AssignTo(ASource);
end;

///////////////////////////////////////////////////////
//   TIdServerIOHandlerSSL
///////////////////////////////////////////////////////

{ TIdServerIOHandlerSSL }

constructor TIdServerIOHandlerSSL.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  fIsInitialized := False;
  fxSSLOptions := TIdSSLOptions.Create;
end;

destructor TIdServerIOHandlerSSL.Destroy;
begin
  if fSSLContext <> nil then begin
    FreeAndNil(fSSLContext);
  end;

  fxSSLOptions.Destroy;
  inherited Destroy;
end;

procedure TIdServerIOHandlerSSL.Init;
begin
  // CreateSSLContext(SSLOptions.fMode);
  // CreateSSLContext;
  fSSLContext := TIdSSLContext.Create;
  with fSSLContext do begin
    Parent := self;
    RootCertFile := SSLOptions.RootCertFile;
    CertFile := SSLOptions.CertFile;
    KeyFile := SSLOptions.KeyFile;

    fVerifyDepth := SSLOptions.fVerifyDepth;
    fVerifyMode := SSLOptions.fVerifyMode;
    // fVerifyFile := SSLOptions.fVerifyFile;
    fVerifyDirs := SSLOptions.fVerifyDirs;
    fCipherList := SSLOptions.fCipherList;

    if Assigned(fOnVerifyPeer) then begin
      VerifyOn := True;
    end
    else begin
      VerifyOn := False;
    end;

    if Assigned(fOnStatusInfo) then begin
      StatusInfoOn := True;
    end
    else begin
      StatusInfoOn := False;
    end;

    {if Assigned(fOnGetPassword) then begin
      PasswordRoutineOn := True;
    end
    else begin
      PasswordRoutineOn := False;
    end;}

    fMethod :=  SSLOptions.Method;
    fMode := SSLOptions.Mode;
    fSSLContext.InitContext(sslCtxServer);
  end;

  fIsInitialized := True;
end;

function TIdServerIOHandlerSSL.Accept(ASocket: TIdStackSocketHandle): TIdIOHandler;
var
  tmpIdCIOpenSSL: TIdSSLIOHandlerSocket;
begin
  if not fIsInitialized then begin
    Init;
  end;

  tmpIdCIOpenSSL := TIdSSLIOHandlerSocket.Create(self);
  tmpIdCIOpenSSL.fIsPeer := True;
  tmpIdCIOpenSSL.Open;
  if tmpIdCIOpenSSL.Binding.Accept(ASocket) then begin
    tmpIdCIOpenSSL.fxSSLOptions := fxSSLOptions;
    tmpIdCIOpenSSL.fSSLSocket := TIdSSLSocket.Create(self);
    tmpIdCIOpenSSL.fSSLContext := fSSLContext;
    result := tmpIdCIOpenSSL;
  end
  else begin
    result := nil;
    FreeAndNil(tmpIdCIOpenSSL);
  end;
end;

procedure TIdServerIOHandlerSSL.DoStatusInfo(Msg: String);
begin
  if Assigned(fOnStatusInfo) then
    fOnStatusInfo(Msg);
end;

procedure TIdServerIOHandlerSSL.DoGetPassword(var Password: String);
begin
  if Assigned(fOnGetPassword) then
    fOnGetPassword(Password);
end;

function TIdServerIOHandlerSSL.DoVerifyPeer(Certificate: TIdX509): Boolean;
begin
  Result := True;
  if Assigned(fOnVerifyPeer) then
    Result := fOnVerifyPeer(Certificate);
end;

///////////////////////////////////////////////////////
//   TIdSSLIOHandlerSocket
///////////////////////////////////////////////////////

{ TIdSSLIOHandlerSocket }

constructor TIdSSLIOHandlerSocket.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  fIsPeer := False;
  fxSSLOptions := TIdSSLOptions.Create;
  fSSLLayerClosed := True;
end;

destructor TIdSSLIOHandlerSocket.Destroy;
begin
  FreeAndNil(fSSLSocket);
  // FreeAndNil(fSSLContext);
  if not fIsPeer then begin
    FreeAndNil(fSSLContext);
    fxSSLOptions.Destroy;
  end;
  inherited Destroy;
end;

procedure TIdSSLIOHandlerSocket.ConnectClient(const AHost: string; const APort: Integer; const ABoundIP: string;
     const ABoundPort: Integer; const ABoundPortMin: Integer; const ABoundPortMax: Integer;
     const ATimeout: Integer = IdTimeoutDefault);
begin
  inherited ConnectClient(AHost, APort, ABoundIP, ABoundPort, ABoundPortMin, ABoundPortMax, ATimeout);

  DoBeforeConnect(self);

  // CreateSSLContext(sslmClient);
  // CreateSSLContext(SSLOptions.fMode);

  Init;

  if not PassThrough then begin
    OpenEncodedConnection;
  end;
end;

procedure TIdSSLIOHandlerSocket.Close;
begin
  FreeAndNil(fSSLSocket);
  if not fIsPeer then begin
    FreeAndNil(fSSLContext);
  end;

  inherited Close;
end;

procedure TIdSSLIOHandlerSocket.Open;
begin
  inherited Open;
end;

function TIdSSLIOHandlerSocket.Recv(var ABuf; ALen: integer): integer;
begin
  if fPassThrough then begin
    result := inherited Recv(ABuf, ALen);
  end
  else begin
    result := RecvEnc(ABuf, ALen);
  end;
end;

function TIdSSLIOHandlerSocket.Send(var ABuf; ALen: integer): integer;
begin
  if fPassThrough then begin
    result := inherited Send(ABuf, ALen);
  end
  else begin
    result := SendEnc(ABuf, ALen);
  end;
end;

procedure TIdSSLIOHandlerSocket.SetPassThrough(const Value: Boolean);
begin
  if not Value then
  begin
    if Connected then begin
      OpenEncodedConnection;
    end;
  end;
  fPassThrough := Value;
end;

function TIdSSLIOHandlerSocket.RecvEnc(var ABuf; ALen: integer): integer;
begin
  Result := fSSLSocket.Recv(ABuf, ALen);
end;

function TIdSSLIOHandlerSocket.SendEnc(var ABuf; ALen: integer): integer;
begin
  Result := fSSLSocket.Send(ABuf, ALen);
end;

procedure TIdSSLIOHandlerSocket.AfterAccept;
begin
  try
    inherited AfterAccept;
    fSSLSocket.Accept(Binding.Handle, fSSLContext);
  except
    Close;
    raise;
  end;
end;

procedure TIdSSLIOHandlerSocket.Init;
begin
  fSSLContext := TIdSSLContext.Create;
  with fSSLContext do begin
    Parent := self;
    RootCertFile := SSLOptions.RootCertFile;
    CertFile := SSLOptions.CertFile;
    KeyFile := SSLOptions.KeyFile;

    fVerifyDepth := SSLOptions.fVerifyDepth;
    fVerifyMode := SSLOptions.fVerifyMode;
    // fVerifyFile := SSLOptions.fVerifyFile;
    fVerifyDirs := SSLOptions.fVerifyDirs;
    fCipherList := SSLOptions.fCipherList;

    if Assigned(fOnVerifyPeer) then begin
      VerifyOn := True;
    end
    else begin
      VerifyOn := False;
    end;

    if Assigned(fOnStatusInfo) then begin
      StatusInfoOn := True;
    end
    else begin
      StatusInfoOn := False;
    end;

    {if Assigned(fOnGetPassword) then begin
      PasswordRoutineOn := True;
    end
    else begin
      PasswordRoutineOn := False;
    end;}


    fMethod :=  SSLOptions.Method;
    fMode := SSLOptions.Mode;
    fSSLContext.InitContext(sslCtxClient);
  end;


  {fSSLContext := TIdSSLContext.Create;
  with fSSLContext do begin
    Parent := self;
    RootCertFile := SSLOptions.RootCertFile;
    CertFile := SSLOptions.CertFile;
    KeyFile := SSLOptions.KeyFile;

    if Assigned(fOnStatusInfo) then begin
      StatusInfoOn := True;
    end
    else begin
      StatusInfoOn := False;
    end;

    if Assigned(fOnVerifyPeer) then begin
      VerifyOn := True;
    end
    else begin
      VerifyOn := False;
    end;

    // Must set mode after above props are set
    Method :=  SSLOptions.Method;
    Mode := axMode;
  end;}
end;

//}
{function TIdSSLIOHandlerSocket.GetPeerCert: TIdX509;
begin
  if fSSLContext <> nil then begin
    Result := fSSLSocket.PeerCert;
  end
  else begin
    Result := nil;
  end;
end;}

procedure TIdSSLIOHandlerSocket.DoStatusInfo(Msg: String);
begin
  if Assigned(fOnStatusInfo) then
    fOnStatusInfo(Msg);
end;

procedure TIdSSLIOHandlerSocket.DoGetPassword(var Password: String);
begin
  if Assigned(fOnGetPassword) then
    fOnGetPassword(Password);
end;

function TIdSSLIOHandlerSocket.DoVerifyPeer(Certificate: TIdX509): Boolean;
begin
  Result := True;
  if Assigned(fOnVerifyPeer) then
    Result := fOnVerifyPeer(Certificate);
end;

procedure TIdSSLIOHandlerSocket.OpenEncodedConnection;
begin
  if not Assigned(fSSLSocket) then
  begin
    fSSLSocket := TIdSSLSocket.Create(self);
    fSSLSocket.fSSLContext := fSSLContext;
    fSSLSocket.Connect(Binding.Handle, fSSLContext);
  end;
end;

procedure TIdSSLIOHandlerSocket.DoBeforeConnect(ASender: TIdSSLIOHandlerSocket);
begin
  if Assigned(OnBeforeConnect) then begin
    OnBeforeConnect(Self);
  end;
end;

{ TIdSSLContext }

constructor TIdSSLContext.Create;
begin
  inherited Create;

  if DLLLoadCount <= 0 then begin
  	if not IdSSLOpenSSL.LoadOpenSLLibrary then begin
    	raise EIdOSSLCouldNotLoadSSLLibrary.Create(RSOSSLCouldNotLoadSSLLibrary);
    end;
  end;
  Inc(DLLLoadCount);

  fVerifyMode := [];
  fMode := sslmUnassigned;
  fSessionId := 1;
end;

destructor TIdSSLContext.Destroy;
begin
  DestroyContext;
  inherited Destroy;
end;

procedure TIdSSLContext.DestroyContext;
begin
  if fContext <> nil then begin
    IdSslCtxFree(fContext);
    fContext := nil;
  end;
end;

procedure TIdSSLContext.InitContext(CtxMode: TIdSSLCtxMode);
var
  SSLMethod: PSSL_METHOD;
  error: Integer;
  pCipherList, pRootCertFile: PChar;
//  pCAname: PSTACK_X509_NAME;
begin
  // Destroy the context first
  DestroyContext;

  if fMode = sslmUnassigned then begin
    if CtxMode = sslCtxServer then begin
      fMode := sslmServer;
    end
    else begin
      fMode := sslmClient;
    end
  end;

  // get SSL method function (SSL2, SSL23, SSL3, TLS)
  SSLMethod := SetSSLMethod;

  // create new SSL context
  fContext := IdSslCtxNew(SSLMethod);
  if fContext = nil then begin
    raise EIdOSSLCreatingContextError.Create(RSSSLCreatingContextError);
  end;

  // assign a password lookup routine
//  if PasswordRoutineOn then begin
    IdSslCtxSetDefaultPasswdCb(fContext, @PasswordCallback);
    IdSslCtxSetDefaultPasswdCbUserdata(fContext, self);
//  end;

  IdSSLCtxSetDefaultVerifyPaths(fContext);

  // load key and certificate files
  if RootCertFile <> '' then begin
    if not LoadRootCert then begin
      raise EIdOSSLLoadingRootCertError.Create(RSSSLLoadingRootCertError);
    end;
  end;

  if CertFile <> '' then begin
    if not LoadCert then begin
      raise EIdOSSLLoadingCertError.Create(RSSSLLoadingCertError);
    end;
  end;

  if KeyFile <> '' then begin
    if not LoadKey then begin
      raise EIdOSSLLoadingKeyError.Create(RSSSLLoadingKeyError);
    end;
  end;

  if StatusInfoOn then begin
    IdSslCtxSetInfoCallback(fContext, PFunction(@InfoCallback));
  end;

//    f_SSL_CTX_set_tmp_rsa_callback(hSSLContext, @RSACallback);

  if fCipherList <> '' then begin
    pCipherList := StrNew(PChar(fCipherList));
    error := IdSslCtxSetCipherList(fContext, pCipherList);
    StrDispose(pCipherList);
  end
  else begin
    error := IdSslCtxSetCipherList(fContext, OPENSSL_SSL_DEFAULT_CIPHER_LIST);
  end;
  if error <= 0 then begin
    raise EIdOSSLSettingCipherError.Create(RSSSLSettingCipherError);
  end;

  if fVerifyMode <> [] then begin
    SetVerifyMode(fVerifyMode, VerifyOn);
  end;

  if CtxMode = sslCtxServer then begin
    IdSSLCtxSetSessionIdContext(fContext, PChar(@fSessionId), SizeOf(fSessionId));
  end;

  // CA list
  if RootCertFile <> '' then begin
    pRootCertFile := StrNew(PChar(RootCertFile));
    IdSSLCtxSetClientCAList(fContext, IdSSLLoadClientCAFile(pRootCertFile));
    StrDispose(pRootCertFile);
  end

end;

procedure TIdSSLContext.SetVerifyMode(Mode: TIdSSLVerifyModeSet; CheckRoutine: Boolean);
begin
  if fContext<>nil then begin
//    IdSSLCtxSetDefaultVerifyPaths(fContext);
    if CheckRoutine then begin
      IdSslCtxSetVerify(fContext, TranslateInternalVerifyToSLL(Mode), PFunction(@VerifyCallback));
    end
    else begin
      IdSslCtxSetVerify(fContext, TranslateInternalVerifyToSLL(Mode), nil);
    end;
    IdSslCtxSetVerifyDepth(fContext, fVerifyDepth);
  end;
end;

function TIdSSLContext.GetVerifyMode: TIdSSLVerifyModeSet;
begin
  Result := fVerifyMode;
end;
{
function TIdSSLContext.LoadVerifyLocations(FileName: String; Dirs: String): Boolean;
var
  pFileName, pDirs : PChar;
begin
  Result := False;

  pFileName := nil;
  pDirs := nil;
  if FileName <> '' then begin
    pFileName := StrNew(PChar(FileName));
  end;
  if Dirs <> '' then begin
    pDirs := StrNew(PChar(Dirs));
  end;

  If (pDirs<>nil) or (pFileName<>nil) Then begin
    If IdSslCtxLoadVerifyLocations(fContext, pFileName, pDirs)<=0 Then Begin
      raise EIdOSSLCouldNotLoadSSLLibrary.Create(RSOSSLCouldNotLoadSSLLibrary);
      exit;
    End;
  end;
  StrDispose(pFileName);
  StrDispose(pDirs);