mormot支持https

mormot支持https

将ssl证书导入电脑系统，以Windows 10为例：

运行 mmc

 

证书导入成功后，双击证书，查看证书指纹：

 

第二项工作：将证书与https绑定：
以管理员身份启动cmd,输入下列命令：
netsh http add sslcert ipport=0.0.0.0:443 certhash=3a0a8fa7cbcab141e102eaab457b1299af8f82cc appid={FDC3C336-D4AF-4EA8-BAA2-15536FDE8799}

第三项工作：修改Delphi源程序：

?
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
program HttpApiServer;
 
{$APPTYPE CONSOLE}
 
{$I Synopse.inc}
 
//['{FDC3C336-D4AF-4EA8-BAA2-15536FDE8799}']
//netsh http add sslcert ipport=0.0.0.0:443 certhash=3a0a8fa7cbcab141e102eaab457b1299af8f82cc appid={FDC3C336-D4AF-4EA8-BAA2-15536FDE8799}
//netsh http delete sslcert ipport=0.0.0.0:443
 
uses
{$I SynDprUses.inc} // use FastMM4 on older Delphi, or set FPC threads
  SysUtils,
  SynCommons,
  SynZip,
  SynCrtSock;
 
type
  TTestServer = class
  protected
    fPath: TFileName;
    fPort, fRoot: string;
    fServer: THttpApiServer;
    fHttps: Boolean;
    function Process(Ctxt: THttpServerRequest): cardinal;
    function ShowDirectory(Ctxt: THttpServerRequest;
      const FileName: TFileName; FN: RawUTF8): cardinal;
  public
    constructor Create(const Path: TFileName);
    destructor Destroy; override;
  end;
 
  { TTestServer }
 
constructor TTestServer.Create(const Path: TFileName);
begin
  fPath := IncludeTrailingPathDelimiter(Path);
  fPort := '443';
  fRoot := '/test';
  fHttps := True;
  fServer := THttpApiServer.Create(false);
  fServer.AddUrl(fRoot, fPort, fHttps, '+', true);
  fServer.RegisterCompress(CompressDeflate); // our server will deflate html :)
  fServer.OnRequest := Process;
  fServer.Clone(31); // will use a thread pool of 32 threads in total
end;
 
destructor TTestServer.Destroy;
begin
  fServer.RemoveUrl(fRoot, fPort, fHttps, '+');
  fServer.Free;
  inherited;
end;
 
{$WARN SYMBOL_PLATFORM OFF}
 
function TTestServer.Process(Ctxt: THttpServerRequest): cardinal;
var
  FileName: TFileName;
  FN: RawUTF8;
begin
  write(Ctxt.Method, ' ', Ctxt.URL);
  if not IdemPChar(pointer(Ctxt.URL), PAnsiChar(UpperCase(fRoot))) then begin
    WriteLn(' End with 404');
    result := 404;
    exit;
  end;
  FN := StringReplaceChars(UrlDecode(copy(Ctxt.URL, Length(fRoot) + 1, maxInt)),
    '/', '\');
  if PosEx('..', FN) > 0 then begin
    WriteLn(' .. End with 404');
    result := 404; // circumvent obvious potential security leak
    exit;
  end;
  while (FN <> '') and (FN[1] = '\') do
    delete(FN, 1, 1);
  while (FN <> '') and (FN[length(FN)] = '\') do
    delete(FN, length(FN), 1);
  FileName := fPath + UTF8ToString(FN);
  writeLn(' => ' + FileName); //c5soft
  if DirectoryExists(FileName) then begin
    Result := ShowDirectory(ctxt, FileName, FN);
  end else begin
    // http.sys will send the specified file from kernel mode
    Ctxt.OutContent := StringToUTF8(FileName);
    Ctxt.OutContentType := HTTP_RESP_STATICFILE;
    result := 200; // THttpApiServer.Execute will return 404 if not found
  end;
end;
 
var
  Msg: string;
 
function TTestServer.ShowDirectory(Ctxt: THttpServerRequest;
  const FileName: TFileName; FN: RawUTF8): cardinal;
var
  W: TTextWriter;
  SRName, href: RawUTF8;
  i: integer;
  SR: TSearchRec;
  cRoot: string;
 
  procedure hrefCompute;
  begin
    SRName := StringToUTF8(SR.Name);
    href := FN + StringReplaceChars(SRName, '\', '/');
  end;
begin
  if fRoot <> '/' then cRoot := fRoot + '/' else cRoot := fRoot;
  // reply directory listing as html
  W := TTextWriter.CreateOwnedStream;
  try
    W.Add('<html><body style="font-family: Arial">' +
      '<h3>%</h3><p><table>', [FN]);
    FN := StringReplaceChars(FN, '\', '/');
    if FN <> '' then
      FN := FN + '/';
    if FindFirst(FileName + '\*.*', faDirectory, SR) = 0 then begin
      repeat
        if (SR.Attr and faDirectory <> 0) and (SR.Name <> '.') then begin
          hrefCompute;
          if SRName = '..' then begin
            i := length(FN);
            while (i > 0) and (FN[i] = '/') do dec(i);
            while (i > 0) and (FN[i] <> '/') do dec(i);
            href := copy(FN, 1, i);
          end;
          W.Add('<tr><td><b><a href="' + cRoot + '%">[%]</a></b></td></tr>', [href,
            SRName]);
        end;
      until FindNext(SR) <> 0;
      FindClose(SR);
    end;
    if FindFirst(FileName + '\*.*', faAnyFile - faDirectory - faHidden, SR) = 0 then begin
      repeat
        hrefCompute;
        if SR.Attr and faDirectory = 0 then
          W.Add('<tr><td><b><a href="' + cRoot +
            '%">%</a></b></td><td>%</td><td>%</td></td></tr>',
            [href, SRName, KB(SR.Size), DateTimeToStr(
{$IFDEF ISDELPHIXE2}SR.TimeStamp{$ELSE}FileDateToDateTime(SR.Time){$ENDIF})]);
      until FindNext(SR) <> 0;
      FindClose(SR);
    end;
    W.AddShort('</table></p><p><i>Powered by mORMot''s <strong>');
 
    W.AddClassName(Ctxt.Server.ClassType);
 
    W.AddShort('</strong></i> - ' +
      'see <a href=https://synopse.info>https://synopse.info</a></p></body></html>');
    Ctxt.OutContent := W.Text;
    Ctxt.OutContentType := HTML_CONTENT_TYPE;
    result := 200;
  finally
    W.Free;
  end;
 
end;
 
begin
  with TTestServer.Create('D:\Programs\Nginx\wwwroot\') do try
    Msg := 'Server is now running on http';
    if fHttps then Msg := Msg + 's';
    msg := msg + '://localhost';
    if fPort <> '80' then
      Msg := Msg + ':' + fPort;
    Msg := Msg + fRoot + #13#10#13#10'Press [Enter] to quit';
    WriteLn(Msg);
    readln;
  finally
    Free;
  end;
end.

　　

 

posted @   delphi中间件  阅读(2366)  评论(1)  编辑  收藏  举报
编辑推荐：
· .NET Core 中如何实现缓存的预热？
· 从 HTTP 原因短语缺失研究 HTTP/2 和 HTTP/3 的设计差异
· AI与.NET技术实操系列：向量存储与相似性搜索在 .NET 中的实现
· 基于Microsoft.Extensions.AI核心库实现RAG应用
· Linux系列：如何用heaptrack跟踪.NET程序的非托管内存泄露
阅读排行：
· TypeScript + Deepseek 打造卜卦网站：技术与玄学的结合
· Manus的开源复刻OpenManus初探
· AI 智能体引爆开源社区「GitHub 热点速览」
· 三行代码完成国际化适配，妙~啊~
· .NET Core 中如何实现缓存的预热？
历史上的今天：
2015-12-21 DELPHI7加载UNICODE编码格式的TXT显示为乱码的解决方法
2013-12-21 冬至
点击右上角即可分享
微信分享提示
SQL AI 助手