TCP/IP (四）

(*@///0000000501*)
(*@/// destructor t_fingerd.Destroy; *)
destructor t_fingerd.Destroy;
begin
  f_answer.Free;
  inherited destroy;
  end;
(*@///0000000301*)
(*@/// procedure t_fingerd.do_action; *)
procedure t_fingerd.do_action;
var
  i: integer;
  temp_socket: TSocket;
  finger_info:TFingerInfo;
  sockinfo: TSockAddr;
  s: string;
begin
  temp_socket:=f_socket;
  self.f_socket:=accept_socket_in(f_socket,sockinfo);
  f_eof:=false;
  finger_info.address:=longint(sockinfo.Sin_addr);
  s:=self.read_line(f_socket);
  finger_info.request:=s;
  finger_info.hostname:='';   (* NYI !!! *)
  if assigned(f_fingerrequest) then
    f_fingerrequest(self,finger_info);
  for i:=0 to f_answer.count-1 do begin
    self.write_s(f_socket,f_answer.strings[i]+#13#10);
    end;
  close_socket_linger(f_socket);
  f_socket:=temp_socket;
  end;
(*@///000000131B*)
(*@/// procedure t_fingerd.SetAnswer(Value: TStringList); *)
procedure t_fingerd.SetAnswer(Value: TStringList);
begin
  if value=NIL then
    f_answer.clear
  else
    f_answer.assign(value);
  end;
(*@///0000000603*)
(*@/// procedure t_fingerd.WndProc(var Msg : TMessage); *)
procedure t_fingerd.WndProc(var Msg : TMessage);
begin
  if msg.msg<>uwm_socketevent then
    inherited wndproc(msg)
  else begin
    if msg.lparamhi=socket_error then
    else begin
      case msg.lparamlo of
        fd_accept: begin
          do_action;
          end;
        end;
      end;
    end;
  end;
(*@///0000000E09*)
(*@/// procedure t_fingerd.action; *)
procedure t_fingerd.action;
begin
  open_socket_in(f_socket,f_Socket_number,my_ip_address);
  if f_socket=INVALID_SOCKET then
    raise ESocketError.Create(WSAGetLastError);
  winsock.WSAAsyncSelect(f_socket,f_handle,uwm_socketevent,fd_accept);
  end;
(*@///000000010B*)
(*@///000000051C*)

{ HTTP and FTP - the file transfer protocols }
(*@/// class t_http(t_tcpip) *)
(*@/// constructor t_http.Create(Aowner:TComponent); *)
constructor t_http.Create(Aowner:TComponent);
begin
  inherited create(AOwner);
  f_content_post:='application/x-www-form-urlencoded';
  f_do_author:=TStringlist.Create;
  end;
(*@///0000000503*)
(*@/// destructor t_http.Destroy; *)
destructor t_http.Destroy;
begin
  f_do_author.free;
  inherited destroy;
  end;
(*@///*)

(*@/// procedure t_http.sendrequest(const method,version: string); *)
procedure t_http.sendrequest(const method,version: string);
begin
  SendCommand(method+' '+f_path+' HTTP/'+version);
  if f_sender<>'' then
    SendCommand('From: '+f_sender);
  if f_reference<>'' then
    SendCommand('Referer: '+f_reference);
  if f_agent<>'' then
    SendCommand('User-Agent: '+f_agent);
  if f_nocache then
    SendCommand('Pragma: no-cache');
  if method='POST' then begin
    SendCommand('Content-Length: '+inttostr(stream.size));
    if f_content_post<>'' then
      SendCommand('Content-Type: '+f_content_post);
    end;
  if f_author<>'' then begin
    self.write_s(f_socket,'Authorization: '+f_author+#13#10);
    if assigned(f_tracer) then
      f_tracer('Authorization: *****',tt_proto_sent);
    end;
  self.write_s(f_socket,#13#10);                          (* finalize the request *)
  end;
(*@///0000000301*)
(*@/// procedure t_http.getanswer; *)
procedure t_http.getanswer;
var
  s: string;
  proto,user,pass,port: string;
  field,data: string;
begin
  f_do_author.clear;
  f_type:='';
  f_size:=0;
  repeat
    s:=self.read_line(f_socket);
    if s<>'' then
      if assigned(f_tracer) then
        f_tracer(s,tt_proto_get);
    if false then
(*@///     else if left(s,8)='HTTP/1.0' then    http-status-reply *)
else if copy(s,1,8)='HTTP/1.0' then begin
  f_status_nr:=strtoint(copy(s,10,3));
  f_status_txt:=copy(s,14,length(s));
  if f_status_nr>=400 then EXIT;   (* HTTP error returned *)
  end
(*@///*)
(*@///     else if pos(':',s)>0         then    parse the response string *)
else if pos(':',s)>0 then begin
  field:=lowercase(copy(s,1,pos(':',s)-1));
  data:=copy(s,pos(':',s)+2,length(s));
  if false then
{   else if field='date' then }
{   else if field='mime-version' then }
{   else if field='pragma' then }
{   else if field='allow' then }
(*@///   else if field='location' then   change the uri !!! *)
else if field='location' then begin
  if proxy<>'' then
    f_path:=data            (* it goes via a proxy, so just change the uri *)
  else begin
    parse_url(data,proto,user,pass,f_hostname,port,f_path);
    if port<>'' then  f_Socket_number:=strtoint(port);
    end;
  end
(*@///0000000601*)
{   else if field='server' then }
{   else if field='content-encoding' then }
(*@///   else if field='content-length' then *)
else if field='content-length' then
  f_size:=strtoint(data)
(*@///*)
(*@///   else if field='content-type' then *)
else if field='content-type' then
  f_type:=data
(*@///*)
(*@///   else if field='www-authenticate' then *)
else if field='www-authenticate' then
  f_do_author.add(data)
(*@///000000020E*)
{   else if field='expires' then }
{   else if field='last-modified' then }
  end
(*@///0000000901*)
(*@///     else                                 some very strange response, ignore it *)
else;
(*@///*)
  until s='';
  if f_status_nr>=400 then
    raise EProtocolError.Create('HTTP',f_status_txt,f_status_nr);
  end;
(*@///0000001101*)

(*@/// procedure t_http.action; *)
procedure t_http.action;
var
  proto,user,pass,host,port,path: string;
begin
(*@///   parse url and proxy to f_hostname, f_path and f_socket_number *)
if f_proxy<>'' then begin
  parse_url(f_url,proto,user,pass,host,port,path);
  f_path:=f_url;
  if proto='' then
    f_path:='http://'+f_path;
  parse_url(f_proxy,proto,user,pass,host,port,path);
  if port='' then port:='8080';
  end
else begin
  parse_url(f_url,proto,user,pass,host,port,f_path);
  if port='' then port:='80';
  end;
if proto='' then  proto:='http';
if f_path='' then f_path:='/';

f_hostname:=host;
f_Socket_number:=strtoint(port);
(*@///0000000601*)
  gethead;   (* to process an eventually Location: answer *)
  getbody;
  end;
(*@///0000000501*)
(*@/// procedure t_http.GetHead; *)
procedure t_http.GetHead;
begin
  login;
  sendrequest('HEAD','1.0');
  getanswer;
  logout;
  end;
(*@///0000000701*)
(*@/// procedure t_http.GetBody; *)
procedure t_http.GetBody;
var
  p: pointer;
  ok,ok2:integer;
begin
  login;
  sendrequest('GET','1.0');
  getanswer;
(*@///   read the data *)
TMemorystream(f_stream).clear;
while not eof(f_socket) do begin
  read_var(f_socket,f_buffer^,buf_size,ok);
  p:=f_buffer;
  while ok>0 do begin   (* just to be sure everything goes into the stream *)
    ok2:=f_stream.write(p^,ok);
    dec(ok,ok2);
    p:=pointer(longint(p)+ok2);
    end;
  end;
f_stream.seek(0,0);  (* set the stream back to start *)
(*@///*)
  logout;
  end;
(*@///0000000901*)
(*@/// procedure t_http.Post; *)
procedure t_http.Post;
var
  p: pointer;
  ok,ok2:integer;
  proto,user,pass,host,port,path: string;
begin
(*@///   parse url and proxy to f_hostname, f_path and f_socket_number *)
if f_proxy<>'' then begin
  parse_url(f_proxy,proto,user,pass,host,port,path);
  f_path:=f_url;
  if port='' then port:='8080';
  end
else begin
  parse_url(f_url,proto,user,pass,host,port,f_path);
  if port='' then port:='80';
  end;
if proto='' then  proto:='http';
if path='' then path:='/';

f_hostname:=host;
f_Socket_number:=strtoint(port);
(*@///*)
  login;
  sendrequest('POST','1.0');
(*@///   Send the data *)
TMemorystream(f_stream).seek(0,0);
ok:=1;
while ok>0 do begin
  ok:=f_stream.read(f_buffer^,buf_size);
  write_buf(f_socket,f_buffer^,ok);
  end;
(*@///0000000607*)
  getanswer;
(*@///   read in the response body *)
TMemorystream(f_stream).clear;
while not eof(f_socket) do begin
  read_var(f_socket,f_buffer^,buf_size,ok);
  p:=f_buffer;
  while ok>0 do begin   (* just to be sure everything goes into the stream *)
    ok2:=f_stream.write(p^,ok);
    dec(ok,ok2);
    p:=pointer(longint(p)+ok2);
    end;
  end;
f_stream.seek(0,0);  (* set the stream back to start *)
(*@///0000000201*)
  logout;
  end;