' Copyright (C) 2023 Andy https://github.com/AAndyProgram ' This program is free software: you can redistribute it and/or modify ' it under the terms of the GNU General Public License as published by ' the Free Software Foundation, either version 3 of the License, or ' (at your option) any later version. ' ' This program is distributed in the hope that it will be useful, ' but WITHOUT ANY WARRANTY Imports SCrawler.API.Base Imports SCrawler.Plugin Imports SCrawler.Plugin.Attributes Imports System.Reflection Imports PersonalUtilities.Tools.Web.Clients Imports PersonalUtilities.Tools.Web.Clients.Base Imports PersonalUtilities.Tools.Web.Documents.JSON Imports PersonalUtilities.Functions.XML Imports PersonalUtilities.Functions.RegularExpressions Imports DN = SCrawler.API.Base.DeclaredNames Imports DownDetector = SCrawler.API.Base.DownDetector Imports Download = SCrawler.Plugin.ISiteSettings.Download Namespace API.Reddit Friend Class SiteSettings : Inherits SiteSettingsBase : Implements DownDetector.IDownDetector #Region "Declarations" #Region "Authorization" Private Const ApiClientID_Default As String = "dYctRA-SIJxyykHe27lGZg" Private Const ApiClientSecret_Default As String = "_5D6KzplRPDga-es1YlpzDIe9hiFlg" Friend ReadOnly Property AuthUserName As PropertyValue Friend ReadOnly Property AuthPassword As PropertyValue Friend ReadOnly Property ApiClientID As PropertyValue Private Function ApiClientID_SetDefault() As Boolean ApiClientID.Value = ApiClientID_Default Return True End Function Friend ReadOnly Property ApiClientSecret As PropertyValue Private Function ApiClientSecret_SetDefault() As Boolean ApiClientSecret.Value = ApiClientSecret_Default Return True End Function Friend ReadOnly Property BearerToken As PropertyValue Private ReadOnly Property BearerTokenUseCurl As PropertyValue #Region "TokenUpdateInterval" Friend ReadOnly Property TokenUpdateInterval As PropertyValue Private ReadOnly Property TokenUpdateIntervalProvider As IFormatProvider #End Region Private ReadOnly Property BearerTokenDateUpdate As PropertyValue Friend ReadOnly Property UseTokenForTimelines As PropertyValue Friend ReadOnly Property UseTokenForSavedPosts As PropertyValue Friend ReadOnly Property UseCookiesForTimelines As PropertyValue Friend ReadOnly Property SavedPostsUserName As PropertyValue Friend ReadOnly Property CredentialsExists As Boolean Get Return {AuthUserName.Value, AuthPassword.Value, ApiClientID.Value, ApiClientSecret.Value}.All(Function(v$) Not v.IsEmptyString) End Get End Property Private Function OAuthCredentialsChecker(ByVal p As IEnumerable(Of PropertyData)) As Boolean Const msgTitle$ = "OAuth credentials" If p.ListExists Then Dim useToken As Boolean = False, useCookies As Boolean = False Dim d$ = String.Empty Dim dCount As Byte = 0 Dim members As IEnumerable(Of MemberInfo) = GetObjectMembers(Me) Dim getPropText As Func(Of String, String) = Function(name) members.First(Function(m) m.Name = name).GetCustomAttribute(Of PropertyOption).ControlText Dim dataStr As Action(Of String, String) = Sub(dd, name) If dd.IsEmptyString Then d.StringAppendLine(getPropText(name)) : dCount += 1 For Each pp As PropertyData In p Select Case pp.Name Case NameOf(AuthUserName) : dataStr(pp.Value, NameOf(AuthUserName)) Case NameOf(AuthPassword) : dataStr(pp.Value, NameOf(AuthPassword)) Case NameOf(ApiClientID) : dataStr(pp.Value, NameOf(ApiClientID)) Case NameOf(ApiClientSecret) : dataStr(pp.Value, NameOf(ApiClientSecret)) Case NameOf(UseTokenForTimelines) : useToken = pp.Value Case NameOf(UseCookiesForTimelines) : useCookies = pp.Value Case Else : Throw New ArgumentException($"Property name '{pp.Name}' is not implemented", "Property Name") End Select Next If d.IsEmptyString Then If useToken And useCookies Then Return True Else If Not useToken Then d.StringAppendLine(getPropText(NameOf(UseTokenForTimelines))) If Not useCookies Then d.StringAppendLine(getPropText(NameOf(UseCookiesForTimelines))) MsgBoxE({$"You need to check the following options:{vbCr}{d}", msgTitle}, vbCritical) Return False End If ElseIf dCount = 4 Then Return MsgBoxE({$"You haven't configured OAuth. It's highly recommended to use OAuth.{vbCr}Do you still want to continue?", msgTitle}, vbExclamation,,, {"Process", "Cancel"}) = 0 Else MsgBoxE({$"You haven't filled in the following fields:{vbCr}{d}.{vbCr}{vbCr}" & "To use OAuth authorization, you must fill in all authorization fields.", msgTitle}, vbCritical) Return False End If End If Return True End Function #End Region #Region "Other" Friend ReadOnly Property UseM3U8 As PropertyValue Friend ReadOnly Property CheckImage As PropertyValue Friend ReadOnly Property CheckImageReturnOrig As PropertyValue Friend ReadOnly Property ConcurrentDownloads As PropertyValue #End Region #Region "IDownDetector Support" Private ReadOnly Property IDownDetector_Value As Integer Implements DownDetector.IDownDetector.Value Get Return 100 End Get End Property Private ReadOnly Property IDownDetector_AddToLog As Boolean Implements DownDetector.IDownDetector.AddToLog Get Return False End Get End Property Private ReadOnly Property IDownDetector_CheckSite As String Implements DownDetector.IDownDetector.CheckSite Get Return "reddit" End Get End Property Private Function IDownDetector_Available(ByVal What As Download, ByVal Silent As Boolean) As Boolean Implements DownDetector.IDownDetector.Available Return MDD.Available(What, Silent) End Function #End Region #End Region #Region "Initializer" Friend Sub New(ByVal AccName As String, ByVal Temp As Boolean) MyBase.New(RedditSite, "reddit.com", AccName, Temp, My.Resources.SiteResources.RedditIcon_128, My.Resources.SiteResources.RedditPic_512) Dim token$ With Responser Dim d% = .Decoders.Count .Decoders.ListAddList({SymbolsConverter.Converters.Unicode, SymbolsConverter.Converters.HTML}, LAP.NotContainsOnly) .Accept = "application/json" token = .Headers.Value(DeclaredNames.Header_Authorization) End With AuthUserName = New PropertyValue(String.Empty, GetType(String)) AuthPassword = New PropertyValue(String.Empty, GetType(String)) ApiClientID = New PropertyValue(String.Empty, GetType(String)) ApiClientSecret = New PropertyValue(String.Empty, GetType(String)) BearerToken = New PropertyValue(token, GetType(String), Sub(v) Responser.Headers.Add(DeclaredNames.Header_Authorization, v)) BearerTokenUseCurl = New PropertyValue(False) TokenUpdateInterval = New PropertyValue(360) TokenUpdateIntervalProvider = New TokenRefreshIntervalProvider BearerTokenDateUpdate = New PropertyValue(Now.AddYears(-1)) UseTokenForTimelines = New PropertyValue(False) UseTokenForSavedPosts = New PropertyValue(False) UseCookiesForTimelines = New PropertyValue(False) SavedPostsUserName = New PropertyValue(String.Empty, GetType(String)) UseM3U8 = New PropertyValue(True) CheckImage = New PropertyValue(False) CheckImageReturnOrig = New PropertyValue(True) ConcurrentDownloads = New PropertyValue(1) MDD = New MyDownDetector(Me) UrlPatternUser = "https://www.reddit.com/{0}/{1}/" ImageVideoContains = "reddit.com" UserRegex = RParams.DM("[htps:/]{7,8}.*?reddit.com/([user]{1,4})/([^/\?&]+)", 0, RegexReturn.ListByMatch, EDP.ReturnValue) End Sub Private Const SettingsVersionCurrent As Integer = 3 Friend Overrides Sub EndInit() If CInt(SettingsVersion.Value) < SettingsVersionCurrent Then SettingsVersion.Value = SettingsVersionCurrent UseM3U8.Value = True CheckImage.Value = False CheckImageReturnOrig.Value = True BearerTokenUseCurl.Value = False End If MyBase.EndInit() End Sub #End Region #Region "GetInstance" Friend Overrides Function GetInstance(ByVal What As Download) As IPluginContentProvider Return New UserData End Function #End Region #Region "DownloadStarted, ReadyToDownload, Available, DownloadDone, UpdateRedGifsToken" Private ReadOnly MDD As MyDownDetector Private Class MyDownDetector : Inherits DownDetector.Checker(Of SiteSettings) Private __TrueValue As Boolean = False Friend Sub New(ByRef _Source As SiteSettings) MyBase.New(_Source) End Sub Protected Overrides Function AvailableImpl(ByVal What As Download, ByVal Silent As Boolean) As Boolean __TrueValue = Source.AvailableTrueValue(What) Return MyBase.AvailableImpl(What, Silent) End Function Protected Overrides Function AvailableImpl_TRUE() As Boolean Return AvailableImpl_TrueValueReturn() End Function Protected Overrides Function AvailableImpl_FALSE_SILENT_NOT_MSG_YES() As Boolean Return AvailableImpl_TrueValueReturn() End Function Private Function AvailableImpl_TrueValueReturn() As Boolean If __TrueValue Then Source.UpdateRedGifsToken() Return __TrueValue AndAlso Source.UpdateTokenIfRequired() End Function Friend Overrides Sub Reset() __TrueValue = False MyBase.Reset() End Sub End Class Friend Property SessionInterrupted As Boolean = False Friend Property RequestCount As Integer = 0 Friend Overrides Function ReadyToDownload(ByVal What As Download) As Boolean If What = Download.Main Then Return Not SessionInterrupted Else Return True End If End Function Friend Overrides Function Available(ByVal What As Download, ByVal Silent As Boolean) As Boolean Return AvailableTrueValue(What) AndAlso UpdateTokenIfRequired() End Function Private Function AvailableTrueValue(ByVal What As Download) As Boolean Return Not What = Download.SavedPosts OrElse (Responser.CookiesExists And ACheck(SavedPostsUserName.Value)) End Function Friend Overrides Sub DownloadDone(ByVal What As Download) SessionInterrupted = False RequestCount = 0 MDD.Reset() MyBase.DownloadDone(What) End Sub Private Sub UpdateRedGifsToken() Settings(RedGifs.RedGifsSiteKey).ListForEach(Sub(h, i) DirectCast(h.Source, RedGifs.SiteSettings).UpdateTokenIfRequired()) End Sub #End Region #Region "IsMyUser, GetUserUrl, GetUserPostUrl" Friend Const ChannelOption As String = "r" Friend Overrides Function IsMyUser(ByVal UserURL As String) As ExchangeOptions Dim l As List(Of String) = RegexReplace(UserURL, UserRegex) If l.ListExists(3) Then Dim n$ = l(2) If Not l(1).IsEmptyString AndAlso l(1) = ChannelOption Then n &= $"@{ChannelOption}" Return New ExchangeOptions(Site, n) Else Return Nothing End If End Function Friend Overrides Function GetUserUrl(ByVal User As IPluginContentProvider) As String With DirectCast(User, UserData) : Return String.Format(UrlPatternUser, IIf(.IsChannel, ChannelOption, "user"), .NameTrue) : End With End Function Friend Overrides Function GetUserPostUrl(ByVal User As UserDataBase, ByVal Media As UserMedia) As String If Not Media.Post.ID.IsEmptyString Then Return $"https://www.reddit.com/comments/{Media.Post.ID.Split("_").LastOrDefault}/" Else Return String.Empty End If End Function #End Region #Region "UserOptions" Friend Overrides Sub UserOptions(ByRef Options As Object, ByVal OpenForm As Boolean) If Options Is Nothing OrElse Not TypeOf Options Is RedditViewExchange Then Options = New RedditViewExchange(Me) If OpenForm Then Using f As New RedditViewSettingsForm(Options, True) : f.ShowDialog() : End Using End If End Sub #End Region #Region "BeginEdit, Update" Private _OldTokenValue As String = String.Empty Friend Overrides Sub BeginEdit() _OldTokenValue = BearerToken.Value MyBase.BeginEdit() End Sub Friend Overrides Sub Update() If _SiteEditorFormOpened Then Dim newTokenValue$ = BearerToken.Value If Not newTokenValue.IsEmptyString AndAlso Not newTokenValue = _OldTokenValue Then BearerTokenDateUpdate.Value = Now End If MyBase.Update() End Sub #End Region #Region "Token" Private Function UpdateTokenIfRequired() As Boolean UpdateRedGifsToken() If (CBool(UseTokenForTimelines.Value) Or CBool(UseTokenForSavedPosts.Value)) AndAlso CredentialsExists Then If CDate(BearerTokenDateUpdate.Value).AddMinutes(TokenUpdateInterval.Value) <= Now Then Return UpdateToken() End If Return True End Function Private Overloads Function UpdateToken() As Boolean Return UpdateToken(AuthUserName.Value, AuthPassword.Value, ApiClientID.Value, ApiClientSecret.Value, EDP.SendToLog + EDP.ReturnValue) End Function Private Overloads Function UpdateToken(ByVal UserName As String, ByVal Password As String, ByVal ClientID As String, ByVal ClientSecret As String) As Boolean Return UpdateToken(UserName, Password, ClientID, ClientSecret, EDP.LogMessageValue) End Function Private Overloads Function UpdateToken(ByVal UserName As String, ByVal Password As String, ByVal ClientID As String, ByVal ClientSecret As String, ByVal e As ErrorsDescriber) As Boolean Try Dim result As Boolean = True If {UserName, Password, ClientID, ClientSecret}.All(Function(v) Not v.IsEmptyString) Then result = False Dim r$ = String.Empty Dim c% = 0 Dim useCurl As Boolean = Settings.CurlFile.Exists And CBool(BearerTokenUseCurl.Value) Dim curlUsed As Boolean = useCurl Do c += 1 Using resp As New Responser With { .Method = "POST", .ProcessExceptionDecision = Function(ByVal status As IResponserStatus, ByVal nullArg As Object, ByVal currErr As ErrorsDescriber) As ErrorsDescriber If status.StatusCode = 429 Then useCurl = False Return EDP.ReturnValue ElseIf status.StatusCode = Net.HttpStatusCode.Forbidden And Not useCurl And Settings.CurlFile.Exists Then useCurl = True Return EDP.ReturnValue Else Return currErr End If End Function } With resp If useCurl Then If Settings.CurlFile.Exists Then curlUsed = True .Mode = Responser.Modes.Curl .CurlPath = Settings.CurlFile .CurlArgumentsLeft = $"-d ""grant_type=password&username={UserName}&password={Password}"" --user ""{ClientID}:{ClientSecret}""" Else Throw New ArgumentNullException("cUrl file", "The path to the cUrl file is not specified") End If Else .Mode = Responser.Modes.Default With .PayLoadValues .Add("grant_type", "password") .Add("username", UserName) .Add("password", Password) End With .CredentialsUserName = ClientID .CredentialsPassword = ClientSecret .PreAuthenticate = True End If End With r = resp.GetResponse("https://www.reddit.com/api/v1/access_token",, EDP.ThrowException) End Using If Not r.IsEmptyString Then Using j As EContainer = JsonDocument.Parse(r) If j.ListExists Then Dim newToken$ = j.Value("access_token") If Not newToken.IsEmptyString Then BearerToken.Value = $"Bearer {newToken}" BearerTokenDateUpdate.Value = Now Responser.SaveSettings() result = True End If End If End Using End If Loop While c < 5 And Not result End If Return result Catch ex As Exception Return ErrorsDescriber.Execute(e, ex, "[Reddit.SiteSettings.UpdateToken]", False) End Try End Function #End Region End Class End Namespace