mORMot and Open Source friends
Artifact [722e896e3d]
Artifact [722e896e3d]
/// classes implementing HTTP/1.1 client and server protocol // - this unit is a part of the freeware Synopse framework, // licensed under a MPL/GPL/LGPL tri-license; version 1.9 unit SynCrtSock; { This file is part of Synopse SQLite3 database framework. Synopse SQLite3 database framework. Copyright (C) 2010 Arnaud Bouchez Synopse Informatique - http://synopse.info *** BEGIN LICENSE BLOCK ***** Version: MPL 1.1/GPL 2.0/LGPL 2.1 The contents of this file are subject to the Mozilla Public License Version 1.1 (the "License"); you may not use this file except in compliance with the License. You may obtain a copy of the License at http://www.mozilla.org/MPL Software distributed under the License is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for the specific language governing rights and limitations under the License. The Original Code is Synopse SQLite3 database framework. The Initial Developer of the Original Code is Arnaud Bouchez. Portions created by the Initial Developer are Copyright (C) 2010 the Initial Developer. All Rights Reserved. Contributor(s): Alternatively, the contents of this file may be used under the terms of either the GNU General Public License Version 2 or later (the "GPL"), or the GNU Lesser General Public License Version 2.1 or later (the "LGPL"), in which case the provisions of the GPL or the LGPL are applicable instead of those above. If you wish to allow use of your version of this file only under the terms of either the GPL or the LGPL, and not to allow others to use your version of this file under the terms of the MPL, indicate your decision by deleting the provisions above and replace them with the notice and other provisions required by the GPL or the LGPL. If you do not delete the provisions above, a recipient may use your version of this file under the terms of any one of the MPL, the GPL or the LGPL. ***** END LICENSE BLOCK ***** TCP/IP and HTTP/1.1 Client and Server *************************************** Initial version: 2009 May, by Arnaud Bouchez Version 1.4 - February 8, 2010 - whole Synopse SQLite3 database framework released under the GNU Lesser General Public License version 3, instead of generic "Public Domain" - fix a bug happening when multiple HTTP connections were opened and closed in the same program Version 1.5 - March 1, 2010 - new generic unix implementation, using libc sockets, in SynLibcSock.pas Version 1.9 - avoid some GPF during client deconnection when the server shut down } interface {$ifdef WITHPHD} {$define DOS} {$define NOSERVER} {$endif} { $define DEBUG2} { $define DEBUG23} {$ifdef DEBUG2} {.$define DEBUG} {$endif} {.$define WITHCHECKSUM} // checksum of TCP/IP content - already done in TCP protocol -> not necessary {.$define WITHSERVERTIME} // hack of the HTTP protocol to automaticaly set the Client CMOS clock from the server {.$define COMPRESS} // the content of all HTTP request is GZiped before sending if client allows it // - usefull only over the Internet with tiny bandwidth // - content of 4803 bytes is compressed into 700, and time is 440 us instead of 220 us {.$define COMPRESS_GZIP} // by default, compression is done with the deflate algorithm // - enable it if you need the oldest GZip format, a bit slowest (due to crc32) uses {$ifdef DOS} // use DWPL TCP/IP stack Hardware, {$ifdef DEBUG} //{$ifdef WITHPHD}Hardware, {$endif} WDosIP, {$endif} Threads, WDosClock, WDosSock, {$endif} {$ifdef MSWINDOWS} Windows, SynWinSock, {$else} Types, LibC, {$endif} SysUtils, Classes; type /// ansi string used for byte storage of all data in this unit {$ifdef UNICODE} TSockData = RawByteString; {$else} TSockData = type AnsiString; {$endif} {$ifndef FPC} /// FPC 64 compatibility integer type PtrInt = integer; /// FPC 64 compatibility pointer type PPtrInt = ^PtrInt; {$endif} /// exception thrown by the classes of this unit ECrtSocket = class(Exception) public constructor Create(const Msg: string); end; TCrtSocketClass = class of TCrtSocket; /// the available available network transport layer // - either TCP/IP, UDP/IP or Unix sockets TCrtSocketLayer = (cslTCP, cslUDP, cslUNIX); /// Fast low-level Socket implementation // - direct access to the OS (Windows, Linux, DWPL) network layer // - use Open constructor to create a client to be connected to a server // - use Bind constructor to initialize a server // - use direct access to low level Windows, Linux or DWPL network layer // - use SockIn and SockOut (after CreateSock*) to read or write data // as with standard Delphi text files (see SendEmail implementation) // - if app is multi-threaded, use faster SockSend() instead of SockOut^ // for direct write access to the socket; but SockIn^ is much faster than // SockRecv() thanks to its internal buffer, even on multi-threaded app // (at least under Windows, it may be up to 10 times faster) // - but you can decide whatever to use none, one or both SockIn/SockOut // - our classes are much faster than the Indy or Synapse implementation TCrtSocket = class public /// initialized after Open() with socket Sock: TSocket; /// initialized after Open() with Server name Server: AnsiString; /// initialized after Open() with port number Port: AnsiString; /// after CreateSockIn, use Readln(SockIn,s) to read a line from the opened socket SockIn: ^TextFile; /// after CreateSockOut, use Writeln(SockOut,s) to send a line to the opened socket SockOut: ^TextFile; /// if higher than 0, read loop will wait for incoming data till // TimeOut milliseconds (default value is 10000) - used also in SockSend() TimeOut: cardinal; /// total bytes received BytesIn, /// total bytes sent BytesOut: cardinal; /// connect to aServer:aPort constructor Open(const aServer, aPort: AnsiString; aLayer: TCrtSocketLayer=cslTCP); /// bind to aPort constructor Bind(const aPort: AnsiString; aLayer: TCrtSocketLayer=cslTCP); /// raise an ECrtSocket exception on error (called by above constructors) procedure OpenBind(const aServer, aPort: AnsiString; doBind: boolean; aSock: integer=-1; aLayer: TCrtSocketLayer=cslTCP); /// initialize SockIn for receiving with read[ln](SockIn^,...) // - data is buffered, filled as the data is available // - read(char) or readln() is indeed very fast // - multithread applications would also use this SockIn pseudo-text file procedure CreateSockIn; /// initialize SockOut for sending with write[ln](SockOut^,....) // - data is sent (flushed) after each writeln() - it's a compiler feature // - use rather SockSend() + SockSendFlush to send headers at once e.g. // since writeln(SockOut^,..) flush buffer each time procedure CreateSockOut; /// close the opened socket, and corresponding SockIn/SockOut destructor Destroy; override; /// read Length bytes from SockIn buffer + Sock if necessary // - if SockIn is available, it first gets data from SockIn^.Buffer, // then directly receive data from socket // - can be used also without SockIn: it will call directly SockRecv() in such case function SockInRead(Content: PAnsiChar; Length: integer): integer; /// check the connection status of the socket function SockConnected: boolean; /// wait till some data is pending in the receiving queue within TimeOut milliseconds // - returns >0 = exact data count pending in, if there is some data to be read // - returns 0 if there is no data to be read // - returns <0 on any socket error function SockCanRead(aTimeOut: cardinal): integer; {$ifndef DOS} // DWPL doesn't implement select() for send :( /// wait till some data can be sent within TimeOut milliseconds // - returns >0 if data can be written // - returns 0 if data can not be written // - returns <0 on any socket error function SockCanWrite(aTimeOut: cardinal): integer; {$endif} /// simulate writeln() with direct use of Send(Sock, ..) // - usefull on multi-treaded environnement (as in THttpServer.Process) // - no temp buffer is used // - handle TSockData, ShortString, Char, Integer parameters // - raise ECrtSocket exception on socket error procedure SockSend(const Values: array of const); overload; /// simulate writeln() with a single line procedure SockSend(const Line: TSockData=''); overload; /// flush all pending data to be sent procedure SockSendFlush; /// fill the Buffer with Length bytes // - use TimeOut milliseconds wait for incoming data // - bypass the SockIn^ buffers // - raise ECrtSocket exception on socket error procedure SockRecv(Buffer: pointer; Length: integer); /// returns the socket input stream as a string // - specify the Max time to wait until some data is available for reading // - if the TimeOut parameter is 0, wait until something is available function SockReceiveString(TimeOut : integer = 300): TSockData; /// fill the Buffer with Length bytes // - use TimeOut milliseconds wait for incoming data // - bypass the SockIn^ buffers // - return false on any error, true on success function TrySockRecv(Buffer: pointer; Length: integer): boolean; /// call readln(SockIn^,Line) or simulate it with direct use of Recv(Sock, ..) // - char are read one by one // - use TimeOut milliseconds wait for incoming data // - raise ECrtSocket exception on socket error procedure SockRecvLn(out Line: TSockData); overload; /// call readln(SockIn^) or simulate it with direct use of Recv(Sock, ..) // - char are read one by one // - use TimeOut milliseconds wait for incoming data // - raise ECrtSocket exception on socket error // - line content is ignored procedure SockRecvLn; overload; /// append P^ data into SndBuf (used by SockSend(), e.g.) // - call SockSendFlush to send it through the network via SndLow() procedure Snd(P: pointer; Len: integer); /// direct send data through network // - raise a ECrtSocket exception on any error // - bypass the SndBuf or SockOut^ buffers procedure SndLow(P: pointer; Len: integer); /// direct send data through network // - return false on any error, true on success // - bypass the SndBuf or SockOut^ buffers function TrySndLow(P: pointer; Len: integer): boolean; /// direct send data through network // - raise a ECrtSocket exception on any error // - bypass the SndBuf or SockOut^ buffers // - raw Data is sent directly to OS: no CR/CRLF is appened to the block procedure Write(const Data: TSockData); private SockInEof: boolean; /// updated by every Snd() SndBuf: TSockData; SndBufLen: integer; /// close and shutdown the connection (called from Destroy) procedure Close; end; /// parent of THttpClientSocket and THttpServerSocket classes // - contain properties for implementing the HTTP/1.1 protocol // - handle chunking of body content THttpSocket = class(TCrtSocket) protected /// true if the TRANSFER-ENCODING: CHUNKED was set in headers Chunked: boolean; {$ifdef COMPRESS} /// true if the GZIP protocol is inside the ACCEPT-ENCODING: header AcceptGZip: boolean; {$endif} procedure GetHeader; procedure GetBody; public /// will contain the first header line: // - 'GET /path HTTP/1.1' for a GET request with THttpServer, e.g. // - 'HTTP/1.0 200 OK' for a GET response after Get() e.g. Command: TSockData; /// will contain the header lines after a Request - use HeaderValue() to get one Headers: array of TSockData; /// will contain the data retrieved from the server, after the Request Content: TSockData; {$ifdef WITHCHECKSUM} /// same as HeaderValue('Content-Checksum'), but retrieved during Request // - if the communication is between a THttpServer and THttpClient, // the content is validated with a fast Adler32 checksum // - it's convenient for testing the custom DWPL TCP/IP stack ContentChecksum: cardinal; {$endif} /// same as HeaderValue('Content-Length'), but retrieved during Request ContentLength: integer; /// same as HeaderValue('Content-Type'), but retrieved during Request ContentType: TSockData; /// add an header entry, returning the just entered entry index in Headers[]s function HeaderAdd(const aValue: TSockData): integer; /// set all Header values at once, from CRLF delimited text procedure HeaderSetText(const aText: TSockData); /// get all Header values at once, as CRLF delimited text function HeaderGetText: TSockData; /// HeaderValue('Content-Type')='text/html', e.g. function HeaderValue(aName: TSockData): TSockData; end; {$ifndef NOSERVER} // without DWPL TCP/IP stack: server Thread /// HTTP/1.1 server class used by THttpServer main server Thread THttpServerSocket = class(THttpSocket) private {$ifdef WITHSERVERTIME} /// true if 'SERVER-TIME: ASK' in headers NeedServerTime: boolean; {$endif} public /// contains the method ('GET','POST'.. e.g.) after GetRequest() Method: TSockData; /// contains the URL ('/' e.g.) after GetRequest() URL: TSockData; /// true if the client is HTTP/1.1 and 'Connection: Close' is not set // (default HTTP/1.1 behavior is keep alive, unless 'Connection: Close' // is specified, cf. RFC 2068 page 108: "HTTP/1.1 applications that do not // support persistent connections MUST include the "close" connection option // in every message") KeepAliveClient: boolean; /// main object function called after aClientSock := Accept + Create: // - get initialize the socket with the supplied accepted socket // - caller will then use the GetRequest method below to // get the request procedure InitRequest(aClientSock: TSocket); /// main object function called after aClientSock := Accept + Create: // - get Command, Method, URL and Headers // - get sent data in Content (if ContentLength<>0) procedure GetRequest; end; {$endif} /// REST and HTTP/1.1 compatible client class // - this component is HTTP/1.1 compatible, according to RFC 2068 document // - the REST commands (GET/POST/PUT/DELETE) are directly available // - open connection with the server with inherited Open(server,port) function // - if KeepAlive>0, the connection is not broken: a further request (within // KeepAlive milliseconds) will use the existing connection if available, // or recreate a new one if the former is outdated or reset by server // (will retry only once); this is faster, uses less resources (especialy // under Windows), and is the recommended way to implement a HTTP/1.1 server // - on any error (timeout, connection closed) will retry once to get the value // - don't forget to use Free procedure when you are finished THttpClientSocket = class(THttpSocket) public /// by default, the client is identified as IE 5.5, which is very // friendly welcome by most servers :( // - you can specify a custom value here UserAgent: TSockData; /// after an Open(server,port), return 200 if OK, http status error otherwize - get // the page data in Content function Get(const url: TSockData; KeepAlive: cardinal=0; const header: TSockData=''): integer; /// after an Open(server,port), return 200 if OK, http status error otherwize - only // header is read from server: Content is always '', but Headers are set function Head(const url: TSockData; KeepAlive: cardinal=0; const header: TSockData=''): integer; /// after an Open(server,port), return 200,201,204 if OK, http status error otherwize function Post(const url, Data, DataType: TSockData; KeepAlive: cardinal=0; const header: TSockData=''): integer; /// after an Open(server,port), return 200,201,204 if OK, http status error otherwize function Put(const url, Data, DataType: TSockData; KeepAlive: cardinal=0; const header: TSockData=''): integer; /// after an Open(server,port), return 200,202,204 if OK, http status error otherwize function Delete(const url: TSockData; KeepAlive: cardinal=0; const header: TSockData=''): integer; /// low-level HTTP/1.1 request // - call by all REST methods above // - after an Open(server,port), return 200,202,204 if OK, http status error otherwize // - retry is false by caller, and will be recursively called with true to retry once function Request(const url, method: TSockData; KeepAlive: cardinal; const header, Data, DataType: TSockData; retry: boolean): integer; end; // without DWPL TCP/IP stack: {$ifndef NOSERVER} THttpServer = class; /// HTTP response Thread // - Execute procedure get the request and calculate the answer // - you don't have to overload the protected THttpServerResp Execute method: // override THttpServer.Request() function or, if you need a lower-level access // (change the protocol, e.g.) THttpServer.Process() method itself THttpServerResp = class(TThread) protected fServer: THttpServer; fServerSock: THttpServerSocket; fClientSock: TSocket; /// main thread loop: read request from socket, send back answer procedure Execute; override; public /// initialize the response thread for the corresponding incoming socket constructor Create(aSock: TSocket; aServer: THttpServer); /// release used socket and memory destructor Destroy; override; end; /// main server Thread // - bind to a port and listen to incoming requests // - assign this requests to THttpServerResp threads // - it implements a HTTP/1.1 compatible server, according to RFC 2068 specifications // - if the client is also HTTP/1.1 compatible, KeepAlive connection is handled: // multiple requests will use the existing connection and thread; // this is faster and uses less resources, especialy under Windows // - don't forget to use Free procedure when you are finished THttpServer = class(TThread) protected /// used to protect Process() call ProcessCS: TRTLCriticalSection; /// server main loop - don't change directly procedure Execute; override; /// this method is called on every new client connection, i.e. every time // a THttpServerResp thread is created with a new incoming socket procedure OnConnect; virtual; /// this method is called on every client disconnection to update stats procedure OnDisconnect; virtual; /// override this function in order to low-level process the request; // default process is to get headers, and call public function Request procedure Process(var ClientSock: THttpServerSocket); virtual; public /// contains the main server Socket // - it's a raw TCrtSocket, which only need a socket to be bound, listening // and accept incoming request // - THttpServerSocket are created on the fly for every request, then // a THttpServerResp thread is created for handling this THttpServerSocket Sock: TCrtSocket; /// will contain the total number of connection to the server // - it's the global count since the server started ServerConnectionCount: cardinal; /// time, in milliseconds, for the HTTP.1/1 connections to be kept alive; // default is 3000 ms ServerKeepAliveTimeOut: cardinal; /// create a Server Thread, binded and listening on a port; // raise a EHttpServer exception if binding failed constructor Create(const aPort: AnsiString); /// release all memory and handlers destructor Destroy; override; /// override this function to customize your http server: // - input: ClientSock.Headers contains the headers for the client request // - output: ClientSock.Headers to be sent back to the client // - output: ClientSock.ContentType to 'text/html' or proper type // - output: Data contains the data to be sent back to the client; // note that 'Content-Length:' header will be filled by length(Data) // - output: cardinal result of the function is the HTTP error code (200 if OK, e.g.) // - this function is called thread-safe by the THttpServerResp threads, // protected by a Critical Section in Process() function Request(var ClientSock: THttpServerSocket; var Data: TSockData): cardinal; virtual; abstract; end; {$endif} /// create a TCrtSocket, returning nil on error // (usefull to easily catch socket error exception ECrtSocket) function Open(const aServer, aPort: AnsiString): TCrtSocket; /// create a THttpClientSocket, returning nil on error // (usefull to easily catch socket error exception ECrtSocket) function OpenHttp(const aServer, aPort: AnsiString): THttpClientSocket; /// retrieve the content of a web page, using the HTTP/1.1 protocol function HttpGet(const server, port: AnsiString; const url: TSockData): TSockData; /// send an email using the SMTP protocol // - retry true on success function SendEmail(const Server: AnsiString; const From, CSVDest, Subject, Text: TSockData; const Headers: TSockData=''; const User: TSockData=''; const Pass: TSockData=''; const Port: AnsiString='25'): boolean; {$ifndef DOS} /// retrieve the IP adress from a computer name function ResolveName(const Name: AnsiString): AnsiString; {$endif} {$ifndef COMPRESS} /// simple Adler32 checksum implementation function Adler32(Adler: cardinal; p: pByte; Count: Integer): cardinal; {$endif} /// Base64 encoding of a string function Base64Encode(const s: TSockData): TSockData; /// Base64 decoding of a string function Base64Decode(const s: TSockData): TSockData; {$ifdef Win32} /// remotly get the MAC address of a computer, from its IP Address // - only works under Win2K and later // - return the MAC address as a 12 hexa chars ('0050C204C80A' e.g.) function GetRemoteMacAddress(const IP: AnsiString): TSockData; {$endif} implementation {$ifdef COMPRESS} uses SynZip; {$endif} {$ifndef COMPRESS} function Adler32(Adler: cardinal; p: pByte; Count: Integer): cardinal; // simple Adler32 checksum implementation // not that if COMPRESS is defined, we will use its faster adler32() asm var s1, s2: cardinal; i, n: integer; begin s1 := LongRec(Adler).Lo; s2 := LongRec(Adler).Hi; while Count>0 do begin if Count<5552 then n := Count else n := 5552; for i := 1 to n do begin inc(s1,p^); inc(p); inc(s2,s1); end; s1 := s1 mod 65521; s2 := s2 mod 65521; dec(Count,n); end; result := word(s1)+cardinal(word(s2)) shl 16; end; {$endif} function Hex2Dec(c: AnsiChar): byte; begin case c of 'A'..'Z': result := Ord(c) - (Ord('A') - 10); 'a'..'z': result := Ord(c) - (Ord('a') - 10); '0'..'9': result := Ord(c) - Ord('0'); else result := 255; end; end; // Base64 string encoding function Base64Encode(const s: TSockData): TSockData; procedure Encode(rp, sp: PAnsiChar; len: integer); const b64: array[0..63] of AnsiChar = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/'; var i: integer; c: cardinal; begin for i := 1 to len div 3 do begin c := ord(sp[0]) shl 16 + ord(sp[1]) shl 8 + ord(sp[2]); rp[0] := b64[(c shr 18) and $3f]; rp[1] := b64[(c shr 12) and $3f]; rp[2] := b64[(c shr 6) and $3f]; rp[3] := b64[c and $3f]; inc(rp,4); inc(sp,3); end; case len mod 3 of 1: begin c := ord(sp[0]) shl 16; rp[0] := b64[(c shr 18) and $3f]; rp[1] := b64[(c shr 12) and $3f]; rp[2] := '='; rp[3] := '='; end; 2: begin c := ord(sp[0]) shl 16 + ord(sp[1]) shl 8; rp[0] := b64[(c shr 18) and $3f]; rp[1] := b64[(c shr 12) and $3f]; rp[2] := b64[(c shr 6) and $3f]; rp[3] := '='; end; end; end; var len: integer; begin result:=''; len := length(s); if len = 0 then exit; SetLength(result, ((len + 2) div 3) * 4); Encode(pointer(result),pointer(s),len); end; function Base64Decode(const s: TSockData): TSockData; var i, j, len: integer; sp, rp: PAnsiChar; c, ch: integer; begin result:= ''; len := length(s); if (len = 0) or (len mod 4 <> 0) then exit; len := len shr 2; SetLength(result, len * 3); sp := pointer(s); rp := pointer(result); for i := 1 to len do begin c := 0; j := 0; while true do begin ch := ord(sp[j]); case chr(ch) of 'A'..'Z' : c := c or (ch - ord('A')); 'a'..'z' : c := c or (ch - (ord('a')-26)); '0'..'9' : c := c or (ch - (ord('0')-52)); '+' : c := c or 62; '/' : c := c or 63; else if j=3 then begin rp[0] := AnsiChar(c shr 16); rp[1] := AnsiChar(c shr 8); SetLength(result, len*3-1); exit; end else begin rp[0] := AnsiChar(c shr 10); SetLength(result, len*3-2); exit; end; end; if j=3 then break; inc(j); c := c shl 6; end; rp[0] := AnsiChar(c shr 16); rp[1] := AnsiChar(c shr 8); rp[2] := AnsiChar(c); inc(rp,3); inc(sp,4); end; end; {$ifndef DOS} function ResolveName(const Name: AnsiString): AnsiString; var l: TStringList; begin l := TStringList.Create; try // use AF_INET+PF_INET instead of AF_UNSPEC+PF_UNSPEC: IP6 is buggy! ResolveNameToIP(Name, AF_INET, PF_INET, SOCK_STREAM, l); if l.Count=0 then result := Name else result := AnsiString(l[0]); finally l.Free; end; end; {$endif} function CallServer(const Server, Port: AnsiString; doBind: boolean; aLayer: TCrtSocketLayer): TSocket; {$ifdef DOS} var SockAddr: TSockAddr; ServerIP: u_long; err, ServerPort: Integer; H: PHostEnt; ConnTimeout: Integer; begin result := -1; // mark error // Check Params val(Port,ServerPort,err); if err<>0 then exit; // Resolve Server IP ServerIP := inet_addr(pointer(Server)); if ServerIP = INADDR_ANY then begin // Doesn't seem to be an IP. Let's try to resolve it with DNS. H := gethostbyname(pointer(Server)); ServerIP := u_long(PInAddr(H^.h_addr^)^); if ServerIP = INADDR_NONE then exit; end; // Create socket to connect to the Server result := socket(PF_INET, SOCK_STREAM, IPPROTO_IP); if result<=0 then begin {$ifdef DEBUG} system.write('[PressAKey]'); readkey; {$endif} {$ifdef DEBUG2} system.Writeln('socket() error: ',WSAGetLastError);{$endif} exit; end; // Set Connect() timeout to 10 seconds (default is 5 seconds) ConnTimeout := 10000; SetSockOpt(result, SOL_SOCKET, SO_CONNTIMEOUT, ConnTimeout, SizeOf(ConnTimeout)); // Establish connection SockAddr.sin_family := PF_INET; SockAddr.sin_addr.S_addr := ServerIP; SockAddr.sin_port := Swap(ServerPort); if bind then begin // call bind if (WDosSock.Bind(result, SockAddr, SizeOf(SockAddr))<>0) or (Listen(result, SOMAXCONN)<>0) then begin CloseSocket(result); result := -1; end; end else if Connect(result, SockAddr, SizeOf(SockAddr))<>0 then begin {$ifdef DEBUG} system.write('[PressAKey]'); readkey; {$endif} {$ifdef DEBUG2} system.Writeln('connect() error: ',WSAGetLastError);{$endif} CloseSocket(result); result := -1; end; end; {$else} // not DOS: var Sin: TVarSin; IP: AnsiString; li: TLinger; SOCK_TYPE, IPPROTO: integer; {$ifndef MSWINDOWS} serveraddr: sockaddr; {$endif} begin result := -1; case aLayer of cslTCP: begin SOCK_TYPE := SOCK_STREAM; IPPROTO := IPPROTO_TCP; end; cslUDP: begin SOCK_TYPE := SOCK_DGRAM; IPPROTO := IPPROTO_UDP; end; cslUNIX: begin {$ifdef MSWINDOWS} exit; // not handled under Win32 {$else} // special version for UNIX sockets result := socket(AF_UNIX,SOCK_STREAM,0); if result<0 then exit; if doBind then begin fillchar(serveraddr,sizeof(serveraddr),0); http://publib.boulder.ibm.com/infocenter/iseries/v5r3/index.jsp?topic=/rzab6/rzab6uafunix.htm serveraddr. if (bind(result,@serveraddr,sizeof(serveraddr))<0) or (listen(result,SOMAXCONN)<0) then begin close(sd); result := -1; end; end; exit; {$endif} end; else exit; // make this stupid compiler happy end; IP := ResolveName(Server); // use AF_INET+PF_INET instead of AF_UNSPEC+PF_UNSPEC: IP6 is buggy! if SetVarSin(Sin, IP, Port, AF_INET, PF_INET, SOCK_TYPE, true)<>0 then exit; result := Socket(integer(Sin.AddressFamily), SOCK_TYPE, IPPROTO); if result=-1 then exit; if doBind then begin // Sockket should remain open for 1 second after a closesocket() call li.l_onoff := Ord(true); li.l_linger := 1; SetSockOpt(result, SOL_SOCKET, SO_LINGER, @li, SizeOf(li)); // bind and listen to this port if (Bind(result, Sin)<>0) or ((aLayer<>cslUDP) and (Listen(result, SOMAXCONN)<>0)) then begin CloseSocket(result); result := -1; end; end else if Connect(result,Sin)<>0 then begin CloseSocket(result); result := -1; end; end; {$endif} function OutputSock(var F: TTextRec): integer; var Index, Size: integer; Sock: TCRTSocket absolute F.Handle; begin if F.BufPos<>0 then begin result := -1; // on socket error -> raise ioresult error if (Sock=nil) or (Sock.Sock=-1) then exit; // file closed Index := 0; repeat Size := Send(Sock.Sock, @F.BufPtr[Index], F.BufPos, 0); if Size<=0 then exit; inc(Sock.BytesOut, Size); dec(F.BufPos,Size); inc(Index,Size); until F.BufPos=0; end; result := 0; // no error end; function InputSock(var F: TTextRec): Integer; // SockIn pseudo text file fill its internal buffer only with available data // -> no unwanted wait time is added // -> very optimized use for readln() in HTTP stream var Size: integer; Sock: TCRTSocket absolute F.Handle; begin F.BufEnd := 0; F.BufPos := 0; result := -1; // on socket error -> raise ioresult error if (Sock=nil) or (Sock.Sock=-1) then exit; // file closed = no socket -> error if Sock.TimeOut<>0 then begin // wait for pending data? Size := Sock.SockCanRead(Sock.TimeOut); // Size>0 if some data pending in if Size<=0 then begin // socket error or time out Sock.SockInEof := true; // mark end of SockIn if Size<0 then // socket error result := -WSAGetLastError; // update ioresult and raise {$I+} exception exit; end; IOCtlSocket(Sock.Sock, FIONREAD, Size); // get exact count if Size>integer(F.BufSize) then Size := F.BufSize; end else Size := F.BufSize; Size := Recv(Sock.Sock, F.BufPtr, Size, 0); // Recv() may return Size=0 if no data is pending, but no TCP/IP error if Size>=0 then begin F.BufEnd := Size; inc(Sock.BytesIn, Size); result := 0; // no error end else begin Sock.SockInEof := true; // error -> mark end of SockIn result := -WSAGetLastError; // result <0 will update ioresult and raise an exception if {$I+} end; end; function CloseSock(var F: TTextRec): integer; var Sock: TCRTSocket absolute F.Handle; begin if Sock<>nil then Sock.Close; Sock := nil; Result := 0; end; function OpenSock(var F: TTextRec): integer; begin F.BufPos := 0; F.BufEnd := 0; if F.Mode=fmInput then begin // ReadLn F.InOutFunc := @InputSock; F.FlushFunc := nil; end else begin // WriteLn F.Mode := fmOutput; F.InOutFunc := @OutputSock; F.FlushFunc := @OutputSock; end; F.CloseFunc := @CloseSock; Result := 0; end; { TCrtSocket } constructor TCrtSocket.Bind(const aPort: AnsiString; aLayer: TCrtSocketLayer=cslTCP); begin OpenBind('0.0.0.0',aPort,true,-1,aLayer); // raise an ECrtSocket exception on error end; constructor TCrtSocket.Open(const aServer, aPort: AnsiString; aLayer: TCrtSocketLayer); begin TimeOut := 5000; // default read timeout is 5 sec OpenBind(aServer,aPort,false,-1,aLayer); // raise an ECrtSocket exception on error end; procedure TCrtSocket.Close; begin if (SockIn<>nil) or (SockOut<>nil) then begin ioresult; // reset ioresult value if SockIn/SockOut were used if SockIn<>nil then begin TTextRec(SockIn^).BufPos := 0; // reset input buffer TTextRec(SockIn^).BufEnd := 0; end; if SockOut<>nil then begin TTextRec(SockOut^).BufPos := 0; // reset output buffer TTextRec(SockOut^).BufEnd := 0; end; end; if Sock=-1 then exit; // no opened connection to close Shutdown(Sock,1); CloseSocket(Sock); Sock := -1; // don't change Server or Port, since may try to reconnect end; procedure TCrtSocket.OpenBind(const aServer, aPort: AnsiString; doBind: boolean; aSock: integer=-1; aLayer: TCrtSocketLayer=cslTCP); begin if aPort='' then Port := '80' else // default port is 80 (HTTP) Port := aPort; if aSock<0 then Sock := CallServer(aServer,Port,doBind,aLayer) else // OPEN or BIND Sock := aSock; // ACCEPT mode -> socket is already created by caller if Sock=-1 then raise ECrtSocket.CreateFmt('Socket Creation error on %s:%s (%d)', [aServer,Port,WSAGetLastError]); Server := aServer; end; const CRLF: array[0..1] of AnsiChar = (#13,#10); procedure TCrtSocket.SockSend(const Values: array of const); var i: integer; tmp: shortstring; begin for i := 0 to high(Values) do with Values[i] do case VType of vtString: Snd(@VString^[1], pByte(VString)^); vtAnsiString: Snd(VAnsiString, length(TSockData(VAnsiString))); {$ifdef UNICODE} vtUnicodeString: begin tmp := shortstring(UnicodeString(VUnicodeString)); // convert into ansi (max length 255) Snd(@tmp[1],length(tmp)); end; {$endif} vtPChar: Snd(VPChar, StrLen(VPChar)); vtChar: Snd(@VChar, 1); vtWideChar: Snd(@VWideChar,1); // only ansi value vtInteger: begin Str(VInteger,tmp); Snd(@tmp[1],length(tmp)); end; end; Snd(@CRLF, 2); end; procedure TCrtSocket.SockSend(const Line: TSockData); begin if Line<>'' then Snd(pointer(Line),length(Line)); Snd(@CRLF, 2); end; procedure TCrtSocket.SockSendFlush; begin if SndBufLen=0 then exit; SndLow(pointer(SndBuf), SndBufLen); SndBufLen := 0; end; procedure TCrtSocket.SndLow(P: pointer; Len: integer); begin if not TrySndLow(P,Len) then raise ECrtSocket.Create('SndLow'); end; function TCrtSocket.TrySndLow(P: pointer; Len: integer): boolean; var SentLen: integer; begin result := false; if (self=nil) or (Len<=0) or (P=nil) then exit; {$ifndef DOS} if (TimeOut<>0) and (SockCanWrite(TimeOut)<=0) then exit; {$endif} repeat SentLen := Send(Sock, P, Len, 0); if SentLen<0 then exit; dec(Len,SentLen); if Len<=0 then break; inc(BytesOut,SentLen); inc(cardinal(P),SentLen); until false; result := true; end; procedure TCrtSocket.Write(const Data: TSockData); begin SndLow(pointer(Data),length(Data)); end; function TCrtSocket.SockCanRead(aTimeOut: cardinal): integer; {$ifdef DOS} // DWPL select() don't implement TimeOut -> do it here var TimeOut: Int64; begin TimeOut := GetMSCounter+aTimeOut; repeat IOCtlSocket(Sock, FIONREAD, result); if result>0 then // there is some data pending in exit; Yield; until GetMSCounter>TimeOut; result := 0; // time out end; {$else} var TimeV: TTimeVal; FDSet: TFDSet; begin // init select() parameters TimeV.tv_usec := (aTimeout mod 1024) * 1024; TimeV.tv_sec := aTimeout div 1024; FDSet.fd_count := 1; // is changed by select() -> recreate each time FDSet.fd_array[0] := Sock; // ask if any data pending in result := select(Sock+1, @FDSet, nil, nil, @TimeV); end; {$endif} {$ifndef DOS} // DWPL doesn't implement select() for send :( // -> we won't use this function with DWPL: it always allows to send data, // since the socket is connected function TCrtSocket.SockCanWrite(aTimeOut: cardinal): integer; var TimeV: TTimeVal; FDSet: TFDSet; begin // init select() parameters TimeV.tv_usec := (aTimeout mod 1024) * 1024; TimeV.tv_sec := aTimeout div 1024; FDSet.fd_count := 1; // is changed by select() -> recreate each time FDSet.fd_array[0] := Sock; // ask if any data can be written result := select(Sock+1, nil, @FDSet, nil, @TimeV); end; {$endif} function TCrtSocket.SockInRead(Content: PAnsiChar; Length: integer): integer; // read Length bytes from SockIn^ buffer + Sock if necessary begin // get data from SockIn buffer, if any (faster than ReadChar) if SockIn<>nil then with TTextRec(SockIn^) do begin result := BufEnd-BufPos; if result>0 then begin if result>Length then result := Length; move(BufPtr[BufPos],Content^,result); inc(BufPos,result); inc(Content,result); dec(Length,result); end; end else result := 0; // direct receiving of the triming bytes from socket if Length>0 then begin SockRecv(Content,Length); inc(result,Length); end; end; destructor TCrtSocket.Destroy; begin Close; if SockIn<>nil then Freemem(SockIn); if SockOut<>nil then Freemem(SockOut); inherited; end; procedure TCrtSocket.Snd(P: pointer; Len: integer); begin if Len<=0 then exit; if integer(SndBuf)=0 then if Len<2048 then // 2048 is about FASTMM4 small block size SetLength(SndBuf,2048) else SetLength(SndBuf,Len) else if Len+SndBufLen>pInteger(integer(SndBuf)-4)^ then SetLength(SndBuf,pInteger(integer(SndBuf)-4)^+Len+2048); move(P^,pointer(integer(SndBuf)+SndBufLen)^,Len); inc(SndBufLen,Len); end; const SOCKBUFSIZE = 1024; // big enough for headers (content will be read directly) procedure TCrtSocket.CreateSockIn; begin if SockIn<>nil then exit; // initialization already occured Getmem(SockIn,SOCKBUFSIZE+(sizeof(TTextRec)-sizeof(TTextBuf))); with TTextRec(SockIn^) do begin Handle := integer(self); Mode := fmClosed; BufSize := SOCKBUFSIZE; BufPtr := Buffer; OpenFunc := @OpenSock; end; SetLineBreakStyle(SockIn^,tlbsCRLF); // http does break lines with #13#10 Reset(SockIn^); end; procedure TCrtSocket.CreateSockOut; begin if SockOut<>nil then exit; // initialization already occured Getmem(SockOut,SOCKBUFSIZE+(sizeof(TTextRec)-sizeof(TTextBuf))); with TTextRec(SockOut^) do begin Handle := integer(self); Mode := fmClosed; BufSize := SOCKBUFSIZE; BufPtr := Buffer; OpenFunc := @OpenSock; end; SetLineBreakStyle(SockOut^,tlbsCRLF); Rewrite(SockOut^); end; procedure TCrtSocket.SockRecv(Buffer: pointer; Length: integer); begin if not TrySockRecv(Buffer,Length) then raise ECrtSocket.Create('SockRecv'); end; function TCrtSocket.TrySockRecv(Buffer: pointer; Length: integer): boolean; var Size: integer; begin result := false; if self=nil then exit; if (Buffer<>nil) and (Length>0) then repeat if TimeOut<>0 then begin // wait for pending data? Size := SockCanRead(TimeOut); // Size>0 if some data pending in if Size<=0 then // socket error or time out exit; end; Size := Recv(Sock, Buffer, Length, 0); if Size<=0 then exit; inc(BytesIn, Size); dec(Length,Size); inc(cardinal(Buffer),Size); until Length=0; result := true; end; procedure TCrtSocket.SockRecvLn(out Line: TSockData); procedure RecvLn(var Line: TSockData); var P: PAnsiChar; LP, L: integer; tmp: array[0..1023] of AnsiChar; // avoid ReallocMem() every char begin P := tmp; Line := ''; repeat SockRecv(P,1); // this is very slow under Windows -> use SockIn^ instead if P^<>#13 then // at least NCSA 1.3 does send a #10 only -> ignore #13 if P^=#10 then begin if Line='' then // get line SetString(Line,tmp,P-tmp) else begin LP := P-tmp; // append to already read chars L := length(Line); Setlength(Line,L+LP); move(tmp,pointer(integer(Line)+L)^,LP); end; exit; end else if P=@tmp[1023] then begin // tmp[] buffer full? L := length(Line); // -> append to already read chars Setlength(Line,L+1024); move(tmp,pointer(integer(Line)+L)^,1024); P := tmp; end else inc(P); until false; end; begin if SockIn<>nil then begin {$I-} readln(SockIn^,Line); // example: HTTP/1.0 200 OK if ioresult<>0 then raise ECrtSocket.Create('SockRecvLn'); {$I+} end else RecvLn(Line); // slow under Windows -> use SockIn^ instead end; procedure TCrtSocket.SockRecvLn; var c: AnsiChar; begin if SockIn<>nil then begin {$I-} readln(SockIn^); if ioresult<>0 then raise ECrtSocket.Create('SockRecvLn'); {$I+} end else repeat SockRecv(@c,1); until c=#10; end; function TCrtSocket.SockConnected: boolean; {$ifdef DOS} var SockAddr: TSockAddr; x: integer; begin x := sizeof(SockAddr); result := GetPeerName(Sock, SockAddr, x)=0; end; {$else} var Sin: TVarSin; begin result := GetPeerName(Sock,Sin)=0; end; {$endif} function TCrtSocket.SockReceiveString(TimeOut: integer): TSockData; var Size, L, Read: integer; begin result := ''; if self=nil then exit; if (TimeOut<>0) and (SockCanRead(TimeOut)<=0) then exit; L := 0; repeat sleep(1); if IOCtlSocket(Sock, FIONREAD, Size)<>0 then // get exact count exit; if Size=0 then if (TimeOut=0) and (result='') then begin // TimeOut=0 -> wait till something SockCanRead(100); // 100 ms delay in infinite loop continue; end else break; SetLength(result,L+Size); // append to result Read := recv(Sock,PAnsiChar(pointer(result))+L,Size,0); inc(L,Read); if Read<Size then SetLength(result,L); // e.g. Read=0 may happen until false; end; { THttpClientSocket } function THttpClientSocket.Delete(const url: TSockData; KeepAlive: cardinal; const header: TSockData): integer; begin result := Request(url,'DELETE',KeepAlive,header,'','',false); end; function THttpClientSocket.Get(const url: TSockData; KeepAlive: cardinal=0; const header: TSockData=''): integer; begin result := Request(url,'GET',KeepAlive,header,'','',false); end; function THttpClientSocket.Head(const url: TSockData; KeepAlive: cardinal; const header: TSockData): integer; begin result := Request(url,'HEAD',KeepAlive,header,'','',false); end; function THttpClientSocket.Post(const url, Data, DataType: TSockData; KeepAlive: cardinal; const header: TSockData): integer; begin result := Request(url,'POST',KeepAlive,header,Data,DataType,false); end; function THttpClientSocket.Put(const url, Data, DataType: TSockData; KeepAlive: cardinal; const header: TSockData): integer; begin result := Request(url,'PUT',KeepAlive,header,Data,DataType,false); end; {$ifndef WITHPHD} function IdemPChar(p, up: pAnsiChar): boolean; // if the beginning of p^ is same as up^ (ignore case - up^ must be already Upper) var c: AnsiChar; begin result := false; if (p=nil) or (up=nil) then exit; while up^<>#0 do begin c := p^; if up^<>c then if c in ['a'..'z'] then begin dec(c,32); if up^<>c then exit; end else exit; inc(up); inc(p); end; result := true; end; {$endif} function GetNextItem(var P: PAnsiChar; Sep: AnsiChar = ','): TSockData; // return next CSV string in P, nil if no more var S: PAnsiChar; begin if P=nil then result := '' else begin S := P; while (S^<>#0) and (S^<>Sep) do inc(S); SetString(result,P,S-P); if S^<>#0 then P := S+1 else P := nil; end; end; {$ifdef UNICODE} // rewrite some functions to avoid unncessary ansi<->unicode conversion function Trim(const S: TSockData): TSockData; asm // fast implementation by John O'Harrow test eax,eax {S = nil?} xchg eax,edx jz System.@LStrClr {Yes, Return Empty String} mov ecx,[edx-4] {Length(S)} cmp byte ptr [edx],' ' {S[1] <= ' '?} jbe @@TrimLeft {Yes, Trim Leading Spaces} cmp byte ptr [edx+ecx-1],' ' {S[Length(S)] <= ' '?} jbe @@TrimRight {Yes, Trim Trailing Spaces} jmp System.@LStrLAsg {No, Result := S (which occurs most time)} @@TrimLeft: {Strip Leading Whitespace} dec ecx jle System.@LStrClr {All Whitespace} inc edx cmp byte ptr [edx],' ' jbe @@TrimLeft @@CheckDone: cmp byte ptr [edx+ecx-1],' ' {$ifdef UNICODE} jbe @@TrimRight push 65535 // RawByteString code page for Delphi 2009/2010 call System.@LStrFromPCharLen // we need a call, not a direct jmp ret {$else} ja System.@LStrFromPCharLen {$endif} @@TrimRight: {Strip Trailing Whitespace} dec ecx jmp @@CheckDone end; function UpperCase(const S: TSockData): TSockData; procedure Upper(Source, Dest: PAnsiChar; L: cardinal); var Ch: AnsiChar; // this sub-call is shorter and faster than 1 plain proc begin repeat Ch := Source^; if (Ch >= 'a') and (Ch <= 'z') then dec(Ch, 32); Dest^ := Ch; dec(L); inc(Source); inc(Dest); until L=0; end; var L: cardinal; begin result := ''; L := Length(S); if L=0 then exit; SetLength(result, L); Upper(pointer(S),pointer(result),L); end; {$endif} function GetCardinal(P: PAnsiChar): cardinal; var c: cardinal; begin if P=nil then begin result := 0; exit; end; if P^=' ' then repeat inc(P) until P^<>' '; c := byte(P^)-48; if c>9 then result := 0 else begin result := c; inc(P); repeat c := byte(P^)-48; if c>9 then break else result := result*10+c; inc(P); until false; end; end; {$ifdef DOS} var CMOSClockSet: boolean = false; {$endif} function THttpClientSocket.Request(const url, method: TSockData; KeepAlive: cardinal; const Header, Data, DataType: TSockData; retry: boolean): integer; procedure DoRetry(Error: integer); begin if retry then // retry once -> return error if already retried result := Error else begin Close; // close this connection try OpenBind(Server,Port,false); // then retry this request with a new socket result := Request(url,method,KeepAlive,Header,Data,DataType,true); except on Exception do result := Error; end; end; end; var DataLen: integer; P: PAnsiChar; begin {$ifdef WIN32} if SockIn=nil then // done once CreateSockIn; // use SockIn by default if not already initialized: 2x faster {$endif} Content := ''; {$ifdef DEBUG2}system.write(#13#10,method,' ',url); if Retry then system.Write(' RETRY');{$endif} if Sock=-1 then DoRetry(404) else // socket closed (e.g. KeepAlive=0) -> reconnect try try {$ifdef DEBUG23}system.write(' Send');{$endif} // send request - we use SockSend because writeln() is calling flush() // -> all header will be sent at once DataLen := length(Data); SockSend([method, ' ', url, ' HTTP/1.1'#13#10+ 'Accept: */*'#13#10'Host: ', Server]); if UserAgent='' then SockSend('User-Agent: Mozilla/4.0 (compatible; MSIE 5.5; Windows; FREE)') else SockSend(['User-Agent: ',UserAgent]); // for POST/PUT: always put content byte count to be sent (even 0) SockSend(['Content-Length: ', DataLen]); {$ifdef WITHCHECKSUM} if DataLen<>0 then SockSend(['Content-Checksum: ', IntToHex(Adler32(0,pointer(Data),DataLen),1)]); {$endif} if DataType<>'' then SockSend(['Content-Type: ',DataType]); if KeepAlive>0 then SockSend(['Keep-Alive: ',KeepAlive,#13#10'Connection: Keep-Alive']) else SockSend('Connection: Close'); if header<>'' then SockSend(header); {$ifdef WITHSERVERTIME} {$ifdef DOS} if not CMOSClockSet then SockSend('SERVER-TIME: ASK'); {$endif} {$endif} SockSend; // send CRLF {$ifdef DEBUG23} SndBuf[SndBufLen+1] := #0; system.Writeln(#13#10'HeaderOut ',PAnsiChar(SndBuf));{$endif} SockSendFlush; // flush all pending data (i.e. headers) to network if DataLen<>0 then // for POST and PUT methods: content to be sent SndLow(pointer(Data),DataLen); // no CRLF at the end of data {$ifdef DEBUG23}system.write('OK ');{$endif} // get headers SockRecvLn(Command); // will raise ECrtSocket on any error {$ifdef DEBUG23}system.write(Command);{$endif} P := pointer(Command); if IdemPChar(P,'HTTP/1.') then begin if P[7]='0' then KeepAlive := 0; // HTTP/1.0 -> force connection close inc(P,9); result := GetCardinal(P); // get http numeric status code if result=0 then begin result := 505; exit; end; end else begin // error on reading answer DoRetry(505); // 505=wrong format exit; end; GetHeader; // read all other headers {$ifdef DEBUG23}system.write('OK Body');{$endif} if not IdemPChar(pointer(method),'HEAD') then GetBody; // get content if necessary (not HEAD method) except on Exception do DoRetry(404); end; finally if KeepAlive=0 then Close; end; end; function Open(const aServer, aPort: AnsiString): TCrtSocket; begin try result := TCrtSocket.Open(aServer,aPort); except on ECrtSocket do result := nil; end; end; function OpenHttp(const aServer, aPort: AnsiString): THttpClientSocket; begin try result := THttpClientSocket.Open(aServer,aPort); except on ECrtSocket do result := nil; end; end; function HttpGet(const server, port: AnsiString; const url: TSockData): TSockData; var Http: THttpClientSocket; begin result := ''; Http := OpenHttp(server,port); if Http<>nil then try if Http.Get(url)=200 then result := Http.Content; finally Http.Free; end; end; function SendEmail(const Server: AnsiString; const From, CSVDest, Subject, Text: TSockData; const Headers: TSockData=''; const User: TSockData=''; const Pass: TSockData=''; const Port: AnsiString='25'): boolean; var TCP: TCrtSocket; procedure Expect(const Answer: TSockData); var Res: TSockData; begin repeat readln(TCP.SockIn^,Res); until (Length(Res)<4)or(Res[4]<>'-'); if not IdemPChar(pointer(Res),pointer(Answer)) then raise Exception.Create(string(Res)); end; procedure Exec(const Command, Answer: TSockData); begin writeln(TCP.SockOut^,Command); Expect(Answer) end; var P: PAnsiChar; rec, ToList: TSockData; begin result := false; P := pointer(CSVDest); if P=nil then exit; TCP := Open(Server, Port); if TCP<>nil then try TCP.CreateSockIn; // we use SockIn and SockOut here TCP.CreateSockOut; Expect('220'); if (User<>'') and (Pass<>'') then begin Exec('EHLO '+Server,'25'); Exec('AUTH LOGIN','334'); Exec(Base64Encode(User),'334'); Exec(Base64Encode(Pass),'235'); end else Exec('HELO '+Server,'25'); writeln(TCP.SockOut^,'MAIL FROM:<',From,'>'); Expect('250'); ToList := 'To: '; repeat rec := trim(GetNextItem(P)); if rec='' then continue; if pos(TSockData('<'),rec)=0 then rec := '<'+rec+'>'; Exec('RCPT TO:'+rec,'25'); ToList := ToList+rec+', '; until P=nil; Exec('DATA','354'); writeln(TCP.SockOut^,'Subject: ',Subject,#13#10, ToList,#13#10'Content-Type: text/plain; charset=ISO-8859-1'#13#10+ 'Content-Transfer-Encoding: 8bit'#13#10, Headers,#13#10#13#10,Text); Exec('.','25'); writeln(TCP.SockOut^,'QUIT'); result := true; finally TCP.Free; end; end; {$ifndef DOS} // without DWPL TCP/IP stack: server Thread var WsaDataOnce: TWSADATA; {$endif} {$ifndef NOSERVER} { THttpServer } constructor THttpServer.Create(const aPort: AnsiString); var aSock: TCrtSocket; begin aSock := TCrtSocket.Bind(aPort); // BIND + LISTEN inherited Create(false); Sock := aSock; InitializeCriticalSection(ProcessCS); ServerKeepAliveTimeOut := 3000; // HTTP.1/1 KeepAlive is 3 seconds by default end; destructor THttpServer.Destroy; begin Terminate; // THttpServerResp.Execute expects Terminated if we reached here // ThreadID := 0 -> don't call WaitFor in Destroy: Execute.Accept() is blocking {$ifdef Linux} pthread_detach(ThreadID); // manualy do it here {$endif} PInteger(@ThreadID)^ := 0; // trick to access a read-only property inherited Destroy; // direct Thread abort, no wait till ended DeleteCriticalSection(ProcessCS); FreeAndNil(Sock); end; {.$define MONOTHREAD} // define this not to create a thread at every connection procedure THttpServer.Execute; var ClientSock: TSocket; Sin: TVarSin; {$ifdef MONOTHREAD} ClientCrtSock: THttpServerSocket; {$endif} begin if Sock.Sock>0 then while not Terminated do begin ClientSock := Accept(Sock.Sock,Sin); if Terminated or (Sock=nil) then begin Shutdown(ClientSock,1); CloseSocket(ClientSock); break; // don't accept input if server is down end; OnConnect; {$ifdef MONOTHREAD} ClientCrtSock := THttpServerSocket.Create; try ClientCrtSock.GetRequest(ClientSock); Process(ClientCrtSock); OnDisconnect; finally ClientCrtSock.Free; // call CloseSocket(ClientSock) end; {$else} THttpServerResp.Create(ClientSock, self); {$endif} end; end; function NowToDosDateTime: integer; var SystemTime: TSystemTime; begin GetLocalTime(SystemTime); with SystemTime do begin LongRec(result).Lo := (wSecond shr 1) or (wMinute shl 5) or (wHour shl 11); LongRec(result).Hi := wDay or (wMonth shl 5) or ((wYear - 1980) shl 9); end; end; procedure THttpServer.OnConnect; begin inc(ServerConnectionCount); end; procedure THttpServer.OnDisconnect; begin // nothing to do by default end; {$ifdef COMPRESS} const GZIP_LEVEL = 1; // 6 is standard, but 1 is enough and faster // w/deflate e.g (uS/bytes for 4803 bytes in): // 1=140/700 2=146/707 3=157/709 5=250/696 6=280/698 7=380/690 9=420/690 {.$define PERF} function GZCompress(const Source: TSockData): TSockData; {$ifdef COMPRESS_GZIP} // performance note: both compression have the same overhead, // about 110us for 425 bytes of data const gzheader : array [0..2] of cardinal = ($88B1F,0,0); var L: integer; P: PAnsiChar; {$ifdef PERF}T: TPrecisionTimer;{$endif} begin {$ifdef PERF}T.Start;{$endif} L := length(Source); SetLength(result,L+128+L shr 3); // maximum possible memory required P := pointer(result); move(gzheader,P^,10); inc(P,10); inc(P,CompressMem(pointer(Source),P,L,length(result)-20,GZIP_LEVEL)); PCardinal(P)^ := crc32(0,pointer(source),L); inc(P,4); PCardinal(P)^ := L; inc(P,4); SetLength(result,P-pointer(result)); {$ifdef PERF}T.Stop; writeln(L,'->',length(result),':',T.Time);{$endif} end; {$else} var strm: TZStream; {$ifdef PERF}T: TPrecisionTimer;{$endif} begin {$ifdef PERF}T.Start;{$endif} strm.Init; strm.next_in := pointer(Source); strm.avail_in := length(Source); SetLength(result,strm.avail_in+256+strm.avail_in shr 3); // max mem required strm.next_out := pointer(result); strm.avail_out := length(result); // +MAX_WBITS below = encode in deflate format // Z_HUFFMAN_ONLY instead of Z_DEFAULT_STRATEGY is slowest and bad if deflateInit2_(strm, GZIP_LEVEL, Z_DEFLATED, +MAX_WBITS, DEF_MEM_LEVEL, Z_DEFAULT_STRATEGY, ZLIB_VERSION, sizeof(strm))>=0 then try Check(deflate(strm,Z_FINISH),[Z_STREAM_END]); finally deflateEnd(strm); end; SetLength(result,strm.total_out); {$ifdef PERF}T.Stop; writeln(strm.total_in,'->',strm.total_out,':',T.Time);{$endif} end; {$endif} {$endif} procedure THttpServer.Process(var ClientSock: THttpServerSocket); var Data: TSockData; DataLen: cardinal; Code: cardinal; i: integer; s: TSockData; begin if ClientSock.Headers=nil then // we didn't get the request = socket read error exit; // -> send will probably fail -> nothing to send back if Terminated then exit; // calc answer (unique thread) try EnterCriticalSection(ProcessCS); // calculation thread protection Code := Request(ClientSock,Data); finally LeaveCriticalSection(ProcessCS); end; if Terminated then exit; // send response (multi-thread OK) at once if (Code<200) or (ClientSock.Headers=nil) then Code := 404; if not(Code in [200,201]) and (Data='') then begin Setlength(ClientSock.Headers,0); ClientSock.ContentType := 'text/html'; // create message to display Data := TSockData(ClassName+' Server Error '+IntToStr(Code) +'<hr>'+StringReplace(string(s),#13#10,'<br>',[rfReplaceAll])); end; // 1. send HTTP status command if ClientSock.KeepAliveClient then ClientSock.SockSend(['HTTP/1.1 ',Code,' OK']) else ClientSock.SockSend(['HTTP/1.0 ',Code,' OK']); // 2. send headers for i := 0 to high(ClientSock.Headers) do begin s := ClientSock.Headers[i]; if s<>'' then begin // no void line (means headers ending) ClientSock.SockSend(s); {$ifdef COMPRESS} if IdemPChar(pointer(s),'CONTENT-ENCODING:') then ClientSock.AcceptGZip := false; // custom encoding: don't GZIP {$endif} end; end; ClientSock.SockSend(['X-Powered-By: SynCrtSock http://synopse.info'#13#10+ 'Server: ',ClassName]); {$ifdef COMPRESS} if ClientSock.AcceptGZip and (Data<>'') then begin s := UpperCase(ClientSock.ContentType); if (s<>'') and (length(Data)+ClientSock.SndBufLen>1024) and (IdemPChar(pointer(s),'TEXT/') or (pos('/JSON',string(s))>0)) then begin // update header ClientSock.SockSend('Content-Encoding: '+ {$ifdef COMPRESS_GZIP}'gzip'{$else}'deflate'{$endif}); // on the fly gzip of the content Data := GZCompress(Data); end else ClientSock.AcceptGZip := false; end; {$endif} DataLen := length(Data); ClientSock.SockSend(['Content-Length: ',DataLen]); // need size, even 0 if Data<>'' then begin if ClientSock.ContentType<>'' then ClientSock.SockSend(['Content-Type: ',ClientSock.ContentType]); {$ifdef WITHCHECKSUM} ClientSock.SockSend(['Content-Checksum: ', IntToHex(Adler32(0,pointer(Data),DataLen),1)]); {$endif} end; {$ifdef WITHSERVERTIME} if ClientSock.NeedServerTime then ClientSock.SockSend(['Server-Time: ',IntToHex(NowToDosDateTime,1)]); {$endif} if ClientSock.KeepAliveClient then ClientSock.SockSend('Connection: Keep-Alive'#13#10) else ClientSock.SockSend; // headers end with a void line ClientSock.SockSendFlush; // flush all pending data (i.e. headers) to network // 3. sent HTTP body content (if any) if Data<>'' then // no CRLF at the end of data ClientSock.SndLow(pointer(Data),DataLen); // direct send to socket end; { THttpServerResp } constructor THttpServerResp.Create(aSock: TSocket; aServer: THttpServer); begin inherited Create(false); FreeOnTerminate := true; fServer := aServer; fClientSock := aSock; fServerSock := THttpServerSocket.Create; end; destructor THttpServerResp.Destroy; begin fServerSock.Free; if fClientSock<>0 then begin // if Destroy happens before fServerSock.GetRequest() in Execute below Shutdown(fClientSock,1); CloseSocket(fClientSock); end; inherited Destroy; end; procedure THttpServerResp.Execute; var c: char; Loop, LoopEnd, LoopMax: integer; aSock: TSocket; const LOOPWAIT = 64; // ms sleep beetwen connections label S; begin aSock := fClientSock; fClientSock := 0; // mark no need to Shutdown and close fClientSock fServerSock.InitRequest(aSock); // now fClientSock is in fServerSock LoopEnd := fServer.ServerKeepAliveTimeOut div LOOPWAIT; LoopMax := LoopEnd+10; Loop := 0; goto S; repeat // get request and headers fServerSock.GetRequest; // calc answer and send response fServer.Process(fServerSock); Loop := 0; if not fServerSock.KeepAliveClient then break; repeat // KeepAlive persistent connection S: if not fServerSock.SockConnected then break; if fServer.Terminated then exit; if (fServerSock.SockCanRead(LOOPWAIT)>0) and (Recv(fServerSock.Sock,@c,1,MSG_PEEK)>0) then Loop := LoopMax; inc(Loop); until Loop>=LoopEnd; // reached ServerKeepAliveTimeOut? until Loop<LoopMax; if fServer<>nil then fServer.OnDisconnect; if (fServer<>nil) and (fServer.Sock<>nil) then try EnterCriticalSection(fServer.ProcessCS); // fServer thread protection inc(fServer.Sock.BytesIn,fServerSock.BytesIn); inc(fServer.Sock.BytesOut,fServerSock.BytesOut); finally LeaveCriticalSection(fServer.ProcessCS); end; end; {$endif} { THttpSocket } function PCharToHex32(p: PAnsiChar): cardinal; var v0,v1: byte; begin result := 0; if p<>nil then begin while p^=' ' do inc(p); repeat v0 := Hex2Dec(p[0]); if v0=255 then break; // not in '0'..'9','a'..'f' v1 := Hex2Dec(p[1]); inc(p); if v1=255 then begin result := (result shl 4)+v0; // only one char left break; end; v0 := v0 shl 4; result := result shl 8; inc(v0,v1); inc(p); inc(result,v0); until false; end; end; procedure THttpSocket.GetBody; var Line: TSockData; // 32 bits chunk length in hexa LinePChar: array[0..31] of AnsiChar; Len, LContent: integer; begin {$ifdef DEBUG23}system.writeln('GetBody ContentLength=',ContentLength);{$endif} Content := ''; {$I-} // direct read bytes, as indicated by Content-Length or Chunked if Chunked then begin // we ignore the Length LContent := 0; // current read position in Content repeat if SockIn<>nil then begin readln(SockIn^,LinePChar); // use of a static PChar is faster if ioresult<>0 then raise ECrtSocket.Create('GetBody1'); Len := PCharToHex32(LinePChar); // get chunk length in hexa end else begin SockRecvLn(Line); Len := PCharToHex32(pointer(Line)); // get chunk length in hexa end; if Len=0 then begin // ignore next line (normaly void) SockRecvLn; break; end; SetLength(Content,LContent+Len); // reserve memory space for this chunk SockInRead(pointer(integer(Content)+LContent),Len) ; // append chunk data inc(LContent,Len); SockRecvLn; // ignore next #13#10 until false; end else if ContentLength>0 then begin SetLength(Content,ContentLength); // not chuncked: direct read SockInRead(pointer(Content),ContentLength); // works with SockIn=nil or not end else if ContentLength<0 then begin // ContentLength=-1 if no Content-Length // no Content-Length nor Chunked header -> read until eof() if SockIn<>nil then while not eof(SockIn^) do begin readln(SockIn^,Line); if Content='' then Content := Line else Content := Content+#13#10+Line; end; ContentLength := length(Content); // update Content-Length exit; end; ContentLength := length(Content); // update Content-Length {$ifdef WITHCHECKSUM} if (Content<>'') and (ContentChecksum<>0) then if ContentChecksum<>Adler32(0,pointer(Content),ContentLength) then raise ECrtSocket.Create('CHECKSUM'); {$endif} if (SockIn<>nil) and (ioresult<>0) then raise ECrtSocket.Create('GetBody2'); {$I+} end; procedure THttpSocket.GetHeader; var s: TSockData; {$ifdef COMPRESS} P: PAnsiChar; {$endif} n: integer; begin ContentType := ''; ContentLength := -1; {$ifdef WITHCHECKSUM} ContentChecksum := 0; {$endif} {$ifdef COMPRESS} AcceptGZip := false; {$endif} Chunked := false; n := 0; repeat SockRecvLn(s); if s='' then break; // headers end with a void line if length(Headers)<=n then SetLength(Headers,n+10); Headers[n] := s; inc(n); {$ifdef DEBUG23}system.Writeln(ClassName,'.HeaderIn ',s);{$endif} if IdemPChar(pointer(s),'CONTENT-LENGTH:') then ContentLength := GetCardinal(pointer(PtrInt(s)+16)) else if IdemPChar(pointer(s),'CONTENT-TYPE:') then ContentType := trim(copy(s,14,128)) else {$ifdef WITHCHECKSUM} if IdemPChar(pointer(s),'CONTENT-CHECKSUM:') then ContentChecksum := PCharToHex32(@s[18]) else {$endif} {$ifdef WITHSERVERTIME} {$ifdef DOS} if not CMOSClockSet and IdemPChar(pointer(s),'SERVER-TIME:') then begin CMOSClockSet := true; SetSystemTime(PCharToHex32(@s[13])); end else {$endif} {$endif} if IdemPChar(pointer(s),'TRANSFER-ENCODING: CHUNKED') then Chunked := true else {$ifdef COMPRESS} if IdemPChar(pointer(s),'ACCEPT-ENCODING:') then begin P := pointer(s); inc(P,16); repeat while P^ in [' ',','] do inc(P); if PInteger(P)^ and $dfdfdfdf= {$ifdef COMPRESS_GZIP} ord('G')+ord('Z')shl 8+ord('I')shl 16+ord('P')shl 24 then begin {$else} ord('D')+ord('E')shl 8+ord('F')shl 16+ord('L')shl 24 then begin {$endif} AcceptGZip := true; break; end; while not (P^ in [',',#0]) do inc(P); until P^=#0; end; {$endif} until false; SetLength(Headers,n); end; function THttpSocket.HeaderAdd(const aValue: TSockData): integer; begin result := length(Headers); SetLength(Headers,result+1); Headers[result] := aValue; end; procedure THttpSocket.HeaderSetText(const aText: TSockData); var P, PDeb: PAnsiChar; n: integer; begin P := pointer(aText); n := 0; if P<>nil then repeat PDeb := P; while P^>#13 do inc(P); if PDeb<>P then begin // add any not void line if length(Headers)<=n then SetLength(Headers,n+10); SetString(Headers[n],PDeb,P-PDeb); inc(n); end; while (P^=#13) or (P^=#10) do inc(P); until P^=#0; SetLength(Headers,n); end; function THttpSocket.HeaderGetText: TSockData; var i,V,L,n: PtrInt; P: PAnsiChar; begin // much faster than for i := 0 to Count-1 do result := result+Headers[i]+#13#10; result := ''; n := length(Headers); if n=0 then exit; L := n*2; // #13#10 size dec(n); for i := 0 to n do if PtrInt(Headers[i])<>0 then inc(L,PPtrInt(PtrInt(Headers[i])-4)^); // fast add length(List[i]) SetLength(result,L); P := pointer(result); for i := 0 to n do begin V := PtrInt(Headers[i]); if V<>0 then begin L := PPtrInt(V-4)^; // L := length(List[i]) move(pointer(V)^,P^,L); inc(P,L); end; PWord(P)^ := 13+10 shl 8; inc(P,2); end; end; function THttpSocket.HeaderValue(aName: TSockData): TSockData; var i: integer; begin if Headers<>nil then begin aName := UpperCase(aName)+':'; for i := 0 to high(Headers) do if IdemPChar(pointer(Headers[i]),pointer(aName)) then begin result := trim(copy(Headers[i],length(aName)+1,maxInt)); exit; end; end; result := ''; end; {$ifndef NOSERVER} // without DWPL TCP/IP stack: server Thread { THttpServerSocket } procedure THttpServerSocket.InitRequest(aClientSock: TSocket); begin {$ifdef WIN32} CreateSockIn; // use SockIn by default if not already initialized: 2x faster {$endif} OpenBind('','',false,aClientSock); // open aClientSock for reading end; procedure THttpServerSocket.GetRequest; var P: PAnsiChar; i: integer; begin if not SockConnected then exit; // 1st line is command: 'GET /path HTTP/1.1' e.g. SockRecvLn(Command); P := pointer(Command); Method := GetNextItem(P,' '); // 'GET' URL := GetNextItem(P,' '); // '/path' KeepAliveClient := IdemPChar(P,'HTTP/1.1'); {$ifdef WITHSERVERTIME} NeedServerTime := false; {$endif} Content := ''; // get headers and content GetHeader; if (ContentLength<0) and KeepAliveClient then ContentLength := 0; // HTTP/1.1 and no content length -> no eof for i := 0 to high(Headers) do {$ifdef WITHSERVERTIME} if IdemPChar(pointer(Headers[i]),'SERVER-TIME: ASK') then NeedServerTime := true else {$endif} if IdemPChar(pointer(Headers[i]),'CONNECTION: CLOSE') then KeepAliveClient := false; GetBody; end; {$endif} { ECrtSocket } constructor ECrtSocket.Create(const Msg: string); begin inherited CreateFmt('%s %d',[Msg,WSAGetLastError]); end; {$ifdef Win32} function GetRemoteMacAddress(const IP: AnsiString): TSockData; // implements http://msdn.microsoft.com/en-us/library/aa366358(VS.85).aspx type TSendARP = function(DestIp: DWORD; srcIP: DWORD; pMacAddr: pointer; PhyAddrLen: Pointer): DWORD; stdcall; const HexChars: array[0..15] of AnsiChar = '0123456789ABCDEF'; var dwRemoteIP: DWORD; PhyAddrLen: Longword; pMacAddr : array [0..7] of byte; I: integer; P: PAnsiChar; SendARPLibHandle: THandle; SendARP: TSendARP; begin result := ''; SendARPLibHandle := LoadLibrary('iphlpapi.dll'); if SendARPLibHandle<>0 then try SendARP := GetProcAddress(SendARPLibHandle,'SendARP'); if @SendARP=nil then exit; // we are not under 2K or later dwremoteIP := inet_addr(pointer(IP)); if dwremoteIP<>0 then begin PhyAddrLen := 8; if SendARP(dwremoteIP, 0, @pMacAddr, @PhyAddrLen)=NO_ERROR then begin if PhyAddrLen=6 then begin SetLength(result,12); P := pointer(result); for i := 0 to 5 do begin P[0] := HexChars[pMacAddr[i] shr 4]; P[1] := HexChars[pMacAddr[i] and $F]; inc(P,2); end; end; end; end; finally FreeLibrary(SendARPLibHandle); end; end; {$endif} initialization {$ifdef DOS} // Network and TCPIP initialization must appears in the program main: // InitNetwork(TNE2000Adapter.Create($220)); e.g. (BUGGY) // InitNetwork(TPacketDriverAdapter.Create); e.g. with uses WDosPktDrv; asm mov ah,2ah int 21h cmp cx,2008 jb @1 mov CMOSClockSet,true // CMOS in 21th century -> don't get time from server @1:end; {$else} if InitSocketInterface then WSAStartup(WinsockLevel, WsaDataOnce) else fillchar(WsaDataOnce,sizeof(WsaDataOnce),0); {$endif} finalization {$ifndef DOS} if WsaDataOnce.wVersion<>0 then WSACleanup; DestroySocketInterface; {$endif} end.