home *** CD-ROM | disk | FTP | other *** search
/ IT.SOFT 22 / ITSOFTCD_22.iso / pc / shareware22 / file3 / TINYWEB.ZIP / SRC.ZIP / SRVMAIN.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1998-10-17  |  54.5 KB  |  1,851 lines
  1. //////////////////////////////////////////////////////////////////////////
  2. //
  3. //  TinyWeb Copyright (C) 1997-98 RIT Research Labs
  4. //
  5. //  This programs is free for commercial and non-commercial use as long as
  6. //  the following conditions are aheared to.
  7. //
  8. //  Copyright remains RIT Research Labs, and as such any Copyright notices
  9. //  in the code are not to be removed. If this package is used in a
  10. //  product, RIT Research Labs should be given attribution as the RIT Research
  11. //  Labs of the parts of the library used. This can be in the form of a textual
  12. //  message at program startup or in documentation (online or textual)
  13. //  provided with the package.
  14. //
  15. //  Redistribution and use in source and binary forms, with or without
  16. //  modification, are permitted provided that the following conditions are
  17. //  met:
  18. //
  19. //  1. Redistributions of source code must retain the copyright
  20. //     notice, this list of conditions and the following disclaimer.
  21. //  2. Redistributions in binary form must reproduce the above copyright
  22. //     notice, this list of conditions and the following disclaimer in the
  23. //     documentation and/or other materials provided with the distribution.
  24. //  3. All advertising materials mentioning features or use of this software
  25. //     must display the following acknowledgement:
  26. //     "Based on TinyWeb Server by RIT Research Labs."
  27. //
  28. //  THIS SOFTWARE IS PROVIDED BY RIT RESEARCH LABS "AS IS" AND ANY EXPRESS
  29. //  OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
  30. //  WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
  31. //  DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE FOR
  32. //  ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
  33. //  DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
  34. //  GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
  35. //  INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER
  36. //  IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
  37. //  OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
  38. //  ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  39. //
  40. //  The licence and distribution terms for any publically available
  41. //  version or derivative of this code cannot be changed. i.e. this code
  42. //  cannot simply be copied and put under another distribution licence
  43. //  (including the GNU Public Licence).
  44. //
  45. //////////////////////////////////////////////////////////////////////////
  46.  
  47. {$I DEFINE.INC}
  48.  
  49. unit SrvMain;
  50.  
  51. interface
  52.  
  53. procedure ComeOn;
  54.  
  55. implementation
  56.  
  57. uses
  58.   {$IFDEF DEF_SSL}
  59.   xSSL,
  60.   SSLeay,
  61.   {$ENDIF}
  62.   WinSock,
  63.   Windows,
  64.   xBase;
  65.  
  66. const
  67.  
  68.   CIndexFile  = {'default.htm' {}'index.html';
  69.   ScriptsPath = '/cgi-bin/';
  70.  
  71.   CHTTPServerThreadBufSize = $2000;
  72.   MaxStatusCodeIdx = 36;
  73.   StatusCodes : array[0..MaxStatusCodeIdx] of record Code: Integer; Msg: string end =
  74.   ((Code:100; Msg:'Continue'),
  75.    (Code:101; Msg:'Switching Protocols'),
  76.    (Code:200; Msg:'OK'),
  77.    (Code:201; Msg:'Created'),
  78.    (Code:202; Msg:'Accepted'),
  79.    (Code:203; Msg:'Non-Authoritative Information'),
  80.    (Code:204; Msg:'No Content'),
  81.    (Code:205; Msg:'Reset Content'),
  82.    (Code:206; Msg:'Partial Content'),
  83.    (Code:300; Msg:'Multiple Choices'),
  84.    (Code:301; Msg:'Moved Permanently'),
  85.    (Code:302; Msg:'Moved Temporarily'),
  86.    (Code:303; Msg:'See Other'),
  87.    (Code:304; Msg:'Not Modified'),
  88.    (Code:305; Msg:'Use Proxy'),
  89.    (Code:400; Msg:'Bad Request'),
  90.    (Code:401; Msg:'Unauthorized'),
  91.    (Code:402; Msg:'Payment Required'),
  92.    (Code:403; Msg:'Forbidden'),
  93.    (Code:404; Msg:'Not Found'),
  94.    (Code:405; Msg:'Method Not Allowed'),
  95.    (Code:406; Msg:'Not Acceptable'),
  96.    (Code:407; Msg:'Proxy Authentication Required'),
  97.    (Code:408; Msg:'Request Time-out'),
  98.    (Code:409; Msg:'Conflict'),
  99.    (Code:410; Msg:'Gone'),
  100.    (Code:411; Msg:'Length Required'),
  101.    (Code:412; Msg:'Precondition Failed'),
  102.    (Code:413; Msg:'Request Entity Too Large'),
  103.    (Code:414; Msg:'Request-URI Too Large'),
  104.    (Code:415; Msg:'Unsupported Media Type'),
  105.    (Code:500; Msg:'Internal Server Error'),
  106.    (Code:501; Msg:'Not Implemented'),
  107.    (Code:502; Msg:'Bad Gateway'),
  108.    (Code:503; Msg:'Service Unavailable'),
  109.    (Code:504; Msg:'Gateway Time-out'),
  110.    (Code:505; Msg:'HTTP Version not supported'));
  111.  
  112. type
  113.   TEntityHeader = class;
  114.   TCollector = class;
  115.  
  116.   TAbstractHttpResponseData = class
  117.   end;
  118.  
  119.   THttpResponseDataFileHandle = class(TAbstractHttpResponseData)
  120.     FHandle: THandle;
  121.     constructor Create(AHandle: DWORD);
  122.   end;
  123.  
  124.   THttpResponseDataEntity = class(TAbstractHttpResponseData)
  125.     FEntityHeader : TEntityHeader;
  126.     constructor Create(AEntityHeader : TEntityHeader);
  127.   end;
  128.  
  129.   THttpResponseErrorCode = class(TAbstractHttpResponseData)
  130.     FErrorCode: Integer;
  131.     constructor Create(AErrorCode: Integer);
  132.   end;
  133.  
  134.   PHTTPServerThreadBufer = ^THTTPServerThreadBufer;
  135.   THTTPServerThreadBufer = array[0..CHTTPServerThreadBufSize-1] of Char;
  136.  
  137.   TPipeReadStdThread = class(TThread)
  138.     Error: Boolean;
  139.     HPipe: DWORD;
  140.     Buffer: PHTTPServerThreadBufer;
  141.     EntityHeader: TEntityHeader;
  142.     Collector: TCollector;
  143.     procedure Execute; override;
  144.   end;
  145.  
  146.   TPipeWriteStdThread = class(TThread)
  147.     HPipe: DWORD;
  148.     s: string;
  149.     procedure Execute; override;
  150.   end;
  151.  
  152.   TPipeReadErrThread = class(TThread)
  153.     HPipe: DWORD;
  154.     s: string;
  155.     procedure Execute; override;
  156.   end;
  157.  
  158.   TContentType = class
  159.     ContentType,
  160.     Extension: string;
  161.   end;
  162.  
  163.   TContentTypeColl = class(TSortedColl)
  164.     function Compare(Key1, Key2: Pointer): Integer; override;
  165.     function KeyOf(Item: Pointer): Pointer; override;
  166.   end;
  167.  
  168.   THTTPData = class;
  169.  
  170.   THTTPServerThread = class(TThread)
  171.     RemoteHost,
  172.     RemoteAddr: string;
  173.     Buffer: THTTPServerThreadBufer;
  174.     Socket: TSocket;
  175.     constructor Create;
  176.     procedure PrepareResponse(d: THTTPData);
  177.     procedure Execute; override;
  178.     destructor Destroy; override;
  179.   end;
  180.  
  181.   TGeneralHeader = class
  182.     CacheControl,            // Section 14.9
  183.     Connection,              // Section 14.10
  184.     Date,                    // Section 14.19
  185.     Pragma,                  // Section 14.32
  186.     TransferEncoding,        // Section 14.40
  187.     Upgrade,                 // Section 14.41
  188.     Via : string;            // Section 14.44
  189.     function Filter(const z, s: string): Boolean;
  190.     function OutString: string;
  191.   end;
  192.  
  193.  
  194.   TResponseHeader = class
  195.     Age,                    // Section 14.6
  196.     Location,               // Section 14.30
  197.     ProxyAuthenticate,      // Section 14.33
  198.     Public_,                // Section 14.35
  199.     RetryAfter,             // Section 14.38
  200.     Server,                 // Section 14.39
  201.     Vary,                   // Section 14.43
  202.     Warning,                // Section 14.45
  203.     WWWAuthenticate         // Section 14.46
  204.       : string;
  205.     function OutString: string;
  206.   end;
  207.  
  208.   TRequestHeader = class
  209.     Accept,                  // Section 14.1
  210.     AcceptCharset,           // Section 14.2
  211.     AcceptEncoding,          // Section 14.3
  212.     AcceptLanguage,          // Section 14.4
  213.     Authorization,           // Section 14.8
  214.     From,                    // Section 14.22
  215.     Host,                    // Section 14.23
  216.     IfModifiedSince,         // Section 14.24
  217.     IfMatch,                 // Section 14.25
  218.     IfNoneMatch,             // Section 14.26
  219.     IfRange,                 // Section 14.27
  220.     IfUnmodifiedSince,       // Section 14.28
  221.     MaxForwards,             // Section 14.31
  222.     ProxyAuthorization,      // Section 14.34
  223.     Range,                   // Section 14.36
  224.     Referer,                 // Section 14.37
  225.     UserAgent: string;       // Section 14.42
  226.     function Filter(const z, s: string): Boolean;
  227.   end;
  228.  
  229.   TCollector = class
  230.   private
  231.     Parsed: Boolean;
  232.     Lines: TStringColl;
  233.     CollectStr: string;
  234.     ContentLength: Integer;
  235.   public
  236.     EntityBody: string;
  237.     GotEntityBody,
  238.     CollectEntityBody: Boolean;
  239.     function Collect(var Buf: THTTPServerThreadBufer; j: Integer): Boolean;
  240.     constructor Create;
  241.     destructor Destroy; override;
  242.     function GetNextLine: string;
  243.     function LineAvail: Boolean;
  244.     procedure SetContentLength(i: Integer);
  245.   end;
  246.  
  247.  
  248.   TEntityHeader = class
  249.     Allow,                   // Section 14.7
  250.     ContentBase,             // Section 14.11
  251.     ContentEncoding,         // Section 14.12
  252.     ContentLanguage,         // Section 14.13
  253.     ContentLength,           // Section 14.14
  254.     ContentLocation,         // Section 14.15
  255.     ContentMD5,              // Section 14.16
  256.     ContentRange,            // Section 14.17
  257.     ContentType,             // Section 14.18
  258.     ETag,                    // Section 14.20
  259.     Expires,                 // Section 14.21
  260.     LastModified,            // Section 14.29
  261.     EntityBody: string;
  262.     EntityLength: Integer;
  263.     CGIStatus,
  264.     CGILocation: string;
  265.     function Filter(const z, s: string): Boolean;
  266.     procedure CopyEntityBody(Collector: TCollector);
  267.     function OutString: string;
  268.   end;
  269.  
  270.   THTTPData = class
  271.     RequestCollector: TCollector;
  272.     FileNfo: TFileINfo;
  273.  
  274.     FHandle: THandle;
  275.     StatusCode,
  276.     HTTPVersionHi,
  277.     HTTPVersionLo: Integer;
  278.  
  279.     TransferFile,
  280.     ReportError,
  281.     KeepAlive: Boolean;
  282.  
  283.     ErrorMsg,
  284.     Method, RequestURI, HTTPVersion, AuthUser, AuthPassword, AuthType,
  285.     URIPath, URIParams, URIQuery, URIQueryParam : string;
  286.  
  287.     ResponceObjective: TAbstractHttpResponseData;
  288.  
  289.     RequestGeneralHeader: TGeneralHeader;
  290.     RequestRequestHeader: TRequestHeader;
  291.     RequestEntityHeader: TEntityHeader;
  292.  
  293.     ResponseGeneralHeader: TGeneralHeader;
  294.     ResponseResponseHeader: TResponseHeader;
  295.     ResponseEntityHeader: TEntityHeader;
  296.  
  297.     constructor Create;
  298.     destructor Destroy; override;
  299.  
  300.   end;
  301.  
  302. var
  303.     {$IFDEF DEBUG}
  304.     DebugExit: Boolean;
  305.     {$ENDIF}
  306.  
  307.   ContentTypes: TContentTypeColl;
  308. {$IFDEF REALMS}
  309.   RealmPaths, RealmNames, RealmUsers: TStringColl;
  310. {$ENDIF}
  311.   ParamStr1,
  312.   FAccessLog,
  313.   FAgentLog,
  314.   FErrorLog,
  315.   FRefererLog: string;
  316.   CSAccessLog,
  317.   CSAgentLog,
  318.   CSErrorLog,
  319.   CSRefererLog: TRTLCriticalSection;
  320.   HAccessLog,
  321.   HAgentLog,
  322.   HErrorLog,
  323.   HRefererLog: DWORD;
  324.  
  325.  
  326. function FileTimeToStr(AT: DWORD): string;
  327. const
  328.   wkday: array[0..6] of string = ('Sun', 'Mon', 'Tue', 'Wed', 'Thu', 'Fri', 'Sat');
  329. var
  330.   D: TSystemTime;
  331.   T: TFileTime;
  332. begin
  333.   uCvtSetFileTime(AT, T.dwLowDateTime, T.dwHighDateTime);
  334.   if FileTimeToSystemTime(T, D) then
  335.   Result :=
  336.   wkday[D.wDayOfWeek] + ', ' +
  337.   ItoSz(D.wDay, 2) + ' ' +
  338.   MonthE(D.wMonth) + ' ' +
  339.   ItoS(D.wYear) + ' ' +
  340.   ItoSz(D.wHour, 2) + ':' +
  341.   ItoSz(D.wMinute, 2) + ':' +
  342.   ItoSz(D.wSecond, 2) + ' GMT';
  343. end;
  344.  
  345. function StrToFileTime(AStr: string): DWORD;
  346. var
  347.   D: TSystemTime;
  348.   T: TFileTime;
  349.   s, z: string;
  350.   e: Integer;
  351. begin
  352.   Result := INVALID_FILE_TIME;
  353.   Clear(D, SizeOf(D));
  354.   s := AStr;
  355.   GetWrd(s, z, ' ');
  356.   GetWrdD(s, z); Val(z, D.wDay, e); if e > 0 then Exit;
  357.   GetWrdA(s, z); D.wMonth := Pos(#1+UpperCase(z)+#1, #1'JAN'#1'FEB'#1'MAR'#1'APR'#1'MAY'#1'JUN'#1'JUL'#1'AUG'#1'SEP'#1'OCT'#1'NOV'#1'DEC'#1);
  358.   if D.wMonth = 0 then Exit;
  359.   D.wMonth := (D.wMonth+3) div 4;
  360.   GetWrdD(s, z); Val(z, D.wYear, e); if e > 0 then Exit;
  361.   if D.wYear < 200 then
  362.   begin
  363.     if D.wYear < 50 then Inc(D.wYear, 2000) else Inc(D.wYear, 1900);
  364.   end;
  365.   GetWrdD(s, z); Val(z, D.wHour, e); if e > 0 then Exit;
  366.   GetWrdD(s, z); Val(z, D.wMinute, e); if e > 0 then Exit;
  367.   GetWrdD(s, z); Val(z, D.wSecond, e); if e > 0 then Exit;
  368.   if not SystemTimeToFileTime(D, T) then Exit;
  369.   Result := uCvtGetFileTime(T.dwLowDateTime, T.dwHighDateTime);
  370. end;
  371.  
  372. // 'Sunday, 17-May-98 18:44:23 GMT; length=4956'
  373.  
  374. constructor THTTPServerThread.Create;
  375. begin
  376.   inherited Create(True);
  377. end;
  378.  
  379. destructor THTTPServerThread.Destroy;
  380. begin
  381.   FreeObject(Socket);
  382.   inherited Destroy;
  383. end;
  384.  
  385. function TGeneralHeader.Filter(const z, s: string): Boolean;
  386. begin
  387.   Result := True;
  388.   if z = 'CACHE-CONTROL'       then CacheControl       := s else // Section 14.9
  389.   if z = 'CONNECTION'          then Connection         := s else // Section 14.10
  390.   if z = 'DATE'                then Date               := s else // Section 14.19
  391.   if z = 'PRAGMA'              then Pragma             := s else // Section 14.32
  392.   if z = 'TRANSFER-ENCODING'   then TransferEncoding   := s else // Section 14.40
  393.   if z = 'UPGRADE'             then Upgrade            := s else // Section 14.41
  394.   if z = 'VIA'                 then Via                := s else // Section 14.44
  395.     Result := False;
  396. end;
  397.  
  398. function TRequestHeader.Filter(const z, s: string): Boolean;
  399. begin
  400.   Result := True;
  401.   if z = 'ACCEPT'              then Accept             := s else // Section 14.1
  402.   if z = 'ACCEPT-CHARSET'      then AcceptCharset      := s else // Section 14.2
  403.   if z = 'ACCEPT-ENCODING'     then AcceptEncoding     := s else // Section 14.3
  404.   if z = 'ACCEPT-LANGUAGE'     then AcceptLanguage     := s else // Section 14.4
  405.   if z = 'AUTHORIZATION'       then Authorization      := s else // Section 14.8
  406.   if z = 'FROM'                then From               := s else // Section 14.22
  407.   if z = 'HOST'                then Host               := s else // Section 14.23
  408.   if z = 'IF-MODIFIED-SINCE'   then IfModifiedSince    := s else // Section 14.24
  409.   if z = 'IF-MATCH'            then IfMatch            := s else // Section 14.25
  410.   if z = 'IF-NONE-MATCH'       then IfNoneMatch        := s else // Section 14.26
  411.   if z = 'IF-RANGE'            then IfRange            := s else // Section 14.27
  412.   if z = 'IF-UNMODIFIED-SINCE' then IfUnmodifiedSince  := s else // Section 14.28
  413.   if z = 'MAX-FORWARDS'        then MaxForwards        := s else // Section 14.31
  414.   if z = 'PROXY-AUTHORIZATION' then ProxyAuthorization := s else // Section 14.34
  415.   if z = 'RANGE'               then Range              := s else // Section 14.36
  416.   if z = 'REFERER'             then Referer            := s else // Section 14.37
  417.   if z = 'USER-AGENT'          then UserAgent          := s else // Section 14.42
  418.     Result := False
  419. end;
  420.  
  421. procedure Add(var s, z: string; const a: string);
  422. begin
  423.   if z <> '' then s := s + a + ': '+z+#13#10;
  424. end;
  425.  
  426. function TResponseHeader.OutString: string;
  427. var
  428.   s: string;
  429. begin
  430.   s := '';
  431.   Add(s, Age,               'Age');                // Section 14.6
  432.   Add(s, Location,          'Location');           // Section 14.30
  433.   Add(s, ProxyAuthenticate, 'Proxy-Authenticate'); // Section 14.33
  434.   Add(s, Public_,           'Public');             // Section 14.35
  435.   Add(s, RetryAfter,        'Retry-After');        // Section 14.38
  436.   Add(s, Server,            'Server');             // Section 14.39
  437.   Add(s, Vary,              'Vary');               // Section 14.43
  438.   Add(s, Warning,           'Warning');            // Section 14.45
  439.   Add(s, WWWAuthenticate,   'WWW-Authenticate');   // Section 14.46
  440.   Result := s;
  441. end;
  442.  
  443. function TEntityHeader.OutString: string;
  444. var
  445.   s: string;
  446. begin
  447.   s := '';
  448.   Add(s, Allow,           'Allow');             // Section 14.7
  449.   Add(s, ContentBase,     'Content-Base');      // Section 14.11
  450.   Add(s, ContentEncoding, 'Content-Encoding');  // Section 14.12
  451.   Add(s, ContentLanguage, 'Content-Language');  // Section 14.13
  452.   Add(s, ContentLength,   'Content-Length');    // Section 14.14
  453.   Add(s, ContentLocation, 'Content-Location');  // Section 14.15
  454.   Add(s, ContentMD5,      'Content-MD5');       // Section 14.16
  455.   Add(s, ContentRange,    'Content-Range');     // Section 14.17
  456.   Add(s, ContentType,     'Content-Type');      // Section 14.18
  457.   Add(s, ETag,            'ETag');              // Section 14.20
  458.   Add(s, Expires,         'Expires');           // Section 14.21
  459.   Add(s, LastModified,    'Last-Modified');     // Section 14.29
  460.   Result := s;
  461. end;
  462.  
  463. function TGeneralHeader.OutString: string;
  464. var
  465.   s: string;
  466. begin
  467.   s := '';
  468.   Add(s, CacheControl,     'Cache-Control');     // Section 14.9
  469.   Add(s, Connection,       'Connection');        // Section 14.10
  470.   Add(s, Date,             'Date');              // Section 14.19
  471.   Add(s, Pragma,           'Pragma');            // Section 14.32
  472.   Add(s, TransferEncoding, 'Transfer-Encoding'); // Section 14.40
  473.   Add(s, Upgrade,          'Upgrade');           // Section 14.41
  474.   Add(s, Via,              'Via');               // Section 14.44
  475.   Result := s;
  476. end;
  477.  
  478. procedure TEntityHeader.CopyEntityBody(Collector: TCollector);
  479. begin
  480.   EntityLength := Collector.ContentLength;
  481.   ContentLength := ItoS(Collector.ContentLength);
  482.   EntityBody := Copy(Collector.EntityBody, 1, EntityLength);
  483. end;
  484.  
  485. function TEntityHeader.Filter(const z, s: string): Boolean;
  486. begin
  487.   Result := True;
  488.   if z = 'ALLOW'            then Allow           := s else // 14.7
  489.   if z = 'CONTENT-BASE'     then ContentBase     := s else // 14.11
  490.   if z = 'CONTENT-ENCODING' then ContentEncoding := s else // 14.12
  491.   if z = 'CONTENT-LANGUAGE' then ContentLanguage := s else // 14.13
  492.   if z = 'CONTENT-LENGTH'   then ContentLength   := s else // 14.14
  493.   if z = 'CONTENT-LOCATION' then ContentLocation := s else // 14.15
  494.   if z = 'CONTENT-MD5'      then ContentMD5      := s else // 14.16
  495.   if z = 'CONTENT-RANGE'    then ContentRange    := s else // 14.17
  496.   if z = 'CONTENT-TYPE'     then ContentType     := s else // 14.18
  497.   if z = 'ETAG'             then ETag            := s else // 14.20
  498.   if z = 'EXPIRES'          then Expires         := s else // 14.21
  499.   if z = 'LAST-MODIFIED'    then LastModified    := s else // 14.29
  500.   if z = 'STATUS'           then CGIStatus       := s else
  501.   if z = 'LOCATION'         then CGILocation     := s else
  502.     Result := False;
  503. end;
  504.  
  505. constructor THTTPData.Create;
  506. begin
  507.   inherited Create;
  508.   RequestCollector := TCollector.Create;
  509.   RequestGeneralHeader := TGeneralHeader.Create;
  510.   RequestRequestHeader := TRequestHeader.Create;
  511.   RequestEntityHeader := TEntityHeader.Create;
  512. end;
  513.  
  514. destructor THTTPData.Destroy;
  515. begin
  516.   FreeObject(RequestCollector);
  517.   FreeObject(RequestGeneralHeader);
  518.   FreeObject(RequestRequestHeader);
  519.   FreeObject(RequestEntityHeader);
  520.   FreeObject(ResponseGeneralHeader);
  521.   FreeObject(ResponseResponseHeader);
  522.   FreeObject(ResponseEntityHeader);
  523.   ZeroHandle(FHandle);
  524.   inherited Destroy;
  525. end;
  526.  
  527. procedure TCollector.SetContentLength(i: Integer);
  528. begin
  529.   ContentLength := i;
  530.   GotEntityBody := ContentLength <= Length(EntityBody);
  531. end;
  532.  
  533. function TCollector.LineAvail: Boolean;
  534. begin
  535.   Result := Lines.Count > 0;
  536. end;
  537.  
  538. function TCollector.GetNextLine: string;
  539. begin
  540.   Result := Lines[0]; Lines.AtFree(0);
  541. end;
  542.  
  543. function TCollector.Collect(var Buf: THTTPServerThreadBufer; j: Integer): Boolean;
  544. var
  545.   i: Integer;
  546. begin
  547.   if not CollectEntityBody then
  548.   for i := 0 to j-1 do
  549.   begin
  550.     CollectStr := CollectStr + Buf[i];
  551.     if Copy(CollectStr, Length(CollectStr)-1, 2) = #13#10 then
  552.     begin
  553.       CollectStr := Copy(CollectStr, 1, Length(CollectStr)-2);
  554.       if CollectStr = '' then
  555.       begin
  556.         CollectEntityBody := True;
  557.         Dec(j, i+1);
  558.         if j > 0 then Move(Buf[i+1], Buf[0], j);
  559.         Break;
  560.       end else
  561.       begin
  562.         Lines.Add(CollectStr);
  563.         CollectStr := '';
  564.       end;
  565.     end;
  566.   end;
  567.  
  568.   if CollectEntityBody then
  569.   begin
  570.     if (CollectEntityBody) and (j>0) then
  571.     begin
  572.       i := Length(EntityBody);
  573.       SetLength(EntityBody, i+j);
  574.       Move(Buf, EntityBody[i+1], j);
  575.     end;
  576.     GotEntityBody := ContentLength <= Length(EntityBody);
  577.   end;
  578.   Result := True;
  579. end;
  580.  
  581. constructor TCollector.Create;
  582. begin
  583.   inherited Create;
  584.   Lines := TStringColl.Create;
  585. end;
  586.  
  587. destructor TCollector.Destroy;
  588. begin
  589.   FreeObject(Lines);
  590.   inherited Destroy;
  591. end;
  592.  
  593.  
  594. procedure TPipeWriteStdThread.Execute;
  595. var
  596.   j: DWORD;
  597.   slen: Integer;
  598. begin
  599.   slen := Length(s);
  600.   if slen > 0 then WriteFile(HPipe, s[1], slen, j, nil);
  601. end;
  602.  
  603. function DoCollect(Collector: TCollector; EntityHeader: TEntityHeader; j: Integer; Buffer: THTTPServerThreadBufer): Boolean;
  604. var
  605.   s,z: string;
  606. begin
  607.   Result := True;
  608.   if not Collector.Collect(Buffer, j) then Result := False else
  609.   if Collector.CollectEntityBody then
  610.   if not Collector.Parsed then
  611.   begin
  612.     Collector.Parsed := True;
  613.     while Collector.LineAvail do
  614.     begin
  615.       s := Collector.GetNextLine;
  616.       if Length(s)<4 then begin Result := False; Break end else
  617.       begin
  618.         GetWrdStrictUC(s, z);
  619.         Delete(z, Length(z), 1);
  620.         if not EntityHeader.Filter(z, s) then
  621.         begin
  622.           // New Feature !!!
  623.         end;
  624.       end;
  625.     end;
  626.     Collector.SetContentLength(StoI(EntityHeader.ContentLength));
  627.   end;
  628. end;
  629.  
  630. procedure TPipeReadErrThread.Execute;
  631. var
  632.   ss: ShortString;
  633.   j: DWORD;
  634. begin
  635.   repeat
  636.     if not ReadFile(HPipe, ss[1], 250, j, nil) then Break;
  637.     ss[0] := Char(j);
  638.     s := s + ss;
  639.   until Terminated;
  640. end;
  641.  
  642.  
  643. procedure TPipeReadStdThread.Execute;
  644. var
  645.   j: DWORD;
  646. begin
  647.   repeat
  648.     if not ReadFile(HPipe, Buffer^, CHTTPServerThreadBufSize, j, nil) then Break;
  649.     Error := not DoCollect(Collector, EntityHeader, j, Buffer^);
  650.     if Error then Break;
  651.     if (Collector.ContentLength > 0) and (Collector.GotEntityBody) then Break;
  652.   until Terminated ;
  653.   j := GetLastError
  654. end;
  655.  
  656. function ExecuteScript(const AExecutable, APath, AScript, AQueryParam, AEnvStr, AStdInStr: string; Buffer: THTTPServerThreadBufer; SelfThr: TThread; var ErrorMsg: string): TEntityHeader;
  657. var
  658.   SI: TStartupInfo;
  659.   PI: TProcessInformation;
  660.   Security: TSecurityAttributes;
  661.   Actually: DWORD;
  662.   si_r, si_w, so_r, so_w, se_r, se_w: THandle;
  663.   b: Boolean;
  664.   Collector: TCollector;
  665.   EntityHeader: TEntityHeader;
  666.   PipeReadStdThread: TPipeReadStdThread;
  667.   PipeWriteStdThread: TPipeWriteStdThread;
  668.   PipeReadErrThread: TPipeReadErrThread;
  669.   s: string;
  670. begin
  671.   Result := nil;
  672.  
  673.   with Security do
  674.   begin
  675.     nLength := SizeOf(TSecurityAttributes);
  676.     lpSecurityDescriptor := nil;
  677.     bInheritHandle := True;
  678.   end;
  679.  
  680.   CreatePipe(si_r, si_w, @Security, 0);
  681.   CreatePipe(so_r, so_w, @Security, 0);
  682.   CreatePipe(se_r, se_w, @Security, 0);
  683.  
  684.   FillChar(SI, SizeOf(SI), 0);
  685.   SI.CB := SizeOf(SI);
  686.   SI.dwFlags := STARTF_USESTDHANDLES or STARTF_USESHOWWINDOW;
  687.   SI.hStdInput := si_r;
  688.   SI.hStdOutput := so_w;
  689.   SI.hStdError := se_w;
  690.   SI.wShowWindow := SW_HIDE;
  691.   if AExecutable = AScript then s := AExecutable else s := AExecutable + ' ' + AScript;
  692.   if AQueryParam <> '' then s := s + ' ' + AQueryParam;
  693.   s := DelSpaces(s);
  694.   b := CreateProcess(
  695.     nil,                     // pointer to name of executable module
  696.     PChar(s),                // pointer to command line string
  697.     @Security,               // pointer to process security attributes
  698.     @Security,               // pointer to thread security attributes
  699.     True,                    // handle inheritance flag
  700.     CREATE_SUSPENDED,        // creation flags
  701.     PChar(AEnvStr),          // pointer to new environment block
  702.     PChar(APath),            // pointer to current directory name
  703.     SI,                      // pointer to STARTUPINFO
  704.     PI                       // pointer to PROCESS_INFORMATION
  705.   );
  706.  
  707.   if not b then
  708.   begin
  709.     ErrorMsg := SysErrorMsg(GetLastError);
  710.     CloseHandles([si_r, si_w, so_r, so_w, se_r, se_w]);
  711.     Exit;
  712.   end;
  713.  
  714.   if AStdInStr = '' then
  715.   begin
  716.     PipeWriteStdThread := nil;
  717.   end else
  718.   begin
  719.     PipeWriteStdThread := TPipeWriteStdThread.Create(True);
  720.     PipeWriteStdThread.s := AStdInStr;
  721.     PipeWriteStdThread.HPipe := si_w;
  722.     PipeWriteStdThread.Suspended := False;
  723.   end;
  724.  
  725.   PipeReadErrThread := TPipeReadErrThread.Create(True);
  726.   PipeReadErrThread.HPipe := se_r;
  727.   PipeReadErrThread.Suspended := False;
  728.  
  729.   Collector := TCollector.Create;
  730.   EntityHeader := TEntityHeader.Create;
  731.   PipeReadStdThread := TPipeReadStdThread.Create(True);
  732.   PipeReadStdThread.Priority := tpLower;
  733.   PipeReadStdThread.Collector := Collector;
  734.   PipeReadStdThread.EntityHeader := EntityHeader;
  735.   PipeReadStdThread.Buffer := @Buffer;
  736.   PipeReadStdThread.HPipe := so_r;
  737.   PipeReadStdThread.Suspended := False;
  738.  
  739.   SelfThr.Priority := tpLowest;
  740.   ResumeThread(PI.hThread);
  741.   WaitForSingleObject(PI.hProcess, INFINITE);
  742.   CloseHandle(PI.hThread);
  743.   CloseHandle(PI.hProcess);
  744.  
  745. // Close StdIn
  746.   CloseHandle(si_r);
  747.   if PipeWriteStdThread = nil then
  748.   begin
  749.     CloseHandle(si_w);
  750.   end else
  751.   begin
  752.     WaitForSingleObject(PipeWriteStdThread.Handle, INFINITE);
  753.     PipeWriteStdThread.Terminate;
  754.     FreeObject(PipeWriteStdThread);
  755.     CloseHandle(si_w);
  756.   end;
  757.  
  758. // Close StdErr
  759.  
  760.   CloseHandle(se_w);
  761.   PipeReadErrThread.Terminate;
  762.   WaitForSingleObject(PipeReadErrThread.Handle, INFINITE);
  763.   ErrorMsg := PipeReadErrThread.s;
  764.   FreeObject(PipeReadErrThread);
  765.   CloseHandle(se_r);
  766.  
  767. // Close StdOut
  768.   PipeReadStdThread.Terminate;
  769.   CloseHandle(so_w);
  770.   WaitForSingleObject(PipeReadStdThread.Handle, INFINITE);
  771.   SelfThr.Priority := tpNormal;
  772.  
  773.   while not PipeReadStdThread.Error do
  774.   begin
  775.     if not ReadFile(so_r, Buffer, CHTTPServerThreadBufSize, Actually, nil) then Break;
  776.     PipeReadStdThread.Error := not DoCollect(Collector, EntityHeader, Actually, Buffer);
  777.     if (Collector.ContentLength > 0) and (Collector.GotEntityBody) then Break;
  778.   end;
  779.   CloseHandle(so_r);
  780.  
  781.   if PipeReadStdThread.Error or not Collector.GotEntityBody then FreeObject(Collector);
  782.   FreeObject(PipeReadStdThread);
  783.   if Collector = nil then FreeObject(EntityHeader) else
  784.   begin
  785.     if Collector.ContentLength = 0 then
  786.     begin
  787.       Collector.ContentLength := Length(Collector.EntityBody);
  788.       EntityHeader.ContentLength := ItoS(Collector.ContentLength);
  789.     end;
  790.     EntityHeader.CopyEntityBody(Collector);
  791.     FreeObject(Collector);
  792.     Result := EntityHeader;
  793.   end;
  794. end;
  795.  
  796. procedure AddAgentLog(const AAgent: string);
  797. var
  798.   s: string;
  799.   b: DWORD;
  800.   slen: Integer;
  801. begin
  802.   s := AAgent + #13#10;
  803.   EnterCriticalSection(CSAgentLog);
  804.   slen := Length(s);
  805.   WriteFile(HAgentLog, s[1], slen, b, nil);
  806.   LeaveCriticalSection(CSAgentLog);
  807. end;
  808.  
  809.  
  810. procedure AddRefererLog(const ARefererSrc, ARefererDst: string);
  811. var
  812.   s: string;
  813.   b: DWORD;
  814.   slen: Integer;
  815. begin
  816.   if ARefererSrc = '' then Exit;
  817.   s := ARefererSrc + ' -> ' + ARefererDst + #13#10;
  818.   EnterCriticalSection(CSRefererLog);
  819.   slen := Length(s);
  820.   WriteFile(HRefererLog, s[1], slen, b, nil);
  821.   LeaveCriticalSection(CSRefererLog);
  822. end;
  823.  
  824. function CurTime: string;
  825. var
  826.   lt: TSystemTime;
  827.   b: Integer;
  828.   s: string;
  829. begin
  830.   GetLocalTime(lt);
  831.   b := TimeZoneBias;
  832.   if b < 0 then begin b := -b; s := s+'+' end else s := s + '-';
  833.   b := b div 60;
  834.   Result := '['+
  835.         ItoSz(lt.wDay, 2) + '/' +
  836.         MonthE(lt.wMonth) + '/' +
  837.         ItoS(lt.wYear) + ':' +
  838.         ItoSz(lt.wHour,2) + ':' +
  839.         ItoSz(lt.wMinute,2) + ':' +
  840.         ItoSz(lt.wSecond, 2) + ' ' +
  841.         s +
  842.         ItoSz(b div 60, 2) +
  843.         ItoSz(b mod 60, 2) +
  844.         ']';
  845. end;
  846.  
  847. procedure AddAccessLog(const ARemoteHost, ARequestLine, AHTTPVersion, AUserName: string; AStatusCode, ALength: Integer);
  848. var
  849.   authuser,z,k: string;
  850.   b: DWORD;
  851.   slen: Integer;
  852. begin
  853.   if ALength = -1 then z := '-' else z := ItoS(ALength);
  854.   if AHTTPVersion = '' then k := '' else k := ' ' + AHTTPVersion;
  855.   if AUserName = '' then authuser := '-' else authuser := AUserName;
  856.   z := ARemoteHost +  // Remote hostname (or IP number if DNS hostname is not available)
  857.        ' - ' +        // rfc-931
  858.        authuser+' '+  // The username as which the user has authenticated himself
  859.        CurTime+' '+   // Date and time of the request
  860.        '"' + ARequestLine + k + '" ' +  // The request line exactly as it came from the client
  861.        ItoS(AStatusCode) + ' ' + // The HTTP status code returned to the client
  862.        z+             // The content-length of the document transferred
  863.        #13#10;
  864.   EnterCriticalSection(CSAccessLog);
  865.   slen := Length(z);
  866.   WriteFile(HAccessLog, z[1], slen, b, nil);
  867.   LeaveCriticalSection(CSAccessLog);
  868. end;
  869.  
  870. procedure AddErrorLog(const AErr: string);
  871. var
  872.   s: string;
  873.   b: DWORD;
  874.   slen: Integer;
  875. begin
  876.   s := CurTime + ' '+ AErr + #13#10;
  877.   EnterCriticalSection(CSErrorLog);
  878.   slen := Length(s);
  879.   WriteFile(HErrorLog, s[1], slen, b, nil);
  880.   LeaveCriticalSection(CSErrorLog);
  881. end;
  882.  
  883. constructor THttpResponseDataEntity.Create(AEntityHeader : TEntityHeader);
  884. begin
  885.   inherited Create;
  886.   FEntityHeader := AEntityHeader;
  887. end;
  888.  
  889. constructor THttpResponseErrorCode.Create(AErrorCode: Integer);
  890. begin
  891.   inherited Create;
  892.   FErrorCode := AErrorCode;
  893. end;
  894.  
  895. constructor THttpResponseDataFileHandle.Create(AHandle: THandle);
  896. begin
  897.   FHandle := AHandle
  898. end;
  899.  
  900. function OpenRequestedFile(const AFName: string; thr: THttpServerThread; d: THttpData): TAbstractHttpResponseData;
  901. var
  902.   I: Integer;
  903.   FHandle: THandle;
  904.   z: string;
  905. begin
  906. // Try to open Requested file
  907.   FHandle := _CreateFile(AFName, [cRead, cSequentialScan]);
  908.   if FHandle = INVALID_HANDLE_VALUE then
  909.   begin
  910.     AddErrorLog('access to '+AFName+' failed for '+thr.RemoteHost+', reason: '+SysErrorMsg(GetLastError));
  911.     Result := THttpResponseErrorCode.Create(404);
  912.     Exit;
  913.   end;
  914.   if not GetFileNfoByHandle(FHandle, d.FileNfo) then
  915.   begin
  916.     Result := THttpResponseErrorCode.Create(404);
  917.     Exit;
  918.   end;
  919.   z := LowerCase(CopyLeft(ExtractFileExt(AFName),2));
  920.   if z <> '' then
  921.   begin
  922.     if not ContentTypes.Search(@z, I) then z := '' else z := TContentType(ContentTypes.FList^[I]).ContentType;
  923.   end;
  924.   if z = '' then z := 'text/plain';
  925.   d.ResponseEntityHeader := TEntityHeader.Create;
  926.   d.ResponseEntityHeader.ContentType := z;
  927.   d.ResponseEntityHeader.EntityLength := d.FileNfo.Size;
  928.   d.ResponseEntityHeader.LastModified := FileTimeToStr(d.FileNfo.Time);
  929.   d.ResponseGeneralHeader.Date := FileTimeToStr(uGetSystemTime);
  930.   Result := THttpResponseDataFileHandle.Create(FHandle);
  931. end;
  932.  
  933. function GetEnvStr(thr: THttpServerThread; d: THttpData): string;
  934. var
  935.   s: string;
  936.   p: PByteArray;
  937.   j: Integer;
  938.  
  939.   procedure Add(const Name, Value: string); begin s := s + Name+'='+Value+#0 end;
  940.  
  941. begin
  942.   s := '';
  943.   p := Pointer(GetEnvironmentStrings);
  944.   j := 0; while (p^[j]<>0) or (p^[j+1]<>0) do Inc(j);
  945.   Inc(j);
  946.   SetLength(s, j);
  947.   Move(p^, s[1], j);
  948.   FreeEnvironmentStrings(Pointer(p));
  949.   Add('REMOTE_HOST', thr.RemoteHost);
  950.   Add('REMOTE_ADDR', thr.RemoteAddr);
  951.   Add('GATEWAY_INTERFACE', 'CGI/1.1');
  952.   Add('SCRIPT_NAME', d.URIPath);
  953.   Add('REQUEST_METHOD', d.Method);
  954.   Add('HTTP_ACCEPT', d.RequestRequestHeader.Accept);                     // Section 14.1
  955.   Add('HTTP_ACCEPT_CHARSET', d.RequestRequestHeader.AcceptCharset);      // Section 14.2
  956.   Add('HTTP_ACCEPT_ENCODING', d.RequestRequestHeader.AcceptEncoding);    // Section 14.3
  957.   Add('HTTP_ACCEPT_LANGUAGE', d.RequestRequestHeader.AcceptLanguage);    // Section 14.4
  958.   Add('HTTP_FROM', d.RequestRequestHeader.From);                         // Section 14.22
  959.   Add('HTTP_HOST', d.RequestRequestHeader.Host);                         // Section 14.23
  960.   Add('HTTP_REFERER', d.RequestRequestHeader.Referer);                   // Section 14.37
  961.   Add('HTTP_USER_AGENT', d.RequestRequestHeader.UserAgent);              // Section 14.42
  962.   Add('QUERY_STRING', d.URIQuery);
  963.   Add('SERVER_SOFTWARE', CServerName);
  964.   Add('SERVER_NAME', 'RIT Research Labs');
  965.   Add('SERVER_PROTOCOL', 'HTTP/1.0');
  966.   Add('SERVER_PORT', ItoS(thr.Socket.FPort));
  967.   Add('CONTENT_TYPE', d.RequestEntityHeader.ContentType);
  968.   Add('CONTENT_LENGTH', d.RequestEntityHeader.ContentLength);
  969.   Add('USER_NAME', d.AuthUser);
  970.   Add('USER_PASSWORD', d.AuthPassword);
  971.   Add('AUTH_TYPE', d.AuthType);
  972.   Result := s + #0;
  973. end;
  974.  
  975. function ReturnNewLocation(const ALocation: string; d: THTTPData): TAbstractHttpResponseData;
  976. begin
  977.   d.ResponseResponseHeader.Location := ALocation;
  978.   Result := THttpResponseErrorCode.Create(302);
  979. end;
  980.  
  981. function IsURL(const s: string): Boolean;
  982. begin
  983.   Result := Pos('://', s) > 0;
  984. end;
  985.  
  986. function WebServerHttpResponse(thr: THttpServerThread; d: THTTPData): TAbstractHttpResponseData;
  987. var
  988.   sPath, sName, sExt,
  989.   s,
  990.   {$IFDEF REAMS}
  991.   z, k, RealmPath,
  992.   MC: TMimeCoder;
  993.   {$ENDIF}
  994.  
  995.   LocalFName: string;
  996.   ii: Integer;
  997.   ResponseEntityHeader: TEntityHeader;
  998.  
  999.  
  1000. {$IFDEF REALMS}
  1001. function CheckRealms: TAbstractHttpResponseData;
  1002. var
  1003.   iii: Integer;
  1004. begin
  1005.   Result := nil;
  1006.   for iii := 0 to RealmPaths.Count-1 do
  1007.   begin
  1008.     RealmPath := RealmPaths[iii];
  1009.     while RealmPath <> '' do
  1010.     begin
  1011.       GetWrd(RealmPath, z, '|');
  1012.       if MatchMask(d.URIPath, z) then
  1013.       begin
  1014.         if (d.AuthUser = '') or (d.AuthPassword = '') then
  1015.         begin
  1016.           if d.ResponseResponseHeader = nil then d.ResponseResponseHeader := TResponseHeader.Create;
  1017.           d.ResponseResponseHeader.WWWAuthenticate := 'Basic realm="'+RealmNames[iii]+'"';
  1018.           Result := THttpResponseErrorCode.Create(401);
  1019.           Exit;
  1020.         end else
  1021.         begin
  1022.           s := RealmUsers[iii];
  1023.           z := ''; k := '';
  1024.           while s <> '' do
  1025.           begin
  1026.             GetWrd(s, z, ' ');
  1027.             GetWrd(z, k, '|');
  1028.             if (k = d.AuthUser) and (z = d.AuthPassword) then Exit;
  1029.           end;
  1030.           Result := THttpResponseErrorCode.Create(401);
  1031.           Exit;
  1032.         end;
  1033.       end;
  1034.     end;
  1035.   end;
  1036. end;
  1037. {$ENDIF}
  1038.  
  1039. procedure Exec;
  1040. begin
  1041.   ResponseEntityHeader := ExecuteScript(s, sPath, LocalFName, d.URIQueryParam, GetEnvStr(thr, d), d.RequestEntityHeader.EntityBody, thr.Buffer, thr, d.ErrorMsg);
  1042. end;
  1043.  
  1044. begin
  1045.   ResponseEntityHeader := nil;
  1046.   s := d.URIPath;
  1047.  
  1048.   Replace('/', '\', s);
  1049.   if (s='') or (s[1]<>'\') then
  1050.   begin
  1051.     Result := THttpResponseErrorCode.Create(403);
  1052.     Exit;
  1053.   end;
  1054.   if (Pos('..', s)>0) or
  1055.      (Pos(':',s)>0) or
  1056.      (Pos('\\',s)>0) then
  1057.   begin
  1058.     Result := THttpResponseErrorCode.Create(403);
  1059.     Exit;
  1060.   end;
  1061.  
  1062.   if s[Length(s)]='\' then s := s + CIndexFile else
  1063.   if ExtractFileExt(s) = '' then
  1064.   begin
  1065.     Result := ReturnNewLocation(d.URIpath+'/', d);
  1066.     Exit;
  1067.   end;
  1068.  
  1069.   LocalFName := ParamStr1 + s;
  1070.  
  1071. {$IFDEF REALMS}
  1072.   if d.RequestRequestHeader.Authorization <> '' then
  1073.   begin
  1074.     s := d.RequestRequestHeader.Authorization;
  1075.     GetWrd(s, z, ' ');
  1076.     if LowerCase(z) <> 'basic' then
  1077.     begin
  1078.       Result := THttpResponseErrorCode.Create(401);
  1079.       Exit;
  1080.     end;
  1081.     GetWrd(s, z, ' ');
  1082.     MC := TMimeCoder.Create(bsBase64);
  1083.     SetLength(s, Length(z));
  1084.     ii := MC.Decode(z, s[1]);
  1085.     if ii = 0 then s := '' else SetLength(s, ii);
  1086.     FreeObject(MC);
  1087.     GetWrd(s, z, ':');
  1088.     d.AuthUser := z;
  1089.     d.AuthPassword := s;
  1090.     d.AuthType := 'Basic';
  1091.   end;
  1092.  
  1093.   Result := CheckRealms;
  1094.   if Result <> nil then Exit;
  1095. {$ENDIF}
  1096.  
  1097. // Analyze file extension
  1098.   if Copy(d.URIPath, 1, Length(ScriptsPath)) = ScriptsPath then
  1099.   begin
  1100.     if not FileExists(LocalFName) then d.ErrorMsg := SysErrorMsg(GetLastError) else
  1101.     begin
  1102.       FSplit(LocalFName, sPath, sName, sExt);
  1103.       if UpperCase(sExt) = '.EXE' then
  1104.       begin
  1105.         s := LocalFName;
  1106.         Exec;
  1107.       end else
  1108.       begin
  1109.         SetLength(s, 1000);
  1110.         ii := FindExecutable(PChar(LocalFName), PChar(sPath), @s[1]);
  1111.         if ii > 32 then
  1112.         begin
  1113.           SetLength(s, NulSearch(s[1]));
  1114.           if not FileExists(s) then
  1115.           begin
  1116.             d.ErrorMsg := SysErrorMsg(GetLastError) + ' ('+s+')';
  1117.           end else
  1118.           begin
  1119.             Exec;
  1120.           end;
  1121.         end else
  1122.         begin
  1123.           if ii = 31 then
  1124.           begin
  1125.             s := LocalFName;
  1126.             Exec;
  1127.           end else
  1128.           begin
  1129.             d.ErrorMsg := SysErrorMsg(ii);
  1130.   {          Result := THttpResponseErrorCode.Create(500);
  1131.             Exit;}
  1132.           end;
  1133.         end;
  1134.       end;
  1135.     end;
  1136.     if ResponseEntityHeader = nil then
  1137.     begin
  1138.       if d.ErrorMsg = '' then
  1139.       begin
  1140.         d.ErrorMsg := 'CGI script '+d.URIPath+' returned nothing';
  1141.       end else
  1142.       begin
  1143.         d.ErrorMsg := 'Internal Server Error: '+d.ErrorMsg;
  1144.       end;
  1145.       Result := THttpResponseErrorCode.Create(500);
  1146.     end else
  1147.     begin
  1148.       if ResponseEntityHeader.CGILocation <> '' then
  1149.       begin
  1150.         if IsURL(ResponseEntityHeader.CGILocation) then
  1151.         begin
  1152.           Result := ReturnNewLocation(ResponseEntityHeader.CGILocation, d);
  1153.         end else
  1154.         begin
  1155.           Result := OpenRequestedFile(ResponseEntityHeader.CGILocation, thr, d);
  1156.         end;
  1157.       end else
  1158.       begin
  1159.         Result := THttpResponseDataEntity.Create(ResponseEntityHeader);
  1160.       end;
  1161.     end;
  1162.     Exit;
  1163.   end;
  1164.  
  1165.   Result := OpenRequestedFile(LocalFName, thr, d);
  1166.  
  1167. end;
  1168.  
  1169. function HttpResponse(thr: THttpServerThread; d: THTTPData): TAbstractHttpResponseData;
  1170. begin
  1171.   Result := WebServerHttpResponse(thr, d);
  1172.   Exit;
  1173. end;
  1174.  
  1175. procedure THTTPServerThread.PrepareResponse(d: THTTPData);
  1176. var
  1177.   r: TAbstractHttpResponseData;
  1178.   rf: THttpResponseDataFileHandle absolute r;
  1179.   re: THttpResponseDataEntity absolute r;
  1180.   rc: THttpResponseErrorCode absolute r;
  1181. begin
  1182.   r := HttpResponse(Self, d);
  1183.   if r = nil then GlobalFail;
  1184.   if r is THttpResponseDataFileHandle then
  1185.   begin
  1186.     d.FHandle := rf.FHandle;
  1187.     d.TransferFile := True;
  1188.     d.ReportError := False;
  1189.     d.StatusCode := 200;
  1190.   end else
  1191.   if r is THttpResponseDataEntity then
  1192.   begin
  1193.     d.ResponseEntityHeader := re.FEntityHeader;
  1194.     d.ReportError := False;
  1195.     d.StatusCode := 200;
  1196.   end else
  1197.   if r is THttpResponseErrorCode then
  1198.   begin
  1199.     d.StatusCode := rc.FErrorCode;
  1200.   end else GlobalFail;
  1201.   FreeObject(r);
  1202. end;
  1203.  
  1204. procedure THTTPServerThread.Execute;
  1205. var
  1206.   FPOS: DWORD;
  1207.   i, j: Integer;
  1208.   s,z: string;
  1209.   d: THTTPData;
  1210.   AbortConnection: Boolean;
  1211.   Actually: DWORD;
  1212.  
  1213. begin
  1214.  
  1215.   if not Socket.Handshake then Exit;
  1216.  
  1217.   RemoteAddr := AddrInet(Socket.FAddr);
  1218.   RemoteHost := GetHostNameByAddr(Socket.FAddr);
  1219.  
  1220.   repeat
  1221.     AbortConnection := False;
  1222.     d := THTTPData.Create;
  1223.     d.StatusCode := 400;
  1224.     d.ReportError := True;
  1225.     d.ResponseGeneralHeader := TGeneralHeader.Create;
  1226.     if d.ResponseResponseHeader = nil then d.ResponseResponseHeader := TResponseHeader.Create;
  1227.     s := '';
  1228.     with d do repeat
  1229.  
  1230.       j := Socket.Read(Buffer, CHTTPServerThreadBufSize);
  1231.       if (j <= 0) or (Socket.Status <> 0) then Break;
  1232.  
  1233.       if not RequestCollector.Collect(Buffer, j) then Break;
  1234.       if not RequestCollector.CollectEntityBody then Continue;
  1235.  
  1236.       if not RequestCollector.Parsed then
  1237.       begin
  1238.         if not RequestCollector.LineAvail then Break;
  1239.         RequestCollector.Parsed := True;
  1240.  
  1241.     // Parse the request
  1242.         s := RequestCollector.GetNextLine;
  1243.  
  1244.         if not ProcessQuotes(s) then Break;
  1245.  
  1246.         GetWrdStrictUC(s, Method);    if s = '' then Break;
  1247.         GetWrdStrict(s, RequestURI);  if s = '' then Break;
  1248.         GetWrdStrict(s, HTTPVersion); if s <> '' then Break;
  1249.  
  1250.     // Parse HTTP version
  1251.         s := HTTPVersion;
  1252.         GetWrd(s, z, '/'); if z <> 'HTTP' then Break;
  1253.         GetWrd(s, z, '.');
  1254.         if not DigitsOnly(s) or not DigitsOnly(z) then Break;
  1255.         if not _Val(z, HttpVersionHi) then Break;
  1256.         if not _Val(s, HttpVersionLo) then Break;
  1257.  
  1258.         s := '';
  1259.         z := '';
  1260.  
  1261.         while RequestCollector.LineAvail do
  1262.         begin
  1263.           s := RequestCollector.GetNextLine;
  1264.           if Length(s)<4 then Break;
  1265.           GetWrdStrictUC(s, z);
  1266.           Delete(z, Length(z), 1);
  1267.           if not RequestGeneralHeader.Filter(z, s) and
  1268.              not RequestRequestHeader.Filter(z, s) and
  1269.              not RequestEntityHeader.Filter(z, s) then
  1270.           begin
  1271.             // New Feature !!!
  1272.           end;
  1273.  
  1274.           s := '';
  1275.           z := '';
  1276.         end;
  1277.  
  1278.         if (s <> '') or (z <> '') then Break;
  1279.         RequestCollector.SetContentLength(StoI(RequestEntityHeader.ContentLength));
  1280.       end;
  1281.  
  1282.       if not RequestCollector.GotEntityBody then Continue;
  1283.  
  1284.       // process intity body
  1285.       RequestEntityHeader.CopyEntityBody(RequestCollector);
  1286.  
  1287.       FreeObject(RequestCollector);
  1288.  
  1289.       KeepAlive := UpperCase(RequestGeneralHeader.Connection) = 'KEEP-ALIVE';
  1290.  
  1291.       if (Method <> 'GET') and
  1292.          (Method <> 'POST') and
  1293.          (Method <> 'HEAD') then
  1294.       begin
  1295.         StatusCode := 403;
  1296.         Break;
  1297.       end else
  1298.       begin
  1299.  
  1300.     // Parse URI
  1301.         s := RequestURI;
  1302.         {$IFDEF DEBUG}
  1303.         if s = '/exit/now' then DebugExit := True;
  1304.         {$ENDIF}
  1305.         i := Pos('?', s);
  1306.         if i > 0 then
  1307.         begin
  1308.           URIQuery := CopyLeft(s, i+1);
  1309.           DeleteLeft(s, i);
  1310.           if Pos('=', URIQuery) = 0 then
  1311.           begin
  1312.             URIQueryParam := URIQuery;
  1313.             if not UnpackPchars(URIQueryParam) then Break;
  1314.           end;
  1315.         end;
  1316.         i := Pos(';', s);
  1317.         if i > 0 then
  1318.         begin
  1319.           URIParams := CopyLeft(s, i+1);
  1320.           DeleteLeft(s, i);
  1321.         end;
  1322.         if not UnpackPchars(s) then Break;
  1323.         URIPath := s;
  1324.  
  1325.         AddRefererLog(d.RequestRequestHeader.Referer, d.URIPath);
  1326.         AddAgentLog(d.RequestRequestHeader.UserAgent);
  1327.  
  1328.         PrepareResponse(d);
  1329.  
  1330.         Break;
  1331.       end;
  1332.     until False;
  1333.  
  1334.   // Send a response
  1335.     with d do
  1336.     begin
  1337.       if ResponseEntityHeader = nil then ResponseEntityHeader := TEntityHeader.Create;
  1338.  
  1339.       if TransferFile and (RequestRequestHeader.IfModifiedSince <> '') then
  1340.       begin
  1341.         Actually := StrToFileTime(RequestRequestHeader.IfModifiedSince);
  1342.         if (Actually <> INVALID_FILE_TIME) and (StrToFileTime(ResponseEntityHeader.LastModified) = Actually) then
  1343.         begin
  1344.           ZeroHandle(FHandle);
  1345.           TransferFile := False;
  1346.           StatusCode := 304;
  1347.           ReportError := True;
  1348.         end;
  1349.       end;
  1350.  
  1351.       s := ResponseEntityHeader.CGIStatus;
  1352.       if s <> '' then
  1353.       begin
  1354.         ReportError := True;
  1355.       end else
  1356.       begin
  1357.  // Get Status Line
  1358.         for i := 0 to MaxStatusCodeIdx do if StatusCode = StatusCodes[i].Code then
  1359.         begin
  1360.           s := StatusCodes[i].Msg;
  1361.           Break;
  1362.         end;
  1363.         if s = '' then GlobalFail;
  1364.         if ErrorMsg = '' then ErrorMsg := s;
  1365.         s := ItoS(StatusCode)+ ' '+ s;
  1366.       end;
  1367.       if ReportError then
  1368.       begin
  1369.         KeepAlive := False;
  1370.         ResponseEntityHeader.ContentType := 'text/html';
  1371.         ResponseEntityHeader.EntityBody :=
  1372.           '<HTML>'+
  1373.           '<TITLE>'+s+'</TITLE>'+
  1374.           '<BODY><H1>'+ErrorMsg+'</H1></BODY>'+
  1375.           '</HTML>';
  1376.         ResponseEntityHeader.EntityLength := Length(ResponseEntityHeader.EntityBody);
  1377.       end;
  1378.  
  1379.       ResponseEntityHeader.ContentLength := ItoS(ResponseEntityHeader.EntityLength);
  1380.  
  1381.       if KeepAlive then ResponseGeneralHeader.Connection := 'Keep-Alive';
  1382.  
  1383.       ResponseResponseHeader.Server := CServerName;
  1384.  
  1385.       if ReportError then i := -1 else i := ResponseEntityHeader.EntityLength;
  1386.       AddAccessLog(RemoteHost, Method + ' ' + URIPath, HTTPVersion, d.AuthUser, StatusCode,  i);
  1387.  
  1388.       s := 'HTTP/1.0 '+ s + #13#10+
  1389.         ResponseGeneralHeader.OutString+
  1390.         ResponseResponseHeader.OutString+
  1391.         ResponseEntityHeader.OutString+
  1392.         #13#10;
  1393.  
  1394.       if TransferFile then
  1395.       begin
  1396.         Socket.WriteStr(s);
  1397.         FPOS := 0;
  1398.         repeat
  1399.           ReadFile(FHandle, Buffer, CHTTPServerThreadBufSize, Actually, nil);
  1400.           Inc(FPOS, Actually);
  1401.           if FPOS > FileNfo.Size then Break;
  1402.           if Actually = 0 then Break;
  1403.           Actually := Socket.Write(Buffer, Actually);
  1404.         until (FPOS = FileNfo.Size) or (Actually < CHTTPServerThreadBufSize) or (Socket.Status <> 0);
  1405.         if FPOS <> FileNfo.Size then AbortConnection := True;
  1406.         ZeroHandle(FHandle);
  1407.       end else
  1408.       begin
  1409.         s := s + ResponseEntityHeader.EntityBody;
  1410.         Socket.WriteStr(s);
  1411.       end;
  1412.       AbortConnection := AbortConnection or not KeepAlive;
  1413.     end;
  1414.     FreeObject(d);
  1415.   until AbortConnection
  1416. end;
  1417.  
  1418.  
  1419. function TContentTypeColl.Compare(Key1, Key2: Pointer): Integer;
  1420. begin
  1421.   Compare := CompareStr(PString(Key1)^, PString(Key2)^);
  1422. end;
  1423.  
  1424. function TContentTypeColl.KeyOf(Item: Pointer): Pointer;
  1425. begin
  1426.   Result := @TContentType(Item).Extension;
  1427. end;
  1428.  
  1429. procedure GetContentTypes(const CBase, SubName: string; Swap: Boolean);
  1430. const
  1431.   ClassBufSize = 1000;
  1432. var
  1433.   Buf: array[0..ClassBufSize] of Char;
  1434.   r: TContentType;
  1435.   s, z, t : string;
  1436.   ec,
  1437.   i: Integer;
  1438.   Key,
  1439.   SubKey,
  1440.   BufSize,                       // size of string buffer
  1441.   cSubKeys,                      // number of subkeys
  1442.   cchMaxSubkey,                  // longest subkey name length
  1443.   cchMaxClass,                   // longest class string length
  1444.   cValues,                       // number of value entries
  1445.   cchMaxValueName,               // longest value name length
  1446.   cbMaxValueData,                // longest value data length
  1447.   cbSecurityDescriptor: DWORD;   // security descriptor length
  1448.   ftLastWriteTime: TFileTime;    // last write time
  1449. begin
  1450.   Key := OpenRegKeyEx(CBase, KEY_QUERY_VALUE or KEY_ENUMERATE_SUB_KEYS);
  1451.   BufSize := ClassBufSize;
  1452.   ec := RegQueryInfoKey(
  1453.     Key,                        // handle of key to query
  1454.     @Buf,
  1455.     @BufSize,
  1456.     nil,
  1457.     @cSubKeys,
  1458.     @cchMaxSubkey,
  1459.     @cchMaxClass,
  1460.     @cValues,
  1461.     @cchMaxValueName,
  1462.     @cbMaxValueData,
  1463.     @cbSecurityDescriptor,
  1464.     @ftLastWriteTime);
  1465.   if ec <> ERROR_SUCCESS then
  1466.   begin
  1467.     RegCloseKey(Key);
  1468.     Exit
  1469.   end;
  1470.   for i := 0 to cSubKeys-1 do
  1471.   begin
  1472.     BufSize := ClassBufSize;
  1473.     ec := RegEnumKeyEx(
  1474.       Key,
  1475.       i,
  1476.       Buf,
  1477.       BufSize,
  1478.       nil,
  1479.       nil, // address of buffer for class string
  1480.       nil, // address for size of class buffer
  1481.       @ftLastWriteTime);
  1482.     if ec <> ERROR_SUCCESS then Continue;
  1483.     SetString(s, Buf, BufSize);
  1484.     SubKey := OpenRegKey(CBase+'\'+s);
  1485.     if SubKey = INVALID_REGISTRY_KEY then Continue;
  1486.     z := ReadRegString(SubKey, SubName);
  1487.     RegCloseKey(SubKey);
  1488.     if Swap then
  1489.     begin
  1490.       t := s;
  1491.       s := z;
  1492.       z := t;
  1493.     end;
  1494.     z := LowerCase(CopyLeft(z,2));
  1495.     if (z = '') or (s = '') then Continue;
  1496.     if ContentTypes.Search(@z, ec) then Continue;
  1497.     r := TContentType.Create;
  1498.     r.ContentType := s;
  1499.     r.Extension := z;
  1500.     ContentTypes.AtInsert(ec, r);
  1501.   end;
  1502.   RegCloseKey(Key);
  1503. end;
  1504.  
  1505. type
  1506.   TAdrB = packed record
  1507.     A, B, C, D: Byte;
  1508.   end;
  1509.  
  1510.  
  1511. function _Adr2Int(const s: string): DWORD;
  1512.  
  1513. var
  1514.   CPos: Integer;
  1515.   Error: Boolean;
  1516.  
  1517. function Get: Byte;
  1518. var
  1519.   C: Char;
  1520.   R: Integer;
  1521.   err: Boolean;
  1522. begin
  1523.   Result := 0;
  1524.   if Error then Exit;
  1525.   err := False;
  1526.   R := Ord(S[CPos])-48;
  1527.   Inc(CPos);
  1528.   C := S[CPos];
  1529.   if (C >= '0') and (C <= '9') then
  1530.   begin
  1531.     R := R * 10 + (Ord(C)-48); Inc(CPos);
  1532.     C := S[CPos];
  1533.     if (C >= '0') and (C <= '9') then begin R := R * 10 + (Ord(C)-48); Inc(CPos) end else err := C <> '.';
  1534.   end else err := C <> '.';
  1535.   if (R > 255) or (err) then
  1536.   begin
  1537.     Error := True;
  1538.     Exit;
  1539.   end;
  1540.   Inc(CPos);
  1541.   Result := R;
  1542. end;
  1543.  
  1544. var
  1545.   A: TAdrB;
  1546. begin
  1547.   Error := False;
  1548.   CPos := 1;
  1549.   A.A := Get;
  1550.   A.B := Get;
  1551.   A.C := Get;
  1552.   A.D := Get;
  1553.   if Error then Result := INADDR_NONE else Result := PInteger(@A)^;
  1554. end;
  1555.  
  1556. function Adr2Int(const s: string): Integer;
  1557. begin
  1558.   Result := _Adr2Int(s+'.');
  1559. end;
  1560.  
  1561.  
  1562. var
  1563.   BindPort, BindAddr: DWORD;
  1564.  
  1565. function GetHomeDir: Boolean;
  1566. var
  1567.   s: string;
  1568.   i: DWORD;
  1569. begin
  1570.   Result := False;
  1571.   if ParamCount < 1 then
  1572.   begin
  1573.     MessageBox(0, 'Path to home directory is absent!'#13#10+
  1574.                   'See READ.ME for details.'#13#10#13#10+
  1575.                   CServerName+' service failed to start.',
  1576.                   CServerName, CMB_FAILED);
  1577.     Exit;
  1578.   end;
  1579.   ParamStr1 := ParamStr(1);
  1580.   if ParamStr1[Length(ParamStr1)] = '\' then Delete(ParamStr1, Length(ParamStr1), 1);
  1581.   s := ParamStr1+'\'+CIndexFile;
  1582.   if not FileExists(s) then
  1583.   begin
  1584.     s := 'Access to "'+s+'" failed'#13#10'Reason: "'+SysErrorMsg(GetLastError)+'"'#13#10#13#10+
  1585.     CServerName+' service failed to start';
  1586.     MessageBox(0, PChar(s), CServerName, CMB_FAILED);
  1587.     Exit;
  1588.   end;
  1589.   BindPort := {$IFDEF DEF_SSL} 443 {$ELSE} 80 {$ENDIF};
  1590.   BindAddr := _INADDR_ANY;
  1591.   if ParamCount > 1 then
  1592.   begin
  1593.     i := Vl(ParamStr(2));
  1594.     if i <> INVALID_VALUE then BindPort := i;
  1595.   end;
  1596.   if ParamCount > 2 then
  1597.   begin
  1598.     i := Adr2Int(ParamStr(3));
  1599.     if i <> INVALID_VALUE then BindAddr := i;
  1600.   end;
  1601.   Result := True;
  1602. end;
  1603.  
  1604. procedure ReadContentTypes;
  1605. begin
  1606.   ContentTypes := TContentTypeColl.Create;
  1607.   GetContentTypes('SOFTWARE\Classes\MIME\Database\Content Type', 'Extension', False);
  1608.   GetContentTypes('SOFTWARE\Classes', 'Content Type', True);
  1609. end;
  1610.  
  1611. procedure InitLogs;
  1612. begin
  1613.   FAccessLog := 'access_log';
  1614.   FAgentLog := 'agent_log';
  1615.   FErrorLog := 'error_log';
  1616.   FRefererLog := 'referer_log';
  1617.   if not _LogOK(FAccessLog, HAccessLog) or
  1618.      not _LogOK(FAgentLog, HAgentLog) or
  1619.      not _LogOK(FErrorLog, HErrorLog) or
  1620.      not _LogOK(FRefererLog, HRefererLog) then GlobalFail;
  1621.   InitializeCriticalSection(CSAccessLog);
  1622.   InitializeCriticalSection(CSAgentLog);
  1623.   InitializeCriticalSection(CSErrorLog);
  1624.   InitializeCriticalSection(CSRefererLog);
  1625. end;
  1626.  
  1627. procedure InitReseterThread;
  1628. begin
  1629.   SocketsColl := TColl.Create;
  1630.   ResetterThread := TResetterThread.Create;
  1631. end;
  1632.  
  1633. procedure FreeDummyLibraries;
  1634. var
  1635.   I: Integer;
  1636. begin
  1637.   I := GetModuleHandle('OleAut32'); if I <> 0 then FreeLibrary(I);
  1638.   I := GetModuleHandle('Ole32'); if I <> 0 then FreeLibrary(I);
  1639.   I := GetModuleHandle('RPCRT4'); if I <> 0 then FreeLibrary(I);
  1640.   I := GetModuleHandle('AdvAPI32'); if I <> 0 then FreeLibrary(I);
  1641.   I := GetModuleHandle('GDI32'); if I <> 0 then FreeLibrary(I);
  1642.   I := GetModuleHandle('COMCTL32'); if I <> 0 then FreeLibrary(I);
  1643.   I := GetModuleHandle('USER32'); if I <> 0 then FreeLibrary(I);
  1644. end;
  1645.  
  1646. procedure MainLoop;
  1647. var
  1648.   J, err, ServerSocketHandle: Integer;
  1649.   NewSocketHandle: Integer;
  1650.   NewSocket: TSocket;
  1651.   NewThread: THTTPServerThread;
  1652.   WData: TWSAData;
  1653.   Addr: TSockAddr;
  1654.   s: string;
  1655. begin
  1656.   err := WSAStartup(MakeWord(1,1), WData);
  1657.   if err <> 0 then
  1658.   begin
  1659.     s := 'Failed to initialize WinSocket,error #'+ItoS(err);
  1660.     MessageBox(0, PChar(s), CServerName, CMB_FAILED);
  1661.     Halt;
  1662.   end;
  1663.   ServerSocketHandle := socket(PF_INET, SOCK_STREAM, IPPROTO_TCP);
  1664.   if ServerSocketHandle = INVALID_SOCKET then
  1665.   begin
  1666.     s := 'Failed to create a socket, Error #'+ItoS(WSAGetLastError);
  1667.     MessageBox(0, PChar(s), CServerName, CMB_FAILED);
  1668.     Halt;
  1669.   end;
  1670.  
  1671.   Addr.sin_family := AF_INET;
  1672.   Addr.sin_port := htons(BindPort);
  1673.   Addr.sin_addr.s_addr := BindAddr;
  1674.   if bind(ServerSocketHandle, Addr, SizeOf(Addr)) = SOCKET_ERROR then
  1675.   begin
  1676.     S := 'Failed to bind the socket, error #'+ItoS(WSAGetLastError)+'.'#13#10#13#10+
  1677.          'Probable reason is that another daemon is already running on the same port ('+ItoS(BindPort)+').';
  1678.     MessageBox(0, PChar(S), CServerName, CMB_FAILED);
  1679.     Halt;
  1680.   end;
  1681.  
  1682.   {$IFDEF DEF_SSL}
  1683.   xSSLeayInit;
  1684.   {$ENDIF DEF_SSL}
  1685.  
  1686.   InitReseterThread;
  1687.  
  1688.   listen(ServerSocketHandle, 5);
  1689.  
  1690.   FreeDummyLibraries;
  1691.  
  1692.   repeat
  1693.     J := SizeOf(Addr);
  1694.     {$IFDEF VER90}
  1695.     NewSocketHandle := accept(ServerSocketHandle, Addr, J);
  1696.     {$ELSE}
  1697.     NewSocketHandle := accept(ServerSocketHandle, @Addr, @J);
  1698.     {$ENDIF}
  1699.     if NewSocketHandle = INVALID_SOCKET then Exit;
  1700.     NewSocket := {$IFDEF DEF_SSL}TSSLSocket{$ELSE}TSocket{$ENDIF}.Create;
  1701.     NewSocket.Handle := NewSocketHandle;
  1702.     NewSocket.FAddr := Addr.sin_addr.s_addr;
  1703.     NewSocket.FPort := Addr.sin_port;
  1704.     if not NewSocket.Startup then FreeObject(NewSocket) else
  1705.     begin
  1706.       SocketsColl.Enter;
  1707.       if SocksCount = 0 then
  1708.       begin
  1709.         ResetterThread.TimeToSleep := SleepQuant;
  1710.         SetEvent(ResetterThread.oSleep);
  1711.       end;
  1712.       Inc(SocksCount);
  1713.       SocketsColl.Leave;
  1714.       NewThread := THTTPServerThread.Create;
  1715.       NewThread.FreeOnTerminate := True;
  1716.       NewThread.Socket := NewSocket;
  1717.       NewSocket.RegisterSelf;
  1718.       NewThread.Resume;
  1719.     end;
  1720.   until {$IFDEF DEBUG}DebugExit{$ELSE}False{$ENDIF};
  1721.   {$IFDEF DEBUG}
  1722.   CloseSocket(ServerSocketHandle);
  1723.   {$ENDIF}
  1724. end;
  1725.  
  1726. {$IFDEF REALMS}
  1727. function ReadRealms: Boolean;
  1728. var
  1729.   s, z, FName: string;
  1730.   FSize, Actually: DWORD;
  1731.   h: THandle;
  1732.   L: TStringColl;
  1733.   i: Integer;
  1734.  
  1735. procedure Failed;
  1736. begin
  1737.   s := 'Access to "'+FName+'" failed'#13#10'Reason: "'+SysErrorMsg(GetLastError)+'"'#13#10#13#10+CServerName+' service failed to start';
  1738.   MessageBox(0, PChar(s), CServerName, CMB_FAILED);
  1739. end;
  1740.  
  1741. begin
  1742.   Result := False;
  1743.   FName := ExtractFilePath(ParamStr(0))+'realms.cfg';
  1744.   h := _CreateFile(FName, [cRead, cExisting, cSequentialScan]);
  1745.   if h = INVALID_HANDLE_VALUE then
  1746.   begin
  1747.     if GetLastError = ERROR_FILE_NOT_FOUND then
  1748.     begin
  1749.       Result := True;
  1750.       Exit;
  1751.     end;
  1752.     Failed;
  1753.     Exit;
  1754.   end;
  1755.   FSize := GetFileSize(h, nil);
  1756.   if FSize = INVALID_FILE_SIZE then
  1757.   begin
  1758.     CloseHandle(h);
  1759.     Failed;
  1760.     Exit;
  1761.   end;
  1762.   if FSize = 0 then s := '' else
  1763.   begin
  1764.     SetLength(s, FSize);
  1765.     if (not ReadFile(h, s[1], FSize, Actually, nil)) or (FSize <> Actually) then
  1766.     begin
  1767.       CloseHandle(h);
  1768.       Failed;
  1769.       Exit;
  1770.     end;
  1771.   end;
  1772.   CloseHandle(h);
  1773.   L := TStringColl.Create;
  1774.   L.SetTextStr(s);
  1775.   Finalize(s);
  1776.   RealmPaths := TStringColl.Create;
  1777.   RealmNames := TStringColl.Create;
  1778.   RealmUsers := TStringColl.Create;
  1779.   for i := 0 to L.Count-1 do
  1780.   begin
  1781.     s := DelSpaces(L[i]);
  1782.     if s = '' then Continue;
  1783.     GetWrd(s, z, ' ');
  1784.     RealmPaths.Add(LowerCase(z));
  1785.     GetWrd(s, z, ' ');
  1786.     RealmNames.Add(z);
  1787.     RealmUsers.Add(s);
  1788.   end;
  1789.   FreeObject(L);
  1790.   Result := True;
  1791. end;
  1792. {$ENDIF}
  1793.  
  1794.  
  1795. procedure ComeOn;
  1796. begin
  1797.  
  1798. //--- Set Hight priority class
  1799. //  SetPriorityClass(GetCurrentProcess, HIGH_PRIORITY_CLASS);
  1800.  
  1801. //--- Get and validate a home directory
  1802.   if not GetHomeDir then Exit;
  1803.  
  1804. //--- Initialize xBase Module
  1805.   xBaseInit;
  1806.  
  1807. {$IFDEF REALMS}
  1808. //--- Read realms
  1809.   if not ReadRealms then Exit;
  1810. {$ENDIF}
  1811.  
  1812. //--- Read content types from registry and associate with file extensions
  1813.   ReadContentTypes;
  1814.  
  1815. // --- Open log files and initialize semaphores
  1816.   InitLogs;
  1817.  
  1818. // --- Perform main loop
  1819.   MainLoop;
  1820.  
  1821. // Non-debug version never exits :-)
  1822.  
  1823. {$IFDEF DEBUG}
  1824.   ResetterThread.Terminate;
  1825.   SetEvent(ResetterThread.oSleep);
  1826.   SocketsColl.Enter;
  1827.   for i := 0 to SocketsColl.Count-1 do shutdown(TSocket(SocketsColl[i]).Handle, 2);
  1828.   SocketsColl.Leave;
  1829.   while SocketsColl.Count > 0 do Sleep(1000);
  1830.   ResetterThread.TimeToSleep := SleepQuant;
  1831.   SetEvent(ResetterThread.oSleep);
  1832.   WaitForSingleObject(ResetterThread.Handle, INFINITE);
  1833.   FreeObject(ResetterThread);
  1834.   FreeObject(SocketsColl);
  1835.   FreeObject(ContentTypes);
  1836.   xBaseDone;
  1837.   CloseHandle(HAccessLog);
  1838.   CloseHandle(HAgentLog);
  1839.   CloseHandle(HErrorLog);
  1840.   CloseHandle(HRefererLog);
  1841.   DeleteCriticalSection(CSAccessLog);
  1842.   DeleteCriticalSection(CSAgentLog);
  1843.   DeleteCriticalSection(CSErrorLog);
  1844.   DeleteCriticalSection(CSRefererLog);
  1845.   {$ENDIF}
  1846. end;
  1847.  
  1848. end.
  1849.  
  1850.  
  1851.