Messages

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; 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; 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.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 := '' + '' + '' + 'Messages

'; end; function TTTW_Chat.GenerateJSON: string; var MsgList: TList; 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.