diff --git a/.gitattributes b/.gitattributes
index 7015991dd6..e0b6b87c6b 100644
--- a/.gitattributes
+++ b/.gitattributes
@@ -8136,18 +8136,26 @@ utils/fppkg/fppkg.pp svneol=native#text/plain
utils/fppkg/fprepos.pp svneol=native#text/plain
utils/fppkg/fpxmlrep.pp svneol=native#text/plain
utils/fppkg/lnet/LICENSE -text
+utils/fppkg/lnet/LICENSE.ADDON -text
utils/fppkg/lnet/fastcgi.pp svneol=native#text/plain
utils/fppkg/lnet/lcommon.pp svneol=native#text/plain
utils/fppkg/lnet/lcontainers.inc svneol=native#text/plain
utils/fppkg/lnet/lcontainersh.inc svneol=native#text/plain
utils/fppkg/lnet/lcontrolstack.pp svneol=native#text/plain
utils/fppkg/lnet/levents.pp svneol=native#text/plain
+utils/fppkg/lnet/lfastcgi.pp svneol=native#text/plain
utils/fppkg/lnet/lftp.pp svneol=native#text/plain
+utils/fppkg/lnet/lhttp.pp svneol=native#text/plain
+utils/fppkg/lnet/lhttputil.pp svneol=native#text/plain
+utils/fppkg/lnet/lmimetypes.pp svneol=native#text/plain
utils/fppkg/lnet/lnet.pp svneol=native#text/plain
+utils/fppkg/lnet/lprocess.pp svneol=native#text/plain
+utils/fppkg/lnet/lsmtp.pp svneol=native#text/plain
+utils/fppkg/lnet/lspawnfcgi.pp svneol=native#text/plain
utils/fppkg/lnet/lstrbuffer.pp svneol=native#text/plain
utils/fppkg/lnet/ltelnet.pp svneol=native#text/plain
+utils/fppkg/lnet/ltimer.pp svneol=native#text/plain
utils/fppkg/lnet/lwebserver.pp svneol=native#text/plain
-utils/fppkg/lnet/openssl.pp -text svneol=unset#text/plain
utils/fppkg/lnet/sys/lepolleventer.inc svneol=native#text/plain
utils/fppkg/lnet/sys/lepolleventerh.inc svneol=native#text/plain
utils/fppkg/lnet/sys/lkqueueeventer.inc svneol=native#text/plain
diff --git a/utils/fppkg/lnet/LICENSE.ADDON b/utils/fppkg/lnet/LICENSE.ADDON
new file mode 100644
index 0000000000..f134b1e33d
--- /dev/null
+++ b/utils/fppkg/lnet/LICENSE.ADDON
@@ -0,0 +1,19 @@
+This is the file LICENSE.Addon, it applies to the Lighweight Network Library (lnet).
+
+The source code of the Lightweight Network library are
+distributed under the Library GNU General Public License
+(see the file LICENSE) with the following modification:
+
+- object files and libraries linked into an application may be
+ distributed without source code.
+
+The unit tomwinsock.pas is EXLUDED from both the GPL and this addon license.
+It is distributed under the terms of BSD license as mentioned in the file.
+I am NOT the author of tomwinsock.pas
+
+If you didn't receive a copy of the file LICENSE, contact:
+ Free Software Foundation, Inc.,
+ 59 Temple Place - Suite 330
+ Boston, MA 02111
+ USA
+
diff --git a/utils/fppkg/lnet/levents.pp b/utils/fppkg/lnet/levents.pp
index bffb5a43eb..cf0c3c734e 100644
--- a/utils/fppkg/lnet/levents.pp
+++ b/utils/fppkg/lnet/levents.pp
@@ -317,7 +317,7 @@ function TLEventer.Bail(const msg: string; const Ernum: Integer): Boolean;
begin
Result := False; // always false, substitute for caller's result
if Assigned(FOnError) then
- FOnError(msg + ': ' + LStrError(Ernum), Self);
+ FOnError(msg + '[' + IntToStr(Ernum) + ']: ' + LStrError(Ernum), Self);
end;
procedure TLEventer.AddForFree(aHandle: TLHandle);
diff --git a/utils/fppkg/lnet/lfastcgi.pp b/utils/fppkg/lnet/lfastcgi.pp
new file mode 100644
index 0000000000..2a8320c92a
--- /dev/null
+++ b/utils/fppkg/lnet/lfastcgi.pp
@@ -0,0 +1,910 @@
+{ FastCGI requester support for lNet
+
+ Copyright (C) 2006 Micha Nelissen
+
+ This library is Free software; you can redistribute it and/or modify it
+ under the terms of the GNU Library General Public License as published by
+ the Free Software Foundation; either version 2 of the License, or (at your
+ option) any later version.
+
+ This program is diStributed in the hope that it will be useful, but WITHOUT
+ ANY WARRANTY; withOut even the implied warranty of MERCHANTABILITY or
+ FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License
+ for more details.
+
+ You should have received a Copy of the GNU Library General Public License
+ along with This library; if not, Write to the Free Software Foundation,
+ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+ This license has been modified. See file LICENSE.ADDON for more information.
+ Should you find these sources without a LICENSE File, please contact
+ me at ales@chello.sk
+}
+
+unit lfastcgi;
+
+{$mode objfpc}{$h+}
+
+interface
+
+uses
+ classes, sysutils, fastcgi, lnet, levents, lstrbuffer, ltimer;
+
+type
+ TLFastCGIClient = class;
+ TLFastCGIRequest = class;
+ TLFastCGIPool = class;
+
+ TLFastCGIRequestEvent = procedure(ARequest: TLFastCGIRequest) of object;
+
+ PLFastCGIRequest = ^TLFastCGIRequest;
+ TLFastCGIRequest = class(TObject)
+ protected
+ FID: integer;
+ FClient: TLFastCGIClient;
+ FBuffer: TStringBuffer;
+ FBufferSendPos: integer;
+ FHeader: FCGI_Header;
+ FHeaderPos: integer;
+ FContentLength: integer;
+ FInputBuffer: pchar;
+ FInputSize: integer;
+ FOutputDone: boolean;
+ FStderrDone: boolean;
+ FOutputPending: boolean;
+ FNextFree: TLFastCGIRequest;
+ FNextSend: TLFastCGIRequest;
+ FOnEndRequest: TLFastCGIRequestEvent;
+ FOnInput: TLFastCGIRequestEvent;
+ FOnOutput: TLFastCGIRequestEvent;
+ FOnStderr: TLFastCGIRequestEvent;
+
+ procedure HandleReceive;
+ procedure HandleReceiveEnd;
+ function HandleSend: boolean;
+ procedure DoEndRequest;
+ procedure DoOutput;
+ procedure DoStderr;
+ procedure EndRequest;
+ procedure RewindBuffer;
+ procedure SetContentLength(NewLength: integer);
+ procedure SendEmptyRec(AType: integer);
+ procedure SendGetValues;
+ procedure SetID(const NewID: integer);
+ public
+ constructor Create;
+ destructor Destroy; override;
+
+ procedure AbortRequest;
+ function Get(ABuffer: pchar; ASize: integer): integer;
+ procedure ParseClientBuffer;
+ function SendBuffer: integer;
+ function SendPrivateBuffer: boolean;
+ procedure SendBeginRequest(AType: integer);
+ procedure SendParam(const AName, AValue: string; AReqType: integer = FCGI_PARAMS);
+ function SendInput(const ABuffer: pchar; ASize: integer): integer;
+ procedure DoneParams;
+ procedure DoneInput;
+
+ property ID: integer read FID write SetID;
+ property StderrDone: boolean read FStderrDone;
+ property OutputDone: boolean read FOutputDone;
+ property OutputPending: boolean read FOutputPending;
+ property OnEndRequest: TLFastCGIRequestEvent read FOnEndRequest write FOnEndRequest;
+ property OnInput: TLFastCGIRequestEvent read FOnInput write FOnInput;
+ property OnOutput: TLFastCGIRequestEvent read FOnOutput write FOnOutput;
+ property OnStderr: TLFastCGIRequestEvent read FOnStderr write FOnStderr;
+ end;
+
+ TFastCGIClientState = (fsIdle, fsConnecting, fsConnectingAgain,
+ fsStartingServer, fsHeader, fsData, fsFlush);
+
+ PLFastCGIClient = ^TLFastCGIClient;
+ TLFastCGIClient = class(TLTcp)
+ protected
+ FRequests: PLFastCGIRequest;
+ FRequestsCount: integer;
+ FNextRequestID: integer;
+ FRequestsSent: integer;
+ FFreeRequest: TLFastCGIRequest;
+ FSendRequest: TLFastCGIRequest;
+ FRequest: TLFastCGIRequest;
+ FState: TFastCGIClientState;
+ FNextFree: TLFastCGIClient;
+ FPool: TLFastCGIPool;
+ FBuffer: pchar;
+ FBufferEnd: pchar;
+ FBufferPos: pchar;
+ FBufferSize: dword;
+ FReqType: byte;
+ FContentLength: integer;
+ FPaddingLength: integer;
+
+ function Connect: Boolean; override;
+ procedure ConnectEvent(ASocket: TLHandle); override;
+ procedure DisconnectEvent(ASocket: TLHandle); override;
+ procedure ErrorEvent(const Msg: string; ASocket: TLHandle); override;
+ function CreateRequester: TLFastCGIRequest;
+ procedure HandleGetValuesResult;
+ procedure HandleReceive(ASocket: TLSocket);
+ procedure HandleSend(ASocket: TLSocket);
+ procedure ParseBuffer;
+ public
+ constructor Create(AOwner: TComponent); override;
+ destructor Destroy; override;
+
+ procedure AddToSendQueue(ARequest: TLFastCGIRequest);
+ function BeginRequest(AType: integer): TLFastCGIRequest;
+ procedure EndRequest(ARequest: TLFastCGIRequest);
+ procedure Flush;
+ function GetBuffer(ABuffer: pchar; ASize: integer): integer;
+
+ property ReqType: byte read FReqType;
+ property RequestsSent: integer read FRequestsSent;
+ end;
+
+ TSpawnState = (ssNone, ssSpawning, ssSpawned);
+
+ TLFastCGIPool = class(TObject)
+ protected
+ FClients: PLFastCGIClient;
+ FClientsCount: integer;
+ FClientsAvail: integer;
+ FClientsMax: integer;
+ FMaxRequestsConn: integer;
+ FFreeClient: TLFastCGIClient;
+ FTimer: TLTimer;
+ FEventer: TLEventer;
+ FAppName: string;
+ FAppEnv: string;
+ FHost: string;
+ FPort: integer;
+ FSpawnState: TSpawnState;
+
+ procedure AddToFreeClients(AClient: TLFastCGIClient);
+ function CreateClient: TLFastCGIClient;
+ procedure ConnectClients(Sender: TObject);
+ procedure StartServer;
+ public
+ constructor Create;
+ destructor Destroy; override;
+
+ function BeginRequest(AType: integer): TLFastCGIRequest;
+ procedure EndRequest(AClient: TLFastCGIClient);
+
+ property AppEnv: string read FAppEnv write FAppEnv;
+ property AppName: string read FAppName write FAppName;
+ property ClientsMax: integer read FClientsMax write FClientsMax;
+ property Eventer: TLEventer read FEventer write FEventer;
+ property MaxRequestsConn: integer read FMaxRequestsConn write FMaxRequestsConn;
+ property Host: string read FHost write FHost;
+ property Port: integer read FPort write FPort;
+ property Timer: TLTimer read FTimer;
+ end;
+
+implementation
+
+uses
+ lSpawnFCGI;
+
+{ TLFastCGIRequest }
+
+constructor TLFastCGIRequest.Create;
+begin
+ inherited;
+
+ FBuffer := InitStringBuffer(504);
+ FHeader.Version := FCGI_VERSION_1;
+ FHeaderPos := -1;
+end;
+
+destructor TLFastCGIRequest.Destroy;
+begin
+ inherited;
+ FreeMem(FBuffer.Memory);
+end;
+
+procedure TLFastCGIRequest.HandleReceive;
+begin
+ case FClient.ReqType of
+ FCGI_STDOUT: DoOutput;
+ FCGI_STDERR: DoStderr;
+ FCGI_END_REQUEST: EndRequest;
+ FCGI_GET_VALUES_RESULT: FClient.HandleGetValuesResult;
+ else
+ FClient.Flush;
+ end;
+end;
+
+procedure TLFastCGIRequest.HandleReceiveEnd;
+begin
+ case FClient.ReqType of
+ FCGI_STDOUT: FOutputDone := true;
+ FCGI_STDERR: FStderrDone := true;
+ end;
+end;
+
+function TLFastCGIRequest.HandleSend: boolean;
+begin
+ if FOnInput <> nil then
+ FOnInput(Self);
+ Result := FInputBuffer = nil;
+end;
+
+procedure TLFastCGIRequest.DoOutput;
+begin
+ if FOnOutput <> nil then
+ FOnOutput(Self);
+end;
+
+procedure TLFastCGIRequest.DoStderr;
+begin
+ if FOnStderr <> nil then
+ FOnStderr(Self);
+end;
+
+procedure TLFastCGIRequest.DoEndRequest;
+begin
+ if FOnEndRequest <> nil then
+ FOnEndRequest(Self);
+end;
+
+procedure TLFastCGIRequest.EndRequest;
+begin
+ FOutputDone := false;
+ FStderrDone := false;
+ FClient.EndRequest(Self);
+ FClient.Flush;
+ RewindBuffer;
+ DoEndRequest;
+end;
+
+function TLFastCGIRequest.Get(ABuffer: pchar; ASize: integer): integer;
+begin
+ Result := FClient.GetBuffer(ABuffer, ASize);
+end;
+
+procedure TLFastCGIRequest.ParseClientBuffer;
+begin
+ FOutputPending := false;
+ if (FClient.Iterator <> nil) and FClient.Iterator.IgnoreRead then
+ FClient.HandleReceive(nil)
+ else
+ FClient.ParseBuffer;
+end;
+
+procedure TLFastCGIRequest.SetID(const NewID: integer);
+begin
+ FID := NewID;
+ FHeader.RequestIDB0 := byte(NewID and $FF);
+ FHeader.RequestIDB1 := byte((NewID shr 8) and $FF);
+end;
+
+procedure TLFastCGIRequest.SetContentLength(NewLength: integer);
+begin
+ FContentLength := NewLength;
+ FHeader.ContentLengthB0 := byte(NewLength and $FF);
+ FHeader.ContentLengthB1 := byte((NewLength shr 8) and $FF);
+ FHeader.PaddingLength := byte(7-((NewLength+7) and 7));
+end;
+
+const
+ PaddingBuffer: array[0..7] of char = (#0, #0, #0, #0, #0, #0, #0, #0);
+type
+ TLFastCGIStringSize = record
+ Size: integer;
+ SizeBuf: array[0..3] of char;
+ end;
+
+function GetFastCGIStringSize(ABufferPos: pbyte; var ASize: integer): integer;
+begin
+ ASize := ABufferPos[0];
+ if ASize >= 128 then
+ begin
+ ASize := ((ABufferPos[0] shl 24) and $7f) or (ABufferPos[1] shl 16)
+ or (ABufferPos[2] shl 8) or ABufferPos[3];
+ Result := 4;
+ end else
+ Result := 1;
+end;
+
+procedure FillFastCGIStringSize(const AStr: string; var AFastCGIStr: TLFastCGIStringSize);
+var
+ lLen: dword;
+begin
+ lLen := dword(Length(AStr));
+ if lLen > 127 then
+ begin
+ AFastCGIStr.Size := 4;
+ AFastCGIStr.SizeBuf[0] := char($80 + ((lLen shr 24) and $ff));
+ AFastCGIStr.SizeBuf[1] := char((lLen shr 16) and $ff);
+ AFastCGIStr.SizeBuf[2] := char((lLen shr 8) and $ff);
+ AFastCGIStr.SizeBuf[3] := char(lLen and $ff);
+ end else begin
+ AFastCGIStr.Size := 1;
+ AFastCGIStr.SizeBuf[0] := char(lLen);
+ end;
+end;
+
+procedure TLFastCGIRequest.SendBeginRequest(AType: integer);
+var
+ lBody: FCGI_BeginRequestBody;
+begin
+ lBody.roleB1 := byte((AType shr 8) and $ff);
+ lBody.roleB0 := byte(AType and $ff);
+ lBody.flags := FCGI_KEEP_CONN;
+ FHeader.ReqType := FCGI_BEGIN_REQUEST;
+ SetContentLength(sizeof(lBody));
+ AppendString(FBuffer, @FHeader, sizeof(FHeader));
+ AppendString(FBuffer, @lBody, sizeof(lBody));
+end;
+
+procedure TLFastCGIRequest.SendParam(const AName, AValue: string; AReqType: integer = FCGI_PARAMS);
+var
+ lNameLen: TLFastCGIStringSize;
+ lValueLen: TLFastCGIStringSize;
+ lTotalLen: integer;
+begin
+ FillFastCGIStringSize(AName, lNameLen);
+ FillFastCGIStringSize(AValue, lValueLen);
+ lTotalLen := lNameLen.Size+lValueLen.Size+Length(AName)+Length(AValue);
+ if (FHeader.ReqType = AReqType) and (FBufferSendPos = 0)
+ and (0 <= FHeaderPos) and (FHeaderPos < FBuffer.Pos - FBuffer.Memory) then
+ begin
+ { undo padding }
+ Dec(FBuffer.Pos, FHeader.PaddingLength);
+ SetContentLength(FContentLength+lTotalLen);
+ Move(FHeader, FBuffer.Memory[FHeaderPos], sizeof(FHeader));
+ end else begin
+ FHeader.ReqType := AReqType;
+ SetContentLength(lTotalLen);
+ FHeaderPos := FBuffer.Pos - FBuffer.Memory;
+ AppendString(FBuffer, @FHeader, sizeof(FHeader));
+ end;
+ AppendString(FBuffer, @lNameLen.SizeBuf[0], lNameLen.Size);
+ AppendString(FBuffer, @lValueLen.SizeBuf[0], lValueLen.Size);
+ AppendString(FBuffer, AName);
+ AppendString(FBuffer, AValue);
+ AppendString(FBuffer, @PaddingBuffer[0], FHeader.PaddingLength);
+end;
+
+procedure TLFastCGIRequest.SendGetValues;
+var
+ lRequestID: integer;
+begin
+ { management record type has request id 0 }
+ lRequestID := ID;
+ ID := 0;
+ SendParam('FCGI_MAX_REQS', '', FCGI_GET_VALUES);
+ { if we're the first connection, ask max. # connections }
+ if FClient.FPool.FClientsAvail = 1 then
+ SendParam('FCGI_MAX_CONNS', '', FCGI_GET_VALUES);
+ ID := lRequestID;
+end;
+
+function TLFastCGIRequest.SendInput(const ABuffer: pchar; ASize: integer): integer;
+begin
+ { first send current buffer if any }
+ if FInputBuffer <> nil then
+ begin
+ Result := SendBuffer;
+ if FInputBuffer <> nil then exit;
+ end else Result := 0;
+ if Result >= ASize then exit;
+ if FInputBuffer = nil then
+ begin
+ FInputBuffer := ABuffer+Result;
+ FInputSize := ASize-Result;
+ FHeader.ReqType := FCGI_STDIN;
+ SetContentLength(FInputSize);
+ AppendString(FBuffer, @FHeader, sizeof(FHeader));
+ end;
+ Inc(Result, SendBuffer);
+end;
+
+procedure TLFastCGIRequest.RewindBuffer;
+begin
+ FBufferSendPos := 0;
+ FHeaderPos := -1;
+ { rewind stringbuffer }
+ FBuffer.Pos := FBuffer.Memory;
+end;
+
+function TLFastCGIRequest.SendPrivateBuffer: boolean;
+var
+ lWritten: integer;
+begin
+ { nothing to send ? }
+ if FBuffer.Pos-FBuffer.Memory = FBufferSendPos then
+ exit(true);
+ { already a queue and we are not first in line ? no use in trying to send then }
+ if (FClient.FSendRequest = nil) or (FClient.FSendRequest = Self) then
+ begin
+ lWritten := FClient.Send(FBuffer.Memory[FBufferSendPos],
+ FBuffer.Pos-FBuffer.Memory-FBufferSendPos);
+ Inc(FBufferSendPos, lWritten);
+ Result := FBufferSendPos = FBuffer.Pos-FBuffer.Memory;
+ { do not rewind buffer, unless remote side has had chance to disconnect }
+ if Result then
+ RewindBuffer;
+ end else
+ Result := false;
+ if not Result then
+ FClient.AddToSendQueue(Self);
+end;
+
+function TLFastCGIRequest.SendBuffer: integer;
+var
+ lWritten: integer;
+begin
+ { already a queue and we are not first in line ? no use in trying to send then }
+ if (FClient.FSendRequest <> nil) and (FClient.FSendRequest <> Self) then
+ exit(0);
+
+ { header to be sent? }
+ if not SendPrivateBuffer then exit(0);
+ { first write request header, then wait for possible disconnect }
+ if FBufferSendPos > 0 then exit(0);
+ if FInputBuffer = nil then exit(0);
+
+ lWritten := FClient.Send(FInputBuffer^, FInputSize);
+ Inc(FInputBuffer, lWritten);
+ Dec(FInputSize, lWritten);
+ if FInputSize = 0 then
+ begin
+ FInputBuffer := nil;
+ AppendString(FBuffer, @PaddingBuffer[0], FHeader.PaddingLength);
+ end else
+ FClient.AddToSendQueue(Self);
+ Result := lWritten;
+end;
+
+procedure TLFastCGIRequest.SendEmptyRec(AType: integer);
+begin
+ FHeader.ReqType := AType;
+ SetContentLength(0);
+ AppendString(FBuffer, @FHeader, sizeof(FHeader));
+ { no padding needed for empty string }
+end;
+
+procedure TLFastCGIRequest.DoneParams;
+begin
+ SendEmptyRec(FCGI_PARAMS);
+end;
+
+procedure TLFastCGIRequest.DoneInput;
+begin
+ SendEmptyRec(FCGI_STDIN);
+ SendPrivateBuffer;
+end;
+
+procedure TLFastCGIRequest.AbortRequest;
+begin
+ FHeader.ReqType := FCGI_ABORT_REQUEST;
+ SetContentLength(0);
+ AppendString(FBuffer, @FHeader, sizeof(FHeader));
+ SendPrivateBuffer;
+end;
+
+{ TLFastCGIClient }
+
+const
+ DataBufferSize = 64*1024-1;
+
+constructor TLFastCGIClient.Create(AOwner: TComponent);
+begin
+ inherited;
+
+ FBuffer := GetMem(DataBufferSize+1);
+ FBufferPos := FBuffer;
+ FBufferEnd := FBuffer;
+ FRequests := AllocMem(sizeof(TLFastCGIRequest));
+ FRequestsCount := 1;
+ FFreeRequest := nil;
+ OnReceive := @HandleReceive;
+ OnCanSend := @HandleSend;
+end;
+
+destructor TLFastCGIClient.Destroy;
+var
+ I: integer;
+begin
+ for I := 0 to FNextRequestID-1 do
+ FRequests[I].Free;
+ FreeMem(FRequests);
+ FreeMem(FBuffer);
+ inherited;
+end;
+
+function TLFastCGIClient.GetBuffer(ABuffer: pchar; ASize: integer): integer;
+begin
+ Result := FBufferEnd - FBufferPos;
+ if Result > FContentLength then
+ Result := FContentLength;
+ if Result > ASize then
+ Result := ASize;
+ Move(FBufferPos^, ABuffer^, Result);
+ Inc(FBufferPos, Result);
+ Dec(FContentLength, Result);
+ { buffer empty? reset }
+ if FBufferPos = FBufferEnd then
+ begin
+ FBufferPos := FBuffer;
+ FBufferEnd := FBuffer;
+ end;
+end;
+
+procedure TLFastCGIClient.ConnectEvent(ASocket: TLHandle);
+begin
+ if FState = fsStartingServer then
+ FPool.FSpawnState := ssSpawned;
+ FState := fsHeader;
+ if FPool <> nil then
+ FPool.AddToFreeClients(Self);
+
+ inherited;
+end;
+
+procedure TLFastCGIClient.DisconnectEvent(ASocket: TLHandle);
+var
+ I: integer;
+ needReconnect: boolean;
+begin
+ inherited;
+ FRequestsSent := 0;
+ needReconnect := false;
+ for I := 0 to FNextRequestID-1 do
+ if FRequests[I].FNextFree = nil then
+ begin
+ { see if buffer contains request, then assume we can resend that }
+ if FRequests[I].FBufferSendPos > 0 then
+ begin
+ needReconnect := true;
+ FRequests[I].FBufferSendPos := 0;
+ FRequests[I].SendPrivateBuffer;
+ end else
+ if FRequests[I].FBuffer.Memory = FRequests[I].FBuffer.Pos then
+ needReconnect := true
+ else
+ FRequests[I].EndRequest;
+ end;
+ if needReconnect then
+ Connect;
+end;
+
+procedure TLFastCGIClient.ErrorEvent(const Msg: string; ASocket: TLHandle);
+begin
+ if (FState = fsConnectingAgain)
+ or ((FState = fsConnecting) and (FPool.FSpawnState = ssSpawned)) then
+ begin
+ FRequest.DoEndRequest;
+ EndRequest(FRequest);
+ FState := fsIdle;
+ end else
+ if FState = fsConnecting then
+ begin
+ FPool.StartServer;
+ FState := fsStartingServer;
+ end;
+end;
+
+procedure TLFastCGIClient.HandleGetValuesResult;
+var
+ lNameLen, lValueLen, lIntVal, lCode: integer;
+ lBufferPtr: pchar;
+ lPrevChar: char;
+
+ procedure GetIntVal;
+ begin
+ lPrevChar := lBufferPtr[lNameLen+lValueLen];
+ lBufferPtr[lNameLen+lValueLen] := #0;
+ Val(lBufferPtr+lNameLen, lIntVal, lCode);
+ lBufferPtr[lNameLen+lValueLen] := lPrevChar;
+ end;
+
+begin
+ repeat
+ lBufferPtr := FBufferPos;
+ Inc(lBufferPtr, GetFastCGIStringSize(PByte(lBufferPtr), lNameLen));
+ Inc(lBufferPtr, GetFastCGIStringSize(PByte(lBufferPtr), lValueLen));
+ if lBufferPtr + lNameLen + lValueLen > FBufferEnd then exit;
+ if StrLComp(lBufferPtr, 'FCGI_MAX_REQS', lNameLen) = 0 then
+ begin
+ GetIntVal;
+ if (lCode = 0) and (FRequestsCount <> lIntVal) then
+ begin
+ FRequestsCount := lIntVal;
+ ReallocMem(FRequests, sizeof(TLFastCGIRequest)*lIntVal);
+ end;
+ end else
+ if StrLComp(lBufferPtr, 'FCGI_MAX_CONNS', lNameLen) = 0 then
+ begin
+ GetIntVal;
+ if lCode = 0 then
+ FPool.ClientsMax := lIntVal;
+ end;
+ Inc(lBufferPtr, lNameLen+lValueLen);
+ Dec(FContentLength, lBufferPtr-FBufferPos);
+ FBufferPos := lBufferPtr;
+ until FContentLength = 0;
+end;
+
+procedure TLFastCGIClient.HandleReceive(ASocket: TLSocket);
+var
+ lRead: integer;
+begin
+ lRead := Get(FBufferEnd^, DataBufferSize-PtrUInt(FBufferEnd-FBuffer));
+ if lRead = 0 then exit;
+ { remote side has had chance to disconnect, clear buffer }
+ Inc(FBufferEnd, lRead);
+ ParseBuffer;
+end;
+
+procedure TLFastCGIClient.HandleSend(ASocket: TLSocket);
+var
+ lRequest: TLFastCGIRequest;
+begin
+ if FSendRequest = nil then exit;
+ lRequest := FSendRequest.FNextSend;
+ repeat
+ if not lRequest.SendPrivateBuffer or not lRequest.HandleSend then
+ exit;
+
+ lRequest.FNextSend := nil;
+ { only this one left in list ? }
+ if FSendRequest = lRequest then
+ begin
+ FSendRequest := nil;
+ exit;
+ end else begin
+ lRequest := lRequest.FNextSend;
+ FSendRequest.FNextSend := lRequest;
+ end;
+ until false;
+end;
+
+procedure TLFastCGIClient.AddToSendQueue(ARequest: TLFastCGIRequest);
+begin
+ if ARequest.FNextSend <> nil then exit;
+
+ if FSendRequest = nil then
+ FSendRequest := ARequest
+ else
+ ARequest.FNextSend := FSendRequest.FNextSend;
+ FSendRequest.FNextSend := ARequest;
+end;
+
+procedure TLFastCGIClient.ParseBuffer;
+var
+ lHeader: PFCGI_Header;
+ lReqIndex: integer;
+begin
+ repeat
+ case FState of
+ fsHeader:
+ begin
+ if FBufferEnd-FBufferPos < sizeof(FCGI_Header) then
+ exit;
+ lHeader := PFCGI_Header(FBufferPos);
+ FReqType := lHeader^.ReqType;
+ lReqIndex := (lHeader^.RequestIDB1 shl 8) or lHeader^.RequestIDB0;
+ FContentLength := (lHeader^.ContentLengthB1 shl 8) or lHeader^.ContentLengthB0;
+ FPaddingLength := lHeader^.PaddingLength;
+ Inc(FBufferPos, sizeof(lHeader^));
+ if lReqIndex > 0 then
+ Dec(lReqIndex);
+ if (lReqIndex < FRequestsCount) and (FRequests[lReqIndex] <> nil) then
+ begin
+ FRequest := FRequests[lReqIndex];
+ if FContentLength > 0 then
+ FState := fsData
+ else begin
+ FRequest.HandleReceiveEnd;
+ Flush;
+ end;
+ end else
+ Flush;
+ end;
+ fsData:
+ begin
+ FRequest.HandleReceive;
+ if FContentLength = 0 then
+ Flush
+ else begin
+ FRequest.FOutputPending := true;
+ exit;
+ end;
+ end;
+ fsFlush: Flush;
+ end;
+ until FBufferPos = FBufferEnd;
+end;
+
+procedure TLFastCGIClient.Flush;
+
+ function FlushSize(var ANumBytes: integer): boolean;
+ var
+ lFlushBytes: integer;
+ begin
+ lFlushBytes := ANumBytes;
+ if lFlushBytes > FBufferEnd - FBufferPos then
+ lFlushBytes := FBufferEnd - FBufferPos;
+ Dec(ANumBytes, lFlushBytes);
+ Inc(FBufferPos, lFlushBytes);
+ Result := ANumBytes = 0;
+ end;
+
+begin
+ FState := fsFlush;
+ if FlushSize(FContentLength) and FlushSize(FPaddingLength) then
+ begin
+ { buffer empty? reset }
+ if FBufferPos = FBufferEnd then
+ begin
+ FBufferPos := FBuffer;
+ FBufferEnd := FBuffer;
+ end;
+ FState := fsHeader;
+ FRequest := nil;
+ end;
+end;
+
+function TLFastCGIClient.CreateRequester: TLFastCGIRequest;
+begin
+ if FRequests[FNextRequestID] = nil then
+ FRequests[FNextRequestID] := TLFastCGIRequest.Create;
+ Result := FRequests[FNextRequestID];
+ Inc(FNextRequestID);
+ Result.FClient := Self;
+ Result.ID := FNextRequestID; { request ids start at 1 }
+end;
+
+function TLFastCGIClient.Connect: Boolean;
+begin
+ Result := inherited Connect(FPool.Host, FPool.Port);
+ FRequest := FRequests[0];
+ if FRequest.FBuffer.Pos = FRequest.FBuffer.Memory then
+ FRequest.SendGetValues;
+ if FState <> fsStartingServer then
+ FState := fsConnecting
+ else
+ FState := fsConnectingAgain;
+end;
+
+function TLFastCGIClient.BeginRequest(AType: integer): TLFastCGIRequest;
+begin
+ if FFreeRequest <> nil then
+ begin
+ Result := FFreeRequest.FNextFree;
+ if FFreeRequest = FFreeRequest.FNextFree then
+ FFreeRequest := nil
+ else
+ FFreeRequest.FNextFree := FFreeRequest.FNextFree.FNextFree;
+ Result.FNextFree := nil;
+ end else
+ if FNextRequestID = FRequestsCount then
+ exit(nil)
+ else begin
+ Result := CreateRequester;
+ end;
+
+ if not Connected then
+ Connect;
+
+ Result.SendBeginRequest(AType);
+ Inc(FRequestsSent);
+end;
+
+procedure TLFastCGIClient.EndRequest(ARequest: TLFastCGIRequest);
+begin
+ if FFreeRequest <> nil then
+ ARequest.FNextFree := FFreeRequest.FNextFree
+ else
+ FFreeRequest := ARequest;
+ FFreeRequest.FNextFree := ARequest;
+ if FPool <> nil then
+ FPool.EndRequest(Self);
+end;
+
+{ TLFastCGIPool }
+
+constructor TLFastCGIPool.Create;
+begin
+ FClientsMax := 1;
+ FMaxRequestsConn := 1;
+ inherited;
+end;
+
+destructor TLFastCGIPool.Destroy;
+var
+ I: integer;
+begin
+ for I := 0 to FClientsAvail-1 do
+ FClients[I].Free;
+ FreeMem(FClients);
+ if FTimer <> nil then
+ FTimer.Free;
+ inherited;
+end;
+
+function TLFastCGIPool.CreateClient: TLFastCGIClient;
+begin
+ if FClientsAvail = FClientsCount then
+ begin
+ Inc(FClientsCount, 64);
+ ReallocMem(FClients, FClientsCount*sizeof(TLFastCGIRequest));
+ end;
+ Result := TLFastCGIClient.Create(nil);
+ Result.FPool := Self;
+ Result.Eventer := FEventer;
+ FClients[FClientsAvail] := Result;
+ Inc(FClientsAvail);
+end;
+
+function TLFastCGIPool.BeginRequest(AType: integer): TLFastCGIRequest;
+var
+ lTempClient: TLFastCGIClient;
+begin
+ Result := nil;
+ while FFreeClient <> nil do
+ begin
+ lTempClient := FFreeClient.FNextFree;
+ Result := lTempClient.BeginRequest(AType);
+ if Result <> nil then break;
+ { Result = nil -> no free requesters on next free client }
+ if lTempClient = FFreeClient then
+ FFreeClient := nil
+ else
+ FFreeClient.FNextFree := lTempClient.FNextFree;
+ lTempClient.FNextFree := nil;
+ end;
+
+ { all clients busy }
+ if Result = nil then
+ if FClientsAvail < FClientsMax then
+ Result := CreateClient.BeginRequest(AType);
+end;
+
+procedure TLFastCGIPool.EndRequest(AClient: TLFastCGIClient);
+begin
+ { TODO: wait for other requests to be completed }
+ if AClient.RequestsSent = FMaxRequestsConn then
+ AClient.Disconnect;
+ AddToFreeClients(AClient);
+end;
+
+procedure TLFastCGIPool.AddToFreeClients(AClient: TLFastCGIClient);
+begin
+ if AClient.FNextFree <> nil then exit;
+
+ if FFreeClient = nil then
+ FFreeClient := AClient
+ else
+ AClient.FNextFree := FFreeClient.FNextFree;
+ FFreeClient.FNextFree := AClient;
+end;
+
+procedure TLFastCGIPool.ConnectClients(Sender: TObject);
+var
+ I: integer;
+begin
+ for I := 0 to FClientsAvail-1 do
+ if FClients[I].FState = fsStartingServer then
+ FClients[I].Connect;
+end;
+
+procedure TLFastCGIPool.StartServer;
+begin
+ if FSpawnState = ssNone then
+ begin
+ FSpawnState := ssSpawning;
+ SpawnFCGIProcess(FAppName, FAppEnv, FPort);
+ if FTimer = nil then
+ FTimer := TLTimer.Create;
+ FTimer.OneShot := true;
+ FTimer.OnTimer := @ConnectClients;
+ end;
+ FTimer.Interval := 2000;
+end;
+
+end.
diff --git a/utils/fppkg/lnet/lftp.pp b/utils/fppkg/lnet/lftp.pp
index 86bcceb25a..b900eb14f8 100644
--- a/utils/fppkg/lnet/lftp.pp
+++ b/utils/fppkg/lnet/lftp.pp
@@ -35,9 +35,9 @@ type
TLFTP = class;
TLFTPClient = class;
- TLFTPStatus = (fsNone, fsCon, fsAuth, fsPasv, fsPort, fsList, fsRetr, fsStor,
- fsType, fsCWD, fsMKD, fsRMD, fsDEL, fsRNFR, fsRNTO, fsSYS,
- fsFeat, fsPWD, fsHelp, fsLast);
+ TLFTPStatus = (fsNone, fsCon, fsAuth, fsPass, fsPasv, fsPort, fsList, fsRetr,
+ fsStor, fsType, fsCWD, fsMKD, fsRMD, fsDEL, fsRNFR, fsRNTO,
+ fsSYS, fsFeat, fsPWD, fsHelp, fsLast);
TLFTPStatusSet = set of TLFTPStatus;
@@ -131,6 +131,7 @@ type
procedure OnControlEr(const msg: string; aSocket: TLSocket);
procedure OnControlRe(aSocket: TLSocket);
procedure OnControlCo(aSocket: TLSocket);
+ procedure OnControlDs(aSocket: TLSocket);
function GetTransfer: Boolean;
@@ -170,6 +171,8 @@ type
function Authenticate(const aUsername, aPassword: string): Boolean;
+ function SendPassword(const aPassword: string): Boolean;
+
function GetData(var aData; const aSize: Integer): Integer;
function GetDataMessage: string;
@@ -211,6 +214,8 @@ type
property OnFailure: TLFTPClientStatusEvent read FOnFailure write FOnFailure;
end;
+ function FTPStatusToStr(const aStatus: TLFTPStatus): string;
+
implementation
uses
@@ -222,7 +227,7 @@ const
EMPTY_REC: TLFTPStatusRec = (Status: fsNone; Args: ('', ''));
- FTPStatusStr: array[TLFTPStatus] of string = ('None', 'Connect', 'Authenticate',
+ FTPStatusStr: array[TLFTPStatus] of string = ('None', 'Connect', 'Authenticate', 'Password',
'Passive', 'Active', 'List', 'Retrieve',
'Store', 'Type', 'CWD', 'MKDIR',
'RMDIR', 'Delete', 'RenameFrom',
@@ -258,13 +263,18 @@ begin
Result.Args[2] := Arg2;
end;
+function FTPStatusToStr(const aStatus: TLFTPStatus): string;
+begin
+ Result := FTPStatusStr[aStatus];
+end;
+
{$i lcontainers.inc}
{ TLFTP }
function TLFTP.GetConnected: Boolean;
begin
- Result := FControl.Connected;
+ Result := FControl.Connected;
end;
function TLFTP.GetTimeout: DWord;
@@ -331,6 +341,7 @@ begin
FControl.OnReceive := @OnControlRe;
FControl.OnConnect := @OnControlCo;
FControl.OnError := @OnControlEr;
+ FControl.OnDisconnect := @OnControlDs;
FData.OnReceive := @OnRe;
FData.OnDisconnect := @OnDs;
@@ -372,7 +383,6 @@ end;
procedure TLFTPClient.OnDs(aSocket: TLSocket);
begin
- // TODO: figure it out brainiac
FSending := False;
Writedbg(['Disconnected']);
end;
@@ -409,6 +419,12 @@ begin
FOnConnect(aSocket);
end;
+procedure TLFTPClient.OnControlDs(aSocket: TLSocket);
+begin
+ if Assigned(FOnError) then
+ FOnError('Connection lost', aSocket);
+end;
+
function TLFTPClient.GetTransfer: Boolean;
begin
Result := FData.Connected;
@@ -586,10 +602,22 @@ begin
FStatus.Remove;
end;
331,
- 332: begin
- FStatusFlags[FStatus.First.Status] := False;
- FControl.SendMessage('PASS ' + FPassword + FLE);
- end;
+ 332: SendPassword(FPassword);
+ else
+ begin
+ FStatusFlags[FStatus.First.Status] := False;
+ Eventize(FStatus.First.Status, False);
+ FStatus.Remove;
+ end;
+ end;
+
+ fsPass : case x of
+ 230:
+ begin
+ FStatusFlags[FStatus.First.Status] := True;
+ Eventize(FStatus.First.Status, True);
+ FStatus.Remove;
+ end;
else
begin
FStatusFlags[FStatus.First.Status] := False;
@@ -819,6 +847,7 @@ begin
case Status of
fsNone : Exit;
fsAuth : Authenticate(Args[1], Args[2]);
+ fsPass : SendPassword(Args[1]);
fsList : List(Args[1]);
fsRetr : Retrieve(Args[1]);
fsStor : Put(Args[1]);
@@ -909,6 +938,17 @@ begin
end;
end;
+function TLFTPClient.SendPassword(const aPassword: string): Boolean;
+begin
+ Result := not FPipeLine;
+ if CanContinue(fsPass, aPassword, '') then begin
+ FControl.SendMessage('PASS ' + aPassword + FLE);
+ FStatus.Insert(MakeStatusRec(fsPass, '', ''));
+ Result := True;
+ end;
+end;
+
+
function TLFTPClient.Retrieve(const FileName: string): Boolean;
begin
Result := not FPipeLine;
diff --git a/utils/fppkg/lnet/lhttp.pp b/utils/fppkg/lnet/lhttp.pp
new file mode 100644
index 0000000000..c16e10e0ac
--- /dev/null
+++ b/utils/fppkg/lnet/lhttp.pp
@@ -0,0 +1,2264 @@
+{ HTTP server and client components
+
+ Copyright (C) 2006 Micha Nelissen
+
+ This library is Free software; you can redistribute it and/or modify it
+ under the terms of the GNU Library General Public License as published by
+ the Free Software Foundation; either version 2 of the License, or (at your
+ option) any later version.
+
+ This program is distributed in the hope that it will be useful, but WITHOUT
+ ANY WARRANTY; withOut even the implied warranty of MERCHANTABILITY or
+ FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License
+ for more details.
+
+ You should have received a Copy of the GNU Library General Public License
+ along with This library; if not, Write to the Free Software Foundation,
+ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+ This license has been modified. See file LICENSE.ADDON for more information.
+ Should you find these sources without a LICENSE File, please contact
+ me at ales@chello.sk
+}
+
+unit lhttp;
+
+{$mode objfpc}{$h+}
+{$inline on}
+
+interface
+
+uses
+ classes, sysutils, lnet, levents, lhttputil, lstrbuffer;
+
+type
+ TLHTTPMethod = (hmHead, hmGet, hmPost, hmUnknown);
+ TLHTTPParameter = (hpConnection, hpContentLength, hpContentType,
+ hpAccept, hpAcceptCharset, hpAcceptEncoding, hpAcceptLanguage, hpHost,
+ hpFrom, hpReferer, hpUserAgent, hpRange, hpTransferEncoding,
+ hpIfModifiedSince, hpIfUnmodifiedSince, hpCookie);
+ TLHTTPStatus = (hsUnknown, hsOK, hsNoContent, hsMovedPermanently, hsFound, hsNotModified,
+ hsBadRequest, hsForbidden, hsNotFound, hsPreconditionFailed, hsRequestTooLong,
+ hsInternalError, hsNotImplemented, hsNotAllowed);
+ TLHTTPTransferEncoding = (teIdentity, teChunked);
+ TLHTTPClientError = (ceNone, ceMalformedStatusLine, ceVersionNotSupported,
+ ceUnsupportedEncoding);
+
+const
+ HTTPDisconnectStatuses = [hsBadRequest, hsRequestTooLong, hsForbidden,
+ hsInternalError, hsNotAllowed];
+ HTTPMethodStrings: array[TLHTTPMethod] of string =
+ ('HEAD', 'GET', 'POST', '');
+ HTTPParameterStrings: array[TLHTTPParameter] of string =
+ ('CONNECTION', 'CONTENT-LENGTH', 'CONTENT-TYPE', 'ACCEPT',
+ 'ACCEPT-CHARSET', 'ACCEPT-ENCODING', 'ACCEPT-LANGUAGE', 'HOST',
+ 'FROM', 'REFERER', 'USER-AGENT', 'RANGE', 'TRANSFER-ENCODING',
+ 'IF-MODIFIED-SINCE', 'IF-UNMODIFIED-SINCE', 'COOKIE');
+ HTTPStatusCodes: array[TLHTTPStatus] of dword =
+ (0, 200, 204, 301, 302, 304, 400, 403, 404, 412, 414, 500, 501, 504);
+ HTTPTexts: array[TLHTTPStatus] of string =
+ ('', 'OK', 'No Content', 'Moved Permanently', 'Found', 'Not Modified', 'Bad Request', 'Forbidden',
+ 'Not Found', 'Precondition Failed', 'Request Too Long', 'Internal Error',
+ 'Method Not Implemented', 'Method Not Allowed');
+ HTTPDescriptions: array[TLHTTPStatus] of string = (
+ { hsUnknown }
+ '',
+ { hsOK }
+ '',
+ { hsNoContent }
+ '',
+ { hsMovedPermanently }
+ '',
+ { hsFound }
+ '',
+ { hsNotModified }
+ '',
+ { hsBadRequest }
+ '400 Bad Request'+#10+
+ 'Bad Request
'+#10+
+ 'Your browser did a request this server did not understand.
'+#10+
+ ''+#10,
+ { hsForbidden }
+ '403 Forbidden'+#10+
+ 'Forbidden
'+#10+
+ 'You do not have permission to access this resource.
'+#10+
+ ''+#10,
+ { hsNotFound }
+ '404 Not Found'+#10+
+ 'Not Found
'+#10+
+ 'The requested URL was not found on this server.
'+#10+
+ ''+#10,
+ { hsPreconditionFailed }
+ '412 Precondition Failed'+#10+
+ 'Precondition Failed
'+#10+
+ 'The precondition on the request evaluated to false.
'+#10+
+ ''+#10,
+ { hsRequestTooLong }
+ '414 Request Too Long'+#10+
+ 'Bad Request
'+#10+
+ 'Your browser did a request that was too long for this server to parse.
'+#10+
+ ''+#10,
+ { hsInternalError }
+ '500 Internal Error'+#10+
+ 'Internal Error
'+#10+
+ 'An error occurred while generating the content for this request.
'+#10+
+ ''+#10,
+ { hsNotImplemented }
+ '501 Method Not Implemented'+#10+
+ 'Method Not Implemented
'+#10+
+ 'The method used in the request is invalid.
'+#10+
+ ''+#10,
+ { hsNotAllowed }
+ '504 Method Not Allowed'+#10+
+ 'Method Not Allowed
'+#10+
+ 'The method used in the request is not allowed on the resource specified in the URL.
'+#10+
+ ''+#10);
+
+
+type
+ TLHTTPSocket = class;
+ TLHTTPConnection = class;
+ TLHTTPClientSocket = class;
+
+ PRequestInfo = ^TRequestInfo;
+ TRequestInfo = record
+ RequestType: TLHTTPMethod;
+ DateTime: TDateTime;
+ Method: pchar;
+ Argument: pchar;
+ QueryParams: pchar;
+ VersionStr: pchar;
+ Version: dword;
+ end;
+
+ PClientRequest = ^TClientRequest;
+ TClientRequest = record
+ Method: TLHTTPMethod;
+ URI: string;
+ QueryParams: string;
+ RangeStart: qword;
+ RangeEnd: qword;
+ end;
+
+ PClientResponse = ^TClientResponse;
+ TClientResponse = record
+ Status: TLHTTPStatus;
+ Version: dword;
+ Reason: string;
+ end;
+
+ PHeaderOutInfo = ^THeaderOutInfo;
+ THeaderOutInfo = record
+ ContentLength: integer;
+ TransferEncoding: TLHTTPTransferEncoding;
+ ExtraHeaders: TStringBuffer;
+ Version: dword;
+ end;
+
+ PResponseInfo = ^TResponseInfo;
+ TResponseInfo = record
+ Status: TLHTTPStatus;
+ ContentType: string;
+ ContentCharset: string;
+ LastModified: TDateTime;
+ end;
+
+ TWriteBlockStatus = (wsPendingData, wsWaitingData, wsDone);
+ TWriteBlockMethod = function: TWriteBlockStatus of object;
+
+ TOutputItem = class(TObject)
+ protected
+ FBuffer: pchar;
+ FBufferPos: integer;
+ FBufferSize: integer;
+ FBufferOffset: integer;
+ FOutputPending: boolean;
+ FEof: boolean;
+ FPrev: TOutputItem;
+ FNext: TOutputItem;
+ FPrevDelayFree: TOutputItem;
+ FNextDelayFree: TOutputItem;
+ FSocket: TLHTTPSocket;
+ FWriteBlock: TWriteBlockMethod;
+
+ procedure DoneInput; virtual;
+ function HandleInput(ABuffer: pchar; ASize: integer): integer; virtual;
+ function WriteBlock: TWriteBlockStatus; virtual;
+ public
+ constructor Create(ASocket: TLHTTPSocket);
+ destructor Destroy; override;
+
+ procedure LogError(const AMessage: string);
+
+ property Socket: TLHTTPSocket read FSocket;
+ end;
+
+ TProcMethod = procedure of object;
+
+ TBufferOutput = class(TOutputItem)
+ protected
+ FPrepareBuffer: TProcMethod;
+ FFinishBuffer: TProcMethod;
+ FBufferMemSize: integer;
+
+ procedure PrepareBuffer;
+ procedure PrepareChunk;
+ procedure FinishBuffer;
+ procedure FinishChunk;
+ procedure SelectChunked;
+ procedure SelectBuffered;
+ procedure SelectPlain;
+ procedure PrependBufferOutput(MinBufferSize: integer);
+ procedure PrependStreamOutput(AStream: TStream; AFree: boolean);
+ function FillBuffer: TWriteBlockStatus; virtual; abstract;
+ function WriteChunk: TWriteBlockStatus;
+ function WriteBuffer: TWriteBlockStatus;
+ function WritePlain: TWriteBlockStatus;
+ function WriteBlock: TWriteBlockStatus; override;
+ public
+ constructor Create(ASocket: TLHTTPSocket);
+ destructor Destroy; override;
+
+ procedure Add(ABuf: pointer; ASize: integer);
+ procedure Add(const AStr: string);
+ procedure Add(AStream: TStream; AQueue: boolean = false; AFree: boolean = true);
+ end;
+
+ TMemoryOutput = class(TOutputItem)
+ protected
+ FFreeBuffer: boolean;
+ public
+ constructor Create(ASocket: TLHTTPSocket; ABuffer: pointer;
+ ABufferOffset, ABufferSize: integer; AFreeBuffer: boolean);
+ destructor Destroy; override;
+ end;
+
+ TStreamOutput = class(TBufferOutput)
+ protected
+ FStream: TStream;
+ FFreeStream: boolean;
+ FStreamSize: integer;
+
+ function FillBuffer: TWriteBlockStatus; override;
+ public
+ constructor Create(ASocket: TLHTTPSocket; AStream: TStream; AFreeStream: boolean);
+ destructor Destroy; override;
+ end;
+
+ TMemoryStreamOutput = class(TOutputItem)
+ protected
+ FFreeStream: boolean;
+ FStream: TMemoryStream;
+
+ function WriteBlock: TWriteBlockStatus; override;
+ public
+ constructor Create(ASocket: TLHTTPSocket; AStream: TMemoryStream; AFreeStream: boolean);
+ destructor Destroy; override;
+ end;
+
+ TChunkState = (csInitial, csData, csDataEnd, csTrailer, csFinished);
+ TLHTTPParameterArray = array[TLHTTPParameter] of pchar;
+
+ TParseBufferMethod = function: boolean of object;
+ TLInputEvent = function(ASocket: TLHTTPClientSocket; ABuffer: pchar; ASize: integer): integer of object;
+ TLCanWriteEvent = procedure(ASocket: TLHTTPClientSocket; var OutputEof: TWriteBlockStatus) of object;
+ TLHTTPClientEvent = procedure(ASocket: TLHTTPClientSocket) of object;
+
+ TLHTTPConnection = class(TLTcp)
+ protected
+ procedure CanSendEvent(aSocket: TLHandle); override;
+ procedure LogAccess(const AMessage: string); virtual;
+ procedure ReceiveEvent(aSocket: TLHandle); override;
+ public
+ destructor Destroy; override;
+ end;
+
+ TLHTTPSocket = class(TLSocket)
+ protected
+ FBuffer: pchar;
+ FBufferPos: pchar;
+ FBufferEnd: pchar;
+ FBufferSize: integer;
+ FRequestBuffer: pchar;
+ FRequestPos: pchar;
+ FRequestInputDone: boolean;
+ FRequestHeaderDone: boolean;
+ FOutputDone: boolean;
+ FInputRemaining: integer;
+ FChunkState: TChunkState;
+ FCurrentInput: TOutputItem;
+ FCurrentOutput: TOutputItem;
+ FLastOutput: TOutputItem;
+ FKeepAlive: boolean;
+ FParseBuffer: TParseBufferMethod;
+ FParameters: TLHTTPParameterArray;
+ FDelayFreeItems: TOutputItem;
+
+ procedure AddContentLength(ALength: integer); virtual; abstract;
+ function CalcAvailableBufferSpace: integer;
+ procedure DelayFree(AOutputItem: TOutputItem);
+ procedure Disconnect; override;
+ procedure DoneBuffer(AOutput: TBufferOutput); virtual;
+ procedure FreeDelayFreeItems;
+ procedure LogAccess(const AMessage: string); virtual;
+ procedure LogMessage; virtual;
+ procedure FlushRequest; virtual;
+ procedure PackRequestBuffer;
+ procedure PackInputBuffer;
+ function ParseRequest: boolean;
+ function ParseEntityPlain: boolean;
+ function ParseEntityChunked: boolean;
+ procedure ParseLine(pLineEnd: pchar); virtual;
+ procedure ParseParameterLine(pLineEnd: pchar);
+ function ProcessEncoding: boolean;
+ procedure ProcessHeaders; virtual; abstract;
+ procedure RelocateVariable(var AVar: pchar);
+ procedure RelocateVariables; virtual;
+ procedure ResetDefaults; virtual;
+ function SetupEncoding(AOutputItem: TBufferOutput; AHeaderOut: PHeaderOutInfo): boolean;
+ procedure WriteError(AStatus: TLHTTPStatus); virtual;
+ public
+ constructor Create; override;
+ destructor Destroy; override;
+
+ procedure AddToOutput(AOutputItem: TOutputItem);
+ procedure PrependOutput(ANewItem, AItem: TOutputItem);
+ procedure RemoveOutput(AOutputItem: TOutputItem);
+ procedure HandleReceive;
+ function ParseBuffer: boolean;
+ procedure WriteBlock;
+
+ property Parameters: TLHTTPParameterArray read FParameters;
+ end;
+
+ { http server }
+
+ TSetupEncodingState = (seNone, seWaitHeaders, seStartHeaders);
+
+ TLHTTPServerSocket = class(TLHTTPSocket)
+ protected
+ FLogMessage: TStringBuffer;
+ FRequestInfo: TRequestInfo;
+ FResponseInfo: TResponseInfo;
+ FHeaderOut: THeaderOutInfo;
+ FSetupEncodingState: TSetupEncodingState;
+
+ procedure AddContentLength(ALength: integer); override;
+ procedure DoneBuffer(AOutput: TBufferOutput); override;
+ procedure FlushRequest; override;
+ function HandleURI: TOutputItem; virtual;
+ procedure LogAccess(const AMessage: string); override;
+ procedure LogMessage; override;
+ procedure RelocateVariables; override;
+ procedure ResetDefaults; override;
+ procedure ParseLine(pLineEnd: pchar); override;
+ procedure ParseRequestLine(pLineEnd: pchar);
+ function PrepareResponse(AOutputItem: TOutputItem; ACustomErrorMessage: boolean): boolean;
+ procedure ProcessHeaders; override;
+ procedure WriteError(AStatus: TLHTTPStatus); override;
+ procedure WriteHeaders(AHeaderResponse, ADataResponse: TOutputItem);
+ public
+ constructor Create; override;
+ destructor Destroy; override;
+
+ function SetupEncoding(AOutputItem: TBufferOutput): boolean;
+ procedure StartMemoryResponse(AOutputItem: TMemoryOutput; ACustomErrorMessage: boolean = false);
+ procedure StartResponse(AOutputItem: TBufferOutput; ACustomErrorMessage: boolean = false);
+
+ property HeaderOut: THeaderOutInfo read FHeaderOut;
+ property RequestInfo: TRequestInfo read FRequestInfo;
+ property ResponseInfo: TResponseInfo read FResponseInfo;
+ end;
+
+ TURIHandler = class(TObject)
+ private
+ FNext: TURIHandler;
+ protected
+ function HandleURI(ASocket: TLHTTPServerSocket): TOutputItem; virtual; abstract;
+ procedure RegisterWithEventer(AEventer: TLEventer); virtual;
+ end;
+
+ TLAccessEvent = procedure(AMessage: string) of object;
+
+ TLHTTPServer = class(TLHTTPConnection)
+ protected
+ FHandlerList: TURIHandler;
+ FLogMessageTZString: string;
+ FServerSoftware: string;
+ FOnAccess: TLAccessEvent;
+
+ function HandleURI(ASocket: TLHTTPServerSocket): TOutputItem;
+ protected
+ procedure LogAccess(const AMessage: string); override;
+ procedure RegisterWithEventer; override;
+ public
+ constructor Create(AOwner: TComponent); override;
+
+ procedure RegisterHandler(AHandler: TURIHandler);
+
+ property ServerSoftware: string read FServerSoftware write FServerSoftware;
+ property OnAccess: TLAccessEvent read FOnAccess write FOnAccess;
+ end;
+
+ { http client }
+
+ TLHTTPClientSocket = class(TLHTTPSocket)
+ protected
+ FRequest: PClientRequest;
+ FResponse: PClientResponse;
+ FHeaderOut: PHeaderOutInfo;
+ FError: TLHTTPClientError;
+
+ procedure AddContentLength(ALength: integer); override;
+ function GetResponseReason: string;
+ function GetResponseStatus: TLHTTPStatus;
+ procedure Cancel(AError: TLHTTPClientError);
+ procedure ParseLine(pLineEnd: pchar); override;
+ procedure ParseStatusLine(pLineEnd: pchar);
+ procedure ProcessHeaders; override;
+ procedure ResetDefaults; override;
+ public
+ constructor Create; override;
+ destructor Destroy; override;
+
+ procedure SendRequest;
+
+ property Error: TLHTTPClientError read FError write FError;
+ property Response: PClientResponse read FResponse;
+ property ResponseReason: string read GetResponseReason;
+ property ResponseStatus: TLHTTPStatus read GetResponseStatus;
+ end;
+
+ TLHTTPClientState = (hcsIdle, hcsWaiting, hcsReceiving);
+
+ TLHTTPClient = class(TLHTTPConnection)
+ protected
+ FRequest: TClientRequest;
+ FResponse: TClientResponse;
+ FHeaderOut: THeaderOutInfo;
+ FState: TLHTTPClientState;
+ FPendingResponses: integer;
+ FOutputEof: boolean;
+ FOnCanWrite: TLCanWriteEvent;
+ FOnDoneInput: TLHTTPClientEvent;
+ FOnInput: TLInputEvent;
+ FOnProcessHeaders: TLHTTPClientEvent;
+
+ procedure ConnectEvent(aSocket: TLHandle); override;
+ procedure DoDoneInput(ASocket: TLHTTPClientSocket);
+ function DoHandleInput(ASocket: TLHTTPClientSocket; ABuffer: pchar; ASize: integer): integer;
+ procedure DoProcessHeaders(ASocket: TLHTTPClientSocket);
+ function DoWriteBlock(ASocket: TLHTTPClientSocket): TWriteBlockStatus;
+ function InitSocket(aSocket: TLSocket): TLSocket; override;
+ procedure InternalSendRequest;
+ public
+ constructor Create(AOwner: TComponent); override;
+ destructor Destroy; override;
+
+ procedure AddExtraHeader(const AHeader: string);
+ procedure ResetRange;
+ procedure SendRequest;
+
+ property ContentLength: integer read FHeaderOut.ContentLength write FHeaderOut.ContentLength;
+ property Method: TLHTTPMethod read FRequest.Method write FRequest.Method;
+ property PendingResponses: integer read FPendingResponses;
+ property RangeStart: qword read FRequest.RangeStart write FRequest.RangeStart;
+ property RangeEnd: qword read FRequest.RangeEnd write FRequest.RangeEnd;
+ property Request: TClientRequest read FRequest;
+ property State: TLHTTPClientState read FState;
+ property URI: string read FRequest.URI write FRequest.URI;
+ property Response: TClientResponse read FResponse;
+ property OnCanWrite: TLCanWriteEvent read FOnCanWrite write FOnCanWrite;
+ property OnDoneInput: TLHTTPClientEvent read FOnDoneInput write FOnDoneInput;
+ property OnInput: TLInputEvent read FOnInput write FOnInput;
+ property OnProcessHeaders: TLHTTPClientEvent read FOnProcessHeaders write FOnProcessHeaders;
+ end;
+
+implementation
+
+uses
+ lCommon;
+
+const
+ RequestBufferSize = 1024;
+ DataBufferSize = 16*1024;
+
+ BufferEmptyToWriteStatus: array[boolean] of TWriteBlockStatus =
+ (wsPendingData, wsDone);
+ EofToWriteStatus: array[boolean] of TWriteBlockStatus =
+ (wsWaitingData, wsDone);
+
+{ helper functions }
+
+function TrySingleDigit(ADigit: char; out OutDigit: byte): boolean;
+begin
+ Result := (ord(ADigit) >= ord('0')) and (ord(ADigit) <= ord('9'));
+ if not Result then exit;
+ OutDigit := ord(ADigit) - ord('0');
+end;
+
+function HTTPVersionCheck(AStr, AStrEnd: pchar; out AVersion: dword): boolean;
+var
+ lMajorVersion, lMinorVersion: byte;
+begin
+ Result := ((AStrEnd-AStr) = 8)
+ and CompareMem(AStr, pchar('HTTP/'), 5)
+ and TrySingleDigit(AStr[5], lMajorVersion)
+ and (AStr[6] = '.')
+ and TrySingleDigit(AStr[7], lMinorVersion);
+ AVersion := lMajorVersion * 10 + lMinorVersion;
+end;
+
+function CodeToHTTPStatus(ACode: dword): TLHTTPStatus;
+begin
+ for Result := Low(TLHTTPStatus) to High(TLHTTPStatus) do
+ if HTTPStatusCodes[Result] = ACode then exit;
+ Result := hsUnknown;
+end;
+
+const
+ HexDigits: array[0..15] of char = '0123456789ABCDEF';
+
+function HexReverse(AValue: dword; ABuffer: pchar): integer;
+begin
+ Result := 0;
+ repeat
+ ABuffer^ := HexDigits[AValue and $F];
+ AValue := AValue shr 4;
+ Dec(ABuffer);
+ Inc(Result);
+ until AValue = 0;
+end;
+
+procedure HexToInt(ABuffer: pchar; out AValue: dword; out ACode: integer);
+var
+ Val, Incr: dword;
+ Start: pchar;
+begin
+ Val := 0;
+ ACode := 0;
+ Start := ABuffer;
+ while ABuffer^ <> #0 do
+ begin
+ if (ABuffer^ >= '0') and (ABuffer^ <= '9') then
+ Incr := ord(ABuffer^) - ord('0')
+ else if (ABuffer^ >= 'A') and (ABuffer^ <= 'F') then
+ Incr := ord(ABuffer^) - ord('A') + 10
+ else if (ABuffer^ >= 'a') and (ABuffer^ <= 'f') then
+ Incr := ord(ABuffer^) - ord('a') + 10
+ else begin
+ ACode := ABuffer - Start + 1;
+ break;
+ end;
+ Val := (Val shl 4) + Incr;
+ Inc(ABuffer);
+ end;
+ AValue := Val;
+end;
+
+{ TURIHandler }
+
+procedure TURIHandler.RegisterWithEventer(AEventer: TLEventer);
+begin
+end;
+
+{ TOutputItem }
+
+constructor TOutputItem.Create(ASocket: TLHTTPSocket);
+begin
+ FSocket := ASocket;
+ inherited Create;
+end;
+
+destructor TOutputItem.Destroy;
+begin
+ if FSocket.FCurrentInput = Self then
+ FSocket.FCurrentInput := nil;
+
+ if FPrevDelayFree = nil then
+ FSocket.FDelayFreeItems := FNextDelayFree
+ else
+ FPrevDelayFree.FNextDelayFree := FNextDelayFree;
+ if FNextDelayFree <> nil then
+ FNextDelayFree.FPrevDelayFree := FPrevDelayFree;
+
+ inherited;
+end;
+
+procedure TOutputItem.DoneInput;
+begin
+end;
+
+function TOutputItem.HandleInput(ABuffer: pchar; ASize: integer): integer;
+begin
+ { discard input }
+ Result := ASize;
+end;
+
+procedure TOutputItem.LogError(const AMessage: string);
+begin
+ FSocket.LogError(AMessage, 0);
+end;
+
+function TOutputItem.WriteBlock: TWriteBlockStatus;
+var
+ lWritten: integer;
+begin
+ if FOutputPending then
+ begin
+ if FBufferSize > FBufferPos then
+ begin
+ lWritten := FSocket.Send(FBuffer[FBufferPos], FBufferSize-FBufferPos);
+ Inc(FBufferPos, lWritten);
+ end;
+ FOutputPending := FBufferPos < FBufferSize;
+ Result := BufferEmptyToWriteStatus[not FOutputPending];
+ end else
+ Result := EofToWriteStatus[FEof];
+end;
+
+const
+ ReserveChunkBytes = 12;
+
+constructor TBufferOutput.Create(ASocket: TLHTTPSocket);
+begin
+ inherited;
+ GetMem(FBuffer, DataBufferSize);
+ FWriteBlock := @WritePlain;
+ FPrepareBuffer := @PrepareBuffer;
+ FFinishBuffer := @FinishBuffer;
+ FBufferMemSize := DataBufferSize;
+end;
+
+destructor TBufferOutput.Destroy;
+begin
+ inherited;
+ FreeMem(FBuffer);
+end;
+
+procedure TBufferOutput.Add(ABuf: pointer; ASize: integer);
+var
+ copySize: integer;
+begin
+ repeat
+ copySize := FBufferSize-FBufferPos;
+ if copySize > ASize then
+ copySize := ASize;
+ Move(ABuf^, FBuffer[FBufferPos], copySize);
+ Inc(FBufferPos, copySize);
+ Dec(ASize, copySize);
+ if ASize = 0 then
+ break;
+ PrependBufferOutput(ASize);
+ until false;
+end;
+
+procedure TBufferOutput.Add(const AStr: string);
+begin
+ Add(PChar(AStr), Length(AStr));
+end;
+
+procedure TBufferOutput.PrependStreamOutput(AStream: TStream; AFree: boolean);
+begin
+ if AStream is TMemoryStream then
+ FSocket.PrependOutput(TMemoryStreamOutput.Create(FSocket, TMemoryStream(AStream), AFree), Self)
+ else
+ FSocket.PrependOutput(TStreamOutput.Create(FSocket, AStream, AFree), Self);
+end;
+
+procedure TBufferOutput.Add(AStream: TStream; AQueue: boolean = false;
+ AFree: boolean = true);
+var
+ size, copySize: integer;
+begin
+ size := AStream.Size - AStream.Position;
+ repeat
+ copySize := FBufferSize-FBufferPos;
+ if copySize > size then
+ copySize := size;
+ AStream.Read(FBuffer[FBufferPos], copySize);
+ Inc(FBufferPos, copySize);
+ Dec(size, copySize);
+ if size = 0 then
+ break;
+ if AQueue then
+ begin
+ PrependBufferOutput(0);
+ PrependStreamOutput(AStream, AFree);
+ end else begin
+ PrependBufferOutput(size);
+ end;
+ until false;
+end;
+
+procedure TBufferOutput.PrepareChunk;
+begin
+ { 12 bytes for starting space, 7 bytes to end: 0 }
+ FBufferPos := ReserveChunkBytes;
+ FBufferOffset := FBufferPos;
+ FBufferSize := FBufferMemSize-7;
+end;
+
+procedure TBufferOutput.FinishChunk;
+var
+ lOffset: integer;
+begin
+ lOffset := HexReverse(FBufferPos-FBufferOffset, FBuffer+FBufferOffset-3);
+ FBuffer[FBufferOffset-2] := #13;
+ FBuffer[FBufferOffset-1] := #10;
+ FBuffer[FBufferPos] := #13;
+ FBuffer[FBufferPos+1] := #10;
+ FBufferSize := FBufferPos+2;
+ FBufferPos := FBufferOffset-lOffset-2;
+end;
+
+procedure TBufferOutput.PrepareBuffer;
+ { also for "plain" encoding }
+begin
+ FBufferPos := 0;
+ FBufferOffset := 0;
+ FBufferSize := FBufferMemSize;
+end;
+
+procedure TBufferOutput.FinishBuffer;
+begin
+ { nothing to do }
+end;
+
+procedure TBufferOutput.PrependBufferOutput(MinBufferSize: integer);
+begin
+ FFinishBuffer();
+ FSocket.PrependOutput(TMemoryOutput.Create(FSocket, FBuffer, FBufferOffset,
+ FBufferPos, true), Self);
+ FBufferMemSize := MinBufferSize;
+ if FBufferMemSize < DataBufferSize then
+ FBufferMemSize := DataBufferSize;
+ FBuffer := GetMem(FBufferMemSize);
+ FPrepareBuffer();
+end;
+
+function TBufferOutput.WriteChunk: TWriteBlockStatus;
+begin
+ if not FOutputPending and not FEof then
+ begin
+ Result := FillBuffer;
+ FEof := Result = wsDone;
+ FOutputPending := FBufferPos > FBufferOffset;
+ if FOutputPending then
+ FinishChunk;
+ if FEof then
+ begin
+ if not FOutputPending then
+ begin
+ { FBufferPos/Size still in "fill mode" }
+ FBufferSize := 0;
+ FBufferPos := 0;
+ FOutputPending := true;
+ end;
+ FBuffer[FBufferSize] := '0';
+ FBuffer[FBufferSize+1] := #13;
+ FBuffer[FBufferSize+2] := #10;
+ { no trailer }
+ FBuffer[FBufferSize+3] := #13;
+ FBuffer[FBufferSize+4] := #10;
+ inc(FBufferSize, 5);
+ end;
+ end else
+ Result := EofToWriteStatus[FEof];
+ if FOutputPending then
+ begin
+ Result := inherited WriteBlock;
+ if (Result = wsDone) and not FEof then
+ begin
+ Result := wsPendingData;
+ PrepareChunk;
+ end;
+ end;
+end;
+
+function TBufferOutput.WriteBuffer: TWriteBlockStatus;
+begin
+ if not FOutputPending then
+ begin
+ Result := FillBuffer;
+ FEof := Result = wsDone;
+ FOutputPending := FEof;
+ if FOutputPending or (FBufferPos = FBufferSize) then
+ begin
+ if FBufferPos > FBufferOffset then
+ begin
+ FSocket.AddContentLength(FBufferPos-FBufferOffset);
+ if not FEof then
+ PrependBufferOutput(0)
+ else begin
+ FBufferSize := FBufferPos;
+ FBufferPos := FBufferOffset;
+ end;
+ end else begin
+ FBufferPos := 0;
+ FBufferSize := 0;
+ end;
+ if FEof then
+ FSocket.DoneBuffer(Self);
+ end;
+ end else
+ Result := EofToWriteStatus[FEof];
+ if Result = wsDone then
+ Result := inherited WriteBlock;
+end;
+
+function TBufferOutput.WritePlain: TWriteBlockStatus;
+begin
+ if not FOutputPending then
+ begin
+ Result := FillBuffer;
+ FEof := Result = wsDone;
+ if FBufferPos > FBufferOffset then
+ begin
+ FOutputPending := true;
+ FBufferSize := FBufferPos;
+ FBufferPos := FBufferOffset;
+ end else begin
+ FBufferSize := 0;
+ FBufferPos := 0;
+ end;
+ end;
+ Result := inherited WriteBlock;
+ if Result <> wsPendingData then
+ begin
+ PrepareBuffer;
+ if not FEof then
+ Result := wsPendingData;
+ end;
+end;
+
+function TBufferOutput.WriteBlock: TWriteBlockStatus;
+begin
+ Result := FWriteBlock();
+end;
+
+procedure TBufferOutput.SelectChunked;
+begin
+ FPrepareBuffer := @PrepareChunk;
+ FWriteBlock := @WriteChunk;
+ FFinishBuffer := @FinishChunk;
+ PrepareChunk;
+end;
+
+procedure TBufferOutput.SelectBuffered;
+begin
+ FPrepareBuffer := @PrepareBuffer;
+ FWriteBlock := @WriteBuffer;
+ FFinishBuffer := @FinishBuffer;
+ PrepareBuffer;
+end;
+
+procedure TBufferOutput.SelectPlain;
+begin
+ FPrepareBuffer := @PrepareBuffer;
+ FWriteBlock := @WritePlain;
+ FFinishBuffer := @FinishBuffer;
+ PrepareBuffer;
+end;
+
+{ TMemoryOutput }
+
+constructor TMemoryOutput.Create(ASocket: TLHTTPSocket; ABuffer: pointer;
+ ABufferOffset, ABufferSize: integer; AFreeBuffer: boolean);
+begin
+ inherited Create(ASocket);
+
+ FBuffer := ABuffer;
+ FBufferPos := ABufferOffset;
+ FBufferSize := ABufferSize;
+ FFreeBuffer := AFreeBuffer;
+ FOutputPending := true;
+end;
+
+destructor TMemoryOutput.Destroy;
+begin
+ inherited;
+ if FFreeBuffer then
+ FreeMem(FBuffer);
+end;
+
+{ TStreamOutput }
+
+constructor TStreamOutput.Create(ASocket: TLHTTPSocket; AStream: TStream; AFreeStream: boolean);
+begin
+ inherited Create(ASocket);
+ FStream := AStream;
+ FFreeStream := AFreeStream;
+ FStreamSize := AStream.Size;
+end;
+
+destructor TStreamOutput.Destroy;
+begin
+ if FFreeStream then
+ FStream.Free;
+ inherited;
+end;
+
+function TStreamOutput.FillBuffer: TWriteBlockStatus;
+var
+ lRead: integer;
+begin
+ lRead := FStream.Read(FBuffer[FBufferPos], FBufferSize-FBufferPos);
+ Inc(FBufferPos, lRead);
+ Result := BufferEmptyToWriteStatus[FStream.Position >= FStreamSize];
+end;
+
+{ TMemoryStreamOutput }
+
+constructor TMemoryStreamOutput.Create(ASocket: TLHTTPSocket; AStream: TMemoryStream;
+ AFreeStream: boolean);
+begin
+ inherited Create(ASocket);
+ FStream := AStream;
+ FFreeStream := AFreeStream;
+ FOutputPending := true;
+end;
+
+destructor TMemoryStreamOutput.Destroy;
+begin
+ if FFreeStream then
+ FStream.Free;
+ inherited;
+end;
+
+function TMemoryStreamOutput.WriteBlock: TWriteBlockStatus;
+var
+ lWritten: integer;
+begin
+ if not FOutputPending then
+ exit(wsDone);
+
+ lWritten := FSocket.Send(PByte(FStream.Memory)[FStream.Position], FStream.Size-FStream.Position);
+ FStream.Position := FStream.Position + lWritten;
+ FOutputPending := FStream.Position < FStream.Size;
+ FEof := not FOutputPending;
+ Result := EofToWriteStatus[FEof];
+end;
+
+{ TLHTTPSocket }
+
+constructor TLHTTPSocket.Create;
+begin
+ inherited;
+
+ FBuffer := GetMem(RequestBufferSize);
+ FBufferSize := RequestBufferSize;
+ FBufferPos := FBuffer;
+ FBufferEnd := FBufferPos;
+ FBuffer[0] := #0;
+ FKeepAlive := true;
+end;
+
+destructor TLHTTPSocket.Destroy;
+begin
+ FreeDelayFreeItems;
+ inherited;
+ FreeMem(FBuffer);
+end;
+
+procedure TLHTTPSocket.Disconnect;
+var
+ lOutput: TOutputItem;
+begin
+ inherited Disconnect;
+ while FCurrentOutput <> nil do
+ begin
+ lOutput := FCurrentOutput;
+ FCurrentOutput := FCurrentOutput.FNext;
+ lOutput.Free;
+ end;
+ if FCurrentInput <> nil then
+ FreeAndNil(FCurrentInput);
+end;
+
+procedure TLHTTPSocket.FreeDelayFreeItems;
+var
+ lItem: TOutputItem;
+begin
+ while FDelayFreeItems <> nil do
+ begin
+ lItem := FDelayFreeItems;
+ FDelayFreeItems := FDelayFreeItems.FNextDelayFree;
+ lItem.Free;
+ end;
+end;
+
+procedure TLHTTPSocket.DelayFree(AOutputItem: TOutputItem);
+begin
+ if AOutputItem = nil then exit;
+ if FDelayFreeItems <> nil then
+ FDelayFreeItems.FPrevDelayFree := AOutputItem;
+ AOutputItem.FNextDelayFree := FDelayFreeItems;
+ FDelayFreeItems := AOutputItem;
+end;
+
+procedure TLHTTPSocket.DoneBuffer(AOutput: TBufferOutput);
+begin
+end;
+
+procedure TLHTTPSocket.LogMessage;
+begin
+end;
+
+procedure TLHTTPSocket.LogAccess(const AMessage: string);
+begin
+end;
+
+procedure TLHTTPSocket.WriteError(AStatus: TLHTTPStatus);
+begin
+end;
+
+procedure TLHTTPSocket.AddToOutput(AOutputItem: TOutputItem);
+begin
+ AOutputItem.FPrev := FLastOutput;
+ if FLastOutput <> nil then
+ begin
+ FLastOutput.FNext := AOutputItem;
+ end else begin
+ FCurrentOutput := AOutputItem;
+ end;
+ FLastOutput := AOutputItem;
+end;
+
+procedure TLHTTPSocket.PrependOutput(ANewItem, AItem: TOutputItem);
+begin
+ ANewItem.FPrev := AItem.FPrev;
+ ANewItem.FNext := AItem;
+ AItem.FPrev := ANewItem;
+ if FCurrentOutput = AItem then
+ FCurrentOutput := ANewItem;
+end;
+
+procedure TLHTTPSocket.RemoveOutput(AOutputItem: TOutputItem);
+begin
+ if AOutputItem.FPrev <> nil then
+ AOutputItem.FPrev.FNext := AOutputItem.FNext;
+ if AOutputItem.FNext <> nil then
+ AOutputItem.FNext.FPrev := AOutputItem.FPrev;
+ if FLastOutput = AOutputItem then
+ FLastOutput := AOutputItem.FPrev;
+ if FCurrentOutput = AOutputItem then
+ FCurrentOutput := AOutputItem.FNext;
+ AOutputItem.FPrev := nil;
+ AOutputItem.FNext := nil;
+end;
+
+procedure TLHTTPSocket.ResetDefaults;
+begin
+ FParseBuffer := @ParseRequest;
+end;
+
+procedure TLHTTPSocket.FlushRequest;
+begin
+ FillDWord(FParameters, sizeof(FParameters) div 4, 0);
+ ResetDefaults;
+end;
+
+function TLHTTPSocket.CalcAvailableBufferSpace: integer;
+begin
+ Result := FBufferSize-(FBufferEnd-FBuffer)-1;
+end;
+
+procedure TLHTTPSocket.HandleReceive;
+var
+ lRead: integer;
+begin
+ if FRequestInputDone then
+ begin
+ IgnoreRead := true;
+ exit;
+ end;
+
+ lRead := CalcAvailableBufferSpace;
+ { if buffer has filled up, keep ignoring and continue parsing requests }
+ if lRead > 0 then
+ begin
+ IgnoreRead := false;
+ lRead := Get(FBufferEnd^, lRead);
+ if lRead = 0 then exit;
+ Inc(FBufferEnd, lRead);
+ FBufferEnd^ := #0;
+ end;
+ ParseBuffer;
+
+ if FIgnoreWrite then
+ WriteBlock;
+end;
+
+procedure TLHTTPSocket.RelocateVariable(var AVar: pchar);
+begin
+ if AVar = nil then exit;
+ AVar := FBuffer + (AVar - FRequestPos);
+end;
+
+procedure TLHTTPSocket.RelocateVariables;
+var
+ I: TLHTTPParameter;
+begin
+ for I := Low(TLHTTPParameter) to High(TLHTTPParameter) do
+ RelocateVariable(FParameters[I]);
+end;
+
+procedure TLHTTPSocket.PackRequestBuffer;
+var
+ lBytesLeft: integer;
+ lFreeBuffer: pchar;
+begin
+ if (FRequestBuffer <> nil) and (FBufferEnd-FBufferPos <= RequestBufferSize) then
+ begin
+ { switch back to normal size buffer }
+ lFreeBuffer := FBuffer;
+ FBuffer := FRequestBuffer;
+ FBufferSize := RequestBufferSize;
+ FRequestBuffer := nil;
+ end else
+ lFreeBuffer := nil;
+ if FRequestPos <> nil then
+ begin
+ lBytesLeft := FBufferEnd-FRequestPos;
+ FBufferEnd := FBuffer+lBytesLeft;
+ RelocateVariable(FBufferPos);
+ RelocateVariables;
+ { include null-terminator, where FBufferEnd is pointing at }
+ Move(FRequestPos^, FBuffer^, lBytesLeft+1);
+ FRequestPos := nil;
+ end;
+ if lFreeBuffer <> nil then
+ FreeMem(lFreeBuffer);
+end;
+
+procedure TLHTTPSocket.PackInputBuffer;
+var
+ lBytesLeft: integer;
+begin
+ { use bigger buffer for more speed }
+ if FRequestBuffer = nil then
+ begin
+ FRequestBuffer := FBuffer;
+ FBuffer := GetMem(DataBufferSize);
+ FBufferSize := DataBufferSize;
+ FRequestPos := nil;
+ end;
+ lBytesLeft := FBufferEnd-FBufferPos;
+ Move(FBufferPos^, FBuffer^, lBytesLeft);
+ FBufferEnd := FBuffer+lBytesLeft;
+ FBufferPos := FBuffer;
+end;
+
+function TLHTTPSocket.ParseEntityPlain: boolean;
+var
+ lNumBytes: integer;
+begin
+ lNumBytes := FBufferEnd - FBufferPos;
+ if lNumBytes > FInputRemaining then
+ lNumBytes := FInputRemaining;
+ { if no output item to feed into, discard }
+ if FCurrentInput <> nil then
+ lNumBytes := FCurrentInput.HandleInput(FBufferPos, lNumBytes);
+ inc(FBufferPos, lNumBytes);
+ dec(FInputRemaining, lNumBytes);
+ Result := FInputRemaining > 0;
+ { prepare for more data, if more data coming }
+ if Result and (FBufferPos+FInputRemaining > FBuffer+FBufferSize) then
+ PackInputBuffer;
+end;
+
+function TLHTTPSocket.ParseEntityChunked: boolean;
+var
+ lLineEnd, lNextLine: pchar;
+ lCode: integer;
+begin
+ repeat
+ if FChunkState = csFinished then
+ exit(false);
+ if FChunkState = csData then
+ if ParseEntityPlain then
+ exit(true)
+ else
+ FChunkState := csDataEnd;
+
+ lLineEnd := StrScan(FBufferPos, #10);
+ if lLineEnd = nil then
+ exit(true);
+
+ lNextLine := lLineEnd+1;
+ if (lLineEnd > FBufferPos) and ((lLineEnd-1)^ = #13) then
+ dec(lLineEnd);
+ case FChunkState of
+ csInitial:
+ begin
+ lLineEnd^ := #0;
+ HexToInt(FBufferPos, dword(FInputRemaining), lCode);
+ if lCode = 1 then
+ begin
+ FChunkState := csFinished;
+ Disconnect;
+ exit(false);
+ end;
+ if FInputRemaining = 0 then
+ FChunkState := csTrailer
+ else
+ FChunkState := csData;
+ end;
+ csDataEnd:
+ begin
+ { skip empty line }
+ FChunkState := csInitial;
+ end;
+ csTrailer:
+ begin
+ { trailer is optional, empty line indicates end }
+ if lLineEnd = FBufferPos then
+ FChunkState := csFinished
+ else
+ ParseParameterLine(lLineEnd);
+ end;
+ end;
+ FBufferPos := lNextLine;
+ until false;
+end;
+
+function TLHTTPSocket.ParseRequest: boolean;
+var
+ pNextLine, pLineEnd: pchar;
+begin
+ if FRequestHeaderDone then exit(not FRequestInputDone);
+ repeat
+ pLineEnd := StrScan(FBufferPos, #10);
+ if pLineEnd = nil then
+ begin
+ if (FRequestBuffer <> nil) or (FRequestPos <> nil) then
+ PackRequestBuffer
+ else if CalcAvailableBufferSpace = 0 then
+ WriteError(hsRequestTooLong);
+ exit(true);
+ end;
+
+ pNextLine := pLineEnd+1;
+ if (pLineEnd > FBufferPos) and ((pLineEnd-1)^ = #13) then
+ dec(pLineEnd);
+ pLineEnd^ := #0;
+ ParseLine(pLineEnd);
+ FBufferPos := pNextLine;
+ if FRequestHeaderDone then
+ exit(not FRequestInputDone);
+ until false;
+end;
+
+procedure TLHTTPSocket.ParseParameterLine(pLineEnd: pchar);
+var
+ lPos: pchar;
+ I: TLHTTPParameter;
+ lLen: integer;
+begin
+ lPos := StrScan(FBufferPos, ' ');
+ if (lPos = nil) or (lPos = FBufferPos) or ((lPos-1)^ <> ':') then
+ begin
+ WriteError(hsBadRequest);
+ exit;
+ end;
+
+ { null-terminate at colon }
+ (lPos-1)^ := #0;
+ StrUpper(FBufferPos);
+ lLen := lPos-FBufferPos-1;
+ for I := Low(TLHTTPParameter) to High(TLHTTPParameter) do
+ if (Length(HTTPParameterStrings[I]) = lLen)
+ and CompareMem(FBufferPos, PChar(HTTPParameterStrings[I]), lLen) then
+ begin
+ repeat
+ inc(lPos);
+ until lPos^ <> ' ';
+ FParameters[I] := lPos;
+ break;
+ end;
+end;
+
+procedure TLHTTPSocket.ParseLine(pLineEnd: pchar);
+begin
+ if FBufferPos[0] = #0 then
+ begin
+ FRequestHeaderDone := true;
+ ProcessHeaders;
+ end else
+ ParseParameterLine(pLineEnd);
+end;
+
+function TLHTTPSocket.ParseBuffer: boolean;
+var
+ lParseFunc: TParseBufferMethod;
+begin
+ repeat
+ lParseFunc := FParseBuffer;
+ Result := FParseBuffer();
+ if not Result and not FRequestInputDone then
+ begin
+ FRequestInputDone := true;
+ if FCurrentInput <> nil then
+ FCurrentInput.DoneInput;
+ end;
+ { if parse func changed mid-run, then we should continue calling the new
+ one: header + data }
+ until (lParseFunc = FParseBuffer) or not Result;
+end;
+
+function TLHTTPSocket.ProcessEncoding: boolean;
+var
+ lCode: integer;
+begin
+ Result := true;
+ if FParameters[hpContentLength] <> nil then
+ begin
+ FParseBuffer := @ParseEntityPlain;
+ Val(FParameters[hpContentLength], FInputRemaining, lCode);
+ if lCode <> 0 then
+ begin
+ WriteError(hsBadRequest);
+ exit;
+ end;
+ end else
+ if FParameters[hpTransferEncoding] <> nil then
+ begin
+ if (StrIComp(FParameters[hpTransferEncoding], 'chunked') = 0) then
+ begin
+ FParseBuffer := @ParseEntityChunked;
+ FChunkState := csInitial;
+ end else begin
+ Result := false;
+ end;
+ end else begin
+ FRequestInputDone := true;
+ end;
+end;
+
+function TLHTTPSocket.SetupEncoding(AOutputItem: TBufferOutput; AHeaderOut: PHeaderOutInfo): boolean;
+begin
+ if AHeaderOut^.ContentLength = 0 then
+ begin
+ if AHeaderOut^.Version >= 11 then
+ begin
+ { we can use chunked encoding }
+ AHeaderOut^.TransferEncoding := teChunked;
+ AOutputItem.SelectChunked;
+ end else begin
+ { we need to buffer the response to find its length }
+ AHeaderOut^.TransferEncoding := teIdentity;
+ AOutputItem.SelectBuffered;
+ { need to accumulate data before starting header output }
+ AddToOutput(AOutputItem);
+ exit(false);
+ end;
+ end else begin
+ AHeaderOut^.TransferEncoding := teIdentity;
+ AOutputItem.SelectPlain;
+ end;
+ Result := true;
+end;
+
+procedure TLHTTPSocket.WriteBlock;
+begin
+ while true do
+ begin
+ if FCurrentOutput = nil then
+ begin
+ if not FOutputDone or (not FRequestInputDone and FKeepAlive) then
+ break;
+
+ if not FKeepAlive then
+ begin
+ Disconnect;
+ exit;
+ end;
+
+ { next request }
+ FRequestInputDone := false;
+ FRequestHeaderDone := false;
+ FOutputDone := false;
+ FRequestPos := FBufferPos;
+ FlushRequest;
+ { rewind buffer pointers if at end of buffer anyway }
+ if FBufferPos = FBufferEnd then
+ PackRequestBuffer;
+
+ if ParseBuffer and IgnoreRead then
+ begin
+ { end of input buffer reached, try reading more }
+ HandleReceive;
+ end;
+
+ if FCurrentOutput = nil then
+ break;
+ end;
+
+ { if we cannot send, then the send buffer is full }
+ if not FCanSend or not FConnected then
+ break;
+
+ case FCurrentOutput.WriteBlock of
+ wsDone:
+ begin
+ if FCurrentOutput = FLastOutput then
+ FLastOutput := nil;
+ { some output items may trigger this parse/write loop }
+ DelayFree(FCurrentOutput);
+ FCurrentOutput := FCurrentOutput.FNext;
+ end;
+ wsWaitingData:
+ begin
+ { wait for more data from external source }
+ break;
+ end;
+ end;
+ { nothing left to write, request was busy and now completed }
+ if FCurrentOutput = nil then
+ begin
+ LogMessage;
+ FOutputDone := true;
+ end;
+ end;
+end;
+
+{ TLHTTPServerSocket }
+
+constructor TLHTTPServerSocket.Create;
+begin
+ inherited;
+
+ FLogMessage := InitStringBuffer(256);
+ FHeaderOut.ExtraHeaders := InitStringBuffer(256);
+ ResetDefaults;
+end;
+
+destructor TLHTTPServerSocket.Destroy;
+begin
+ FreeMem(FLogMessage.Memory);
+ FreeMem(FHeaderOut.ExtraHeaders.Memory);
+ inherited;
+end;
+
+procedure TLHTTPServerSocket.AddContentLength(ALength: integer);
+begin
+ Inc(FHeaderOut.ContentLength, ALength);
+end;
+
+procedure TLHTTPServerSocket.DoneBuffer(AOutput: TBufferOutput);
+begin
+ if FCurrentOutput <> AOutput then
+ begin
+ RemoveOutput(AOutput);
+ AOutput.FNext := FCurrentOutput;
+ FCurrentOutput := AOutput;
+ end;
+ WriteHeaders(AOutput, nil);
+end;
+
+procedure TLHTTPServerSocket.LogAccess(const AMessage: string);
+begin
+ TLHTTPConnection(FCreator).LogAccess(AMessage);
+end;
+
+procedure TLHTTPServerSocket.LogMessage;
+begin
+ { log a message about this request,
+ ' "" ""' }
+ AppendString(FLogMessage, IntToStr(HTTPStatusCodes[FResponseInfo.Status]));
+ AppendChar(FLogMessage, ' ');
+ AppendString(FLogMessage, IntToStr(FHeaderOut.ContentLength));
+ AppendString(FLogMessage, ' "');
+ AppendString(FLogMessage, FParameters[hpReferer]);
+ AppendString(FLogMessage, '" "');
+ AppendString(FLogMessage, FParameters[hpUserAgent]);
+ AppendChar(FLogMessage, '"');
+ AppendChar(FLogMessage, #0);
+ LogAccess(FLogMessage.Memory);
+end;
+
+procedure TLHTTPServerSocket.ResetDefaults;
+begin
+ inherited;
+ FRequestInfo.RequestType := hmUnknown;
+ FSetupEncodingState := seNone;
+ with FResponseInfo do
+ begin
+ Status := hsOK;
+ ContentType := 'application/octet-stream';
+ ContentCharset := '';
+ LastModified := 0.0;
+ end;
+end;
+
+procedure TLHTTPServerSocket.FlushRequest;
+ { reset structure to zero, not called from constructor }
+begin
+ with FRequestInfo do
+ begin
+ { request }
+ Argument := nil;
+ QueryParams := nil;
+ Version := 0;
+ end;
+ with FHeaderOut do
+ begin
+ ContentLength := 0;
+ TransferEncoding := teIdentity;
+ ExtraHeaders.Pos := ExtraHeaders.Memory;
+ Version := 0;
+ end;
+ inherited;
+end;
+
+procedure TLHTTPServerSocket.RelocateVariables;
+begin
+ RelocateVariable(FRequestInfo.Method);
+ RelocateVariable(FRequestInfo.Argument);
+ RelocateVariable(FRequestInfo.QueryParams);
+ RelocateVariable(FRequestInfo.VersionStr);
+ inherited;
+end;
+
+procedure TLHTTPServerSocket.ParseLine(pLineEnd: pchar);
+begin
+ if FRequestInfo.RequestType = hmUnknown then
+ begin
+ ParseRequestLine(pLineEnd);
+ exit;
+ end;
+
+ inherited;
+end;
+
+procedure TLHTTPServerSocket.ParseRequestLine(pLineEnd: pchar);
+var
+ lPos: pchar;
+ I: TLHTTPMethod;
+ NowLocal: TDateTime;
+begin
+ { make a timestamp for this request }
+ NowLocal := Now;
+ FRequestInfo.DateTime := LocalTimeToGMT(NowLocal);
+ { begin log message }
+ FLogMessage.Pos := FLogMessage.Memory;
+ AppendString(FLogMessage, PeerAddress);
+ AppendString(FLogMessage, ' - [');
+ AppendString(FLogMessage, FormatDateTime('dd/mmm/yyyy:hh:nn:ss', NowLocal));
+ AppendString(FLogMessage, TLHTTPServer(FCreator).FLogMessageTZString);
+ AppendString(FLogMessage, FBufferPos, pLineEnd-FBufferPos);
+ AppendString(FLogMessage, '" ');
+
+ { decode version }
+ lPos := pLineEnd;
+ repeat
+ if lPos^ = ' ' then break;
+ dec(lPos);
+ if lPos < FBufferPos then
+ begin
+ WriteError(hsBadRequest);
+ exit;
+ end;
+ until false;
+
+ lPos^ := #0;
+ inc(lPos);
+ { lPos = version string }
+ if not HTTPVersionCheck(lPos, pLineEnd, FRequestInfo.Version) then
+ begin
+ WriteError(hsBadRequest);
+ exit;
+ end;
+ FRequestInfo.VersionStr := lPos;
+ FHeaderOut.Version := FRequestInfo.Version;
+
+ { trim spaces at end of URI }
+ dec(lPos);
+ repeat
+ if lPos = FBufferPos then break;
+ dec(lPos);
+ if lPos^ <> ' ' then break;
+ lPos^ := #0;
+ until false;
+
+ { decode method }
+ FRequestInfo.Method := FBufferPos;
+ lPos := StrScan(FBufferPos, ' ');
+ if lPos = nil then
+ begin
+ WriteError(hsBadRequest);
+ exit;
+ end;
+
+ lPos^ := #0;
+ for I := Low(TLHTTPMethod) to High(TLHTTPMethod) do
+ begin
+ if I = hmUnknown then
+ begin
+ WriteError(hsNotImplemented);
+ exit;
+ end;
+
+ if ((lPos-FBufferPos) = Length(HTTPMethodStrings[I]))
+ and CompareMem(FBufferPos, PChar(HTTPMethodStrings[I]), lPos-FBufferPos) then
+ begin
+ repeat
+ inc(lPos);
+ until lPos^ <> ' ';
+ FRequestInfo.Argument := lPos;
+ FRequestInfo.RequestType := I;
+ break;
+ end;
+ end;
+
+ if ((pLineEnd-FRequestInfo.Argument) > 7) and (StrIComp(FRequestInfo.Argument, 'http://') = 0) then
+ begin
+ { absolute URI }
+ lPos := FRequestInfo.Argument+7;
+ while (lPos^ = '/') do
+ Inc(lPos);
+ FParameters[hpHost] := lPos;
+ lPos := StrScan(lPos, '/');
+ FRequestInfo.Argument := lPos;
+ end;
+ { FRequestInfo.Argument now points to an "abs_path" }
+ if FRequestInfo.Argument[0] <> '/' then
+ begin
+ WriteError(hsBadRequest);
+ exit;
+ end;
+ repeat
+ Inc(FRequestInfo.Argument);
+ until FRequestInfo.Argument[0] <> '/';
+end;
+
+procedure TLHTTPServerSocket.ProcessHeaders;
+ { process request }
+var
+ lPos: pchar;
+begin
+ { do HTTP/1.1 Host-field present check }
+ if (FRequestInfo.Version > 10) and (FParameters[hpHost] = nil) then
+ begin
+ WriteError(hsBadRequest);
+ exit;
+ end;
+
+ lPos := StrScan(FRequestInfo.Argument, '?');
+ if lPos <> nil then
+ begin
+ lPos^ := #0;
+ FRequestInfo.QueryParams := lPos+1;
+ end;
+
+ FKeepAlive := FRequestInfo.Version > 10;
+ if FParameters[hpConnection] <> nil then
+ begin
+ if StrIComp(FParameters[hpConnection], 'keep-alive') = 0 then
+ FKeepAlive := true
+ else
+ if StrIComp(FParameters[hpConnection], 'close') = 0 then
+ FKeepAlive := false;
+ end;
+
+ HTTPDecode(FRequestInfo.Argument);
+ if not CheckPermission(FRequestInfo.Argument) then
+ begin
+ WriteError(hsForbidden);
+ end else begin
+ if not ProcessEncoding then
+ begin
+ WriteError(hsNotImplemented);
+ exit;
+ end;
+
+ FCurrentInput := HandleURI;
+ { if we have a valid outputitem, wait until it is ready
+ to produce its response }
+ if FCurrentInput = nil then
+ begin
+ if FResponseInfo.Status = hsOK then
+ WriteError(hsNotFound)
+ else
+ WriteError(FResponseInfo.Status);
+ end else if FRequestInputDone then
+ FCurrentInput.DoneInput;
+ end;
+end;
+
+function TLHTTPServerSocket.PrepareResponse(AOutputItem: TOutputItem; ACustomErrorMessage: boolean): boolean;
+var
+ lDateTime: TDateTime;
+begin
+ { check modification date }
+ if FResponseInfo.Status < hsBadRequest then
+ begin
+ if (FParameters[hpIfModifiedSince] <> nil)
+ and (FResponseInfo.LastModified <> 0.0) then
+ begin
+ if TryHTTPDateStrToDateTime(FParameters[hpIfModifiedSince], lDateTime) then
+ begin
+ if lDateTime > FRequestInfo.DateTime then
+ FResponseInfo.Status := hsBadRequest
+ else
+ if FResponseInfo.LastModified <= lDateTime then
+ FResponseInfo.Status := hsNotModified;
+ end;
+ end else
+ if (FParameters[hpIfUnmodifiedSince] <> nil) then
+ begin
+ if TryHTTPDateStrToDateTime(FParameters[hpIfUnmodifiedSince], lDateTime) then
+ begin
+ if (FResponseInfo.LastModified = 0.0)
+ or (lDateTime < FResponseInfo.LastModified) then
+ FResponseInfo.Status := hsPreconditionFailed;
+ end;
+ end;
+ end;
+
+ if (FResponseInfo.Status < hsOK) or (FResponseInfo.Status in [hsNoContent, hsNotModified]) then
+ begin
+ { RFC says we MUST not include a response for these statuses }
+ ACustomErrorMessage := false;
+ FHeaderOut.ContentLength := 0;
+ end;
+
+ Result := (FResponseInfo.Status = hsOK) or ACustomErrorMessage;
+ if not Result then
+ begin
+ WriteError(FResponseInfo.Status);
+ DelayFree(AOutputItem);
+ end;
+end;
+
+procedure TLHTTPServerSocket.StartMemoryResponse(AOutputItem: TMemoryOutput; ACustomErrorMessage: boolean = false);
+begin
+ if PrepareResponse(AOutputItem, ACustomErrorMessage) then
+ begin
+ if FRequestInfo.RequestType <> hmHead then
+ FHeaderOut.ContentLength := AOutputItem.FBufferSize
+ else
+ FHeaderOut.ContentLength := 0;
+ WriteHeaders(nil, AOutputItem);
+ end;
+end;
+
+function TLHTTPServerSocket.SetupEncoding(AOutputItem: TBufferOutput): boolean;
+const
+ SetupEncodingToState: array[boolean] of TSetupEncodingState = (seWaitHeaders, seStartHeaders);
+begin
+ if FSetupEncodingState > seNone then
+ exit(FSetupEncodingState = seStartHeaders);
+ Result := inherited SetupEncoding(AOutputItem, @FHeaderOut);
+ FSetupEncodingState := SetupEncodingToState[Result];
+end;
+
+procedure TLHTTPServerSocket.StartResponse(AOutputItem: TBufferOutput; ACustomErrorMessage: boolean = false);
+begin
+ if PrepareResponse(AOutputItem, ACustomErrorMessage) then
+ if (FRequestInfo.RequestType = hmHead) or SetupEncoding(AOutputItem) then
+ WriteHeaders(nil, AOutputItem);
+end;
+
+function TLHTTPServerSocket.HandleURI: TOutputItem; {inline;} {<--- triggers IE}
+begin
+ Result := TLHTTPServer(FCreator).HandleURI(Self);
+end;
+
+procedure TLHTTPServerSocket.WriteError(AStatus: TLHTTPStatus);
+var
+ lMessage: string;
+ lMsgOutput: TMemoryOutput;
+begin
+ if AStatus in HTTPDisconnectStatuses then
+ FKeepAlive := false;
+ lMessage := HTTPDescriptions[AStatus];
+ FRequestHeaderDone := true;
+ FResponseInfo.Status := AStatus;
+ FHeaderOut.ContentLength := Length(lMessage);
+ FHeaderOut.TransferEncoding := teIdentity;
+ if Length(lMessage) > 0 then
+ begin
+ FResponseInfo.ContentType := 'text/html';
+ lMsgOutput := TMemoryOutput.Create(Self, PChar(lMessage), 0, Length(lMessage), false)
+ end else begin
+ FResponseInfo.ContentType := '';
+ lMsgOutput := nil;
+ end;
+ WriteHeaders(nil, lMsgOutput);
+end;
+
+procedure TLHTTPServerSocket.WriteHeaders(AHeaderResponse, ADataResponse: TOutputItem);
+var
+ lTemp: string[23];
+ lMessage: TStringBuffer;
+ tempStr: string;
+begin
+ lMessage := InitStringBuffer(504);
+
+ AppendString(lMessage, 'HTTP/1.1 ');
+ Str(HTTPStatusCodes[FResponseInfo.Status], lTemp);
+ AppendString(lMessage, lTemp);
+ AppendChar(lMessage, ' ');
+ AppendString(lMessage, HTTPTexts[FResponseInfo.Status]);
+ AppendString(lMessage, #13#10+'Date: ');
+ AppendString(lMessage, FormatDateTime(HTTPDateFormat, FRequestInfo.DateTime));
+ AppendString(lMessage, ' GMT');
+ tempStr := TLHTTPServer(FCreator).ServerSoftware;
+ if Length(tempStr) > 0 then
+ begin
+ AppendString(lMessage, #13#10+'Server: ');
+ AppendString(lMessage, tempStr);
+ end;
+ if Length(FResponseInfo.ContentType) > 0 then
+ begin
+ AppendString(lMessage, #13#10+'Content-Type: ');
+ AppendString(lMessage, FResponseInfo.ContentType);
+ if Length(FResponseInfo.ContentCharset) > 0 then
+ begin
+ AppendString(lMessage, '; charset=');
+ AppendString(lMessage, FResponseInfo.ContentCharset);
+ end;
+ end;
+ if FHeaderOut.TransferEncoding = teIdentity then
+ begin
+ AppendString(lMessage, #13#10+'Content-Length: ');
+ Str(FHeaderOut.ContentLength, lTemp);
+ AppendString(lMessage, lTemp);
+ end else begin
+ { only other possibility: teChunked }
+ AppendString(lMessage, #13#10+'Transfer-Encoding: chunked');
+ end;
+ if FResponseInfo.LastModified <> 0.0 then
+ begin
+ AppendString(lMessage, #13#10+'Last-Modified: ');
+ AppendString(lMessage, FormatDateTime(HTTPDateFormat, FResponseInfo.LastModified));
+ AppendString(lMessage, ' GMT');
+ end;
+ AppendString(lMessage, #13#10+'Connection: ');
+ if FKeepAlive then
+ AppendString(lMessage, 'keep-alive')
+ else
+ AppendString(lMessage, 'close');
+ AppendString(lMessage, #13#10);
+ with FHeaderOut.ExtraHeaders do
+ AppendString(lMessage, Memory, Pos-Memory);
+ AppendString(lMessage, #13#10);
+ if AHeaderResponse <> nil then
+ begin
+ AHeaderResponse.FBuffer := lMessage.Memory;
+ AHeaderResponse.FBufferSize := lMessage.Pos-lMessage.Memory;
+ end else
+ AddToOutput(TMemoryOutput.Create(Self, lMessage.Memory, 0,
+ lMessage.Pos-lMessage.Memory, true));
+
+ if ADataResponse <> nil then
+ begin
+ if FRequestInfo.RequestType = hmHead then
+ DelayFree(ADataResponse)
+ else
+ AddToOutput(ADataResponse);
+ end;
+end;
+
+{ TLHTTPConnection }
+
+destructor TLHTTPConnection.Destroy;
+begin
+ inherited;
+end;
+
+procedure TLHTTPConnection.LogAccess(const AMessage: string);
+begin
+end;
+
+procedure TLHTTPConnection.ReceiveEvent(aSocket: TLHandle);
+begin
+ TLHTTPSocket(aSocket).HandleReceive;
+ TLHTTPSocket(aSocket).FreeDelayFreeItems;
+end;
+
+procedure TLHTTPConnection.CanSendEvent(aSocket: TLHandle);
+begin
+ TLHTTPSocket(aSocket).WriteBlock;
+ TLHTTPSocket(aSocket).FreeDelayFreeItems;
+end;
+
+{ TLHTTPServer }
+
+constructor TLHTTPServer.Create(AOwner: TComponent);
+var
+ TZSign: char;
+ TZSecsAbs: integer;
+begin
+ inherited Create(AOwner);
+
+ SocketClass := TLHTTPServerSocket;
+ if TZSeconds >= 0 then
+ TZSign := '+'
+ else
+ TZSign := '-';
+ TZSecsAbs := Abs(TZSeconds);
+ FLogMessageTZString := Format(' %s%.2d%.2d] "',
+ [TZSign, TZSecsAbs div 3600, (TZSecsAbs div 60) mod 60]);
+end;
+
+function TLHTTPServer.HandleURI(ASocket: TLHTTPServerSocket): TOutputItem;
+var
+ lHandler: TURIHandler;
+begin
+ Result := nil;
+ lHandler := FHandlerList;
+ while lHandler <> nil do
+ begin
+ Result := lHandler.HandleURI(ASocket);
+ if ASocket.ResponseInfo.Status <> hsOK then break;
+ if Result <> nil then break;
+ lHandler := lHandler.FNext;
+ end;
+end;
+
+procedure TLHTTPServer.LogAccess(const AMessage: string);
+begin
+ if Assigned(FOnAccess) then
+ FOnAccess(AMessage);
+end;
+
+procedure TLHTTPServer.RegisterHandler(AHandler: TURIHandler);
+begin
+ if AHandler = nil then exit;
+ AHandler.FNext := FHandlerList;
+ FHandlerList := AHandler;
+ if Eventer <> nil then
+ AHandler.RegisterWithEventer(Eventer);
+end;
+
+procedure TLHTTPServer.RegisterWithEventer;
+var
+ lHandler: TURIHandler;
+begin
+ inherited;
+ lHandler := FHandlerList;
+ while lHandler <> nil do
+ begin
+ lHandler.RegisterWithEventer(Eventer);
+ lHandler := lHandler.FNext;
+ end;
+end;
+
+{ TClientInput }
+
+type
+ TClientOutput = class(TOutputItem)
+ protected
+ FPersistent: boolean;
+
+ procedure DoneInput; override;
+ public
+ constructor Create(ASocket: TLHTTPClientSocket);
+ destructor Destroy; override;
+ procedure FreeInstance; override;
+
+ function HandleInput(ABuffer: pchar; ASize: integer): integer; override;
+ function WriteBlock: TWriteBlockStatus; override;
+ end;
+
+constructor TClientOutput.Create(ASocket: TLHTTPClientSocket);
+begin
+ inherited Create(ASocket);
+ FPersistent := true;
+end;
+
+destructor TClientOutput.Destroy;
+begin
+ if FPersistent then exit;
+ inherited;
+end;
+
+procedure TClientOutput.FreeInstance;
+begin
+ if FPersistent then exit;
+ inherited;
+end;
+
+procedure TClientOutput.DoneInput;
+begin
+ TLHTTPClient(TLHTTPClientSocket(FSocket).FCreator).
+ DoDoneInput(TLHTTPClientSocket(FSocket));
+end;
+
+function TClientOutput.HandleInput(ABuffer: pchar; ASize: integer): integer;
+begin
+ Result := TLHTTPClient(TLHTTPClientSocket(FSocket).FCreator).
+ DoHandleInput(TLHTTPClientSocket(FSocket), ABuffer, ASize);
+end;
+
+function TClientOutput.WriteBlock: TWriteBlockStatus;
+begin
+ Result := TLHTTPClient(TLHTTPClientSocket(FSocket).FCreator).
+ DoWriteBlock(TLHTTPClientSocket(FSocket));
+end;
+
+{ TLHTTPClientSocket }
+
+constructor TLHTTPClientSocket.Create;
+begin
+ inherited Create;
+
+ FCurrentInput := TClientOutput.Create(Self);
+ ResetDefaults;
+end;
+
+destructor TLHTTPClientSocket.Destroy;
+begin
+ if Assigned(FCurrentInput) then begin
+ TClientOutput(FCurrentInput).FPersistent := false;
+ FreeAndNil(FCurrentInput);
+ end;
+ inherited;
+end;
+
+procedure TLHTTPClientSocket.AddContentLength(ALength: integer);
+begin
+ Inc(TLHTTPClient(FCreator).FHeaderOut.ContentLength, ALength);
+end;
+
+procedure TLHTTPClientSocket.Cancel(AError: TLHTTPClientError);
+begin
+ FError := AError;
+ Disconnect;
+end;
+
+function TLHTTPClientSocket.GetResponseReason: string;
+begin
+ Result := FResponse^.Reason;
+end;
+
+function TLHTTPClientSocket.GetResponseStatus: TLHTTPStatus;
+begin
+ Result := FResponse^.Status;
+end;
+
+procedure TLHTTPClientSocket.SendRequest;
+var
+ lMessage: TStringBuffer;
+ lTemp: string[23];
+ hasRangeStart, hasRangeEnd: boolean;
+begin
+ lMessage := InitStringBuffer(504);
+
+ AppendString(lMessage, HTTPMethodStrings[FRequest^.Method]);
+ AppendChar(lMessage, ' ');
+ AppendString(lMessage, FRequest^.URI);
+ AppendChar(lMessage, ' ');
+ AppendString(lMessage, 'HTTP/1.1'+#13#10+'Host: ');
+ AppendString(lMessage, TLHTTPClient(FCreator).Host);
+ if TLHTTPClient(FCreator).Port <> 80 then
+ begin
+ AppendChar(lMessage, ':');
+ Str(TLHTTPClient(FCreator).Port, lTemp);
+ AppendString(lMessage, lTemp);
+ end;
+ AppendString(lMessage, #13#10);
+ hasRangeStart := TLHTTPClient(FCreator).RangeStart <> high(qword);
+ hasRangeEnd := TLHTTPClient(FCreator).RangeEnd <> high(qword);
+ if hasRangeStart or hasRangeEnd then
+ begin
+ AppendString(lMessage, 'Range: bytes=');
+ if hasRangeStart then
+ begin
+ Str(TLHTTPClient(FCreator).RangeStart, lTemp);
+ AppendString(lMessage, lTemp);
+ end;
+ AppendChar(lMessage, '-');
+ if hasRangeEnd then
+ begin
+ Str(TLHTTPClient(FCreator).RangeEnd, lTemp);
+ AppendString(lMessage, lTemp);
+ end;
+ end;
+ with FHeaderOut^.ExtraHeaders do
+ AppendString(lMessage, Memory, Pos-Memory);
+ AppendString(lMessage, #13#10);
+ AddToOutput(TMemoryOutput.Create(Self, lMessage.Memory, 0,
+ lMessage.Pos-lMessage.Memory, true));
+ AddToOutput(FCurrentInput);
+
+ WriteBlock;
+end;
+
+procedure TLHTTPClientSocket.ParseLine(pLineEnd: pchar);
+begin
+ if FError <> ceNone then
+ exit;
+
+ if FResponse^.Status = hsUnknown then
+ begin
+ ParseStatusLine(pLineEnd);
+ exit;
+ end;
+
+ inherited;
+end;
+
+procedure TLHTTPClientSocket.ParseStatusLine(pLineEnd: pchar);
+var
+ lPos: pchar;
+begin
+ lPos := FBufferPos;
+ repeat
+ if lPos >= pLineEnd then
+ begin
+ Cancel(ceMalformedStatusLine);
+ exit;
+ end;
+ if lPos^ = ' ' then
+ break;
+ Inc(lPos);
+ until false;
+ if not HTTPVersionCheck(FBufferPos, lPos, FResponse^.Version) then
+ begin
+ Cancel(ceMalformedStatusLine);
+ exit;
+ end;
+
+ if (FResponse^.Version > 11) then
+ begin
+ Cancel(ceVersionNotSupported);
+ exit;
+ end;
+
+ { status code }
+ Inc(lPos);
+ if (lPos+3 >= pLineEnd) or (lPos[3] <> ' ') then
+ begin
+ Cancel(ceMalformedStatusLine);
+ exit;
+ end;
+ FResponse^.Status := CodeToHTTPStatus((ord(lPos[0])-ord('0'))*100
+ + (ord(lPos[1])-ord('0'))*10 + (ord(lPos[2])-ord('0')));
+ if FResponse^.Status = hsUnknown then
+ begin
+ Cancel(ceMalformedStatusLine);
+ exit;
+ end;
+
+ Inc(lPos, 4);
+ if lPos < pLineEnd then
+ FResponse^.Reason := lPos;
+end;
+
+procedure TLHTTPClientSocket.ProcessHeaders;
+begin
+ if not ProcessEncoding then
+ Cancel(ceUnsupportedEncoding);
+
+ TLHTTPClient(FCreator).DoProcessHeaders(Self);
+end;
+
+procedure TLHTTPClientSocket.ResetDefaults;
+begin
+ inherited;
+
+ FError := ceNone;
+end;
+
+{ TLHTTPClient }
+
+constructor TLHTTPClient.Create(AOwner: TComponent);
+begin
+ FPort:=80;
+ inherited;
+
+ SocketClass := TLHTTPClientSocket;
+ FRequest.Method := hmGet;
+ FHeaderOut.ExtraHeaders := InitStringBuffer(256);
+ ResetRange;
+end;
+
+destructor TLHTTPClient.Destroy;
+begin
+ FreeMem(FHeaderOut.ExtraHeaders.Memory);
+ inherited;
+end;
+
+procedure TLHTTPClient.AddExtraHeader(const AHeader: string);
+begin
+ AppendString(FHeaderOut.ExtraHeaders, AHeader);
+ AppendString(FHeaderOut.ExtraHeaders, #13#10);
+end;
+
+procedure TLHTTPClient.ConnectEvent(aSocket: TLHandle);
+begin
+ inherited;
+ InternalSendRequest;
+end;
+
+procedure TLHTTPClient.DoDoneInput(ASocket: TLHTTPClientSocket);
+begin
+ Dec(FPendingResponses);
+ if FPendingResponses = 0 then
+ FState := hcsIdle
+ else
+ FState := hcsWaiting;
+ if Assigned(FOnDoneInput) then
+ FOnDoneInput(ASocket);
+end;
+
+function TLHTTPClient.DoHandleInput(ASocket: TLHTTPClientSocket; ABuffer: pchar; ASize: integer): integer;
+begin
+ FState := hcsReceiving;
+ if Assigned(FOnInput) then
+ Result := FOnInput(ASocket, ABuffer, ASize)
+ else
+ Result := ASize;
+end;
+
+procedure TLHTTPClient.DoProcessHeaders(ASocket: TLHTTPClientSocket);
+begin
+ if Assigned(FOnProcessHeaders) then
+ FOnProcessHeaders(ASocket);
+end;
+
+function TLHTTPClient.DoWriteBlock(ASocket: TLHTTPClientSocket): TWriteBlockStatus;
+begin
+ Result := wsDone;
+ if not FOutputEof then
+ if Assigned(FOnCanWrite) then
+ FOnCanWrite(ASocket, Result)
+end;
+
+function TLHTTPClient.InitSocket(aSocket: TLSocket): TLSocket;
+begin
+ Result := inherited;
+ TLHTTPClientSocket(aSocket).FHeaderOut := @FHeaderOut;
+ TLHTTPClientSocket(aSocket).FRequest := @FRequest;
+ TLHTTPClientSocket(aSocket).FResponse := @FResponse;
+end;
+
+procedure TLHTTPClient.InternalSendRequest;
+begin
+ FOutputEof := false;
+ TLHTTPClientSocket(FIterator).SendRequest;
+ Inc(FPendingResponses);
+ if FState = hcsIdle then
+ FState := hcsWaiting;
+end;
+
+procedure TLHTTPClient.ResetRange;
+begin
+ FRequest.RangeStart := High(FRequest.RangeStart);
+ FRequest.RangeEnd := High(FRequest.RangeEnd);
+end;
+
+procedure TLHTTPClient.SendRequest;
+begin
+ if not Connected then
+ Connect(FHost, FPort)
+ else
+ InternalSendRequest;
+end;
+
+end.
+
diff --git a/utils/fppkg/lnet/lhttputil.pp b/utils/fppkg/lnet/lhttputil.pp
new file mode 100644
index 0000000000..1f7ba6f8c0
--- /dev/null
+++ b/utils/fppkg/lnet/lhttputil.pp
@@ -0,0 +1,232 @@
+{ Utility routines for HTTP server component
+
+ Copyright (C) 2006 Micha Nelissen
+
+ This library is Free software; you can redistribute it and/or modify it
+ under the terms of the GNU Library General Public License as published by
+ the Free Software Foundation; either version 2 of the License, or (at your
+ option) any later version.
+
+ This program is diStributed in the hope that it will be useful, but WITHOUT
+ ANY WARRANTY; withOut even the implied warranty of MERCHANTABILITY or
+ FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License
+ for more details.
+
+ You should have received a Copy of the GNU Library General Public License
+ along with This library; if not, Write to the Free Software Foundation,
+ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+ This license has been modified. See file LICENSE.ADDON for more information.
+ Should you find these sources without a LICENSE File, please contact
+ me at ales@chello.sk
+}
+
+unit lHTTPUtil;
+
+{$mode objfpc}{$h+}
+{$inline on}
+
+interface
+
+uses
+ sysutils,
+ strutils;
+
+const
+ HTTPDateFormat: string = 'ddd, dd mmm yyyy hh:nn:ss';
+ HTTPAllowedChars = ['A'..'Z','a'..'z', '*','@','.','_','-',
+ '0'..'9', '$','!','''','(',')'];
+
+type
+ PSearchRec = ^TSearchRec;
+
+ function GMTToLocalTime(ADateTime: TDateTime): TDateTime;
+ function LocalTimeToGMT(ADateTime: TDateTime): TDateTime;
+ function TryHTTPDateStrToDateTime(ADateStr: pchar; var ADest: TDateTime): boolean;
+
+ function SeparatePath(var InPath: string; out ExtraPath: string; const Mode:Longint;
+ ASearchRec: PSearchRec = nil): boolean;
+ function CheckPermission(const ADocument: pchar): boolean;
+ function HTTPDecode(AStr: pchar): pchar;
+ function HTTPEncode(const AStr: string): string;
+ function HexToNum(AChar: char): byte;
+
+implementation
+
+uses
+ lCommon;
+
+function GMTToLocalTime(ADateTime: TDateTime): TDateTime;
+begin
+ Result := ADateTime + (TZSeconds*1000/MSecsPerDay);
+end;
+
+function LocalTimeToGMT(ADateTime: TDateTime): TDateTime;
+begin
+ Result := ADateTime - (TZSeconds*1000/MSecsPerDay);
+end;
+
+function TryHTTPDateStrToDateTime(ADateStr: pchar; var ADest: TDateTime): boolean;
+var
+ lYear, lMonth, lDay: word;
+ lTime: array[0..2] of word;
+ I, lCode: integer;
+begin
+ if StrLen(ADateStr) < Length(HTTPDateFormat)+4 then exit(false);
+ { skip redundant short day string }
+ Inc(ADateStr, 5);
+ { day }
+ if ADateStr[2] = ' ' then
+ ADateStr[2] := #0
+ else
+ exit(false);
+ Val(ADateStr, lDay, lCode);
+ if lCode <> 0 then exit(false);
+ Inc(ADateStr, 3);
+ { month }
+ lMonth := 1;
+ repeat
+ if CompareMem(ADateStr, @ShortMonthNames[lMonth][1], 3) then break;
+ inc(lMonth);
+ if lMonth = 13 then exit(false);
+ until false;
+ Inc(ADateStr, 4);
+ { year }
+ if ADateStr[4] = ' ' then
+ ADateStr[4] := #0
+ else
+ exit(false);
+ Val(ADateStr, lYear, lCode);
+ if lCode <> 0 then exit(false);
+ Inc(ADateStr, 5);
+ { hour, minute, second }
+ for I := 0 to 2 do
+ begin
+ ADateStr[2] := #0;
+ Val(ADateStr, lTime[I], lCode);
+ Inc(ADateStr, 3);
+ if lCode <> 0 then exit(false);
+ end;
+ ADest := EncodeDate(lYear, lMonth, lDay) + EncodeTime(lTime[0], lTime[1], lTime[2], 0);
+ Result := true;
+end;
+
+function SeparatePath(var InPath: string; out ExtraPath: string; const Mode:Longint;
+ ASearchRec: PSearchRec = nil): boolean;
+var
+ lFullPath: string;
+ lPos: integer;
+ lSearchRec: TSearchRec;
+begin
+ if ASearchRec = nil then
+ ASearchRec := @lSearchRec;
+ ExtraPath := '';
+ if Length(InPath) <= 2 then exit(false);
+ lFullPath := InPath;
+ if InPath[Length(InPath)] = PathDelim then
+ SetLength(InPath, Length(InPath)-1);
+ repeat
+ Result := SysUtils.FindFirst(InPath, Mode, ASearchRec^) = 0;
+ SysUtils.FindClose(ASearchRec^);
+ if Result then
+ begin
+ ExtraPath := Copy(lFullPath, Length(InPath)+1, Length(lFullPath)-Length(InPath));
+ break;
+ end;
+ lPos := RPos(PathDelim, InPath);
+ if lPos > 0 then
+ SetLength(InPath, lPos-1)
+ else
+ break;
+ until false;
+end;
+
+function HexToNum(AChar: char): byte;
+begin
+ if ('0' <= AChar) and (AChar <= '9') then
+ Result := ord(AChar) - ord('0')
+ else if ('A' <= AChar) and (AChar <= 'F') then
+ Result := ord(AChar) - (ord('A') - 10)
+ else if ('a' <= AChar) and (AChar <= 'f') then
+ Result := ord(AChar) - (ord('a') - 10)
+ else
+ Result := 0;
+end;
+
+function HTTPDecode(AStr: pchar): pchar;
+var
+ lPos, lNext, lDest: pchar;
+begin
+ lDest := AStr;
+ repeat
+ lPos := AStr;
+ while not (lPos^ in ['%', '+', #0]) do
+ Inc(lPos);
+ if (lPos[0]='%') and (lPos[1] <> #0) and (lPos[2] <> #0) then
+ begin
+ lPos^ := char((HexToNum(lPos[1]) shl 4) + HexToNum(lPos[2]));
+ lNext := lPos+2;
+ end else if lPos[0] = '+' then
+ begin
+ lPos^ := ' ';
+ lNext := lPos+1;
+ end else
+ lNext := nil;
+ Inc(lPos);
+ if lDest <> AStr then
+ Move(AStr^, lDest^, lPos-AStr);
+ Inc(lDest, lPos-AStr);
+ AStr := lNext;
+ until lNext = nil;
+ Result := lDest;
+end;
+
+function HTTPEncode(const AStr: string): string;
+ { code from MvC's web }
+var
+ src, srcend, dest: pchar;
+ hex: string[2];
+ len: integer;
+begin
+ len := Length(AStr);
+ SetLength(Result, len*3); // Worst case scenario
+ if len = 0 then
+ exit;
+ dest := pchar(Result);
+ src := pchar(AStr);
+ srcend := src + len;
+ while src < srcend do
+ begin
+ if src^ in HTTPAllowedChars then
+ dest^ := src^
+ else if src^ = ' ' then
+ dest^ := '+'
+ else begin
+ dest^ := '%';
+ inc(dest);
+ hex := HexStr(Ord(src^),2);
+ dest^ := hex[1];
+ inc(dest);
+ dest^ := hex[2];
+ end;
+ inc(dest);
+ inc(src);
+ end;
+ SetLength(Result, dest - pchar(Result));
+end;
+
+function CheckPermission(const ADocument: pchar): boolean;
+var
+ lPos: pchar;
+begin
+ lPos := ADocument;
+ repeat
+ lPos := StrScan(lPos, '/');
+ if lPos = nil then exit(true);
+ if (lPos[1] = '.') and (lPos[2] = '.') and ((lPos[3] = '/') or (lPos[3] = #0)) then
+ exit(false);
+ inc(lPos);
+ until false;
+end;
+
+end.
diff --git a/utils/fppkg/lnet/lmimetypes.pp b/utils/fppkg/lnet/lmimetypes.pp
new file mode 100644
index 0000000000..191c967968
--- /dev/null
+++ b/utils/fppkg/lnet/lmimetypes.pp
@@ -0,0 +1,108 @@
+{ Mime types helper
+
+ Copyright (C) 2006 Micha Nelissen
+
+ This library is Free software; you can redistribute it and/or modify it
+ under the terms of the GNU Library General Public License as published by
+ the Free Software Foundation; either version 2 of the License, or (at your
+ option) any later version.
+
+ This program is diStributed in the hope that it will be useful, but WITHOUT
+ ANY WARRANTY; withOut even the implied warranty of MERCHANTABILITY or
+ FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License
+ for more details.
+
+ You should have received a Copy of the GNU Library General Public License
+ along with This library; if not, Write to the Free Software Foundation,
+ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+ This license has been modified. See file LICENSE.ADDON for more information.
+ Should you find these sources without a LICENSE File, please contact
+ me at ales@chello.sk
+}
+
+unit lMimeTypes;
+
+{$mode objfpc}{$h+}
+
+interface
+
+uses
+ classes, sysutils, strutils;
+
+type
+ TStringObject = class(TObject)
+ Str: string;
+ end;
+
+ procedure InitMimeList(const aFileName: string);
+
+var
+ MimeList: TStringList = nil;
+
+implementation
+
+var
+ MimeFileName: string;
+
+procedure InitMimeList(const aFileName: string);
+var
+ MimeFile: Text;
+ lPos, lNextPos: integer;
+ lLine, lName: string;
+ lStrObj: TStringObject;
+ lBuffer: array[1..32*1024] of byte;
+begin
+ if not Assigned(MimeList) then begin
+ MimeFileName := aFileName;
+ MimeList := TStringList.Create;
+ if FileExists(MimeFileName) then
+ begin
+ Assign(MimeFile, MimeFileName);
+ Reset(MimeFile);
+ SetTextBuf(MimeFile, lBuffer);
+ while not Eof(MimeFile) do
+ begin
+ ReadLn(MimeFile, lLine);
+ if (Length(lLine) = 0) or (lLine[1] = '#') then
+ continue;
+
+ lPos := Pos(#9, lLine);
+ if lPos = 0 then
+ continue;
+ lName := Copy(lLine, 1, lPos-1);
+
+ while (lPos <= Length(lLine)) and (lLine[lPos] in [#9,' ']) do
+ Inc(lPos);
+ if lPos > Length(lLine) then
+ continue;
+ repeat
+ lNextPos := PosEx(' ', lLine, lPos);
+ if lNextPos = 0 then
+ lNextPos := Length(lLine)+1;
+ lStrObj := TStringObject.Create;
+ lStrObj.Str := lName;
+ MimeList.AddObject('.'+Copy(lLine, lPos, lNextPos-lPos), lStrObj);
+ lPos := lNextPos+1;
+ until lPos > Length(lLine);
+ end;
+ close(MimeFile);
+ end;
+ MimeList.Sorted := true;
+ end;
+end;
+
+procedure FreeMimeList;
+var
+ I: integer;
+begin
+ if Assigned(MimeList) then begin
+ for I := 0 to MimeList.Count - 1 do
+ MimeList.Objects[I].Free;
+ FreeAndNil(MimeList);
+ end;
+end;
+
+finalization
+ FreeMimeList;
+end.
diff --git a/utils/fppkg/lnet/lnet.pp b/utils/fppkg/lnet/lnet.pp
index 0b97318bfe..3525313987 100644
--- a/utils/fppkg/lnet/lnet.pp
+++ b/utils/fppkg/lnet/lnet.pp
@@ -440,7 +440,7 @@ procedure TLSocket.LogError(const msg: string; const ernum: Integer);
begin
if Assigned(FOnError) then
if ernum > 0 then
- FOnError(Self, msg + ': ' + LStrError(ernum))
+ FOnError(Self, msg + '[' + IntToStr(ernum) + ']: ' + LStrError(ernum))
else
FOnError(Self, msg);
end;
diff --git a/utils/fppkg/lnet/lprocess.pp b/utils/fppkg/lnet/lprocess.pp
new file mode 100644
index 0000000000..87ba9075cc
--- /dev/null
+++ b/utils/fppkg/lnet/lprocess.pp
@@ -0,0 +1,185 @@
+{ Asynchronous process support
+
+ Copyright (C) 2006 Micha Nelissen
+
+ This library is Free software; you can redistribute it and/or modify it
+ under the terms of the GNU Library General Public License as published by
+ the Free Software Foundation; either version 2 of the License, or (at your
+ option) any later version.
+
+ This program is diStributed in the hope that it will be useful, but WITHOUT
+ ANY WARRANTY; withOut even the implied warranty of MERCHANTABILITY or
+ FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License
+ for more details.
+
+ You should have received a Copy of the GNU Library General Public License
+ along with This library; if not, Write to the Free Software Foundation,
+ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+ This license has been modified. See file LICENSE.ADDON for more information.
+ Should you find these sources without a LICENSE File, please contact
+ me at ales@chello.sk
+}
+
+unit lProcess;
+
+{$mode objfpc}{$h+}
+
+interface
+
+uses
+ sysutils, classes, process, levents, pipes;
+
+type
+ TLInputPipeStream = class(TInputPipeStream)
+ protected
+ FEvent: TLHandle;
+ public
+ function Read(var Buffer; Count: longint): longint; override;
+ end;
+
+ TLOutputPipeStream = class(TOutputPipeStream)
+ protected
+ FEvent: TLHandle;
+ public
+ function Write(const Buffer; Count: longint): longint; override;
+ end;
+
+ TLProcess = class(TProcess)
+ protected
+ FInputEvent: TLHandle;
+ FOutputEvent: TLHandle;
+ FStderrEvent: TLHandle;
+ FEventer: TLEventer;
+
+ function GetOnNeedInput: TLHandleEvent;
+ function GetOnHasOutput: TLHandleEvent;
+ function GetOnHasStderr: TLHandleEvent;
+ procedure SetOnNeedInput(NewOnInput: TLHandleEvent);
+ procedure SetOnHasOutput(NewOnOutput: TLHandleEvent);
+ procedure SetOnHasStderr(NewOnStderr: TLHandleEvent);
+ public
+ constructor Create(AOwner: TComponent); override;
+ destructor Destroy; override;
+
+ procedure CloseInput; override;
+ procedure CloseOutput; override;
+ procedure CloseStderr; override;
+ procedure Execute; override;
+
+ property InputEvent: TLHandle read FInputEvent;
+ property OutputEvent: TLHandle read FOutputEvent;
+ property StderrEvent: TLHandle read FStderrEvent;
+ property Eventer: TLEventer read FEventer write FEventer;
+ property OnNeedInput: TLHandleEvent read GetOnNeedInput write SetOnNeedInput;
+ property OnHasOutput: TLHandleEvent read GetOnHasOutput write SetOnHasOutput;
+ property OnHasStderr: TLHandleEvent read GetOnHasStderr write SetOnHasStderr;
+ end;
+
+implementation
+
+function TLInputPipeStream.Read(var Buffer; Count: longint): longint;
+begin
+ Result := inherited;
+ FEvent.IgnoreRead := false;
+end;
+
+function TLOutputPipeStream.Write(const Buffer; Count: longint): longint;
+begin
+ Result := inherited;
+ FEvent.IgnoreWrite := false;
+end;
+
+constructor TLProcess.Create(AOwner: TComponent);
+begin
+ inherited;
+
+ FInputEvent := TLHandle.Create;
+ FOutputEvent := TLHandle.Create;
+ FStderrEvent := TLHandle.Create;
+end;
+
+destructor TLProcess.Destroy;
+begin
+ inherited;
+ FInputEvent.Free;
+ FOutputEvent.Free;
+ FStderrEvent.Free;
+end;
+
+procedure TLProcess.CloseInput;
+begin
+ FEventer.UnplugHandle(FInputEvent);
+ inherited;
+end;
+
+procedure TLProcess.CloseOutput;
+begin
+ FEventer.UnplugHandle(FOutputEvent);
+ inherited;
+end;
+
+procedure TLProcess.CloseStderr;
+begin
+ FEventer.UnplugHandle(FStderrEvent);
+ inherited;
+end;
+
+procedure TLProcess.Execute;
+begin
+ inherited;
+
+ if (poUsePipes in Options) and (FEventer <> nil) then
+ begin
+ if Input <> nil then
+ begin
+ FInputEvent.Handle := Input.Handle;
+ FInputEvent.IgnoreRead := true;
+ FEventer.AddHandle(FInputEvent);
+ end;
+ if Output <> nil then
+ begin
+ FOutputEvent.Handle := Output.Handle;
+ FOutputEvent.IgnoreWrite := true;
+ FEventer.AddHandle(FOutputEvent);
+ end;
+ if Stderr <> nil then
+ begin
+ FStderrEvent.Handle := Stderr.Handle;
+ FStderrEvent.IgnoreWrite := true;
+ FEventer.AddHandle(FStderrEvent);
+ end;
+ end;
+end;
+
+function TLProcess.GetOnNeedInput: TLHandleEvent;
+begin
+ Result := FInputEvent.OnWrite;
+end;
+
+function TLProcess.GetOnHasOutput: TLHandleEvent;
+begin
+ Result := FOutputEvent.OnRead;
+end;
+
+function TLProcess.GetOnHasStderr: TLHandleEvent;
+begin
+ Result := FStderrEvent.OnRead;
+end;
+
+procedure TLProcess.SetOnNeedInput(NewOnInput: TLHandleEvent);
+begin
+ FInputEvent.OnWrite := NewOnInput;
+end;
+
+procedure TLProcess.SetOnHasOutput(NewOnOutput: TLHandleEvent);
+begin
+ FOutputEvent.OnRead := NewOnOutput;
+end;
+
+procedure TLProcess.SetOnHasStderr(NewOnStderr: TLHandleEvent);
+begin
+ FStderrEvent.OnRead := NewOnStderr;
+end;
+
+end.
diff --git a/utils/fppkg/lnet/lsmtp.pp b/utils/fppkg/lnet/lsmtp.pp
new file mode 100644
index 0000000000..adeadedf4e
--- /dev/null
+++ b/utils/fppkg/lnet/lsmtp.pp
@@ -0,0 +1,530 @@
+{ lNet SMTP unit
+
+ CopyRight (C) 2005-2006 Ales Katona
+
+ This library is Free software; you can rediStribute it and/or modify it
+ under the terms of the GNU Library General Public License as published by
+ the Free Software Foundation; either version 2 of the License, or (at your
+ option) any later version.
+
+ This program is diStributed in the hope that it will be useful, but WITHOUT
+ ANY WARRANTY; withOut even the implied warranty of MERCHANTABILITY or
+ FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License
+ for more details.
+
+ You should have received a Copy of the GNU Library General Public License
+ along with This library; if not, Write to the Free Software Foundation,
+ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+ This license has been modified. See File LICENSE.ADDON for more inFormation.
+ Should you find these sources without a LICENSE File, please contact
+ me at ales@chello.sk
+}
+
+unit lsmtp;
+
+{$mode objfpc}{$H+}
+{$inline on}
+
+interface
+
+uses
+ Classes, lNet, lEvents, lCommon;
+
+type
+ TLSMTP = class;
+ TLSMTPClient = class;
+
+ TLSMTPStatus = (ssNone, ssCon, ssHelo, ssEhlo, ssMail,
+ ssRcpt, ssData, ssRset, ssQuit);
+
+ TLSMTPStatusSet = set of TLSMTPStatus;
+
+ TLSMTPStatusRec = record
+ Status: TLSMTPStatus;
+ Args: array[1..2] of string;
+ end;
+
+ { TLSMTPStatusFront }
+ {$DEFINE __front_type__ := TLSMTPStatusRec}
+ {$i lcontainersh.inc}
+ TLSMTPStatusFront = TLFront;
+
+ TLSMTPClientStatusEvent = procedure (aSocket: TLSocket;
+ const aStatus: TLSMTPStatus) of object;
+
+ TLSMTP = class(TLComponent)
+ protected
+ FConnection: TLTcp;
+ protected
+ function GetTimeout: DWord;
+ procedure SetTimeout(const AValue: DWord);
+
+ function GetConnected: Boolean;
+
+ function GetSocketClass: TLSocketClass;
+ procedure SetSocketClass(const AValue: TLSocketClass);
+
+ function GetEventer: TLEventer;
+ procedure SetEventer(Value: TLEventer);
+ public
+ constructor Create(aOwner: TComponent); override;
+ destructor Destroy; override;
+ public
+ property Connected: Boolean read GetConnected;
+ property Connection: TLTcp read FConnection;
+
+ property SocketClass: TLSocketClass read GetSocketClass write SetSocketClass;
+ property Eventer: TLEventer read GetEventer write SetEventer;
+ property Timeout: DWord read GetTimeout write SetTimeout;
+ end;
+
+ { TLSMTPClient }
+
+ TLSMTPClient = class(TLSMTP, ILClient)
+ protected
+ FStatus: TLSMTPStatusFront;
+ FCommandFront: TLSMTPStatusFront;
+ FPipeLine: Boolean;
+
+ FOnConnect: TLSocketEvent;
+ FOnReceive: TLSocketEvent;
+ FOnDisconnect: TLSocketEvent;
+ FOnSuccess: TLSMTPClientStatusEvent;
+ FOnFailure: TLSMTPClientStatusEvent;
+ FOnError: TLSocketErrorEvent;
+
+ FSL: TStringList;
+ FStatusSet: TLSMTPStatusSet;
+ FMessage: string;
+ protected
+ procedure OnEr(const msg: string; aSocket: TLSocket);
+ procedure OnRe(aSocket: TLSocket);
+ procedure OnCo(aSocket: TLSocket);
+ procedure OnDs(aSocket: TLSocket);
+ protected
+ function CanContinue(const aStatus: TLSMTPStatus; const Arg1, Arg2: string): Boolean;
+
+ function CleanInput(var s: string): Integer;
+
+ procedure EvaluateAnswer(const Ans: string);
+
+ procedure ExecuteFrontCommand;
+ public
+ constructor Create(aOwner: TComponent); override;
+ destructor Destroy; override;
+
+ function Connect(const aHost: string; const aPort: Word = 25): Boolean; virtual;
+ function Connect: Boolean; virtual;
+
+ function Get(var aData; const aSize: Integer; aSocket: TLSocket = nil): Integer; virtual;
+ function GetMessage(out msg: string; aSocket: TLSocket = nil): Integer; virtual;
+
+ procedure SendMail(const From, Recipients, Subject, Msg: string);
+ procedure Helo(aHost: string = '');
+ procedure Ehlo(aHost: string = '');
+ procedure Mail(const From: string);
+ procedure Rcpt(const RcptTo: string);
+ procedure Data(const Msg: string);
+ procedure Rset;
+ procedure Quit;
+
+ procedure Disconnect; override;
+
+ procedure CallAction; override;
+ public
+ property PipeLine: Boolean read FPipeLine write FPipeLine;
+ property StatusSet: TLSMTPStatusSet read FStatusSet write FStatusSet;
+ property OnConnect: TLSocketEvent read FOnConnect write FOnConnect;
+ property OnReceive: TLSocketEvent read FOnReceive write FOnReceive;
+ property OnDisconnect: TLSocketEvent read FOnDisconnect write FOnDisconnect;
+ property OnSuccess: TLSMTPClientStatusEvent read FOnSuccess write FOnSuccess;
+ property OnFailure: TLSMTPClientStatusEvent read FOnFailure write FOnFailure;
+ property OnError: TLSocketErrorEvent read FOnError write FOnError;
+ end;
+
+implementation
+
+uses
+ SysUtils;
+
+const
+ EMPTY_REC: TLSMTPStatusRec = (Status: ssNone; Args: ('', ''));
+ SLE = #13#10;
+
+{$i lcontainers.inc}
+
+function StatusToStr(const aStatus: TLSMTPStatus): string;
+const
+ STATAR: array[ssNone..ssQuit] of string = ('ssNone', 'ssCon', 'ssHelo', 'ssEhlo', 'ssMail',
+ 'ssRcpt', 'ssData', 'ssRset', 'ssQuit');
+begin
+ Result := STATAR[aStatus];
+end;
+
+function MakeStatusRec(const aStatus: TLSMTPStatus; const Arg1, Arg2: string): TLSMTPStatusRec;
+begin
+ Result.Status := aStatus;
+ Result.Args[1] := Arg1;
+ Result.Args[2] := Arg2;
+end;
+
+{ TLSMTP }
+
+function TLSMTP.GetTimeout: DWord;
+begin
+ Result := FConnection.Timeout;
+end;
+
+procedure TLSMTP.SetTimeout(const AValue: DWord);
+begin
+ FConnection.Timeout := aValue;
+end;
+
+function TLSMTP.GetConnected: Boolean;
+begin
+ Result := FConnection.Connected;
+end;
+
+function TLSMTP.GetSocketClass: TLSocketClass;
+begin
+ Result := FConnection.SocketClass;
+end;
+
+procedure TLSMTP.SetSocketClass(const AValue: TLSocketClass);
+begin
+ FConnection.SocketClass := AValue;
+end;
+
+function TLSMTP.GetEventer: TLEventer;
+begin
+ Result := FConnection.Eventer;
+end;
+
+procedure TLSMTP.SetEventer(Value: TLEventer);
+begin
+ FConnection.Eventer := Value;
+end;
+
+constructor TLSMTP.Create(aOwner: TComponent);
+begin
+ inherited Create(aOwner);
+
+ FConnection := TLTcp.Create(nil);
+end;
+
+destructor TLSMTP.Destroy;
+begin
+ FConnection.Free;
+
+ inherited Destroy;
+end;
+
+{ TLSMTPClient }
+
+constructor TLSMTPClient.Create(aOwner: TComponent);
+begin
+ inherited Create(aOwner);
+ FPort := 25;
+ FStatusSet := []; // empty set for "ok/not-ok" Event
+ FSL := TStringList.Create;
+ FHost := '';
+ FMessage := '';
+// {$warning TODO: fix pipelining support when server does it}
+ FPipeLine := False;
+
+ FConnection.OnError := @OnEr;
+ FConnection.OnReceive := @OnRe;
+ FConnection.OnConnect := @OnCo;
+
+ FStatus := TLSMTPStatusFront.Create(EMPTY_REC);
+ FCommandFront := TLSMTPStatusFront.Create(EMPTY_REC);
+end;
+
+destructor TLSMTPClient.Destroy;
+begin
+ Quit;
+ FSL.Free;
+ FStatus.Free;
+ FCommandFront.Free;
+
+ inherited Destroy;
+end;
+
+procedure TLSMTPClient.OnEr(const msg: string; aSocket: TLSocket);
+begin
+ if Assigned(FOnError) then
+ FOnError(msg, aSocket);
+end;
+
+procedure TLSMTPClient.OnRe(aSocket: TLSocket);
+begin
+ if Assigned(FOnReceive) then
+ FOnReceive(aSocket);
+end;
+
+procedure TLSMTPClient.OnCo(aSocket: TLSocket);
+begin
+ if Assigned(FOnConnect) then
+ FOnConnect(aSocket);
+end;
+
+procedure TLSMTPClient.OnDs(aSocket: TLSocket);
+begin
+ if Assigned(FOnDisconnect) then
+ FOnDisconnect(aSocket);
+end;
+
+function TLSMTPClient.CanContinue(const aStatus: TLSMTPStatus; const Arg1, Arg2: string): Boolean;
+begin
+ Result := FPipeLine or FStatus.Empty;
+ if not Result then
+ FCommandFront.Insert(MakeStatusRec(aStatus, Arg1, Arg2));
+end;
+
+function TLSMTPClient.CleanInput(var s: string): Integer;
+var
+ i: Integer;
+begin
+ FSL.Text := s;
+ if FSL.Count > 0 then
+ for i := 0 to FSL.Count-1 do
+ if Length(FSL[i]) > 0 then EvaluateAnswer(FSL[i]);
+ s := StringReplace(s, SLE, LineEnding, [rfReplaceAll]);
+ i := Pos('PASS', s);
+ if i > 0 then
+ s := Copy(s, 1, i-1) + 'PASS';
+ Result := Length(s);
+end;
+
+procedure TLSMTPClient.EvaluateAnswer(const Ans: string);
+
+ function GetNum: Integer;
+ begin
+ try
+ Result := StrToInt(Copy(Ans, 1, 3));
+ except
+ Result := -1;
+ end;
+ end;
+
+ function ValidResponse(const Answer: string): Boolean; inline;
+ begin
+ Result := (Length(Ans) >= 3) and
+ (Ans[1] in ['1'..'5']) and
+ (Ans[2] in ['0'..'9']) and
+ (Ans[3] in ['0'..'9']);
+
+ if Result then
+ Result := (Length(Ans) = 3) or ((Length(Ans) > 3) and (Ans[4] = ' '));
+ end;
+
+ procedure Eventize(const aStatus: TLSMTPStatus; const Res: Boolean);
+ begin
+ if Res then begin
+ if Assigned(FOnSuccess) and (aStatus in FStatusSet) then
+ FOnSuccess(FConnection.Iterator, aStatus);
+ end else begin
+ if Assigned(FOnFailure) and (aStatus in FStatusSet) then
+ FOnFailure(FConnection.Iterator, aStatus);
+ end;
+ end;
+
+var
+ x: Integer;
+begin
+ x := GetNum;
+ if ValidResponse(Ans) and not FStatus.Empty then
+ case FStatus.First.Status of
+ ssCon,
+ ssHelo,
+ ssEhlo: case x of
+ 200..299: begin
+ Eventize(FStatus.First.Status, True);
+ FStatus.Remove;
+ end;
+ else begin
+ Eventize(FStatus.First.Status, False);
+ Disconnect;
+ end;
+ end;
+
+ ssMail,
+ ssRcpt: begin
+ Eventize(FStatus.First.Status, (x >= 200) and (x < 299));
+ FStatus.Remove;
+ end;
+
+ ssData: case x of
+ 200..299: begin
+ Eventize(FStatus.First.Status, True);
+ FStatus.Remove;
+ end;
+ 300..399: if Length(FMessage) > 0 then begin
+ FConnection.SendMessage(FMessage);
+ FMessage := '';
+ end;
+ else begin
+ Eventize(FStatus.First.Status, False);
+ FStatus.Remove;
+ end;
+ end;
+
+ ssRset: begin
+ Eventize(FStatus.First.Status, (x >= 200) and (x < 299));
+ FStatus.Remove;
+ end;
+
+ ssQuit: begin
+ Eventize(FStatus.First.Status, (x >= 200) and (x < 299));
+ FStatus.Remove;
+ if Assigned(FOnDisconnect) then
+ FOnDisconnect(FConnection.Iterator);
+ Disconnect;
+ end;
+ end;
+ if FStatus.Empty and not FCommandFront.Empty then
+ ExecuteFrontCommand;
+end;
+
+procedure TLSMTPClient.ExecuteFrontCommand;
+begin
+ with FCommandFront.First do
+ case Status of
+ ssHelo: Helo(Args[1]);
+ ssEhlo: Ehlo(Args[1]);
+ ssMail: Mail(Args[1]);
+ ssRcpt: Rcpt(Args[1]);
+ ssData: Data(Args[1]);
+ ssRset: Rset;
+ ssQuit: Quit;
+ end;
+ FCommandFront.Remove;
+end;
+
+function TLSMTPClient.Connect(const aHost: string; const aPort: Word = 25): Boolean;
+begin
+ Result := False;
+ Disconnect;
+ if FConnection.Connect(aHost, aPort) then begin
+ FHost := aHost;
+ FPort := aPort;
+ FStatus.Insert(MakeStatusRec(ssCon, '', ''));
+ Result := True;
+ end;
+end;
+
+function TLSMTPClient.Connect: Boolean;
+begin
+ Result := Connect(FHost, FPort);
+end;
+
+function TLSMTPClient.Get(var aData; const aSize: Integer; aSocket: TLSocket): Integer;
+var
+ s: string;
+begin
+ Result := FConnection.Get(aData, aSize, aSocket);
+ if Result > 0 then begin
+ SetLength(s, Result);
+ Move(aData, PChar(s)^, Result);
+ CleanInput(s);
+ end;
+end;
+
+function TLSMTPClient.GetMessage(out msg: string; aSocket: TLSocket): Integer;
+begin
+ Result := FConnection.GetMessage(msg, aSocket);
+ if Result > 0 then
+ Result := CleanInput(msg);
+end;
+
+procedure TLSMTPClient.SendMail(const From, Recipients, Subject, Msg: string);
+var
+ i: Integer;
+begin
+ if (Length(Recipients) > 0) and (Length(From) > 0) then begin
+ Mail(From);
+ FSL.CommaText := StringReplace(Recipients, ' ', ',', [rfReplaceAll]);
+ for i := 0 to FSL.Count-1 do
+ Rcpt(FSL[i]);
+ Data('From: ' + From + SLE + 'Subject: ' + Subject + SLE + 'To: ' + FSL.CommaText + SLE + Msg);
+ Rset;
+ end;
+end;
+
+procedure TLSMTPClient.Helo(aHost: string = '');
+begin
+ if Length(Host) = 0 then
+ aHost := FHost;
+ if CanContinue(ssHelo, aHost, '') then begin
+ FConnection.SendMessage('HELO ' + aHost + SLE);
+ FStatus.Insert(MakeStatusRec(ssHelo, '', ''));
+ end;
+end;
+
+procedure TLSMTPClient.Ehlo(aHost: string = '');
+begin
+ if Length(aHost) = 0 then
+ aHost := FHost;
+ if CanContinue(ssEhlo, aHost, '') then begin
+ FConnection.SendMessage('EHLO ' + aHost + SLE);
+ FStatus.Insert(MakeStatusRec(ssEhlo, '', ''));
+ end;
+end;
+
+procedure TLSMTPClient.Mail(const From: string);
+begin
+ if CanContinue(ssMail, From, '') then begin
+ FConnection.SendMessage('MAIL FROM:' + '<' + From + '>' + SLE);
+ FStatus.Insert(MakeStatusRec(ssMail, '', ''));
+ end;
+end;
+
+procedure TLSMTPClient.Rcpt(const RcptTo: string);
+begin
+ if CanContinue(ssRcpt, RcptTo, '') then begin
+ FConnection.SendMessage('RCPT TO:' + '<' + RcptTo + '>' + SLE);
+ FStatus.Insert(MakeStatusRec(ssRcpt, '', ''));
+ end;
+end;
+
+procedure TLSMTPClient.Data(const Msg: string);
+begin
+ if CanContinue(ssData, Msg, '') then begin
+ // TODO: clean SLEs and '.' on line starts
+ FMessage := Msg + SLE + '.' + SLE;
+ FConnection.SendMessage('DATA' + SLE);
+ FStatus.Insert(MakeStatusRec(ssData, '', ''));
+ end;
+end;
+
+procedure TLSMTPClient.Rset;
+begin
+ if CanContinue(ssRset, '', '') then begin
+ FConnection.SendMessage('RSET' + SLE);
+ FStatus.Insert(MakeStatusRec(ssRset, '', ''));
+ end;
+end;
+
+procedure TLSMTPClient.Quit;
+begin
+ if CanContinue(ssQuit, '', '') then begin
+ FConnection.SendMessage('QUIT' + SLE);
+ FStatus.Insert(MakeStatusRec(ssQuit, '', ''));
+ end;
+end;
+
+procedure TLSMTPClient.Disconnect;
+begin
+ FConnection.Disconnect;
+ FStatus.Clear;
+ FCommandFront.Clear;
+end;
+
+procedure TLSMTPClient.CallAction;
+begin
+ FConnection.CallAction;
+end;
+
+end.
+
diff --git a/utils/fppkg/lnet/lspawnfcgi.pp b/utils/fppkg/lnet/lspawnfcgi.pp
new file mode 100644
index 0000000000..280ad94c7f
--- /dev/null
+++ b/utils/fppkg/lnet/lspawnfcgi.pp
@@ -0,0 +1,21 @@
+unit lSpawnFCGI;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+ Sockets, lNet, lCommon;
+
+ function SpawnFCGIProcess(App, Enviro: string; const aPort: Word): Integer;
+
+implementation
+
+{$ifdef UNIX}
+ {$i lspawnfcgiunix.inc}
+{$else}
+ {$i lspawnfcgiwin.inc}
+{$endif}
+
+end.
+
diff --git a/utils/fppkg/lnet/ltimer.pp b/utils/fppkg/lnet/ltimer.pp
new file mode 100644
index 0000000000..9aae74dc8e
--- /dev/null
+++ b/utils/fppkg/lnet/ltimer.pp
@@ -0,0 +1,61 @@
+unit ltimer;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+ Classes, SysUtils;
+
+type
+
+ { TLTimer }
+
+ TLTimer = class(TObject)
+ protected
+ FOnTimer: TNotifyEvent;
+ FInterval: TDateTime;
+ FStarted: TDateTime;
+ FOneShot: Boolean;
+ FEnabled: Boolean;
+
+ function GetInterval: Integer;
+ procedure SetInterval(const aValue: Integer);
+ public
+ procedure CallAction;
+ property Enabled: Boolean read FEnabled write FEnabled;
+ property Interval: Integer read GetInterval write SetInterval;
+ property OneShot: Boolean read FOneShot write FOneShot;
+ property OnTimer: TNotifyEvent read FOnTimer write FOnTimer;
+ end;
+
+implementation
+
+{ TLTimer }
+
+function TLTimer.GetInterval: Integer;
+begin
+ Result := Round(FInterval * MSecsPerDay);
+end;
+
+procedure TLTimer.SetInterval(const aValue: Integer);
+begin
+ FInterval := AValue / MSecsPerDay;
+ FStarted := Now;
+ FEnabled := true;
+end;
+
+procedure TLTimer.CallAction;
+begin
+ if FEnabled and Assigned(FOnTimer) and (Now - FStarted >= FInterval) then
+ begin
+ FOnTimer(Self);
+ if not FOneShot then
+ FStarted := Now
+ else
+ FEnabled := false;
+ end;
+end;
+
+end.
+
diff --git a/utils/fppkg/lnet/openssl.pp b/utils/fppkg/lnet/openssl.pp
deleted file mode 100644
index 465900e187..0000000000
--- a/utils/fppkg/lnet/openssl.pp
+++ /dev/null
@@ -1,1452 +0,0 @@
-unit OpenSSL;
-
-{==============================================================================|
-| Project : Ararat Synapse | 003.004.001 |
-|==============================================================================|
-| Content: SSL support by OpenSSL |
-|==============================================================================|
-| Copyright (c)1999-2005, Lukas Gebauer |
-| All rights reserved. |
-| |
-| Redistribution and use in source and binary forms, with or without |
-| modification, are permitted provided that the following conditions are met: |
-| |
-| Redistributions of source code must retain the above copyright notice, this |
-| list of conditions and the following disclaimer. |
-| |
-| Redistributions in binary form must reproduce the above copyright notice, |
-| this list of conditions and the following disclaimer in the documentation |
-| and/or other materials provided with the distribution. |
-| |
-| Neither the name of Lukas Gebauer nor the names of its contributors may |
-| be used to endorse or promote products derived from this software without |
-| specific prior written permission. |
-| |
-| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
-| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
-| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
-| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
-| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
-| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
-| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
-| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
-| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
-| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
-| DAMAGE. |
-|==============================================================================|
-| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
-| Portions created by Lukas Gebauer are Copyright (c)2002-2005. |
-| All Rights Reserved. |
-|==============================================================================|
-| Contributor(s): |
-|==============================================================================|
-| FreePascal basic cleanup (original worked too): Ales Katona |
-|==============================================================================|
-| History: see HISTORY.HTM from distribution package |
-| (Found at URL: http://www.ararat.cz/synapse/) |
-|==============================================================================}
-
-{
-Special thanks to Gregor Ibic
- (Intelicom d.o.o., http://www.intelicom.si)
- for good inspiration about begin with SSL programming.
-}
-
-{$MODE DELPHI}{$H+}
-
-{:@abstract(OpenSSL support)
-
-This unit is Pascal interface to OpenSSL library (used by @link(ssl_openssl) unit).
-OpenSSL is loaded dynamicly on-demand. If this library is not found in system,
-requested OpenSSL function just return errorcode.
-}
-
-interface
-
-uses
- DynLibs;
-
-var
- {$IFDEF WINDOWS}
- DLLSSLName: string = 'ssleay32.dll';
- DLLSSLName2: string = 'libssl32.dll';
- DLLUtilName: string = 'libeay32.dll';
- {$ELSE}
- DLLSSLName: string = 'libssl.so';
- DLLUtilName: string = 'libcrypto.so';
- {$ENDIF}
-
-type
- SslPtr = Pointer;
- PSslPtr = ^SslPtr;
- PSSL_CTX = SslPtr;
- PSSL = SslPtr;
- PSSL_METHOD = SslPtr;
- PX509 = SslPtr;
- PX509_NAME = SslPtr;
- PEVP_MD = SslPtr;
- PInteger = ^Integer;
- PBIO_METHOD = SslPtr;
- PBIO = SslPtr;
- EVP_PKEY = SslPtr;
- PRSA = SslPtr;
- PASN1_UTCTIME = SslPtr;
- PASN1_INTEGER = SslPtr;
- PPasswdCb = SslPtr;
- PFunction = procedure;
-
- DES_cblock = array[0..7] of Byte;
- PDES_cblock = ^DES_cblock;
- des_ks_struct = packed record
- ks: DES_cblock;
- weak_key: Integer;
- end;
- des_key_schedule = array[1..16] of des_ks_struct;
-
-const
- EVP_MAX_MD_SIZE = 16 + 20;
-
- SSL_ERROR_NONE = 0;
- SSL_ERROR_SSL = 1;
- SSL_ERROR_WANT_READ = 2;
- SSL_ERROR_WANT_WRITE = 3;
- SSL_ERROR_WANT_X509_LOOKUP = 4;
- SSL_ERROR_SYSCALL = 5; //look at error stack/return value/errno
- SSL_ERROR_ZERO_RETURN = 6;
- SSL_ERROR_WANT_CONNECT = 7;
- SSL_ERROR_WANT_ACCEPT = 8;
-
- SSL_OP_NO_SSLv2 = $01000000;
- SSL_OP_NO_SSLv3 = $02000000;
- SSL_OP_NO_TLSv1 = $04000000;
- SSL_OP_ALL = $000FFFFF;
- SSL_VERIFY_NONE = $00;
- SSL_VERIFY_PEER = $01;
-
- OPENSSL_DES_DECRYPT = 0;
- OPENSSL_DES_ENCRYPT = 1;
-
- X509_V_OK = 0;
- X509_V_ILLEGAL = 1;
- X509_V_ERR_UNABLE_TO_GET_ISSUER_CERT = 2;
- X509_V_ERR_UNABLE_TO_GET_CRL = 3;
- X509_V_ERR_UNABLE_TO_DECRYPT_CERT_SIGNATURE = 4;
- X509_V_ERR_UNABLE_TO_DECRYPT_CRL_SIGNATURE = 5;
- X509_V_ERR_UNABLE_TO_DECODE_ISSUER_PUBLIC_KEY = 6;
- X509_V_ERR_CERT_SIGNATURE_FAILURE = 7;
- X509_V_ERR_CRL_SIGNATURE_FAILURE = 8;
- X509_V_ERR_CERT_NOT_YET_VALID = 9;
- X509_V_ERR_CERT_HAS_EXPIRED = 10;
- X509_V_ERR_CRL_NOT_YET_VALID = 11;
- X509_V_ERR_CRL_HAS_EXPIRED = 12;
- X509_V_ERR_ERROR_IN_CERT_NOT_BEFORE_FIELD = 13;
- X509_V_ERR_ERROR_IN_CERT_NOT_AFTER_FIELD = 14;
- X509_V_ERR_ERROR_IN_CRL_LAST_UPDATE_FIELD = 15;
- X509_V_ERR_ERROR_IN_CRL_NEXT_UPDATE_FIELD = 16;
- X509_V_ERR_OUT_OF_MEM = 17;
- X509_V_ERR_DEPTH_ZERO_SELF_SIGNED_CERT = 18;
- X509_V_ERR_SELF_SIGNED_CERT_IN_CHAIN = 19;
- X509_V_ERR_UNABLE_TO_GET_ISSUER_CERT_LOCALLY = 20;
- X509_V_ERR_UNABLE_TO_VERIFY_LEAF_SIGNATURE = 21;
- X509_V_ERR_CERT_CHAIN_TOO_LONG = 22;
- X509_V_ERR_CERT_REVOKED = 23;
- X509_V_ERR_INVALID_CA = 24;
- X509_V_ERR_PATH_LENGTH_EXCEEDED = 25;
- X509_V_ERR_INVALID_PURPOSE = 26;
- X509_V_ERR_CERT_UNTRUSTED = 27;
- X509_V_ERR_CERT_REJECTED = 28;
- //These are 'informational' when looking for issuer cert
- X509_V_ERR_SUBJECT_ISSUER_MISMATCH = 29;
- X509_V_ERR_AKID_SKID_MISMATCH = 30;
- X509_V_ERR_AKID_ISSUER_SERIAL_MISMATCH = 31;
- X509_V_ERR_KEYUSAGE_NO_CERTSIGN = 32;
- X509_V_ERR_UNABLE_TO_GET_CRL_ISSUER = 33;
- X509_V_ERR_UNHANDLED_CRITICAL_EXTENSION = 34;
- //The application is not happy
- X509_V_ERR_APPLICATION_VERIFICATION = 50;
-
- SSL_FILETYPE_ASN1 = 2;
- SSL_FILETYPE_PEM = 1;
- EVP_PKEY_RSA = 6;
-
-var
- SSLLibHandle: TLibHandle = 0;
- SSLUtilHandle: TLibHandle = 0;
- SSLLibFile: string = '';
- SSLUtilFile: string = '';
-
-// libssl.dll
- function SslGetError(s: PSSL; ret_code: Integer):Integer;
- function SslLibraryInit:Integer;
- procedure SslLoadErrorStrings;
-// function SslCtxSetCipherList(arg0: PSSL_CTX; str: PChar):Integer;
- function SslCtxSetCipherList(arg0: PSSL_CTX; var str: String):Integer;
- function SslCtxNew(meth: PSSL_METHOD):PSSL_CTX;
- procedure SslCtxFree(arg0: PSSL_CTX);
- function SslSetFd(s: PSSL; fd: Integer):Integer;
- function SslMethodV2:PSSL_METHOD;
- function SslMethodV3:PSSL_METHOD;
- function SslMethodTLSV1:PSSL_METHOD;
- function SslMethodV23:PSSL_METHOD;
- function SslCtxUsePrivateKey(ctx: PSSL_CTX; pkey: SslPtr):Integer;
- function SslCtxUsePrivateKeyASN1(pk: integer; ctx: PSSL_CTX; d: String; len: integer):Integer;
-// function SslCtxUsePrivateKeyFile(ctx: PSSL_CTX; const _file: PChar; _type: Integer):Integer;
- function SslCtxUsePrivateKeyFile(ctx: PSSL_CTX; const _file: String; _type: Integer):Integer;
- function SslCtxUseCertificate(ctx: PSSL_CTX; x: SslPtr):Integer;
- function SslCtxUseCertificateASN1(ctx: PSSL_CTX; len: integer; d: String):Integer;
- function SslCtxUseCertificateFile(ctx: PSSL_CTX; const _file: String; _type: Integer):Integer;
-// function SslCtxUseCertificateChainFile(ctx: PSSL_CTX; const _file: PChar):Integer;
- function SslCtxUseCertificateChainFile(ctx: PSSL_CTX; const _file: String):Integer;
- function SslCtxCheckPrivateKeyFile(ctx: PSSL_CTX):Integer;
- procedure SslCtxSetDefaultPasswdCb(ctx: PSSL_CTX; cb: PPasswdCb);
- procedure SslCtxSetDefaultPasswdCbUserdata(ctx: PSSL_CTX; u: SslPtr);
-// function SslCtxLoadVerifyLocations(ctx: PSSL_CTX; const CAfile: PChar; const CApath: PChar):Integer;
- function SslCtxLoadVerifyLocations(ctx: PSSL_CTX; const CAfile: String; const CApath: String):Integer;
- function SslNew(ctx: PSSL_CTX):PSSL;
- procedure SslFree(ssl: PSSL);
- function SslAccept(ssl: PSSL):Integer;
- function SslConnect(ssl: PSSL):Integer;
- function SslShutdown(ssl: PSSL):Integer;
- function SslRead(ssl: PSSL; buf: SslPtr; num: Integer):Integer;
- function SslPeek(ssl: PSSL; buf: SslPtr; num: Integer):Integer;
- function SslWrite(ssl: PSSL; buf: SslPtr; num: Integer):Integer;
- function SslPending(ssl: PSSL):Integer;
- function SslGetVersion(ssl: PSSL):String;
- function SslGetPeerCertificate(ssl: PSSL):PX509;
- procedure SslCtxSetVerify(ctx: PSSL_CTX; mode: Integer; arg2: PFunction);
- function SSLGetCurrentCipher(s: PSSL):SslPtr;
- function SSLCipherGetName(c: SslPtr): String;
- function SSLCipherGetBits(c: SslPtr; var alg_bits: Integer):Integer;
- function SSLGetVerifyResult(ssl: PSSL):Integer;
-
-// libeay.dll
- function X509New: PX509;
- procedure X509Free(x: PX509);
- function X509NameOneline(a: PX509_NAME; var buf: String; size: Integer):String;
- function X509GetSubjectName(a: PX509):PX509_NAME;
- function X509GetIssuerName(a: PX509):PX509_NAME;
- function X509NameHash(x: PX509_NAME):Cardinal;
-// function SslX509Digest(data: PX509; _type: PEVP_MD; md: PChar; len: PInteger):Integer;
- function X509Digest(data: PX509; _type: PEVP_MD; md: String; var len: Integer):Integer;
- function X509print(b: PBIO; a: PX509): integer;
- function X509SetVersion(x: PX509; version: integer): integer;
- function X509SetPubkey(x: PX509; pkey: EVP_PKEY): integer;
- function X509SetIssuerName(x: PX509; name: PX509_NAME): integer;
- function X509NameAddEntryByTxt(name: PX509_NAME; field: string; _type: integer;
- bytes: string; len, loc, _set: integer): integer;
- function X509Sign(x: PX509; pkey: EVP_PKEY; const md: PEVP_MD): integer;
- function X509GmtimeAdj(s: PASN1_UTCTIME; adj: integer): PASN1_UTCTIME;
- function X509SetNotBefore(x: PX509; tm: PASN1_UTCTIME): integer;
- function X509SetNotAfter(x: PX509; tm: PASN1_UTCTIME): integer;
- function X509GetSerialNumber(x: PX509): PASN1_INTEGER;
- function EvpPkeyNew: EVP_PKEY;
- procedure EvpPkeyFree(pk: EVP_PKEY);
- function EvpPkeyAssign(pkey: EVP_PKEY; _type: integer; key: Prsa): integer;
- function EvpGetDigestByName(Name: String): PEVP_MD;
- procedure EVPcleanup;
-// function ErrErrorString(e: integer; buf: PChar): PChar;
- function SSLeayversion(t: integer): string;
- procedure ErrErrorString(e: integer; var buf: string; len: integer);
- function ErrGetError: integer;
- procedure ErrClearError;
- procedure ErrFreeStrings;
- procedure ErrRemoveState(pid: integer);
- procedure OPENSSLaddallalgorithms;
- procedure CRYPTOcleanupAllExData;
- procedure RandScreen;
- function BioNew(b: PBIO_METHOD): PBIO;
- procedure BioFreeAll(b: PBIO);
- function BioSMem: PBIO_METHOD;
- function BioCtrlPending(b: PBIO): integer;
- function BioRead(b: PBIO; var Buf: String; Len: integer): integer;
- function BioWrite(b: PBIO; Buf: String; Len: integer): integer;
- function d2iPKCS12bio(b:PBIO; Pkcs12: SslPtr): SslPtr;
- function PKCS12parse(p12: SslPtr; pass: string; var pkey, cert, ca: SslPtr): integer;
- procedure PKCS12free(p12: SslPtr);
- function RsaGenerateKey(bits, e: integer; callback: PFunction; cb_arg: SslPtr): PRSA;
- function Asn1UtctimeNew: PASN1_UTCTIME;
- procedure Asn1UtctimeFree(a: PASN1_UTCTIME);
- function Asn1IntegerSet(a: PASN1_INTEGER; v: integer): integer;
- function i2dX509bio(b: PBIO; x: PX509): integer;
- function i2dPrivateKeyBio(b: PBIO; pkey: EVP_PKEY): integer;
-
- // 3DES functions
- procedure DESsetoddparity(Key: des_cblock);
- function DESsetkeychecked(key: des_cblock; schedule: des_key_schedule): Integer;
- procedure DESecbencrypt(Input: des_cblock; output: des_cblock; ks: des_key_schedule; enc: Integer);
-
-function IsSSLloaded: Boolean;
-function InitSSLInterface: Boolean;
-function DestroySSLInterface: Boolean;
-
-implementation
-
-type
-// libssl.dll
- TSslGetError = function(s: PSSL; ret_code: Integer):Integer; cdecl;
- TSslLibraryInit = function:Integer; cdecl;
- TSslLoadErrorStrings = procedure; cdecl;
- TSslCtxSetCipherList = function(arg0: PSSL_CTX; str: PChar):Integer; cdecl;
- TSslCtxNew = function(meth: PSSL_METHOD):PSSL_CTX; cdecl;
- TSslCtxFree = procedure(arg0: PSSL_CTX); cdecl;
- TSslSetFd = function(s: PSSL; fd: Integer):Integer; cdecl;
- TSslMethodV2 = function:PSSL_METHOD; cdecl;
- TSslMethodV3 = function:PSSL_METHOD; cdecl;
- TSslMethodTLSV1 = function:PSSL_METHOD; cdecl;
- TSslMethodV23 = function:PSSL_METHOD; cdecl;
- TSslCtxUsePrivateKey = function(ctx: PSSL_CTX; pkey: sslptr):Integer; cdecl;
- TSslCtxUsePrivateKeyASN1 = function(pk: integer; ctx: PSSL_CTX; d: sslptr; len: integer):Integer; cdecl;
- TSslCtxUsePrivateKeyFile = function(ctx: PSSL_CTX; const _file: PChar; _type: Integer):Integer; cdecl;
- TSslCtxUseCertificate = function(ctx: PSSL_CTX; x: SslPtr):Integer; cdecl;
- TSslCtxUseCertificateASN1 = function(ctx: PSSL_CTX; len: Integer; d: SslPtr):Integer; cdecl;
- TSslCtxUseCertificateFile = function(ctx: PSSL_CTX; const _file: PChar; _type: Integer):Integer; cdecl;
- TSslCtxUseCertificateChainFile = function(ctx: PSSL_CTX; const _file: PChar):Integer; cdecl;
- TSslCtxCheckPrivateKeyFile = function(ctx: PSSL_CTX):Integer; cdecl;
- TSslCtxSetDefaultPasswdCb = procedure(ctx: PSSL_CTX; cb: SslPtr); cdecl;
- TSslCtxSetDefaultPasswdCbUserdata = procedure(ctx: PSSL_CTX; u: SslPtr); cdecl;
- TSslCtxLoadVerifyLocations = function(ctx: PSSL_CTX; const CAfile: PChar; const CApath: PChar):Integer; cdecl;
- TSslNew = function(ctx: PSSL_CTX):PSSL; cdecl;
- TSslFree = procedure(ssl: PSSL); cdecl;
- TSslAccept = function(ssl: PSSL):Integer; cdecl;
- TSslConnect = function(ssl: PSSL):Integer; cdecl;
- TSslShutdown = function(ssl: PSSL):Integer; cdecl;
- TSslRead = function(ssl: PSSL; buf: PChar; num: Integer):Integer; cdecl;
- TSslPeek = function(ssl: PSSL; buf: PChar; num: Integer):Integer; cdecl;
- TSslWrite = function(ssl: PSSL; const buf: PChar; num: Integer):Integer; cdecl;
- TSslPending = function(ssl: PSSL):Integer; cdecl;
- TSslGetVersion = function(ssl: PSSL):PChar; cdecl;
- TSslGetPeerCertificate = function(ssl: PSSL):PX509; cdecl;
- TSslCtxSetVerify = procedure(ctx: PSSL_CTX; mode: Integer; arg2: SslPtr); cdecl;
- TSSLGetCurrentCipher = function(s: PSSL):SslPtr; cdecl;
- TSSLCipherGetName = function(c: Sslptr):PChar; cdecl;
- TSSLCipherGetBits = function(c: SslPtr; alg_bits: PInteger):Integer; cdecl;
- TSSLGetVerifyResult = function(ssl: PSSL):Integer; cdecl;
-
-// libeay.dll
- TX509New = function: PX509; cdecl;
- TX509Free = procedure(x: PX509); cdecl;
- TX509NameOneline = function(a: PX509_NAME; buf: PChar; size: Integer):PChar; cdecl;
- TX509GetSubjectName = function(a: PX509):PX509_NAME; cdecl;
- TX509GetIssuerName = function(a: PX509):PX509_NAME; cdecl;
- TX509NameHash = function(x: PX509_NAME):Cardinal; cdecl;
- TX509Digest = function(data: PX509; _type: PEVP_MD; md: PChar; len: PInteger):Integer; cdecl;
- TX509print = function(b: PBIO; a: PX509): integer; cdecl;
- TX509SetVersion = function(x: PX509; version: integer): integer; cdecl;
- TX509SetPubkey = function(x: PX509; pkey: EVP_PKEY): integer; cdecl;
- TX509SetIssuerName = function(x: PX509; name: PX509_NAME): integer; cdecl;
- TX509NameAddEntryByTxt = function(name: PX509_NAME; field: PChar; _type: integer;
- bytes: PChar; len, loc, _set: integer): integer; cdecl;
- TX509Sign = function(x: PX509; pkey: EVP_PKEY; const md: PEVP_MD): integer; cdecl;
- TX509GmtimeAdj = function(s: PASN1_UTCTIME; adj: integer): PASN1_UTCTIME; cdecl;
- TX509SetNotBefore = function(x: PX509; tm: PASN1_UTCTIME): integer; cdecl;
- TX509SetNotAfter = function(x: PX509; tm: PASN1_UTCTIME): integer; cdecl;
- TX509GetSerialNumber = function(x: PX509): PASN1_INTEGER; cdecl;
- TEvpPkeyNew = function: EVP_PKEY; cdecl;
- TEvpPkeyFree = procedure(pk: EVP_PKEY); cdecl;
- TEvpPkeyAssign = function(pkey: EVP_PKEY; _type: integer; key: Prsa): integer; cdecl;
- TEvpGetDigestByName = function(Name: PChar): PEVP_MD; cdecl;
- TEVPcleanup = procedure; cdecl;
- TSSLeayversion = function(t: integer): PChar; cdecl;
- TErrErrorString = procedure(e: integer; buf: PChar; len: integer); cdecl;
- TErrGetError = function: integer; cdecl;
- TErrClearError = procedure; cdecl;
- TErrFreeStrings = procedure; cdecl;
- TErrRemoveState = procedure(pid: integer); cdecl;
- TOPENSSLaddallalgorithms = procedure; cdecl;
- TCRYPTOcleanupAllExData = procedure; cdecl;
- TRandScreen = procedure; cdecl;
- TBioNew = function(b: PBIO_METHOD): PBIO; cdecl;
- TBioFreeAll = procedure(b: PBIO); cdecl;
- TBioSMem = function: PBIO_METHOD; cdecl;
- TBioCtrlPending = function(b: PBIO): integer; cdecl;
- TBioRead = function(b: PBIO; Buf: PChar; Len: integer): integer; cdecl;
- TBioWrite = function(b: PBIO; Buf: PChar; Len: integer): integer; cdecl;
- Td2iPKCS12bio = function(b:PBIO; Pkcs12: SslPtr): SslPtr; cdecl;
- TPKCS12parse = function(p12: SslPtr; pass: PChar; var pkey, cert, ca: SslPtr): integer; cdecl;
- TPKCS12free = procedure(p12: SslPtr); cdecl;
- TRsaGenerateKey = function(bits, e: integer; callback: PFunction; cb_arg: SslPtr): PRSA; cdecl;
- TAsn1UtctimeNew = function: PASN1_UTCTIME; cdecl;
- TAsn1UtctimeFree = procedure(a: PASN1_UTCTIME); cdecl;
- TAsn1IntegerSet = function(a: PASN1_INTEGER; v: integer): integer; cdecl;
- Ti2dX509bio = function(b: PBIO; x: PX509): integer; cdecl;
- Ti2dPrivateKeyBio= function(b: PBIO; pkey: EVP_PKEY): integer; cdecl;
-
- // 3DES functions
- TDESsetoddparity = procedure(Key: des_cblock); cdecl;
- TDESsetkeychecked = function(key: des_cblock; schedule: des_key_schedule): Integer; cdecl;
- TDESecbencrypt = procedure(Input: des_cblock; output: des_cblock; ks: des_key_schedule; enc: Integer); cdecl;
- //thread lock functions
- TCRYPTOnumlocks = function: integer; cdecl;
- TCRYPTOSetLockingCallback = procedure(cb: Sslptr); cdecl;
-
-var
-// libssl.dll
- _SslGetError: TSslGetError = nil;
- _SslLibraryInit: TSslLibraryInit = nil;
- _SslLoadErrorStrings: TSslLoadErrorStrings = nil;
- _SslCtxSetCipherList: TSslCtxSetCipherList = nil;
- _SslCtxNew: TSslCtxNew = nil;
- _SslCtxFree: TSslCtxFree = nil;
- _SslSetFd: TSslSetFd = nil;
- _SslMethodV2: TSslMethodV2 = nil;
- _SslMethodV3: TSslMethodV3 = nil;
- _SslMethodTLSV1: TSslMethodTLSV1 = nil;
- _SslMethodV23: TSslMethodV23 = nil;
- _SslCtxUsePrivateKey: TSslCtxUsePrivateKey = nil;
- _SslCtxUsePrivateKeyASN1: TSslCtxUsePrivateKeyASN1 = nil;
- _SslCtxUsePrivateKeyFile: TSslCtxUsePrivateKeyFile = nil;
- _SslCtxUseCertificate: TSslCtxUseCertificate = nil;
- _SslCtxUseCertificateASN1: TSslCtxUseCertificateASN1 = nil;
- _SslCtxUseCertificateFile: TSslCtxUseCertificateFile = nil;
- _SslCtxUseCertificateChainFile: TSslCtxUseCertificateChainFile = nil;
- _SslCtxCheckPrivateKeyFile: TSslCtxCheckPrivateKeyFile = nil;
- _SslCtxSetDefaultPasswdCb: TSslCtxSetDefaultPasswdCb = nil;
- _SslCtxSetDefaultPasswdCbUserdata: TSslCtxSetDefaultPasswdCbUserdata = nil;
- _SslCtxLoadVerifyLocations: TSslCtxLoadVerifyLocations = nil;
- _SslNew: TSslNew = nil;
- _SslFree: TSslFree = nil;
- _SslAccept: TSslAccept = nil;
- _SslConnect: TSslConnect = nil;
- _SslShutdown: TSslShutdown = nil;
- _SslRead: TSslRead = nil;
- _SslPeek: TSslPeek = nil;
- _SslWrite: TSslWrite = nil;
- _SslPending: TSslPending = nil;
- _SslGetVersion: TSslGetVersion = nil;
- _SslGetPeerCertificate: TSslGetPeerCertificate = nil;
- _SslCtxSetVerify: TSslCtxSetVerify = nil;
- _SSLGetCurrentCipher: TSSLGetCurrentCipher = nil;
- _SSLCipherGetName: TSSLCipherGetName = nil;
- _SSLCipherGetBits: TSSLCipherGetBits = nil;
- _SSLGetVerifyResult: TSSLGetVerifyResult = nil;
-
-// libeay.dll
- _X509New: TX509New = nil;
- _X509Free: TX509Free = nil;
- _X509NameOneline: TX509NameOneline = nil;
- _X509GetSubjectName: TX509GetSubjectName = nil;
- _X509GetIssuerName: TX509GetIssuerName = nil;
- _X509NameHash: TX509NameHash = nil;
- _X509Digest: TX509Digest = nil;
- _X509print: TX509print = nil;
- _X509SetVersion: TX509SetVersion = nil;
- _X509SetPubkey: TX509SetPubkey = nil;
- _X509SetIssuerName: TX509SetIssuerName = nil;
- _X509NameAddEntryByTxt: TX509NameAddEntryByTxt = nil;
- _X509Sign: TX509Sign = nil;
- _X509GmtimeAdj: TX509GmtimeAdj = nil;
- _X509SetNotBefore: TX509SetNotBefore = nil;
- _X509SetNotAfter: TX509SetNotAfter = nil;
- _X509GetSerialNumber: TX509GetSerialNumber = nil;
- _EvpPkeyNew: TEvpPkeyNew = nil;
- _EvpPkeyFree: TEvpPkeyFree = nil;
- _EvpPkeyAssign: TEvpPkeyAssign = nil;
- _EvpGetDigestByName: TEvpGetDigestByName = nil;
- _EVPcleanup: TEVPcleanup = nil;
- _SSLeayversion: TSSLeayversion = nil;
- _ErrErrorString: TErrErrorString = nil;
- _ErrGetError: TErrGetError = nil;
- _ErrClearError: TErrClearError = nil;
- _ErrFreeStrings: TErrFreeStrings = nil;
- _ErrRemoveState: TErrRemoveState = nil;
- _OPENSSLaddallalgorithms: TOPENSSLaddallalgorithms = nil;
- _CRYPTOcleanupAllExData: TCRYPTOcleanupAllExData = nil;
- _RandScreen: TRandScreen = nil;
- _BioNew: TBioNew = nil;
- _BioFreeAll: TBioFreeAll = nil;
- _BioSMem: TBioSMem = nil;
- _BioCtrlPending: TBioCtrlPending = nil;
- _BioRead: TBioRead = nil;
- _BioWrite: TBioWrite = nil;
- _d2iPKCS12bio: Td2iPKCS12bio = nil;
- _PKCS12parse: TPKCS12parse = nil;
- _PKCS12free: TPKCS12free = nil;
- _RsaGenerateKey: TRsaGenerateKey = nil;
- _Asn1UtctimeNew: TAsn1UtctimeNew = nil;
- _Asn1UtctimeFree: TAsn1UtctimeFree = nil;
- _Asn1IntegerSet: TAsn1IntegerSet = nil;
- _i2dX509bio: Ti2dX509bio = nil;
- _i2dPrivateKeyBio: Ti2dPrivateKeyBio = nil;
-
- // 3DES functions
- _DESsetoddparity: TDESsetoddparity = nil;
- _DESsetkeychecked: TDESsetkeychecked = nil;
- _DESecbencrypt: TDESecbencrypt = nil;
- //thread lock functions
- _CRYPTOnumlocks: TCRYPTOnumlocks = nil;
- _CRYPTOSetLockingCallback: TCRYPTOSetLockingCallback = nil;
-
-var
- SSLloaded: boolean = false;
-
-// libssl.dll
-function SslGetError(s: PSSL; ret_code: Integer):Integer;
-begin
- if InitSSLInterface and Assigned(_SslGetError) then
- Result := _SslGetError(s, ret_code)
- else
- Result := SSL_ERROR_SSL;
-end;
-
-function SslLibraryInit:Integer;
-begin
- if InitSSLInterface and Assigned(_SslLibraryInit) then
- Result := _SslLibraryInit
- else
- Result := 1;
-end;
-
-procedure SslLoadErrorStrings;
-begin
- if InitSSLInterface and Assigned(_SslLoadErrorStrings) then
- _SslLoadErrorStrings;
-end;
-
-//function SslCtxSetCipherList(arg0: PSSL_CTX; str: PChar):Integer;
-function SslCtxSetCipherList(arg0: PSSL_CTX; var str: String):Integer;
-begin
- if InitSSLInterface and Assigned(_SslCtxSetCipherList) then
- Result := _SslCtxSetCipherList(arg0, PChar(str))
- else
- Result := 0;
-end;
-
-function SslCtxNew(meth: PSSL_METHOD):PSSL_CTX;
-begin
- if InitSSLInterface and Assigned(_SslCtxNew) then
- Result := _SslCtxNew(meth)
- else
- Result := nil;
-end;
-
-procedure SslCtxFree(arg0: PSSL_CTX);
-begin
- if InitSSLInterface and Assigned(_SslCtxFree) then
- _SslCtxFree(arg0);
-end;
-
-function SslSetFd(s: PSSL; fd: Integer):Integer;
-begin
- if InitSSLInterface and Assigned(_SslSetFd) then
- Result := _SslSetFd(s, fd)
- else
- Result := 0;
-end;
-
-function SslMethodV2:PSSL_METHOD;
-begin
- if InitSSLInterface and Assigned(_SslMethodV2) then
- Result := _SslMethodV2
- else
- Result := nil;
-end;
-
-function SslMethodV3:PSSL_METHOD;
-begin
- if InitSSLInterface and Assigned(_SslMethodV3) then
- Result := _SslMethodV3
- else
- Result := nil;
-end;
-
-function SslMethodTLSV1:PSSL_METHOD;
-begin
- if InitSSLInterface and Assigned(_SslMethodTLSV1) then
- Result := _SslMethodTLSV1
- else
- Result := nil;
-end;
-
-function SslMethodV23:PSSL_METHOD;
-begin
- if InitSSLInterface and Assigned(_SslMethodV23) then
- Result := _SslMethodV23
- else
- Result := nil;
-end;
-
-function SslCtxUsePrivateKey(ctx: PSSL_CTX; pkey: SslPtr):Integer;
-begin
- if InitSSLInterface and Assigned(_SslCtxUsePrivateKey) then
- Result := _SslCtxUsePrivateKey(ctx, pkey)
- else
- Result := 0;
-end;
-
-function SslCtxUsePrivateKeyASN1(pk: integer; ctx: PSSL_CTX; d: String; len: integer):Integer;
-begin
- if InitSSLInterface and Assigned(_SslCtxUsePrivateKeyASN1) then
- Result := _SslCtxUsePrivateKeyASN1(pk, ctx, Sslptr(d), len)
- else
- Result := 0;
-end;
-
-//function SslCtxUsePrivateKeyFile(ctx: PSSL_CTX; const _file: PChar; _type: Integer):Integer;
-function SslCtxUsePrivateKeyFile(ctx: PSSL_CTX; const _file: String; _type: Integer):Integer;
-begin
- if InitSSLInterface and Assigned(_SslCtxUsePrivateKeyFile) then
- Result := _SslCtxUsePrivateKeyFile(ctx, PChar(_file), _type)
- else
- Result := 0;
-end;
-
-function SslCtxUseCertificate(ctx: PSSL_CTX; x: SslPtr):Integer;
-begin
- if InitSSLInterface and Assigned(_SslCtxUseCertificate) then
- Result := _SslCtxUseCertificate(ctx, x)
- else
- Result := 0;
-end;
-
-function SslCtxUseCertificateASN1(ctx: PSSL_CTX; len: integer; d: String):Integer;
-begin
- if InitSSLInterface and Assigned(_SslCtxUseCertificateASN1) then
- Result := _SslCtxUseCertificateASN1(ctx, len, SslPtr(d))
- else
- Result := 0;
-end;
-
-function SslCtxUseCertificateFile(ctx: PSSL_CTX; const _file: String; _type: Integer):Integer;
-begin
- if InitSSLInterface and Assigned(_SslCtxUseCertificateFile) then
- Result := _SslCtxUseCertificateFile(ctx, PChar(_file), _type)
- else
- Result := 0;
-end;
-
-//function SslCtxUseCertificateChainFile(ctx: PSSL_CTX; const _file: PChar):Integer;
-function SslCtxUseCertificateChainFile(ctx: PSSL_CTX; const _file: String):Integer;
-begin
- if InitSSLInterface and Assigned(_SslCtxUseCertificateChainFile) then
- Result := _SslCtxUseCertificateChainFile(ctx, PChar(_file))
- else
- Result := 0;
-end;
-
-function SslCtxCheckPrivateKeyFile(ctx: PSSL_CTX):Integer;
-begin
- if InitSSLInterface and Assigned(_SslCtxCheckPrivateKeyFile) then
- Result := _SslCtxCheckPrivateKeyFile(ctx)
- else
- Result := 0;
-end;
-
-procedure SslCtxSetDefaultPasswdCb(ctx: PSSL_CTX; cb: PPasswdCb);
-begin
- if InitSSLInterface and Assigned(_SslCtxSetDefaultPasswdCb) then
- _SslCtxSetDefaultPasswdCb(ctx, cb);
-end;
-
-procedure SslCtxSetDefaultPasswdCbUserdata(ctx: PSSL_CTX; u: SslPtr);
-begin
- if InitSSLInterface and Assigned(_SslCtxSetDefaultPasswdCbUserdata) then
- _SslCtxSetDefaultPasswdCbUserdata(ctx, u);
-end;
-
-//function SslCtxLoadVerifyLocations(ctx: PSSL_CTX; const CAfile: PChar; const CApath: PChar):Integer;
-function SslCtxLoadVerifyLocations(ctx: PSSL_CTX; const CAfile: String; const CApath: String):Integer;
-begin
- if InitSSLInterface and Assigned(_SslCtxLoadVerifyLocations) then
- Result := _SslCtxLoadVerifyLocations(ctx, SslPtr(CAfile), SslPtr(CApath))
- else
- Result := 0;
-end;
-
-function SslNew(ctx: PSSL_CTX):PSSL;
-begin
- if InitSSLInterface and Assigned(_SslNew) then
- Result := _SslNew(ctx)
- else
- Result := nil;
-end;
-
-procedure SslFree(ssl: PSSL);
-begin
- if InitSSLInterface and Assigned(_SslFree) then
- _SslFree(ssl);
-end;
-
-function SslAccept(ssl: PSSL):Integer;
-begin
- if InitSSLInterface and Assigned(_SslAccept) then
- Result := _SslAccept(ssl)
- else
- Result := -1;
-end;
-
-function SslConnect(ssl: PSSL):Integer;
-begin
- if InitSSLInterface and Assigned(_SslConnect) then
- Result := _SslConnect(ssl)
- else
- Result := -1;
-end;
-
-function SslShutdown(ssl: PSSL):Integer;
-begin
- if InitSSLInterface and Assigned(_SslShutdown) then
- Result := _SslShutdown(ssl)
- else
- Result := -1;
-end;
-
-//function SslRead(ssl: PSSL; buf: PChar; num: Integer):Integer;
-function SslRead(ssl: PSSL; buf: SslPtr; num: Integer):Integer;
-begin
- if InitSSLInterface and Assigned(_SslRead) then
- Result := _SslRead(ssl, PChar(buf), num)
- else
- Result := -1;
-end;
-
-//function SslPeek(ssl: PSSL; buf: PChar; num: Integer):Integer;
-function SslPeek(ssl: PSSL; buf: SslPtr; num: Integer):Integer;
-begin
- if InitSSLInterface and Assigned(_SslPeek) then
- Result := _SslPeek(ssl, PChar(buf), num)
- else
- Result := -1;
-end;
-
-//function SslWrite(ssl: PSSL; const buf: PChar; num: Integer):Integer;
-function SslWrite(ssl: PSSL; buf: SslPtr; num: Integer):Integer;
-begin
- if InitSSLInterface and Assigned(_SslWrite) then
- Result := _SslWrite(ssl, PChar(buf), num)
- else
- Result := -1;
-end;
-
-function SslPending(ssl: PSSL):Integer;
-begin
- if InitSSLInterface and Assigned(_SslPending) then
- Result := _SslPending(ssl)
- else
- Result := 0;
-end;
-
-//function SslGetVersion(ssl: PSSL):PChar;
-function SslGetVersion(ssl: PSSL):String;
-begin
- if InitSSLInterface and Assigned(_SslGetVersion) then
- Result := _SslGetVersion(ssl)
- else
- Result := '';
-end;
-
-function SslGetPeerCertificate(ssl: PSSL):PX509;
-begin
- if InitSSLInterface and Assigned(_SslGetPeerCertificate) then
- Result := _SslGetPeerCertificate(ssl)
- else
- Result := nil;
-end;
-
-//procedure SslCtxSetVerify(ctx: PSSL_CTX; mode: Integer; arg2: SslPtr);
-procedure SslCtxSetVerify(ctx: PSSL_CTX; mode: Integer; arg2: PFunction);
-begin
- if InitSSLInterface and Assigned(_SslCtxSetVerify) then
- _SslCtxSetVerify(ctx, mode, @arg2);
-end;
-
-function SSLGetCurrentCipher(s: PSSL):SslPtr;
-begin
- if InitSSLInterface and Assigned(_SSLGetCurrentCipher) then
-{$IFDEF CIL}
-{$ELSE}
- Result := _SSLGetCurrentCipher(s)
-{$ENDIF}
- else
- Result := nil;
-end;
-
-//function SSLCipherGetName(c: SslPtr):PChar;
-function SSLCipherGetName(c: SslPtr):String;
-begin
- if InitSSLInterface and Assigned(_SSLCipherGetName) then
- Result := _SSLCipherGetName(c)
- else
- Result := '';
-end;
-
-//function SSLCipherGetBits(c: SslPtr; alg_bits: PInteger):Integer;
-function SSLCipherGetBits(c: SslPtr; var alg_bits: Integer):Integer;
-begin
- if InitSSLInterface and Assigned(_SSLCipherGetBits) then
- Result := _SSLCipherGetBits(c, @alg_bits)
- else
- Result := 0;
-end;
-
-function SSLGetVerifyResult(ssl: PSSL):Integer;
-begin
- if InitSSLInterface and Assigned(_SSLGetVerifyResult) then
- Result := _SSLGetVerifyResult(ssl)
- else
- Result := X509_V_ERR_APPLICATION_VERIFICATION;
-end;
-
-// libeay.dll
-function X509New: PX509;
-begin
- if InitSSLInterface and Assigned(_X509New) then
- Result := _X509New
- else
- Result := nil;
-end;
-
-procedure X509Free(x: PX509);
-begin
- if InitSSLInterface and Assigned(_X509Free) then
- _X509Free(x);
-end;
-
-//function SslX509NameOneline(a: PX509_NAME; buf: PChar; size: Integer):PChar;
-function X509NameOneline(a: PX509_NAME; var buf: String; size: Integer):String;
-begin
- if InitSSLInterface and Assigned(_X509NameOneline) then
- Result := _X509NameOneline(a, PChar(buf),size)
- else
- Result := '';
-end;
-
-function X509GetSubjectName(a: PX509):PX509_NAME;
-begin
- if InitSSLInterface and Assigned(_X509GetSubjectName) then
- Result := _X509GetSubjectName(a)
- else
- Result := nil;
-end;
-
-function X509GetIssuerName(a: PX509):PX509_NAME;
-begin
- if InitSSLInterface and Assigned(_X509GetIssuerName) then
- Result := _X509GetIssuerName(a)
- else
- Result := nil;
-end;
-
-function X509NameHash(x: PX509_NAME):Cardinal;
-begin
- if InitSSLInterface and Assigned(_X509NameHash) then
- Result := _X509NameHash(x)
- else
- Result := 0;
-end;
-
-//function SslX509Digest(data: PX509; _type: PEVP_MD; md: PChar; len: PInteger):Integer;
-function X509Digest(data: PX509; _type: PEVP_MD; md: String; var len: Integer):Integer;
-begin
- if InitSSLInterface and Assigned(_X509Digest) then
- Result := _X509Digest(data, _type, PChar(md), @len)
- else
- Result := 0;
-end;
-
-function EvpPkeyNew: EVP_PKEY;
-begin
- if InitSSLInterface and Assigned(_EvpPkeyNew) then
- Result := _EvpPkeyNew
- else
- Result := nil;
-end;
-
-procedure EvpPkeyFree(pk: EVP_PKEY);
-begin
- if InitSSLInterface and Assigned(_EvpPkeyFree) then
- _EvpPkeyFree(pk);
-end;
-
-function SSLeayversion(t: integer): string;
-begin
- if InitSSLInterface and Assigned(_SSLeayversion) then
- Result := PChar(_SSLeayversion(t))
- else
- Result := '';
-end;
-
-procedure ErrErrorString(e: integer; var buf: string; len: integer);
-begin
- if InitSSLInterface and Assigned(_ErrErrorString) then
- _ErrErrorString(e, Pointer(buf), len);
- buf := PChar(Buf);
-end;
-
-function ErrGetError: integer;
-begin
- if InitSSLInterface and Assigned(_ErrGetError) then
- Result := _ErrGetError
- else
- Result := SSL_ERROR_SSL;
-end;
-
-procedure ErrClearError;
-begin
- if InitSSLInterface and Assigned(_ErrClearError) then
- _ErrClearError;
-end;
-
-procedure ErrFreeStrings;
-begin
- if InitSSLInterface and Assigned(_ErrFreeStrings) then
- _ErrFreeStrings;
-end;
-
-procedure ErrRemoveState(pid: integer);
-begin
- if InitSSLInterface and Assigned(_ErrRemoveState) then
- _ErrRemoveState(pid);
-end;
-
-procedure OPENSSLaddallalgorithms;
-begin
- if InitSSLInterface and Assigned(_OPENSSLaddallalgorithms) then
- _OPENSSLaddallalgorithms;
-end;
-
-procedure EVPcleanup;
-begin
- if InitSSLInterface and Assigned(_EVPcleanup) then
- _EVPcleanup;
-end;
-
-procedure CRYPTOcleanupAllExData;
-begin
- if InitSSLInterface and Assigned(_CRYPTOcleanupAllExData) then
- _CRYPTOcleanupAllExData;
-end;
-
-procedure RandScreen;
-begin
- if InitSSLInterface and Assigned(_RandScreen) then
- _RandScreen;
-end;
-
-function BioNew(b: PBIO_METHOD): PBIO;
-begin
- if InitSSLInterface and Assigned(_BioNew) then
- Result := _BioNew(b)
- else
- Result := nil;
-end;
-
-procedure BioFreeAll(b: PBIO);
-begin
- if InitSSLInterface and Assigned(_BioFreeAll) then
- _BioFreeAll(b);
-end;
-
-function BioSMem: PBIO_METHOD;
-begin
- if InitSSLInterface and Assigned(_BioSMem) then
- Result := _BioSMem
- else
- Result := nil;
-end;
-
-function BioCtrlPending(b: PBIO): integer;
-begin
- if InitSSLInterface and Assigned(_BioCtrlPending) then
- Result := _BioCtrlPending(b)
- else
- Result := 0;
-end;
-
-//function BioRead(b: PBIO; Buf: PChar; Len: integer): integer;
-function BioRead(b: PBIO; var Buf: String; Len: integer): integer;
-begin
- if InitSSLInterface and Assigned(_BioRead) then
- Result := _BioRead(b, PChar(Buf), Len)
- else
- Result := -2;
-end;
-
-//function BioWrite(b: PBIO; Buf: PChar; Len: integer): integer;
-function BioWrite(b: PBIO; Buf: String; Len: integer): integer;
-begin
- if InitSSLInterface and Assigned(_BioWrite) then
- Result := _BioWrite(b, PChar(Buf), Len)
- else
- Result := -2;
-end;
-
-function X509print(b: PBIO; a: PX509): integer;
-begin
- if InitSSLInterface and Assigned(_X509print) then
- Result := _X509print(b, a)
- else
- Result := 0;
-end;
-
-function d2iPKCS12bio(b:PBIO; Pkcs12: SslPtr): SslPtr;
-begin
- if InitSSLInterface and Assigned(_d2iPKCS12bio) then
- Result := _d2iPKCS12bio(b, Pkcs12)
- else
- Result := nil;
-end;
-
-function PKCS12parse(p12: SslPtr; pass: string; var pkey, cert, ca: SslPtr): integer;
-begin
- if InitSSLInterface and Assigned(_PKCS12parse) then
- Result := _PKCS12parse(p12, SslPtr(pass), pkey, cert, ca)
- else
- Result := 0;
-end;
-
-procedure PKCS12free(p12: SslPtr);
-begin
- if InitSSLInterface and Assigned(_PKCS12free) then
- _PKCS12free(p12);
-end;
-
-function RsaGenerateKey(bits, e: integer; callback: PFunction; cb_arg: SslPtr): PRSA;
-begin
- if InitSSLInterface and Assigned(_RsaGenerateKey) then
- Result := _RsaGenerateKey(bits, e, callback, cb_arg)
- else
- Result := nil;
-end;
-
-function EvpPkeyAssign(pkey: EVP_PKEY; _type: integer; key: Prsa): integer;
-begin
- if InitSSLInterface and Assigned(_EvpPkeyAssign) then
- Result := _EvpPkeyAssign(pkey, _type, key)
- else
- Result := 0;
-end;
-
-function X509SetVersion(x: PX509; version: integer): integer;
-begin
- if InitSSLInterface and Assigned(_X509SetVersion) then
- Result := _X509SetVersion(x, version)
- else
- Result := 0;
-end;
-
-function X509SetPubkey(x: PX509; pkey: EVP_PKEY): integer;
-begin
- if InitSSLInterface and Assigned(_X509SetPubkey) then
- Result := _X509SetPubkey(x, pkey)
- else
- Result := 0;
-end;
-
-function X509SetIssuerName(x: PX509; name: PX509_NAME): integer;
-begin
- if InitSSLInterface and Assigned(_X509SetIssuerName) then
- Result := _X509SetIssuerName(x, name)
- else
- Result := 0;
-end;
-
-function X509NameAddEntryByTxt(name: PX509_NAME; field: string; _type: integer;
- bytes: string; len, loc, _set: integer): integer;
-begin
- if InitSSLInterface and Assigned(_X509NameAddEntryByTxt) then
- Result := _X509NameAddEntryByTxt(name, PChar(field), _type, PChar(Bytes), len, loc, _set)
- else
- Result := 0;
-end;
-
-function X509Sign(x: PX509; pkey: EVP_PKEY; const md: PEVP_MD): integer;
-begin
- if InitSSLInterface and Assigned(_X509Sign) then
- Result := _X509Sign(x, pkey, md)
- else
- Result := 0;
-end;
-
-function Asn1UtctimeNew: PASN1_UTCTIME;
-begin
- if InitSSLInterface and Assigned(_Asn1UtctimeNew) then
- Result := _Asn1UtctimeNew
- else
- Result := nil;
-end;
-
-procedure Asn1UtctimeFree(a: PASN1_UTCTIME);
-begin
- if InitSSLInterface and Assigned(_Asn1UtctimeFree) then
- _Asn1UtctimeFree(a);
-end;
-
-function X509GmtimeAdj(s: PASN1_UTCTIME; adj: integer): PASN1_UTCTIME;
-begin
- if InitSSLInterface and Assigned(_X509GmtimeAdj) then
- Result := _X509GmtimeAdj(s, adj)
- else
- Result := nil;
-end;
-
-function X509SetNotBefore(x: PX509; tm: PASN1_UTCTIME): integer;
-begin
- if InitSSLInterface and Assigned(_X509SetNotBefore) then
- Result := _X509SetNotBefore(x, tm)
- else
- Result := 0;
-end;
-
-function X509SetNotAfter(x: PX509; tm: PASN1_UTCTIME): integer;
-begin
- if InitSSLInterface and Assigned(_X509SetNotAfter) then
- Result := _X509SetNotAfter(x, tm)
- else
- Result := 0;
-end;
-
-function i2dX509bio(b: PBIO; x: PX509): integer;
-begin
- if InitSSLInterface and Assigned(_i2dX509bio) then
- Result := _i2dX509bio(b, x)
- else
- Result := 0;
-end;
-
-function i2dPrivateKeyBio(b: PBIO; pkey: EVP_PKEY): integer;
-begin
- if InitSSLInterface and Assigned(_i2dPrivateKeyBio) then
- Result := _i2dPrivateKeyBio(b, pkey)
- else
- Result := 0;
-end;
-
-function EvpGetDigestByName(Name: String): PEVP_MD;
-begin
- if InitSSLInterface and Assigned(_EvpGetDigestByName) then
- Result := _EvpGetDigestByName(PChar(Name))
- else
- Result := nil;
-end;
-
-function Asn1IntegerSet(a: PASN1_INTEGER; v: integer): integer;
-begin
- if InitSSLInterface and Assigned(_Asn1IntegerSet) then
- Result := _Asn1IntegerSet(a, v)
- else
- Result := 0;
-end;
-
-function X509GetSerialNumber(x: PX509): PASN1_INTEGER;
-begin
- if InitSSLInterface and Assigned(_X509GetSerialNumber) then
- Result := _X509GetSerialNumber(x)
- else
- Result := nil;
-end;
-
-// 3DES functions
-procedure DESsetoddparity(Key: des_cblock);
-begin
- if InitSSLInterface and Assigned(_DESsetoddparity) then
- _DESsetoddparity(Key);
-end;
-
-function DESsetkeychecked(key: des_cblock; schedule: des_key_schedule): Integer;
-begin
- if InitSSLInterface and Assigned(_DESsetkeychecked) then
- Result := _DESsetkeychecked(key, schedule)
- else
- Result := -1;
-end;
-
-procedure DESecbencrypt(Input: des_cblock; output: des_cblock; ks: des_key_schedule; enc: Integer);
-begin
- if InitSSLInterface and Assigned(_DESecbencrypt) then
- _DESecbencrypt(Input, output, ks, enc);
-end;
-
-function LoadLib(const Value: String): HModule;
-begin
- Result := LoadLibrary(Value);
-end;
-
-function GetProcAddr(module: HModule; const ProcName: string): SslPtr;
-begin
- Result := GetProcAddress(module, PChar(ProcName));
-end;
-
-function InitSSLInterface: Boolean;
-{var
- s: string;
- x: integer;}
-begin
- if not IsSSLloaded then
- begin
- SSLLibHandle := LoadLib(DLLSSLName);
- SSLUtilHandle := LoadLib(DLLUtilName);
- {$IFNDEF UNIX}
- if (SSLLibHandle = 0) then
- SSLLibHandle := LoadLib(DLLSSLName2);
- {$ENDIF}
- if (SSLLibHandle <> 0) and (SSLUtilHandle <> 0) then
- begin
- _SslGetError := GetProcAddr(SSLLibHandle, 'SSL_get_error');
- _SslLibraryInit := GetProcAddr(SSLLibHandle, 'SSL_library_init');
- _SslLoadErrorStrings := GetProcAddr(SSLLibHandle, 'SSL_load_error_strings');
- _SslCtxSetCipherList := GetProcAddr(SSLLibHandle, 'SSL_CTX_set_cipher_list');
- _SslCtxNew := GetProcAddr(SSLLibHandle, 'SSL_CTX_new');
- _SslCtxFree := GetProcAddr(SSLLibHandle, 'SSL_CTX_free');
- _SslSetFd := GetProcAddr(SSLLibHandle, 'SSL_set_fd');
- _SslMethodV2 := GetProcAddr(SSLLibHandle, 'SSLv2_method');
- _SslMethodV3 := GetProcAddr(SSLLibHandle, 'SSLv3_method');
- _SslMethodTLSV1 := GetProcAddr(SSLLibHandle, 'TLSv1_method');
- _SslMethodV23 := GetProcAddr(SSLLibHandle, 'SSLv23_method');
- _SslCtxUsePrivateKey := GetProcAddr(SSLLibHandle, 'SSL_CTX_use_PrivateKey');
- _SslCtxUsePrivateKeyASN1 := GetProcAddr(SSLLibHandle, 'SSL_CTX_use_PrivateKey_ASN1');
- //use SSL_CTX_use_RSAPrivateKey_file instead SSL_CTX_use_PrivateKey_file,
- //because SSL_CTX_use_PrivateKey_file not support DER format. :-O
- _SslCtxUsePrivateKeyFile := GetProcAddr(SSLLibHandle, 'SSL_CTX_use_RSAPrivateKey_file');
- _SslCtxUseCertificate := GetProcAddr(SSLLibHandle, 'SSL_CTX_use_certificate');
- _SslCtxUseCertificateASN1 := GetProcAddr(SSLLibHandle, 'SSL_CTX_use_certificate_ASN1');
- _SslCtxUseCertificateFile := GetProcAddr(SSLLibHandle, 'SSL_CTX_use_certificate_file');
- _SslCtxUseCertificateChainFile := GetProcAddr(SSLLibHandle, 'SSL_CTX_use_certificate_chain_file');
- _SslCtxCheckPrivateKeyFile := GetProcAddr(SSLLibHandle, 'SSL_CTX_check_private_key');
- _SslCtxSetDefaultPasswdCb := GetProcAddr(SSLLibHandle, 'SSL_CTX_set_default_passwd_cb');
- _SslCtxSetDefaultPasswdCbUserdata := GetProcAddr(SSLLibHandle, 'SSL_CTX_set_default_passwd_cb_userdata');
- _SslCtxLoadVerifyLocations := GetProcAddr(SSLLibHandle, 'SSL_CTX_load_verify_locations');
- _SslNew := GetProcAddr(SSLLibHandle, 'SSL_new');
- _SslFree := GetProcAddr(SSLLibHandle, 'SSL_free');
- _SslAccept := GetProcAddr(SSLLibHandle, 'SSL_accept');
- _SslConnect := GetProcAddr(SSLLibHandle, 'SSL_connect');
- _SslShutdown := GetProcAddr(SSLLibHandle, 'SSL_shutdown');
- _SslRead := GetProcAddr(SSLLibHandle, 'SSL_read');
- _SslPeek := GetProcAddr(SSLLibHandle, 'SSL_peek');
- _SslWrite := GetProcAddr(SSLLibHandle, 'SSL_write');
- _SslPending := GetProcAddr(SSLLibHandle, 'SSL_pending');
- _SslGetPeerCertificate := GetProcAddr(SSLLibHandle, 'SSL_get_peer_certificate');
- _SslGetVersion := GetProcAddr(SSLLibHandle, 'SSL_get_version');
- _SslCtxSetVerify := GetProcAddr(SSLLibHandle, 'SSL_CTX_set_verify');
- _SslGetCurrentCipher := GetProcAddr(SSLLibHandle, 'SSL_get_current_cipher');
- _SslCipherGetName := GetProcAddr(SSLLibHandle, 'SSL_CIPHER_get_name');
- _SslCipherGetBits := GetProcAddr(SSLLibHandle, 'SSL_CIPHER_get_bits');
- _SslGetVerifyResult := GetProcAddr(SSLLibHandle, 'SSL_get_verify_result');
-
- _X509New := GetProcAddr(SSLUtilHandle, 'X509_new');
- _X509Free := GetProcAddr(SSLUtilHandle, 'X509_free');
- _X509NameOneline := GetProcAddr(SSLUtilHandle, 'X509_NAME_oneline');
- _X509GetSubjectName := GetProcAddr(SSLUtilHandle, 'X509_get_subject_name');
- _X509GetIssuerName := GetProcAddr(SSLUtilHandle, 'X509_get_issuer_name');
- _X509NameHash := GetProcAddr(SSLUtilHandle, 'X509_NAME_hash');
- _X509Digest := GetProcAddr(SSLUtilHandle, 'X509_digest');
- _X509print := GetProcAddr(SSLUtilHandle, 'X509_print');
- _X509SetVersion := GetProcAddr(SSLUtilHandle, 'X509_set_version');
- _X509SetPubkey := GetProcAddr(SSLUtilHandle, 'X509_set_pubkey');
- _X509SetIssuerName := GetProcAddr(SSLUtilHandle, 'X509_set_issuer_name');
- _X509NameAddEntryByTxt := GetProcAddr(SSLUtilHandle, 'X509_NAME_add_entry_by_txt');
- _X509Sign := GetProcAddr(SSLUtilHandle, 'X509_sign');
- _X509GmtimeAdj := GetProcAddr(SSLUtilHandle, 'X509_gmtime_adj');
- _X509SetNotBefore := GetProcAddr(SSLUtilHandle, 'X509_set_notBefore');
- _X509SetNotAfter := GetProcAddr(SSLUtilHandle, 'X509_set_notAfter');
- _X509GetSerialNumber := GetProcAddr(SSLUtilHandle, 'X509_get_serialNumber');
- _EvpPkeyNew := GetProcAddr(SSLUtilHandle, 'EVP_PKEY_new');
- _EvpPkeyFree := GetProcAddr(SSLUtilHandle, 'EVP_PKEY_free');
- _EvpPkeyAssign := GetProcAddr(SSLUtilHandle, 'EVP_PKEY_assign');
- _EVPCleanup := GetProcAddr(SSLUtilHandle, 'EVP_cleanup');
- _EvpGetDigestByName := GetProcAddr(SSLUtilHandle, 'EVP_get_digestbyname');
- _SSLeayversion := GetProcAddr(SSLUtilHandle, 'SSLeay_version');
- _ErrErrorString := GetProcAddr(SSLUtilHandle, 'ERR_error_string_n');
- _ErrGetError := GetProcAddr(SSLUtilHandle, 'ERR_get_error');
- _ErrClearError := GetProcAddr(SSLUtilHandle, 'ERR_clear_error');
- _ErrFreeStrings := GetProcAddr(SSLUtilHandle, 'ERR_free_strings');
- _ErrRemoveState := GetProcAddr(SSLUtilHandle, 'ERR_remove_state');
- _OPENSSLaddallalgorithms := GetProcAddr(SSLUtilHandle, 'OPENSSL_add_all_algorithms_noconf');
- _CRYPTOcleanupAllExData := GetProcAddr(SSLUtilHandle, 'CRYPTO_cleanup_all_ex_data');
- _RandScreen := GetProcAddr(SSLUtilHandle, 'RAND_screen');
- _BioNew := GetProcAddr(SSLUtilHandle, 'BIO_new');
- _BioFreeAll := GetProcAddr(SSLUtilHandle, 'BIO_free_all');
- _BioSMem := GetProcAddr(SSLUtilHandle, 'BIO_s_mem');
- _BioCtrlPending := GetProcAddr(SSLUtilHandle, 'BIO_ctrl_pending');
- _BioRead := GetProcAddr(SSLUtilHandle, 'BIO_read');
- _BioWrite := GetProcAddr(SSLUtilHandle, 'BIO_write');
- _d2iPKCS12bio := GetProcAddr(SSLUtilHandle, 'd2i_PKCS12_bio');
- _PKCS12parse := GetProcAddr(SSLUtilHandle, 'PKCS12_parse');
- _PKCS12free := GetProcAddr(SSLUtilHandle, 'PKCS12_free');
- _RsaGenerateKey := GetProcAddr(SSLUtilHandle, 'RSA_generate_key');
- _Asn1UtctimeNew := GetProcAddr(SSLUtilHandle, 'ASN1_UTCTIME_new');
- _Asn1UtctimeFree := GetProcAddr(SSLUtilHandle, 'ASN1_UTCTIME_free');
- _Asn1IntegerSet := GetProcAddr(SSLUtilHandle, 'ASN1_INTEGER_set');
- _i2dX509bio := GetProcAddr(SSLUtilHandle, 'i2d_X509_bio');
- _i2dPrivateKeyBio := GetProcAddr(SSLUtilHandle, 'i2d_PrivateKey_bio');
-
- // 3DES functions
- _DESsetoddparity := GetProcAddr(SSLUtilHandle, 'DES_set_odd_parity');
- _DESsetkeychecked := GetProcAddr(SSLUtilHandle, 'DES_set_key_checked');
- _DESecbencrypt := GetProcAddr(SSLUtilHandle, 'DES_ecb_encrypt');
- //
- _CRYPTOnumlocks := GetProcAddr(SSLUtilHandle, 'CRYPTO_num_locks');
- _CRYPTOsetlockingcallback := GetProcAddr(SSLUtilHandle, 'CRYPTO_set_locking_callback');
-
-{ SetLength(s, 1024);
- x := GetModuleFilename(SSLLibHandle,PChar(s),Length(s));
- SetLength(s, x);
- SSLLibFile := s;
- SetLength(s, 1024);
- x := GetModuleFilename(SSLUtilHandle,PChar(s),Length(s));
- SetLength(s, x);
- SSLUtilFile := s;}
- //init library
- if assigned(_SslLibraryInit) then
- _SslLibraryInit;
- if assigned(_SslLoadErrorStrings) then
- _SslLoadErrorStrings;
- if assigned(_OPENSSLaddallalgorithms) then
- _OPENSSLaddallalgorithms;
- if assigned(_RandScreen) then
- _RandScreen;
-{$WARNING investigate if it REALLY needs to be done}
-{ if assigned(_CRYPTOnumlocks) and assigned(_CRYPTOsetlockingcallback) then
- InitLocks;}
-
- Result := True;
- SSLloaded := True;
- end
- else
- begin
- //load failed!
- if SSLLibHandle <> 0 then
- begin
- FreeLibrary(SSLLibHandle);
- SSLLibHandle := 0;
- end;
- if SSLUtilHandle <> 0 then
- begin
- FreeLibrary(SSLUtilHandle);
- SSLLibHandle := 0;
- end;
- Result := False;
- end;
- end
- else
- //loaded before...
- Result := true;
-end;
-
-function DestroySSLInterface: Boolean;
-begin
- if IsSSLLoaded then
- begin
-{ //deinit library
- if assigned(_CRYPTOnumlocks) and assigned(_CRYPTOsetlockingcallback) then
- FreeLocks;}
- EVPCleanup;
- CRYPTOcleanupAllExData;
- ErrRemoveState(0);
- end;
- SSLloaded := false;
- if SSLLibHandle <> 0 then
- begin
- FreeLibrary(SSLLibHandle);
- SSLLibHandle := 0;
- end;
- if SSLUtilHandle <> 0 then
- begin
- FreeLibrary(SSLUtilHandle);
- SSLLibHandle := 0;
- end;
-
- _SslGetError := nil;
- _SslLibraryInit := nil;
- _SslLoadErrorStrings := nil;
- _SslCtxSetCipherList := nil;
- _SslCtxNew := nil;
- _SslCtxFree := nil;
- _SslSetFd := nil;
- _SslMethodV2 := nil;
- _SslMethodV3 := nil;
- _SslMethodTLSV1 := nil;
- _SslMethodV23 := nil;
- _SslCtxUsePrivateKey := nil;
- _SslCtxUsePrivateKeyASN1 := nil;
- _SslCtxUsePrivateKeyFile := nil;
- _SslCtxUseCertificate := nil;
- _SslCtxUseCertificateASN1 := nil;
- _SslCtxUseCertificateFile := nil;
- _SslCtxUseCertificateChainFile := nil;
- _SslCtxCheckPrivateKeyFile := nil;
- _SslCtxSetDefaultPasswdCb := nil;
- _SslCtxSetDefaultPasswdCbUserdata := nil;
- _SslCtxLoadVerifyLocations := nil;
- _SslNew := nil;
- _SslFree := nil;
- _SslAccept := nil;
- _SslConnect := nil;
- _SslShutdown := nil;
- _SslRead := nil;
- _SslPeek := nil;
- _SslWrite := nil;
- _SslPending := nil;
- _SslGetPeerCertificate := nil;
- _SslGetVersion := nil;
- _SslCtxSetVerify := nil;
- _SslGetCurrentCipher := nil;
- _SslCipherGetName := nil;
- _SslCipherGetBits := nil;
- _SslGetVerifyResult := nil;
-
- _X509New := nil;
- _X509Free := nil;
- _X509NameOneline := nil;
- _X509GetSubjectName := nil;
- _X509GetIssuerName := nil;
- _X509NameHash := nil;
- _X509Digest := nil;
- _X509print := nil;
- _X509SetVersion := nil;
- _X509SetPubkey := nil;
- _X509SetIssuerName := nil;
- _X509NameAddEntryByTxt := nil;
- _X509Sign := nil;
- _X509GmtimeAdj := nil;
- _X509SetNotBefore := nil;
- _X509SetNotAfter := nil;
- _X509GetSerialNumber := nil;
- _EvpPkeyNew := nil;
- _EvpPkeyFree := nil;
- _EvpPkeyAssign := nil;
- _EVPCleanup := nil;
- _EvpGetDigestByName := nil;
- _SSLeayversion := nil;
- _ErrErrorString := nil;
- _ErrGetError := nil;
- _ErrClearError := nil;
- _ErrFreeStrings := nil;
- _ErrRemoveState := nil;
- _OPENSSLaddallalgorithms := nil;
- _CRYPTOcleanupAllExData := nil;
- _RandScreen := nil;
- _BioNew := nil;
- _BioFreeAll := nil;
- _BioSMem := nil;
- _BioCtrlPending := nil;
- _BioRead := nil;
- _BioWrite := nil;
- _d2iPKCS12bio := nil;
- _PKCS12parse := nil;
- _PKCS12free := nil;
- _RsaGenerateKey := nil;
- _Asn1UtctimeNew := nil;
- _Asn1UtctimeFree := nil;
- _Asn1IntegerSet := nil;
- _i2dX509bio := nil;
- _i2dPrivateKeyBio := nil;
-
- // 3DES functions
- _DESsetoddparity := nil;
- _DESsetkeychecked := nil;
- _DESecbencrypt := nil;
- //
- _CRYPTOnumlocks := nil;
- _CRYPTOsetlockingcallback := nil;
- Result := True;
-end;
-
-function IsSSLloaded: Boolean;
-begin
- Result := SSLLoaded;
-end;
-
-finalization
- DestroySSLInterface;
-
-end.