この発言に対し以下のコメントが寄せられています

#00987　ＫｅＹ          さん　RE:TServerSocketでブロッキング通信




  
 

みなさんこんにちは、ＫｅＹです。

TServerSocketでstThreadBlockingを使用するときのサンプルです。
素朴なHTTPデーモンを作ってみました。

使い方は、
1.アプリケーションの新規作成を選ぶ。
2.フォームにServerSocketを張り付ける。
3.Unit1.pasを入れ替える。
4.フォームのOnCreateとOnDestroy、
  ServerSocket1のOnGetThreadを関連づける
5.Constで定義しているポート番号と、ドキュメントルートのディレクトリ、
  デフォルトのファイルを確認・変更する。
6.末尾で定義しているContent-Typeを確認・変更する。
7.ドキュメントルートのディレクトリにファイルを置く。
で実行。
これでブラウザから http://127.0.0.1:8080/ などでアクセス可能に。

RFCなど読んだことがないので馬鹿な間違いをしているかもしれませんが
とりあえず動きました。
なんかまずい所があったら添削願います。 m(_ _)m

あ、D4とD5で確認しました。それと、TServerSocketを使っているので
Proffesional版以上になるのでしょうか。

//----Unit1.pasここから
unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
Dialogs,
  StdCtrls, ScktComp;

type
  TForm1 = class(TForm)
    ServerSocket1: TServerSocket;
    procedure ServerSocket1GetThread(Sender: TObject;
      ClientSocket: TServerClientWinSocket;
      var SocketThread: TServerClientThread);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    { Private 宣言 }
  public
    { Public 宣言 }
  end;

  TTinyHttpdThread = class(TServerClientThread)
  private
    { Private 宣言 }
  protected
    procedure ClientExecute; override;
  end;

const
  RootDir='c:\Delphi\Httpd\Root';
  PortNo=8080;
  DefaultDoc='index.html';

  Response403='HTTP/1.0 403 Forbidden'#13#10+
      'Content-Type: text/plain'#13#10#13#10'Error 403 Forbidden';
  Response404='HTTP/1.0 404 Not Found'#13#10+
      'Content-Type: text/plain'#13#10#13#10'Error 404 Not Found';

var
  Form1: TForm1;

implementation

{$R *.DFM}

var
  ContentTypes: TStrings;

procedure TForm1.FormCreate(Sender: TObject);
begin
  ServerSocket1.Port:=PortNo;
  ServerSocket1.ServerType:=stThreadBlocking;
  ;ServerSocket1.Active:=True;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  if ServerSocket1.Active then
  begin
    ServerSocket1.Active:=False;
  end;
end;

procedure TForm1.ServerSocket1GetThread(Sender: TObject;
  ClientSocket: TServerClientWinSocket;
  var SocketThread: TServerClientThread);
begin
  SocketThread:=TTinyHttpdThread.Create(False, ClientSocket);
end;

{ TTiniHttpdThread }

procedure TTinyHttpdThread.ClientExecute;
var
  Stream: TWinSocketStream;
  Buffer: array[0..4095] of Char;
  GetSize: Integer;

  HttpReq: TMemoryStream;
  HttpReqStr: TStrings;
  s: string;
  i: Integer;

  SendFile: TFileStream;
  SendFileExt: string;
  SendHeader: string;
  ContentType: string;
begin
  HttpReq:=TMemoryStream.Create;
  HttpReqStr:=TStringList.Create;

  try
    //このループはお決まりのもの
    while (not Terminated) and ClientSocket.Connected do
    begin
      try
        //ソケットストリームの作成
        Stream:=TWinSocketStream.Create(ClientSocket, 500);
        try
          //受信可能状態になるのを待つ
          if Stream.WaitForData(60000) then
          begin
            //リクエストを全部読んでTMemoryStreamに保存
            //    本当はセキュリティホールになるのでやってはいけない
            HttpReq.Clear;
            GetSize:=Stream.Read(Buffer, sizeof(Buffer));
            while GetSize>0 do
            begin
              HttpReq.Write(Buffer, GetSize);
              GetSize:=Stream.Read(Buffer, sizeof(Buffer));
            end;

            //TStringsにコピー
            HttpReq.Seek(0, soFromBeginning);
            HttpReqStr.LoadFromStream(HttpReq);

            //GETメソッドか？
            if CompareText(
                Copy(HttpReqStr.Strings[0], 1, 4),'GET ')=0 then
            begin
              //'GET 'を削除
              s:=Copy(HttpReqStr.Strings[0], 5,
                  Length(HttpReqStr.Strings[0]));
              s:=Trim(s);

              //ディレクトリ部分だけ抜き出す
              if Pos(' ', s)>0 then
                s:=Copy(s, 1, Pos(' ', s)-1);

              //'/'を'\'に変更
              for i:=1 to Length(s) do
              begin
                if (s[i]='/') then
                  s[i]:='\';
              end;

              //ルートディレクトリを付ける
              s:=rootdir+s;

              //最後がフォルダならデフォルトファイルを追加
              if s[Length(s)]='\' then
                s:=s+DefaultDoc;

              //ファイルをオープン
              //    CGI引数付きのGETメソッドはここで失敗する
              //    また引数なしのCGIプログラムはそのまま
              //    ファイルを渡してしまう
              try
                SendFile:=TFileStream.Create(
                  s, fmOpenRead or fmShareDenyWrite
                );
              except
                //失敗したら404のエラー
                SendFile:=nil;
                s:=Response404;
                Stream.Write(s[1], Length(s));
              end;

              if Assigned(SendFile) then
              begin
                try
                  //拡張子を取得
                  SendFileExt:=ExtractFileExt(s);

                  //'.'を取り除く
                  Delete(SendFileExt,1,1);

                  //Content-Typeを決定
                  ContentType:=ContentTypes.Values[s];
                  //設定なし
                  if s='' then
                    ContentType:='application/octet-stream';

                  //最低限のヘッダ
                  SendHeader:='HTTP/1.0 200 '#13#10+
                      'Content-Type: '+ContentType+
                       #13#10#13#10;

                  //ヘッダ送信
                  Stream.Write(SendHeader[1], Length(SendHeader));

                  //ファイルを送信
                  GetSize:=SendFile.Read(Buffer, sizeof(Buffer));
                  while GetSize>0 do
                  begin
                    Stream.Write(Buffer, GetSize);
                    GetSize:=SendFile.Read(Buffer, sizeof(Buffer));
                  end;
                finally
                  SendFile.Free;
                end;
              end;
            end
            else begin
              //GETメソッド以外には対応していません
              s:=Response403;
              Stream.Write(s[1], Length(s));
            end;
          end;
        finally
          //ソケットストリームを破棄
          Stream.Free;

          //ソケットをクローズ
          ClientSocket.Close;
        end;
      except
        HandleException;
      end;
    end;
  finally
    HttpReq.Free;
    HttpReqStr.Free;
  end;
end;

initialization
  ContentTypes:=TStringList.Create;
  ContentTypes.Add('HTML=text/html');
  ContentTypes.Add('HTM=text/html');
  ContentTypes.Add('JPEG=image/jpeg');
  ContentTypes.Add('JPG=image/jpeg');
  ContentTypes.Add('GIF=image/gif');
finalization
  ContentTypes.Free;
end.
//----Unit1.pasここまで

99/12/4(Sat) 02:25am  VEJ04660 ＫｅＹ

Original document by ＫｅＹ          氏 ID:(VEJ04660)

ここにあるドキュメントは NIFTY SERVEの Delphi Users' Forum の16番会議室「玉石混淆みんなで作るSample蔵」に投稿されたサンプルです。これらのサンプルはボーランド株式会社がサポートする公式のものではありません。また、必ずしも動作が検証されているものではありません。これらのサンプルを使用したことに起因するいかなる損害も投稿者、およびフォーラムスタッフはその責めを負いません。使用者のリスクの範疇でご使用下さい。