synhttp/ssl_libssh2.pas

{==============================================================================|
| Project : Ararat Synapse                                       | 001.000.000 |
|==============================================================================|
| Content: SSH support by LibSSH2                                              |
|==============================================================================|
| Copyright (c)1999-2013, Lukas Gebauer                                        |
| All rights reserved.                                                         |
|                                                                              |
| Redistribution and use in source and binary forms, with or without           |
| modification, are permitted provided that the following conditions are met:  |
|                                                                              |
| Redistributions of source code must retain the above copyright notice, this  |
| list of conditions and the following disclaimer.                             |
|                                                                              |
| Redistributions in binary form must reproduce the above copyright notice,    |
| this list of conditions and the following disclaimer in the documentation    |
| and/or other materials provided with the distribution.                       |
|                                                                              |
| Neither the name of Lukas Gebauer nor the names of its contributors may      |
| be used to endorse or promote products derived from this software without    |
| specific prior written permission.                                           |
|                                                                              |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"  |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE    |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE   |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR  |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL       |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR   |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER   |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT           |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY    |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH  |
| DAMAGE.                                                                      |
|==============================================================================|
| The Initial Developer of the Original Code is Alexey Suhinin.                |
| Portions created by Alexey Suhinin are Copyright (c)2012-2013.                |
| Portions created by Lukas Gebauer are Copyright (c)2013-2013.                |
| All Rights Reserved.                                                         |
|==============================================================================|
| Contributor(s):                                                              |
|==============================================================================|
| History: see HISTORY.HTM from distribution package                           |
|          (Found at URL: http://www.ararat.cz/synapse/)                       |
|==============================================================================}

//requires LibSSH2 libraries! http://libssh2.org

{:@abstract(SSH plugin for LibSSH2)

Requires libssh2.dll or libssh2.so. 
You can download binaries as part of the CURL project from 
http://curl.haxx.se/download.html

You need Pascal bindings for the library too! You can find one at:
 http://www.lazarus.freepascal.org/index.php/topic,15935.msg86465.html#msg86465

This plugin implements the client part only.
}

{$IFDEF FPC}
  {$MODE DELPHI}
{$ENDIF}
{$H+}

unit ssl_libssh2;

interface
 
uses
  SysUtils,
  blcksock, synsock,
  libssh2;
 
type
  {:@abstract(class implementing LibSSH2 SSH plugin.)
   Instance of this class will be created for each @link(TTCPBlockSocket).
   You not need to create instance of this class, all is done by Synapse itself!}
  TSSLLibSSH2 = class(TCustomSSL)
  protected
    FSession: PLIBSSH2_SESSION;
    FChannel: PLIBSSH2_CHANNEL;
    function SSHCheck(Value: integer): Boolean;
    function DeInit: Boolean;
  public
    {:See @inherited}
    constructor Create(const Value: TTCPBlockSocket); override;
    destructor Destroy; override;
    {:See @inherited}
    function LibVersion: String; override;
    {:See @inherited}
    function LibName: String; override;
    {:See @inherited}
    function Connect: boolean; override;
    {:See @inherited}
    function Shutdown: boolean; override;
    {:See @inherited}
    function BiShutdown: boolean; override;
    {:See @inherited}
    function SendBuffer(Buffer: TMemory; Len: Integer): Integer; override;
    {:See @inherited}
    function RecvBuffer(Buffer: TMemory; Len: Integer): Integer; override;
    {:See @inherited}
    function WaitingData: Integer; override;
    {:See @inherited}
    function GetSSLVersion: string; override;
  published
  end;
 
implementation
 
{==============================================================================}
function TSSLLibSSH2.SSHCheck(Value: integer): Boolean;
var
  PLastError: PAnsiChar;
  ErrMsgLen: Integer;
begin
  Result := true;
  FLastError := 0;
  FLastErrorDesc := '';
  if Value<0 then
  begin
    FLastError := libssh2_session_last_error(FSession, PLastError, ErrMsglen, 0);
    FLastErrorDesc := PLastError;
    Result := false;
  end;
end;
 
 
function TSSLLibSSH2.DeInit: Boolean;
begin
  if Assigned(FChannel) then
  begin
    libssh2_channel_free(FChannel);
    FChannel := nil;
  end;
  if Assigned(FSession) then
  begin
    libssh2_session_disconnect(FSession,'Goodbye');
    libssh2_session_free(FSession);
    FSession := nil;
  end;
  FSSLEnabled := False;
  Result := true;
end;
 
constructor TSSLLibSSH2.Create(const Value: TTCPBlockSocket);
begin
  inherited Create(Value);
  FSession := nil;
  FChannel := nil;
end;
 
destructor TSSLLibSSH2.Destroy;
begin
  DeInit;
  inherited Destroy;
end;
 
function TSSLLibSSH2.Connect: boolean;
begin
  Result := False;
  if SSLEnabled then DeInit;
  if (FSocket.Socket <> INVALID_SOCKET) and (FSocket.SSL.SSLType = LT_SSHv2) then
    begin
      FSession := libssh2_session_init();
      if not Assigned(FSession) then
      begin
        FLastError := -999;
        FLastErrorDesc := 'Cannot initialize SSH session';
        exit;
      end;
      if not SSHCheck(libssh2_session_startup(FSession, FSocket.Socket)) then
        exit;
      // Attempt private key authentication, then fall back to username/password but
      // do not forget original private key auth error. This avoids giving spurious errors like
      // Authentication failed (username/password)
      // instead of e.g.
      // Unable to extract public key from private key file: Method unimplemented in libgcrypt backend
      if FSocket.SSL.PrivateKeyFile<>'' then
        if (not SSHCheck(libssh2_userauth_publickey_fromfile(FSession, PChar(FSocket.SSL.Username), nil, PChar(FSocket.SSL.PrivateKeyFile), PChar(FSocket.SSL.KeyPassword))))
          and (libssh2_userauth_password(FSession, PChar(FSocket.SSL.Username), PChar(FSocket.SSL.Password))<0) then
            exit;
      FChannel := libssh2_channel_open_session(FSession);
      if not assigned(FChannel) then
      begin
//        SSHCheck(-1);
        FLastError:=-999;
        FLastErrorDesc := 'Cannot open session';
        exit;
      end;
      if not SSHCheck(libssh2_channel_request_pty(FChannel, 'vanilla')) then
        exit;
      if not SSHCheck(libssh2_channel_shell(FChannel)) then
        exit;
      FSSLEnabled := True;
      Result := True;
    end;
end;

function TSSLLibSSH2.LibName: String;
begin
  Result := 'ssl_libssh2';
end;
 
function TSSLLibSSH2.Shutdown: boolean;
begin
  Result := DeInit;
end;
 
 
function TSSLLibSSH2.BiShutdown: boolean;
begin
  Result := DeInit;
end;
 
function TSSLLibSSH2.SendBuffer(Buffer: TMemory; Len: Integer): Integer;
begin
  Result:=libssh2_channel_write(FChannel, PAnsiChar(Buffer), Len);
  SSHCheck(Result);
end;

function TSSLLibSSH2.RecvBuffer(Buffer: TMemory; Len: Integer): Integer;
begin
  result:=libssh2_channel_read(FChannel, PAnsiChar(Buffer), Len);
  SSHCheck(Result);
end;
 
function TSSLLibSSH2.WaitingData: Integer;
begin
  if libssh2_poll_channel_read(FChannel, Result) <> 1 then
    Result := 0;
end;
 
function TSSLLibSSH2.GetSSLVersion: string;
begin
  Result := 'SSH2';
end;

function TSSLLibSSH2.LibVersion: String;
begin
  Result := libssh2_version(0);
end;

initialization
  if libssh2_init(0)=0 then
    SSLImplementation := TSSLLibSSH2;
 
finalization
  libssh2_exit;
 
end.