idsslopenssl.pas

photo.163.com 相册下载器 多线程下载

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

  inherited Close;
end;

procedure TIdSSLIOHandlerSocketOpenSSL.Open;
begin
  inherited Open;
end;

function TIdSSLIOHandlerSocketOpenSSL.Recv(var ABuf : TIdBytes): integer;
begin
  if fPassThrough then begin
   result := Binding.Receive(ABuf);
 //  Recv(ABuf, ALen, 0 );
  end
  else begin
    result := RecvEnc(ABuf);
  end;
end;

function TIdSSLIOHandlerSocketOpenSSL.Send(const ABuf : TIdBytes): integer;
begin
  if fPassThrough then begin
//    result := Binding.Send(ABuf, ALen, 0 );
    result := Binding.Send(ABuf,0);
  end
  else begin
    result := SendEnc(ABuf);
  end;
end;

procedure TIdSSLIOHandlerSocketOpenSSL.SetPassThrough(const Value: Boolean);
begin
  if fPassThrough <> Value then begin
    if not Value then begin
      if BindingAllocated then begin
        if Assigned(fSSLContext) then begin
          OpenEncodedConnection;
        end
        else begin
          raise EIdOSSLCouldNotLoadSSLLibrary.Create(RSOSSLCouldNotLoadSSLLibrary);
        end;
      end;
    end;
    fPassThrough := Value;
  end;
end;

function TIdSSLIOHandlerSocketOpenSSL.RecvEnc(var ABuf : TIdBytes): integer;
begin
  Result := fSSLSocket.Recv(ABuf);
end;

function TIdSSLIOHandlerSocketOpenSSL.SendEnc(const ABuf : TIdBytes): integer;
begin
  Result := fSSLSocket.Send(ABuf);
end;

procedure TIdSSLIOHandlerSocketOpenSSL.AfterAccept;
begin
  try
    inherited AfterAccept;
    StartSSL;
  except
    Close;
    raise;
  end;
end;

procedure TIdSSLIOHandlerSocketOpenSSL.Init;
begin
  if not Assigned(fSSLContext) then 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;
end;

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

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

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

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

procedure TIdSSLIOHandlerSocketOpenSSL.OpenEncodedConnection;
begin
  if FIsPeer then begin
    if not Assigned(fSSLSocket) then begin
      fSSLSocket := TIdSSLSocket.Create(self);
      fSSLSocket.fSSLContext := fSSLContext;
    end;
    fSSLSocket.Accept(Binding.Handle, fSSLContext);
  end else begin
    if not Assigned(fSSLSocket) then begin
      fSSLSocket := TIdSSLSocket.Create(self);
      fSSLSocket.fSSLContext := fSSLContext;
      fSSLSocket.Connect(Binding.Handle, fSSLContext);
    end;
  end;
  fPassThrough := false;
end;

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

procedure TIdSSLIOHandlerSocketOpenSSL.WriteDirect(
  ABuffer: TIdBytes
  );
var
  LBuffer: TIdBytes;
  LBufLen: Integer;
  LCount: Integer;
  LPos: Integer;
begin

  LPos := 0;
  repeat
    LBufLen := Length(ABuffer) - LPos;
    SetLength(LBuffer,LBufLen);
    Move(ABuffer[LPos],LBuffer[0],LBufLen);
      //we have to make sure we call the Intercept for logging
    if Intercept <> nil then begin
      Intercept.Send(LBuffer);
    end;
    LCount := Send(LBuffer);
    // TODO - Have a AntiFreeze param which allows the send to be split up so that process
    // can be called more. Maybe a prop of the connection, MaxSendSize?

    TIdAntiFreezeBase.DoProcess(False);

    FClosedGracefully := LCount = 0;

    // Check if other side disconnected
    CheckForDisconnect;
    //TODO: This relies on STack - make it abstract
    // Check to see if the error signifies disconnection

    if GBSDStack.CheckForSocketError(LCount, [ID_WSAESHUTDOWN, Id_WSAECONNABORTED
     , Id_WSAECONNRESET]) <> 0 then begin
      FClosedGracefully := True;
      Close;
      GBSDStack.RaiseSocketError(GBSDStack.WSGetLastError);
    end;

    DoWork(wmWrite, LCount);
    LPos := LPos + LCount;
  until LPos >= Length(ABuffer);
end;

function TIdSSLIOHandlerSocketOpenSSL.ReadFromSource(
 ARaiseExceptionIfDisconnected: Boolean; ATimeout: Integer;
 ARaiseExceptionOnTimeout: Boolean): Integer;
// Reads any data in tcp/ip buffer and puts it into Indy buffer
// This must be the ONLY raw read from Winsock routine
// This must be the ONLY call to RECV - all data goes thru this method
var
  LByteCount: Integer;
  LBuffer: TIdBytes;
  LLastError: Integer;
begin
  if ATimeout = IdTimeoutDefault then begin
    if ReadTimeOut = 0 then begin
      ATimeout := IdTimeoutInfinite;
    end else begin
      ATimeout := FReadTimeout;
    end;
  end;
  Result := 0;
  // Check here as this side may have closed the socket
  CheckForDisconnect(ARaiseExceptionIfDisconnected);
  if BindingAllocated then begin
    LByteCount := 0;
    repeat
      if Readable(ATimeout) then begin
        if Assigned(FRecvBuffer) then begin
          // No need to call AntiFreeze, the Readable does that.
          if BindingAllocated then begin
            SetLength(LBuffer,RecvBufferSize);
            try
              LByteCount := Recv(LBuffer);
              SetLength(LBuffer,LByteCount);
                if Intercept <> nil then begin
                  Intercept.Receive(LBuffer);
                  LByteCount := Length(LBuffer);
                end;
              FRecvBuffer.Write(LBuffer);
          //    WriteBuffer(LBuffer^,LByteCount);
            finally
              SetLength(LBuffer,0);
            end;
          end else begin
            raise EIdClosedSocket.Create(RSStatusDisconnected);
          end;
        end else begin
          LByteCount := 0;
          if ARaiseExceptionIfDisconnected then
            raise EIdException.Create(RSNotConnected);
        end;
        FClosedGracefully := LByteCount = 0;

        if not ClosedGracefully then begin
          LLastError := GBSDStack.CheckForSocketError(LByteCount, [Id_WSAESHUTDOWN
           , Id_WSAECONNABORTED]);
          if LLastError <> 0 then begin
            LByteCount := 0;
            Close;
            // Do not raise unless all data has been read by the user
            if InputBufferIsEmpty then begin
              GBSDStack.RaiseSocketError(LLastError);
            end;
          end;

          // InputBuffer.Size is modified above
          if LByteCount > 0 then begin

{            if Assigned(Intercept) then begin
              IOHandler.RecvBuffer.Position := 0;
              Intercept.Receive(IOHandler.RecvBuffer);
              LByteCount := IOHandler.RecvBuffer.Size;
            end;  }
//AsciiFilter - needs to go in TIdIOHandler
//            if ASCIIFilter then begin
//              for i := 1 to IOHandler.RecvBuffer.Size do begin
//                PChar(IOHandler.RecvBuffer.Memory)[i] := Chr(Ord(PChar(IOHandler.RecvBuffer.Memory)[i]) and $7F);
//              end;
//            end;
            FRecvBuffer.ExtractToIdBuffer(FInputBuffer,-1);
          end;
        end;
        // Check here as other side may have closed connection
        CheckForDisconnect(ARaiseExceptionIfDisconnected);
        Result := LByteCount;
      end else begin
        // Timeout
        if ARaiseExceptionOnTimeout then begin
          raise EIdReadTimeout.Create(RSReadTimeout);
        end;
        Result := -1;
        Break;
      end;
    until (LByteCount <> 0) or (Connected = False);
  end else begin
    if ARaiseExceptionIfDisconnected then begin
      raise EIdException.Create(RSNotConnected);
    end;
  end;
end;

function TIdSSLIOHandlerSocketOpenSSL.Clone: TIdSSLIOHandlerSocketBase;
var LIO : TIdSSLIOHandlerSocketOpenSSL;
begin
  LIO := TIdSSLIOHandlerSocketOpenSSL.Create(nil);
  LIO.SSLOptions.Assign( SSLOptions );
  LIO.OnStatusInfo := OnStatusInfo;
  LIO.OnGetPassword := OnGetPassword;
  LIO.OnVerifyPeer := OnVerifyPeer;
  Result := LIO;
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    {Do not Localize}
    if not LoadRootCert then begin
      raise EIdOSSLLoadingRootCertError.Create(RSSSLLoadingRootCertError);
    end;
  end;

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

  if KeyFile <> '' then begin    {Do not Localize}
    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    {Do not Localize}
    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    {Do not Localize}
    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);
  Result:=True;
End;
}
function TIdSSLContext.SetSSLMethod: PSSL_METHOD;
begin
  if fMode = sslmUnassigned then begin
  	raise EIdOSSLModeNotSet.create(RSOSSLModeNotSet);
  end;
  case fMethod of
    sslvSSLv2: