mormot2 THttpAsyncServer

mormot2 THttpAsyncServer

支持delphi和lazarus。

/// <author>cxg 2023-2-12</author>
/// mormot2 异步httpserver 支持delphi+lazarus
unit sock.mormot2.httpserver;
{$IFDEF fpc}
  {$MODE DELPHI}{$H+}
{$ENDIF}

interface

uses
  classes, keyValue.serialize, api.router, IniFiles,
  mormot.Net.sock, SysUtils, system.JSON, json.help, mormot.net.async,
  mormot.net.http, mormot.net.server;

var
  BinApis: TJSONObject;    //二进制API
  RestApis: TJSONObject;   //REST API，包括json,protobuf

const  //content-type
  cBin = 'application/octet-stream; charset=utf-8';
  cJson = 'application/json; charset=utf-8';
  cProtobuf = 'application/protobuf; charset=utf-8';

type
  THttpSVR = class
  private
    FServer: THttpAsyncServer;
    function process(Ctxt: THttpServerRequestAbstract): cardinal;
  public
    constructor Create;
    destructor Destroy; override;
  end;

implementation

function ReadJsonFile(const FileName: string): string;
begin
  var f: TStringList := TStringList.Create;
  f.LoadFromFile(FileName, TEncoding.UTF8);
  Result := f.Text;
  f.Free;
end;

function strof(const aBytes: TBytes): RawByteString; overload;
begin
  SetLength(Result, Length(aBytes));
  Move(aBytes[0], Result[1], Length(aBytes));
end;

procedure setHeader(const Ctxt: THttpServerRequestAbstract; const ContentType: string);  //mormot2 binary http header
begin
  Ctxt.OutContentType := ContentType;
  Ctxt.OutCustomHeaders := 'Access-Control-Allow-Origin:*' + #13#10 + 'Access-Control-Allow-Methods:*' + #13#10 + 'Access-Control-Allow-Headers:*';
end;

procedure router(const Ctxt: THttpServerRequestAbstract);  //mormot2 router
begin
  if Pos('/bin', Ctxt.URL) > 0 then      //二进制 API
  begin
    setHeader(Ctxt, cBin);
    var req: TSerialize := tserialize.Create;
    var res: TSerialize := tserialize.Create;
    if Ctxt.InContent > '' then
      req.unMarshal(Ctxt.InContent);
    var url: string := Ctxt.URL;
    var arr: TArray<string> := url.Split(['/']);
    var funcName: string := arr[2];
    var ja: TJSONArray := BinApis.A['bin'];
    for var i: Integer := 0 to ja.Count - 1 do
    begin
      var o: TJSONObject := ja.Items[i] as TJSONObject;
      if o.S['funcname'] = funcName then
      begin
        RouterAPI(o.S['classname'], o.S['funcname'], [req, res]);
        Break;
      end;
    end;
    Ctxt.OutContent := res.marshal3;
    req.Free;
    res.Free;
  end
  else if Pos('/rest', Ctxt.URL) > 0 then    //JSON API
  begin
    setHeader(Ctxt, cJson);
    var url: string := Ctxt.URL;
    var arr: TArray<string> := url.Split(['/']);
    var resource: string := arr[2];
    var req: TSerialize := tserialize.Create;
    var res: TSerialize := tserialize.Create;
    req.asStr['url'] := url;
    if Ctxt.InContent > '' then
      req.asStr['body'] := Ctxt.InContent;
    req.asStr['type'] := 'json';
    var ja: TJSONArray := RestApis.A[resource];
    for var i: Integer := 0 to ja.Count - 1 do
    begin
      var o: TJSONObject := ja.Items[i] as TJSONObject;
      if o.S['method'] = Ctxt.Method then
      begin
        RouterAPI(o.S['classname'], o.S['funcname'], [req, res]);
        Break;
      end;
    end;
    Ctxt.OutContent := UTF8Encode(res.asStr['res']);
    req.Free;
    res.Free;
  end
  else if Pos('/protobuf', Ctxt.URL) > 0 then   //PROTOBUF API
  begin
    setHeader(Ctxt, cProtobuf);
    var url: string := Ctxt.URL;
    var arr: TArray<string> := url.Split(['/']);
    var resource: string := arr[2];
    var req: TSerialize := tserialize.Create;
    var res: TSerialize := tserialize.Create;
    req.asStr['url'] := url;
    if Ctxt.InContent > '' then
      req.asBytes['body'] := BytesOf(Ctxt.InContent);
    req.asStr['type'] := 'protobuf';
    var ja: TJSONArray := RestApis.A[resource];
    for var i: Integer := 0 to ja.Count - 1 do
    begin
      var o: TJSONObject := ja.Items[i] as TJSONObject;
      if o.S['method'] = Ctxt.Method then
      begin
        RouterAPI(o.S['classname'], o.S['funcname'], [req, res]);
        Break;
      end;
    end;
    Ctxt.OutContent := strof(res.asBytes['res']);
    req.Free;
    res.Free;
  end;
end;

{ THttpSVR }

constructor THttpSVR.Create;
var
  ini: tinifile;
  httpport: string;
  threadnum: integer;
  ssl: Boolean;
  KeepAliveTimeOut: Integer;
  queueLen: Integer;
  tls: TNetTlsContext;
begin
  ini := tinifile.create(extractfilepath(paramstr(0)) + 'server.conf');
  httpport := ini.readstring('config', 'httpport', '1122');
  threadnum := ini.readinteger('config', 'threadnum', 32);
  if threadnum > 256 then
    threadnum := 256;
  ssl := ini.ReadBool('config', 'ssl', False); //https?
  ini.free;
  KeepAliveTimeOut := 30000;
  if not ssl then
    FServer := THttpAsyncServer.Create(httpport, nil, nil, 'yn', threadnum, KeepAliveTimeOut, [])
  else
    FServer := THttpAsyncServer.Create(httpport, nil, nil, 'yn', threadnum, KeepAliveTimeOut, [hsoEnableTls]);
  queueLen := 100000;
  FServer.HttpQueueLength := queueLen;
  FServer.OnRequest := process;
  if not ssl then
    FServer.WaitStarted
  else
  begin
    InitNetTlsContextSelfSignedServer(tls);  //自签名
    try
      FServer.WaitStarted(10, @tls);
    finally
      DeleteFile(Utf8ToString(tls.CertificateFile));
      DeleteFile(Utf8ToString(tls.PrivateKeyFile));
    end;
  end;
  {$IFDEF console}
  Writeln('New THttpAsyncServer server');
  if not ssl then
    Writeln('Http port: ', httpport)
  else
    Writeln('Https port: ', httpport);
  Writeln('Thread num: ', threadnum);
  {$ENDIF}
end;

destructor THttpSVR.Destroy;
begin
  FreeAndNil(FServer);
  inherited;
end;

function THttpSVR.process(Ctxt: THttpServerRequestAbstract): cardinal;
begin
  router(Ctxt);
  Result := 200;
end;

initialization
  binapis := TJSONObject.Create;
  restapis := TJSONObject.Create;
  binapis.Parse(ReadJsonFile(ExtractFilePath(ParamStr(0)) + 'binrouter.json'));
  restapis.Parse(ReadJsonFile(ExtractFilePath(ParamStr(0)) + 'restrouter.json'));

finalization
  FreeAndNil(binapis);
  FreeAndNil(restapis);

end.