ttw_fmx_v10/utils/uWebServerChat.pas

295 lines
9.3 KiB
Plaintext

unit uWebServerChat;
interface
uses System.classes, System.StrUtils, System.DateUtils, System.JSON, System.Generics.Collections,
IdBaseComponent, IdComponent, IdCustomTCPServer, IdContext,
IdCustomHTTPServer, uRecords, System.IOUtils, IdGlobalProtocols,
IdHTTPServer, System.SysUtils;
type
TTwitchMessage = record
Nickname: string;
Content: string;
Timestamp: TDateTime;
TimeMsg: Integer;
end;
type
TTTW_Chat = class(TObject)
fFontsList: tstringlist;
IdHTTPServer1: TIdHTTPServer;
procedure IdHTTPServer1CommandGet(AContext: TIdContext;
ARequestInfo: TIdHTTPRequestInfo; AResponseInfo: TIdHTTPResponseInfo);
private
FBColor: string;
Messages: TThreadList<TTwitchMessage>;
FDeleteByTime: Boolean; // Ðåæèì óäàëåíèÿ: ïî âðåìåíè (true) èëè êîëè÷åñòâó (false)
FMaxMsgCount: Integer; // Ìàêñèìàëüíîå êîëè÷åñòâî ñîîáùåíèé
function GenerateHTML: string;
function GenerateJSON: string;
procedure CleanupOldMessages;
public
msgStyle: TStyleChat;
constructor Create(FontList: tstrings; aPort:integer; aColor:string);
destructor Destroy;
procedure addMessage(newMsg: TStyleChat);
procedure ActiveServer(aEn: boolean);
procedure SetDeleteMode(DeleteByTime: Boolean; MaxMsgCount: Integer); // Óñòàíîâêà ðåæèìà óäàëåíèÿ
procedure changeBackground(aColor:string);
end;
var
Timestamp2: string;
implementation
uses uGeneral;
{ TTTW_Chat }
procedure TTTW_Chat.SetDeleteMode(DeleteByTime: Boolean; MaxMsgCount: Integer);
begin
FDeleteByTime := DeleteByTime;
FMaxMsgCount := MaxMsgCount;
end;
procedure TTTW_Chat.ActiveServer(aEn: boolean);
begin
IdHTTPServer1.Active := aEn;
end;
procedure TTTW_Chat.addMessage(newMsg: TStyleChat);
var
Msg: TTwitchMessage;
begin
Msg.Nickname := newMsg.Nick;
Msg.Content := newMsg.Context;
Msg.Timestamp := now;
Msg.TimeMsg := newMsg.TimeMsg;
msgStyle := newMsg;
with Messages.LockList do
try
if not FDeleteByTime then
begin
// Óäàëåíèå ñòàðûõ ñîîáùåíèé ïðè ïðåâûøåíèè ëèìèòà
while Count >= FMaxMsgCount do
Delete(0);
end;
Add(Msg);
finally
Messages.UnlockList;
end;
end;
procedure TTTW_Chat.changeBackground(aColor: string);
begin
FBColor:=aColor;
end;
procedure TTTW_Chat.CleanupOldMessages;
var
MsgList: TList<TTwitchMessage>;
I: integer;
ExpiryTime: TDateTime;
begin
if not FDeleteByTime then
Exit; // Âûõîäèì, åñëè óäàëåíèå ïî âðåìåíè îòêëþ÷åíî
MsgList := Messages.LockList;
try
for I := MsgList.Count - 1 downto 0 do
begin
ExpiryTime := Now - (MsgList[I].TimeMsg / 86400); // Èñïîëüçóåì çíà÷åíèå èç ñîîáùåíèÿ
if MsgList[I].Timestamp < ExpiryTime then
MsgList.Delete(I);
end;
finally
Messages.UnlockList;
end;
end;
constructor TTTW_Chat.Create(FontList: tstrings; aPort:integer;AColor:string);
var
I: integer;
begin
FBColor := AColor;
Messages := TThreadList<TTwitchMessage>.Create;
IdHTTPServer1 := TIdHTTPServer.Create;
IdHTTPServer1.DefaultPort := aPort;
IdHTTPServer1.OnCommandGet := IdHTTPServer1CommandGet;
fFontsList := tstringlist.Create;
for I := 0 to FontList.Count - 1 do
fFontsList.Add(FontList[I]);
FDeleteByTime := True; // Ïî óìîë÷àíèþ óäàëåíèå ïî âðåìåíè
FMaxMsgCount := 100; // Çíà÷åíèå ïî óìîë÷àíèþ
end;
destructor TTTW_Chat.Destroy;
begin
Messages.Free;
IdHTTPServer1.Active := false;
IdHTTPServer1.Free;
fFontsList.Free;
end;
function TTTW_Chat.GenerateHTML: string;
var
I: integer;
s, s1: string;
DeleteByTimeJS: string;
begin
DeleteByTimeJS := LowerCase(BoolToStr(FDeleteByTime)); // Ïðåîáðàçóåì áóëåâî çíà÷åíèå â ñòðîêó 'true' èëè 'false'
s := 'body { background: ' + FBColor + '; }' + #13#10;
for I := 41 to fFontsList.Count - 1 do
begin
s1 := StringReplace(fFontsList[I], '.ttf', '', [rfReplaceAll]);
s := s + '@font-face { font-family: ''' + s1 + '''; src: url(fonts/' + fFontsList[I] + '); }' + #13#10;
end;
Result := '<!DOCTYPE html><html><head>' +
'<meta http-equiv="Cache-Control" content="no-cache, no-store, must-revalidate">' +
'<meta http-equiv="Pragma" content="no-cache"><meta http-equiv="Expires" content="0">' +
'<title>Messages</title><style>' + s +
'.message { margin:5px; border-radius:5px; transition: opacity 1s linear; display: flex; align-items: center; }' +
'.message-icon { width: 1.5em; height: 1.5em; margin-right: 0.5em; }' + // Ñòèëü äëÿ èêîíêè
'</style><script>' +
'let existingMessages = new Map(); let fetching = false;' +
'function fetchMessages() {' +
' if (fetching) return; fetching = true;' +
' fetch("/messages").then(response => response.json()).then(data => {' +
' const container = document.getElementById("messages");' +
' const newIds = new Set();' +
' data.forEach(msg => {' +
' const msgId = "msg-" + msg.timestamp;' +
' newIds.add(msgId);' +
' if (!existingMessages.has(msgId)) {' +
' const div = document.createElement("div");' +
' div.className = "message";' +
' div.id = msgId;' +
' div.style = `background-color:${msg.color}; font-family:${msg.family}; ' +
' padding:${msg.padding}px; border: ${msg.sizeBorder}px solid ${msg.colorBorder}; ' +
' color:${msg.colorText}; font-size:${msg.fontSize}px;`;' +
' div.innerHTML = `' +
// ' <img src="${msg.iconUrl}" class="message-icon">' + // Äîáàâëåíà èêîíêà
' <div><b>${msg.nickname}:</b> ${msg.content}</div>`;' +
' div.style.opacity = "1";' +
' container.appendChild(div);' +
' existingMessages.set(msgId, div);' +
' if (deleteByTime) {' + // Óñòàíàâëèâàåì òàéìåð òîëüêî åñëè âêëþ÷åíî óäàëåíèå ïî âðåìåíè
' setTimeout(() => {' +
' div.style.opacity = "0";' +
' setTimeout(() => { div.remove(); existingMessages.delete(msgId); }, 1000);' +
' }, msg.timeMsg * 1000);' +
' }' +
' }' +
' });' +
' existingMessages.forEach((div, msgId) => {' +
' if (!newIds.has(msgId)) { div.remove(); existingMessages.delete(msgId); }' +
' });' +
' }).finally(() => { fetching = false; });' +
'}' +
'setInterval(fetchMessages, 500); fetchMessages();' +
'</script></head><body><div id="messages"></div></body></html>';
end;
function TTTW_Chat.GenerateJSON: string;
var
MsgList: TList<TTwitchMessage>;
Msg: TTwitchMessage;
JSONArray: TJSONArray;
JSONObject: TJSONObject;
begin
JSONArray := TJSONArray.Create;
try
MsgList := Messages.LockList;
try
for Msg in MsgList do
begin
JSONObject := TJSONObject.Create;
JSONObject.AddPair('nickname', Msg.Nickname);
JSONObject.AddPair('content', Msg.Content);
JSONObject.AddPair('timestamp',
TJSONNumber.Create(DateTimeToUnix(Msg.Timestamp)));
JSONObject.AddPair('color', msgStyle.BlockColor); // Îñòàâëÿåì HEX-öâåò
JSONObject.AddPair('bcolor', msgStyle.BColor); // Îñòàâëÿåì HEX-öâåò
JSONObject.AddPair('fontSize', TJSONNumber.Create(msgStyle.FontSize));
JSONObject.AddPair('colorText', msgStyle.FontColor);
JSONObject.AddPair('colorBorder', msgStyle.BorderColor);
JSONObject.AddPair('sizeBorder',
TJSONNumber.Create(msgStyle.BorderSize));
JSONObject.AddPair('padding', TJSONNumber.Create(msgStyle.BorderSize));
JSONObject.AddPair('family', msgStyle.FontFamily);
JSONObject.AddPair('timeMsg', TJSONNumber.Create(Msg.TimeMsg)); // Äîáàâëÿåì âðåìÿ
// Óïðàâëÿåò òîëüêî áëîêîì, íå òåêñòîì
JSONArray.Add(JSONObject);
end;
finally
Messages.UnlockList;
end;
Result := JSONArray.ToString;
finally
JSONArray.Free;
end;
end;
procedure TTTW_Chat.IdHTTPServer1CommandGet(AContext: TIdContext;
ARequestInfo: TIdHTTPRequestInfo; AResponseInfo: TIdHTTPResponseInfo);
var
HtmlContent: string;
FontFileName: string;
FontFilePath: string;
MIMEType: string;
FS: TFileStream;
begin
CleanupOldMessages;
if ARequestInfo.Document = '/messages' then
begin
AResponseInfo.ContentType := 'application/json; charset=utf-8';
AResponseInfo.ContentText := GenerateJSON;
end
else if Pos('/fonts/', ARequestInfo.Document) = 1 then
// Ïðîâåðÿåì çàïðîñ ê øðèôòàì
begin
// Èçâëåêàåì èìÿ ôàéëà èç URL
FontFileName := TPath.GetFileName(ARequestInfo.Document);
// Ôîðìèðóåì ïîëíûé ïóòü ê ôàéëó (ïàïêà fonts äîëæíà áûòü ðÿäîì ñ èñïîëíÿåìûì ôàéëîì)
FontFilePath := myConst.fontsPath + FontFileName;
// Ïðîâåðÿåì ñóùåñòâîâàíèå ôàéëà
if FileExists(FontFilePath) then
begin
MIMEType := 'font/ttf';
// Íàñòðàèâàåì îòâåò
AResponseInfo.ContentType := MIMEType;
try
FS := TFileStream.Create(FontFilePath, fmOpenRead + fmShareDenyWrite);
AResponseInfo.ContentStream := FS;
AResponseInfo.ResponseNo := 200;
except
FS.Free;
AResponseInfo.ResponseNo := 500;
end;
end;
end
else
begin
AResponseInfo.CacheControl := 'no-cache, no-store, must-revalidate';
AResponseInfo.Pragma := 'no-cache';
AResponseInfo.Expires := 0;
Timestamp2 := IntToStr(DateTimeToUnix(now));
AResponseInfo.ContentType := 'text/html; charset=utf-8';
AResponseInfo.ContentText := GenerateHTML;
end;
end;
end.