unit HTTP;
{HTTP functions}

interface
uses
  Windows, Classes, SysUtils, WinSock;

{Write to stdout}
procedure Write(const Value: String);

{Write to stdout + CRLF}
procedure WriteLn(const Value: String = '');

{Report HTML formatted error, terminating the application}
procedure ReportError(const Error: String);

{Get Stdin/Stdout handles}
function bGetStdHandle(var FHandle: THandle; sType: DWord): Boolean;

{Free objects used in cgi}
procedure FreeData;

{Read POST Method params}
procedure ReadPostData;

{Read GET Method params}
function ReadGetData: String;

{Misc functions}
{Load file to a string}
function ReadFile(const FileName: String): String;

{String replace}
function StringReplace(S: String; const Pattern, ReplaceString: String; ReplaceAll: Boolean = True): String;

{Convert String to Integer}
function StrToInt(const S: String): DWord;

{Convert Integer to String}
function IntToStr(Value: Integer): String;

{Convert Hex string to it's Integer value}
function HexToInt(Value: String): LongWord;

{Resource utils}
function GetResourcePointer(const Res: String; var Size: LongWord): Pointer;
function GetStringFromResource(const Res: String): String;

function xResolve(const Host: String): Integer;
function WSockAddrToIp(Value: LongWord): String;
function SafeWrite(hFile: THandle; Buf: Pointer; Len: DWord): Boolean;
procedure LogText(const FName, Text: String);
function xReadFile(const FileName: String): String;

var
  FStdin, FStdout: THandle;
  FParams: TStringList = nil;

implementation

procedure Write(const Value:String);
var
  count, wt, len, plen: DWord;
  Err: Bool;
begin
  count := 1; len := Length(Value); Err := True;
  while (len > 0) and (Err) do begin
    if len > $EFD1 then
      plen := $EFD1
    else
      plen := len;              // The total size must be less than 64K.
    Err := WriteFile(FStdOut,   // Handle to the console screen buffer.
      Value[count],             // Pointer to a buffer that contains characters to be written to the console screen buffer.
      plen,                     // Number of TCHARs to write.
      wt,                       // Pointer to a variable that receives the number of TCHARs actually written.
      nil);                     // Reserved; must be NULL.
    Dec(len, wt);
    Inc(count, wt);
  end;
  if not Err then Halt;
end;

procedure WriteLn(const Value: String = '');
begin
  Write(Value + #$0D#$0A);
end;

function URLDecode(psSrc: String): String;
var
  i: Integer;
  ESC: String[2];
  CharCode: integer;
begin
  Result := '';
  while Pos('+', psSrc) > 0 do psSrc[Pos('+', psSrc)] := ' ';
  i := 1;
  while i <= Length(psSrc) do
  begin
    if psSrc[i] <> '%' then
      Result := Result + psSrc[i]
    else begin
      Inc(i);
      ESC := Copy(psSrc, i, 2);
      Inc(i);
      CharCode := HexToInt(ESC);
      if (CharCode > 0) and (CharCode < 256) then
        Result := Result + Char(CharCode);
    end;
    Inc(i);
  end;
end;

procedure DecodeParams(Value: String);
var
  S: String;
begin
  while Pos('&', Value) > 0 do begin
    S := Copy(Value, 0, Pos('&', Value) - 1);
    FParams.Add(URLDecode(S));
    Delete(Value, 1, Pos('&', Value));
  end;
  if Value <> '' then
    FParams.Add(Trim(URLDecode(Value)));
end;

procedure DecodeMParams(Value: String);
var
  boundary: String;
  data, name: String;
  I: Integer;
const
  clen: String = 'Content-Disposition: form-data; name="';
begin
  boundary := Copy(Value, 0, Pos(#13#10, Value)-2);
  I := Pos(boundary, Value);
  while I > 0 do begin
    Delete(Value, 1, Length(boundary)+3);
    I := Pos(boundary, Value);
    if I > 0 then begin
      data := Copy(Value, 0, I-1);
      Delete(Value, 1, Length(data));

      if Pos(clen, data) > 0 then begin
        Delete(data, 1, Pos(clen, data) + Length(clen)-1);
        name := Copy(data, 0, Pos('"', data)-1);
        data := Copy(data, Pos(#13#10#13#10, data) + 4, Length(data) - Pos(#13#10#13#10, data) - 5);
        FParams.Values[name] := data;
      end;
    end;
  end;
end;

procedure ReadPostData;
var
  count, rd, I: DWord;
  Err: Bool;
  Variable: String;
  ContentType: String;
  Buffer: array[Word] of Char;
  Params: String;
begin
  Params := '';
  SetString(ContentType, Buffer, GetEnvironmentVariable(PChar('CONTENT_TYPE'), Buffer, SizeOf(Buffer)));
  SetString(Variable, Buffer, GetEnvironmentVariable(PChar('CONTENT_LENGTH'), Buffer, SizeOf(Buffer)));
  I := StrToInt(Variable);

  if I = 0 then ReportError('Could not read POST data');
  SetFilePointer(FStdIn, 0, nil, FILE_BEGIN);
  SetString(Params, nil, I);
  Err := True; count := 1;
  while (I <> count + 1) and (Err) do begin
    Err := Windows.ReadFile(FStdIn,
      Params[count],
      I - count + 1,
      rd,
      nil);
    Inc(count, rd);
  end;
  if Length(Params) > 0 then begin
    if ContentType = 'application/x-www-form-urlencoded' then
      DecodeParams(Params)
    else if Pos('multipart/form-data', ContentType) > 0 then
      DecodeMParams(Params)
    else
      ReportError('Could not read POST data');    
  end else
    ReportError('Could not read POST data');
end;

function ReadGetData: String;
var
  Buffer: PChar;
begin
  GetMem(Buffer, 2048);
  Buffer[0] := #0;
  GetEnvironmentVariable(PChar('QUERY_STRING'), Buffer, 2048);
  Result := Buffer;
  FreeMem(Buffer);
  if Result = '' then
    ReportError('Could not read GET data');
end;

function bGetStdHandle(var FHandle: THandle; sType: DWord): Boolean;
begin
  FHandle := GetStdHandle(sType);
  Result := FHandle <> INVALID_HANDLE_VALUE;
end;

procedure FreeData;
begin
  if FParams <> nil then begin
    FParams.Free;
    FParams := nil;
    Write(GetStringFromResource('FOOTERDATA'));
  end;
end;

procedure ReportError(const Error: String);
begin
  Write('<h1>' + Error + '</h1>');
  FreeData;
  Halt;
end;

{------------------- Misc ----------------}
function ReadFile(const FileName: String): String;
procedure CloseFile(var FHandle: THandle);
begin
  if FHandle <> INVALID_HANDLE_VALUE then
    CloseHandle(FHandle);
  FHandle := INVALID_HANDLE_VALUE;
end;

function OpenFile(var FHandle: THandle; const FileName: String): Boolean;
begin
  Result := False;
  FHandle := CreateFile(PChar(FileName), GENERIC_READ, FILE_SHARE_READ, nil, OPEN_EXISTING, 0, 0);
  if FHandle = INVALID_HANDLE_VALUE then Exit;
  if SetFilePointer(FHandle, 0, nil, 0) = LongWord(-1) then
  begin
    CloseFile(FHandle);
    Exit;
  end;
  Result := True;
end;

var
  Buf: array[0..2047] of Char;
  rd: DWord;
  Len: DWord;
  FHandle: THandle;
begin
  Result := '';
  if not OpenFile(FHandle, FileName) then Exit;
  Len := SizeOf(Buf);
  while Windows.ReadFile(FHandle, Buf, Len, rd, nil) do begin
    if rd > 0 then begin
      Result := Result + Copy(Buf, 0, rd);
    end else
      Break;
  end;
  CloseFile(FHandle);
end;


function CopyLeft(const S: String; I: Integer): String;
begin
  Result := Copy(S, I, Length(S) - I + 1);
end;

function StringReplace(S: String; const Pattern, ReplaceString: String; ReplaceAll: Boolean = True): String;
var
  I, J: Integer;
  LP, LR: Integer;
begin
  Result := '';
  J := 1;
  LP := Length(Pattern);
  LR := Length(ReplaceString);
  repeat
    I := Pos(Pattern, CopyLeft(S, J));
    if I > 0 then begin
      Delete(S, J + I - 1, LP);
      Insert(ReplaceString, S, J + I - 1);
      if not ReplaceAll then
        Break;
    end;
    Inc(J, I + LR - 1);
  until I = 0;
  Result := S;
end;

function StrToInt(const S: String): DWord;
var
  c : Integer;
begin
  Val(S, Result, C);
  if C <> 0 then Result := 0;
end;

function IntToStr(Value: Integer): String;
begin
  Str(Value, Result);
end;

function HexToInt(Value: String): LongWord;
const
  HexStr: String = '0123456789ABCDEF';
var
  i: Word;
begin
  Result := 0;
  if Value = '' then Exit;
  for i := 1 to Length(Value) do
    Inc(Result, (Pos(Value[i], HexStr) - 1) shl ((Length(Value) - i) shl 2));
end;

function GetResourcePointer(const Res: String; var Size: LongWord): Pointer;
var
  SRC: HRSRC;
  hg: HGlobal;
begin
  Result := nil;
  SRC := FindResource(0, PChar(Res), RT_RCDATA);
  if SRC = 0 then Exit;
  Size := SizeOfResource(0, SRC);
  if Size = 0 then Exit;
  hg := LoadResource(0, SRC);
  if hg = 0 then Exit;
  Result := LockResource(hg);
end;

function GetStringFromResource(const Res: String): String;
var
  rcLen: Cardinal;
  ResPointer: Pointer;
begin
  Result := '';
  ResPointer := GetResourcePointer(Res, rcLen);
  if (ResPointer <> nil) and (rcLen > 0) then begin
    SetLength(Result, rcLen);
    Move(ResPointer^, Result[1], rcLen);
  end;
end;

function xResolve(const Host: String): Integer;
var
  he: PHostEnt;
begin
  Result := inet_addr(PChar(Host));
  if DWord(Result) = DWord(INADDR_NONE) then begin
    he := gethostbyname(PChar(Host));
    if he = nil then Exit;
    Result := PInteger(he^.h_addr_list^)^;
  end;
end;

function WSockAddrToIp(Value: LongWord): String;
var
  ia: in_addr;
begin
  ia.S_addr := Value;
  Result := inet_ntoa(ia);
end;

function SafeWrite(hFile: THandle; Buf: Pointer; Len: DWord): Boolean;
var
  count, wt, plen: DWord;
  Err: Bool;
begin
  if hFile <> INVALID_HANDLE_VALUE then begin
    count := 0; Err := True;
    while (len > 0) and (Err) do begin
      if len > $EFD1 then
        plen := $EFD1
      else
        plen := len;              // The total size must be less than 64K.
      Err := WriteFile(hFile,     // Handle to the console screen buffer.
        Pointer(LongWord(Buf) + count)^,    // Pointer to a buffer that contains characters to be written to the console screen buffer.
        plen,                     // Number of TCHARs to write.
        wt,                       // Pointer to a variable that receives the number of TCHARs actually written.
        nil);                     // Reserved; must be NULL.
      Dec(len, wt);
      Inc(count, wt);
    end;
    Result := Err;
  end else
    Result := False;
end;

procedure LogText(const FName, Text: String);
var
  F: TextFile;
begin
  if not FileExists(FName) then
  begin
    Assign(F, FName);
    {$I-}
    ReWrite(F);
    if IOResult <> 0 then
      Exit;
    {$I+}
    CloseFile(F);
  end;
  Assign(F, FName);
  {$I-}
  Append(F);
  if IOResult <> 0 then
    Exit;
  System.Writeln(F, Text);
  {$I+}
  CloseFile(F);
end;

procedure xCloseFile(var FHandle: THandle);
begin
  if FHandle <> INVALID_HANDLE_VALUE then
    CloseHandle(FHandle);
  FHandle := INVALID_HANDLE_VALUE;
end;

function xOpenFile(var FHandle: THandle; const FileName: String): Boolean;
begin
  Result := False;
  FHandle := CreateFile(PChar(FileName), GENERIC_READ, FILE_SHARE_READ or FILE_SHARE_WRITE, nil, OPEN_EXISTING, 0, 0);
  if FHandle = INVALID_HANDLE_VALUE then Exit;
  if SetFilePointer(FHandle, 0, nil, 0) = LongWord(-1) then begin
    xCloseFile(FHandle);
    Exit;
  end;
  Result := True;
end;

function xReadFile(const FileName: String): String;
var
  Buf: array[0..2047] of Char;
  rd, c: DWord;
  Len: DWord;
  FHandle: THandle;
begin
  Result := '';
  if not xOpenFile(FHandle, FileName) then Exit;
  Len := GetFileSize(FHandle, nil);
  if Len = $FFFFFFFF then Exit;
  SetLength(Result, Len); c := 0;
  while Windows.ReadFile(FHandle, Buf, SizeOf(Buf), rd, nil) do begin
    if rd > 0 then begin
      Move(Buf, Result[c + 1], rd);
    end else
      Break;
    c := c + rd;
  end;
  xCloseFile(FHandle);
  if Len <> c then Result := '';
end;

initialization
  FParams := TStringList.Create;

finalization
  FParams.Free;

end.
