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