Http.pas

unit Http;

interface

uses
  Classes, SysUtils, WinSock,
  IdBaseComponent, IdComponent, IdTCPServer, IdIoHandlerSocket, IdThreadMgrPool,
  IdTCPConnection, IdTCPClient, IdStackConsts;

type
  THttp = class(TObject)
  private
    IdTCPServer1: TIdTCPServer;
    IdThreadMgrPool1: TIdThreadMgrPool;
  public
    constructor Create;
    destructor Destroy; override;
    procedure Start;
    class function Request(Node: string; SendText: string): string;
    class procedure ServerExecute(AThread: TIdPeerThread);
  end;

function CheckHostIp(Host: string; Ip: string): boolean;

implementation

uses
  ZLibEx,
  Bbs, Transport, Web, Readcgi, Config, StrSub;

constructor THttp.Create;
begin
  inherited;
  IdThreadMgrPool1 := TIdThreadMgrPool.Create(nil);
  IdThreadMgrPool1.PoolSize := 64;
  IdTCPServer1 := TIdTCPServer.Create(nil);
  IdTCPServer1.DefaultPort := StrToInt2(FConfig.FPort);
  IdTCPServer1.OnExecute := ServerExecute;
  IdTCPServer1.ThreadMgr := IdThreadMgrPool1;
  IdTCPServer1.MaxConnections := 64;
  IdTCPServer1.ListenQueue := 64;
  IdTCPServer1.TerminateWaitTime := 30000;
end;

destructor THttp.Destroy;
begin
  if IdTCPServer1 <> nil then begin
    try
      IdTCPServer1.Free;
    except
    end;
    IdTCPServer1 := nil;
  end;
  if IdThreadMgrPool1 <> nil then begin
    try
      IdThreadMgrPool1.Free;
    except
    end;
    IdThreadMgrPool1 := nil;
  end;
  inherited;
end;

procedure THttp.Start;
begin
  try
    IdTCPServer1.Active := true;
  except
  end;
end;

function ReadString2(IdTCPConnection: TIdTCPConnection): string;
const
  MassBufferSize  = $1000;
type
  TMassBuffer = array[0..0] of char;
var
  stream: TMemoryStream;
  n: integer;
begin
  stream := TMemoryStream.Create;
  stream.Position := 0;
  IdTCPConnection.ReadStream(stream, -1, true);
  n := stream.Position;
  stream.Position := 0;
  SetLength(result, n);
  stream.Read(result[1], n);
  stream.Free;
end;

class function THttp.Request(Node: string; SendText: string): string;
const
  EOL: string = #13#10;
var
  IdTCPClient: TIdTCPClient;
  Buffer: array[0..1024-1] of Char;
  s: string;
  s2: string;
  RecvText: string;
  gzipAccept: boolean;
  ContentLength: integer;
  k: integer;
begin
  result := '';
  if FTerminateFlag or (FConfig.FLocalOnly and (Copy(Node, 1, 8) <> '192.168.')) then begin
    exit;
  end;
  IdTCPClient := TIdTCPClient.Create(nil);
  try
    try
      k := 15000;
      IdTCPClient.Host := SeparateNodeHost(Node);
      IdTCPClient.Port := StrToInt2(SeparateNodePort(Node), 8000);
      IdTCPClient.ReadTimeout := k;
      IdTCPClient.Connect(k);
      (IdTCPClient.IOHandler as TIdIOHandlerSocket).Binding.SetSockOpt(Id_SOL_SOCKET, Id_SO_SNDTIMEO, @k, SizeOf(integer));
      (IdTCPClient.IOHandler as TIdIOHandlerSocket).Binding.SetSockOpt(Id_SOL_SOCKET, Id_SO_RCVTIMEO, @k, SizeOf(integer));
      FillChar(Buffer, SizeOf(Buffer), #0);
      IdTCPClient.Write(SendText);
      ContentLength := -1;
      gzipAccept := false;
      while true do begin
        if FTerminateFlag then begin
          result := '';
          exit;
        end;
        s := IdTCPClient.ReadLn(EOL);
        result := result + s + #$0d + #$0a;
        if s = '' then begin
          break;
        end;
        if CompareText2(s, 'Content-Length:') = 0 then begin
          s := Copy2(s, 16);
          if s[1] = ' ' then begin
            s := Copy2(s, 2);
          end;
          ContentLength := StrToInt2(s);
        end else if CompareText2(s, 'Content-Encoding:') = 0 then begin
          if Pos('gzip', Copy2(s, 17)) > 0 then begin
            gzipAccept := true;
          end;
        end;
      end;
      if ContentLength <> -1 then begin
        result := result + IdTCPClient.ReadString(ContentLength);
      end else begin
        result := result + ReadString2(IdTCPClient);
      end;
    finally
      IdTCPClient.Disconnect;
      IdTCPClient.Free;
    end;
  except
    result := '';
    exit;
  end;
  s := result;
  s2 := SeparateWord(#$0d + #$0a + #$0d + #$0a, s);
  if gzipAccept then begin
    try
      s := ZDecompressStr2(s, 32 + 15);
    except
      s := '';
    end;
    result := s2 + #$0d + #$0a + #$0d + #$0a + s;
  end;
  if FConfig.FDebugLog > 0 then begin
    s := SendText;
    s2 := SeparateCrLf(s);
    s := result;
    SeparateCrLf2(s);
    RecvText := SeparateLf(s);
    RecvText := RecvText + '" "' + SeparateLf(s);
    RecvText := Copy(RecvText, 1, 64);
    Node := SeparateWord('/', Node);
    Log(DateTimeToStr(Now) + ' Tx: "' + Node +'" "' + s2 + '" "' + RecvText + '"' + #$0a);
    if FConfig.FDebugLog > 1 then begin
      Log(DateTimeToStr(Now) + ' Tx: "' + Node +'" "' + SendText + '" "' + result + '"' + #$0a, 2, 'dump');
    end;
  end;
end;

function CheckHostIp(Host: string; Ip: string): boolean;
type
  TPInAddr = array[0..15] of PInAddr;
  PPInAddr = ^TPInAddr;
var
  he: PHostEnt;
  buf: array[0..255] of char;
  pp: PPInAddr;
  s: string;
  i: integer;
begin
  result := false;
  if Length(Host) >= 256 - 1 then begin
    exit;
  end;
  try
    StrPCopy(@buf, Host);
    he := GetHostByName(@buf);
    if he <> nil then begin
      i := 0;
      pp := PPInAddr(he^.h_addr_list);
      while pp^[i] <> nil do begin
        s := inet_ntoa(pp^[i]^);
        if s = Ip then begin
          result := true;
          break;
        end;
        Inc(i);
      end;
    end;
  except
  end;
end;

function IpCheck(RemoteIp: string): boolean;
var
  adminIp: string;
  n: integer;
begin
  adminIp := FConfig.FAdminIp;
  if (RemoteIp = '127.0.0.1') or (RemoteIp = 'localhost') then begin
    result := true;
    exit;
  end;
  n := Pos('*', adminIp);
  if n > 0 then begin
    adminIp := Copy(adminIp, 1, n - 1);
    RemoteIp := Copy(RemoteIp, 1, n - 1);
  end;
  result := (RemoteIp = adminIp);
end;

function WriteNotFoundError: string;
begin
  result :=
    'HTTP/1.0 404 Not Found' + #$0d + #$0a +
    'Server: shinGETsu/' + ShingetsuVersion + ' (Crescent/' + ReportVersion + ')' + #$0d + #$0a +
    'Connection: Close' + #$0d + #$0a +
    'Content-Type: text/plain' + #$0d + #$0a +
    #$0d + #$0a +
    'Not Found' + #$0a;
end;

class procedure THttp.ServerExecute(AThread: TIdPeerThread);
const
  MassBufferSize  = $8000;
  EOL: string = #13#10;
type
  TMassBuffer = array[0..0] of char;
var
  FContent: TMemoryStream;
  RemoteAddress: string;
  RemotePort: integer;
  s: string;
  ContentLength: integer;
  ContentBody: string;
  transport: TTransport;
  bbs: TBbs;
  readcgi: TReadcgi;
  gatewaycgi: TWeb;
  SenderNode: string;
  gzipAccept: boolean;
  authOk: boolean;
  httpcmd: string;
  n: integer;
  req: string;
  cmd1: string;
  cmd2: string;
  compress: boolean;
  k: integer;
  resHeader: string;
  resBody: string;
  procedure WriteData(Content: string; Gzip: boolean = false; Header: string = '');
  var
    n: integer;
    n2: integer;
    content2: string;
    encode: string;
    s: string;
    s2: string;
  begin
    encode := '';
    if Header = '' then begin
      Header := SeparateCrLf2(Content);
      if Header <> '' then begin
        Header := Header + #$0d + #$0a;
      end;
    end;
    if FConfig.FDebugLog > 0 then begin
      s := Content;
      s2 := SeparateLf(s);
      s2 := s2 + '" "' + SeparateLf(s);
      s2 := Copy(s2, 1, 64);
      Log(DateTimeToStr(Now) + ' Rx: "' + SenderNode + '" "' + req + '" "' + s2 + '"' + #$0a);
      if FConfig.FDebugLog > 1 then begin
        req := httpcmd;
        Log(DateTimeToStr(Now) + ' Rx: "' + SenderNode + '" "' + req + '" "' + ContentBody + '" "' +
        Header + #$0d + #$0a + Content + '"' + #$0a, 2, 'dump');
      end;
    end;
    n := Length(Content);
    if Gzip and gzipAccept then begin
      n := Length(Content);
      try
        Content2 := ZCompressStr2(Content, zcDefault, 16 + 15, 8, zsDefault);
      except
        exit;
      end;
      n2 := Length(Content2);
      if n2 < n then begin
        n := n2;
        Content := Content2;
        encode := 'Content-Encoding: gzip'  + #$0d + #$0a;
      end;
    end;
    Header := Header + encode +
      'Content-Length: ' + IntToStr(n) + #$0d + #$0a +
      #$0d + #$0a;
    if Length(Content) < 2048 then begin
      Header := Header + Content;
      AThread.Connection.Write(Header);
    end else begin
      AThread.Connection.Write(Header);
      AThread.Connection.Write(Content);
    end;
  end;
begin
  FContent := TMemoryStream.Create;
  transport := TTransport.Create;
  bbs := TBbs.Create(transport);
  readcgi := TReadcgi.Create(bbs);
  gatewaycgi := TWeb.Create(bbs);
  try
    try
      k := 15000;
      AThread.Connection.ReadTimeout := k;
      (AThread.Connection.IOHandler as TIdIOHandlerSocket).Binding.SetSockOpt(Id_SOL_SOCKET, Id_SO_SNDTIMEO, @k, SizeOf(integer));
      (AThread.Connection.IOHandler as TIdIOHandlerSocket).Binding.SetSockOpt(Id_SOL_SOCKET, Id_SO_RCVTIMEO, @k, SizeOf(integer));
      RemoteAddress := (AThread.Connection.IOHandler as TIdIOHandlerSocket).Binding.PeerIP;
      RemotePort := (AThread.Connection.IOHandler as TIdIOHandlerSocket).Binding.PeerPort;
      SenderNode := RemoteAddress + ':' + IntToStr(RemotePort);
      ContentBody := '';
      ContentLength := -1;

      authOk := false;
      if IpCheck(RemoteAddress) then begin
        authOk := true;
      end;
      gzipAccept := false;
      httpcmd := '';
      while true do begin
        if FTerminateFlag then begin
          exit;
        end;
        s := AThread.Connection.ReadLn(EOL);
        if s = '' then begin
          break;
        end;
        if httpcmd = '' then begin
          httpcmd := s;
        end else if CompareText2(s, 'Content-Length:') = 0 then begin
          s := Copy2(s, 16);
          if s[1] = ' ' then begin
            s := Copy2(s, 2);
          end;
          ContentLength := StrToInt2(s);
        end else if CompareText2(s, 'Authorization:') = 0 then begin
          n := AnsiPos('Basic ', s);
          if n > 0 then begin
            s := Copy2(s, n + 6, -1);
            if (FConfig.FUser <> '') and (FConfig.FUser <> 'default') then begin
              if s = Base64EncodeStr(FConfig.FUser + ':' + FConfig.FPassword) then begin
                authOk := true;
              end;
            end;
          end;
        end else if CompareText2(s, 'Accept-Encoding:') = 0 then begin
          if Pos('gzip', Copy2(s, 17)) > 0 then begin
            gzipAccept := true;
          end;
        end else if CompareText2(s, 'User-Agent:') = 0 then begin
//          if Pos('Indy', Copy2(s, 12)) > 0 then begin
//            isJane := true;
//          end;
        end;
      end;
      if CompareText2(httpcmd, 'GET ') = 0 then begin
        s := Copy2(httpcmd, 5);
        s := Trim(s);

        if Pos(' ', s) > 0 then begin
          s := Copy(s, 1, Pos(' ', s) - 1);
        end;
        req := s;
        SeparateWord('/', s);
        if Pos('?', s) > 0 then begin
          cmd1 := SeparateWord('?', s);
          cmd2 := SeparateWord('/', s);
        end else begin
          cmd1 := SeparateWord('/', s);
          cmd2 := SeparateWord('/', s);
        end;
        if req = '/' then begin
          gatewaycgi.GetMethod('/gateway.cgi', authOk, resHeader, resBody);
          WriteData(resBody, false, resHeader);
        end else if (cmd1 = 'server.cgi') and (cmd2 = '') then begin
          gatewaycgi.GetMethod('/gateway.cgi/MOTD', authOk, resHeader, resBody);
          WriteData(resBody, false, resHeader);
        end else if (cmd1 = 'server.cgi') then begin
          transport.ServerCgi(cmd2, SenderNode, req, compress, resHeader, resBody);
          WriteData(resBody, compress, resHeader);
        end else if CompareText2(req, '/read.cgi') = 0 then begin
          readcgi.GetMethod(req, authOk, resHeader, resBody);
          WriteData(resBody, false, resHeader);
        end else if CompareText2(req, '/gateway.cgi') = 0 then begin
          gatewaycgi.GetMethod(req, authOk, resHeader, resBody);
          WriteData(resBody, false, resHeader);
        end else begin
          WriteData(WriteNotFoundError);
        end;
      end else if CompareText2(httpcmd, 'POST ') = 0 then begin
        if ContentLength <> -1 then begin
          ContentBody := AThread.Connection.ReadString(ContentLength);
        end else begin
          ContentBody := ReadString2(AThread.Connection);
        end;
        s := Copy2(httpcmd, 6);
        s := Trim(s);
        if Pos(' ', s) > 0 then begin
          s := Copy(s, 1, Pos(' ', s) - 1);
        end;
        req := s;
        SeparateWord('/', s);
        if Pos('?', s) > 0 then begin
          cmd1 := SeparateWord('?', s);
          cmd2 := SeparateWord('/', s);
        end else begin
          cmd1 := SeparateWord('/', s);
          cmd2 := SeparateWord('/', s);
        end;
        if CompareText2(req, '/read.cgi/') = 0 then begin
          readcgi.PostMethod(req, ContentBody, authOk, resHeader, resBody);
          WriteData(resBody, false, resHeader);
        end else if CompareText2(req, '/gateway.cgi/') = 0 then begin
          gatewaycgi.PostMethod(req, ContentBody, authOk, resHeader, resBody);
          WriteData(resBody, false, resHeader);
        end else begin
          WriteData(WriteNotFoundError);
        end;
      end else begin
        WriteData(WriteNotFoundError);
      end;
    finally
      gatewaycgi.Free;
      readcgi.Free;
      bbs.Free;
      transport.Free;
      FContent.Free;
      AThread.Connection.Disconnect;
    end;
  except
  end;
end;

end.