paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-09-05 05:13:25 +02:00
Code Issues Packages Projects Releases Wiki Activity

* Fix errors, download now works

Browse Source 
git-svn-id: trunk@40786 -
This commit is contained in:
michael 2019-01-06 16:39:45 +00:00
parent b2b34338e5
commit 8d4102a927
1 changed files with 69 additions and 32 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

101
packages/gnutls/examples/httpget.pp
View File

@ -1,16 +1,22 @@
program httpget;
{$mode objfpc}
{$h+}
uses ssockets, gnutls;
uses sysutils, ssockets, gnutls, uriparser;
Const
MAX_BUF = 1024*256;
MSG = 'GET / HTTP/1.0'#13#10#13#10;
logLevel = 0; // Set to positive value to enable logging.
// Correct this for your system.
DefaultCerts : PChar = '/etc/ssl/certs/ca-certificates.crt';
MAX_BUF = 1024*256;
MSG = 'GET %s HTTP/1.0'#13#10'Host: %s'#13#10#13#10;
Procedure MyLogFunc(level : longint; msg : PChar); cdecl;
begin
writeln('Log[',Level:2,']: ',msg);
writeln(StdErr,'Log[',Level:2,']: ',msg);
end;
Var
@ -20,14 +26,30 @@ Var
buf : Array[0..MAX_BUF] of char;
cred : tgnutls_certificate_credentials_t;
errptr,desc : pchar;
S : String;
HostName : String;
FN, URL,S, HostName : String;
port : word;
uri : TURI;
begin
hostname:='www.freepascal.org';
// hostname:='www.google.be';
port:=443;
if paramCount<1 then
begin
writeln('Usage : ',ExtractFileName(ParamStr(0)),' url');
Halt(1);
end;
url:=ParamStr(1);
uri:=ParseURI(URL,'https',443);
hostname:=uri.Host;
if uri.Protocol<>'https' then
begin
Writeln('Only https supported');
Halt(1);
end;
Port:=URI.Port;
FN:=uri.Path+URI.Document;
if (URI.Params<>'') then
FN:=FN+'?'+URI.Params;
if FN='' then FN:='/';
LoadGNutls();
gnutls_global_init();
ret := gnutls_certificate_allocate_credentials (@cred);
@ -48,12 +70,15 @@ begin
gnutls_strerror(ret));
halt(1);
end;
gnutls_global_set_log_function(@MyLogFunc);
gnutls_global_set_log_level(5);
if (logLevel>0) then
begin
gnutls_global_set_log_function(@MyLogFunc);
gnutls_global_set_log_level(logLevel);
end;
gnutls_init(@session, GNUTLS_CLIENT);
// gnutls_priority_set_direct(session,'PERFORMANCE:+ANON-ECDH:+ANON-DH',Nil);
ret:=gnutls_set_default_priority(session);
// ret := gnutls_priority_set_direct(session, 'SECURE256', @errptr);
// ret:=gnutls_set_default_priority(session);
ret := gnutls_priority_set_direct(session, 'NORMAL', @errptr);
if (ret <> GNUTLS_E_SUCCESS) then
begin
writeln(stderr, 'error: gnutls_priority_set_direct: ',gnutls_strerror(ret) , ' error: at: ', errptr);
@ -70,6 +95,7 @@ begin
Sock:=TINetSocket.Create(HostName,Port);
gnutls_transport_set_int(session, Sock.Handle);
gnutls_handshake_set_timeout(session,GNUTLS_DEFAULT_HANDSHAKE_TIMEOUT);
ret := gnutls_server_name_set(session, GNUTLS_NAME_DNS,pchar(HostName), length(HostName));
if (ret <> GNUTLS_E_SUCCESS) then
begin
@ -81,7 +107,14 @@ begin
Repeat
ret:=gnutls_handshake(session);
until (ret>0) or (gnutls_error_is_fatal(ret) <> 0);
if Ret<>GNUTLS_E_SUCCESS then
Case ret of
GNUTLS_E_AGAIN : Writeln(StdErr,'Handshake again');
GNUTLS_E_INTERRUPTED : Writeln(StdErr,'Handshake interrupted');
else
Writeln(StdErr,'Error ',ret,' received, fatal : ',gnutls_error_is_fatal(ret));
end;
until (ret>=0) or (gnutls_error_is_fatal(ret) <> 0);
if (ret < 0) then
begin
writeln(stderr, '*** Handshake failed');
@ -90,25 +123,29 @@ begin
else
begin
desc := gnutls_session_get_desc(session);
writeln('- Session info: ', desc);
writeln(StdErr,'- Session info: ', desc);
// gnutls_free(desc);
end;
gnutls_record_send(session, @MSG[1], length(MSG));
ret := gnutls_record_recv(session, @buf, MAX_BUF);
if (ret=0) then
writeln('- Peer has closed the TLS connection\n')
else if ((ret < 0) and (gnutls_error_is_fatal(ret) = 0)) then
writeln(stderr, '*** Warning: ', gnutls_strerror(ret))
else if (ret < 0) then
Writeln(stderr, '*** Error: ', gnutls_strerror(ret))
else if (ret > 0) then
begin
writeln('- Received %d bytes: ', ret);
SetLength(S,Ret);
Move(Buf[0],S[1],Ret);
Writeln(S);
gnutls_bye(session, GNUTLS_SHUT_RDWR);
end;
S:=Format(Msg,[FN,HostName]);
Writeln(StdErr,'Sending request : ',S);
gnutls_record_send(session, Pchar(S), length(S));
repeat
ret := gnutls_record_recv(session, @buf, MAX_BUF);
if (ret=0) then
writeln(StdErr,'- Peer has closed the TLS connection\n')
else if ((ret < 0) and (gnutls_error_is_fatal(ret) = 0)) then
writeln(stderr, '*** Warning: ', gnutls_strerror(ret))
else if (ret < 0) then
Writeln(stderr, '*** Error: ', ret, ' : ',gnutls_strerror(ret), ' ',(ret=GNUTLS_E_INTERRUPTED) or (Ret=GNUTLS_E_AGAIN))
else if (ret > 0) then
begin
writeln(StdErr,'- Received ',ret,' bytes: ');
SetLength(S,Ret);
Move(Buf[0],S[1],Ret);
Writeln(S);
end;
until (ret<=0) and Not ((ret=GNUTLS_E_INTERRUPTED) or (Ret=GNUTLS_E_AGAIN));
gnutls_bye(session, GNUTLS_SHUT_RDWR);
Sock.Free;
gnutls_deinit(session);
gnutls_certificate_free_credentials(cred);