From 33d493b29f0e6fd33c928afde1d7a46115b6012d Mon Sep 17 00:00:00 2001 From: Craig Moksnes Date: Wed, 11 Mar 2020 16:57:04 -0500 Subject: [PATCH] Log discovery and other files. HDHomeRun UPnP response is now more correct. Added /videotest service to make it easier to troubleshoot encoding/transferring video related issues --- LogUtils.pas | 19 +++-- ProxyFormUnit.fmx | 66 +++------------- ProxyFormUnit.pas | 74 ++++++----------- ProxyServerModuleUnit.pas | 107 ++++++++++++++++++++----- ProxyServiceModuleUnit.pas | 145 ++++++++++++++++++++-------------- ProxyWebModuleUnit.dfm | 5 ++ ProxyWebModuleUnit.pas | 158 +++++++++++++++++++++++++++---------- SocketUtils.pas | 108 ++++++++++++++++++------- VideoUtils.pas | 7 +- ceton/Ceton.pas | 84 +++++++++++++++----- 10 files changed, 485 insertions(+), 288 deletions(-) diff --git a/LogUtils.pas b/LogUtils.pas index ef6e788..e077944 100644 --- a/LogUtils.pas +++ b/LogUtils.pas @@ -5,10 +5,15 @@ interface uses System.SysUtils; +const + cLogDefault = 'default'; + cLogDiscovery = 'discovery'; + cLogNames: Array[0..1] of String = (cLogDefault, cLogDiscovery); + type ILogger = interface ['{772B05D3-D06A-4E0D-A259-929772F8704D}'] - procedure Log(const aMessage: String); + procedure Log(const aLogName: String; const aMessage: String); end; TLogger = class abstract @@ -16,8 +21,8 @@ TLogger = class abstract class var fLogger: ILogger; public - class procedure Log(const aMessage: String); static; - class procedure LogFmt(const aMessage: String; const aArgs: array of const); static; + class procedure Log(const aLogName: String; const aMessage: String); static; + class procedure LogFmt(const aLogName: String; const aMessage: String; const aArgs: array of const); static; class procedure SetLogger(const aLogger: ILogger); static; end; @@ -26,10 +31,10 @@ implementation { TLogger } -class procedure TLogger.Log(const aMessage: String); +class procedure TLogger.Log(const aLogName: String; const aMessage: String); begin if Assigned(fLogger) then - fLogger.Log(aMessage); + fLogger.Log(aLogName, aMessage); end; class procedure TLogger.SetLogger(const aLogger: ILogger); @@ -37,9 +42,9 @@ class procedure TLogger.SetLogger(const aLogger: ILogger); fLogger := aLogger; end; -class procedure TLogger.LogFmt(const aMessage: String; const aArgs: array of const); +class procedure TLogger.LogFmt(const aLogName: String; const aMessage: String; const aArgs: array of const); begin - Log(Format(aMessage, aArgs)); + Log(aLogName, Format(aMessage, aArgs)); end; end. diff --git a/ProxyFormUnit.fmx b/ProxyFormUnit.fmx index fa95d1b..a69fd89 100644 --- a/ProxyFormUnit.fmx +++ b/ProxyFormUnit.fmx @@ -2,7 +2,7 @@ object MainForm: TMainForm Left = 0 Top = 0 Caption = 'Ceton HDHomeRun Proxy' - ClientHeight = 507 + ClientHeight = 492 ClientWidth = 400 Fill.Kind = Solid Position = ScreenCenter @@ -12,20 +12,21 @@ object MainForm: TMainForm FormFactor.Devices = [Desktop, iPhone, iPad] OnCreate = FormCreate OnDestroy = FormDestroy + OnMouseWheel = FormMouseWheel OnShow = FormShow DesignerMasterStyle = 0 object VertScrollBox1: TVertScrollBox Align = Client Size.Width = 400.000000000000000000 - Size.Height = 507.000000000000000000 + Size.Height = 492.000000000000000000 Size.PlatformDefault = False TabOrder = 3 Viewport.Width = 400.000000000000000000 - Viewport.Height = 507.000000000000000000 + Viewport.Height = 492.000000000000000000 object OuterPanelContainer: TLayout Align = Top Size.Width = 400.000000000000000000 - Size.Height = 505.000000000000000000 + Size.Height = 489.000000000000000000 Size.PlatformDefault = False TabOrder = 0 object PanelContainer: TLayout @@ -302,7 +303,7 @@ object MainForm: TMainForm object Layout1: TLayout Align = Bottom Position.Y = 166.000000000000000000 - Size.Width = 200.000000000000000000 + Size.Width = 394.000000000000000000 Size.Height = 34.000000000000000000 Size.PlatformDefault = False TabOrder = 0 @@ -318,7 +319,7 @@ object MainForm: TMainForm end object btnRefreshChannels: TButton Anchors = [akTop, akRight] - Position.X = 69.000000000000000000 + Position.X = 263.000000000000000000 Position.Y = 4.000000000000000000 Size.Width = 121.000000000000000000 Size.Height = 22.000000000000000000 @@ -342,7 +343,7 @@ object MainForm: TMainForm Margins.Left = 10.000000000000000000 Margins.Top = 9.000000000000000000 Margins.Right = 10.000000000000000000 - Size.Width = 180.000000000000000000 + Size.Width = 374.000000000000000000 Size.Height = 157.000000000000000000 Size.PlatformDefault = False TabOrder = 1 @@ -352,7 +353,7 @@ object MainForm: TMainForm DefaultItemStyles.GroupFooterStyle = '' ShowCheckboxes = True OnChangeCheck = lbChannelsChangeCheck - Viewport.Width = 176.000000000000000000 + Viewport.Width = 370.000000000000000000 Viewport.Height = 153.000000000000000000 end end @@ -376,55 +377,6 @@ object MainForm: TMainForm Size.Height = 6.000000000000000000 Size.PlatformDefault = False end - object pnlDebug: TExpander - Align = Top - IsExpanded = False - Margins.Left = 3.000000000000000000 - Margins.Right = 3.000000000000000000 - Margins.Bottom = 3.000000000000000000 - Position.X = 3.000000000000000000 - Position.Y = 480.000000000000000000 - ShowCheck = False - Size.Width = 394.000000000000000000 - Size.Height = 20.000000000000000000 - Size.PlatformDefault = False - Text = 'Debug' - TabOrder = 6 - OnMouseDown = PanelMouseDown - OnResized = PanelResizing - ContentSize = '41' - object btnGetVideoSample: TButton - Position.X = 176.000000000000000000 - Position.Y = 11.000000000000000000 - Size.Width = 121.000000000000000000 - Size.Height = 22.000000000000000000 - Size.PlatformDefault = False - TabOrder = 0 - Text = 'Get Video Sample' - OnClick = btnGetVideoSampleClick - end - object seChannel: TSpinBox - Touch.InteractiveGestures = [LongTap, DoubleTap] - TabOrder = 2 - Cursor = crIBeam - Max = 10000.000000000000000000 - RepeatClick = True - Position.X = 77.000000000000000000 - Position.Y = 11.000000000000000000 - Size.Width = 89.000000000000000000 - Size.Height = 22.000000000000000000 - Size.PlatformDefault = False - end - object Label8: TLabel - Position.X = 24.000000000000000000 - Position.Y = 14.000000000000000000 - Size.Width = 89.000000000000000000 - Size.Height = 17.000000000000000000 - Size.PlatformDefault = False - Text = 'Channel:' - TabOrder = 1 - end - end end end end diff --git a/ProxyFormUnit.pas b/ProxyFormUnit.pas index d858ae5..963c26f 100644 --- a/ProxyFormUnit.pas +++ b/ProxyFormUnit.pas @@ -36,6 +36,7 @@ interface FMX.ListView, FMX.SpinBox, FMX.Menus, + FMX.Platform, REST.json, REST.Client, @@ -92,10 +93,6 @@ TMainForm = class(TForm, IServiceConfigEvents) Splitter1: TSplitter; Splitter2: TSplitter; OuterPanelContainer: TLayout; - pnlDebug: TExpander; - btnGetVideoSample: TButton; - seChannel: TSpinBox; - Label8: TLabel; HelpCallout: TCalloutRectangle; lblHelp: TLabel; eCetonTunerAddress: TComboEdit; @@ -110,7 +107,6 @@ TMainForm = class(TForm, IServiceConfigEvents) procedure btnRefreshChannelsClick(Sender: TObject); procedure eHDHRListenHTTPPortChangeTracking(Sender: TObject); procedure ceHDHRListenIPChangeTracking(Sender: TObject); - procedure btnGetVideoSampleClick(Sender: TObject); procedure btnShowConfigFolderClick(Sender: TObject); procedure PanelResizing(Sender: TObject); procedure eHDHRExternalAddressChangeTracking(Sender: TObject); @@ -119,6 +115,8 @@ TMainForm = class(TForm, IServiceConfigEvents) procedure EditMouseLeave(Sender: TObject); procedure PanelMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Single); + procedure FormMouseWheel(Sender: TObject; Shift: TShiftState; + WheelDelta: Integer; var Handled: Boolean); private { Private declarations } fConfigManager: IServiceConfigManager; @@ -151,7 +149,7 @@ TMainForm = class(TForm, IServiceConfigEvents) protected // IServiceConfigEvents procedure Changed(const aSender: TObject; const aSections: TServiceConfigSections); - procedure Log(const aMessage: String); + procedure Log(const aLogName: String; const aMessage: String); procedure DiscoveredCetonDevicesChanged; public { Public declarations } @@ -644,50 +642,7 @@ function TMainForm.ExtractIP(const aComboEdit: TComboEdit): String; end; end; -procedure TMainForm.btnGetVideoSampleClick(Sender: TObject); -var - lStream: TCetonVideoStream; - lStopWatch: TStopWatch; - lBuffer: array[0..8191] of Byte; - lSize: Integer; - lFS: TFileStream; - lChannel: TChannelMapItem; - lFilename: String; -begin - lFilename := 'Sample.ts'; - - lChannel := TChannelMapItem.Create; - try - if Client.TryGetChannel(Round(seChannel.Value), lChannel) then - begin - lFilename := Format('SampleCh%dP%d.ts', [lChannel.Channel, lChannel.ItemProgram]); - end; - finally - lChannel.Free; - end; - - lFS := TFile.Create(ExtractFilePath(ParamStr(0))+lFilename); - try - lStream := TCetonVideoStream.Create(Client, -1, Round(seChannel.Value), False); - try - lStopWatch := TStopWatch.StartNew; - while lStopWatch.ElapsedMilliseconds <= 6000 do - begin - lSize := lStream.Read(lBuffer, SizeOf(lBuffer)); - if lSize = 0 then - Break; - - lFS.WriteBuffer(lBuffer, lSize); - end; - finally - lStream.Free; - end; - finally - lFS.Free; - end; -end; - -procedure TMainForm.Log(const aMessage: String); +procedure TMainForm.Log(const aLogName: String; const aMessage: String); begin // TODO end; @@ -700,7 +655,7 @@ procedure TMainForm.btnShowConfigFolderClick(Sender: TObject); procedure TMainForm.PanelResizing(Sender: TObject); begin // Always keep the outer panel container at content size so the scrolling matches the content - OuterPanelContainer.Height := pnlDebug.Position.Y + pnlDebug.Height + pnlDebug.Margins.Bottom; + OuterPanelContainer.Height := Splitter2.Position.Y + Splitter2.Height; // But make the panel container much larger so that splitters have lots of room to work with PanelContainer.Height := OuterPanelContainer.Height + 1000; end; @@ -793,4 +748,21 @@ procedure TMainForm.DiscoveredCetonDevicesChanged; end); end; +type + TCustomScrollBox_Access = class(TCustomScrollBox); + +procedure TMainForm.FormMouseWheel(Sender: TObject; Shift: TShiftState; + WheelDelta: Integer; var Handled: Boolean); +var + lControl: IControl; +begin + lControl := ObjectAtPoint(Screen.MousePos); + if Assigned(lControl) and (not (lControl.GetObject is TListBox)) then + begin + // Force all mouse wheel handling to go to scrollbox. There's probably a better way to do this. + TCustomScrollBox_Access(VertScrollBox1).MouseWheel(Shift, WheelDelta, Handled); + Handled := True; + end; +end; + end. diff --git a/ProxyServerModuleUnit.pas b/ProxyServerModuleUnit.pas index f4778ba..4fd79d4 100644 --- a/ProxyServerModuleUnit.pas +++ b/ProxyServerModuleUnit.pas @@ -7,6 +7,7 @@ interface System.Classes, System.Diagnostics, System.Generics.Collections, + System.DateUtils, Winapi.ActiveX, FMX.Types, FMX.Dialogs, @@ -40,6 +41,8 @@ interface SSDP_MULTICAST_GROUP = '239.255.255.250'; SSDP_PORT = 1900; + cSSDPAliveIntervalSec = 1800; + type TIdCOMThread = class(TIdThreadWithTask) protected @@ -75,6 +78,7 @@ TProxyServerModule = class(TDataModule, IServiceConfigEvents) procedure ServerException(AContext: TIdContext; AException: Exception); function CreateSSDPDiscoverPacket: String; + function TryCreateSSDPResponsePacket(const aRequestHost: String; out aPacket: String): Boolean; function TryCreateSSDPAlivePacket(const aRequestHost: String; out aPacket: String): Boolean; procedure DiscoverCetonDevices; @@ -86,7 +90,7 @@ TProxyServerModule = class(TDataModule, IServiceConfigEvents) protected // IServiceConfigEvents procedure Changed(const aSender: TObject; const aSections: TServiceConfigSections); - procedure Log(const aMessage: String); + procedure Log(const aLogName: String; const aMessage: String); procedure DiscoveredCetonDevicesChanged; public { Public declarations } @@ -209,7 +213,7 @@ procedure TProxyServerModule.StartServer; end; fServer.Active := True; except - TLogger.Log('Unable to bind HTTP server listening port'); + TLogger.Log(cLogDefault, 'Unable to bind HTTP server listening port'); end; try @@ -236,7 +240,7 @@ procedure TProxyServerModule.StartServer; end; fDiscoveryServer.Active := True; except - TLogger.Log('Unable to bind discovery listening port'); + TLogger.Log(cLogDefault, 'Unable to bind discovery listening port'); end; { try @@ -248,7 +252,7 @@ procedure TProxyServerModule.StartServer; end; fControlServer.Active := True; except - TLogger.Log('Unable to bind control listening port'); + TLogger.Log(cLogDefault, 'Unable to bind control listening port'); end;} try @@ -277,7 +281,7 @@ procedure TProxyServerModule.StartServer; fSSDPClient.ReuseSocket := rsTrue; fSSDPClient.Active := True; except - TLogger.Log('Unable to bind SSDP listening port'); + TLogger.Log(cLogDefault, 'Unable to bind SSDP listening port'); end; try @@ -290,7 +294,7 @@ procedure TProxyServerModule.StartServer; end; fSSDPServer.Active := True; except - TLogger.Log('Unable to create SSDP server'); + TLogger.Log(cLogDefault, 'Unable to create SSDP server'); end; // Send broadcast for UPnP devices @@ -358,7 +362,7 @@ procedure TProxyServerModule.DiscoveryUDPRead(AThread: TIdUDPListenerThread; begin SetLength(lHex, Length(AData)*2); BinToHex(AData, PAnsiChar(lHex), Length(AData)); - TLogger.LogFmt('Received control data from %s on %s: %s', [ABinding.PeerIP, ABinding.IP, lHex]); + TLogger.LogFmt(cLogDiscovery,'Received control data from %s on %s: %s', [ABinding.PeerIP, ABinding.IP, lHex]); if TPacket.TryFromBytes(TBytes(AData), lPacket) then begin @@ -367,7 +371,7 @@ procedure TProxyServerModule.DiscoveryUDPRead(AThread: TIdUDPListenerThread; case lPacket._Type of HDHOMERUN_TYPE_DISCOVER_REQ: begin lDiscovery := lPacket.ToDiscovery; - TLogger.LogFmt('Received discovery request: Device type: %d, Device ID: %s', [lDiscovery.DeviceType, IntToHex(lDiscovery.DeviceID, 8)]); + TLogger.LogFmt(cLogDiscovery,'Received discovery request: Device type: %d, Device ID: %s', [lDiscovery.DeviceType, IntToHex(lDiscovery.DeviceID, 8)]); ConfigManager.LockConfig(lConfig); try @@ -396,7 +400,7 @@ procedure TProxyServerModule.DiscoveryUDPRead(AThread: TIdUDPListenerThread; lBytes := TPacket.FromDiscovery(False, lDiscovery).ToBytes; SetLength(lHex, Length(lBytes)*2); BinToHex(lBytes, PAnsiChar(lHex), Length(lBytes)); - TLogger.LogFmt('Sending discovery response: Device ID: %s, Base URL: %s, %s', [IntToHex(lDiscovery.DeviceID, 8), lDiscovery.BaseURL, lHex]); + TLogger.LogFmt(cLogDiscovery,'Sending discovery response: Device ID: %s, Base URL: %s, %s', [IntToHex(lDiscovery.DeviceID, 8), lDiscovery.BaseURL, lHex]); AThread.Server.SendBuffer(ABinding.PeerIP, ABinding.PeerPort, TIdBytes(lBytes)); end; @@ -404,7 +408,7 @@ procedure TProxyServerModule.DiscoveryUDPRead(AThread: TIdUDPListenerThread; end; HDHOMERUN_TYPE_DISCOVER_RPY: begin lDiscovery := lPacket.ToDiscovery; - TLogger.LogFmt('Received discovery reply: Device type: %d, Device ID: %s', [lDiscovery.DeviceType, IntToHex(lDiscovery.DeviceID, 8)]); + TLogger.LogFmt(cLogDiscovery,'Received discovery reply: Device type: %d, Device ID: %s', [lDiscovery.DeviceType, IntToHex(lDiscovery.DeviceID, 8)]); end; end; end; @@ -495,12 +499,12 @@ function TProxyServerModule.TryGetAddress(const aRequestLocalIP: String; out aAd procedure TProxyServerModule.ControlTCPConnect(aContext: TIdContext); begin - TLogger.Log('Control connect'); + TLogger.Log(cLogDefault, 'Control connect'); end; procedure TProxyServerModule.ControlTCPExecute(aContext: TIdContext); begin - TLogger.Log('Control execute'); + TLogger.Log(cLogDefault, 'Control execute'); end; {Description: Ceton InfiniTV MOCUR (00-00-22-00-00-XX-XX-XX) @@ -575,7 +579,9 @@ function TProxyServerModule.CreateSSDPDiscoverPacket: String; cSSDPDiscover = 'M-SEARCH * HTTP/1.1'#13#10+ 'Host: 239.255.255.250:1900'#13#10+ - 'ST: '+{'ssdp:all'}'urn:schemas-cetoncorp-com:device:SecureContainer:1'#13#10+ +// 'ST: ssdp:all'#13#10+ + 'ST: urn:schemas-cetoncorp-com:device:SecureContainer:1'#13#10+ +// 'ST: upnp:rootdevice'#13#10+ 'Man: "ssdp:discover"'#13#10+ 'MX: 3'#13#10#13#10; begin @@ -600,9 +606,9 @@ procedure TProxyServerModule.SSDPClientRead(Sender: TObject; begin if String(lData).Contains('ST: upnp:rootdevice') then begin - TLogger.LogFmt('Received M-SEARCH for rootdevice from %s on %s', [ABinding.PeerIP, ABinding.IP]); + TLogger.LogFmt(cLogDiscovery, 'Received M-SEARCH for rootdevice from %s on %s', [ABinding.PeerIP, ABinding.IP]); - if TryCreateSSDPAlivePacket(ABinding.IP, lPacket) then + if TryCreateSSDPResponsePacket(ABinding.IP, lPacket) then fDiscoveryServer.Send(ABinding.PeerIP, ABinding.PeerPort, lPacket); end; end @@ -610,7 +616,7 @@ procedure TProxyServerModule.SSDPClientRead(Sender: TObject; begin if String(lData).ToLower.Contains('cetoncorp') then begin - TLogger.LogFmt('Received NOTIFY from ceton device %s on %s: %s', [ABinding.PeerIP, ABinding.IP, String(lData)]); + TLogger.LogFmt(cLogDiscovery, 'Received NOTIFY from ceton device %s on %s: %s', [ABinding.PeerIP, ABinding.IP, String(lData)]); lValues := TStringList.Create; try @@ -672,7 +678,7 @@ function TProxyServerModule.TryCreateSSDPAlivePacket(const aRequestHost: String; Result := False; end; -procedure TProxyServerModule.Log(const aMessage: String); +procedure TProxyServerModule.Log(const aLogName: String; const aMessage: String); begin // Nothing end; @@ -711,7 +717,7 @@ procedure TProxyServerModule.SSDPServerRead(AThread: TIdUDPListenerThread; const SetLength(lData, Length(AData)); Move(AData[0], lData[Low(lData)], Length(AData)); - TLogger.LogFmt('Received SSDP discovery response from %s on %s: %s', [ABinding.PeerIP, ABinding.IP, String(lData)]); + TLogger.LogFmt(cLogDiscovery, 'Received SSDP discovery response from %s on %s: %s', [ABinding.PeerIP, ABinding.IP, String(lData)]); lValues := TStringList.Create; try @@ -736,4 +742,69 @@ procedure TProxyServerModule.DiscoveredCetonDevicesChanged; // Nothing end; +function DateTimeToRFC1123(aDate: TDateTime): string; +const + StrWeekDay: string = 'MonTueWedThuFriSatSun'; + StrMonth: string = 'JanFebMarAprMayJunJulAugSepOctNovDec'; +var + Year, Month, Day: Word; + Hour, Min, Sec, MSec: Word; + DayOfWeek: Word; +begin + DecodeDate(aDate, Year, Month, Day); + DecodeTime(aDate, Hour, Min, Sec, MSec); + DayOfWeek := ((Trunc(aDate) - 2) mod 7); + Result := Copy(StrWeekDay, 1 + DayOfWeek * 3, 3) + ', ' + + Format('%2.2d %s %4.4d %2.2d:%2.2d:%2.2d', + [Day, Copy(StrMonth, 1 + 3 * (Month - 1), 3), + Year, Hour, Min, Sec]); +end; + +{ +HTTP/1.1 200 OK +Server: HDHomeRun/1.0 UPnP/1.0 +ST: upnp:rootdevice +Location: http://192.168.1.43:80/dri/device.xml +Cache-Control: max-age=1800 +USN: uuid:473366D2-A765-3D61-B466-E73B254C632B::upnp:rootdevice +Ext: +Content-Length: 0 +Date: Wed, 11 Mar 2020 21:34:52 GMT +} + +function TProxyServerModule.TryCreateSSDPResponsePacket( + const aRequestHost: String; out aPacket: String): Boolean; +const + cSSDPResponse = + 'Server: HDHomeRun/1.0 UPnP/1.0'#13#10+ + 'ST: upnp:rootdevice'#13#10+ + 'Location: http://%s:%d/device.xml'#13#10+ + 'Cache-Control: max-age=%d'#13#10+ + 'USN: uuid:%s::upnp:rootdevice'#13#10+ + 'Ext:'#13#10+ + 'Content-Length: 0'#13#10+ + 'Date: %s'#13#10#13#10; +var + lAddress: String; + lPort: Integer; + lDeviceUUID: String; + lConfig: TServiceConfig; +begin + if TryGetAddress(ARequestHost, lAddress) then + begin + ConfigManager.LockConfig(lConfig); + try + lPort := lConfig.ExternalHTTPPort; + lDeviceUUID := lConfig.DeviceUUID; + finally + ConfigManager.UnlockConfig(lConfig); + end; + + aPacket := Format(cSSDPResponse, [lAddress, lPort, cSSDPAliveIntervalSec+30, lDeviceUUID, DateTimeToRFC1123(TTimeZone.Local.ToUniversalTime(Now))+' GMT']); + Result := True; + end + else + Result := False; +end; + end. diff --git a/ProxyServiceModuleUnit.pas b/ProxyServiceModuleUnit.pas index 5a8d718..052648f 100644 --- a/ProxyServiceModuleUnit.pas +++ b/ProxyServiceModuleUnit.pas @@ -14,6 +14,7 @@ interface System.Generics.Defaults, System.SyncObjs, System.Diagnostics, + System.StrUtils, FMX.Types, Winapi.ActiveX, @@ -81,7 +82,7 @@ TServiceConfig = class(TPersistent) ['{E51631F5-FC88-4FEC-BCF6-9A0F5616CE79}'] procedure Changed(const aSender: TObject; const aSections: TServiceConfigSections); procedure DiscoveredCetonDevicesChanged; - procedure Log(const aMessage: String); + procedure Log(const aLogName: String; const aMessage: String); end; IServiceConfigManager = interface @@ -89,7 +90,7 @@ TServiceConfig = class(TPersistent) procedure LockConfig(out aConfig: TServiceConfig); procedure UnlockConfig(var aConfig: TServiceConfig); - procedure Log(const aMessage: String); + procedure Log(const aLogName: String; const aMessage: String); procedure Changed(const aSender: TObject; const aSections: TServiceConfigSections); procedure DiscoveredCetonDevicesChanged; @@ -109,7 +110,7 @@ TServiceConfigManager = class(TInterfacedObject, IServiceConfigManager) procedure LockConfig(out aConfig: TServiceConfig); procedure UnlockConfig(var aConfig: TServiceConfig); - procedure Log(const aMessage: String); + procedure Log(const aLogName: String; const aMessage: String); procedure Changed(const aSender: TObject; const aSections: TServiceConfigSections); procedure DiscoveredCetonDevicesChanged; @@ -128,9 +129,9 @@ TServiceThread = class(TThread, IInterface, IServiceConfigEvents) fChangeEvent: TEvent; fConfigChanged: Boolean; fCetonDeviceDiscovered: Boolean; - fLogCache: TStringBuilder; + fLogCaches: TArray; - procedure SaveLog; + procedure SaveLogs; procedure QueryDiscoveredCetonDevices; protected @@ -141,7 +142,7 @@ TServiceThread = class(TThread, IInterface, IServiceConfigEvents) // IServiceConfigEvents procedure Changed(const aSender: TObject; const aSections: TServiceConfigSections); - procedure Log(const aMessage: String); + procedure Log(const aLogName: String; const aMessage: String); procedure DiscoveredCetonDevicesChanged; public constructor Create(const aServiceModule: TProxyServiceModule); @@ -165,16 +166,16 @@ TProxyServiceModule = class(TDataModule, IServiceConfigEvents, ILogger) procedure LoadConfig; procedure SaveConfig; - procedure MoveLog; + procedure MoveLog(const aFilename: String); protected // IServiceConfigEvents procedure Changed(const aSender: TObject; const aSections: TServiceConfigSections); - procedure Log(const aMessage: String); + procedure Log(const aLogName: String; const aMessage: String); procedure DiscoveredCetonDevicesChanged; // ILogger procedure ILogger.Log = HandleLoggerLog; - procedure HandleLoggerLog(const aMessage: String); + procedure HandleLoggerLog(const aLogName: String; const aMessage: String); public { Public declarations } property ConfigManager: IServiceConfigManager read fConfigManager; @@ -385,7 +386,7 @@ procedure TServiceConfigManager.UnlockConfig(var aConfig: TServiceConfig); Unlock; end; -procedure TServiceConfigManager.Log(const aMessage: String); +procedure TServiceConfigManager.Log(const aLogName: String; const aMessage: String); var i: Integer; begin @@ -393,7 +394,7 @@ procedure TServiceConfigManager.Log(const aMessage: String); try for i := 0 to fEventListeners.Count-1 do begin - fEventListeners[i].Log(aMessage); + fEventListeners[i].Log(aLogName, aMessage); end; finally Unlock; @@ -418,22 +419,27 @@ procedure TServiceConfigManager.DiscoveredCetonDevicesChanged; { TProxyServiceModule } procedure TProxyServiceModule.DataModuleCreate(Sender: TObject); +var + i: Integer; begin fDiscoveredCetonDeviceList := TDiscoveredCetonDeviceList.Create; fConfigManager := TServiceConfigManager.Create; - try - MoveLog; - except - // + for i := 0 to High(cLogNames) do + begin + try + MoveLog(GetConfigPath+'cetonproxy'+cLogNames[i]+'.log'); + except + // + end; end; fThread := TServiceThread.Create(Self); TLogger.SetLogger(Self); - TLogger.Log('Starting cetonproxy'); + TLogger.Log(cLogDefault, 'Starting cetonproxy'); fClient := TCetonClient.Create; @@ -456,7 +462,7 @@ procedure TProxyServiceModule.DataModuleDestroy(Sender: TObject); SaveConfig; - TLogger.Log('Closing cetonproxy'); + TLogger.Log(cLogDefault, 'Closing cetonproxy'); end; function TProxyServiceModule.GetConfigPath: String; @@ -561,32 +567,33 @@ procedure TProxyServiceModule.SaveConfig; end; except on e: Exception do - TLogger.LogFmt('Unable to save config: %s', [e.Message]); + TLogger.LogFmt(cLogDefault, 'Unable to save config: %s', [e.Message]); end; end; -procedure TProxyServiceModule.Log(const aMessage: String); +procedure TProxyServiceModule.Log(const aLogName: String; const aMessage: String); begin // Nothing end; -procedure TProxyServiceModule.HandleLoggerLog(const aMessage: String); +procedure TProxyServiceModule.HandleLoggerLog(const aLogName: String; const aMessage: String); begin // Pass to config manager to allow broadcasting it to multiple recipients - ConfigManager.Log(aMessage); + ConfigManager.Log(aLogName, aMessage); end; -procedure TProxyServiceModule.MoveLog; +procedure TProxyServiceModule.MoveLog(const aFilename: String); var - lPath: String; + lPath, lFilename: String; lBaseFilename, lNewFilename: String; i, lIndex: Integer; lFiles: TArray; begin - lPath := GetConfigPath; - if TFile.Exists(lPath+'cetonproxy.log') then + lPath := IncludeTrailingPathDelimiter(ExtractFilePath(aFilename)); + lFilename := ExtractFileName(aFilename); + if TFile.Exists(aFilename) then begin - lBaseFilename := lPath + 'cetonproxy' + FormatDateTime('yyyymmddhhhnnss', Now); + lBaseFilename := lPath + ChangeFileExt(lFilename, FormatDateTime('yyyymmddhhhnnss', Now)); lNewFilename := lBaseFilename + '.log'; lIndex := 1; while TFile.Exists(lNewFilename) do @@ -595,11 +602,11 @@ procedure TProxyServiceModule.MoveLog; Inc(lIndex); end; - TFile.Move(lPath+'cetonproxy.log', lNewFilename); + TFile.Move(aFilename, lNewFilename); end; // Check for a maximum number of log files - lFiles := TDirectory.GetFiles(lPath, 'cetonproxy*.log', TSearchOption.soTopDirectoryOnly); + lFiles := TDirectory.GetFiles(lPath, ChangeFileExt(lFilename,'*.log'), TSearchOption.soTopDirectoryOnly); if Length(lFiles) > cMaxLogFiles then begin TArray.Sort(lFiles, TComparer.Default); @@ -640,12 +647,16 @@ procedure TProxyServiceModule.DiscoveredCetonDevicesChanged; { TServiceThread } constructor TServiceThread.Create(const aServiceModule: TProxyServiceModule); +var + i: Integer; begin fServiceModule := aServiceModule; fChangeEvent := TEvent.Create(nil, False, False, ''); - fLogCache := TStringBuilder.Create; + SetLength(fLogCaches, Length(cLogNames)); + for i := 0 to High(cLogNames) do + fLogCaches[i] := TStringBuilder.Create; fServiceModule.ConfigManager.AddListener(Self); @@ -660,6 +671,8 @@ procedure TServiceThread.Changed(const aSender: TObject; end; destructor TServiceThread.Destroy; +var + i: Integer; begin Terminate; fChangeEvent.SetEvent; @@ -668,7 +681,8 @@ destructor TServiceThread.Destroy; fServiceModule.ConfigManager.RemoveListener(Self); fChangeEvent.Free; - fLogCache.Free; + for i := 0 to High(cLogNames) do + fLogCaches[i].Free; inherited; end; @@ -712,7 +726,7 @@ procedure TServiceThread.QueryDiscoveredCetonDevices; end; end else - TLogger.LogFmt('Unable to reach %s at discovered Ceton device with IP %s: Received status code %d (%s)', [lDevice.DescriptionXMLURL, lDevice.IP, lRequest.Response.StatusCode, lRequest.Response.StatusText]); + TLogger.LogFmt(cLogDiscovery, 'Unable to reach %s at discovered Ceton device with IP %s: Received status code %d (%s)', [lDevice.DescriptionXMLURL, lDevice.IP, lRequest.Response.StatusCode, lRequest.Response.StatusText]); finally lRequest.Free; end; @@ -721,7 +735,7 @@ procedure TServiceThread.QueryDiscoveredCetonDevices; end; except on e: Exception do - TLogger.LogFmt('Unable to reach %s at discovered Ceton device with IP %s: %s', [lDevice.DescriptionXMLURL, lDevice.IP, e.Message]); + TLogger.LogFmt(cLogDiscovery, 'Unable to reach %s at discovered Ceton device with IP %s: %s', [lDevice.DescriptionXMLURL, lDevice.IP, e.Message]); end; end; end; @@ -742,13 +756,13 @@ procedure TServiceThread.Execute; fServiceModule.SaveConfig; end; - SaveLog; + SaveLogs; try fServiceModule.Client.CheckTuner; except on e: Exception do - TLogger.Log(e.Message); + TLogger.Log(cLogDefault, e.Message); end; if fCetonDeviceDiscovered then @@ -785,51 +799,60 @@ function TServiceThread._Release: Integer; Result := -1; end; -procedure TServiceThread.Log(const aMessage: String); +procedure TServiceThread.Log(const aLogName: String; const aMessage: String); var lMsg: String; + lIndex: Integer; begin lMsg := Format('[%s] %s', [FormatDateTime('yyyy-mm-dd hh:nn:ss.zzz', Now), aMessage]); FMX.Types.Log.d('%s', [lMsg]); - TMonitor.Enter(fLogCache); - try - fLogCache.AppendLine(lMsg); - finally - TMonitor.Exit(fLogCache); + lIndex := IndexText(aLogName, cLogNames); + if lIndex > -1 then + begin + TMonitor.Enter(fLogCaches[lIndex]); + try + fLogCaches[lIndex].AppendLine(lMsg); + finally + TMonitor.Exit(fLogCaches[lIndex]); + end; end; end; -procedure TServiceThread.SaveLog; +procedure TServiceThread.SaveLogs; var lText: String; lPath: String; + i: Integer; begin - TMonitor.Enter(fLogCache); - try - if fLogCache.Length = 0 then - Exit; + for i := 0 to High(cLogNames) do + begin + TMonitor.Enter(fLogCaches[i]); + try + if fLogCaches[i].Length = 0 then + Continue; - lText := fLogCache.ToString; - fLogCache.Length := 0; - finally - TMonitor.Exit(fLogCache); - end; + lText := fLogCaches[i].ToString; + fLogCaches[i].Length := 0; + finally + TMonitor.Exit(fLogCaches[i]); + end; - lPath := fServiceModule.GetConfigPath+'cetonproxy.log'; + lPath := fServiceModule.GetConfigPath+'cetonproxy'+cLogNames[i]+'.log'; - try - TFile.AppendAllText(lPath, lText); - except - // Ignore - end; + try + TFile.AppendAllText(lPath, lText); + except + // Ignore + end; - try - if TFile.GetSize(lPath) >= cLogSizeRollover then - fServiceModule.MoveLog; - except - // Ignore + try + if TFile.GetSize(lPath) >= cLogSizeRollover then + fServiceModule.MoveLog(lPath); + except + // Ignore + end; end; end; diff --git a/ProxyWebModuleUnit.dfm b/ProxyWebModuleUnit.dfm index 74e7844..f0ef802 100644 --- a/ProxyWebModuleUnit.dfm +++ b/ProxyWebModuleUnit.dfm @@ -47,6 +47,11 @@ object ProxyWebModule: TProxyWebModule Name = 'SpeedTestAction' PathInfo = '/speedtest' OnAction = ProxyWebModuleSpeedTestActionAction + end + item + Name = 'VideoTestAction' + PathInfo = '/videotest/v*' + OnAction = ProxyWebModuleVideoTestActionAction end> Height = 333 Width = 414 diff --git a/ProxyWebModuleUnit.pas b/ProxyWebModuleUnit.pas index 1f0a555..0c718b3 100644 --- a/ProxyWebModuleUnit.pas +++ b/ProxyWebModuleUnit.pas @@ -26,11 +26,13 @@ interface SocketUtils; type + TChunkedStreamPacketCallback = reference to procedure(const aPacketSize: Integer; var aContinue: Boolean); + TIdHTTPAppChunkedResponse = class(TIdHTTPAppResponse) private public procedure SendChunkedHeader; - procedure SendChunkedStream(const aStream: TStream; const aLogSpeed: Boolean = False); + procedure SendChunkedStream(const aStream: TStream; const aPacketCallback: TChunkedStreamPacketCallback = nil); function Connected: Boolean; end; @@ -55,6 +57,8 @@ TProxyWebModule = class(TWebModule) Request: TWebRequest; Response: TWebResponse; var Handled: Boolean); procedure ProxyWebModuleSpeedTestActionAction(Sender: TObject; Request: TWebRequest; Response: TWebResponse; var Handled: Boolean); + procedure ProxyWebModuleVideoTestActionAction(Sender: TObject; + Request: TWebRequest; Response: TWebResponse; var Handled: Boolean); private { Private declarations } fConfigManager: IServiceConfigManager; @@ -65,7 +69,7 @@ TProxyWebModule = class(TWebModule) function GetAddress(const aRequest: TWebRequest): String; procedure GetLineup(const aLineup: TLineup); - procedure SendTuneResponse(const aTuner, aChannel: Integer; const Response: TWebResponse); + procedure SendTuneResponse(const aTuner, aChannel: Integer; const aTest: Boolean; const aDurationSec: Integer; const aRemux: Boolean; const Response: TWebResponse); function CreateDeviceXML: String; @@ -94,41 +98,29 @@ procedure TIdHTTPAppChunkedResponse.SendChunkedHeader; FSent := True; end; -procedure TIdHTTPAppChunkedResponse.SendChunkedStream(const aStream: TStream; const aLogSpeed: Boolean = False); +procedure TIdHTTPAppChunkedResponse.SendChunkedStream(const aStream: TStream; const aPacketCallback: TChunkedStreamPacketCallback = nil); var lBuffer: TBytes; lSize: Integer; - lDataMeter: TDataMeter; - lStopWatch: TStopWatch; + lContinue: Boolean; begin FThread.Binding.UseNagle := False; - if aLogSpeed then - begin - lDataMeter := Default(TDataMeter); - lStopWatch := TStopwatch.StartNew; - end; + lContinue := True; SetLength(lBuffer, 8192); repeat lSize := aStream.Read(lBuffer, Length(lBuffer)); if lSize > 0 then begin - if aLogSpeed then - lDataMeter.Add(lSize); - FThread.Connection.IOHandler.WriteLn(IntToHex(lSize, 1)); FThread.Connection.IOHandler.Write(TIdBytes(lBuffer), lSize); FThread.Connection.IOHandler.WriteLn; - end; - if aLogSpeed and (lStopWatch.ElapsedMilliseconds >= 1000) then - begin - TLogger.LogFmt('Send rate: %0.2fmbps', [lDataMeter.GetBytesPerSecond(False)*8/1000000]); - lStopWatch.Reset; - lStopWatch.Start; + if Assigned(aPacketCallback) then + aPacketCallback(lSize, lContinue); end; - until lSize = 0; + until (lSize = 0) or (not lContinue); FThread.Connection.IOHandler.WriteLn('0'); FThread.Connection.IOHandler.WriteLn; @@ -144,7 +136,7 @@ function TIdHTTPAppChunkedResponse.Connected: Boolean; procedure TProxyWebModule.WebModuleDefaultAction(Sender: TObject; Request: TWebRequest; Response: TWebResponse; var Handled: Boolean); begin - TLogger.LogFmt('Received unknown request from %s: %s', [Request.RemoteAddr, Request.PathInfo]); + TLogger.LogFmt(cLogDefault, 'Received unknown request from %s: %s', [Request.RemoteAddr, Request.PathInfo]); { if (Request.InternalPathInfo = '') or (Request.InternalPathInfo = '/')then Response.Content := ReverseString.Content @@ -184,7 +176,7 @@ procedure TProxyWebModule.ProxyWebModuleDiscoverActionAction(Sender: TObject; lResponse.Free; end; - TLogger.LogFmt('Received discover from %s, Response: %s', [Request.RemoteAddr, Response.Content]); + TLogger.LogFmt(cLogDiscovery, 'Received discover from %s, Response: %s', [Request.RemoteAddr, Response.Content]); except HandleException; end; @@ -197,7 +189,7 @@ procedure TProxyWebModule.ProxyWebModuleLineupJSONActionAction(Sender: TObject; begin Handled := True; try - TLogger.LogFmt('Received lineup.json request from %s', [Request.RemoteAddr]); + TLogger.LogFmt(cLogDefault, 'Received lineup.json request from %s', [Request.RemoteAddr]); try lLineup := TLineup.Create; try @@ -209,27 +201,59 @@ procedure TProxyWebModule.ProxyWebModuleLineupJSONActionAction(Sender: TObject; lLineup.Free; end; finally - TLogger.LogFmt('Finished lineup.json request from %s', [Request.RemoteAddr]); + TLogger.LogFmt(cLogDefault, 'Finished lineup.json request from %s', [Request.RemoteAddr]); end; except HandleException; end; end; -procedure TProxyWebModule.SendTuneResponse(const aTuner, aChannel: Integer; const Response: TWebResponse); +procedure TProxyWebModule.SendTuneResponse(const aTuner, aChannel: Integer; const aTest: Boolean; const aDurationSec: Integer; const aRemux: Boolean; const Response: TWebResponse); var lStream: TCetonVideoStream; + lStatsWatch, lDurationWatch: TStopWatch; + lStatsArray: TArray; begin // TODO: Grab content type from video stream Response.ContentType := 'video/mpeg'; TIdHTTPAppChunkedResponse(Response).SendChunkedHeader; repeat + lStatsWatch := TStopWatch.StartNew; + lDurationWatch := TStopWatch.StartNew; + // If Create here - lStream := TCetonVideoStream.Create(Client, aTuner, aChannel); + lStream := TCetonVideoStream.Create(Client, aTuner, aChannel, aRemux); try try - TIdHTTPAppChunkedResponse(Response).SendChunkedStream(lStream); + TIdHTTPAppChunkedResponse(Response).SendChunkedStream(lStream, + procedure(const aPacketSize: Integer; var aContinue: Boolean) + var + lTunerStats: PTunerStats; + lClientstats: PTunerClientStats; + begin + if (aTest) and (lStatsWatch.ElapsedMilliseconds >= 1000) then + begin + lStatsArray := Client.GetTunerStats; + lTunerStats := @lStatsArray[lStream.Viewer.TunerIndex]; + lClientStats := lTunerStats.Clients[lStream.Viewer.Reader.ReaderIndex]; + + if Assigned(lClientStats) then + TLogger.LogFmt(cLogDefault, 'Sending video to client %d: Tuner %d, Channel %d, Program %d, From tuner %d packets at %0.2fMbps, Buffer free %0.0f%%, To encoder %d packets at %0.2fMbps, To client %d bytes at %0.2fMbps, Lost packets %d', [ + lStream.Viewer.TunerIndex, lStream.Viewer.Reader.ReaderIndex, lTunerStats.Channel, lStream.ProgramFilter, lTunerStats.InPackets, lTunerStats.InMeter.GetBytesPerSecond(True)*8/1000000, lTunerStats.BufferFree*100, lClientStats.OutPackets, lClientStats.OutMeter.GetBytesPerSecond(True)*8/1000000, lStream.Stats.OutBytes, lStream.Stats.OutMeter.GetBytesPerSecond(True)*8/1000000, lClientStats.Lost]) + else + TLogger.LogFmt(cLogDefault, 'Sending video to client %d: Tuner %d, Channel %d, Program %d, From tuner %d packets at %0.2fMbps, Buffer free %0.0f%%, To client %d bytes at %0.2fMbps', [ + lStream.Viewer.TunerIndex, lStream.Viewer.Reader.ReaderIndex, lTunerStats.Channel, lStream.ProgramFilter, lTunerStats.InPackets, lTunerStats.InMeter.GetBytesPerSecond(True)*8/1000000, lTunerStats.BufferFree*100, lStream.Stats.OutBytes, lStream.Stats.OutMeter.GetBytesPerSecond(True)*8/1000000]); + + lStatsWatch.Reset; + lStatsWatch.Start; + end; + + if (aDurationSec > 0) and (lDurationWatch.ElapsedMilliseconds >= aDurationSec*1000) then + aContinue := False; + end); + + Exit; except on e: ECetonError do // Loop around to try to start stream again @@ -250,7 +274,7 @@ procedure TProxyWebModule.ProxyWebModuleAutoActionAction(Sender: TObject; begin Handled := True; try - TLogger.LogFmt('Received tune request from %s: %s', [Request.RemoteAddr, Request.PathInfo]); + TLogger.LogFmt(cLogDefault, 'Received tune request from %s: %s', [Request.RemoteAddr, Request.PathInfo]); try lParts := Request.PathInfo.Split(['/'], TStringSplitOptions.ExcludeEmpty); if (Length(lParts) >= 2) and (lParts[1].StartsWith('v',True)) then @@ -258,11 +282,11 @@ procedure TProxyWebModule.ProxyWebModuleAutoActionAction(Sender: TObject; lChannel := StrToIntDef(lParts[1].Substring(1),0); if lChannel > 0 then begin - SendTuneResponse(-1, lChannel, Response); + SendTuneResponse(-1, lChannel, False, 0, True, Response); end; end; finally - TLogger.LogFmt('Finished tune request from %s: %s', [Request.RemoteAddr, Request.PathInfo]); + TLogger.LogFmt(cLogDefault, 'Finished tune request from %s: %s', [Request.RemoteAddr, Request.PathInfo]); end; except HandleException; @@ -271,7 +295,7 @@ procedure TProxyWebModule.ProxyWebModuleAutoActionAction(Sender: TObject; procedure TProxyWebModule.HandleException; begin - TLogger.LogFmt('Service handler error: %s', [Exception(ExceptObject).Message]); + TLogger.LogFmt(cLogDefault, 'Service handler error: %s', [Exception(ExceptObject).Message]); // Send the response ourselves in an exception handler that eats all exceptions to // prevent the default handler from doing it and showing an error message box @@ -294,7 +318,7 @@ procedure TProxyWebModule.ProxyWebModuleLineupXMLActionAction(Sender: TObject; begin Handled := True; try - TLogger.LogFmt('Received lineup.xml request from %s', [Request.RemoteAddr]); + TLogger.LogFmt(cLogDefault, 'Received lineup.xml request from %s', [Request.RemoteAddr]); try lLineup := TLineup.Create; try @@ -306,7 +330,7 @@ procedure TProxyWebModule.ProxyWebModuleLineupXMLActionAction(Sender: TObject; lLineup.Free; end; finally - TLogger.LogFmt('Finished lineup.json request from %s', [Request.RemoteAddr]); + TLogger.LogFmt(cLogDefault, 'Finished lineup.json request from %s', [Request.RemoteAddr]); end; except HandleException; @@ -383,7 +407,7 @@ procedure TProxyWebModule.ProxyWebModuleTunerActionAction(Sender: TObject; begin Handled := True; try - TLogger.LogFmt('Received tune request from %s: %s', [Request.RemoteAddr, Request.PathInfo]); + TLogger.LogFmt(cLogDefault, 'Received tune request from %s: %s', [Request.RemoteAddr, Request.PathInfo]); try lParts := Request.PathInfo.Split(['/'], TStringSplitOptions.ExcludeEmpty); if (Length(lParts) >= 2) and (lParts[0].StartsWith('tuner',True)) and (lParts[1].StartsWith('v',True)) then @@ -392,11 +416,11 @@ procedure TProxyWebModule.ProxyWebModuleTunerActionAction(Sender: TObject; lChannel := StrToIntDef(lParts[1].Substring(1),0); if (lTuner > -1) and (lChannel > 0) then begin - SendTuneResponse(lTuner, lChannel, Response); + SendTuneResponse(lTuner, lChannel, False, 0, True, Response); end; end; finally - TLogger.LogFmt('Finished tune request from %s: %s', [Request.RemoteAddr, Request.PathInfo]); + TLogger.LogFmt(cLogDefault, 'Finished tune request from %s: %s', [Request.RemoteAddr, Request.PathInfo]); end; except HandleException; @@ -415,12 +439,12 @@ procedure TProxyWebModule.ProxyWebModuleLineupStatusActionAction( begin Handled := True; try - TLogger.LogFmt('Received lineup status request from %s: %s', [Request.RemoteAddr, Request.PathInfo]); + TLogger.LogFmt(cLogDefault, 'Received lineup status request from %s: %s', [Request.RemoteAddr, Request.PathInfo]); try Response.ContentType := 'application/json'; Response.Content := '{"ScanInProgress":0,"ScanPossible":1,"Source":"Cable","SourceList":["Cable"]}'; finally - TLogger.LogFmt('Finished lineup status request from %s: %s', [Request.RemoteAddr, Request.PathInfo]); + TLogger.LogFmt(cLogDefault, 'Finished lineup status request from %s: %s', [Request.RemoteAddr, Request.PathInfo]); end; except HandleException; @@ -432,12 +456,12 @@ procedure TProxyWebModule.ProxyWebModuleDeviceXMLActionAction(Sender: TObject; begin Handled := True; try - TLogger.LogFmt('Received device.xml request from %s: %s', [Request.RemoteAddr, Request.PathInfo]); + TLogger.LogFmt(cLogDefault, 'Received device.xml request from %s: %s', [Request.RemoteAddr, Request.PathInfo]); try Response.ContentType := 'application/xml'; Response.Content := CreateDeviceXML; finally - TLogger.LogFmt('Finished device.xml request from %s: %s', [Request.RemoteAddr, Request.PathInfo]); + TLogger.LogFmt(cLogDefault, 'Finished device.xml request from %s: %s', [Request.RemoteAddr, Request.PathInfo]); end; except HandleException; @@ -829,22 +853,38 @@ procedure TProxyWebModule.ProxyWebModuleSpeedTestActionAction(Sender: TObject; Request: TWebRequest; Response: TWebResponse; var Handled: Boolean); var lStream: TRandomStream; + lStopWatch: TStopWatch; + lMeter: TDataMeter; begin Handled := True; try - TLogger.LogFmt('Received speedtest request from %s: %s', [Request.RemoteAddr, Request.PathInfo]); + TLogger.LogFmt(cLogDefault, 'Received speedtest request from %s: %s', [Request.RemoteAddr, Request.PathInfo]); try Response.ContentType := 'video/mpeg'; TIdHTTPAppChunkedResponse(Response).SendChunkedHeader; + lStopWatch := TStopWatch.StartNew; + lMeter := Default(TDataMeter); + lStream := TRandomStream.Create; try - TIdHTTPAppChunkedResponse(Response).SendChunkedStream(lStream, True); + TIdHTTPAppChunkedResponse(Response).SendChunkedStream(lStream, + procedure(const aPacketSize: Integer; var aContinue: Boolean) + begin + lMeter.Add(aPacketSize); + + if (lStopWatch.ElapsedMilliseconds >= 1000) then + begin + TLogger.LogFmt(cLogDefault, 'Send rate: %0.2fmbps', [lMeter.GetBytesPerSecond(False)*8/1000000]); + lStopWatch.Reset; + lStopWatch.Start; + end; + end); finally lStream.Free; end; finally - TLogger.LogFmt('Finished speedtest request from %s: %s', [Request.RemoteAddr, Request.PathInfo]); + TLogger.LogFmt(cLogDefault, 'Finished speedtest request from %s: %s', [Request.RemoteAddr, Request.PathInfo]); end; except HandleException; @@ -871,6 +911,38 @@ function TProxyWebModule.GetAddress(const aRequest: TWebRequest): String; Result := aRequest.Host; end; +procedure TProxyWebModule.ProxyWebModuleVideoTestActionAction(Sender: TObject; + Request: TWebRequest; Response: TWebResponse; var Handled: Boolean); +var + lParts: TArray; + lChannel, lDuration, lTunerIndex: Integer; + lRemux: Boolean; +begin + Handled := True; + try + TLogger.LogFmt(cLogDefault, 'Received test video request from %s: %s', [Request.RemoteAddr, Request.PathInfo]); + try + lParts := Request.PathInfo.Split(['/'], TStringSplitOptions.ExcludeEmpty); + if (Length(lParts) >= 2) and (lParts[1].StartsWith('v',True)) then + begin + lChannel := StrToIntDef(lParts[1].Substring(1),0); + if lChannel > 0 then + begin + lTunerIndex := StrToIntDef(Request.QueryFields.Values['tuner'], -1); + lDuration := StrToIntDef(Request.QueryFields.Values['duration'], 45); + lRemux := Boolean(StrToIntDef(Request.QueryFields.Values['remux'], 0)); + + SendTuneResponse(lTunerIndex, lChannel, True, lDuration, lRemux, Response); + end; + end; + finally + TLogger.LogFmt(cLogDefault, 'Finished test video request from %s: %s', [Request.RemoteAddr, Request.PathInfo]); + end; + except + HandleException; + end; +end; + initialization finalization Web.WebReq.FreeWebModules; diff --git a/SocketUtils.pas b/SocketUtils.pas index 77ce987..42cd038 100644 --- a/SocketUtils.pas +++ b/SocketUtils.pas @@ -13,6 +13,7 @@ interface System.Diagnostics, System.Timespan, System.Generics.Collections, + System.IOUtils, IdUDPServer, IdGlobal, @@ -132,7 +133,9 @@ TRTPVideoSink = class(TInterfacedObject, IRTPVideoSink) procedure Lock; procedure Unlock; - procedure UDPRead(AThread: TIdUDPListenerThread; const AData: TIdBytes; ABinding: TIdSocketHandle); + procedure ReceivePacket(const aData: PByte; const aSize: Integer); + + procedure UDPRead(AThread: TIdUDPListenerThread; const AData: TIdBytes; ABinding: TIdSocketHandle); virtual; protected // IRTPVideoSink function GetPort: Integer; @@ -149,6 +152,16 @@ TRTPVideoSink = class(TInterfacedObject, IRTPVideoSink) destructor Destroy; override; end; + TDebugRTPVideoSink = class(TRTPVideoSink) + private + fFileStream: TFileStream; + protected + procedure UDPRead(AThread: TIdUDPListenerThread; const AData: TIdBytes; ABinding: TIdSocketHandle); override; + public + constructor Create(const aFilename: String; const aPacketSize, aPacketCount: Integer; const aStats: IVideoStats); reintroduce; + destructor Destroy; override; + end; + TDataMeterWindow = type String; TDataMeter = record @@ -428,44 +441,21 @@ function TRTPVideoSink.GetPort: Integer; Result := 0; end; -procedure TRTPVideoSink.UDPRead(AThread: TIdUDPListenerThread; - const AData: TIdBytes; ABinding: TIdSocketHandle); +procedure TRTPVideoSink.ReceivePacket(const aData: PByte; const aSize: Integer); var - lPacket: PVideoPacket; - lWritten, lToWrite: Integer; - lHeader: PRTPHeader; i: Integer; + lPacket: PVideoPacket; lOpenPacketCount: Integer; begin - if Length(AData) < 12 then - Exit; - - lHeader := @AData[0]; - Lock; try - if fLastHeader.Version > 0 then - begin - if lHeader.SequenceNumber <> fLastHeader.SequenceNumber+1 then - if Assigned(fStats) then - fStats.PacketOutOfOrder(lHeader.SequenceNumber - fLastHeader.SequenceNumber); - if lHeader.PayloadType <> fLastHeader.PayloadType then - if Assigned(fStats) then - fStats.PayloadTypeChange(lHeader.PayloadType); - end; - fLastHeader := lHeader^; - - lWritten := 12; // Skip RTP header - lToWrite := Length(AData)-lWritten; - - lPacket := @fPackets[fWritePacketIndex]; - if Length(lPacket.Data) < lToWrite then - SetLength(lPacket.Data, lToWrite); + if Length(lPacket.Data) < aSize then + SetLength(lPacket.Data, aSize); - Move(AData[lWritten], lPacket.Data[0], lToWrite); - lPacket.Size := lToWrite; + Move(AData^, lPacket.Data[0], aSize); + lPacket.Size := aSize; if Assigned(fStats) then fStats.PacketReceived(fWritePacketIndex, lPacket^); @@ -506,6 +496,36 @@ procedure TRTPVideoSink.UDPRead(AThread: TIdUDPListenerThread; end; end; +procedure TRTPVideoSink.UDPRead(AThread: TIdUDPListenerThread; + const AData: TIdBytes; ABinding: TIdSocketHandle); +var + lHeader: PRTPHeader; +begin + if Length(AData) < 12 then + Exit; + + lHeader := @AData[0]; + + Lock; + try + if fLastHeader.Version > 0 then + begin + if lHeader.SequenceNumber <> fLastHeader.SequenceNumber+1 then + if Assigned(fStats) then + fStats.PacketOutOfOrder(lHeader.SequenceNumber - fLastHeader.SequenceNumber); + if lHeader.PayloadType <> fLastHeader.PayloadType then + if Assigned(fStats) then + fStats.PayloadTypeChange(lHeader.PayloadType); + end; + fLastHeader := lHeader^; + finally + Unlock; + end; + + // Skip RTP header + ReceivePacket(@AData[12], Length(Adata)-12); +end; + procedure TRTPVideoSink.Lock; begin TMonitor.Enter(Self); @@ -900,4 +920,32 @@ function TLocalIPInfoArrayHelper.Keep( SetLength(Result, lCount); end; +{ TDebugRTPVideoSink } + +procedure TDebugRTPVideoSink.UDPRead(AThread: TIdUDPListenerThread; + const AData: TIdBytes; ABinding: TIdSocketHandle); +var + lBuffer: array[0..2048] of Byte; + lSize: Integer; +begin + // Read from file instead + lSize := fFileStream.Read(lBuffer, Length(AData)); + if lSize > 0 then + ReceivePacket(@lBuffer[0], lSize); +end; + +constructor TDebugRTPVideoSink.Create(const aFilename: String; const aPacketSize, aPacketCount: Integer; const aStats: IVideoStats); +begin + fFileStream := TFile.OpenRead(aFilename); + + inherited Create(aPacketSize, aPacketCount, aStats); +end; + +destructor TDebugRTPVideoSink.Destroy; +begin + fFileStream.Free; + + inherited; +end; + end. diff --git a/VideoUtils.pas b/VideoUtils.pas index 8ba54b7..1f4ba8f 100644 --- a/VideoUtils.pas +++ b/VideoUtils.pas @@ -278,13 +278,16 @@ function TVideoConverter.Next: Boolean; fPacket.pos := -1; // log_packet(ofmt_ctx, @pkt, 'out'); - // lRet := av_interleaved_write_frame(fOutputFormatContext, @fPacket); +// lRet := av_interleaved_write_frame(fOutputFormatContext, @fPacket); lRet := av_write_frame(fOutputFormatContext, @fPacket); if lRet < 0 then ErrorFmt('Error muxing packet: %s', [GetErrorStr(lRet)]); end else + begin LogFmt('Dropped packet with non-increasing timestamp on %s stream %d', [AnsiString(av_get_media_type_string(lInStream.codecpar.codec_type)), fPacket.stream_index]); + Continue; + end; finally av_packet_unref(@fPacket); end; @@ -311,7 +314,7 @@ procedure TVideoConverter.LogFmt(const aMsg: String; const aArgs: array of const); begin if Assigned(fOnLog) then - fOnLog(Format(aMsg, aArgs)); + fOnLog(Format(Trim(aMsg), aArgs)); end; initialization diff --git a/ceton/Ceton.pas b/ceton/Ceton.pas index 3e0e7d4..3d88106 100644 --- a/ceton/Ceton.pas +++ b/ceton/Ceton.pas @@ -2,6 +2,8 @@ interface +{.$DEFINE DEBUGSINK} + {$SCOPEDENUMS ON} uses @@ -34,6 +36,12 @@ interface SocketUtils, VideoUtils; +{$IFDEF DEBUGSINK} +const + cDebugSinkFilename = 'C:\dev\cetonproxy\remuxtest\SampleCh76P4673.ts'; + cDebugSinkProgramNumber = 467; +{$ENDIF} + const cRTPPacketSize = 2048; cRTPPacketCount = Round(20 {20mbit stream} * 1000000/8 {to bytes} / 1500 {avg packet size} * 10 {number of seconds}); @@ -226,9 +234,11 @@ TREST = class abstract TTunerClientStats = record Active: Boolean; Lost: Integer; + OutPackets: Int64; OutMeter: TDataMeter; end; + PTunerStats = ^TTunerStats; TTunerStats = record private fClients: TArray; @@ -237,7 +247,7 @@ TTunerStats = record public Channel: Integer; Active: Boolean; - PacketsReceived: Integer; + InPackets: Int64; InMeter: TDataMeter; BufferFree: Single; @@ -363,14 +373,21 @@ TCetonClient = class property Model: TCetonModel read GetModel; end; + TCetonViewerStats = record + OutBytes: Int64; + OutMeter: TDataMeter; + end; + TCetonVideoStream = class(TStream) private fWriteBuffer, fReadBuffer: TRingBuffer; fClient: TCetonClient; fViewer: TCetonViewer; + fStats: TCetonViewerStats; fConverter: TVideoConverter; fConverterError: Exception; fConverterErrorAddress: Pointer; + fProgramFilter: Integer; function ConverterRead(const aBuf: PByte; const aSize: Integer): Integer; function ConverterWrite(const aBuf: PByte; const aSize: Integer): Integer; @@ -381,6 +398,11 @@ TCetonVideoStream = class(TStream) function Read(var Buffer; Count: Longint): Longint; override; function Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; override; + + property ProgramFilter: Integer read fProgramFilter; + property Viewer: TCetonViewer read fViewer; + + property Stats: TCetonViewerStats read fStats; end; TDiscoveredCetonDevice = record @@ -694,7 +716,7 @@ class procedure TREST.StartStream(const aClient: TRestClient; var lRequest: TStartStopStreamRequest; begin - TLogger.LogFmt('Starting stream on tuner %d to %s:%d', [aTunerID, aIP, aPort]); + TLogger.LogFmt(cLogDefault, 'Starting stream on tuner %d to %s:%d', [aTunerID, aIP, aPort]); lRequest := TStartStopStreamRequest.Create(nil); try @@ -716,7 +738,7 @@ class procedure TREST.StopStream(const aClient: TRestClient; var lRequest: TStartStopStreamRequest; begin - TLogger.LogFmt('Stopping stream on tuner %d', [aTunerID]); + TLogger.LogFmt(cLogDefault, 'Stopping stream on tuner %d', [aTunerID]); lRequest := TStartStopStreamRequest.Create(nil); try @@ -738,7 +760,7 @@ class procedure TREST.TuneChannel(const aClient: TRestClient; const aTunerID, var lRequest: TTuneChannelRequest; begin - TLogger.LogFmt('Setting channel on tuner %d to %d', [aTunerID, aChannel]); + TLogger.LogFmt(cLogDefault, 'Setting channel on tuner %d to %d', [aTunerID, aChannel]); lRequest := TTuneChannelRequest.Create(nil); try @@ -783,7 +805,7 @@ class function TREST.GetVar(const aClient: TRestClient; const aTunerID: Integer; lValue: String; lStart,lEnd: Integer; begin - TLogger.LogFmt('Getting %s\%s for tuner %d', [aServiceName, aVarName, aTunerID]); + TLogger.LogFmt(cLogDefault, 'Getting %s\%s for tuner %d', [aServiceName, aVarName, aTunerID]); lRequest := TVarRequest.Create(nil); try @@ -808,7 +830,7 @@ class function TREST.GetVar(const aClient: TRestClient; const aTunerID: Integer; if (lStart > -1) and (lEnd > -1) then lValue := lValue.Substring(lStart+Length(cValueStart), lEnd-lStart-Length(cValueStart)); - TLogger.LogFmt('Received %s\%s for tuner %d: "%s"', [aServiceName, aVarName, aTunerID, lValue]); + TLogger.LogFmt(cLogDefault, 'Received %s\%s for tuner %d: "%s"', [aServiceName, aVarName, aTunerID, lValue]); Result := lValue; end; @@ -856,7 +878,7 @@ class function TREST.GetTunerCount(const aClient: TRestClient): Integer; //var // lRequest: TRESTRequest; begin - TLogger.Log('Checking tuner count'); + TLogger.Log(cLogDefault, 'Checking tuner count'); // A 4 tuner PCI card still seems to respond to information requests for tuners 5 // and 6. But one difference I saw is that DescramblingStatus is (null) on @@ -884,14 +906,14 @@ class function TREST.GetTunerCount(const aClient: TRestClient): Integer; lRequest.Free; end;} - TLogger.LogFmt('Determined tuner count: %d', [Result]); + TLogger.LogFmt(cLogDefault, 'Determined tuner count: %d', [Result]); end; class function TREST.GetModel(const aClient: TRestClient): TCetonModel; var lConnectionType: String; begin - TLogger.Log('Identifying tuner model'); + TLogger.Log(cLogDefault, 'Identifying tuner model'); lConnectionType := TREST.GetVar(aClient, 0, 'diag', 'Host_Connection').ToLower; @@ -902,7 +924,7 @@ class function TREST.GetModel(const aClient: TRestClient): TCetonModel; else Result := TCetonModel.Ethernet; - TLogger.LogFmt('Determined tuner model: %s', [GetEnumName(TypeInfo(TCetonModel), Integer(Result))]); + TLogger.LogFmt(cLogDefault, 'Determined tuner model: %s', [GetEnumName(TypeInfo(TCetonModel), Integer(Result))]); end; { TTunerList } @@ -1071,12 +1093,15 @@ procedure TCetonClient.StartStream(const aTuner: Integer; const aChannel: Intege if lCount >= 3 then begin - TLogger.LogFmt('No video data on tuner %d for channel %d', [aViewer.TunerIndex, aChannel]); + TLogger.LogFmt(cLogDefault, 'No video data on tuner %d for channel %d', [aViewer.TunerIndex, aChannel]); raise ECetonError.Create('No video data'); end; until lReceivedPacket or (lCount >= 3); + // Get copy protection status for informational purposes + TRest.GetVar(fClient, aViewer.TunerIndex, 'diag', 'CopyProtectionStatus'); + lTuner.Channel := aChannel; lTuner.Active := True; lTuner.RefCount := lTuner.RefCount + 1; @@ -1322,7 +1347,7 @@ procedure TCetonClient.CheckTuner; try fDetectedListenIP := lTCPClient.Socket.Binding.IP; - TLogger.LogFmt('Detected tuner listen IP: %s', [fDetectedListenIP]); + TLogger.LogFmt(cLogDefault, 'Detected tuner listen IP: %s', [fDetectedListenIP]); finally Unlock; end; @@ -1331,7 +1356,7 @@ procedure TCetonClient.CheckTuner; end; except on e: Exception do - TLogger.LogFmt('Unable to detect tuner listen IP: %s', [e.Message]); + TLogger.LogFmt(cLogDefault, 'Unable to detect tuner listen IP: %s', [e.Message]); end; except raise ECetonError.CreateFmt('Unable to reach tuner at %s', [lTunerAddress]); @@ -1447,7 +1472,13 @@ destructor TTuner.Destroy; function TTuner.GetSink: IRTPVideoSink; begin if not Assigned(fSink) then + begin +{$IFDEF DEBUGSINK} + fSink := TDebugRTPVideoSink.Create(cDebugSinkFilename, cRTPPacketSize, cRTPPacketCount, Self); +{$ELSE} fSink := TRTPVideoSink.Create(cRTPPacketSize, cRTPPacketCount, Self); +{$ENDIF} + end; Result := fSink; end; @@ -1466,15 +1497,19 @@ procedure TTuner.RemoveSink; procedure TTuner.PacketReceived(const aPacketIndex: Integer; const aPacket: TVideoPacket); begin - Inc(fInternalStats.PacketsReceived); + Inc(fInternalStats.InPackets); fInternalStats.InMeter.Add(aPacket.Size); StatsUpdated; end; procedure TTuner.PacketRead(const aReaderIndex, aPacketIndex: Integer; const aPacket: TVideoPacket); +var + lClient: PTunerClientStats; begin - fInternalStats.CreateClient(aReaderIndex).OutMeter.Add(aPacket.Size); + lClient := fInternalStats.CreateClient(aReaderIndex); + Inc(lClient.OutPackets); + lClient.OutMeter.Add(aPacket.Size); StatsUpdated; end; @@ -1507,7 +1542,7 @@ function TTuner.ContainsSink(const aSink: IRTPVideoSink): Boolean; procedure TTuner.ReaderSlow(const aReaderIndex, aPacketIndex: Integer; const aPacket: TVideoPacket); begin - TLogger.LogFmt('Client %d cannot keep up on tuner %d (From tuner: %0.2fMbps, To client: %0.2fMbps)', [aReaderIndex, Index, fInternalStats.InMeter.GetBytesPerSecond(True)*8/1000000, fInternalStats.Clients[aReaderIndex].OutMeter.GetBytesPerSecond(True)*8/1000000]); + TLogger.LogFmt(cLogDefault, 'Client %d cannot keep up on tuner %d (From tuner: %0.2fMbps, To client: %0.2fMbps)', [aReaderIndex, Index, fInternalStats.InMeter.GetBytesPerSecond(True)*8/1000000, fInternalStats.Clients[aReaderIndex].OutMeter.GetBytesPerSecond(True)*8/1000000]); Inc(fInternalStats.CreateClient(aReaderIndex).Lost); StatsUpdated(True); end; @@ -1524,12 +1559,12 @@ procedure TTuner.BufferAvailability(const aOpenPacketCount, procedure TTuner.PacketOutOfOrder(const aDelta: Integer); begin - TLogger.LogFmt('Packet out of order on tuner %d: %d', [Index, aDelta]); + TLogger.LogFmt(cLogDefault, 'Packet out of order on tuner %d: %d', [Index, aDelta]); end; procedure TTuner.PayloadTypeChange(const aPayloadType: UInt8); begin - TLogger.LogFmt('Packet payload type changed on tuner %d: %d', [Index, aPayloadType]); + TLogger.LogFmt(cLogDefault, 'Packet payload type changed on tuner %d: %d', [Index, aPayloadType]); end; function TTuner.GetStats: TTunerStats; @@ -1616,6 +1651,8 @@ constructor TCetonVideoStream.Create(const aClient: TCetonClient; fClient.StartStream(aTuner, aChannel, fViewer); + fProgramFilter := -1; + if aRemux then begin lChannel := TChannelMapItem.Create; @@ -1626,7 +1663,13 @@ constructor TCetonVideoStream.Create(const aClient: TCetonClient; fConverter.OnRead := ConverterRead; fConverter.OnWrite := ConverterWrite; fConverter.OnLog := ConverterLog; +{$IFDEF DEBUGSINK} + fConverter.ProgramFilter := cDebugSinkProgramNumber; +{$ELSE} fConverter.ProgramFilter := lChannel.ItemProgram; +{$ENDIF} + + fProgramFilter := fConverter.ProgramFilter; end; finally lChannel.Free; @@ -1653,6 +1696,9 @@ function TCetonVideoStream.Read(var Buffer; Count: Longint): Longint; end; Result := fWriteBuffer.Read(Buffer, Count); + + Inc(fStats.OutBytes, Result); + fStats.OutMeter.Add(Result); end; destructor TCetonVideoStream.Destroy; @@ -1678,7 +1724,7 @@ function TCetonVideoStream.Seek(const Offset: Int64; Origin: TSeekOrigin): Int64 procedure TCetonVideoStream.ConverterLog(const aMsg: String); begin - TLogger.LogFmt('Client %d tuner %d video converter: %s', [fViewer.Reader.ReaderIndex, fViewer.TunerIndex, aMsg]); + TLogger.LogFmt(cLogDefault, 'Client %d tuner %d video converter: %s', [fViewer.Reader.ReaderIndex, fViewer.TunerIndex, aMsg]); end; { TChannelMapItem }