📄 dxhttpservercore.pas

📁 Well known and usefull component for delphi 7
💻 PAS
📖 第 1 页 / 共 2 页
字号:
上一页 12
   fOnCommandTEXTSEARCH:=Value;
   AddBasicEvent ('TEXTSEARCH',Value) ;
end;

procedure TDXHTTPServerCore.SetOnCommandSPACEJUMP (value:HTTPTBasicEvent) ;
begin
   fOnCommandSPACEJUMP:=Value;
   AddBasicEvent ('SPACEJUMP',Value) ;
end;

procedure TDXHTTPServerCore.SetOnCommandSEARCH (value:HTTPTBasicEvent) ;
begin
   fOnCommandSEARCH:=Value;
   AddBasicEvent ('SEARCH',Value) ;
end;

procedure TDXHTTPServerCore.SetOnCommandOPTIONS (value:HTTPTBasicEvent) ;
begin
   fOnCommandOPTIONS:=Value;
   AddBasicEvent ('OPTIONS',Value) ;
end;

procedure TDXHTTPServerCore.SetOnCommandTRACE (value:HTTPTBasicEvent) ;
begin
   fOnCommandTRACE:=Value;
   AddBasicEvent ('TRACE',Value) ;
end;

procedure TDXHTTPServerCore.SetOnCommandCONNECT (value:HTTPTBasicEvent) ;
begin
   fOnCommandCONNECT:=Value;
   AddBasicEvent ('CONNECT',Value) ;
end;

procedure TDXHTTPServerCore.SetOnCommandPATCH (value:HTTPTBasicEvent) ;
begin
   fOnCommandPATCH:=Value;
   AddBasicEvent ('PATCH',Value) ;
end;

procedure TDXHTTPServerCore.ProcessSession (ClientThread:TDXClientThread) ;
var
   S,WS:string;
   HeaderInfo:PHeaderInfo;
   Loop:Integer;
   WasHandled:Boolean;
   OutData:Pointer;
   WantKeepAlive:Boolean;
   ManualTimeout:Comp;

   procedure NotHandled;
   begin
      ClientThread.Socket.Write (
         'HTTP/1.0 '+HeaderText (400) +#13#10+#13#10+
         '<html><head><title>Error</title>'+
         '<body><h1>Error</h1><hr><h3>Unsupported Method <B>"'+
         HeaderInfo.Method+'"</B></h3></body></head></html>') ;
   end;

   procedure BuildHeader (ClientHeader:string) ;
   var
      line,token1,token2:string;
      Error:Integer;
      Ch:Char;
      I:Integer;

      procedure AddToUnknown;
      begin
         if HeaderInfo^.Unknown='' then HeaderInfo^.Unknown:=token1+': '+line
         else HeaderInfo^.Unknown:=HeaderInfo^.Unknown+#13#10+token1+': '+line;
      end;

   begin
      line:=ClientHeader;
      with HeaderInfo^ do begin
         if RAW='' then begin
            RAW:=Line;
            Method:=Uppercase (FetchByChar (line,#32,False) ) ;
try
            URI:=EscapeDecode (FetchByChar (line,#32,False) ) ;
except
            URI:='/';
end;
            if CharPos ('?',URI) >0 then begin
               QueryString:=Copy (URI,CharPos ('?',URI) +1,Length (URI) ) ;
               Delete (URI,CharPos ('?',URI) ,Length (URI) ) ;
            end;
            Protocol:=FetchByChar (line,#32,False) ;
         end
         else begin
            token1:=Uppercase (FetchByChar (line,#32,False) ) ;
            // 4RC2
{            I:=Length(Token1);
            Setlength(Token2,I);
            While I>0 do Begin
               Case Token1[i] of
                  '-':Token2[i]:='_';
                  Else Token2[i]:=Token1[i];
               End;
               Dec(I);
            End;}
            // 5FRC
            Token2:=Token1;
            I:=CharPos('-',Token2);
            While I>0 do Begin
               Token2[I]:=#32;
               I:=CharPos('-',Token2);
            End;
            ALL_HTTP:=Concat(ALL_HTTP,'HTTP_',Token2,Line,#10);
//            ALL_HTTP:=ALL_HTTP+'HTTP_'+Token2+{#32+}Line+{#13}#10;
            Ch:=Token1[1];
            case Ch of
               'A':if token1='ACCEPT:' then Accept:=Accept+Line
                  else if token1='ACCEPT-CHARSET:' then AcceptCharset:=Line
                  else if token1='ACCEPT-ENCODING:' then AcceptEncoding:=Line
                  else if token1='ACCEPT-LANGUAGE:' then AcceptLanguage:=Line
                  else if token1='ALLOW:' then Allow:=Line
                  else if token1='AUTHORIZATION:' then begin
                     AuthType:=FetchByChar (line,#32,False) ;// Usually is "Basic"
                     token2:=FetchByChar (line,#32,False) ;
                     token2:=Base64ToString (token2) ;// Decode the "Basic" encoded string
                     AuthName:=FetchByChar (token2,':',False) ;
                     AuthPass:=FetchByChar (token2,';',False) ;// should actually be leftovers
                  end
                  else AddToUnknown;
               'C':if token1='CACHE-CONTROL:' then CacheControl:=Line
                  else if token1='CONNECTION:' then Connection:=Line
                  else if token1='CACHE-INFO:' then CacheInfo:=Line
                  else if token1='CONTENT-LENGTH:' then begin
                     Val (FetchByChar (line,#32,False) ,ContentLength,Error) ;
                  end
                  else if token1='CONTENT-TYPE:' then ContentType:=Line
                  else if token1='COOKIE:' then Cookie:=Line
                  else AddToUnknown;
               'D':if token1='DATE:' then Date:=Line
                  else AddToUnknown;
               'F':if token1='FROM:' then From:=Line
                  else if token1='FORWARDED:' then Forwarded:=Line
                  else if token1='FORWARDED-FOR:' then ForwardedFor:=Line
                  else AddToUnknown;
               'H':if token1='HOST:' then Host:=Line
                  else AddToUnknown;
               'I':if token1='IF-MODIFIED-SINCE:' then IfModSince:=Line
                  else if token1='IF-MATCH:' then IfMatch:=Line
                  else if token1='IF-NONE-MATCH:' then IfNoneMatch:=Line
                  else if token1='IF-RANGE:' then IfRange:=Line
                  else if token1='IF-UNMODIFIED-SINCE:' then IfUnModSince:=Line
                  else AddToUnknown;
               'K':if token1='KEEP-ALIVE:' then KeepAlive:=Line
                  else AddToUnknown;
               'M':if token1='MAX-FORWARDS:' then MaxForwards:=Line
                  else AddToUnknown;
               'P':if token1='PUBLIC:' then PublicCache:=Line
                  else if token1='PRAGMA:' then Pragma:=Line
                  else if token1='PROXY-CONNECTION:' then ProxyConnection:=Line
                  else if token1='PROXY-AUTHORIZATION:' then ProxyAuthorization:=Line
                  else AddToUnknown;
               'R':if token1='REFERER:' then Referer:=Line
                  else if token1='RANGE:' then Range:=Line
                  else AddToUnknown;
               'T':if token1='TRANSFER-ENCODING:' then TransferEncoding:=Line
                  else AddToUnknown;
               'U':if token1='UPGRADE:' then Upgrade:=Line
                  else if token1='USER-AGENT:' then UserAgent:=Trim (Line)
                  else AddToUnknown;
               'V':if token1='VIA:' then Via:=Line
                  else AddToUnknown;
               'W':if token1='WEFERER:' then Weferer:=Line
                  else if token1='WSER-AGENT:' then WserAgent:=Line
                  else AddToUnknown;
            else AddToUnknown;
            end;
         end;
      end;
   end;

   procedure ManuallyGetHost;
   begin
      with HeaderInfo^ do begin
         if Quickpos ('//',URI) >0 then begin
            Host:=Copy (URI,1,QuickPos ('//',URI) +1) ;
            Delete (URI,1,Length (Host) ) ;
         end;
         if URI<>'/' then begin
            Host:=Host+Copy (URI,1,CharPos ('/',URI) ) ;
            Delete (URI,1,CharPos ('/',URI) ) ;
         end;
      end;
   end;

begin
   New (HeaderInfo) ;
   repeat
      FillChar2(HeaderInfo^,SizeOf(HeaderInfo^),#0);
      with HeaderInfo^ do begin
         ClientAddr:=ClientThread.Socket.PeerIPAddress;
         ClientHost:=HeaderInfo^.ClientAddr;
         ContentLength:=0;
      end;
      fbForceAbort:=False;
      with ClientThread.Socket do begin
         if fSupportKeepAlive then ManualTimeout:=TimeCounter+Timeout
         else ManualTimeout:=Timecounter+5000;
         S:='';
         while (QuickPos (#13#10#13#10,S) =0) and
            (Length (S) <8192) and
            (ManualTimeout>TimeCounter) do begin
            WS:=ReadStr (-1) ;
            If Ws='' then Begin
               if (not Connected) then begin
                  Dispose (Headerinfo) ;
                  Exit;
               end;
               DoSleepEx(10);
            End
            Else S:=S+Ws;
         end;
         HeaderInfo^.All_RAW:=Copy(S,1,QuickPos(#13#10#13#10,S)-1);
         if (LastReadTimeout) or (S=''{new}) then begin
            Dispose (Headerinfo) ;
            Exit;
         end;
         while Length(S) >0 do begin
            Ws:=Copy (S,1,QuickPos (#13#10,S) -1) ;
            if assigned({$IFDEF TLS_EDITION}OnReadFilter{$ELSE}OnFilter{$ENDIF}) then begin
               Loop:=FilterRead (@WS[1],OutData,Length (WS) ,ClientThread) ;
               SetLength (WS,Loop) ;
               if Assigned (Outdata) then begin
                  FastMove (TDXBSArray (OutData^) ,WS[1],Loop) ;
{$IFDEF TLS_EDITION}OnReadFilter{$ELSE}OnFilter{$ENDIF}(ddFreePointer,nil,OutData,Loop,Loop,WasHandled,ClientThread) ;
               end;
            end;
         //SF_NOTIFY_READ_RAW_DATA
            if assigned (fDXISAPI) and (fDXISAPI.FilterCount>0) then
               fDXISAPI.ServerRawRead (WS,Length (WS) ) ;
            BuildHeader (Ws) ;
            Delete (S,1,Length (Ws) +2) ;
            if Copy (S,1,2) =#13#10 then begin//end of header
               HeaderInfo^.PostData:=Copy (S,3,Length (S) ) ;
               S:='';
            end;
         end;
         if HeaderInfo^.Host='' then ManuallyGetHost;
{
         Delete (HeaderInfo^.ALL_HTTP,Length (HeaderInfo^.ALL_HTTP) ,1) ;
         HeaderInfo^.ALL_HTTP:=HeaderInfo^.ALL_HTTP+#0;
}
         If Length (HeaderInfo^.ALL_HTTP)>0 then HeaderInfo^.ALL_HTTP[Length (HeaderInfo^.ALL_HTTP)]:=#0;
      //SF_NOTIFY_PREPROC_HEADERS
         if assigned (fDXISAPI) and (fDXISAPI.FilterCount>0) then
            fDXISAPI.ServerPreprocHeaderEvent (HeaderInfo) ;
         Loop:=0;
         WasHandled:=False;
         WantKeepAlive:=fSupportKeepAlive;
         while (Loop<fEventArray.Count) and (not WasHandled) do begin
            if PHTTPBasicEvent (fEventArray[Loop]) .Command=HeaderInfo^.Method then begin
               case PHTTPBasicEvent (fEventArray[Loop]) .Tag of
                  1:if Assigned (PHTTPBasicEvent (fEventArray[Loop]) .EventProcedure) then
                     HTTPTBasicEvent (PHTTPBasicEvent (fEventArray[Loop]) .EventProcedure) (ClientThread,HeaderInfo,WantKeepAlive) ;
               end;
               WasHandled:=True;
            end
            else Inc (Loop) ;
         end;
         if not WasHandled then begin
            if assigned (OnCommandOther) then OnCommandOther (ClientThread,HeaderInfo,WasHandled) ;
            if not WasHandled then NotHandled;
            WantKeepAlive:=False;
         end;
      end;
   //SF_NOTIFY_END_OF_REQUEST
      if assigned (fDXISAPI) and (fDXISAPI.FilterCount>0) then
         fDXISAPI.ServerEndOfRequest;
      if not fSupportKeepAlive then WantKeepAlive:=False;
// 624      if WantKeepAlive then ProcessWindowsMessageQueue;// 9/11/2002
   until (not WantKeepAlive) or (not ClientThread.Socket.Connected) ;
   Dispose (HeaderInfo) ;//2.4
   //SF_NOTIFY_END_OF_NET_SESSION
   if assigned (fDXISAPI) and (fDXISAPI.FilterCount>0) then
      fDXISAPI.ServerEndSession;
end;

function TDXHTTPServerCore.HeaderText (StatusCode:Integer) :string;
var
   Loop:Integer;

begin
   if StatusCode>404 then begin// divide and conquor
      Loop:=MaxStatusCodes;
      while StatusCodes[Loop].Code>StatusCode do Dec (Loop) ;
   end
   else begin
      Loop:=0;
      while StatusCodes[Loop].Code<StatusCode do Inc (Loop) ;
   end;
   if StatusCodes[Loop].Code=StatusCode then
      Result:=IntToStr (StatusCode) +#32+StatusCodes[Loop].Msg
   else
      Result:='500 Internal Server Error';
end;

procedure TDXHTTPServerCore.Start;
begin
   if assigned (fDXISAPI) and (fDXISAPI.FilterCount>0) then
      fDXISAPI.ServerStartEvent;
   inherited Start;
end;

procedure TDXHTTPServerCore.Stop;
begin
   if assigned (fDXISAPI) and (fDXISAPI.FilterCount>0) then begin
      fDXISAPI.ServerStopEvent;
   end;
   inherited Stop;
end;

end.
上一页 12
⌨️ 快捷键说明

复制代码 Ctrl + C
搜索代码 Ctrl + F
全屏模式 F11
切换主题 Ctrl + Shift + D
显示快捷键 ?
增大字号 Ctrl + =
减小字号 Ctrl + -