' + IcsCRLF +
'' + IcsCRLF;
LogEvent('Challenge web response: ' + RespCode);
end;
begin
// ignore favicon requests completely
if Path = '/favicon.ico' then begin
RespCode := '404 Not Found';
Title := RespCode;
Msg := 'Error: File Not Found';
BuildBody;
Exit;
end;
SWebSrv := (Sender as TSimpleClientSocket); { V9.5 }
LogEvent(TimeToStr(Now) + ': Challenge web request, Host: ' + Host + ', Path: ' + Path + ', Params: ' + Params); { V9.5 added time }
LogEvent('Request Host: ' + SWebSrv.RequestHost + ', Request HostName: ' + SWebSrv.RequestHostName); { V9.5 !! TEMP }
// FullURL := 'http://' + Host + Path;
RespData := '';
/// check if URL is for .well-known and matches a pending challenge
if (Pos ('/.well-known/', Path) = 1) and (Length(FChallengeItems) > 0) then begin
WebSrvHttp(Self, IcsLowerCase(Host), Path, RespData); { V8.64 }
end;
if (RespData = '') then begin
RespCode := '404 Not Found';
Title := RespCode;
Msg := 'Error: File Not Found';
BuildBody;
end
else begin
// found a page o return
LogEvent('Challenge web server response sent for: ' + Host);
FChkChallgTrg := IcsGetTrgSecs64 (10); { V8.63 next check 10 secs }
RespCode := '200 OK';
Body := RespData;
end;
{ web page is sent by event handler }
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{ event called by web server when http-01 challenge requested }
procedure TSslX509Certs.WebSrvHttp(Sender: TObject; const Host, Path: string; var RespData: string); { V8.64 }
var
I: Integer;
MyHost: String;
begin
LogEvent('Challenge web http-01 request, URL: http://' + Host + Path);
try
if (Pos('[', Host) = 1) then { V9.6 IPv6 address needs [] removing }
MyHost := Copy(Host, 2, Length(Host) - 2)
else
MyHost := Host;
/// check if host has Acme certificate created - beware path is mixed case
if ( FChallengesTot > 0) and (Length(FChallengeItems) > 0) then begin
for I := 0 to Length(FChallengeItems) - 1 do begin
if (FChallengeItems [I].CDomain = MyHost) then begin // was it for our domain
with FChallengeItems [I] do begin
// check if our page requested - beware need forward slashes
if (Pos(CPage, Path) >= 1) and (CResp <> '') then begin
RespData := CResp;
LogEvent('Sending web http-01 challenge response: ' + RespData);
break;
end;
end;
end;
end;
end;
if RespData = '' then { V8.67 report error }
LogEvent('Challenge web http-01 response: not found in list: ' + MyHost);
except
on E:Exception do
LogEvent('Failed to find http-01 challenge - ' + E.Message);
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{ event called by web server when tls-alpn-01 challenge requested }
procedure TSslX509Certs.WebSrvAlpn(Sender: TObject; const Host: string; var CertFName: string);
var
I: Integer;
WSocket: TSslWSocketClient;
begin
WSocket := (Sender as TSslWSocketClient);
{ V9.6 raw SNI for IP address checking, server already loggd full HELLO }
LogEvent('Challenge web tls-alpn-01 request, Host: ' + Host + ', SNI Raw: ' + WSocket.CliHelloData.PunyServerName);
try
/// check if host has Acme certificate created
if ( FChallengesTot > 0) and (Length(FChallengeItems) > 0) then begin
for I := 0 to Length(FChallengeItems) - 1 do begin
if FChallengeItems [I].CAlpnSNI = IcsLowerCase(Host) then begin // was it for our domain, V9.5 AlpnSNI
with FChallengeItems [I] do begin
if (CAcmeAlpnCert <> '') then begin
if FileExists(CAcmeAlpnCert) then begin
CertFName := CAcmeAlpnCert;
LogEvent('Sending web tls-alpn-01 challenge certificate: ' + CAcmeAlpnCert);
break;
end
else
LogEvent('Failed to find tls-alpn-01 challenge certificate: ' + CAcmeAlpnCert);
end;
end;
end;
end;
end;
except
on E:Exception do begin
LogEvent('Failed to find tls-alpn-01 challenge - ' + E.Message);
end;
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TSslX509Certs.SaveDataFile(const FName, Data: String): Boolean;
var
NewFStream: TFileStream;
Attempts: integer;
begin
Result := False ; ;
for attempts := 1 to 3 do
begin
if attempts > 1 then LogEvent('Failed to save fail, retrying');
try
if FileExists(FName) then
begin
if NOT DeleteFile(FName) then
begin
LogEvent('Failed to delete old file: ' + FName) ;
exit ;
end;
end;
if NOT ForceDirectories(ExtractFileDir (FName)) then
begin
LogEvent('Failed to create directory: ' + FName);
continue;
end;
try
NewFStream := TFileStream.Create (FName, fmCreate) ;
NewFStream.WriteBuffer(AnsiString(Data) [1], Length (Data)) ;
LogEvent('Saved file OK: ' + FName);
Result := true ;
Exit;
finally
FreeAndNil(NewFStream) ;
end;
except
on E:Exception do begin
LogEvent('Failed to save file: ' + FName + ' - ' + E.Message);
end;
end;
end;
end ;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
// start local web server if neeeded
function TSslX509Certs.StartLocalServer(ChallgType: TChallengeType; const HostName: String): Boolean; { V8.64, V9.5 HostName }
begin
Result := False;
if ChallgType = ChallFileSrv then
Result := StartDomSrv('');
if ChallgType = ChallAlpnSrv then
Result := StartDomSrv(HostName); { V9.5 correct HostName }
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
// prepare challenge for one domain, either local or for certificate supplier
// might be well-know file, ALPN TLS certificate or DNS record
// starts local web server if needed for challenge
function TSslX509Certs.PrepOneChallenge(Item: TChallengeItem): Boolean; { V8.64 }
begin
Result := False;
// check well known dircectory exists to create challenge file or APLN certificate, create it if not }
if Item.CType in [ChallFileUNC, ChallAlpnUNC, ChallAlpnApp {, ChallAlpnSrv}] then begin { V8.70 added Apln }
if (Pos ('\', Item.CDirWellKnown) = 0) or (Item.CDirWellKnown[Length(Item.CDirWellKnown)] <> '\') then begin
FLastError := 'Invalid challenge well known directory: ' + Item.CDirWellKnown;
LogEvent(FLastError);
Exit;
end;
if NOT ForceDirectories (Item.CDirWellKnown) then { V8.70 }
LogEvent ('Failed to create directory: ' + Item.CDirWellKnown);
end;
// Well-Known file challenges
if Item.CType in [ChallFileUNC, ChallFileFtp, ChallFileApp, ChallFileSrv] then begin
// UNC file share, create file on remote server
if Item.CType in [ChallFileUNC] then begin
LogEvent ('Built domain challenge validation file name: ' + Item.CWKFullName + ', saving token: ' + Item.CResp);
Result := SaveDataFile (StringReplace(Item.CWKFullName, '/', '\', [rfReplaceAll]), Item.CResp); { V8.66 correct path }
end
// FTP handled by application - never tested !!
else if (Item.CType = ChallFileFtp) then begin
if Assigned(FonChallengeFTP) then begin
LogEvent ('Built domain challenge validation file name: ' + Item.CWKFullName + ', saving token: ' + Item.CResp);
if NOT SaveDataFile (Item.CWKFullName, Item.CResp) then Exit ;
LogEvent ('!!! Must FTP challenge file: ' + Item.CWKFullName +' to .well-known directory for: ' + Item.CDomain);
FonChallengeFTP(Self, Item, Result);
end;
if NOT Result then
LogEvent ('FTP challenge setup failed');
end
// internal challenge database
else if Item.CType in [ChallFileSrv, ChallFileApp] then begin
LogEvent ('Using internal challenge validation for: ' + Item.CWKFullName + ', against token: ' + Item.CResp);
Result := True;
end;
end
// tls-alpn-01 challenges
else if Item.CType in [ChallAlpnUNC, ChallAlpnSrv, ChallAlpnApp] then begin
LogEvent('Creating ACME ALPN TLS/SSL challenge certificate: ' + Item.CAcmeAlpnCert);
// UNC file share, create file on remote server
if Item.CType = ChallAlpnUNC then begin
Result := CreateAcmeAlpnCert(Item.CAcmeAlpnCert, Item.CDomain, Item.CResp);
if NOT Result then begin
FLastError := 'Failed to create ACME ALPN SSL certificate';
LogEvent(FLastError);
end;
end
// internal challenge database
else if Item.CType in [ChallAlpnSrv, ChallAlpnApp] then begin
Result := CreateAcmeAlpnCert(Item.CAcmeAlpnCert, Item.CDomain, Item.CResp);
if NOT Result then begin
FLastError := 'Failed to create ACME ALPN SSL certificate';
LogEvent(FLastError);
end;
end;
end
// V8.64 DNS challenges - handled by application
{ V9.5 added ChallDnsAcnt, V9.6 added ChallDnsPersAuto, ChallDnsPersMan }
else if Item.CType in [ChallDNSAuto, ChallDnsAcnt, ChallDnsMan, ChallDnsPersAuto, ChallDnsPersMan] then begin
LogEvent ('!!! Add challenge DNS TXT record for: ' + Item.CPage + ', with: ' + Item.CDNSValue);
if Assigned(FOnChallengeDNS) then begin
Result := False;
FOnChallengeDNS(Self, Item, Result);
if NOT Result then begin
FLastError := 'DNS challenge setup failed';
LogEvent(FLastError);
end;
end
else
LogEvent ('DNS challenge not supported by application');
end;
// start local server if needed V9.6 no longer
(* if Result and (Item.CType in [ChallFileSrv, ChallAlpnSrv]) then begin
if FDomWebServer.WebSrvIP <> FChallgSrvIP then
StopDomSrv; { V8.65 check correct IP }
Result := StartLocalServer(Item.CType, Item.CAlpnSNI); { V9.5 }
end; *)
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TSslX509Certs.IcsLogEvent(Sender: TObject; const Msg: string); { V8.71 used by DnsQuery }
begin
LogEvent (Msg) ;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
// test one challenge, either local or data from supplier for proper challenge
function TSslX509Certs.TestOneChallenge(Item: TChallengeItem): Boolean; { V8.64 }
var
Content, errinfo, TestUrl: string;
StatCode, Loop, I: integer;
Trg: Int64;
begin
Result := False;
// start local server if needed - V9.6 gets confused with two challenges, start before testing
(* if (Item.CType in [ChallFileSrv, ChallAlpnSrv]) then begin
if FDomWebServer.WebSrvIP <> FChallgSrvIP then
StopDomSrv; { V8.65 check correct IP }
if NOT StartLocalServer(Item.CType, Item.CAlpnSNI) then { V9.5 }
Exit;
end; *)
if (Item.CType in [ChallFileSrv, ChallAlpnSrv]) and (NOT DomSrvIsRunning) then begin { V9.6 }
LogEvent('Challenge test failed, local web server not running');
Exit;
end;
// Well-Known file challenges
if Item.CType in [ChallFileUNC, ChallFileFtp, ChallFileSrv, ChallFileApp] then begin
if (Pos(':', Item.CDomain) > 0) then { V9.6 IPv6 address }
TestUrl := 'http://[' + Item.CDomain + ']/.well-known/' + Item.CPage // must quote IPv6 address in URL
else
TestUrl := 'http://' + Item.CDomain + '/.well-known/' + Item.CPage;
LogEvent('Testing HTTP challenge ' + ChallengeTypeLits[Item.CType] + ' against: ' + TestUrl);
// try and read it via HTTP
try
FHttpTest.AlpnProtocols.Clear; // V9.5 clear not blank
FHttpTest.DebugLevel := FDebugLevel; // V9.5 need logging
FHttpTest.SocketFamily := FSocketFamily; // V8.60 allow IPv6
FHttpTest.ProxyURL := FProxyURL; // V8.62 proxy support
FHttpTest.RestParams.Clear;
StatCode := FHttpTest.RestRequest(HttpGET, TestUrl, False, '');
errinfo := FHttpTest.ReasonPhrase;
except
on E:Exception do begin
errinfo := 'Exception: ' + E.Message; { V8.67 }
StatCode := 99;
end;
end;
if StatCode <> 200 then begin
LogEvent('Failed to access HTTP challenge URL: ' + TestUrl + ' - ' + errinfo); { V8.67 better message }
end
else begin
Content := String(FHttpTest.ResponseOctet); // ignore content coding
if Content = Item.CResp then begin
LogEvent('Successfully tested HTTP challenge for: ' + Item.CDomain);
Result := true;
end
else
LogEvent('Failed to compare challenge content for: ' + Item.CDomain + ' - ' + Content);
end;
end;
// tls-alpn-01 challenges
if Item.CType in [ChallAlpnUNC, ChallAlpnSrv, ChallAlpnApp] then begin
if (Pos(':', Item.CDomain) > 0) then { V9.6 IPv6 address }
TestUrl := 'https://[' + Item.CDomain + ']/' // must quote IPv6 address in URL
else
TestUrl := 'https://' + Item.CDomain + '/';
LogEvent('Testing tls-alpn-01 challenge ' + ChallengeTypeLits[Item.CType] + ' against: ' + TestUrl);
// try and connect via HTTPS, expect to fail due to self signed certificate
try
FHttpTest.AlpnProtocols.Clear; // V9.5 clear then add
FHttpTest.AlpnProtocols.Add(AlpnAcmeTls1);
FHttpTest.DebugLevel := FDebugLevel; // V9.5 need logging
FHttpTest.SocketFamily := FSocketFamily;
FHttpTest.ProxyURL := FProxyURL;
FHttpTest.CertVerMethod := CertVerNone; { V9.6 don't check cert chain, bad certificate }
FHttpTest.SslAllowSelfSign := True;
FHttpTest.SslReportChain := False;
FHttpTest.SslSniType := SslSniHostArpaIP; { V9.6 send IP address in ARPA format }
FHttpTest.RestParams.Clear;
// FHttpTest.Connection := 'close'; { V8.64 }
FHttpTest.RestRequest(HttpGET, TestUrl, False, '');
errinfo := FHttpTest.ReasonPhrase;
if (FHttpTest.StatusCode <> 200) and (FHttpTest.GetAlpnProtocol = '') then begin
LogEvent('Failed to test Tls-Alpn-01 challenge, No APLN: ' + errinfo);
end
else begin
Result := (FHttpTest.GetAlpnProtocol = AlpnAcmeTls1); // we reached Acme aware server
if Result then
LogEvent('Successfully tested Tls-Alpn-01 challenge for: ' + Item.CDomain)
else
LogEvent('Failed Tls-Alpn-01 challenge, ALPN received: ' + Item.CDomain + ' - ' + FHttpTest.GetAlpnProtocol); { V8.67 }
// pending, check certificate had correct stuff??
end;
except
on E:Exception do begin
LogEvent('Exception accessing challenge ALPN: ' + E.Message); { V8.67 }
end;
end;
end;
// V8.64 DNS challenges
// if a DNS server address is supplied tries that first, then runs through
// list of well known public servers from Cloudfare, Google, etc, until one answers
{ V9.5 added ChallDnsAcn, V9.6 added ChallDnsPersAuto, ChallDnsPersMan }
if Item.CType in [ChallDNSAuto, ChallDnsAcnt, ChallDnsMan, ChallDnsPersAuto, ChallDnsPersMan] then begin
LogEvent('Testing DNS challenge ' + ChallengeTypeLits[Item.CType] + ' for: ' + Item.CDomain);
try
if NOT Assigned(FDnsQuery) then
FDnsQuery := TDnsQuery.Create(Nil);
FDnsQuery.Proto := 'udp';
if FDnsServer <> '' then begin
FDnsQuery.ServerStrat := SrvStratOne; { V8.71 }
FDnsQuery.Addr := FDnsServer;
end
else
FDnsQuery.ServerStrat := SrvStratPub; { V8.71 use public server list }
FDnsQuery.OnLogEvent := IcsLogEvent; { V8.71 }
LogEvent('DNS Query: ' + Item.CPage);
for Loop := 1 to 6 do begin // DNS servers seem to ignore TXT records and work next time!
{ if FDnsPubNr >= 0 then begin
if (FDnsPubNr > High(DnsPublicServerTable)) then FDnsPubNr := 0;
FDnsQuery.Addr := DnsPublicServerTable[FDnsPubNr];
end; }
FDnsQuery.QueryAnySync(Item.CPage, DnsQueryTXT) ;
if FDnsQuery.TXTRecordCount > 0 then begin
for I := 0 to FDnsQuery.TXTRecordCount - 1 do begin
LogEvent('!!! DNS TXT record: ' + FDnsQuery.TXTRecord[I]); // !!! TEMP DIAG
if (FDnsQuery.TXTRecord[I] = Item.CDNSValue) then begin
LogEvent('Successfully tested DNS challenge for: ' + Item.CPage + ', Data=' + Item.CDNSValue);
Result := True;
Exit;
end;
end;
end;
LogEvent('Failed to test DNS ' + Item.CPage + ' challenge, no natching TXT record');
if Loop = 3 then
break;
LogEvent('Waiting 5 seconds for DNS retry');
Trg := IcsGetTrgSecs64 (5) ;
while (NOT IcsTestTrgTick64 (Trg)) do
begin
FHttpTest.CtrlSocket.ProcessMessages ;
if FHttpTest.CtrlSocket.Terminated then
break ;
end ;
end;
except
on E:Exception do begin
LogEvent('DNS query failed: ' + E.Message);
end;
end;
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
// clean up challenge, remove old files or records
procedure TSslX509Certs.CleanupChallenge(Item: TChallengeItem); { V8.64 }
var
Flag: Boolean;
begin
if Item.CDomain = '' then
Exit; { V8.65 }
LogEvent('Cleaning up old challenge for: ' + Item.CDomain);
if Item.CType in [ChallFileUNC] then begin
if (Item.CWKFullName <> '') and FileExists(Item.CWKFullName) then
DeleteFile(Item.CWKFullName);
end;
if (Item.CAcmeAlpnCert <> '') then begin
if FileExists(Item.CAcmeAlpnCert) then
DeleteFile(Item.CAcmeAlpnCert);
end;
// remove old DNS records, except fake which never change - not persistent!!!
if Item.CType in [ChallDNSAuto, ChallDnsAcnt, ChallDnsMan] then begin { V9.5 }
if Pos ('fake', Item.CPage) > 0 then
Item.CDNSValue := ''; { V8.65 }
if (Item.CDNSValue <> '') and Assigned(FOnChallengeDNS) then begin
LogEvent ('!!! Remove DNS TXT record for: ' + Item.CPage + ', with: ' + Item.CDNSValue);
Item.CIssueState := IssStateCancel; // delete DNS
Flag := False;
FOnChallengeDNS(Self, Item, Flag);
if NOT Flag then
LogEvent ('DNS challenge removal failed');
end;
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
// local challenge test, fake challenge data
// warning other functions are dependent upon these CPage prefixes
function TSslX509Certs.LocalOneChallenge(Item: TChallengeItem): Boolean; { V8.64 }
var
ChallgNum: Integer;
begin
Result := False;
LogEvent('Starting local challenge test for: ' + Item.CDomain + ', using method: ' + ChallengeTypeLits[Item.CType]);
if (Item.CType in [ChallFileSrv, ChallAlpnSrv]) and (NOT DomSrvIsRunning) then begin { V9.6 }
LogEvent('Challenge test failed, local web server not running');
Exit;
end;
Item.CWKFullName := '';
Item.CIssueState := IssStateNone ;
Item.CWildcard := False;
if Item.CType in [ChallFileUNC, ChallFileFtp, ChallFileSrv, ChallFileApp] then begin
Item.CResp := 'My ICS Random String at ' + DateTimeToStr (Now) + ' for ' + Item.CDomain;
Item.CPage := 'ics-validation/icstestfile-' + IntToStr(Random(9999999)); // forward slashes
Item.CWKFullName := Item.CDirWellKnown + Item.CPage;
end
else if Item.CType in [ChallAlpnUNC, ChallAlpnSrv, ChallAlpnApp] then begin
Item.CPage := 'fake-acmealpn-' + IcsBuildCertFName(Item.CDomain) + '.pem';
Item.CResp := '1234';
if Item.CDirWellKnown = '' then
Item.CAcmeAlpnCert := FDirCertWork + Item.CPage { V9.6 no well-known dir for some challenges }
else
Item.CAcmeAlpnCert := Item.CDirWellKnown + Item.CPage;
end
else if Item.CType in [ChallDNSAuto, ChallDnsAcnt, ChallDnsMan] then begin { V9.5 }
// strip off wild card prefix
if Pos ('*.', Item.CDomain) = 1 then begin
Item.CDomain := Copy(Item.CDomain, 3, 99);
Item.CWildcard := True;
Item.CDNSValue := String(IcsBase64UrlEncodeA(IcsHashDigest('5678', Digest_sha256)));
end
else
Item.CDNSValue := String(IcsBase64UrlEncodeA(IcsHashDigest('1234', Digest_sha256)));
Item.CPage := '_fake-challenge.' + IcsIDNAToASCII(Item.CDomain);
end
else begin
Result := True;
LogEvent('Test skipped, method not supported');
Exit;
end;
Result := PrepOneChallenge(Item);
if Result then begin
// save database challenge - only in array, never saved to database since temporary
ChallgNum := DBAddChallenge(Item);
Result := TestOneChallenge(Item);
if NOT Result then
Exit;
// clean up challenge once OK
CleanupChallenge (Item);
if ChallgNum >= 0 then
DBRemoveChallenge(ChallgNum);
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
// locally test challenge for one domain name
function TSslX509Certs.TestChallenge(const aDomain, aDirWellKnown: String): Boolean; { V8.64 }
var
CurChallenge: TChallengeItem;
begin
CurChallenge.CCommonName := fCertCommonName;
CurChallenge.CSuppOrderId := FSuppOrderId;
CurChallenge.CSupplierProto := FSupplierProto;
CurChallenge.CType := fSuppCertChallenge;
CurChallenge.CIssueState := IssStateNone;
CurChallenge.CDomain := aDomain;
CurChallenge.CAlpnSNI := aDomain; { V9.5, V9.6 not arpa }
CurChallenge.CDirWellKnown := aDirWellKnown;
Result := LocalOneChallenge(CurChallenge);
if (NOT Result) and (FLastError = '') then
FLastError := FLastResponse; // keep first real error
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
// locally test all challenges for all alternate names
function TSslX509Certs.TestAltNameChallgs: Boolean; { V8.64 }
var
I: Integer;
begin
Result := False;
if FCertSubAltNames.Count = 0 then
Exit;
// V9.6 start local server if needed
if (fSuppCertChallenge in [ChallFileSrv, ChallAlpnSrv]) then begin
if DomSrvIsRunning then
StopDomSrv;
if NOT StartLocalServer(fSuppCertChallenge, fCertCommonName{ FCertSubAltNames[0].SADomain}) then { V9.5, V9.6 only one domain???? }
Exit;
end;
Result := True;
for I := 0 to FCertSubAltNames.Count - 1 do begin
if FCertSubAltNames[I].SADirWellKnown = '' then
FCertSubAltNames[I].SADirWellKnown := FDirWellKnown; { V8.66 sanity check }
if NOT TestChallenge(FCertSubAltNames[I].SADomain,
FCertSubAltNames[I].SADirWellKnown) then Result := False;
end;
StopDomSrv;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
// create a self signed certificate for the ACME tls-alpn-01 challenge with the provided token
// also creates simple self signed if no keyauth, for localhost
function TSslX509Certs.CreateAcmeAlpnCert(const FileName, CName, KeyAuth: String): Boolean;
var
MySslCertTools: TSslCertTools;
Hash: AnsiString;
AcmeId, S: String;
AltNames: TStringList;
begin
Result := False;
if KeyAuth <> '' then begin
Hash := IcsHashDigest(AnsiString(KeyAuth), Digest_sha256);
AcmeId := IcsBufferToHex(Hash);
end;
MySslCertTools := TSslCertTools.Create(nil);
AltNames := TStringList.Create;
try
try
if NOT ForceDirectories(ExtractFileDir (FileName)) then { V8.70 }
begin
LogEvent('Failed to create directory: ' + FileName);
Exit;
end;
AltNames.Add(CName); { V9.5 Acme now requires SAN name or gives OID 2.5.29.17 is not present error }
CreateSelfSignCertEx(FileName, CName, AltNames, PrivKeyECsecp256, '', AcmeId); { V8.64 }
{ write cert to log }
MySslCertTools.LoadFromFile(FileName, croTry, croTry);
S := 'SSL certificate:';
if KeyAuth <> '' then
S := S + ' Acme keyAuthorization: ' + KeyAuth + ', Acme Identifier: ' + AcmeId;
if FDebugLevel >= DebugSslLow then
S := S + IcsCRLF + MySslCertTools.GetRawText
else
S := S + IcsCRLF + MySslCertTools.CertInfo(False);
LogEvent(S);
Result := True;
except
on E:Exception do
LogEvent ('Failed to create SSL certificate: ' + E.Message);
end;
finally
MySslCertTools.Free;
AltNames.Free;
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
// read Acme supplier accounts list
function TSslX509Certs.DBSuppliersRead: Boolean; { V9.5 }
var
section, title: String;
J: Integer;
SupplieIni: TIcsIniFile;
begin
Result := False;
AcmeSuppTot := 0;
SetLength(AcmeSuppRecs, 10);
if NOT FileExists(FAccSuppFile) then
Exit;
try
SupplieIni := TIcsIniFile.Create(FAccSuppFile);
{ allow up to 100 account directories }
for J := 1 to 100 do begin
section := 'Account-' + IntToStr (J);
title := IcsTrim(SupplieIni.ReadString(section, 'SuppTitle', ''));
if title = '' then
continue;
if (AcmeSuppTot + + 1) >= Length(AcmeSuppRecs) then
SetLength(AcmeSuppRecs, AcmeSuppTot + 10);
with AcmeSuppRecs[AcmeSuppTot] do begin
ASuppTitle := title;
ASupplier := TAcmeSupplier(GetEnumValue (TypeInfo (TAcmeSupplier),
IcsTrim(SupplieIni.ReadString(section, 'Supplier', 'AcmeLetsEncryptLive'))));
if ASupplier > High(TAcmeSupplier) then
ASupplier := AcmeLetsEncrypt; { sanity test }
ASuppDir := SupplieIni.ReadString(section, 'SuppDir', '');
if ASuppDir <> '' then
ASuppDir := IncludeTrailingPathDelimiter(Trim(ASuppDir)); // sanity test
end;
AcmeSuppTot := AcmeSuppTot + 1;
end;
SetLength(AcmeSuppRecs, AcmeSuppTot);
Result := True;
except
on E:Exception do begin
LogEvent('Could not open supplier accounts database: ' + FAccSuppFile + ' - ' + E.Message);
Exit;
end;
end;
SupplieIni.Free;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
// save Acme suppliers list
// creates C:\ProgramData\ICS-Acme-Accounts\ics-acme-accounts.db if missing
function TSslX509Certs.DBSuppliersSave: Boolean; { V9.5 }
var
section: String;
J, Tot, DelNr: Integer;
SupplieIni: TIcsIniFile;
begin
Result := False;
if AcmeSuppTot <= 0 then
Exit;
Tot := 0;
DelNr := 0;
try
SupplieIni := TIcsIniFile.Create(FAccSuppFile); // create if not exists
for J := 0 to AcmeSuppTot - 1 do begin
with AcmeSuppRecs[J] do begin
if ASuppTitle <> '' then begin // not deleted
Tot := Tot + 1;
section := 'Account-' + IntToStr (Tot);
SupplieIni.WriteString(section, 'SuppTitle', Trim(ASuppTitle));
SupplieIni.WriteString(section, 'Supplier', GetEnumName (TypeInfo (TAcmeSupplier), Ord (ASupplier)));
SupplieIni.WriteString(section, 'SuppDir', IncludeTrailingPathDelimiter(Trim(ASuppDir)));
end
else
DelNr := DelNr + 1;
end;
end;
// delete any extra sections
while (DelNr > 0) do begin
Tot := Tot + 1;
DelNr := DelNr - 1;
section := 'Account-' + IntToStr (Tot);
SupplieIni.EraseSection(section);
end;
SupplieIni.UpdateFile; // write INI file
Result := True;
except
on E:Exception do begin
LogEvent('Could not create supplier accounts database: ' + FAccSuppFile + ' - ' + E.Message);
Exit;
end;
end;
SupplieIni.Free;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
// find Acme supplier account from list
function TSslX509Certs.DBFindAccSupp(const ATitle: String): Integer; { V9.5 }
var
J: Integer;
begin
Result := -1;
if AcmeSuppTot = 0 then
Exit;
for J := 0 to AcmeSuppTot - 1 do begin
if AcmeSuppRecs[J].ASuppTitle = ATitle then begin
Result := J;
Exit;
end;
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
// add new Acme supplier account to supplier list, optional create account database
// closes account
function TSslX509Certs.DBAddAccSupp(const ATitle, ADirAcc: String; ASupplier: TAcmeSupplier; CreateNew: Boolean;
AccKeyType: TSslPrivKeyType = PrivKeyECsecp256): Boolean; { V9.5 }
var
MySuppTitle, MyDirAcc, AccDBFile: String;
begin
Result := False;
MySuppTitle := Trim(ATitle);
// if account exists, nothing more to do
// pendng, should we check directory as well???
if AcmeSuppTot = 0 then
DBSuppliersRead ;
if (DBFindAccSupp(MySuppTitle) >= 0) then begin
LogEvent('Supplier already exists: ' + MySuppTitle);
Result := True;
Exit;
end;
if Pos(IcsSpace, MySuppTitle) > 0 then begin
LogEvent('Supplier Name Not Allowed Blanks: ' + MySuppTitle);
Exit;
end;
// create account directory name if not passed
MyDirAcc := ADirAcc;
if MyDirAcc = '' then
MyDirAcc := IncludeTrailingPathDelimiter(AccSuppDir) + MySuppTitle + '\';
if NOT ForceDirectories (MyDirAcc) then begin
LogEvent('Failed to Create Account Directory: ' + MyDirAcc);
Exit;
end;
// see if creating new supplier account database and Acme account with supplier
AccDBFile := IncludeTrailingPathDelimiter(AccDBFile) + FileIcsCntlDB;
if (NOT FileExists(AccDBFile)) then begin
LogEvent('Creating New Supplier Account: ' + MySuppTitle + ' for Account Dir: ' + MyDirAcc);
ClearAccount;
FSupplierTitle := MySuppTitle;
FAcmeAccKeyType := AccKeyType;
FAcmeSupplier := ASupplier;
FDirCertWork := MyDirAcc;
SupplierProto := SuppProtoAcmeV2;
SupplierServer := AcmeSupplierApiURLs[FAcmeSupplier];
try
if NOT DBOpenINI(FDirCertWork, True) then begin
LogEvent('Failed to Create Supplier Account Database: ' + AccDBFile);
Exit;
end;
if NOT DBWriteAccount then begin
LogEvent('Failed to Save Supplier Account');
Exit;
end;
// create new private key, then send it to Acme supplier to creare new account
if CreateNew then begin
if NOT SetAcmeAccount(True) then begin
LogEvent('Failed to Open Acme Account - ' + LastError + ': ' + MyDirAcc);
if ASupplier in [AcmeLetsEncrypt, AcmeLetsEncryptTest] then
Exit;
LogEvent('Need to Use GUI to Create Acme Account');
end
else
LogEvent('Created New Acme Account OK: ' + MySuppTitle);
end;
finally
FreeAndNil(FControlFile);
end;
end;
// add new record to supplier table and save it
AcmeSuppTot := AcmeSuppTot + 1;
SetLength(AcmeSuppRecs, AcmeSuppTot);
with AcmeSuppRecs[AcmeSuppTot - 1] do begin
ASuppTitle := MySuppTitle;
ASupplier := ASupplier;
ASuppDir := MyDirAcc;
end;
Result := DBSuppliersSave;
if NOT Result then
LogEvent('Failed to Create New Supplier Account')
else
LogEvent('Created New Supplier Account OK: ' + MySuppTitle);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
// certificate supplier specific stuff,
function TSslX509Certs.DBOpenINI(const WorkDir: String; CreateNew: Boolean = False): Boolean;
var
fname: String;
begin
Result := False;
fname := IncludeTrailingPathDelimiter(WorkDir) + FileIcsCntlDB;
if Assigned(FControlFile) then begin
if FCnrtFileName = fname then begin
Result := True;
Exit;
end;
FControlFile.Free;
end;
FCnrtFileName := fname;
if (NOT CreateNew) and (NOT FileExists(FCnrtFileName)) then begin
LogEvent('Account database not found: ' + FCnrtFileName);
FCnrtFileName := '';
Exit;
end;
try
FControlFile := TIcsIniFile.Create(FCnrtFileName);
Result := True;
except
on E:Exception do begin
LogEvent('Could not open account database: ' + FCnrtFileName + ' - ' + E.Message);
FCnrtFileName := '';
Exit;
end;
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
// certificate supplier specific stuff,
function TSslX509Certs.DBReadAccount(const WorkDir: String): Boolean;
var
section, OldWorkDir: String;
OldProto: TSupplierProto;
begin
Result := False;
if NOT DBOpenINI(WorkDir, False) then
Exit;
section := CntlDBAccount;
with FControlFile do begin
// common stuff
OldProto := TSupplierProto (GetEnumValue (TypeInfo (TSupplierProto), ReadString (section, 'SupplierProto', 'SuppProtoNone'))) ;
if (Ord(OldProto) <= 0) or (OldProto <= SuppProtoNone) then begin
LogEvent('Existing account not found');
Exit;
end;
OldWorkDir := ReadString (section, 'DirCertWork', '') ;
if (OldWorkDir <> '') and (CompareText(OldWorkDir, WorkDir) <> 0) then begin
LogEvent('Certificate work directory, expected ' + WorkDir + ' but found ' + OldWorkDir);
// Exit;
end;
// do not read/write 'SeqOrderNum' here
FSupplierProto := OldProto;
FDirCertWork := OldWorkDir;
FDebugLevel := THttpDebugLevel(GetEnumValue(TypeInfo(THttpDebugLevel), ReadString (section, 'DebugLevel', 'DebugNone'))) ;
if (FDebugLevel < Low(THttpDebugLevel)) or (FDebugLevel > High(THttpDebugLevel)) then
FDebugLevel := DebugConn;
FDomWebSrvIP := ReadString (section, 'DomWebSrvIP', '') ;
FDomWebSrvIP2 := ReadString (section, 'DomWebSrvIP2', '') ; { V9.5 }
FSocketFamily := TSocketFamily(GetEnumValue(TypeInfo(TSocketFamily), ReadString (section, 'SocketFamily', 'sfAny'))) ; { V9.5 }
if (FSocketFamily < Low(TSocketFamily)) or (FSocketFamily > High(TSocketFamily)) then
FSocketFamily := sfAny;
FProxyURL := ReadString (section, 'ProxyURL', ''); { V9.5 }
if ReadString (section, 'LogJson', 'False') = 'True' then
FLogJson := true
else
FLogJson := false ;
if ReadString (section, 'LogPkeys', 'False') = 'True' then
FLogPkeys := true
else
FLogPkeys := false ;
FSupplierEmail := ReadString (section, 'SupplierEmail', '') ;
FSupplierServer := ReadString (section, 'SupplierServer', '') ;
FSupplierTitle := ReadString (section, 'SupplierTitle', 'UnknownSupplier') ; { V9.5 }
// own CA stuff
if FSupplierProto = SuppProtoOwnCA then begin
FCACertFile := ReadString (section, 'CACertFile', '') ;
FCAPkeyFile := ReadString (section, 'CAPkeyFile', '') ;
FCAPkeyPw := ReadString (section, 'CAPkeyPw', '') ;
end;
// ACME stuff
if FSupplierProto = SuppProtoAcmeV2 then begin
FAcmeAccKeyType := TSslPrivKeyType (GetEnumValue (TypeInfo (TSslPrivKeyType), ReadString (section, 'AcmeAccKeyType', 'PrivKeyRsa2048'))) ;
fAcmeAccountUrl := ReadString (section, 'AcmeAccountUrl', '') ;
fAcmeAccountNum := ReadString (section, 'AcmeAccountNum', '') ;
FAcmeSupplier := TAcmeSupplier(GetEnumValue (TypeInfo (TAcmeSupplier),
IcsTrim(ReadString(section, 'AcmeSupplier', 'AcmeLetsEncryptLive')))); { V9.5 }
if (FAcmeSupplier > High(TAcmeSupplier)) then
FAcmeSupplier := AcmeLetsEncrypt; { sanity test }
FAcmeEABKid := ReadString (section, 'AcmeEABKid', '') ; { V9.5 }
FAcmeEABHmacKey := ReadString (section, 'AcmeEABHmacKey', '') ; { V9.5 }
if fAcmeAccountUrl <> '' then begin
LogTimeStamp;
LogEvent('Loaded existing ACME account: ' + fAcmeAccountUrl + ' from ' + WorkDir);
end;
end;
LogEvent('Opened Supplier Account for: ' + FSupplierTitle + ', Protocol: ' + SupplierProtoLits [FSupplierProto] +
', Supplier: ' + AcmeSupplierLits[FAcmeSupplier] + ', File: ' + FCnrtFileName);
end;
Result := DBReadSections;
if Result then
LogEvent('Common Name domains found, total: ' + IntToStr(Length(FDomainItems)));
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TSslX509Certs.DBReadSections: Boolean;
var
I: Integer;
MyDomains: TStringList;
section: String;
begin
Result := False;
if NOT DBOpenINI(FDirCertWork, False) then
Exit;
MyDomains := TStringList.Create;
try
FControlFile.ReadSections(FDBIniSections); // get cert domains and challenges
for I := 0 to FDBIniSections.Count - 1 do begin
if Pos(CntlDBDomainPre, FDBIniSections[I]) = 1 then
MyDomains.Add(Copy(FDBIniSections[I], Length(CntlDBDomainPre) + 1, 999));
end;
MyDomains.Sort;
SetLength(FDomainItems, MyDomains.Count);
if MyDomains.Count > 0 then begin
for I := 0 to MyDomains.Count - 1 do begin
with FDomainItems[I], FControlFile do begin
section := IcsLowerCase(CntlDBDomainPre + MyDomains[I]);
DCommonName := MyDomains[I];
DCertSANs := ReadString (section, 'CertSubAltList', '') ;
DProduct := ReadString (section, 'SuppCertProduct', '') ;
DSuppOrderId := ReadString (section, 'SuppOrderId', '') ;
DIssueState := TIssueState(GetEnumValue (TypeInfo (TIssueState), ReadString (section, 'IssueState', 'IssStateNone')));
if DIssueState > High(TIssueState) then DIssueState := IssStateNone;
DSuppCertChallg := TChallengeType (GetEnumValue (TypeInfo (TChallengeType), ReadString (section, 'SuppCertChallenge', 'ChallNone'))) ;
if DSuppCertChallg > High(TChallengeType) then DSuppCertChallg := ChallNone;
DCertStartDT := RFC3339_StrToDate(ReadString (section, 'NewCertStartDT', '')) ;
DCertEndDT := RFC3339_StrToDate(ReadString (section, 'NewCertEndDT', '')) ;
{$IFDEF MSCRYPT_Tools}
// DMsCertLoc := TMsCertLocation(GetEnumValue (TypeInfo (TMsCertLocation), ReadString (section, 'MsCertLoc', 'MsLocMachine'))) ; { V8.71 }
{$ENDIF}
DIssueStartDT := RFC3339_StrToDate(ReadString (section, 'ChallgStartDT', '')) ; { V9.5 }
DCertProfile := ReadString (section, 'CertAcmeProfile', '') ; { V9.5 }
DCertRenewDays := ReadInteger (section, 'CertRenewDays', 0) ; { V9.5 }
if ReadString (section, 'CertRenewNow', 'False') = 'True' then DCertRenewNow := true else DCertRenewNow := false ; { V9.5 }
end;
end;
end;
Result := True;
if Assigned(FOnDomainsRefresh) then
FOnDomainsRefresh(Self);
finally
MyDomains.Free;
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TSslX509Certs.DBWriteAccount: Boolean;
var
section, temp: string;
begin
Result := False;
if NOT DBOpenINI(FDirCertWork, False) then
Exit;
section := CntlDBAccount;
with FControlFile do begin
// common stuff
// do not read/write 'SeqOrderNum' here
WriteString (section, 'DebugLevel', GetEnumName (TypeInfo (THttpDebugLevel), Ord(FDebugLevel))) ;
WriteString (section, 'DirCertWork', FDirCertWork) ;
WriteString (section, 'DomWebSrvIP', FDomWebSrvIP) ;
WriteString (section, 'DomWebSrvIP2', FDomWebSrvIP2) ; { V9.5 }
WriteString (section, 'SocketFamily', GetEnumName(TypeInfo(TSocketFamily), Ord(FSocketFamily))); { V9.5 }
WriteString (section, 'ProxyURL', FProxyURL); { V9.5 }
if FLogJson then temp := 'True' else temp := 'False' ; WriteString (section, 'LogJson', temp) ;
if FLogPkeys then temp := 'True' else temp := 'False' ; WriteString (section, 'LogPkeys', temp) ;
WriteString (section, 'SupplierEmail', FSupplierEmail) ;
WriteString (section, 'SupplierProto', GetEnumName (TypeInfo (TSupplierProto), Ord (FSupplierProto)));
WriteString (section, 'SupplierServer', FSupplierServer) ;
WriteString (section, 'SupplierTitle', FSupplierTitle) ;
// ACME stuff
if FSupplierProto = SuppProtoAcmeV2 then begin
WriteString (section, 'AcmeAccKeyType', GetEnumName (TypeInfo (TSslPrivKeyType), Ord(FAcmeAccKeyType))) ;
WriteString (section, 'AcmeAccountNum', fAcmeAccountNum) ;
WriteString (section, 'AcmeAccountUrl', fAcmeAccountUrl) ;
WriteString (section, 'AcmeSupplier', GetEnumName (TypeInfo (TAcmeSupplier), Ord(FAcmeSupplier))) ; { V9.5 }
WriteString (section, 'AcmeEABKid', FAcmeEABKid) ; { V9.5 }
WriteString (section, 'AcmeEABHmacKey', FAcmeEABHmacKey) ; { V9.5 }
end;
// own CA stuff
if FSupplierProto = SuppProtoOwnCA then begin
WriteString (section, 'CACertFile', FCACertFile) ;
WriteString (section, 'CAPkeyFile', FCAPkeyFile) ;
WriteString (section, 'CAPkeyPw', FCAPkeyPw) ;
end;
end;
FControlFile.UpdateFile; // write INI file
Result := True;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TSslX509Certs.DBNewOrderNum: Integer;
var
section: string;
begin
Result := 0;
if NOT DBOpenINI(FDirCertWork, False) then
Exit;
section := CntlDBAccount;
FSeqOrderNum := FControlFile.ReadInteger (section, 'SeqOrderNum', 0) ; { V8.64 }
if FSeqOrderNum < 1001 then begin
LogEvent('Failed to read valid SeqOrderNum, resetting');
// LogEvent('SeqOrderNum=' + FControlFile.ReadString (section, 'SeqOrderNum', '')); // !! TEMP DIAG
FSeqOrderNum := 1001;
end;
Result := FSeqOrderNum;
LogEvent('New sequential order number: ' + IntToStr(Result)) ;
FSeqOrderNum := FSeqOrderNum + 1;
FControlFile.WriteInteger (section, 'SeqOrderNum', FSeqOrderNum) ;
FControlFile.UpdateFile; // write INI file
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TSslX509Certs.DBFindDomain(const CNDomain: String): Integer;
var
I: Integer;
begin
Result := -1;
if Length(FDomainItems) > 0 then begin
for I := 0 to Length(FDomainItems) - 1 do begin
if FDomainItems[I].DCommonName = CNDomain then begin
Result := I;
Exit;
end;
end;
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
// a certificate common name domain, perhaps with sub domains as well
// UseStoredProps replaces all public properties from database values
//function TSslX509Certs.DBReadCNDomain(const CNDomain: String; UseStoredProps: Boolean): Boolean;
function TSslX509Certs.DBReadCNDomain(const CNDomain: String): Boolean; { V9.5 always reads Stored Properties }
var
section, temp, aDomain, aDirWellKnown, aDirPubWebCert, aApprovalEmail, S: String;
I, idx: Integer;
begin
Result := False;
// if UseStoredProps then
ClearCertOrder; { V9.5 }
if NOT DBOpenINI(FDirCertWork, False) then
Exit;
section := IcsLowerCase(CntlDBDomainPre + CNDomain);
with FControlFile do begin
temp := ReadString (section, 'CertCommonName', 'xx') ;
if temp <> CNDomain then begin
LogEvent('Certificate domain not found in database: ' + CNDOmain);
Exit;
end;
FCertCommonName := temp;
// stuff supplied by user from public properties
FCertAddress := ReadString (Section, 'CertAddress', '') ;
FCertApprovEmail := ReadString (section, 'CertApprovEmail', '') ;
FCertContactEmail := ReadString (section, 'CertContactEmail', '') ;
FCertContactFirst := ReadString (section, 'CertContactFirst', '') ;
FCertContactLast := ReadString (section, 'CertContactLast', '') ;
FCertContactTitle := ReadString (section, 'CertContactTitle', '') ;
FCertCountry := ReadString (section, 'CertCountry', '') ;
FCertCsrOrigin := TCertCsrOrigin (GetEnumValue (TypeInfo (TCertCsrOrigin), ReadString (section, 'CertCsrOrigin', 'CsrOriginProps'))) ;
FCertLocality := ReadString (section, 'CertLocality', '') ;
FCertOldCsrFile := ReadString (section, 'CertOldCsrFile', '') ;
FCertOldPrvKey := ReadString (section, 'CertOldPrvKey', '') ;
FCertOrgUnit := ReadString (section, 'CertOrgUnit', '') ;
FCertOrganization := ReadString (section, 'CertOrganization', '') ;
IcsStrToSet(TypeInfo (TCertOutFmt), ReadString (section, 'CertOutFmts', ''), FCertOutFmts, SizeOf(FCertOutFmts)) ;
FCertPhone := ReadString (section, 'CertPhone', '') ;
FCertPostCode := ReadString (section, 'CertPostCode', '') ;
FCertSerNumType := TSerNumType (GetEnumValue (TypeInfo (TSerNumType), ReadString (section, 'CertSerNumType', 'SerNumRandom'))) ;
FCertSignDigestType := TEvpDigest (GetEnumValue (TypeInfo (TEvpDigest), ReadString (section, 'CertSignDigestType', 'Digest_sha256'))) ;
FCertState := ReadString (section, 'CertState', '') ;
FCertValidity := ReadInteger (section, 'CertValidity', 0) ;
FDirPubWebCert.CommaText := ReadString (section, 'DirPubWebCert', '') ;
FDirWellKnown := ReadString (section, 'DirWellKnown', '') ;
S := ReadString (section, 'PrivKeyCipher', 'PrivKeyEncNone');
FPrivKeyCipher := TSslPrivKeyCipher (GetEnumValue (TypeInfo (TSslPrivKeyCipher), S)) ;
FPrivKeyPassword := ReadString (section, 'PrivKeyPassword', '') ; // encrypt password !!!!
FPrivKeyType := TSslPrivKeyType (GetEnumValue (TypeInfo (TSslPrivKeyType), ReadString (section, 'PrivKeyType', 'PrivKeyRsa2048'))) ;
FSuppCertChallenge := TChallengeType (GetEnumValue (TypeInfo (TChallengeType), ReadString (section, 'SuppCertChallenge', 'ChallNone'))) ;
if FSuppCertChallenge > High(TChallengeType) then
FSuppCertChallenge := ChallNone;
FSuppCertProduct := ReadString (section, 'SuppCertProduct', '') ;
FSuppOrderId := ReadString (section, 'SuppOrderId', '') ;
FSuppOrderRef := ReadString (section, 'SuppOrderRef', '') ;
FChallgSrvIP := ReadString (section, 'ChallgSrvIP', FDomWebSrvIP) ; { V8.65 }
FChallgSrvIP2 := ReadString (section, 'ChallgSrvIP2', FDomWebSrvIP2) ; { V8.71 }
{$IFDEF MSCRYPT_Tools}
FMsCertLoc := TMsCertLocation(GetEnumValue (TypeInfo (TMsCertLocation), ReadString (section, 'MsCertLoc', 'MsLocMachine'))) ; { V8.71 }
{$ENDIF}
FCertAcmeProfile := ReadString (section, 'CertAcmeProfile', '') ; { V9.5 }
if ReadString (section, 'AutoOrderComplete', 'True') = 'True' then FAutoOrderComplete := true else FAutoOrderComplete := false ; { V9.5 }
if ReadString (section, 'CertRenewNow', 'False') = 'True' then FCertRenewNow := true else FCertRenewNow := false ; { V9.5 }
// stuff created during certificate processing
FAcmeOrderFinalizeUrl := ReadString (section, 'AcmeOrderFinalizeUrl', '');
FAcmeOrderObjUrl := ReadString (section, 'AcmeOrderObjUrl', '');
FChallgDoneDT := RFC3339_StrToDate(ReadString (section, 'ChallgDoneDT', '')) ;
FChallgExpireDT := RFC3339_StrToDate(ReadString (section, 'ChallgExpireDT', '')); { V8.64 }
FChallgStartDT := RFC3339_StrToDate(ReadString (section, 'ChallgStartDT', '')) ;
FFileFinalBundle := ReadString (section, 'FileFinalBundle', '') ;
FFileFinalCSR := ReadString (section, 'FileFinalCSR', '') ;
FFileFinalCert := ReadString (section, 'FileFinalCert', '') ;
FFileFinalPrvKey := ReadString (section, 'FileFinalPrvKey', '') ;
FIssueState := TIssueState(GetEnumValue (TypeInfo (TIssueState), ReadString (section, 'IssueState', 'IssStateNone')));
if FIssueState > High(TIssueState) then
FIssueState := IssStateNone;
FNewCertCN := ReadString (section, 'NewCertCN', '') ;
FNewCertChainInfo := ReadString (section, 'NewCertChainInfo', '') ;
FNewCertEndDT := RFC3339_StrToDate(ReadString (section, 'NewCertEndDT', '')) ;
FNewCertErrs := ReadString (section, 'NewCertErrs', '') ;
FNewCertSAN := ReadString (section, 'NewCertSAN', '') ;
FNewCertStartDT := RFC3339_StrToDate(ReadString (section, 'NewCertStartDT', '')) ;
FNewCertValRes := TChainResult(GetEnumValue (TypeInfo (TChainResult), ReadString (section, 'NewCertValRes', 'chainOK'))) ;
FNewOrderNum := ReadInteger (section, 'NewOrderNum', 0) ;
FOrderAttempts := ReadInteger (section, 'OrderAttempts', 0) ;
FOrderCertsDT := RFC3339_StrToDate(ReadString (section, 'OrderCertsDT', '')) ;
FOrderStartDT := RFC3339_StrToDate(ReadString (section, 'OrderStartDT', '')) ;
FPartFNameFinal := ReadString (section, 'PartFNameFinal', '') ;
FPartFNameOrder := ReadString (section, 'PartFNameOrder', '') ;
FPartFNameServer.CommaText := ReadString (section, 'PartFNameServer', '') ;
FPendingChallg := ReadInteger (section, 'PendingChallg', 0) ;
FProductCA := ReadString (section, 'ProductCA', '') ;
FProductCertType := ReadString (section, 'ProductCertType', '') ;
FProductDVAuth := ReadString (section, 'ProductDVAuth', '') ;
FProductFeatures := ReadString (section, 'ProductFeatures', '') ;
FProductMaxSan := ReadInteger (section, 'ProductMaxSan', 0) ;
FProductQuote := ReadString (section, 'ProductQuote', '') ;
FCertRenewDays := ReadInteger (section, 'CertRenewDays', 0) ; { V9.5 }
FCertRenewCheckDT := RFC3339_StrToDate(ReadString (section, 'CertRenewCheckDT', '')) ; { V9.5 }
FCertRenewRetryDT := RFC3339_StrToDate(ReadString (section, 'CertRenewRetryDT', '')) ; { V9.5 }
FCertRenewalId := ReadString (section, 'CertRenewalId', '') ; { V9.5 }
FAcmeChallngReport := IcsUnEscapeCRLF(ReadString (section, 'AcmeChallngReport', '')) ; { V9.5 }
// find Subject Alternate Names
// if UseStoredProps then begin
FCertSANs.CommaText := ReadString (section, 'CertSubAltList', '') ;
FCertSubAltNames.Clear;
FCertSANTot := FCertSANs.Count;
if FCertSANTot > 0 then begin
for I := 0 to FCertSANTot - 1 do begin
section := IcsLowerCase(CntlDBSANPre + FCertCommonName + '=' + FCertSANs[I]);
aDomain := ReadString (section, 'Domain', '') ;
aDirWellKnown := ReadString (section, 'DirWellKnown', '') ;
aDirPubWebCert := ReadString (section, 'DirPubWebCert', '') ;
aApprovalEmail := ReadString (section, 'ApprovalEmail', '') ;
if aDomain <> '' then begin
idx := FCertSubAltNames.AddItem (aDomain, aDirWellKnown, aDirPubWebCert, aApprovalEmail);
with FCertSubAltNames [idx] do begin
SAIssueState := TIssueState(GetEnumValue (TypeInfo (TIssueState), ReadString (section, 'SAIssueState', 'IssStateNone'))) ;
if SAIssueState > High(TIssueState) then SAIssueState := IssStateNone;
SAStartDT := RFC3339_StrToDate(ReadString (section, 'SAStartDT', '')) ;
SADoneDT := RFC3339_StrToDate(ReadString (section, 'SADoneDT', '')) ;
SAValidResult := ReadString (section, 'SAValidResult', '') ;
end;
end;
end;
end;
// end;
end;
Result := True;
// try and update one FDomainItems to avoid reloading lot
idx := DBFindDomain(CNDomain);
if idx < 0 then
DBReadSections
else begin
FDomainItems[idx].DCertSANs := FCertSANs.CommaText;
FDomainItems[idx].DProduct := FSuppCertProduct;
FDomainItems[idx].DSuppOrderId := FSuppOrderId;
FDomainItems[idx].DIssueState := FIssueState;
FDomainItems[idx].DCertStartDT := FNewCertStartDT;
FDomainItems[idx].DCertEndDT := FNewCertEndDT;
FDomainItems[idx].DIssueStartDT := FChallgStartDT; { V9.5 }
FDomainItems[idx].DCertProfile := FCertAcmeProfile; { V9.5 }
FDomainItems[idx].DCertRenewDays := FCertRenewDays; { V9.5 }
FDomainItems[idx].DCertRenewNow := FCertRenewNow; { V9.5 }
end;
if Assigned(FOnDomainsRefresh) then
FOnDomainsRefresh(Self);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
// V9.5 get renewal infomation dates only for certificate common name domain }
// only used to build IcsHosts dates
function TSslX509Certs.DBReadCNDomDates(const CNDomain: String): Boolean; { V9.5 }
var
section, temp: String;
begin
Result := False;
if NOT DBOpenINI(FDirCertWork, False) then
Exit;
section := IcsLowerCase(CntlDBDomainPre + CNDomain);
with FControlFile do begin
temp := ReadString (section, 'CertCommonName', 'xx') ;
if temp <> CNDomain then begin
LogEvent('Certificate domain not found in database: ' + CNDOmain);
Exit;
end;
FCertCommonName := 'xx'; // deliberately corrupted to ensure all props read again
FIssueState := TIssueState(GetEnumValue (TypeInfo (TIssueState), ReadString (section, 'IssueState', 'IssStateNone')));
if FIssueState > High(TIssueState) then
FIssueState := IssStateNone;
FAcmeOrderObjUrl := ReadString (section, 'AcmeOrderObjUrl', '');
FChallgExpireDT := RFC3339_StrToDate(ReadString (section, 'ChallgExpireDT', ''));
FNewCertEndDT := RFC3339_StrToDate(ReadString (section, 'NewCertEndDT', '')) ;
FNewCertStartDT := RFC3339_StrToDate(ReadString (section, 'NewCertStartDT', '')) ;
FCertRenewDays := ReadInteger (section, 'CertRenewDays', 0) ;
if ReadString (section, 'CertRenewNow', 'False') = 'True' then FCertRenewNow := true else FCertRenewNow := false ;
FCertRenewCheckDT := RFC3339_StrToDate(ReadString (section, 'CertRenewCheckDT', '')) ;
FCertRenewRetryDT := RFC3339_StrToDate(ReadString (section, 'CertRenewRetryDT', '')) ;
FCertRenewalId := ReadString (section, 'CertRenewalId', '') ;
FFileFinalBundle := ReadString (section, 'FileFinalBundle', '') ;
Result := True;
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TSslX509Certs.DBWriteCNDomain: Boolean;
var
section, temp: string;
I, J: Integer;
flag: Boolean;
begin
Result := False;
if FCertCommonName = '' then begin { V8.71 }
LogEvent('Can not save domain with blank Common Name') ;
Exit;
end;
if NOT DBOpenINI(FDirCertWork, False) then
Exit;
section := CntlDBDomainPre + FCertCommonName;
with FControlFile do begin
WriteString (section, 'AcmeOrderFinalizeUrl', FAcmeOrderFinalizeUrl);
WriteString (section, 'AcmeOrderObjUrl', FAcmeOrderObjUrl);
WriteString (Section, 'CertAddress', FCertAddress) ;
WriteString (section, 'CertApprovEmail', FCertApprovEmail) ;
WriteString (section, 'CertCommonName', FCertCommonName) ;
WriteString (section, 'CertContactEmail', FCertContactEmail) ;
WriteString (section, 'CertContactFirst', FCertContactFirst) ;
WriteString (section, 'CertContactLast', FCertContactLast) ;
WriteString (section, 'CertContactTitle', FCertContactTitle) ;
WriteString (section, 'CertCountry', FCertCountry) ;
WriteString (section, 'CertCsrOrigin', GetEnumName (TypeInfo (TCertCsrOrigin), Ord(CertCsrOrigin))) ;
WriteString (section, 'CertLocality', FCertLocality) ;
WriteString (section, 'CertOldCsrFile', CertOldCsrFile) ;
WriteString (section, 'CertOldPrvKey', CertOldPrvKey) ;
WriteString (section, 'CertOrgUnit', FCertOrgUnit) ;
WriteString (section, 'CertOrganization', FCertOrganization) ;
WriteString (section, 'CertOutFmts', IcsSetToStr(TypeInfo (TCertOutFmt), FCertOutFmts, SizeOf(FCertOutFmts))) ;
WriteString (section, 'CertPhone', FCertPhone) ;
WriteString (section, 'CertPostCode', FCertPostCode) ;
WriteString (section, 'CertSerNumType', GetEnumName (TypeInfo (TSerNumType), Ord(FCertSerNumType))) ;
WriteString (section, 'CertSignDigestType', GetEnumName (TypeInfo (TEvpDigest), Ord(FCertSignDigestType))) ;
WriteString (section, 'CertState', FCertState) ;
WriteInteger (section, 'CertValidity', FCertValidity) ;
WriteString (section, 'ChallgDoneDT', RFC3339_DateToStr(FChallgDoneDT)) ;
WriteString (section, 'ChallgExpireDT', RFC3339_DateToStr(FChallgExpireDT)); { V8.64 }
WriteString (section, 'ChallgStartDT', RFC3339_DateToStr(FChallgStartDT)) ;
WriteString (section, 'DirPubWebCert', FDirPubWebCert.CommaText) ;
WriteString (section, 'DirWellKnown', FDirWellKnown) ;
WriteString (section, 'FileFinalBundle', FFileFinalBundle) ;
WriteString (section, 'FileFinalCSR', FFileFinalCSR) ;
WriteString (section, 'FileFinalCert', FFileFinalCert) ;
WriteString (section, 'FileFinalPrvKey', FFileFinalPrvKey) ;
WriteString (section, 'IssueState', GetEnumName (TypeInfo (TIssueState), Ord(FIssueState)));
WriteString (section, 'NewCertCN', FNewCertCN) ;
WriteString (section, 'NewCertChainInfo', FNewCertChainInfo) ;
WriteString (section, 'NewCertEndDT', RFC3339_DateToStr(FNewCertEndDT)) ;
WriteString (section, 'NewCertErrs', FNewCertErrs) ;
WriteString (section, 'NewCertSAN', FNewCertSAN) ;
WriteString (section, 'NewCertStartDT', RFC3339_DateToStr(FNewCertStartDT)) ;
WriteString (section, 'NewCertValRes', GetEnumName (TypeInfo (TChainResult), Ord(FNewCertValRes))) ;
WriteInteger (section, 'NewOrderNum', FNewOrderNum) ;
WriteInteger (section, 'OrderAttempts', FOrderAttempts) ;
WriteString (section, 'OrderCertsDT', RFC3339_DateToStr(FOrderCertsDT)) ;
WriteString (section, 'OrderStartDT', RFC3339_DateToStr(FOrderStartDT)) ;
WriteString (section, 'PartFNameFinal', FPartFNameFinal) ;
WriteString (section, 'PartFNameOrder', FPartFNameOrder) ;
WriteString (section, 'PartFNameServer', FPartFNameServer.CommaText) ;
WriteInteger (section, 'PendingChallg', FPendingChallg) ;
WriteString (section, 'PrivKeyCipher', GetEnumName (TypeInfo (TSslPrivKeyCipher), Ord(FPrivKeyCipher))) ;
WriteString (section, 'PrivKeyPassword', FPrivKeyPassword) ; // encrypt password !!!!
WriteString (section, 'PrivKeyType', GetEnumName (TypeInfo (TSslPrivKeyType), Ord(FPrivKeyType))) ;
WriteString (section, 'ProductCertType', FProductCertType) ;
WriteString (section, 'ProductDVAuth', FProductDVAuth) ;
WriteString (section, 'ProductFeatures', FProductFeatures) ;
WriteInteger (section, 'ProductMaxSan', FProductMaxSan) ;
WriteString (section, 'ProductQuote', FProductQuote) ;
WriteString (section, 'SuppCertChallenge', GetEnumName (TypeInfo (TChallengeType), Ord(FSuppCertChallenge)));
WriteString (section, 'SuppOrderId', FSuppOrderId) ;
WriteString (section, 'SuppOrderRef', FSuppOrderRef) ;
WriteString (section, 'SuppCertProduct', FSuppCertProduct) ;
WriteString (section, 'ProductCA', FProductCA) ;
WriteString (section, 'ChallgSrvIP', FChallgSrvIP) ; { V8.65 }
WriteString (section, 'ChallgSrvIP2', FChallgSrvIP2) ; { V8.71 }
{$IFDEF MSCRYPT_Tools}
WriteString (section, 'MsCertLoc', GetEnumName (TypeInfo (TMsCertLocation), Ord(FMsCertLoc))); { V8.71 }
{$ENDIF}
WriteString (section, 'CertAcmeProfile', FCertAcmeProfile); { V9.5 }
if FAutoOrderComplete then temp := 'True' else temp := 'False' ; WriteString (section, 'AutoOrderComplete', temp) ; { V9.5 }
if FCertRenewNow then temp := 'True' else temp := 'False' ; WriteString (section, 'CertRenewNow', temp) ; { V9.5 }
WriteInteger (section, 'CertRenewDays', FCertRenewDays) ; { V9.5 }
WriteString (section, 'CertRenewCheckDT', RFC3339_DateToStr(FCertRenewCheckDT)) ; { V9.5 }
WriteString (section, 'CertRenewRetryDT', RFC3339_DateToStr(FCertRenewRetryDT)) ; { V9.5 }
WriteString (section, 'CertRenewalId', FCertRenewalId) ; { V9.5 }
WriteString (section, 'AcmeChallngReport', IcsEscapeCRLF(FAcmeChallngReport)) ; { V9.5 }
// write INI file
FControlFile.UpdateFile;
// erase any old SAN sections
FControlFile.ReadSections(FDBIniSections);
section := CntlDBSANPre + FCertCommonName + '=';
for J := 0 to FDBIniSections.Count - 1 do begin
if Pos(section, FDBIniSections[J]) = 1 then begin
flag := False;
if FCertSubAltNames.Count > 0 then begin
temp := Copy(FDBIniSections[J], Length(section), 999);
for I := 0 to FCertSubAltNames.Count - 1 do begin
if FCertSubAltNames[I].SADomain = temp then begin
flag := True;
break;
end;
end;
end;
if NOT flag then
FControlFile.EraseSection(FDBIniSections[J]);
end;
end;
// save Subject Alternate Names
temp := '';
FCertSANs.Clear;
if CertSubAltNames.Count > 0 then begin
// save current SAN sections
for I := 0 to FCertSubAltNames.Count - 1 do begin
with FCertSubAltNames[I] do begin
if SADomain = '' then Continue; // sanity check
FCertSANs.Add(SADomain);
section := CntlDBSANPre + FCertCommonName + '=' + SADomain;
WriteString (section, 'Domain', SADomain) ;
WriteString (section, 'DirWellKnown', SADirWellKnown) ;
WriteString (section, 'DirPubWebCert', SADirPubWebCert) ;
WriteString (section, 'ApprovalEmail', SAApprovalEmail) ;
WriteString (section, 'SAIssueState', GetEnumName (TypeInfo (TIssueState), Ord(SAIssueState))) ;
WriteString (section, 'SAStartDT', RFC3339_DateToStr(SAStartDT)) ;
WriteString (section, 'SADoneDT', RFC3339_DateToStr(SADoneDT)) ;
WriteString (section, 'SAValidResult', SAValidResult) ;
end;
end;
end;
section := CntlDBDomainPre + FCertCommonName;
WriteString (section, 'CertSubAltList', FCertSANs.CommaText) ;
end;
FControlFile.UpdateFile; // write INI file
DBReadSections;
if Assigned(FOnDomainsRefresh) then
FOnDomainsRefresh(Self);
Result := True;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
// V9.5 update renewal infomation dates, perhaps daily
function TSslX509Certs.DBWriteCNDomDates: Boolean; { V9.5 }
var
section, temp: string;
begin
Result := False;
if FCertCommonName = '' then begin { V8.71 }
LogEvent('Can not save domain with blank Common Name') ;
Exit;
end;
if NOT DBOpenINI(FDirCertWork, False) then begin
LogEvent('Failed to Open Account Database: ' + FDirCertWork);
Exit;
end;
section := CntlDBDomainPre + FCertCommonName;
with FControlFile do begin
WriteString (section, 'IssueState', GetEnumName (TypeInfo (TIssueState), Ord(FIssueState)));
WriteString (section, 'AcmeOrderObjUrl', FAcmeOrderObjUrl);
WriteString (section, 'ChallgExpireDT', RFC3339_DateToStr(FChallgExpireDT));
WriteInteger (section, 'CertRenewDays', FCertRenewDays) ;
if FCertRenewNow then temp := 'True' else temp := 'False' ; WriteString (section, 'CertRenewNow', temp) ;
WriteString (section, 'CertRenewCheckDT', RFC3339_DateToStr(FCertRenewCheckDT)) ;
WriteString (section, 'CertRenewRetryDT', RFC3339_DateToStr(FCertRenewRetryDT)) ;
WriteString (section, 'CertRenewalId', FCertRenewalId) ;
WriteString (section, 'NewCertEndDT', RFC3339_DateToStr(FNewCertEndDT)) ;
WriteString (section, 'NewCertStartDT', RFC3339_DateToStr(FNewCertStartDT)) ;
UpdateFile;
Result := True;
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
// delete certificate common name domain, perhaps with sub domains as well
function TSslX509Certs.DBDeleteCNDomain(const CNDomain: String): Boolean;
var
section: string;
J: Integer;
begin
Result := False;
if NOT DBOpenINI(FDirCertWork, False) then
Exit;
section := CntlDBDomainPre + CNDomain;
if FControlFile.SectionExists(section) then
FControlFile.EraseSection(section);
// erase any SAN sections
FControlFile.ReadSections(FDBIniSections);
section := IcsLowerCase(CntlDBSANPre + CNDomain + '=');
for J := 0 to FDBIniSections.Count - 1 do begin
if Pos(section, FDBIniSections[J]) = 1 then begin
FControlFile.EraseSection(FDBIniSections[J]);
end;
end;
FControlFile.UpdateFile; // write INI file
DBReadSections;
if Assigned(FOnDomainsRefresh) then FOnDomainsRefresh(Self);
Result := True;
FreeAndNil(FControlFile); { V9.6 make sure gets reloaded so old domain disappears }
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
// find SAB record for domain, allowing for wildcards
function TSslX509Certs.DBFindSAN(const adomain: String): Integer;
var
I: Integer;
begin
Result := -1;
for I := 0 to FCertSubAltNames.Count - 1 do begin
if (adomain = FCertSubAltNames[I].SADomain) then begin
Result := I;
Exit;
end
// wild card removes *. from domain
else if (Pos(adomain, FCertSubAltNames[I].SADomain) > 1) and (Pos ('*.', FCertSubAltNames[I].SADomain) = 1) then begin
Result := I;
Exit;
end;
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TSslX509Certs.DBFindChallengeNum(const Domain: String; Wildcard: Boolean): Integer;
var
I: Integer;
begin
Result := -1;
if FChallengesTot = 0 then
Exit;
for I := 0 to Length(FChallengeItems) - 1 do begin
if (FChallengeItems [I].CDomain = IcsLowerCase(Domain)) and (FChallengeItems [I].CWildcard = Wildcard) then begin { V8.64 }
Result := I;
Exit;
end;
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
// find first blank challenge in array, or increase array size
function TSslX509Certs.DBFreeChallengeNum: Integer;
var
I, tot: Integer;
begin
tot := Length(FChallengeItems);
if tot > 0 then begin
for I := 0 to Length(FChallengeItems) - 1 do begin
if FChallengeItems [I].CDomain = '' then begin
Result := I;
Exit;
end;
end;
end;
SetLength(FChallengeItems, tot + 8);
for I := tot to Length(FChallengeItems) - 1 do
FChallengeItems [I].CDomain := ''; // clear all records
Result := tot;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TSslX509Certs.DBReadChallenges: Boolean;
var
section: string;
I, Days: Integer;
StartedDT, ExpiredDT: TDateTime;
Updated: Boolean;
ChallgType: TChallengeType;
begin
Result := False;
if NOT DBReadSections then
Exit;
FChallengesTot := 0;
Updated := False;
SetLength(FChallengeItems, FDBIniSections.Count + 2);
for I := 0 to Length(FChallengeItems) - 1 do
FChallengeItems [I].CDomain := ''; // clear all records
for I := 0 to FDBIniSections.Count - 1 do begin
if Pos(CntlDBChallenge, FDBIniSections[I]) = 1 then begin
section := FDBIniSections[I];
with FControlFile do begin
{ V8.63 expire and remove challenge after 24 hours or a week }
StartedDT := RFC3339_StrToDate(ReadString (section, 'CStartDT', '')) ;
ExpiredDT := RFC3339_StrToDate(ReadString (section, 'CExpireDT', '')) ; // V8.64
ChallgType := TChallengeType(GetEnumValue (TypeInfo (TChallengeType), ReadString (section, 'CType', ''))) ;
if ChallgType > High(TChallengeType) then ChallgType := ChallNone;
if ExpiredDT < 10 then begin
Days := 1;
if (ChallgType in [ChallDNSAuto, ChallDnsAcnt, ChallDnsMan, ChallEmail, ChallManual]) then
Days := 7;
ExpiredDT := StartedDT + Days;
end;
if ((ExpiredDT + 1) < Now) then begin // remove out of date challenge, V9.5 add one day for time zone problems
LogEvent ('Removing expired challenge: ' + section + ', Expired: ' + IcsDateTimeToAStr(ExpiredDT)); { V9.5 add date }
EraseSection(section);
Updated := True;
Continue;
end;
with FChallengeItems [FChallengesTot] do begin
CDomain := ReadString (section, 'CDomain', '') ;
CWildcard := ReadBool (section, 'CWildcard', False) ;
CCommonName := ReadString (section, 'CCommonName', '') ;
CSanIdx := ReadInteger (section, 'CSanIdx', -1) ;
CSuppOrderId := ReadString (section, 'CSuppOrderId', '') ;
CDirWellKnown := ReadString (section, 'CDirWellKnown', '') ;
CDirPubWebCert := ReadString (section, 'CDirPubWebCert', '') ;
CWKFullName := ReadString (section, 'CWKFullName', '') ;
CSupplierProto := TSupplierProto(GetEnumValue (TypeInfo (TSupplierProto), ReadString (section, 'CSupplierProto', ''))) ;
CType := ChallgType;
CIssueState := TIssueState(GetEnumValue (TypeInfo (TIssueState), ReadString (section, 'CIssueState', ''))) ;
if CIssueState > High(TIssueState) then CIssueState := IssStateNone;
CAuthzURL := ReadString (section, 'CAuthzURL', '') ;
ChallgToken := IcsUnEscapeCRLF(ReadString (section, 'ChallgToken', '')) ;
ChallengeURL := ReadString (section, 'ChallengeURL', '') ;
CPage := ReadString (section, 'CPage', '') ;
CResp := IcsUnEscapeCRLF(ReadString (section, 'CResp', '')) ;
CDNSValue := ReadString (section, 'CDNSValue', '') ;
CAcmeAlpnCert := ReadString (section, 'CAcmeAlpnCert', '') ; // V8.62
CStartDT := StartedDT;
CExpireDT := ExpiredDT;
CDoneDT := RFC3339_StrToDate(ReadString (section, 'CDoneDT', '')) ;
CValidResult := ReadString (section, 'CValidResult', '') ;
end;
FChallengesTot := FChallengesTot + 1;
end;
end;
end;
LogEvent('Number of domain challenges found: ' + IntToStr(FChallengesTot));
if Updated then
FControlFile.UpdateFile; // write INI file
Result := True;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
// add or update challenge in array
function TSslX509Certs.DBAddChallenge(Item: TChallengeItem): Integer;
begin
Result := DBFindChallengeNum(Item.CDomain, Item.CWildcard);
if Result < 0 then begin
Result := DBFreeChallengeNum;
FChallengesTot := FChallengesTot + 1;
end;
FChallengeItems [Result] := Item;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
// reemove challenge from array by clearing domain
function TSslX509Certs.DBRemoveChallenge(ChallgNum: Integer): Boolean;
begin
Result := False;
if (ChallgNum >= 0) and (ChallgNum < Length(FChallengeItems)) then begin
FChallengeItems [ChallgNum].CDomain := '';
FChallengesTot := FChallengesTot - 1;
Result := True;
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TSslX509Certs.DBWriteOneChallenge(Item: TChallengeItem): Integer;
var
section: string;
begin
Result := -1;
if NOT DBOpenINI(FDirCertWork, False) then
Exit;
with Item do begin
CDomain := IcsLowerCase(CDomain);
CCommonName := IcsLowerCase(CCommonName);
if CWildcard then { V8.64 may have separate challenges for wild and host domains }
section := CntlDBChallenge + 'wild-' + CDomain
else
section := CntlDBChallenge + 'host-' + CDomain;
with FControlFile do begin
WriteString (section, 'CDomain', CDomain) ;
WriteBool (section, 'CWildcard', CWildcard) ;
WriteString (section, 'CCommonName', CCommonName) ;
WriteInteger (section, 'CSanIdx', CSanIdx) ;
WriteString (section, 'CSuppOrderId', CSuppOrderId) ;
WriteString (section, 'CDirWellKnown', CDirWellKnown) ;
WriteString (section, 'CDirPubWebCert', CDirPubWebCert) ;
WriteString (section, 'CWKFullName', CWKFullName) ;
WriteString (section, 'CSupplierProto', GetEnumName (TypeInfo (TSupplierProto), Ord(CSupplierProto))) ;
WriteString (section, 'CType', GetEnumName (TypeInfo (TChallengeType),Ord(CType))) ;
WriteString (section, 'CIssueState', GetEnumName (TypeInfo (TIssueState),Ord(CIssueState))) ;
WriteString (section, 'CAuthzURL', CAuthzURL) ;
WriteString (section, 'ChallgToken', IcsEscapeCRLF(ChallgToken)) ;
WriteString (section, 'ChallengeURL', ChallengeURL) ;
WriteString (section, 'CPage', CPage) ;
WriteString (section, 'CResp', IcsEscapeCRLF(CResp)) ;
WriteString (section, 'CDNSValue', CDNSValue) ;
WriteString (section, 'CAcmeAlpnCert', CAcmeAlpnCert) ; // V8.62
if CStartDT < 10 then CStartDT := Now; // sanity check, needed to expire record
WriteString (section, 'CStartDT', RFC3339_DateToStr(CStartDT)) ;
WriteString (section, 'CDoneDT', RFC3339_DateToStr(CDoneDT)) ;
WriteString (section, 'CExpireDT', RFC3339_DateToStr(CExpireDT)) ; // V8.64
WriteString (section, 'CValidResult', CValidResult) ;
end;
end;
FControlFile.UpdateFile; // write INI file
// now update array
Result := DBAddChallenge(Item);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TSslX509Certs.DBDeleteChallenge(const Domain: String; Wildcard: Boolean): Boolean;
var
section: string;
begin
Result := False;
if NOT DBOpenINI(FDirCertWork, False) then
Exit;
if WildCard then { V8.64 may have separate challenges for wild and host domains }
section := CntlDBChallenge + 'wild-' + Domain
else
section := CntlDBChallenge + 'host-' + Domain;
if NOT FControlFile.SectionExists(section) then
Exit;
FControlFile.EraseSection(section);
FControlFile.UpdateFile; // write INI file
Result := True;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TSslX509Certs.BuildSANList;
var
flag: Boolean;
I: Integer;
PubDir: string;
begin
// make sure common name is also in SANs, so we can ignore it subsequently
flag := false;
if FCertSubAltNames.Count > 0 then begin
for I := 0 to FCertSubAltNames.Count - 1 do begin
if FCertSubAltNames[I].SADomain <> fCertCommonName then flag := True;
end;
end;
if NOT flag then begin
PubDir := '';
if FDirPubWebCert.Count > 0 then PubDir := FDirPubWebCert[0];
FCertSubAltNames.AddItem(fCertCommonName, FDirWellKnown, PubDir, FCertApprovEmail);
end;
FCertSANTot := FCertSubAltNames.Count;
FCertSANs.Clear;
for I := 0 to FCertSANTot - 1 do
FCertSANs.Add(FCertSubAltNames[I].SADomain);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
// set partial directory names for work and final certificate dictorties
function TSslX509Certs.SetPartFNames(ReadOnly: Boolean = False): Boolean;
var
CN, NewDir: string;
I: Integer;
begin
FPartFNameWork := '';
FPartFNameFinal := '';
FPartFNameOrder := '';
FPartFNameServer.Clear;
FPartFNameServer.Sorted := True;
FPartFNameServer.Duplicates := dupIgnore;
FPartFNameServer.CaseSensitive := false;
Result := False ;
// V9.1 fatal error
if FDirCertWork = '' then begin
FLastError := 'No certificate work directory set to build file names';
LogEvent(FLastError);
exit;
end;
// work dir where we will save our certificates and keys
if NOT ReadOnly then begin
if NOT ForceDirectories (FDirCertWork) then begin
FLastError := 'Failed to create directory: ' + FDirCertWork;
LogEvent(FLastError);
exit;
end;
end;
// V9.1 fatal error
if NOT IcsDirExists(FDirCertWork) then begin
FLastError := 'Certificate order work directory not found: ' + FDirCertWork;
LogEvent(FLastError);
exit;
end;
// create certificate file name from domain common name, change . to _ and * to x
CN := IcsBuildCertFName(FCertCommonName) ;
FPartFNameWork := IncludeTrailingPathDelimiter(FDirCertWork) + FNewCertPrefix + 'work-' + CN ;
if fSuppOrderId <> '' then begin
FPartFNameOrder := IncludeTrailingPathDelimiter(FDirCertWork) + FNewCertPrefix + FSuppOrderId + '-' + CN ;
FPartFNameWork := FPartFNameOrder;
end;
fPartFNameFinal := IncludeTrailingPathDelimiter(fDirCertWork) + CN ;
// build list of remote web server certificate locations, ignoing duplicates
// also check work directory and remote server are not the same
if (FDirPubWebCert.Count > 0) then begin
for I := 0 to FDirPubWebCert.Count - 1 do begin
NewDir := FDirPubWebCert[I];
if (Pos('\\', NewDir) = 1) or (Pos (':', NewDir) = 2) then begin { V8.65 sanity check }
NewDir := IncludeTrailingPathDelimiter(NewDir);
FDirPubWebCert[I] := NewDir;
if NewDir <> fPartFNameFinal then
FPartFNameServer.Add(NewDir);
end;
end;
end;
if (FCertSubAltNames.Count > 0) then begin
for I := 0 to FCertSubAltNames.Count - 1 do begin
NewDir := FCertSubAltNames[I].SADirPubWebCert;
if (Pos('\\', NewDir) = 1) or (Pos (':', NewDir) = 2) then begin { V8.65 sanity check }
NewDir := IncludeTrailingPathDelimiter(NewDir);
if NewDir <> fPartFNameFinal then
FPartFNameServer.Add(NewDir);
end;
end;
end;
// see if creating remote directories
if (NOT ReadOnly) and (FPartFNameServer.Count > 0) then begin
for I := 0 to FPartFNameServer.Count - 1 do begin
if NOT ForceDirectories (FPartFNameServer[I]) then begin
LogEvent ('Failed to create certificate directory: ' + FPartFNameServer[I]);
Exit;
end;
end;
end;
// finally add common domain name
FPartFNameServer.Sorted := False; // now editing list
if (FPartFNameServer.Count > 0) then begin
for I := 0 to FPartFNameServer.Count - 1 do begin
FPartFNameServer[I] := IncludeTrailingPathDelimiter(FPartFNameServer[I]) + CN ;
end;
end;
Result := True ;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TSslX509Certs.SetFullFileNames (const FileDir: String) ;
begin
FFileCSR := FileDir + FileSuffCSR ;
FFilePrvKey := FileDir + FileSuffPKey ;
FFileCertPem := FileDir + FileSuffCertPem ;
FFileInterPem := FileDir + FileSuffInterPem ;
FFileBundPem := FileDir + FileSuffBundPem ;
FFileBundP12 := FileDir + FileSuffBundP12 ;
FFileBundP7 := FileDir + FileSuffBundP7 ;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
// create new private key and certificate signing request
function TSslX509Certs.CreateKeyandReq(IsCA: Boolean = False): boolean; { V9.1 add CA }
var
I: Integer;
SocFamily: TSocketFamily; { V9.5 }
begin
Result := False ;
// see if using old CSR
if FCertCsrOrigin = CsrOriginFile then begin
if NOT FNewSslCert.IsReqLoaded then begin
LogEvent ('No old certificate request loaded: ' + FCertOldCsrFile);
Exit;
end;
if NOT FNewSslCert.IsPKeyLoaded then begin
LogEvent ('No old private key loaded: ' + FCertOldPrvKey);
Exit;
end;
end
else begin
if (fCertCommonName = '') { or (FCertSubAltNames.Count = 0)} then begin { V9.1 optional }
LogEvent ('No domain name for request');
Exit;
end;
LogEvent ('Generating private and public key pair, please wait');
try
FNewSslCert.X509Req := Nil; { V8.64 before key creation }
if FPrivKeyType < PrivKeyRsa2048 then
FPrivKeyType := PrivKeyRsa2048; { V8.64 sanity check }
FNewSslCert.PrivKeyType := FPrivKeyType;
FNewSslCert.PrivateKey := Nil;
FNewSslCert.DoKeyPair;
if FNewSslCert.IsPKeyLoaded then { V8.64 check actually created }
LogEvent ('Generated private and public key pair OK:' + IcsCRLF + FNewSslCert.PrivateKeyInfo)
else begin
LogEvent ('Failed to generate private key - bad key parameters?');
exit ;
end;
except
on E:Exception do begin
LogEvent ('Failed to generate private key - ' + E.Message);
exit ;
end;
end;
LogEvent ('Generating certificate signing request');
try
with fNewSslCert do begin
if WSocketIsIP(fCertCommonName, SocFamily) then { V9.5 cmmon name not allowed IP address }
CommonName := ''
else
CommonName := fCertCommonName;
AltDNSList.Clear;
AltIpList.Clear;
if FCertSubAltNames.Count > 0 then begin { V9.1 optional }
for I := 0 to FCertSubAltNames.Count - 1 do begin
if WSocketIsIP(FCertSubAltNames[I].SADomain, SocFamily) then { V9.5 allow IP addresses }
AltIpList.Add(FCertSubAltNames[I].SADomain)
else
AltDNSList.Add(FCertSubAltNames[I].SADomain);
end;
end;
CertDigest := fCertSignDigestType ;
Country := FCertCountry;
State := FCertState;
Locality := FCertLocality;
Organization := FCertOrganization;
OrgUnit := FCertOrgUnit;
Descr := FCertDescr;
Email := FCertContactEmail;
// V9.1 set extensions
BasicIsCA := IsCA; { V9.1 }
ExpireDays := FCertValidity;
BasicPathLen := 0;
KeyCertSign := False;
KeyCRLSign := False;
KeyDigiSign := False;
KeyDataEnc := False;
KeyKeyEnc := True;
KeyKeyAgree := False;
KeyNonRepud := False;
KeyExtClient := False;
KeyExtServer := True; { V9.1 make sure IDN processed }
KeyExtEmail := False;
KeyExtCode := False;
end;
FNewSslCert.DoCertReqProps;
LogEvent('Created certificate signing request OK:' + IcsCRLF + FNewSslCert.ReqCertInfo);
except
on E:Exception do begin
LogEvent ('Failed to generate CSR - ' + E.Message);
exit ;
end;
end;
end;
try
FNewSslCert.PrivateKeySaveToPemFile (fFilePrvKey, FPrivKeyPassword, FPrivKeyCipher) ;
fPrvKeyLines := FNewSslCert.SavePKeyToText (FPrivKeyPassword, FPrivKeyCipher);
LogEvent ('Saved private key file with ' + SslPrivKeyCipherLits[TSslPrivKeyCipher(FPrivKeyCipher)] +
' key cipher: ' + FFilePrvKey); { V8.67 }
if FLogPkeys then LogEvent (IcsCRLF + fPrvKeyLines + IcsCRLF) ;
FNewSslCert.SaveReqToFile(fFileCSR, true);
fCSRLines := FNewSslCert.SaveReqToText (false) ; // no comments, confused order
LogEvent ('Saved certificate signing request file: ' + fFileCSR + IcsCRLF + IcsCRLF + fCSRLines + IcsCRLF) ;
except
on E:Exception do begin
LogEvent ('Failed to save CSR or key - ' + E.Message);
exit ;
end;
end;
Result := true;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
// check old CSR file and old private key files, keep common name and SANs
function TSslX509Certs.CheckCSR(RequirePkey: Boolean = True): Boolean;
var
ReqSANs: TStringList;
PubDir: String;
I: Integer;
begin
Result := False;
if (FCertOldCsrFile = '') or (NOT FileExists(FCertOldCsrFile)) then begin
LogEvent ('Can not find old certificate signing request file: ' + FCertOldCsrFile);
Exit;
end;
if (FCertOldPrvKey = '') or (NOT FileExists(FCertOldPrvKey)) then begin
LogEvent ('Can not find old private key gile: ' + FCertOldPrvKey);
if RequirePkey then
Exit;
end;
try
FNewSslCert.LoadReqFromFile(FCertOldCsrFile);
if NOT FNewSslCert.IsReqLoaded then begin
LogEvent ('Failed to load CSR file: ' + FCertOldCsrFile);
Exit;
end;
LogEvent('Loaded certificate request OK' + IcsCRLF + FNewSslCert.ReqCertInfo);
if (FCertOldPrvKey <> '') then begin
try
FNewSslCert.PrivateKeyLoadFromPemFile (FCertOldPrvKey, FPrivKeyPassword) ;
except
on E:Exception do begin
LogEvent ('Failed to load private key file: ' + E.Message);
end;
end;
if NOT FNewSslCert.IsPKeyLoaded then begin
LogEvent ('Failed to load old private key file: ' + FCertOldPrvKey);
if RequirePkey then
Exit;
end;
end;
FCertCommonName := FNewSslCert.ReqSubjCName;
FCertSubAltNames.Clear;
PubDir := '';
if FDirPubWebCert.Count > 0 then PubDir := FDirPubWebCert[0];
FCertSubAltNames.AddItem(FCertCommonName, FDirWellKnown, PubDir);
ReqSANs := TStringList.Create;
try
ReqSANs.Text := FNewSslCert.ReqSubjAltNameDNS;
if ReqSANs.Count > 0 then begin
for I := 0 to ReqSANs.Count - 1 do begin
if (ReqSANs[I] <> FCertCommonName) then
FCertSubAltNames.AddItem(ReqSANs[I], FDirWellKnown, PubDir);
end;
end;
finally
ReqSANs.Free;
end;
except
on E:Exception do begin
LogEvent ('Failed to Load CSR File: ' + E.Message);
end;
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{ V9.5 get certificate info for Acme renewal information and ordernew requests }
{ built from certificate AuthorityKeyId and SerialNum }
function TSslX509Certs.GetAcmeRenewalInfo(Cert: TX509Base): String;
function TrimB64(const Value: String): String; // remove base64 padding = from end
var
Len: Integer;
begin
Result := Value;
while true do begin
len := Length(Result);
if (len <= 1) then
Exit;
if Result[len] <> '=' then
Exit;
SetLength(Result, len - 1);
end;
end;
begin
Result := '';
if NOT Assigned(Cert) then
Exit;
// LogEvent ('AcmeRenewalInfo, Auth=' + Cert.AuthorityKeyId + ', Serial=' + Cert.SerialNumHex); // !!! TEMP DIAG
Result := TrimB64(IcsBase64UrlEncodeTB(IcsHexToTB(AnsiString(Cert.AuthorityKeyId)))) + '.' +
TrimB64(IcsBase64UrlEncodeTB(Cert.SerialNumTB));
LogEvent ('AcmeRenewalInfo, Combined=' + Result); // !!! TEMP DIAG
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{ saves up to three copies of all certificate files:
1 - work directory, includes unique order number for historic purposes
2 - work directory, final cert name without order, replacing older version
3 - server directory, final cert name without order, replacing older version
Also validates certificate chain to ensure intermediate matches and CA available
Returns false on failure, with LastError
}
function TSslX509Certs.SaveCertificateFiles(const CertName: string): Boolean;
var
P12KeyCipher, PemKeyCipher: TSslPrivKeyCipher;
P12Password, FDir, CName, IName, SAName: String;
I, J: Integer;
X509List: TX509List; { V8.67 }
function TestBundle(const FName, PW: String): Boolean; { V8.67 check we can open bundle }
var
TestCert: TX509Base;
begin
Result := False;
TestCert := TX509Base.Create(Nil);
try
try
TestCert.LoadFromFile(FName, croTry, croTry, PW);
Result := True;
except
on E:Exception do begin
LogEvent ('Failed to open certificate bundle: ' + E.Message + ' - ' + FName);
end;
end;
finally
TestCert.Free;
end;
end;
function SaveAllCerts: Boolean;
begin
Result := False;
try
if (FCSRLines <> '') and (OutFmtReq in FCertOutFmts) then begin
SaveDataFile (FFileCSR, FCSRLines);
LogEvent('Saved certificate request file: ' + FFileCSR);
end;
if (OutFmtSep in FCertOutFmts) then begin
FNewSslCert.PrivateKeySaveToPemFile (FFilePrvKey, FPrivKeyPassword, PemKeyCipher);
LogEvent ('Saved private key file with ' +
SslPrivKeyCipherLits[TSslPrivKeyCipher(PemKeyCipher)] + ' key cipher: ' + FFilePrvKey); { V8.67 }
FNewSslCert.SaveToPemFile(FFileCertPem, False, True, False); // no private key or inters
LogEvent('Saved PEM certificate alone: ' + FFileCertPem);
if FNewSslCert.IsInterLoaded then begin
FNewSslCert.SaveIntersToToPemFile(FFileInterPem, True);
LogEvent('Saved PEM intermediate certificate: ' + FFileInterPem);
end;
end;
if (OutFmtBudl in FCertOutFmts) then begin
FNewSslCert.SaveToPemFile(FFileBundPem, True, True, FNewSslCert.IsInterLoaded, { V8.64 }
FPrivKeyPassword, PemKeyCipher); // add private key and inters
LogEvent('Saved PEM bundle with certificate, key and intermediate with ' +
SslPrivKeyCipherLits[TSslPrivKeyCipher(PemKeyCipher)] + ' key cipher: ' + FFileBundPem); { V8.67 }
end;
if (OutFmtP12 in FCertOutFmts) then begin
FNewSslCert.SaveToP12File(fFileBundP12, P12Password, FNewSslCert.IsInterLoaded, P12KeyCipher); { V8.64 add private key and inters }
LogEvent('Saved PKCS12 bundle with certificate, key and intermediate with ' +
SslPrivKeyCipherLits[TSslPrivKeyCipher(P12KeyCipher)] + ' key cipher: ' + FFileBundP12); { V8.67 }
end;
if (FNewCertP7Lines <> '') and (OutFmtP7 in FCertOutFmts) then begin
SaveDataFile (FFileBundP7, FNewCertP7Lines) ;
LogEvent('Saved PKCS7 bundle: ' + FFileBundP7);
end;
Result := True;
except
on E:Exception do begin
FLastError := 'Failed to save file - ' + E.Message;
LogEvent(FLastError);
end;
end;
end;
begin
Result := False;
FLastError := ''; { V9.5 }
LogTimeStamp;
LogEvent ('Saving SSL certificate files for: ' + CertName);
if FPartFNameOrder = '' then begin
FLastError := 'Can not save certificate files without directory';
LogEvent(FLastError);
Exit ;
end;
SetFullFileNames (FPartFNameOrder);
if (Pos(PEM_STRING_HDR_BEGIN, FNewCertLines) = 0) then begin
FLastError := 'Did not teceive a valid PEM certificate';
LogEvent(FLastError);
Exit ;
end;
ClearRenewals; { V9.5 clear old cert and renewal stuff }
// sanity check, must save some files
if NOT ((OutFmtSep in FCertOutFmts) OR (OutFmtBudl in
FCertOutFmts) OR (OutFmtP12 in FCertOutFmts)) then
FCertOutFmts := FCertOutFmts + [OutFmtSep];
// Windows will not load PKCS12 file without a password, so create one if missing
FPrivKeyPassword := Trim(FPrivKeyPassword);
P12KeyCipher := PrivKeyEncNone;
PemKeyCipher := PrivKeyEncNone;
if (OutFmtP12 in FCertOutFmts) and (OutFmtPwP12 in FCertOutFmts) then begin { V8.67 now configurable, but defaults true }
P12KeyCipher := FPrivKeyCipher;
P12Password := FPrivKeyPassword;
if (P12Password = '') then begin { V8.67 simplified }
P12Password := 'password';
LogEvent('Set required PKCS12 file password to "password"');
end;
if (P12KeyCipher = PrivKeyEncNone) then
P12KeyCipher := PrivKeyEncAES256;
{ V8.67 is 3DES available, prefer that so older versions of Windows will load our PFX file }
{ V9.3 no longer prefer TripleDES, too old }
// if (ICS_OPENSSL_VERSION_MAJOR < 3) or ICS_OSSL3_LOADED_LEGACY then
// P12KeyCipher := PrivKeyEncTripleDES
if (P12KeyCipher = PrivKeyEncTripleDES) and (NOT ICS_OSSL3_LOADED_LEGACY) then { V9.4 change 3DES if not available }
P12KeyCipher := PrivKeyEncAES256;
end;
{ V8.67 see if protecting PEM keys }
{ note: Apache web server can not use encrypted private keys }
if (OutFmtPwPem in FCertOutFmts) and (FPrivKeyPassword <> '') then begin
PemKeyCipher := FPrivKeyCipher;
end;
// V8.67 load all downloaded certificates from CertLines and check what we received
// build final bundle in FNewSslCert
X509List := TX509List.Create(self);
try
try
X509List.LoadAllFromString(FNewCertLines);
if (X509List.Count = 0) then begin
FLastError := 'Did not receive a valid PEM certificate';
LogEvent(FLastError);
exit ;
end;
for J := 0 to X509List.Count - 1 do begin
CName := IcsStndIPv6Str(X509List[J].SubjectCName);
IName := X509List[J].IssuerCName;
SAName := X509List[J].SubAltAllDisp; { V9.6 combines DNS and IP addresses }
if (CName = '') then
CName := X509List[J].ListAllNames[0];
// look for main certificate by common name
LogEvent('Certificate ' + IntToStr(J + 1) + ', Common Name: ' + CName + ', SAN: ' + SAName + ', Issuer: ' + IName);
if (CertName = CName) or (Pos (CertName, SAName) > 0) then begin
FNewCertCN := CName;
FNewCertSAN := SAName;
FNewSslCert.X509 := X509List[J].X509;
if NOT FNewSslCert.CheckCertAndPKey then
LogEvent ('!!! WARNING, private key does not match certificate public key')
else
LogEvent ('Found order certificate with matching private key, subject alt names (SAN): ' + FNewCertSAN);
end
// any others are intermediates, don't want any self signed root certificates
else begin
// V8.68 see if removing Lets Encrypt intermediate for expired root CA, needed for old Androids only
if NOT FKeepOldCA then begin
if IName = 'DST Root CA X3' then begin
LogEvent ('Ignored intermediate for expired root: ' + IName);
continue;
end;
if CName = 'GTS Root R1' then begin { V9.5 Google root signed by Globalsign }
LogEvent ('Ignored intermediate for cross signed root: ' + CName);
continue;
end;
end;
if X509List[J].SelfSigned then
LogEvent ('!!! WARNING, Ignored self signed certificate: ' + CName)
else
FNewSslCert.AddToInters(X509List[J].X509); // keep intermediate for our bundle
end;
end;
if NOT FNewSslCert.IsCertLoaded then begin
FLastError := 'Did not find certificate in downloaded PEM bundle: ' + CertName;
LogEvent(FLastError);
Exit;
end;
except
on E:Exception do begin
FLastError := 'Failed to recognise downloaded PEM bundle - ' + E.Message;
LogEvent(FLastError);
exit ;
end;
end;
finally
X509List.Free;
end;
// save separate PEM file
if (OutFmtSep in FCertOutFmts) then begin
FNewSslCert.SaveToPemFile(FFileCertPem, False, True, False); // no private key or inters
LogEvent('Saved PEM certificate alone: ' + FFileCertPem);
FFileFinalBundle := FFileCertPem; // in case no bundle specified
end;
// keep issue dates
FNewCertEndDT := FNewSslCert.ValidNotAfter;
FNewCertStartDT := FNewSslCert.ValidNotBefore;
FCertRenewDays := Trunc(FNewCertEndDT - FNewCertStartDT) div 3; // V9.5 temporary in case renewal info fails
// V9.5 get renewal recommended dates from server
FCertRenewalId := GetAcmeRenewalInfo(FNewSslCert);
AcmeV2RenewalInfo;
FCertRenewNow := False;
// V9.5 Buypass may need local intermediate - no longer supporting Acme
{ if (NOT FNewSslCert.IsInterLoaded) and (FAcmeSupplier in [AcmeBuypass, AcmeBuypassTest]) then begin
FileInter := IncludeTrailingPathDelimiter(GSSL_CERTS_DIR) + FileBuypassInter;
if FileExists(FileInter) then begin
LogEvent ('Adding local BuyPass intermediate certificate to bundle');
try
FNewSslCert.LoadIntersFromPemFile(FileInter);
except
on E:Exception do begin
LogEvent('Failed to add intermediate certificate - ' + E.Message);
end;
end;
end;
end; }
// OwnCA only, get intermediate
if (NOT FNewSslCert.IsInterLoaded) and (FNewInterLines <> '') then begin { V8.64 }
LogEvent (IcsCRLF + 'PEM intermediate certificate' + IcsCRLF + FNewInterLines + IcsCRLF);
if (Pos(PEM_STRING_HDR_BEGIN, FNewInterLines) = 0) then begin
LogEvent ('Did not receive a valid PEM intermediate certificate: ' + FNewInterLines);
FNewInterLines := '';
end
else begin
try
if FNewInterLines <> '' then
FNewSslCert.LoadIntersFromString(FNewInterLines);
except
on E:Exception do begin
LogEvent('Failed to recognise intermediate certificate - ' + E.Message);
end;
end;
end;
end;
// save inter as separate file
if FNewSslCert.IsInterLoaded and (OutFmtSep in FCertOutFmts) then begin
try
FNewSslCert.SaveIntersToToPemFile(FFileInterPem, True);
LogEvent('Saved PEM intermediate certificate: ' + FFileInterPem);
except
on E:Exception do begin
LogEvent ('Failed to recognise intermediate certificate - ' + E.Message);
end;
end;
end;
// save PKCS7 file
if (FNewCertP7Lines <> '') and (OutFmtP7 in FCertOutFmts) then begin
LogEvent(IcsCRLF + 'PEM PKCS7 certificate' + IcsCRLF + FNewCertP7Lines + IcsCRLF) ;
SaveDataFile(FFileBundP7, FNewCertP7Lines) ;
end;
// log certificate content
LogEvent (IcsCRLF + 'Certificate Details: ' + IcsCRLF + FNewSslCert.CertInfo(False) + IcsCRLF + IcsCRLF);
// save PEM bundle file for Apache and PKCS12 bundle for Windows, both with key passworded
try
if (OutFmtBudl in FCertOutFmts) then begin
FNewSslCert.SaveToPemFile(FFileBundPem, True, True, FNewSslCert.IsInterLoaded, { V8.64 }
FPrivKeyPassword, PemKeyCipher); // add private key and inters
LogEvent('Saved PEM bundle with certificate, key and intermediate with ' +
SslPrivKeyCipherLits[TSslPrivKeyCipher(PemKeyCipher)] + ' key cipher: ' + fFileBundPem);
FFileFinalBundle := FFileBundPem;
if NOT TestBundle(FFileBundPem, FPrivKeyPassword) then begin { V8.67 check we can open bundle }
FLastError := 'Failed to open new PEM bundle - ' + FFileBundPem;
LogEvent(FLastError);
Exit;
end;
end;
if (OutFmtP12 in FCertOutFmts) then begin
FNewSslCert.SaveToP12File(FFileBundP12, P12Password, FNewSslCert.IsInterLoaded, { V8.64 }
P12KeyCipher); // add private key and inters
LogEvent('Saved PKCS12 bundle with certificate, key and intermediate with ' +
SslPrivKeyCipherLits[TSslPrivKeyCipher(P12KeyCipher)] + ' key cipher: ' + FFileBundP12);
if NOT (OutFmtBudl in FCertOutFmts) then { V8.69 prioritise PEM over P12 }
FFileFinalBundle := FFileBundP12;
if NOT TestBundle(FFileBundP12, P12Password) then begin { V8.67 check we can open bundle }
FLastError := 'Failed to open new PKCS12 bundle - ' + FFileBundP12;
LogEvent(FLastError);
Exit;
end;
end;
except
on E:Exception do
begin
FLastError := 'Failed to save bundle - ' + E.Message;
LogEvent(FLastError);
Exit;
end;
end;
// now validate and report certificate chain
try
if NOT IcsSslRootCAStore.InitFlag then { V9.1 if internal not loaded, do it }
IcsSslRootCAStore.Initialise;
{ V8.47 warning, currently only checking first Host name }
FNewCertValRes := FNewSslCert.ValidateCertChain(CertName, IcsSslRootCAStore, FNewCertChainInfo, FNewCertErrs, 30);
if FNewCertValRes = chainOK then
LogEvent ('SSL certificate chain validated OK: ' + IcsCRLF + FNewCertChainInfo + IcsCRLF + IcsCRLF)
else begin
if FNewCertValRes = chainWarn then
FNewCertErrs := 'Chain Warning - ' + FNewCertErrs
else begin
FNewCertErrs := 'Chain Failed - ' + FNewCertErrs;
LogEvent ('SSL certificate errors - ' + FNewCertErrs + IcsCRLF + IcsCRLF);
end;
end;
FNewCertChainInfo := IcsEscapeCRLF(FNewCertChainInfo);
{ V8.67 truncate chain info to avoid overloading DB INI file }
if Length(FNewCertChainInfo) > 800 then { V9.2 was 1000, now 800 }
SetLength(FNewCertChainInfo, 800);
FNewCertErrs := IcsEscapeCRLF(FNewCertErrs);
except
on E:Exception do begin
FLastError := 'Failed to validate chain - ' + E.Message;
LogEvent(FLastError);
Exit;
end;
end;
FFileFinalCSR := FFileCSR;
FFileFinalPrvKey := FFilePrvKey;
FFileFinalCert := FFileCertPem;
// finally save files again without order number, locally
LogEvent ('Saving final versions of all files without order numbers locally');
SetFullFileNames (FPartFNameFinal);
if NOT SaveAllCerts then begin
if NOT SaveAllCerts then // two repeats
Exit;
end;
// pending - did order succeed if some of this copying failed!!!!
// see if copying files to web server directories
if (FPartFNameServer.Count > 0) then begin
LogEvent ('Saving final versions of all files without order numbers on server');
for I := 0 to FPartFNameServer.Count - 1 do begin
FDir := FPartFNameServer[I];
if (Pos ('\\', FDir) = 1) or (Pos (':', FDir) = 2) then begin { V8.64 }
SetFullFileNames (FDir);
if NOT SaveAllCerts then begin
if NOT SaveAllCerts then begin
if NOT SaveAllCerts then // two repeats
Exit;
end;
end;
end
else
LogEvent ('Skipped copying, bad directory: ' + FDir);
end;
end;
LogEvent('Finished collecting and saving certificate for ' + CertName + IcsCRLF + IcsCRLF);
// V8.67 load into Windows Certificate Store for IIS
// V8.69 Windows store is only on Windows
{$IFDEF MSCRYPT_Tools}
if (OutFmtWinStore in FCertOutFmts) then begin
try
if IcsIsProgAdmin or (FMsCertLoc = MsLocCurUser) then begin { V8.71 current user or local machine stores }
FNewSslCert.SaveToStorePfx(FMsCertLoc, True, True);
LogEvent('Installed certificate bundle ino Windows Certificate ' + MsCertLocTitles[FMsCertLoc] + ' Store OK');
end
else
LogEvent('Program needs administrator rights to install bundle in Windows Certificate Local Machine Store');
except
on E:Exception do begin
FLastError := 'Failed to install bundle in Windows Certificate ' + MsCertLocTitles[FMsCertLoc] + ' Store - ' + E.Message;
LogEvent(FLastError);
Exit;
end;
end;
end;
{$ENDIF}
Result := True;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TSslX509Certs.RedistribteFiles: Boolean;
begin
Result := False;
if (fCertCommonName = '') then begin
LogEvent('Must specify domain Common Name for certificate');
Exit;
end;
// read internal variables and public properties from database, so same as order
if NOT DBReadCNDomain(fCertCommonName) then
Exit;
if FIssueState < IssStateCollected then begin
LogEvent('Certificate order must be completed first');
Exit;
end;
LogEvent ('Redistributing old certificate');
FNewSslCert.ClearAll;
try
if FFileFinalBundle <> '' then
FNewSslCert.LoadFromFile(FFileFinalBundle, croTry, croTry, FPrivKeyPassword);
if NOT (FNewSslCert.IsCertLoaded and FNewSslCert.IsPKeyLoaded) then begin
LogEvent('Failed to read certificate bundle, trying aeparate files');
FNewSslCert.LoadFromFile(FFileFinalCert, croTry, croTry, FPrivKeyPassword);
FNewSslCert.PrivateKeyLoadFromPemFile(FFileFinalPrvKey, FPrivKeyPassword);
end;
except
on E:Exception do begin
LogEvent ('Failed to read old certificate - ' + E.Message);
Exit;
end;
end;
if NOT (FNewSslCert.IsCertLoaded and FNewSslCert.IsPKeyLoaded) then begin
LogEvent ('Failed to read old certificate - ' + FFileFinalBundle);
Exit;
end;
if FNewSslCert.ValidNotAfter < IcsGetUTCTime then begin { V8.61 }
LogEvent ('Old certificate has expired');
Exit;
end;
fNewCertLines := FNewSslCert.SaveCertToText(False);
// save lots of certificates in different formats and places
if NOT SaveCertificateFiles(fCertCommonName) then
Exit;
DBWriteCNDomain;
if Assigned(FOnNewCert) then FOnNewCert(Self);
Result := True;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TSslX509Certs.DumpJson(const Item: String = '');
begin
if NOT FLogJson then Exit ;
if FDebugLevel >= DebugBody then
Exit; // already done it
LogEvent('Response (length ' + IntToKbyte(Length(FHttpRest.ResponseRaw)) + ')' + IcsCRLF + FHttpRest.ResponseRaw);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TSslX509Certs.AcmeGetRequest(HttpReq: THttpRequest; const FullURL: String; AcmeJson: String): boolean; { V9.5 pass String not SO }
var
I: integer;
S, JsonWebSig: string;
begin
result := false;
if Pos ('https://', FullURL) <> 1 then begin
FLastError := 'AcmeGetRequest, Invalid URL: ' + FullURL;
LogEvent(FLastError);
exit;
end;
FHttpRest.ServerAuth := httpAuthNone;
FHttpRest.DebugLevel := FDebugLevel;
FHttpRest.Agent := 'ICS-ACME-' + ComponentVersion; // V8.60
FHttpRest.SocketFamily := FSocketFamily; // V8.60 allow IPv6
FHttpRest.ProxyURL := FProxyURL; // V8.62 proxy support
FHttpRest.AlpnProtocols.Clear; // V9.5 clear then add
FHttpRest.AlpnProtocols.Add(ALPN_ID_HTTP11); // V9.5
if (Pos ('/new-cert', FullURL) > 1) or (Pos ('/cert/', FullURL) > 1) or (Pos ('issuer-cert', FullURL) > 1) then
FHttpRest.Accept := 'application/pkix-cert'
else
FHttpRest.Accept := '*/*' ;
FHttpRest.FollowRelocation := False; // nonce will fail since unchanged
FHttpRest.ContentTypePost := 'application/jose+json';
fAcmeRespLocation := '';
if (FHttpRest.HttpDownFileName <> '') then { V8.68 are we downloading a file }
FHttpRest.HttpMemStrategy := HttpStratFile
else
FHttpRest.HttpMemStrategy := HttpStratMem;
FAccountLastTick := IcsGetTickCount64; { V8.63 idle account timeout }
try
// Json parameters need to be signed by private key as a Json Web Signature
// adding nonce from last request to prevent playback
if HttpReq = httpPOST then begin
if FDebugLevel >= DebugParams then
LogEvent ('AcmeJson: ' + AcmeJson);
// Acme v2 sends the public key once, which is stored on the server and then
// a shorter Key Id (kid) sent in subsequent requests, with nonce and URL
if fAcmeKwkKid = '' then
JsonWebSig := IcsJoseJWSJson(fAcmeJoseAlg, AcmeJson, '', fAcmePrivKey.PrivateKey, '',
fAcmeKwkPub, '', fAcmeRespNonce, FullURL, True) { V9.5 ECDSA IEEE }
else
JsonWebSig := IcsJoseJWSJson(fAcmeJoseAlg, AcmeJson, '', fAcmePrivKey.PrivateKey, '',
'', fAcmeKwkKid, fAcmeRespNonce, FullURL, True); { V9.5 ECDSA IEEE }
FHttpRest.RestParams.Clear;
fAcmeLastStatus := FHttpRest.RestRequest(httpPOST, FullURL, false, JsonWebSig);
end
else
fAcmeLastStatus := FHttpRest.RestRequest(HttpReq, FullURL, false, '');
except
on E:Exception do begin
LogEvent('Failed to contact Acme Server: ' + E.Message);
// don't exit, may still have something useful
end;
end;
// pending, should be loop to retry ???
try
{ look for special Acme headers
HTTP/1.1 409 Conflict
Content-Type: application/problem+json
Boulder-Requester: 5592135
Location: https://acme-staging.api.letsencrypt.org/acme/reg/5592135
Replay-Nonce: r1PKRhkQqI7GWwk1sGNwH_V5w2h0U7S0C44jq8vNhH0
HTTP/1.1 201 Created
Content-Type: application/json
Boulder-Requester: 5592485
Link: