diff --git a/EmailUtils.pas b/EmailUtils.pas new file mode 100644 index 0000000..1a17e90 --- /dev/null +++ b/EmailUtils.pas @@ -0,0 +1,177 @@ +unit EmailUtils; + +interface + +uses + System.Classes, + System.SysUtils, + + IdSMTP, + IdEmailAddress, + IdMessage, + IdMessageBuilder, + IdSSLOpenSSL, + IdSSLOpenSSLHeaders, + IdExplicitTLSClientServerBase; + +{$SCOPEDENUMS ON} + +const + cEmailDefaultPort = 25; + +type + TEmailTLSOption = ( + None, + NoTLSSupport, + UseImplicitTLS, + UseRequireTLS, + UseExplicitTLS + ); + TEmailSSLVersion = ( + None, + SSLv2, + SSLv23, + SSLv3, + TLSv1, + TLSv1_1, + TLSv1_2 + ); + + TEmailServerSettings = class(TPersistent) + private + fServerPort: Integer; + fServerAddress: String; + fSSLVersion: TEmailSSLVersion; + fPassword: String; + fUsername: String; + fTLSOption: TEmailTLSOption; + public + constructor Create; + + procedure Assign(Source: TPersistent); override; + procedure AssignTo(Dest: TPersistent); override; + published + property ServerAddress: String read fServerAddress write fServerAddress; + property ServerPort: Integer read fServerPort write fServerPort; + property TLSOption: TEmailTLSOption read fTLSOption write fTLSOption; + property SSLVersion: TEmailSSLVersion read fSSLVersion write fSSLVersion; + property Username: String read fUsername write fUsername; + property Password: String read fPassword write fPassword; + end; + + TEmail = class(TPersistent) + private + fBody: String; + fSubject: String; + fRecipients: String; + fSender: String; + public + property Sender: String read fSender write fSender; + property Recipients: String read fRecipients write fRecipients; + property Subject: String read fSubject write fSubject; + property Body: String read fBody write fBody; + end; + + TEmailUtils = class abstract + public + class procedure Send(const aSettings: TEmailServerSettings; const aEmail: TEmail); static; + end; + +implementation + +{ TEmailServerSettings } + +procedure TEmailServerSettings.AssignTo(Dest: TPersistent); +begin + if Dest is TEmailServerSettings then + begin + TEmailServerSettings(Dest).fServerAddress := fServerAddress; + TEmailServerSettings(Dest).fServerPort := fServerPort; + TEmailServerSettings(Dest).fTLSOption := fTLSOption; + TEmailServerSettings(Dest).fSSLVersion := fSSLVersion; + TEmailServerSettings(Dest).fUsername := fUsername; + TEmailServerSettings(Dest).fPassword := fPassword; + end + else + inherited; +end; + +procedure TEmailServerSettings.Assign(Source: TPersistent); +begin + if not Assigned(Source) then + begin + fServerPort := cEmailDefaultPort; + end + else + inherited; +end; + + +constructor TEmailServerSettings.Create; +begin + Assign(nil); +end; + +{ TEmailUtils } + +class procedure TEmailUtils.Send(const aSettings: TEmailServerSettings; + const aEmail: TEmail); +var + lSMTP: TIdSMTP; + lMessage: TIdMessage; +begin + lSMTP := TIdSMTP.Create(nil); + try + lSMTP.IOHandler := TIdSSLIOHandlerSocketOpenSSL.Create; + case aSettings.TLSOption of + TEmailTLSOption.NoTLSSupport: lSMTP.UseTLS := utNoTLSSupport; + TEmailTLSOption.UseImplicitTLS: lSMTP.UseTLS := utUseImplicitTLS; + TEmailTLSOption.UseRequireTLS: lSMTP.UseTLS := utUseRequireTLS; + TEmailTLSOption.UseExplicitTLS: lSMTP.UseTLS := utUseExplicitTLS; + end; + case aSettings.SSLVersion of + TEmailSSLVersion.SSLv2: TIdSSLIOHandlerSocketOpenSSL(lSMTP.IOHandler).SSLOptions.Method := sslvSSLv2; + TEmailSSLVersion.SSLv23: TIdSSLIOHandlerSocketOpenSSL(lSMTP.IOHandler).SSLOptions.Method := sslvSSLv23; + TEmailSSLVersion.SSLv3: TIdSSLIOHandlerSocketOpenSSL(lSMTP.IOHandler).SSLOptions.Method := sslvSSLv3; + TEmailSSLVersion.TLSv1: TIdSSLIOHandlerSocketOpenSSL(lSMTP.IOHandler).SSLOptions.Method := sslvTLSv1; + TEmailSSLVersion.TLSv1_1: TIdSSLIOHandlerSocketOpenSSL(lSMTP.IOHandler).SSLOptions.Method := sslvTLSv1_1; + TEmailSSLVersion.TLSv1_2: TIdSSLIOHandlerSocketOpenSSL(lSMTP.IOHandler).SSLOptions.Method := sslvTLSv1_2; + end; + + lSMTP.Host := aSettings.ServerAddress; + lSMTP.Port := aSettings.ServerPort; + + if aSettings.Username <> '' then + begin + lSMTP.AuthType := satDefault; + lSMTP.Username := aSettings.Username; + lSMTP.Password := aSettings.Password; + end + else + lSMTP.AuthType := satNone; + + lMessage := TIdMessage.Create(nil); + try + lMessage.From.Text := aEmail.Sender; + lMessage.ReplyTo.EMailAddresses := aEmail.Sender; + + lMessage.Recipients.EMailAddresses := aEmail.Recipients; + + lMessage.Subject := aEmail.Subject; + + lMessage.Body.Text := aEmail.Body; + + lMessage.Date := Now; + + lSMTP.Connect; + lSMTP.Send(lMessage); + finally + lMessage.Free; + end; + finally + lSMTP.Free; + end; + +end; + +end. diff --git a/LogUtils.pas b/LogUtils.pas index e077944..955110e 100644 --- a/LogUtils.pas +++ b/LogUtils.pas @@ -14,6 +14,7 @@ interface ILogger = interface ['{772B05D3-D06A-4E0D-A259-929772F8704D}'] procedure Log(const aLogName: String; const aMessage: String); + procedure LogError(const aLogName: String; const aMessage: String); end; TLogger = class abstract @@ -24,6 +25,9 @@ TLogger = class abstract 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 LogError(const aLogName: String; const aMessage: String); static; + class procedure LogErrorFmt(const aLogName: String; const aMessage: String; const aArgs: array of const); static; + class procedure SetLogger(const aLogger: ILogger); static; end; @@ -47,4 +51,16 @@ class procedure TLogger.LogFmt(const aLogName: String; const aMessage: String; c Log(aLogName, Format(aMessage, aArgs)); end; +class procedure TLogger.LogError(const aLogName, aMessage: String); +begin + if Assigned(fLogger) then + fLogger.LogError(aLogName, aMessage); +end; + +class procedure TLogger.LogErrorFmt(const aLogName, aMessage: String; + const aArgs: array of const); +begin + LogError(aLogName, Format(aMessage, aArgs)); +end; + end. diff --git a/ProxyFormUnit.fmx b/ProxyFormUnit.fmx index fdf7bbe..73a5e83 100644 --- a/ProxyFormUnit.fmx +++ b/ProxyFormUnit.fmx @@ -2,7 +2,7 @@ object MainForm: TMainForm Left = 0 Top = 0 Caption = 'Ceton HDHomeRun Proxy' - ClientHeight = 483 + ClientHeight = 537 ClientWidth = 400 Fill.Kind = Solid Position = ScreenCenter @@ -18,15 +18,15 @@ object MainForm: TMainForm object VertScrollBox1: TVertScrollBox Align = Client Size.Width = 400.000000000000000000 - Size.Height = 483.000000000000000000 + Size.Height = 537.000000000000000000 Size.PlatformDefault = False TabOrder = 3 Viewport.Width = 400.000000000000000000 - Viewport.Height = 483.000000000000000000 + Viewport.Height = 537.000000000000000000 object OuterPanelContainer: TLayout Align = Top Size.Width = 400.000000000000000000 - Size.Height = 481.000000000000000000 + Size.Height = 529.000000000000000000 Size.PlatformDefault = False TabOrder = 0 object PanelContainer: TLayout @@ -49,7 +49,7 @@ object MainForm: TMainForm Size.Height = 20.000000000000000000 Size.PlatformDefault = False Text = 'Advanced Settings' - TabOrder = 0 + TabOrder = 1 OnMouseDown = PanelMouseDown OnResized = PanelResizing ContentSize = '156' @@ -204,7 +204,7 @@ object MainForm: TMainForm Size.Height = 59.000000000000000000 Size.PlatformDefault = False Text = 'Settings' - TabOrder = 2 + TabOrder = 3 OnMouseDown = PanelMouseDown OnResized = PanelResizing ContentSize = '39' @@ -236,13 +236,13 @@ object MainForm: TMainForm Margins.Left = 3.000000000000000000 Margins.Right = 3.000000000000000000 Position.X = 3.000000000000000000 - Position.Y = 120.000000000000000000 + Position.Y = 146.000000000000000000 ShowCheck = False Size.Width = 394.000000000000000000 Size.Height = 354.000000000000000000 Size.PlatformDefault = False Text = 'Tuners' - TabOrder = 3 + TabOrder = 4 OnMouseDown = PanelMouseDown OnResized = PanelResizing ContentSize = '334' @@ -295,20 +295,20 @@ object MainForm: TMainForm Margins.Top = 3.000000000000000000 Margins.Right = 3.000000000000000000 Position.X = 3.000000000000000000 - Position.Y = 94.000000000000000000 + Position.Y = 120.000000000000000000 ShowCheck = False Size.Width = 394.000000000000000000 Size.Height = 20.000000000000000000 Size.PlatformDefault = False Text = 'Channels' - TabOrder = 1 + TabOrder = 2 OnMouseDown = PanelMouseDown OnResized = PanelResizing ContentSize = '200' object Layout1: TLayout Align = Bottom Position.Y = 166.000000000000000000 - Size.Width = 394.000000000000000000 + Size.Width = 200.000000000000000000 Size.Height = 34.000000000000000000 Size.PlatformDefault = False TabOrder = 0 @@ -324,7 +324,7 @@ object MainForm: TMainForm end object btnRefreshChannels: TButton Anchors = [akTop, akRight] - Position.X = 263.000000000000000000 + Position.X = 69.000000000000000000 Position.Y = 4.000000000000000000 Size.Width = 121.000000000000000000 Size.Height = 22.000000000000000000 @@ -348,7 +348,7 @@ object MainForm: TMainForm Margins.Left = 10.000000000000000000 Margins.Top = 9.000000000000000000 Margins.Right = 10.000000000000000000 - Size.Width = 374.000000000000000000 + Size.Width = 180.000000000000000000 Size.Height = 157.000000000000000000 Size.PlatformDefault = False TabOrder = 1 @@ -358,7 +358,7 @@ object MainForm: TMainForm DefaultItemStyles.GroupFooterStyle = '' ShowCheckboxes = True OnChangeCheck = lbChannelsChangeCheck - Viewport.Width = 370.000000000000000000 + Viewport.Width = 176.000000000000000000 Viewport.Height = 153.000000000000000000 end end @@ -366,7 +366,7 @@ object MainForm: TMainForm Align = Top Cursor = crVSplit MinSize = 20.000000000000000000 - Position.Y = 114.000000000000000000 + Position.Y = 140.000000000000000000 ShowGrip = False Size.Width = 400.000000000000000000 Size.Height = 6.000000000000000000 @@ -376,12 +376,245 @@ object MainForm: TMainForm Align = Top Cursor = crVSplit MinSize = 20.000000000000000000 - Position.Y = 474.000000000000000000 + Position.Y = 500.000000000000000000 ShowGrip = False Size.Width = 400.000000000000000000 Size.Height = 6.000000000000000000 Size.PlatformDefault = False end + object pnlEmailSettings: TExpander + Align = Top + IsExpanded = False + Margins.Left = 3.000000000000000000 + Margins.Top = 3.000000000000000000 + Margins.Right = 3.000000000000000000 + Margins.Bottom = 3.000000000000000000 + Position.X = 3.000000000000000000 + Position.Y = 94.000000000000000000 + ShowCheck = False + Size.Width = 394.000000000000000000 + Size.Height = 20.000000000000000000 + Size.PlatformDefault = False + Text = 'Email Settings' + TabOrder = 0 + OnMouseDown = PanelMouseDown + OnResized = PanelResizing + ContentSize = '291' + object Label11: TLabel + Position.X = 15.000000000000000000 + Position.Y = 12.000000000000000000 + Size.Width = 196.000000000000000000 + Size.Height = 17.000000000000000000 + Size.PlatformDefault = False + Text = 'Server address (SMTP):' + ParentShowHint = False + ShowHint = True + TabOrder = 5 + end + object eEmailServerAddress: TEdit + Touch.InteractiveGestures = [LongTap, DoubleTap] + TabOrder = 8 + Position.X = 210.000000000000000000 + Position.Y = 9.000000000000000000 + Size.Width = 150.000000000000000000 + Size.Height = 22.000000000000000000 + Size.PlatformDefault = False + OnChangeTracking = eEmailServerAddressChangeTracking + end + object eEmailServerPort: TEdit + Touch.InteractiveGestures = [LongTap, DoubleTap] + TabOrder = 7 + Position.X = 210.000000000000000000 + Position.Y = 36.000000000000000000 + Size.Width = 150.000000000000000000 + Size.Height = 22.000000000000000000 + Size.PlatformDefault = False + OnChangeTracking = eEmailServerPortChangeTracking + end + object Label5: TLabel + Position.X = 15.000000000000000000 + Position.Y = 39.000000000000000000 + Size.Width = 196.000000000000000000 + Size.Height = 17.000000000000000000 + Size.PlatformDefault = False + Text = 'Server port:' + ParentShowHint = False + ShowHint = True + TabOrder = 2 + end + object Label8: TLabel + Position.X = 15.000000000000000000 + Position.Y = 66.000000000000000000 + Size.Width = 196.000000000000000000 + Size.Height = 17.000000000000000000 + Size.PlatformDefault = False + Text = 'Security:' + ParentShowHint = False + ShowHint = True + TabOrder = 0 + end + object cbEmailServerSecurity: TComboBox + Items.Strings = ( + 'Plain' + 'TLS' + 'SSL') + Position.X = 210.000000000000000000 + Position.Y = 63.000000000000000000 + Size.Width = 150.000000000000000000 + Size.Height = 22.000000000000000000 + Size.PlatformDefault = False + TabOrder = 9 + OnChange = cbEmailServerSecurityChange + end + object Label9: TLabel + Position.X = 15.000000000000000000 + Position.Y = 93.000000000000000000 + Size.Width = 196.000000000000000000 + Size.Height = 17.000000000000000000 + Size.PlatformDefault = False + Text = 'Username:' + ParentShowHint = False + ShowHint = True + TabOrder = 3 + end + object eEmailServerUsername: TEdit + Touch.InteractiveGestures = [LongTap, DoubleTap] + TabOrder = 6 + Position.X = 210.000000000000000000 + Position.Y = 90.000000000000000000 + Size.Width = 150.000000000000000000 + Size.Height = 22.000000000000000000 + Size.PlatformDefault = False + OnChangeTracking = eEmailServerUsernameChangeTracking + end + object eEmailServerPassword: TEdit + Touch.InteractiveGestures = [LongTap, DoubleTap] + TabOrder = 4 + Position.X = 210.000000000000000000 + Position.Y = 117.000000000000000000 + Size.Width = 150.000000000000000000 + Size.Height = 22.000000000000000000 + Size.PlatformDefault = False + OnChangeTracking = eEmailServerPasswordChangeTracking + end + object Label10: TLabel + Position.X = 15.000000000000000000 + Position.Y = 120.000000000000000000 + Size.Width = 196.000000000000000000 + Size.Height = 17.000000000000000000 + Size.PlatformDefault = False + Text = 'Password:' + ParentShowHint = False + ShowHint = True + TabOrder = 1 + end + object GroupBox1: TGroupBox + Align = Top + Margins.Left = 10.000000000000000000 + Margins.Top = 142.000000000000000000 + Margins.Right = 10.000000000000000000 + Position.X = 10.000000000000000000 + Position.Y = 142.000000000000000000 + Size.Width = 374.000000000000000000 + Size.Height = 141.000000000000000000 + Size.PlatformDefault = False + Text = 'Error Notifications' + TabOrder = 10 + object sbErrorEmailFrequency: TSpinBox + Touch.InteractiveGestures = [LongTap, DoubleTap] + TabOrder = 0 + Cursor = crIBeam + Max = 1000000.000000000000000000 + Value = 30.000000000000000000 + Position.X = 144.000000000000000000 + Position.Y = 24.000000000000000000 + OnChangeTracking = sbErrorEmailFrequencyChangeTracking + end + object Label12: TLabel + Position.X = 15.000000000000000000 + Position.Y = 27.000000000000000000 + Size.Width = 122.000000000000000000 + Size.Height = 17.000000000000000000 + Size.PlatformDefault = False + Text = 'Frequency:' + ParentShowHint = False + ShowHint = True + TabOrder = 7 + end + object Label13: TLabel + Position.X = 15.000000000000000000 + Position.Y = 54.000000000000000000 + Size.Width = 114.000000000000000000 + Size.Height = 17.000000000000000000 + Size.PlatformDefault = False + Text = 'Sender:' + ParentShowHint = False + ShowHint = True + TabOrder = 6 + end + object eErrorEmailSender: TEdit + Touch.InteractiveGestures = [LongTap, DoubleTap] + TabOrder = 10 + Position.X = 144.000000000000000000 + Position.Y = 51.000000000000000000 + Size.Width = 206.000000000000000000 + Size.Height = 22.000000000000000000 + Size.PlatformDefault = False + OnChangeTracking = eErrorEmailSenderChangeTracking + end + object Label14: TLabel + Position.X = 15.000000000000000000 + Position.Y = 81.000000000000000000 + Size.Width = 122.000000000000000000 + Size.Height = 17.000000000000000000 + Size.PlatformDefault = False + Text = 'Recipients:' + ParentShowHint = False + ShowHint = True + TabOrder = 5 + end + object eErrorEmailRecipients: TEdit + Touch.InteractiveGestures = [LongTap, DoubleTap] + TabOrder = 9 + Position.X = 144.000000000000000000 + Position.Y = 78.000000000000000000 + Size.Width = 206.000000000000000000 + Size.Height = 22.000000000000000000 + Size.PlatformDefault = False + OnChangeTracking = eErrorEmailRecipientsChangeTracking + end + object eErrorEmailSubject: TEdit + Touch.InteractiveGestures = [LongTap, DoubleTap] + TabOrder = 8 + Position.X = 144.000000000000000000 + Position.Y = 105.000000000000000000 + Size.Width = 206.000000000000000000 + Size.Height = 22.000000000000000000 + Size.PlatformDefault = False + OnChangeTracking = eErrorEmailSubjectChangeTracking + end + object Label15: TLabel + Position.X = 15.000000000000000000 + Position.Y = 108.000000000000000000 + Size.Width = 122.000000000000000000 + Size.Height = 17.000000000000000000 + Size.PlatformDefault = False + Text = 'Subject:' + ParentShowHint = False + ShowHint = True + TabOrder = 4 + end + object Label16: TLabel + Position.X = 248.000000000000000000 + Position.Y = 27.000000000000000000 + Size.Width = 57.000000000000000000 + Size.Height = 17.000000000000000000 + Size.PlatformDefault = False + Text = 'seconds' + TabOrder = 11 + end + end + end end end end @@ -1708,13 +1941,13 @@ object MainForm: TMainForm 0000C804401453697A652E506C6174666F726D44656661756C74080B5374796C 654C6F6F6B7570060B767468756D627374796C65000000} end> - Left = 24 - Top = 320 + Left = 48 + Top = 32 end object SaveTimer: TTimer OnTimer = SaveTimerTimer - Left = 72 - Top = 320 + Left = 88 + Top = 32 end object HelpCallout: TCalloutRectangle Fill.Color = xFFE5E5E5 diff --git a/ProxyFormUnit.pas b/ProxyFormUnit.pas index 41e0536..e6c21c5 100644 --- a/ProxyFormUnit.pas +++ b/ProxyFormUnit.pas @@ -33,6 +33,7 @@ interface FMX.SpinBox, FMX.Menus, FMX.Platform, + FMX.Objects, REST.json, REST.Client, @@ -41,9 +42,10 @@ interface HDHR, Ceton, SocketUtils, + EmailUtils, ProxyServiceModuleUnit, - ProxyServerModuleUnit, FMX.Objects; + ProxyServerModuleUnit; type TChannelListBoxItem = class(TListBoxItem) @@ -92,6 +94,27 @@ TMainForm = class(TForm, IServiceConfigEvents) lblHelp: TLabel; eCetonTunerAddress: TComboEdit; lbTuners: TListBox; + pnlEmailSettings: TExpander; + Label11: TLabel; + eEmailServerAddress: TEdit; + eEmailServerPort: TEdit; + Label5: TLabel; + Label8: TLabel; + cbEmailServerSecurity: TComboBox; + Label9: TLabel; + eEmailServerUsername: TEdit; + eEmailServerPassword: TEdit; + Label10: TLabel; + GroupBox1: TGroupBox; + sbErrorEmailFrequency: TSpinBox; + Label12: TLabel; + Label13: TLabel; + eErrorEmailSender: TEdit; + Label14: TLabel; + eErrorEmailRecipients: TEdit; + eErrorEmailSubject: TEdit; + Label15: TLabel; + Label16: TLabel; procedure FormCreate(Sender: TObject); procedure FormDestroy(Sender: TObject); procedure lbChannelsChangeCheck(Sender: TObject); @@ -114,6 +137,15 @@ TMainForm = class(TForm, IServiceConfigEvents) procedure FormMouseWheel(Sender: TObject; Shift: TShiftState; WheelDelta: Integer; var Handled: Boolean); procedure lbTunersChangeCheck(Sender: TObject); + procedure eEmailServerAddressChangeTracking(Sender: TObject); + procedure eEmailServerPortChangeTracking(Sender: TObject); + procedure cbEmailServerSecurityChange(Sender: TObject); + procedure eEmailServerUsernameChangeTracking(Sender: TObject); + procedure eEmailServerPasswordChangeTracking(Sender: TObject); + procedure sbErrorEmailFrequencyChangeTracking(Sender: TObject); + procedure eErrorEmailSenderChangeTracking(Sender: TObject); + procedure eErrorEmailRecipientsChangeTracking(Sender: TObject); + procedure eErrorEmailSubjectChangeTracking(Sender: TObject); private { Private declarations } fConfigManager: IServiceConfigManager; @@ -147,6 +179,7 @@ TMainForm = class(TForm, IServiceConfigEvents) // IServiceConfigEvents procedure Changed(const aSender: TObject; const aSections: TServiceConfigSections); procedure Log(const aLogName: String; const aMessage: String); + procedure LogError(const aLogName: String; const aMessage: String); procedure DiscoveredCetonDevicesChanged; public { Public declarations } @@ -349,6 +382,26 @@ procedure TMainForm.UpdateInterface; eHDHRListenHTTPPort.Text := IntToStr(lConfig.HTTPPort); eHDHRExternalAddress.Text := lConfig.ExternalAddress; eHDHRExternalHTTPPort.Text := IntToStr(lConfig.ExternalHTTPPort); + + eEmailServerAddress.Text := lConfig.EmailServer.ServerAddress; + eEmailServerPort.Text := IntToStr(lConfig.EmailServer.ServerPort); + case lConfig.EmailServer.TLSOption of + TEmailTLSOption.None, TEmailTLSOption.NoTLSSupport: cbEmailServerSecurity.ItemIndex := 0; + TEmailTLSOption.UseImplicitTLS, TEmailTLSOption.UseRequireTLS, TEmailTLSOption.UseExplicitTLS: begin + case lConfig.EmailServer.SSLVersion of + TEmailSSLVersion.None: cbEmailServerSecurity.ItemIndex := 0; + TEmailSSLVersion.SSLv2, TEmailSSLVersion.SSLv23, TEmailSSLVersion.SSLv3: cbEmailServerSecurity.ItemIndex := 2; + TEmailSSLVersion.TLSv1, TEmailSSLVersion.TLSv1_1, TEmailSSLVersion.TLSv1_2: cbEmailServerSecurity.ItemIndex := 1; + end; + end; + end; + eEmailServerUsername.Text := lConfig.EmailServer.Username; + eEmailServerPassword.Text := lConfig.EmailServer.Password; + + sbErrorEmailFrequency.Value := lConfig.ErrorEmail.FrequencySec; + eErrorEmailSender.Text := lConfig.ErrorEmail.Sender; + eErrorEmailRecipients.Text := lConfig.ErrorEmail.Recipients; + eErrorEmailSubject.Text := lConfig.ErrorEmail.Subject; finally ConfigManager.UnlockConfig(lConfig); end; @@ -569,7 +622,7 @@ procedure TMainForm.eHDHRListenHTTPPortChangeTracking(Sender: TObject); ConfigManager.UnlockConfig(lConfig); end; - Save([TServiceConfigSection.Other]); + Save([TServiceConfigSection.Server]); end; end; @@ -604,7 +657,7 @@ procedure TMainForm.ceHDHRListenIPChangeTracking(Sender: TObject); ConfigManager.UnlockConfig(lConfig); end; - Save([TServiceConfigSection.Other]); + Save([TServiceConfigSection.Server]); end; end; @@ -812,9 +865,176 @@ procedure TMainForm.lbTunersChangeCheck(Sender: TObject); ConfigManager.UnlockConfig(lConfig); end; - // TODO: Use another config section so that servers aren't restarted Save([TServiceConfigSection.Other]); end; end; +procedure TMainForm.eEmailServerAddressChangeTracking(Sender: TObject); +var + lConfig: TServiceConfig; +begin + if not InterfaceUpdating then + begin + ConfigManager.LockConfig(lConfig); + try + lConfig.EmailServer.ServerAddress := eEmailServerAddress.Text; + finally + ConfigManager.UnlockConfig(lConfig); + end; + + Save([TServiceConfigSection.Other]); + end; +end; + +procedure TMainForm.eEmailServerPortChangeTracking(Sender: TObject); +var + lConfig: TServiceConfig; +begin + if not InterfaceUpdating then + begin + ConfigManager.LockConfig(lConfig); + try + lConfig.EmailServer.ServerPort := StrToIntDef(eEmailServerPort.Text, cEmailDefaultPort); + finally + ConfigManager.UnlockConfig(lConfig); + end; + + Save([TServiceConfigSection.Other]); + end; +end; + +procedure TMainForm.cbEmailServerSecurityChange(Sender: TObject); +var + lConfig: TServiceConfig; +begin + if not InterfaceUpdating then + begin + ConfigManager.LockConfig(lConfig); + try + case cbEmailServerSecurity.ItemIndex of + -1,0: lConfig.EmailServer.TLSOption := TEmailTLSOption.None; + 1: begin + lConfig.EmailServer.TLSOption := TEmailTLSOption.UseRequireTLS; + lConfig.EmailServer.SSLVersion := TEmailSSLVersion.TLSv1_2; + end; + 2: begin + lConfig.EmailServer.TLSOption := TEmailTLSOption.UseRequireTLS; + lConfig.EmailServer.SSLVersion := TEmailSSLVersion.SSLv3; + end; + end; + finally + ConfigManager.UnlockConfig(lConfig); + end; + + Save([TServiceConfigSection.Other]); + end; +end; + +procedure TMainForm.eEmailServerUsernameChangeTracking(Sender: TObject); +var + lConfig: TServiceConfig; +begin + if not InterfaceUpdating then + begin + ConfigManager.LockConfig(lConfig); + try + lConfig.EmailServer.Username := eEmailServerUsername.Text; + finally + ConfigManager.UnlockConfig(lConfig); + end; + + Save([TServiceConfigSection.Other]); + end; +end; + +procedure TMainForm.eEmailServerPasswordChangeTracking(Sender: TObject); +var + lConfig: TServiceConfig; +begin + if not InterfaceUpdating then + begin + ConfigManager.LockConfig(lConfig); + try + lConfig.EmailServer.Password := eEmailServerPassword.Text; + finally + ConfigManager.UnlockConfig(lConfig); + end; + + Save([TServiceConfigSection.Other]); + end; +end; + +procedure TMainForm.sbErrorEmailFrequencyChangeTracking(Sender: TObject); +var + lConfig: TServiceConfig; +begin + if not InterfaceUpdating then + begin + ConfigManager.LockConfig(lConfig); + try + lConfig.ErrorEmail.FrequencySec := Round(sbErrorEmailFrequency.Value); + finally + ConfigManager.UnlockConfig(lConfig); + end; + + Save([TServiceConfigSection.Other]); + end; +end; + +procedure TMainForm.eErrorEmailSenderChangeTracking(Sender: TObject); +var + lConfig: TServiceConfig; +begin + if not InterfaceUpdating then + begin + ConfigManager.LockConfig(lConfig); + try + lConfig.ErrorEmail.Sender := eErrorEmailSender.Text; + finally + ConfigManager.UnlockConfig(lConfig); + end; + + Save([TServiceConfigSection.Other]); + end; +end; + +procedure TMainForm.eErrorEmailRecipientsChangeTracking(Sender: TObject); +var + lConfig: TServiceConfig; +begin + if not InterfaceUpdating then + begin + ConfigManager.LockConfig(lConfig); + try + lConfig.ErrorEmail.Recipients := eErrorEmailRecipients.Text; + finally + ConfigManager.UnlockConfig(lConfig); + end; + + Save([TServiceConfigSection.Other]); + end; +end; + +procedure TMainForm.eErrorEmailSubjectChangeTracking(Sender: TObject); +var + lConfig: TServiceConfig; +begin + if not InterfaceUpdating then + begin + ConfigManager.LockConfig(lConfig); + try + lConfig.ErrorEmail.Subject := eErrorEmailSubject.Text; + finally + ConfigManager.UnlockConfig(lConfig); + end; + + Save([TServiceConfigSection.Other]); + end; +end; + +procedure TMainForm.LogError(const aLogName, aMessage: String); +begin + // TODO +end; + end. diff --git a/ProxyServerModuleUnit.pas b/ProxyServerModuleUnit.pas index 5a05a3a..f69f419 100644 --- a/ProxyServerModuleUnit.pas +++ b/ProxyServerModuleUnit.pas @@ -91,6 +91,7 @@ TProxyServerModule = class(TDataModule, IServiceConfigEvents) // IServiceConfigEvents procedure Changed(const aSender: TObject; const aSections: TServiceConfigSections); procedure Log(const aLogName: String; const aMessage: String); + procedure LogError(const aLogName: String; const aMessage: String); procedure DiscoveredCetonDevicesChanged; public { Public declarations } @@ -422,7 +423,7 @@ procedure TProxyServerModule.Changed(const aSender: TObject; TThread.ForceQueue(nil, procedure() begin - if TServiceConfigSection.Other in aSections then + if TServiceConfigSection.Server in aSections then begin RestartServersTimer.Enabled := True; end; @@ -443,6 +444,11 @@ function TProxyServerModule.TryGetAddress(const aRequestLocalIP: String; out aAd lAddresses: TLocalIPInfoArray; lModel: TCetonModel; begin + // The goal here is to return an IP address that the remote end will be able to reach + // us on as an HDHomeRun. The easiest thing to do is take whatever IP the remote already + // used to reach us as the IP address it should continue to use, but of course it's not + // that easy. + ConfigManager.LockConfig(lConfig); try aAddress := lConfig.ExternalAddress; @@ -468,7 +474,7 @@ function TProxyServerModule.TryGetAddress(const aRequestLocalIP: String; out aAd // BaseURLs. // We can detect if the request is coming from the same computer as this - // app by checking if the PeerIP is found in the local address list. + // app by checking if the ARequestLocalIP is found in the local address list. lAddresses := TSocketUtils.GetLocalIPs; @@ -477,13 +483,14 @@ function TProxyServerModule.TryGetAddress(const aRequestLocalIP: String; out aAd if ProxyServiceModule.Client.EnabledTunerCount = 0 then Exit(False); + // If it's a USB/PCI device, exclude the local ip that was created by + // the Ceton device + // TODO: This is not a good assumption to make if it's a USB/PCI device + // and set to bridged mode. If there is only one local IP address, + // don't remove it. lModel := ProxyServiceModule.Client.Model; - if lModel <> TCetonModel.Ethernet then - begin - // If it's a USB/PCI device, exclude the local ip that was created by - // the Ceton device + if (lModel <> TCetonModel.Ethernet) and (Length(lAddresses) > 1) then lAddresses := lAddresses.Remove(ProxyServiceModule.Client.ListenIP); - end; // Choose a local IP that we should respond to aAddress := lAddresses.LowestMetric(4).IP; @@ -807,4 +814,9 @@ function TProxyServerModule.TryCreateSSDPResponsePacket( Result := False; end; +procedure TProxyServerModule.LogError(const aLogName, aMessage: String); +begin + // Nothing +end; + end. diff --git a/ProxyServiceModuleUnit.pas b/ProxyServiceModuleUnit.pas index d2a1c4d..97d9ee2 100644 --- a/ProxyServiceModuleUnit.pas +++ b/ProxyServiceModuleUnit.pas @@ -33,7 +33,8 @@ interface HDHR, Ceton, LogUtils, - FileUtils; + FileUtils, + EmailUtils; const cServiceConfigVersion = 2; @@ -41,10 +42,29 @@ interface cLogSizeRollover = 2000000; cMaxLogFiles = 5; + cErrorEmailFrequencySec = 60; + type - TServiceConfigSection = (Channels, Other); + TServiceConfigSection = (Channels, Server, Other); TServiceConfigSections = set of TServiceConfigSection; + TErrorEmailSettings = class(TPersistent) + private + fFrequencySec: Integer; + fSubject: String; + fRecipients: String; + fSender: String; + public + constructor Create; + procedure AssignTo(Dest: TPersistent); override; + procedure Assign(Source: TPersistent); override; + published + property FrequencySec: Integer read fFrequencySec write fFrequencySec; + property Sender: String read fSender write fSender; + property Recipients: String read fRecipients write fRecipients; + property Subject: String read fSubject write fSubject; + end; + TServiceConfig = class(TPersistent) private fDeviceID: UInt32; @@ -55,6 +75,8 @@ TServiceConfig = class(TPersistent) fExternalAddress: String; fExternalHTTPPort: Integer; fVersion: Integer; + fEmailServer: TEmailServerSettings; + fErrorEmail: TErrorEmailSettings; procedure CreateDeviceID; procedure CreateDeviceUUID; @@ -67,6 +89,9 @@ TServiceConfig = class(TPersistent) function ToJSON: String; class function FromJSON(const aJSON: String): TServiceConfig; static; + property EmailServer: TEmailServerSettings read fEmailServer; + property ErrorEmail: TErrorEmailSettings read fErrorEmail; + property Ceton: TCetonConfig read fCeton; property Version: Integer read fVersion write fVersion; @@ -83,6 +108,7 @@ TServiceConfig = class(TPersistent) procedure Changed(const aSender: TObject; const aSections: TServiceConfigSections); procedure DiscoveredCetonDevicesChanged; procedure Log(const aLogName: String; const aMessage: String); + procedure LogError(const aLogName: String; const aMessage: String); end; IServiceConfigManager = interface @@ -91,6 +117,7 @@ TServiceConfig = class(TPersistent) procedure UnlockConfig(var aConfig: TServiceConfig); procedure Log(const aLogName: String; const aMessage: String); + procedure LogError(const aLogName: String; const aMessage: String); procedure Changed(const aSender: TObject; const aSections: TServiceConfigSections); procedure DiscoveredCetonDevicesChanged; @@ -111,6 +138,7 @@ TServiceConfigManager = class(TInterfacedObject, IServiceConfigManager) procedure UnlockConfig(var aConfig: TServiceConfig); procedure Log(const aLogName: String; const aMessage: String); + procedure LogError(const aLogName: String; const aMessage: String); procedure Changed(const aSender: TObject; const aSections: TServiceConfigSections); procedure DiscoveredCetonDevicesChanged; @@ -130,8 +158,15 @@ TServiceThread = class(TThread, IInterface, IServiceConfigEvents) fConfigChanged: Boolean; fCetonDeviceDiscovered: Boolean; fLogCaches: TArray; + fErrorEmailCache: TStringBuilder; + fEmailServerSettings: TEmailServerSettings; + fErrorEmailSettings: TErrorEmailSettings; + fErrorEmailStartDateTime: TDateTime; + + procedure GetEmailSettings; procedure SaveLogs; + procedure SendErrorEmail; procedure QueryDiscoveredCetonDevices; protected @@ -143,6 +178,7 @@ TServiceThread = class(TThread, IInterface, IServiceConfigEvents) // IServiceConfigEvents procedure Changed(const aSender: TObject; const aSections: TServiceConfigSections); procedure Log(const aLogName: String; const aMessage: String); + procedure LogError(const aLogName: String; const aMessage: String); procedure DiscoveredCetonDevicesChanged; public constructor Create(const aServiceModule: TProxyServiceModule); @@ -171,11 +207,14 @@ TProxyServiceModule = class(TDataModule, IServiceConfigEvents, ILogger) // IServiceConfigEvents procedure Changed(const aSender: TObject; const aSections: TServiceConfigSections); procedure Log(const aLogName: String; const aMessage: String); + procedure LogError(const aLogName: String; const aMessage: String); procedure DiscoveredCetonDevicesChanged; // ILogger procedure ILogger.Log = HandleLoggerLog; + procedure ILogger.LogError = HandleLoggerLogError; procedure HandleLoggerLog(const aLogName: String; const aMessage: String); + procedure HandleLoggerLogError(const aLogName: String; const aMessage: String); public { Public declarations } property ConfigManager: IServiceConfigManager read fConfigManager; @@ -301,6 +340,8 @@ class function TServiceConfig.FromJSON(const aJSON: String): TServiceConfig; constructor TServiceConfig.Create; begin fCeton := TCetonConfig.Create; + fEmailServer := TEmailServerSettings.Create; + fErrorEmail := TErrorEmailSettings.Create; fHTTPPort := HDHR_HTTP_PORT; fExternalHTTPPort := fHTTPPort; @@ -313,6 +354,8 @@ constructor TServiceConfig.Create; destructor TServiceConfig.Destroy; begin + fErrorEmail.Free; + fEmailServer.Free; fCeton.Free; inherited; @@ -327,6 +370,8 @@ procedure TServiceConfig.AssignTo(Dest: TPersistent); lDest := TServiceConfig(Dest); lDest.fVersion := fVersion; + lDest.fEmailServer.Assign(fEmailServer); + lDest.fErrorEmail.Assign(fErrorEmail); lDest.fCeton.Assign(fCeton); lDest.fDeviceID := fDeviceID; lDest.fDeviceUUID := fDeviceUUID; @@ -441,6 +486,21 @@ procedure TServiceConfigManager.DiscoveredCetonDevicesChanged; end; end; +procedure TServiceConfigManager.LogError(const aLogName, aMessage: String); +var + i: Integer; +begin + Lock; + try + for i := 0 to fEventListeners.Count-1 do + begin + fEventListeners[i].LogError(aLogName, aMessage); + end; + finally + Unlock; + end; +end; + { TProxyServiceModule } procedure TProxyServiceModule.DataModuleCreate(Sender: TObject); @@ -669,6 +729,18 @@ procedure TProxyServiceModule.DiscoveredCetonDevicesChanged; // Nothing end; +procedure TProxyServiceModule.LogError(const aLogName, aMessage: String); +begin + // Nothing +end; + +procedure TProxyServiceModule.HandleLoggerLogError(const aLogName, + aMessage: String); +begin + // Pass to config manager to allow broadcasting it to multiple recipients + ConfigManager.LogError(aLogName, aMessage); +end; + { TServiceThread } constructor TServiceThread.Create(const aServiceModule: TProxyServiceModule); @@ -683,6 +755,12 @@ constructor TServiceThread.Create(const aServiceModule: TProxyServiceModule); for i := 0 to High(cLogNames) do fLogCaches[i] := TStringBuilder.Create; + fEmailServerSettings := TEmailServerSettings.Create; + fErrorEmailSettings := TErrorEmailSettings.Create; + fErrorEmailCache := TStringBuilder.Create; + + GetEmailSettings; + fServiceModule.ConfigManager.AddListener(Self); inherited Create(True); @@ -709,6 +787,10 @@ destructor TServiceThread.Destroy; for i := 0 to High(cLogNames) do fLogCaches[i].Free; + fErrorEmailCache.Free; + fErrorEmailSettings.Free; + fEmailServerSettings.Free; + inherited; end; @@ -781,6 +863,8 @@ procedure TServiceThread.Execute; begin fConfigChanged := False; + GetEmailSettings; + fServiceModule.SaveConfig; end; @@ -822,6 +906,8 @@ procedure TServiceThread.Execute; if fServiceModule.DiscoveredCetonDeviceList.Clean then fServiceModule.ConfigManager.DiscoveredCetonDevicesChanged; + + SendErrorEmail; end; finally CoUninitialize; @@ -874,6 +960,8 @@ procedure TServiceThread.SaveLogs; begin for i := 0 to High(cLogNames) do begin + lText := ''; + TMonitor.Enter(fLogCaches[i]); try if fLogCaches[i].Length = 0 then @@ -912,4 +1000,122 @@ procedure TServiceThread.DiscoveredCetonDevicesChanged; // Nothing end; +procedure TServiceThread.LogError(const aLogName, aMessage: String); +var + lMsg: String; +begin + Log(aLogName, aMessage); + + // Log for email notification + if SameText(aLogName, cLogDefault) then + begin + lMsg := Format('[%s] %s', [FormatDateTime('yyyy-mm-dd hh:nn:ss.zzz', Now), aMessage]); + + TMonitor.Enter(fErrorEmailCache); + try + fErrorEmailCache.AppendLine(lMsg); + finally + TMonitor.Exit(fErrorEmailCache); + end; + end; +end; + +procedure TServiceThread.SendErrorEmail; +var + lText: String; + lEmail: TEmail; +begin + lText := ''; + + TMonitor.Enter(fErrorEmailCache); + try + if fErrorEmailCache.Length = 0 then + Exit; + + if fErrorEmailStartDateTime = 0 then + begin + // Start the timer to the next email now + fErrorEmailStartDateTime := Now; + Exit; + end; + + if Now < IncSecond(fErrorEmailStartDateTime, fErrorEmailSettings.FrequencySec) then + Exit; + + lText := fErrorEmailCache.ToString; + fErrorEmailCache.Length := 0; + fErrorEmailStartDateTime := 0; + finally + TMonitor.Exit(fErrorEmailCache); + end; + + if (fErrorEmailSettings.Recipients <> '') and (fEmailServerSettings.ServerAddress <> '') then + begin + lEmail := TEmail.Create; + try + lEmail.Sender := fErrorEmailSettings.Sender; + lEmail.Recipients := fErrorEmailSettings.Recipients; + lEmail.Subject := fErrorEmailSettings.Subject; + lEmail.Body := lText; + + try + TEmailUtils.Send(fEmailServerSettings, lEmail); + except + on e: Exception do + begin + // Do not send to error to avoid loop + TLogger.Log(cLogDefault, Format('Unable to send email: %s', [e.Message])); + end; + end; + finally + lEmail.Free; + end; + end; +end; + +procedure TServiceThread.GetEmailSettings; +var + lConfig: TServiceConfig; +begin + fServiceModule.ConfigManager.LockConfig(lConfig); + try + fEmailServerSettings.Assign(lConfig.EmailServer); + fErrorEmailSettings.Assign(lConfig.ErrorEmail); + finally + fServiceModule.ConfigManager.UnlockConfig(lConfig); + end; +end; + +{ TErrorEmailSettings } + +constructor TErrorEmailSettings.Create; +begin + Assign(nil); +end; + +procedure TErrorEmailSettings.AssignTo(Dest: TPersistent); +begin + if Dest is TErrorEmailSettings then + begin + TErrorEmailSettings(Dest).fFrequencySec := fFrequencySec; + TErrorEmailSettings(Dest).fSender := fSender; + TErrorEmailSettings(Dest).fRecipients := fRecipients; + TErrorEmailSettings(Dest).fSubject := fSubject; + end + else + inherited; +end; + +procedure TErrorEmailSettings.Assign(Source: TPersistent); +begin + if not Assigned(Source) then + begin + fFrequencySec := cErrorEmailFrequencySec; + fSender := 'cetonproxy'; + fSubject := 'Cetonproxy error'; + end + else + inherited; +end; + end. diff --git a/ProxyWebModuleUnit.pas b/ProxyWebModuleUnit.pas index 3e5605c..0c0873d 100644 --- a/ProxyWebModuleUnit.pas +++ b/ProxyWebModuleUnit.pas @@ -10,7 +10,8 @@ interface Web.WebReq, FMX.Types, IdHTTPWebBrokerBridge, - IDGlobal, + IdGlobal, + IdStack, REST.JSON, REST.Json.Types, REST.JsonReflect, @@ -229,6 +230,12 @@ procedure TProxyWebModule.SendTuneResponse(const aTuner, aChannel: Integer; cons // If Create here lStream := TCetonVideoStream.Create(Client, aTuner, aChannel, aAllowedDisabledTuners, aRemux); try + lStream.OnCheckAbort := + procedure(var aAbort: Boolean) + begin + aAbort := not TIdHTTPAppChunkedResponse(Response).Connected; + end; + try TIdHTTPAppChunkedResponse(Response).SendChunkedStream(lStream, procedure(const aPacketSize: Integer; var aContinue: Boolean) @@ -298,8 +305,31 @@ procedure TProxyWebModule.ProxyWebModuleAutoActionAction(Sender: TObject; end; procedure TProxyWebModule.HandleException; +var + lError: Boolean; begin - TLogger.LogFmt(cLogDefault, 'Service handler error: %s', [Exception(ExceptObject).Message]); + // Ignore + lError := True; + if Exception(ExceptObject) is EIdSocketError then + begin + case EIdSocketError(ExceptObject).LastError of + 10053, 10054: begin + // 10053: Software cause connection abort + // 10054: Socket Error + lError := False; + end; + end; + end + else if Exception(ExceptObject) is ECetonClosedError then + begin + // Ignore client-initiated close exceptions + lError := False; + end; + + if lError then + TLogger.LogErrorFmt(cLogDefault, 'Service handler error: %s', [Exception(ExceptObject).Message]) + else + 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 diff --git a/VideoUtils.pas b/VideoUtils.pas index e1c44d6..228524b 100644 --- a/VideoUtils.pas +++ b/VideoUtils.pas @@ -24,8 +24,8 @@ interface EVideoConverterError = class(Exception); TVideoReadWriteEvent = reference to function(const aBuf: PByte; const aSize: Integer): Integer; - TVideoLogEvent = reference to procedure(const aMsg: String); + TVideoInterruptEvent = reference to procedure(var aAbort: Boolean); TVideoConverter = class private @@ -39,12 +39,14 @@ TVideoConverter = class fProgramFilter: Integer; fFinished: Boolean; + fOnInterrupt: TVideoInterruptEvent; function GetErrorStr(const aErrorCode: Integer): String; procedure LogFmt(const aMsg: String; const aArgs: array of const); procedure ErrorFmt(const aMsg: String; const aArgs: array of const); + procedure CheckInterrupt(var aAbort: Boolean); function ReadPacket(const buf: PByte; const buf_size: Integer): Integer; function WritePacket(const buf: PByte; const buf_size: Integer): Integer; @@ -59,6 +61,7 @@ TVideoConverter = class property OnRead: TVideoReadWriteEvent read fOnRead write fOnRead; property OnWrite: TVideoReadWriteEvent read fOnWrite write fOnWrite; property OnLog: TVideoLogEvent read fOnLog write fOnLog; + property OnInterrupt: TVideoInterruptEvent read fOnInterrupt write fOnInterrupt; property ProgramFilter: Integer read fProgramFilter write fProgramFilter; end; @@ -94,6 +97,18 @@ procedure _LogCallback(avcl: Pointer; level: Integer; const fmt: PAnsiChar; vl: end; end; +function _InterruptCallback(opaque: Pointer): Integer; cdecl; +var + lAbort: Boolean; +begin + lAbort := False; + TvideoConverter(opaque).CheckInterrupt(lAbort); + if lAbort then + Result := 1 + else + Result := 0; +end; + { TVideoConverter } procedure TVideoConverter.Open; @@ -102,6 +117,8 @@ procedure TVideoConverter.Open; begin fInputFormatContext := avformat_alloc_context; fInputFormatContext.pb := avio_alloc_context(av_malloc(cConverterPacketSize), cConverterPacketSize, 0, Self, _ReadPacket, nil, nil); + fInputFormatContext.interrupt_callback.opaque := Self; + fInputFormatContext.interrupt_callback.callback := _InterruptCallback; lRet := avformat_open_input(@fInputFormatContext, nil, nil, nil); if lRet < 0 then @@ -317,6 +334,12 @@ procedure TVideoConverter.LogFmt(const aMsg: String; fOnLog(Format(Trim(aMsg), aArgs)); end; +procedure TVideoConverter.CheckInterrupt(var aAbort: Boolean); +begin + if Assigned(fOnInterrupt) then + fOnInterrupt(aAbort); +end; + initialization av_log_set_callback(_LogCallback); finalization diff --git a/ceton/Ceton.pas b/ceton/Ceton.pas index 593998b..7cb24c5 100644 --- a/ceton/Ceton.pas +++ b/ceton/Ceton.pas @@ -214,6 +214,8 @@ TVarRequest = class(TCustomRESTRequest) TCetonModel = (Ethernet, USB, PCI); TREST = class abstract + private + class function GetTunerCountFromDescriptionXML(const aXMLContent: String): Integer; static; public type TValidateValueCallback = reference to function(const aValue: String): Boolean; @@ -407,6 +409,8 @@ TCetonViewerStats = record OutMeter: TDataMeter; end; + TCheckAbortEvent = reference to procedure(var aAbort: Boolean); + TCetonVideoStream = class(TStream) private fWriteBuffer, fReadBuffer: TRingBuffer; @@ -417,10 +421,16 @@ TCetonVideoStream = class(TStream) fConverterError: Exception; fConverterErrorAddress: Pointer; fProgramFilter: Integer; + fAbort: Boolean; + fCheckAbortTimer: TStopwatch; + fOnCheckAbort: TCheckAbortEvent; + + procedure DoCheckAbort(var aAbort: Boolean); function ConverterRead(const aBuf: PByte; const aSize: Integer): Integer; function ConverterWrite(const aBuf: PByte; const aSize: Integer): Integer; procedure ConverterLog(const aMsg: String); + procedure ConverterInterrupt(var aAbort: Boolean); public constructor Create(const aClient: TCetonClient; const aTuner: Integer; const aChannel: Integer; const aAllowedDisabledTuners: Boolean; const aRemux: Boolean); reintroduce; destructor Destroy; override; @@ -432,6 +442,8 @@ TCetonVideoStream = class(TStream) property Viewer: TCetonViewer read fViewer; property Stats: TCetonViewerStats read fStats; + + property OnCheckAbort: TCheckAbortEvent read fOnCheckAbort write fOnCheckAbort; end; TDiscoveredCetonDevice = record @@ -904,20 +916,38 @@ class function TREST.VarContains(const aValue: String): TValidateValueCallback; end; class function TREST.GetTunerCount(const aClient: TRestClient): Integer; -//var -// lRequest: TRESTRequest; +var + lRequest: TRESTRequest; begin TLogger.Log(cLogDefault, 'Checking tuner count'); + lRequest := TRESTRequest.Create(nil); + try + lRequest.Timeout := 1500; + + lRequest.Client := aClient; + lRequest.Method := TRESTRequestMethod.rmGet; + lRequest.Resource := 'description.xml'; + + lRequest.Execute; + + Result := GetTunerCountFromDescriptionXML(lRequest.Response.Content); + finally + lRequest.Free; + end; + + +{ // Following also doesn't work because newer firmwares appear to also respond to this. // 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 // nonexistant tuners, so using this for now. if SameText(TREST.GetVar(aClient, 5, 'cas', 'DescramblingStatus', 3000), '(null)') then Result := 4 else - Result := 6; + Result := 6;} -{ lRequest := TRESTRequest.Create(nil); +{ // Following method doesn't work because 4 tuner cards still respond + lRequest := TRESTRequest.Create(nil); try lRequest.Timeout := 1500; @@ -956,6 +986,44 @@ class function TREST.GetModel(const aClient: TRestClient): TCetonModel; TLogger.LogFmt(cLogDefault, 'Determined tuner model: %s', [GetEnumName(TypeInfo(TCetonModel), Integer(Result))]); end; +class function TREST.GetTunerCountFromDescriptionXML( + const aXMLContent: String): Integer; +var + lXML: IXMLDocument; + lRootNode, lDeviceNode, lDeviceListNode, lSubDeviceNode, lDeviceTypeNode: IXMLNode; + i: Integer; +begin + Result := 0; + + lXML := TXMLDocument.Create(nil); + lXML.LoadFromXML(aXMLContent); + + lRootNode := lXML.ChildNodes.FindNode('root'); + if Assigned(lRootNode) then + begin + lDeviceNode := lRootNode.ChildNodes.FindNode('device'); + if Assigned(lDeviceNode) then + begin + lDeviceListNode := lDeviceNode.ChildNodes.FindNode('deviceList'); + if Assigned(lDeviceListNode) then + begin + for i := 0 to lDeviceListNode.ChildNodes.Count-1 do + begin + lSubDeviceNode := lDeviceListNode.ChildNodes[i]; + + lDeviceTypeNode := lSubDeviceNode.ChildNodes.FindNode('deviceType'); + if Assigned(lDeviceTypeNode) and (lDeviceTypeNode.Text.ToLower.Contains(':mediaserver:')) then + Inc(Result); + end; + end; + end; + end; + + // Fallback + if Result = 0 then + Result := 6; +end; + { TTunerList } constructor TTunerList.Create; @@ -1057,10 +1125,13 @@ procedure TCetonClient.StartStream(const aTuner: Integer; const aChannel: Intege for i := 0 to fTunerList.Count-1 do begin lTuner := fTunerList[i]; - if (aAllowDisabledTuners) or ((i < fConfig.Tuners.Count) and (fConfig.Tuners[i].Enabled)) then + if not lTuner.Active then begin - aViewer.TunerIndex := i; - Break; + if (aAllowDisabledTuners) or ((i < fConfig.Tuners.Count) and (fConfig.Tuners[i].Enabled)) then + begin + aViewer.TunerIndex := i; + Break; + end; end; end; if aViewer.TunerIndex = -1 then @@ -1074,7 +1145,6 @@ procedure TCetonClient.StartStream(const aTuner: Integer; const aChannel: Intege lTunerIndex := 0; for i := 0 to fTunerList.Count-1 do begin - lTuner := fTunerList[i]; if (aAllowDisabledTuners) or ((i < fConfig.Tuners.Count) and (fConfig.Tuners[i].Enabled)) then begin if lTunerIndex = aTuner then @@ -1157,7 +1227,7 @@ procedure TCetonClient.StartStream(const aTuner: Integer; const aChannel: Intege end; until lReceivedPacket or (lCount >= 3); - // Get copy protection status for informational purposes + // Get other info for logging purposes TRest.GetVar(fClient, aViewer.TunerIndex, 'diag', 'CopyProtectionStatus'); lTuner.Channel := aChannel; @@ -1422,6 +1492,13 @@ function TCetonClient.CheckTuner: Boolean; on e: Exception do TLogger.LogFmt(cLogDefault, 'Unable to detect tuner listen IP: %s', [e.Message]); end; + + // Get other information for logging + try + TRest.GetVar(fClient, 0, 'diag', 'Host_Firmware'); + except + // + end; except raise ECetonError.CreateFmt('Unable to reach tuner at %s', [lTunerAddress]); end; @@ -1668,11 +1745,24 @@ procedure TTuner.ReaderStopped(const aReaderIndex: Integer); function TCetonVideoStream.ConverterRead(const aBuf: PByte; const aSize: Integer): Integer; +var + lAbort: Boolean; begin // Read packets from client into a ring buffer and then // copy them into the read buffer to go to converter - try + lAbort := False; + DoCheckAbort(lAbort); + if lAbort then + begin + if not Assigned(fConverterError) then + begin + fConverterError := ECetonClosedError.Create('Client connection closed'); + fConverterErrorAddress := ReturnAddress; + end; + Exit(0); + end; + while fReadBuffer.Size < aSize do fClient.ReadStream(fViewer, fReadBuffer, aSize-fReadBuffer.Size, cReadPacketSize); @@ -1715,6 +1805,8 @@ constructor TCetonVideoStream.Create(const aClient: TCetonClient; fReadBuffer := TRingBuffer.Create; fWriteBuffer := TRingBuffer.Create; + fCheckAbortTimer := TStopwatch.StartNew; + fClient.StartStream(aTuner, aChannel, aAllowedDisabledTuners, fViewer); fProgramFilter := -1; @@ -1729,6 +1821,7 @@ constructor TCetonVideoStream.Create(const aClient: TCetonClient; fConverter.OnRead := ConverterRead; fConverter.OnWrite := ConverterWrite; fConverter.OnLog := ConverterLog; + fConverter.OnInterrupt := ConverterInterrupt; {$IFDEF DEBUGSINK} fConverter.ProgramFilter := cDebugSinkProgramNumber; {$ELSE} @@ -1747,10 +1840,20 @@ function TCetonVideoStream.Read(var Buffer; Count: Longint): Longint; begin if Assigned(fConverter) then begin - // Fill ring buffer by way of video converter - while (fWriteBuffer.Size < Count) and (not Assigned(fConverterError)) do - if not fConverter.Next then - Break; + try + // Fill ring buffer by way of video converter + while (fWriteBuffer.Size < Count) and (not Assigned(fConverterError)) do + if not fConverter.Next then + Break; + except + // Prefer an exception already stored in fConverterError, because that is the + // original error + if not Assigned(fConverterError) then + begin + fConverterError := Exception(AcquireExceptionObject); + fConverterErrorAddress := ExceptAddr; + end; + end; if Assigned(fConverterError) then raise fConverterError at fConverterErrorAddress; @@ -1793,6 +1896,31 @@ procedure TCetonVideoStream.ConverterLog(const aMsg: String); TLogger.LogFmt(cLogDefault, 'Client %d tuner %d video converter: %s', [fViewer.Reader.ReaderIndex, fViewer.TunerIndex, aMsg]); end; +procedure TCetonVideoStream.ConverterInterrupt(var aAbort: Boolean); +begin + DoCheckAbort(aAbort); +end; + +procedure TCetonVideoStream.DoCheckAbort(var aAbort: Boolean); +begin + if fAbort then + begin + aAbort := True; + Exit; + end; + + if fCheckAbortTimer.ElapsedMilliseconds >= 1000 then + begin + fCheckAbortTimer.Reset; + fCheckAbortTimer.Start; + + if Assigned(fOnCheckAbort) then + fOnCheckAbort(aAbort); + + fAbort := aAbort; + end; +end; + { TChannelMapItem } procedure TChannelMapItem.AssignTo(Dest: TPersistent); diff --git a/cetonproxy.dpr b/cetonproxy.dpr index 68f3d4f..a928bb8 100644 --- a/cetonproxy.dpr +++ b/cetonproxy.dpr @@ -36,7 +36,8 @@ uses libavutil_log in 'ffmpeg\src\headers\libavutil_log.pas', libavutil_avstring in 'ffmpeg\src\headers\libavutil_avstring.pas', LogUtils in 'LogUtils.pas', - FileUtils in 'FileUtils.pas'; + FileUtils in 'FileUtils.pas', + EmailUtils in 'EmailUtils.pas'; {$R *.res} diff --git a/openssl/libeay32.dll b/openssl/libeay32.dll new file mode 100644 index 0000000..b3e6a01 Binary files /dev/null and b/openssl/libeay32.dll differ diff --git a/openssl/ssleay32.dll b/openssl/ssleay32.dll new file mode 100644 index 0000000..5bef436 Binary files /dev/null and b/openssl/ssleay32.dll differ