-
-
Notifications
You must be signed in to change notification settings - Fork 135
/
Copy pathmormot.net.acme.pas
1436 lines (1329 loc) · 49.2 KB
/
mormot.net.acme.pas
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
/// Network ACME / Let's Encrypt Support
// - this unit is a part of the Open Source Synopse mORMot framework 2,
// licensed under a MPL/GPL/LGPL three license - see LICENSE.md
unit mormot.net.acme;
{
*****************************************************************************
Automatic Certificate Management Environment (ACME v2) Client
- JWS HTTP-client implementation
- ACME client implementation
- Let's Encrypt TLS / HTTPS Encryption Certificates Support
- HTTP-01 Let's Encrypt Challenges HTTP Server on port 80
- HTTP/HTTPS Fully Featured Multi-Host Web Server
*****************************************************************************
}
interface
{$I ..\mormot.defines.inc}
{$ifdef USE_OPENSSL}
// compile as a void unit if USE_OPENSSL is not defined
uses
sysutils,
classes,
mormot.core.base,
mormot.core.os,
mormot.core.data,
mormot.core.unicode,
mormot.core.text,
mormot.core.buffers,
mormot.core.datetime,
mormot.core.variants,
mormot.core.rtti,
mormot.core.json,
mormot.core.log,
mormot.core.threads,
mormot.core.search,
mormot.crypt.core,
mormot.crypt.secure,
mormot.lib.openssl11, // for per-domain-name PSSL_CTX certificates
mormot.net.sock,
mormot.net.http,
mormot.net.client, // for TJwsHttpClient
mormot.net.server; // for HTTP-01 challenge server
{ **************** JWS HTTP-client implementation }
type
/// exception associated with TJwsHttpClient
EJwsHttp = class(ESynException);
/// JSON Web Signature (JWS) HTTP-client
// - send content secured with digital signature
TJwsHttpClient = class(TSimpleHttpClient)
protected
fCert: ICryptCert;
fNonce: RawUtf8;
fKid: RawUtf8;
fJwkThumbprint: RawUtf8;
fLog: TSynLogClass;
function GetNonceAndBody: RawJson;
public
/// initialize this JWS-oriented HTTP client
constructor Create(aLog: TSynLogClass; const aCert: ICryptCert);
/// perform a HEAD request, not signed/authenticated
function Head(const aUrl: RawUtf8): RawJson;
/// perform a GET request, not signed/authenticated
function Get(const aUrl: RawUtf8): RawJson;
/// perform a POST request, with a signed JWS body as plain JSON
function Post(const aUrl: RawUtf8; const aJson: RawJson): RawJson; overload;
/// perform a POST request, with a signed JWS body as key/value pairs
function Post(const aUrl: RawUtf8; const aNameValues: array of const): RawJson; overload;
/// JWK Thumbprint as SHA-256
property JwkThumbprint: RawUtf8
read fJwkThumbprint;
end;
{ **************** ACME client implementation }
type
/// exception associated with TAcmeClient
EAcmeClient = class(ESynException);
/// the status of a given ACME challenge
TAcmeStatus = (
asInvalid,
asPending,
asValid
);
/// the details of one ACME HTTP-01 challenge
TAcmeChallenge = record
/// the current status of this challenge
Status: TAcmeStatus;
/// the "identifier.type" field, typically 'dns'
SubjectType: RawUtf8;
/// the "identifier.value" field, typically 'synopse.info'
SubjectValue: RawUtf8;
/// the "url" field of the challenge
// - used to trigger and check the challenge state
// - e.g. 'https://<LETSENCRYPT>/acme/chall/prV_B7yEyA4' in RFC 8555
Url: RawUtf8;
/// the "token" field of the challenge
// - e.g. 'DGyRejmCefe7v4NfDGDKfA' in RFC 8555
Token: RawUtf8;
/// the key authorization, i.e. the challenge content to be returned
// - i.e. the concatenation of the Token, '.', and the JWK base-64 hash
// - from URI as http://<Domain>/.well-known/acme-challenge/<Token>
Key: RawUtf8;
end;
/// the details of all ACME challenges
TAcmeChallengeDynArray = array of TAcmeChallenge;
/// callback to actually implement one HTTP-01 ACME challenge
// - is called once before the challenge process with non void Key
// - is called once after the challenge process with Key = '', so that
// you can remove the challenge content (e.g. files) from your web server
// - should publish the Key content into the expected HTTP server URI, i.e.
// http://<Domain>/.well-known/acme-challenge/<Token>
TOnAcmeChallenge = procedure(Sender: TObject;
const Domain, Key, Token: RawUtf8) of object;
/// ACME client processing class
// - implements the ACME V2 client (specified in RFC8555) to download
// free domain validated certificates, mainly from Let's Encrypt
// - see https://letsencrypt.org/how-it-works for a high-level description
TAcmeClient = class(TSynLocked)
protected
fDirectoryUrl: RawUtf8;
fContact: RawUtf8;
fSubjects: RawUtf8;
fSubject: TRawUtf8DynArray;
fHttpClient: TJwsHttpClient;
fChallenges: TAcmeChallengeDynArray;
fOnChallenges: TOnAcmeChallenge;
fChallengeWwwFolder: TFileName;
fLog: TSynLogClass;
// URI filled by ReadDirectory
fNewNonce: RawUtf8;
fNewAccount: RawUtf8;
fNewOrder: RawUtf8;
// URI filled by CreateOrder
fFinalize: RawUtf8;
procedure ReadDirectory;
procedure CreateAccount;
function CreateOrder: TAcmeStatus;
function RequestAuth(const aJson: RawJson): integer;
procedure OnChallengeWwwFolder(Sender: TObject;
const Domain, Key, Token: RawUtf8);
public
/// create an ACME client instance
// - aDirectoryUrl is the main URL of a directory object, typically
// ACME_LETSENCRYPT_URL (for production) or ACME_LETSENCRYPT_DEBUG_URL
// (for testing)
// - aCert is a local private certificate used to identify the client
// account for the JWK requests - so is not involved in the TLS chain
constructor Create(aLog: TSynLogClass; const aCert: ICryptCert;
const aDirectoryUrl, aContact, aSubjects: RawUtf8); reintroduce;
/// finalize the instance
destructor Destroy; override;
/// check if a Server Name text is part of associated Subjects
function Match(const aServerName: RawUtf8): boolean;
{$ifdef HASINLINE} inline; {$endif}
/// search for a given Challenge token, and return the associated key
function GetChallenge(aUri: PUtf8Char; aUriLen: PtrInt;
var Content: RawUtf8): boolean;
/// register account and applying for Certificate Issuance
// - caller should have set the OnChallenges, Contact and Subjects
// properties with the expected event or values
procedure StartDomainRegistration;
/// check if challenge for a domain is completed
function CheckChallengesStatus: TAcmeStatus;
/// finalize the order and download the signed certificate
// - aCert contain the final PEM certificate as signed by the ACME server
// - aPrivateKey contains the PEM private key generated locally, and
// optionally encrypted via aPrivateKeyPassword
function CompleteDomainRegistration(out aCert, aPrivateKey: RawUtf8;
const aPrivateKeyPassword: SpiUtf8): TAcmeStatus;
/// will run StartDomainRegistration and wait until it is completed
// - low-level wrapper using any TOnAcmeChallenge callback
// - won't execute function CompleteDomainRegistration() if OutSignedCert
// or OutPrivateKey are not set
function RegisterAndWait(const OnChallenge: TOnAcmeChallenge;
const OutSignedCert, OutPrivateKey: TFileName;
const aPrivateKeyPassword: SpiUtf8; WaitForSec: integer;
Terminated: PBoolean): TAcmeStatus;
/// will run StartDomainRegistration and wait until it is completed
// - ChallengeWwwFolder is a local folder where to store the temporary
// challenges, to be served by an external web server, e.g. nginx - the
// method will append ACME_CHALLENGE_PATH to the supplied local folder name
function RegisterAndWaitFolder(
const ChallengeWwwFolder, OutSignedCert, OutPrivateKey: TFileName;
const aPrivateKeyPassword: SpiUtf8; WaitForSec: integer): TAcmeStatus;
/// associated contact as mailto: link, e.g. 'mailto:[email protected]'
property Contact: RawUtf8
read fContact write fContact;
/// associated subjects as CSV, typically domain names to authenticate
// - e.g. 'synopse.info,www.synopse.info'
// - match Subject[] array field
property Subjects: RawUtf8
read fSubjects write fSubjects;
/// associated subjects as array, typically domain names to authenticate
// - e.g. ['synopse.info', 'www.synopse.info']
// - match Subjects CSV field
property Subject: TRawUtf8DynArray
read fSubject write fSubject;
/// low-level direct access to the associated challenges
// - may be used instead of OnChallenges callback
property Challenges: TAcmeChallengeDynArray
read fChallenges;
/// callback to let the top-level application publish the challenges
property OnChallenges: TOnAcmeChallenge
read fOnChallenges write fOnChallenges;
end;
TAcmeClientObjArray = array of TAcmeClient;
function ToText(status: TAcmeStatus): PShortString; overload;
{ **************** Let's Encrypt TLS / HTTPS Encryption Certificates Support }
const
ACME_LETSENCRYPT_URL =
'https://acme-v02.api.letsencrypt.org/directory';
ACME_LETSENCRYPT_DEBUG_URL =
'https://acme-staging-v02.api.letsencrypt.org/directory';
ACME_CHALLENGE_PATH =
'/.well-known/acme-challenge/';
ACME_CHALLENGE_PATH_UPPER =
'/.WELL-KNOWN/ACME-CHALLENGE/';
ACME_CHALLENGE_PATH_LEN = length(ACME_CHALLENGE_PATH);
type
EAcmeLetsEncrypt = class(ESynException);
TAcmeLetsEncrypt = class;
/// used to generate or renew one Let's Encrypt domain certificate
TAcmeLetsEncryptClient = class(TAcmeClient)
protected
fDomainJson, fReferenceCert, fSignedCert, fPrivKey: TFileName;
fOwner: TAcmeLetsEncrypt;
fCtx: PSSL_CTX;
fRedirectHttps: RawUtf8;
fRenewing: boolean;
procedure ClearCtx;
// internal method called by TAcmeLetsEncrypt.OnNetTlsAcceptServerName
function GetServerContext: PSSL_CTX;
public
/// initialize certificate management with Let's Encrypt of one domain
// - aDomainFile is the ##.json of this domain to be read from disk
// with its associated ##.acme.pem, ##.crt.me, and ##.key.pem files
constructor Create(aOwner: TAcmeLetsEncrypt; const aDomainFile: TFileName); reintroduce;
/// finalize the information of this domain certificate
destructor Destroy; override;
end;
TAcmeLetsEncryptClientObjArray = array of TAcmeLetsEncryptClient;
/// handle one or several Let's Encrypt domains certificates
// - with automated generation and renewal
// - information is located in a single aKeyStoreFolder directory, as
// associated ##.json, ##.acme.pem, ##.crt.me, and ##.key.pem files
TAcmeLetsEncrypt = class(TSynLocked)
protected
fClient: TAcmeLetsEncryptClientObjArray;
fKeyStoreFolder: TFileName;
fPrivateKeyPassword: SpiUtf8;
fDirectoryUrl, fAlgo: RawUtf8;
fLog: TSynLogClass;
fRenewBeforeEndDays: integer;
fRenewWaitForSeconds: integer;
fRenewTerminated: boolean;
fRenewing: boolean;
fOnChallenge: TOnAcmeChallenge;
function GetClient(const ServerName: RawUtf8): TAcmeLetsEncryptClient;
function GetClientLocked(const ServerName: RawUtf8): TAcmeLetsEncryptClient;
public
/// initialize certificates management with Let's Encrypt
// - if aDirectoryUrl is not '', will use the "staging" environment - you
// should specify ACME_LETSENCRYPT_URL on production
// - if aAlgo is '', will use 'x509-es256' as default
// - a global aPrivateKeyPassword could be set to protect ##.key.pem files
constructor Create(aLog: TSynLogClass; const aKeyStoreFolder: TFileName;
const aDirectoryUrl, aAlgo: RawUtf8;
const aPrivateKeyPassword: SpiUtf8); reintroduce;
/// finalize the certificates management
destructor Destroy; override;
/// read the certificates from the local storage folder
procedure LoadFromKeyStoreFolder;
/// validate the stored certificates in a background TLoggedWorkThread
procedure CheckCertificatesBackground;
/// run by CheckCertificatesBackground to validate the stored certificates
// - load each one, check their expiration date against RenewBeforeEndDays,
// and generate or renew them in order
// - follow RenewWaitForSeconds timeout for each certificate
// - this blocking process could take some time (several seconds per domain)
procedure CheckCertificates(Sender: TObject);
/// TOnNetTlsAcceptServerName event, set to OnNetTlsAcceptServerName
// global variable of mormot.net.sock
function OnNetTlsAcceptServerName(Context: PNetTlsContext; TLS: pointer;
const ServerName: RawUtf8): pointer;
/// TOnNetTlsAcceptChallenge event, set to OnNetTlsAcceptChallenge
// global variable of mormot.net.sock
// - Let's Encrypt typical uri is '/.well-known/acme-challenge/<TOKEN>'
function OnNetTlsAcceptChallenge(const domain, uri: RawUtf8;
var content: RawUtf8): boolean;
/// raw access to the internal Client list
property Client: TAcmeLetsEncryptClientObjArray
read fClient;
/// a callback which may be needed during CheckCertificates() process
// - not needed if an internal HTTP server is processed
property OnChallenge: TOnAcmeChallenge
read fOnChallenge write fOnChallenge;
published
/// the algorithm used for the certificates
property KeyAlgo: RawUtf8
read fAlgo;
/// where the certificates and related information are persisted
property KeyStoreFolder: TFileName
read fKeyStoreFolder;
/// the URI root folder used for ACME authentication
property DirectoryUrl: RawUtf8
read fDirectoryUrl;
/// how many days before expiration CheckCertificates() should renew a
// certificate
// - default is 30 days, as stated by https://letsencrypt.org/docs/faq
// - set to <= 0 to disable the whole CheckCertificates() process
property RenewBeforeEndDays: integer
read fRenewBeforeEndDays write fRenewBeforeEndDays;
/// how many seconds CheckCertificates() should wait for getting a certificate
// - default is 30 seconds
property RenewWaitForSeconds: integer
read fRenewWaitForSeconds write fRenewWaitForSeconds;
end;
{ **************** HTTP-01 Let's Encrypt Challenges HTTP Server on port 80 }
type
/// handle one or several Let's Encrypt domains certificates with an
// associated HTTP server running on port 80
// - will support HTTP-01 challenge answers when renewing is active
// - will redirect any plain HTTP port 80 request to HTTPS port 443
// - at startup, then twice a day, will try to renew the certificates in the
// background, following RenewBeforeEndDays property policy
// - is typically associated to a main THttpAsyncServer for the HTTPS requests
TAcmeLetsEncryptServer = class(TAcmeLetsEncrypt)
protected
fHttpServer: THttpServer; // a single threaded HTTP server is enough
fHttpsServer: THttpServerGeneric;
fNextCheckTix: Int64;
fRedirectHttps: integer;
function OnHeaderParsed(
Request: THttpServerSocket): THttpServerSocketGetRequestResult;
procedure OnAcceptIdle(Sender: TObject; Tix64: Int64);
public
/// initialize certificates management and HTTP server with Let's Encrypt
// - if aDirectoryUrl is not '', will use the "staging" environment - you
// should specify ACME_LETSENCRYPT_URL on production
// - if aAlgo is '', will use 'x509-es256' as default
// - a global aPrivateKeyPassword could be set to protect ##.key.pem files
// - you can specify the associated main HTTPS server into aHttpsServer so
// that our plain HTTP server will follow its configuration (e.g. logging)
// - by default, the HTTP server will consume a single thread, but you can
// set e.g. aHttpServerThreadCount = 2 on a production server
// - aPort can be set to something else than 80, e.g. behind a reverse proxy
// - will raise an exception if port 80 is not available for binding (e.g.
// if the user is not root on Linux/POSIX)
constructor Create(aLog: TSynLogClass; const aKeyStoreFolder: TFileName;
const aDirectoryUrl, aAlgo: RawUtf8; const aPrivateKeyPassword: SpiUtf8;
aHttpsServer: THttpServerGeneric = nil;
aHttpServerThreadCount: integer = -1; const aPort: RawUtf8 = ''); reintroduce;
/// finalize the certificates management and the associated HTTP server
destructor Destroy; override;
/// allow to specify the https URI to redirect from any request on port 80
// - Redirection should include the full URI, e.g. 'https://blog.synopse.info'
function Redirect(const Domain, Redirection: RawUtf8): boolean;
// the associated HTTPS server as supplied to Create()
property HttpsServer: THttpServerGeneric
read fHttpsServer;
published
/// the limited HTTP server launched by this class, running on port 80
property HttpServer: THttpServer
read fHttpServer;
end;
{ **************** HTTP/HTTPS Fully Featured Multi-Host Web Server }
implementation
{ **************** JWS HTTP-client implementation }
{ TJwsHttpClient }
constructor TJwsHttpClient.Create(aLog: TSynLogClass; const aCert: ICryptCert);
begin
inherited Create({aOnlyUseClientSocket=}false);
fLog := aLog;
fCert := aCert;
end;
function TJwsHttpClient.GetNonceAndBody: RawJson;
var
err: RawUtf8;
begin
if Assigned(fLog) then
fLog.Add.Log(sllTrace, '% = % %',
[fUri, fStatus, KBNoSpace(length(fBody))], self);
// the server includes a Replay-Nonce header field in every response
fNonce := FindIniNameValue(pointer(fHeaders), 'REPLAY-NONCE: ');
// validate the response
if not (fStatus in [HTTP_SUCCESS, HTTP_CREATED, HTTP_NOCONTENT]) then
begin
err := JsonDecode(pointer(fBody), 'detail', nil, {handlejsonobjarr=} false);
if err = '' then
StatusCodeToReason(fStatus, err);
EJwsHttp.RaiseUtf8('Error % [%] while querying %', [fStatus, err, fUri]);
end;
result := fBody;
end;
function TJwsHttpClient.Head(const aUrl: RawUtf8): RawJson;
begin
Request(aUrl, 'HEAD');
result := GetNonceAndBody;
end;
function TJwsHttpClient.Get(const aUrl: RawUtf8): RawJson;
begin
Request(aUrl, 'GET');
result := GetNonceAndBody;
end;
function TJwsHttpClient.Post(const aUrl: RawUtf8; const aJson: RawJson): RawJson;
var
jwk, header: RawUtf8;
thumb: TSha256Digest;
header_enc, json_enc, body_enc: RawUtf8;
sign: RawUtf8;
data: RawUtf8;
begin
if fKid <> '' then
begin
// we have the key identifier provided by the server
header := FormatJson('{"alg":?,"kid":?,"nonce":?,"url":?}', [],
[CAA_JWT[fCert.AsymAlgo], fKid, fNonce, aUrl])
end
else
begin
// no key identifier, need to provide JSON Web Key
if not fCert.HasPrivateSecret then
raise EJwsHttp.Create('No private key');
// compute JWK JSON object - e.g. '{"e":..,"kty":"RSA","n":..}' for RSA
jwk := fCert.JwkCompute;
// the thumbprint of a JWK is computed with no whitespace or line breaks
// before or after any syntaxic elements and with the required members
// ordered lexicographically, using SHA-256 hashing
thumb := Sha256Digest(jwk);
fJwkThumbprint := BinToBase64uri(@thumb, sizeof(thumb));
header := FormatJson('{"alg":?,"jwk":%,"nonce":?,"url":?}',
[jwk], [CAA_JWT[fCert.AsymAlgo], fNonce, aUrl]);
end;
header_enc := BinToBase64uri(header);
json_enc := BinToBase64uri(aJson);
body_enc := header_enc + '.' + json_enc;
sign := GetSignatureSecurityRaw(fCert.AsymAlgo, fCert.Sign(body_enc));
data := FormatJson('{"protected":?,"payload":?,"signature":?}',
[], [header_enc, json_enc, sign]);
Request(aUrl, 'POST', '', data, 'application/jose+json');
result := GetNonceAndBody;
if fKid = '' then
fKid := FindIniNameValue(pointer(fHeaders), 'LOCATION: ');
end;
function TJwsHttpClient.Post(const aUrl: RawUtf8;
const aNameValues: array of const): RawJson;
begin
result := Post(aUrl, JsonEncode(aNameValues));
end;
{ **************** ACME client implementation }
function AcmeTextToStatus(p: PUtf8Char): TAcmeStatus;
begin
if IdemPChar(p, 'VALID') then
result := asValid
else if IdemPChar(p, 'READY') then
result := asValid
else if IdemPChar(p, 'PENDING') then
result := asPending
else
result := asInvalid;
end;
function ToText(status: TAcmeStatus): PShortString;
begin
result := GetEnumName(TypeInfo(TAcmeStatus), ord(status));
end;
// return identifers TDocVariant array from Subjects, as
// [ {"type":"dns", "value":"synopse.info"} ]
function GetIdentifiersArr(const aSubjects: TRawUtf8DynArray): variant;
var
i, j: PtrInt;
typ, val: RawUtf8;
begin
VarClear(result);
TDocVariantData(result).InitFast(length(aSubjects), dvArray);
for i := 0 to length(aSubjects) - 1 do
begin
val := aSubjects[i];
j := PosExChar(':', val);
if j > 0 then
begin
typ := copy(val, 1, j - 1);
delete(val, 1, j);
end
else
typ := 'dns';
TDocVariantData(result).AddItem(_ObjFast([
'type', typ,
'value', val]));
end;
end;
{ TAcmeClient }
constructor TAcmeClient.Create(aLog: TSynLogClass; const aCert: ICryptCert;
const aDirectoryUrl, aContact, aSubjects: RawUtf8);
var
i: PtrInt;
begin
fLog := aLog;
inherited Create;
fDirectoryUrl := aDirectoryUrl;
fContact := aContact;
if aSubjects = '' then
raise EAcmeClient.Create('Create with aSubjects=nil');
fSubjects := aSubjects;
fSubject := CsvToRawUtf8DynArray(fSubjects);
for i := 0 to high(fSubject) do
if fSubject[i] = '' then // not allowed by FindPropName()
raise EAcmeClient.Create('Create with a void entry in aSubjects CSV');
fHttpClient := TJwsHttpClient.Create(fLog, aCert);
end;
destructor TAcmeClient.Destroy;
begin
FreeAndNil(fHttpClient);
inherited Destroy;
end;
function TAcmeClient.Match(const aServerName: RawUtf8): boolean;
begin
// very fast case insensitive O(n) search
result := FindPropName(pointer(fSubject), aServerName, length(fSubject)) >= 0;
end;
function TAcmeClient.GetChallenge(aUri: PUtf8Char; aUriLen: PtrInt;
var Content: RawUtf8): boolean;
var
i: PtrInt;
c: ^TAcmeChallenge;
begin
c := pointer(fChallenges);
if aUriLen > 0 then
for i := 1 to length(fChallenges) do
begin
if CompareBuf(c^.Token, aUri, aUriLen) = 0 then
begin
if Assigned(fLog) then
fLog.Add.Log(sllTrace, 'GetChallenge %', [c^.Token], self);
result := true;
Content := c^.Key;
exit;
end;
inc(c);
end;
result := false;
end;
procedure TAcmeClient.ReadDirectory;
var
resp: RawJson;
v: array [0..2] of TValuePUtf8Char;
begin
// In order to help clients configure themselves with the right URLs for
// each ACME operation, ACME servers provide a directory object
resp := fHttpClient.Get(fDirectoryUrl);
if Assigned(fLog) then
fLog.Add.Log(sllTrace, 'ReadDirectory %', [resp], self);
JsonDecode(pointer(resp), [
'newNonce',
'newAccount',
'newOrder'], @v, {handlejsonobjarr=} true);
v[0].ToUtf8(fNewNonce);
v[1].ToUtf8(fNewAccount);
v[2].ToUtf8(fNewOrder);
if (fNewNonce = '') or
(fNewAccount = '') or
(fNewOrder = '') then
EAcmeClient.RaiseUtf8('Invalid directory %', [fDirectoryUrl]);
end;
procedure TAcmeClient.CreateAccount;
var
resp: RawJson;
status: RawUtf8;
begin
// A client creates a new account with the server by sending a POST
// request to the server's newAccount URL
resp := fHttpClient.Post(fNewAccount,
['termsOfServiceAgreed', true,
'contact', _ArrFast([fContact])]);
status := JsonDecode(pointer(resp), 'status', nil, {handlejsonobjarr=} true);
if AcmeTextToStatus(pointer(status)) <> asValid then
EAcmeClient.RaiseUtf8('% returned status % (expected "valid")',
[fNewAccount, status]);
end;
function TAcmeClient.CreateOrder: TAcmeStatus;
var
i, j, n: PtrInt;
ch: ^TAcmeChallenge;
r1, r2: RawJson;
v1, v2: array [0..2] of TValuePUtf8Char;
auth: TRawUtf8DynArray;
p: PUtf8Char;
chs: TPUtf8CharDynArray;
begin
fChallenges := nil;
// The client begins the certificate issuance process by sending a POST
// request to the server's newOrder resource
r1 := fHttpClient.Post(fNewOrder, ['identifiers', GetIdentifiersArr(fSubject)]);
JsonDecode(pointer(r1), [
'status',
'finalize',
'authorizations'], @v1, {handleJsonObjectsOrArray=}true);
result := AcmeTextToStatus(v1[0].Text);
if result = asInvalid then
EAcmeClient.RaiseUtf8('% returned "%" (expected "pending" or "ready")',
[fNewOrder, v1[0].Text]);
v1[1].ToUtf8(fFinalize);
// When a client receives an order from the server in reply to a
// newOrder request, it downloads the authorization resources by sending
// requests to the indicated URLs
n := 0;
DynArrayLoadJson(auth, v1[2].Text, TypeInfo(TRawUtf8DynArray));
SetLength(fChallenges, length(auth));
ch := pointer(fChallenges);
for i := 0 to length(auth) - 1 do
begin
r2 := fHttpClient.Post(auth[i], '');
JsonDecode(pointer(r2), [
'status',
'identifier',
'challenges'], @v1, {handlejsonobjarr=} true);
ch^.Status := AcmeTextToStatus(v1[0].Text);
JsonDecode(v1[1].Text, [
'type',
'value'], @v2, {handlejsonobjarr=} false);
v2[0].ToUtf8(ch^.SubjectType);
v2[1].ToUtf8(ch^.SubjectValue);
if ch^.Status = asPending then
begin
p := v1[2].Text;
if NextNotSpaceCharIs(p, '[') then
JsonArrayDecode(p, chs)
else
chs := nil;
for j := 0 to length(chs) - 1 do
begin
JsonDecode(chs[j], [
'type',
'url',
'token'], @v2, {handlejsonobjarr=} false);
// support only HTTP validation by now
if v2[0].Idem('HTTP-01') then
begin
v2[1].ToUtf8(ch^.Url);
v2[2].ToUtf8(ch^.Token);
// A key authorization is a string that
// concatenates the token for the challenge with a key fingerprint
// (using the SHA-256 digest), separated by a "." character
ch^.Key := ch^.Token + '.' + fHttpClient.JwkThumbprint;
inc(n);
break; // we found and stored the "http-01" challenge
end;
end;
end;
inc(ch);
end;
fLog.Add.Log(sllDebug, 'CreateOrder chal=%/%', [n, length(fChallenges)], self);
end;
function TAcmeClient.RequestAuth(const aJson: RawJson): integer;
var
i: PtrInt;
resp: RawJson;
status: RawUtf8;
begin
// The client indicates to the server that it is ready for the challenge
// validation by sending an empty body aJson = '{}'.
// If aJson = '' then client requests validation state
result := 0; // return how many pending
for i := 0 to length(fChallenges) - 1 do
begin
if fChallenges[i].Status = asPending then
begin
resp := fHttpClient.Post(fChallenges[i].Url, aJson);
status := JsonDecode(pointer(resp), 'status', nil, {handleobjarr=} false);
fChallenges[i].Status := AcmeTextToStatus(pointer(status));
inc(result, ord(fChallenges[i].Status = asPending));
end;
end;
end;
procedure TAcmeClient.OnChallengeWwwFolder(Sender: TObject;
const Domain, Key, Token: RawUtf8);
var
fn: TFileName;
begin
if fChallengeWwwFolder = '' then
exit;
fn := FormatString('%%', [fChallengeWwwFolder, Token]);
if Key <> '' then
FileFromString(Key, fn) // initial call
else
DeleteFile(fn); // final call
end;
procedure TAcmeClient.StartDomainRegistration;
var
i, n: PtrInt;
begin
fLog.Add.Log(sllTrace, 'StartDomainRegistration %', [fSubjects], self);
// In order to help clients configure themselves with the right URLs for
// each ACME operation, ACME servers provide a directory object
ReadDirectory;
// Before sending a POST request to the server, an ACME client needs to
// have a fresh anti-replay nonce to put in the "nonce" header of the JWS
fHttpClient.Head(fNewNonce);
// Create an account on an ACME server or retrieve existing
CreateAccount;
// Applying for Certificate Issuance
if CreateOrder = asPending then
begin
// Notify top-level application
if Assigned(fOnChallenges) then
for i := 0 to length(fChallenges) - 1 do
if fChallenges[i].Key <> '' then
fOnChallenges(self, fSubjects, fChallenges[i].Key, fChallenges[i].Token);
// Queue challenge testing by sending {} to initiate the server process
n := RequestAuth('{}');
fLog.Add.Log(sllTrace, 'StartDomainRegistration pending=%', [n], self);
end;
end;
function TAcmeClient.CheckChallengesStatus: TAcmeStatus;
var
i, pending, valid: PtrInt;
begin
// Before sending a POST request to the server, an ACME client needs to
// have a fresh anti-replay nonce to put in the "nonce" header of the JWS
fHttpClient.Head(fNewNonce);
// Check if challenge for a domain is completed
pending := RequestAuth(''); // {} to initiate, '' to check status
// Compute result:
// One invalid -> invalid
// All valid -> valid
// else pending
result := asPending;
valid := 0;
for i := 0 to length(fChallenges) - 1 do
case fChallenges[i].Status of
asInvalid:
result := asInvalid;
asValid:
inc(valid);
end;
if (result = asPending) and
(valid = length(fChallenges)) then
result := asValid;
fLog.Add.Log(sllDebug, 'CheckChallengesStatus=% pending=% valid=% count=%',
[ToText(result)^, pending, valid, length(fChallenges)], self);
end;
function TAcmeClient.CompleteDomainRegistration(out aCert, aPrivateKey: RawUtf8;
const aPrivateKeyPassword: SpiUtf8): TAcmeStatus;
var
csr: RawByteString;
pk, resp: RawUtf8;
i: PtrInt;
v: array [0..1] of TValuePUtf8Char;
begin
try
// Generate a new PKCS#10 Certificate Signing Request
csr := PemToDer(fHttpClient.fCert.CertAlgo.CreateSelfSignedCsr(
fSubjects, aPrivateKeyPassword, pk));
// Before sending a POST request to the server, an ACME client needs to
// have a fresh anti-replay nonce to put in the "nonce" header of the JWS
fHttpClient.Head(fNewNonce);
// Once the validation process is complete and the server is satisfied
// that the client has met its requirements, the client finalizes the
// order by submitting a Certificate Signing Request (CSR)
resp := fHttpClient.Post(fFinalize, [
'csr', BinToBase64uri(csr)]);
JsonDecode(pointer(resp), [
'status',
'certificate'], @v, {handlejsonobjarr=} true);
result := AcmeTextToStatus(v[0].Text);
if result = asValid then
begin
// The server has issued the certificate and provisioned its
// URL to the "certificate" field of the order.
// Download the certificate
aCert := fHttpClient.Post(v[1].ToUtf8, '');
if IsPem(aCert) then
fLog.Add.Log(sllDebug, 'CompleteDomainRegistration finalize=%',
[aCert], self)
else
result := asInvalid;
end;
if result = asValid then
// only keep the generated private key on success
aPrivateKey := pk
finally
FillZero(pk);
FillZero(resp);
if Assigned(fOnChallenges) then
// call with key = '' to notify final state
for i := 0 to length(fChallenges) - 1 do
if fChallenges[i].Key <> '' then
fOnChallenges(nil, fSubjects, {key=}'', fChallenges[i].Token);
fChallenges := nil;
end;
end;
function TAcmeClient.RegisterAndWait(const OnChallenge: TOnAcmeChallenge;
const OutSignedCert, OutPrivateKey: TFileName;
const aPrivateKeyPassword: SpiUtf8; WaitForSec: integer;
Terminated: PBoolean): TAcmeStatus;
var
endtix: Int64;
cert, pk: RawUtf8;
log: ISynLog;
begin
log := fLog.Enter(self, 'RegisterAndWait');
fOnChallenges := OnChallenge;
StartDomainRegistration;
endtix := GetTickCount64 + WaitForSec * 1000;
repeat
result := asInvalid;
if Terminated = nil then
sleep(1000)
else if SleepHiRes(1000, Terminated^) then
exit;
result := CheckChallengesStatus;
if result <> asPending then
break;
until GetTickCount64 > endtix;
if (result <> asValid) or
(OutSignedCert = '') or
(OutPrivateKey = '') then
exit;
result := CompleteDomainRegistration(cert, pk, aPrivateKeyPassword);
if Assigned(log) then
log.Log(sllDebug, 'CompleteDomainRegistration=%', [ToText(result)^], self);
if result = asValid then
try
FileFromString(cert, OutSignedCert);
FileFromString(pk, OutPrivateKey);
finally
FillZero(cert);
FillZero(pk);
end;
end;
function TAcmeClient.RegisterAndWaitFolder(
const ChallengeWwwFolder, OutSignedCert, OutPrivateKey: TFileName;
const aPrivateKeyPassword: SpiUtf8; WaitForSec: integer): TAcmeStatus;
begin
if fChallengeWwwFolder <> '' then
EAcmeClient.RaiseUtf8(
'%.RegisterAndWaitFolder: already called as %', [self, fChallengeWwwFolder]);
if not DirectoryExists(ChallengeWwwFolder) then
EAcmeClient.RaiseUtf8(
'%.RegisterAndWaitFolder: unknown %', [self, ChallengeWwwFolder]);
fChallengeWwwFolder := EnsureDirectoryExists(
FormatString('%.well-known%acme-challenge',
[IncludeTrailingPathDelimiter(ChallengeWwwFolder), PathDelim]), EAcmeClient);
try
result := RegisterAndWait(OnChallengeWwwFolder,
OutSignedCert, OutPrivateKey, aPrivateKeyPassword, WaitForSec, nil);
finally
fChallengeWwwFolder := '';
end;
end;
{ **************** Let's Encrypt TLS / HTTPS Encryption Certificates Support }
{ TAcmeLetsEncryptClient }
constructor TAcmeLetsEncryptClient.Create(
aOwner: TAcmeLetsEncrypt; const aDomainFile: TFileName);
var
cc: ICryptCert;
dom: TDocVariantData;
json, c: RawUtf8;
s: TRawUtf8DynArray;
begin
fOwner := aOwner;
fDomainJson := aDomainFile + '.json';
fReferenceCert := aDomainFile + '.acme.pem';
fSignedCert := aDomainFile + '.crt.pem';
fPrivKey := aDomainFile + '.key.pem';
json := StringFromFile(fDomainJson);
fOwner.fLog.Add.Log(sllTrace, 'Create(%) %', [aDomainFile, json], self);
dom.InitJsonInPlace(pointer(json), []);
c := dom.U['contact'];
dom.A['subjects'].ToRawUtf8DynArray(s);
cc := Cert(fOwner.fAlgo);
if cc = nil then
EAcmeLetsEncrypt.RaiseUtf8('%.Create: unsupported %', [self, fOwner.fAlgo]);
if not FileExists(fSignedCert) or
not FileExists(fPrivKey) or
not cc.LoadFromFile(fReferenceCert, cccCertWithPrivateKey) then
begin
fOwner.fLog.Add.Log(sllDebug, 'Create(%): invalid certs -> recreate',
[aDomainFile], self);
DeleteFile(fReferenceCert);
DeleteFile(fSignedCert);
DeleteFile(fPrivKey);
// create a new certificate to sign the JWK queries (not used for TLS)
cc.Generate([cuDigitalSignature], s[0], nil, 3650);
cc.SaveToFile(fReferenceCert, cccCertWithPrivateKey); // no password needed
end;
inherited Create(fOwner.fLog, cc, fOwner.fDirectoryUrl, c, RawUtf8ArrayToCsv(s));
end;
destructor TAcmeLetsEncryptClient.Destroy;
begin
ClearCtx;
inherited Destroy;
end;
procedure TAcmeLetsEncryptClient.ClearCtx;
begin
if fCtx <> nil then
fCtx.Free;
fCtx := nil;
end;
function TAcmeLetsEncryptClient.GetServerContext: PSSL_CTX;
begin
// client made fSafe.Lock
result := fCtx;
if (result <> nil) or // most of time, immediate return from cache
not FileExists(fSignedCert) or
not FileExists(fPrivKey) then
exit;
// will be assigned by SSL_set_SSL_CTX() which requires only a certificate
result := SSL_CTX_new(TLS_server_method);
// cut-down version of TOpenSslNetTls.SetupCtx
if result.SetCertificateFiles(
fSignedCert, fPrivKey, fOwner.fPrivateKeyPassword) then
fCtx := result
else
begin
result.Free;
result := nil; // silently fallback to main certificate
end;
end;
{ TAcmeLetsEncrypt }
constructor TAcmeLetsEncrypt.Create(aLog: TSynLogClass;
const aKeyStoreFolder: TFileName; const aDirectoryUrl, aAlgo: RawUtf8;