mysockhttp.pas

< Delphi网络通信协议分析与应用实现>>一书的源代码。

unit MySockHttp;

// *****************************************************************************
//                          THTTPSOCK 0.1b
// Created By Carlo Kok                   http://cajsoft.cjb.net/
//
// Bugreport: [e-mail]
// *****************************************************************************
//
// Registering:
// Please register when you like mysock. You can register by sending an
// email with you name, companyname, country and what you think of mysock.
// To [e-mail]. Registered will cost you nothing.
//
// Copyright (C) 1999 by Carlo Kok ([e-mail])
//
// This software is provided 'as-is', without any express or implied
// warranty. In no event will the author be held liable for any damages
// arising from the use of this software.
//
// Permission is granted to anyone to use this software for any purpose,
// including commercial applications, and to alter it and redistribute
// it freely, subject to the following restrictions:
//
// 1. The origin of this software must not be misrepresented, you must
// not claim that you wrote the original software. If you use this
// software in a product, an acknowledgment in the product
// documentation would be appreciated but is not required.
//
// 2. Altered source versions must be plainly marked as such, and
// must not be misrepresented as being the original software.
//
// 3. This notice and the copyright string may not be removed
// or altered from any source distribution.


{
Version 0.1a
 - Created unit
Version 0.1b
 - Removed several bugs
}

interface
Uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
     MySock;

Const
  Copyright : STring = 'TSock 2.0a - HTTP Copyright (C) 1999 by Carlo Kok ([e-mail]) http://cajsoft.cjb.net';

type
  THttpHead = class;
  THttpServerSock = class;
  THttpClientEvent = Procedure(Server : THttpServerSock; Client : TClientSockServ; Head : THttpHead) of object;
  THttpServerSock = class(TCustomServerSock)
  private
    fOnClient : THttpClientEvent;
  protected
    Procedure DoAutoAccept(Sender : TObject; NewSock : TClientSockServ);override;
  published
    Property OnClient : THttpClientEvent read FOnClient write FOnClient;
    Property MaxClient;
    Property Active;
    Property PortName;
    Property OnMaxClient;
  end;
  THttpHead = class
  private
    fOtherfields : TStrings;
    fPostData : String;
    fHttpVer : String;
    FMethod : String;
    FUrl : String;
    fAuthPass : String;
    fAuthUser : String;
    fAuthType : String;
    fAuthorization : string;
    fContent_Encoding : string;
    fContent_Length : string;
    fContent_Type : string;
    fFrom : string;
    fIf_Modified_Since : string;
    fReferer : string;
    fUser_Agent : string;
    fHost : String;
  public
    Constructor Create;
    Destructor Destroy;override;
    Procedure Use(S : String);
    function GetOtherVal(s : string) : string;


    property otherfields : TStrings read FOtherFields;
    property Method : String read fMethod;
    property Url : String read FUrl;
    property HttpVer : String read FHttpVer;

    property Auth_Password : String read fAuthPass;
    property Auth_Username : String read fAuthUser;
    property Auth_Type : String read fAuthType;
    property Authorization : String read fAuthorization;
    property Content_Encoding : String read fContent_Encoding;
    property Content_Length : String read fContent_Length;
    property Content_Type : String read fContent_Type;
    property From : String read fFrom;
    property Host : string read FHost;
    property If_Modified_Since : String read fIf_Modified_Since;
    property Referer : String read fReferer;
    property User_Agent : String read fUser_Agent;

    property PostData : string read FPostData;
  end;
{Used as a reply for GET}
Procedure SendRedirect(Client : TClientSockServ; newurl : string);
Procedure SendPasswordNeeded(Client : TClientSockServ; Realm : string);
procedure SendNotFoundError(Client : TClientSockServ);

{Used as a reply for HEAD}
Procedure HeadSendRedirect(Client : TClientSockServ; newurl : string);
Procedure HeadSendPasswordNeeded(Client : TClientSockServ; Realm : string);
procedure HeadSendNotFoundError(Client : TClientSockServ);

{This can be used with both HEAD and GET}
Procedure SendFile(Fn : String; Client : TClientSockServ; Head : THttpHead; Mimetype : String);
Procedure SendSeqFile(Fn : String; Client : TClientSockServ; Head : THttpHead; Mimetype : String; Realm : String);
Procedure SendStdHeader(Client : TClientSockServ);

Procedure Register;

implementation
Procedure SendFile(Fn : String; Client : TClientSockServ; Head : THttpHead; Mimetype : String);
const
  DaysOfWeek: array[1..7] of string = (
      'Sun', 'Mon', 'Tue', 'Wed',
      'Thu', 'Fri', 'Sat');
  Months: array[1..12] of string = (
      'Jan', 'Feb', 'Mar', 'Apr',
      'May', 'Jun', 'Jul', 'Aug',
      'Sep', 'Oct', 'Nov', 'Dec');
  function Date2Str(const Date : TDateTime): String; //convert a date to a string in internet format
  var
    Month, Day, Year, Hour, Minute, Sec, MSec: Word;
    function IntToStr2(i : Integer) : String;
    begin
      result:=IntToStr(i);
      while length(result)<2 do
        result:='0'+result;
    end;
  begin
    try
      DecodeDate(Date, Year, Month, Day);
      DecodeTime(Date, Hour, Minute, Sec, MSec);
      Result:=DaysOfWeek[DayOfWeek(Date)]+', '+IntToStr(Day)+' '+Months[Month]+' '+
              IntToStr(Year)+' '+IntToStr2(Hour)+':'+IntToStr2(Minute)+':'+IntToStr2(Sec)+' GMT';
    except
      result:='';
    end;
  end;
var
  Fs : TFileStream;
  s : string;
begin
  try
    Fs:=TFileStream.Create(Fn, FmOpenRead or fmShareDenyWrite);
  except
  Client.Send('HTTP/1.0 404 Not found'#13#10+
    'Content-Type: text/html'#13#10#13#10);
  if uppercase(head.method)='GET' then
    Client.send('<h1>404 Not found</h1>The file you specified was is use, maybe because it is being updated.');
    exit;
  end;
  if CompareStr(head.If_Modified_Since, DateToStr(FileDateToDateTime(FileAge(fn))))=0 then begin
    Client.Send('HTTP/1.1 304 not modified'#13#10+
      'Content-Type: '+MimeType+#13#10+
      'Content-Length: '+IntToStr(fs.size)+#13#10+
      'Last-Modified: '+Date2Str(FileDateToDateTime(FileAge(fn)))+#13#10#13#10);
    fs.free;
    exit;
  end;
  Client.Send('HTTP/1.1 200 OK'#13#10+
    'Content-Type: '+MimeType+#13#10+
    'Content-Length: '+IntToStr(fs.size)+#13#10+
    'Last-Modified: '+Date2Str(FileDateToDateTime(FileAge(fn)))+#13#10#13#10);
  if uppercase(head.method)<>'HEAD' then begin
    repeat
      if Client.MustClose then exit;
      setlength(s, 1024);
      setlength(s, fs.Read(s[1], length(s)));
      if length(s)>0 then
        Client.Send(s);
     until length(s)=0;
  end;
  fs.free;
end;
Procedure SendSeqFile(Fn : String; Client : TClientSockServ; Head : THttpHead; Mimetype : String; Realm : String);
const
  DaysOfWeek: array[1..7] of string = (
      'Sun', 'Mon', 'Tue', 'Wed',
      'Thu', 'Fri', 'Sat');
  Months: array[1..12] of string = (
      'Jan', 'Feb', 'Mar', 'Apr',
      'May', 'Jun', 'Jul', 'Aug',
      'Sep', 'Oct', 'Nov', 'Dec');
  function Date2Str(const Date : TDateTime): String; //convert a date to a string in internet format
  var
    Month, Day, Year, Hour, Minute, Sec, MSec: Word;
    function IntToStr2(i : Integer) : String;
    begin
      result:=IntToStr(i);
      while length(result)<2 do
        result:='0'+result;
    end;
  begin
    try
      DecodeDate(Date, Year, Month, Day);
      DecodeTime(Date, Hour, Minute, Sec, MSec);
      Result:=DaysOfWeek[DayOfWeek(Date)]+', '+IntToStr(Day)+' '+Months[Month]+' '+
              IntToStr(Year)+' '+IntToStr2(Hour)+':'+IntToStr2(Minute)+':'+IntToStr2(Sec)+' GMT';
    except
      result:='';
    end;
  end;
var
  Fs : TFileStream;
  s : string;
begin
  try
    Fs:=TFileStream.Create(Fn, FmOpenRead or fmShareDenyWrite);
  except
  Client.Send('HTTP/1.1 404 Not found'#13#10+
    'Content-Type: text/html'#13#10#13#10);
  if uppercase(head.method)='GET' then
    Client.send('<h1>404 Not found</h1>The file you specified was is use, maybe because it is being updated.');
    exit;
  end;
  if CompareStr(head.If_Modified_Since, DateToStr(FileDateToDateTime(FileAge(fn))))=0 then begin
    Client.Send('HTTP/1.1 304 not modified'#13#10+
      'WWW-Authenticate: Basic realm="'+realm+'"'#13#10+
      'Content-Type: '+MimeType+#13#10+
      'Content-Length: '+IntToStr(fs.size)+#13#10+
      'Last-Modified: '+Date2Str(FileDateToDateTime(FileAge(fn)))+#13#10#13#10);
    fs.free;
    exit;
  end;
  Client.Send('HTTP/1.1 200 OK'#13#10+
    'WWW-Authenticate: Basic realm="'+realm+'"'#13#10+
    'Content-Type: '+MimeType+#13#10+
    'Content-Length: '+IntToStr(fs.size)+#13#10+
    'Last-Modified: '+Date2Str(FileDateToDateTime(FileAge(fn)))+#13#10#13#10);
  if uppercase(head.method)<>'HEAD' then begin
    repeat
      if Client.MustClose then exit;
      setlength(s, 1024);
      setlength(s, fs.Read(s[1], length(s)));
      if length(s)>0 then
        Client.Send(s);
     until length(s)=0;
  end;
  fs.free;
end;
Procedure SendStdHeader(Client : TClientSockServ);
begin
  Client.Send(
    'HTTP/1.1 200 OK'#13#10+
    'Content-Type: text/html'#13#10#13#10);
end;

Procedure SendRedirect(Client : TClientSockServ; newurl : string);
begin
  Client.Send(
    'HTTP/1.1 301 Moved Permanently'#13#10+
    'Location: '+newurl+#13#10+
    'Content-Type: text/html'#13#10#13#10+
    'This resource is moved to : <a href="'+newurl+'">'+newurl+'</a>.');
end;

Procedure SendPasswordNeeded(Client : TClientSockServ; Realm : string);
begin
  Client.Send(
    'HTTP/1.1 401 Unauthorized'#13#10+
    'WWW-Authenticate: Basic realm="'+realm+'"'#13#10+
    'Content-Type: text/html'#13#10#13#10+
    '<h1>401 Unauthorized<h1>You are not authorized for this resource.');
end;

procedure SendNotFoundError(Client : TClientSockServ);
begin
  Client.Send(
    'HTTP/1.1 404 File not found'#13#10+
    'Content-Type: text/html'#13#10#13#10+
    '<h1>404 File not found</h1>'#13#10+
    'The file you specified was not found on this server.');
end;

Procedure HeadSendRedirect(Client : TClientSockServ; newurl : string);
begin
  Client.Send(
    'HTTP/1.1 301 Moved Permanently'#13#10+
    'Location: '+newurl+#13#10+
    'Content-Type: text/html'#13#10#13#10);
end;

Procedure HeadSendPasswordNeeded(Client : TClientSockServ; Realm : string);
begin
  Client.Send(
    'HTTP/1.1 401 Unauthorized'#13#10+
    'WWW-Authenticate: Basic realm="'+realm+'"'#13#10+
    'Content-Type: text/html'#13#10#13#10);
end;

procedure HeadSendNotFoundError(Client : TClientSockServ);
begin
  Client.Send(
    'HTTP/1.0 404 File not found'#13#10+
    'Content-Type: text/html'#13#10#13#10);
end;
Constructor THttpHead.Create;
begin
  inherited Create;
  fOtherfields:=TStringlist.Create;
  fPostData:='';
end;

Procedure THttpHead.Use(S : String);
var
  w1, w2 : String;
begin
  s:=s+#13#10;
  w2:=copy(s, 1, pos(#13#10, s) -1);
   delete(s, 1, pos(#13#10, s)+1);
  fMethod:=Copy(w2, 1, pos(' ', w2)-1);

  delete(w2, 1, pos(' ', w2));
  FUrl:=Copy(w2, 1, pos(' HTTP/', w2)-1);
  if furl='' then furl:='/';
  if pos('/', furl)<>1 then
    furl:='/'+furl;
  Delete(w2, 1, pos(' HTTP/', w2)+5);
  fHttpVer:=w2;
  while pos(#13#10, s)>0 do begin
    w2:=copy(s, 1, pos(#13#10, s)-1);
    if w2='' then break; {end of header is #13#10#13#10}
    delete(s, 1, pos(#13#10, s)+1);
    w1:=copy(w2, 1, pos(':', w2)-1);
    delete(w2, 1, pos(':', w2));
    while pos(' ', w2)=1 do
      delete(w2,1,1);
    Fotherfields.Add(w1+'='+w2);
  end;

  fAuthorization:=GetOtherVal('Authorization');
  fContent_Encoding:=GetOtherVal('Content-Encoding');
  fContent_Length:=GetOtherVal('Content-Length');
  fContent_Type:=GetOtherVal('Content-Type');
  fFrom:=GetOtherVal('From');
  fIf_Modified_Since:=GetOtherVal('If-Modified-Since');
  fReferer:=GetOtherVal('Referer');
  fUser_Agent:=GetOtherVal('User-Agent');
  fHost:=GetOtherVal('Host');
  fAuthPass:=FAuthorization;
  FAuthType:=copy(fAuthPass, 1, pos(' ', fAuthPass)-1);
  delete(fAuthPass, 1, pos(' ', fAuthPass));
  fAuthPass:=base64decode(fAuthPass);
  fAuthUser:=copy(fAuthPass, 1, pos(':', fAuthPass)-1);
  delete(fAuthPass, 1, pos(':', fAuthPass));
end;

Destructor THttpHead.Destroy;
begin
  FOtherfields.free;
  inherited Destroy;
end;

function THttpHead.GetOtherVal(s : string) : string;
begin
  if fOtherfields.IndexOfName(s)<>-1 then
    Result:=fOtherFields.Values[s]
  else
    Result:='';
end;


Procedure THttpServerSock.DoAutoAccept(Sender : TObject; NewSock : TClientSockServ);
var
  dataread : string;
  PostLength : Integer;
  head : THttpHead;
begin
  dataread:='';
  head:=THttpHead.Create;
  newsock.Blocking:=true;
  while (not newsock.MustClose)and(newsock.Connected) do begin
    newsock.processmessages;
    dataread:=dataread+newsock.Receive;
    if pos(#13#10#13#10, dataread)>0 then begin
      head.use(copy(dataread, 1, pos(#13#10#13#10, dataread)-1));
      delete(dataread, 1, pos(#13#10#13#10, dataread)+3);
      if head.Method='POST' then begin
        // data is being posted, wait until done
        PostLength:=StrToIntDef(head.fContent_Length, 0);
        if postlength>0 then
        while true do begin
          if (newsock.MustClose)or (not newsock.Connected) then begin
            head.free;
            exit;
          end;
          dataread:=dataread+newsock.receive;
          if length(dataread)>=postlength then break;
        end;
        head.fPostData:=dataread;
      end;
      if assigned(FOnClient) then
      FOnClient(Sender as THttpServerSock, newsock, Head);
      if newsock.connected then newsock.close;
    end;
  end;
  head.Free;
end;

Procedure Register;
Begin
  RegisterComponents('TSock', [THttpServerSock]);
End;

end.