modRdap.bas

Attribute VB_Name = "modRdap"
Option Explicit
'RDAP domain lookups (RFC 7480-7484). RDAP is HTTPS + JSON and replaces
'port-43 WHOIS for gTLDs (ICANN sunset port 43 in January 2025).
'Self-contained: needs only clsJson. Callers fall back to the WhoIs OCX
'when RdapLookup returns Success = False.

Public Type RdapResult
    Success As Boolean          'result fields below are valid
    NotRegistered As Boolean    'HTTP 404: the domain is available
    ErrorMsg As String          'set when Success = False
    Registrar As String
    WhoisServer As String
    CreatedDate As String       'yyyy-mm-dd
    UpdatedDate As String
    ExpirationDate As String
    Status As String
    NS1 As String
    NS2 As String
    RawJson As String
End Type

Private Const BOOTSTRAP_URL As String = "https://data.iana.org/rdap/dns.json"
Private Const BOOTSTRAP_FILE As String = "rdap-bootstrap.json"
Private Const BOOTSTRAP_MAX_AGE_DAYS As Long = 30

'TLD -> RDAP base URL table from the IANA bootstrap file
Private m_BootTlds() As String
Private m_BootUrls() As String
Private m_BootCount As Long
Private m_BootLoaded As Boolean
Private m_BootTried As Boolean

Public Function RdapLookup(ByVal DomainName As String) As RdapResult
    Dim res As RdapResult
    DomainName = LCase$(Trim$(DomainName))

    Dim baseUrl As String
    baseUrl = GetRdapBase(DomainName)
    If baseUrl = "" Then
        res.ErrorMsg = "No RDAP server known for this TLD"
        RdapLookup = res
        Exit Function
    End If
    If Right$(baseUrl, 1) <> "/" Then baseUrl = baseUrl & "/"

    Dim httpStatus As Long, Body As String
    If HttpGetText(baseUrl & "domain/" & DomainName, httpStatus, Body) = False Then
        res.ErrorMsg = "RDAP request failed (no response)"
        RdapLookup = res
        Exit Function
    End If

    res.RawJson = Body
    If httpStatus = 404 Then
        res.Success = True
        res.NotRegistered = True
        res.Status = "Not Registered"
        RdapLookup = res
        Exit Function
    End If
    If httpStatus <> 200 Then
        res.ErrorMsg = "RDAP HTTP error " & httpStatus
        res.RawJson = ""
        RdapLookup = res
        Exit Function
    End If

    On Error GoTo parseFail
    Dim parser As clsJson
    Set parser = New clsJson
    Dim doc As Object
    Set doc = parser.Parse(Body)

    'events[]: eventAction registration / expiration / last changed
    Dim vList As Variant, vItem As Variant
    VarAssign vList, JItem(doc, "events")
    If TypeName(vList) = "Collection" Then
        For Each vItem In vList
            Select Case LCase$(JText(vItem, "eventAction"))
                Case "registration"
                    res.CreatedDate = IsoDateOnly(JText(vItem, "eventDate"))
                Case "expiration"
                    res.ExpirationDate = IsoDateOnly(JText(vItem, "eventDate"))
                Case "last changed"
                    res.UpdatedDate = IsoDateOnly(JText(vItem, "eventDate"))
            End Select
        Next
    End If

    'nameservers[]: ldhName
    VarAssign vList, JItem(doc, "nameservers")
    If TypeName(vList) = "Collection" Then
        For Each vItem In vList
            Dim sNs As String
            sNs = JText(vItem, "ldhName")
            If sNs <> "" Then
                If res.NS1 = "" Then
                    res.NS1 = sNs
                ElseIf res.NS2 = "" Then
                    res.NS2 = sNs
                End If
            End If
        Next
    End If

    'status[]: joined list
    VarAssign vList, JItem(doc, "status")
    If TypeName(vList) = "Collection" Then
        For Each vItem In vList
            If Not IsObject(vItem) Then
                If res.Status <> "" Then res.Status = res.Status & ", "
                res.Status = res.Status & CStr(vItem)
            End If
        Next
    End If

    'entities[]: entity with role "registrar" -> vcard fn
    res.Registrar = FindRegistrar(doc)

    'port43: legacy whois server, when the registry still lists one. Modern
    'registries often omit it - fall back to the registrar's RDAP host from
    'the "related" link, then to the registry RDAP host we queried.
    res.WhoisServer = JText(doc, "port43")
    If res.WhoisServer = "" Then res.WhoisServer = FindRelatedRdapHost(doc)
    If res.WhoisServer = "" Then res.WhoisServer = UrlHost(baseUrl)

    res.Success = True
    RdapLookup = res
    Exit Function
parseFail:
    res.Success = False
    res.ErrorMsg = "RDAP parse error: " & Err.Description
    RdapLookup = res
End Function

'Host of the rel="related" link - registries point it at the registrar's
'RDAP service (the modern equivalent of the registrar whois server).
Private Function FindRelatedRdapHost(ByVal doc As Variant) As String
    On Error GoTo done
    Dim vLinks As Variant, vLink As Variant
    VarAssign vLinks, JItem(doc, "links")
    If TypeName(vLinks) <> "Collection" Then Exit Function
    For Each vLink In vLinks
        If LCase$(JText(vLink, "rel")) = "related" Then
            Dim sHref As String
            sHref = JText(vLink, "href")
            If sHref <> "" Then
                FindRelatedRdapHost = UrlHost(sHref)
                Exit Function
            End If
        End If
    Next
done:
End Function

Private Function UrlHost(ByVal Url As String) As String
    Dim p As Long
    p = InStr(1, Url, "://")
    If p > 0 Then Url = Mid$(Url, p + 3)
    p = InStr(1, Url, "/")
    If p > 0 Then Url = Left$(Url, p - 1)
    UrlHost = LCase$(Url)
End Function

'Look for an entity with role "registrar" and return its vcard "fn" value.
Private Function FindRegistrar(ByVal doc As Variant) As String
    On Error GoTo done
    Dim vEntities As Variant, vEnt As Variant
    VarAssign vEntities, JItem(doc, "entities")
    If TypeName(vEntities) <> "Collection" Then Exit Function
    For Each vEnt In vEntities
        Dim vRoles As Variant, vRole As Variant
        VarAssign vRoles, JItem(vEnt, "roles")
        If TypeName(vRoles) = "Collection" Then
            For Each vRole In vRoles
                If Not IsObject(vRole) Then
                    If LCase$(CStr(vRole)) = "registrar" Then
                        'vcardArray = ["vcard", [["fn",{},"text","Name"], ...]]
                        Dim vVcard As Variant, vProps As Variant, vProp As Variant
                        VarAssign vVcard, JItem(vEnt, "vcardArray")
                        If TypeName(vVcard) = "Collection" Then
                            VarAssign vProps, JItem(vVcard, 2)
                            If TypeName(vProps) = "Collection" Then
                                For Each vProp In vProps
                                    If TypeName(vProp) = "Collection" Then
                                        If LCase$(JText(vProp, 1)) = "fn" Then
                                            FindRegistrar = JText(vProp, 4)
                                            Exit Function
                                        End If
                                    End If
                                Next
                            End If
                        End If
                    End If
                End If
            Next
        End If
    Next
done:
End Function

'Normalize assorted whois date formats ("14-sep-2025", "2025-09-14T04:00:00Z")
'to yyyy-mm-dd so rows sort chronologically as text and DateDiff can parse
'them. Returns the input unchanged when it cannot be parsed.
Public Function NormalizeDateString(ByVal s As String) As String
    s = Trim$(s)
    NormalizeDateString = s
    If s = "" Then Exit Function
    On Error GoTo done
    Dim sTry As String
    sTry = IsoDateOnly(s)
    If IsDate(sTry) Then
        NormalizeDateString = Format$(CDate(sTry), "yyyy-mm-dd")
    End If
done:
End Function

'Trim an ISO 8601 timestamp ("2026-08-30T04:00:00Z") to its date part so the
'value sorts sanely and CheckDomainExpire's DateDiff can parse it.
Public Function IsoDateOnly(ByVal s As String) As String
    s = Trim$(s)
    Dim p As Long
    p = InStr(1, s, "T")
    If p > 1 Then s = Left$(s, p - 1)
    IsoDateOnly = s
End Function

Public Function FormatRdapReport(r As RdapResult) As String
    Dim s As String
    If r.NotRegistered Then
        s = "Domain is NOT registered (RDAP 404) - it appears to be available." & vbCrLf
    Else
        s = "RDAP Lookup Result" & vbCrLf
        s = s & "------------------" & vbCrLf
        s = s & "Registrar:       " & r.Registrar & vbCrLf
        s = s & "Whois Server:    " & r.WhoisServer & vbCrLf
        s = s & "Created Date:    " & r.CreatedDate & vbCrLf
        s = s & "Updated Date:    " & r.UpdatedDate & vbCrLf
        s = s & "Expiration Date: " & r.ExpirationDate & vbCrLf
        s = s & "Status:          " & r.Status & vbCrLf
        s = s & "Name Server 1:   " & r.NS1 & vbCrLf
        s = s & "Name Server 2:   " & r.NS2 & vbCrLf
    End If
    s = s & vbCrLf & "Raw RDAP JSON:" & vbCrLf & r.RawJson
    FormatRdapReport = s
End Function

'Return the RDAP base URL for a domain's TLD, or "" if the TLD has no RDAP
'service (caller should fall back to port-43 whois).
Public Function GetRdapBase(ByVal DomainName As String) As String
    EnsureBootstrap
    Dim p As Long
    p = InStrRev(DomainName, ".")
    If p = 0 Then Exit Function
    Dim tld As String
    tld = LCase$(Trim$(Mid$(DomainName, p + 1)))
    Dim i As Long
    For i = 1 To m_BootCount
        If m_BootTlds(i) = tld Then
            GetRdapBase = m_BootUrls(i)
            Exit Function
        End If
    Next
End Function

'Load the TLD -> RDAP URL table. Uses the cached rdap-bootstrap.json beside
'the exe; refreshes from IANA when missing or older than 30 days. Network
'is attempted at most once per session.
Private Sub EnsureBootstrap()
    If m_BootLoaded Or m_BootTried Then Exit Sub
    m_BootTried = True

    Dim cachePath As String
    cachePath = App.Path & "\" & BOOTSTRAP_FILE

    Dim haveFile As Boolean, stale As Boolean
    haveFile = RdapFileExists(cachePath)
    stale = True
    If haveFile Then
        On Error Resume Next
        stale = (DateDiff("d", FileDateTime(cachePath), Now) > BOOTSTRAP_MAX_AGE_DAYS)
        On Error GoTo 0
    End If

    If (Not haveFile) Or stale Then
        Dim httpStatus As Long, Body As String
        If HttpGetText(BOOTSTRAP_URL, httpStatus, Body) Then
            If httpStatus = 200 And Len(Body) > 100 Then
                If ParseBootstrap(Body) Then
                    m_BootLoaded = True
                    SaveTextFile cachePath, Body
                End If
            End If
        End If
    End If

    'download skipped or failed - use the cached copy, stale or not
    If haveFile And m_BootLoaded = False Then
        If ParseBootstrap(ReadTextFile(cachePath)) Then m_BootLoaded = True
    End If

    'user-maintained extras for TLDs (like .io) that run RDAP but are not in
    'the IANA registry. Appended after the bootstrap so IANA data wins.
    LoadExtraRdap
End Sub

'rdap-extra.ini lines: tld=https://rdap.example/ ( # and ; start comments)
Private Sub LoadExtraRdap()
    On Error GoTo done
    Dim p As String
    p = App.Path & "\rdap-extra.ini"
    If RdapFileExists(p) = False Then Exit Sub
    Dim f As Long, sLine As String, eq As Long
    f = FreeFile
    Open p For Input As #f
    Do While Not EOF(f)
        Line Input #f, sLine
        sLine = Trim$(sLine)
        If sLine <> "" And Left$(sLine, 1) <> "#" And Left$(sLine, 1) <> ";" Then
            eq = InStr(1, sLine, "=")
            If eq > 1 Then
                AddBootEntry Left$(sLine, eq - 1), Mid$(sLine, eq + 1)
            End If
        End If
    Loop
    Close #f
done:
End Sub

Private Sub AddBootEntry(ByVal tld As String, ByVal Url As String)
    Dim cap As Long
    cap = 0
    On Error Resume Next
    cap = UBound(m_BootTlds)
    On Error GoTo 0
    If m_BootCount + 1 > cap Then
        If cap = 0 Then
            ReDim m_BootTlds(1 To 200)
            ReDim m_BootUrls(1 To 200)
        Else
            ReDim Preserve m_BootTlds(1 To cap + 200)
            ReDim Preserve m_BootUrls(1 To cap + 200)
        End If
    End If
    m_BootCount = m_BootCount + 1
    m_BootTlds(m_BootCount) = LCase$(Trim$(tld))
    m_BootUrls(m_BootCount) = Trim$(Url)
End Sub

'Bootstrap format: {"services": [ [ ["tld", ...], ["https://url/", ...] ], ... ]}
Private Function ParseBootstrap(ByVal jsonText As String) As Boolean
    On Error GoTo failed
    Dim parser As clsJson
    Set parser = New clsJson
    Dim doc As Object
    Set doc = parser.Parse(jsonText)

    Dim vServices As Variant
    VarAssign vServices, JItem(doc, "services")
    If TypeName(vServices) <> "Collection" Then Exit Function

    ReDim m_BootTlds(1 To 2000)
    ReDim m_BootUrls(1 To 2000)
    m_BootCount = 0

    Dim vSvc As Variant, vTlds As Variant, vUrls As Variant
    Dim vTld As Variant, vUrl As Variant
    For Each vSvc In vServices
        VarAssign vTlds, JItem(vSvc, 1)
        VarAssign vUrls, JItem(vSvc, 2)
        Dim sUrl As String
        sUrl = ""
        If TypeName(vUrls) = "Collection" Then
            For Each vUrl In vUrls
                If Not IsObject(vUrl) Then
                    If LCase$(Left$(CStr(vUrl), 6)) = "https:" Then
                        sUrl = CStr(vUrl)
                        Exit For
                    End If
                    If sUrl = "" Then sUrl = CStr(vUrl)
                End If
            Next
        End If
        If sUrl <> "" And TypeName(vTlds) = "Collection" Then
            For Each vTld In vTlds
                If Not IsObject(vTld) Then
                    m_BootCount = m_BootCount + 1
                    If m_BootCount > UBound(m_BootTlds) Then
                        ReDim Preserve m_BootTlds(1 To UBound(m_BootTlds) + 500)
                        ReDim Preserve m_BootUrls(1 To UBound(m_BootUrls) + 500)
                    End If
                    m_BootTlds(m_BootCount) = LCase$(CStr(vTld))
                    m_BootUrls(m_BootCount) = sUrl
                End If
            Next
        End If
    Next
    ParseBootstrap = (m_BootCount > 0)
    Exit Function
failed:
    m_BootCount = 0
End Function

'HTTP GET returning the status code and body. Never raises; False means no
'response at all (DNS/connect/TLS failure). ServerXMLHTTP (WinHTTP) is
'preferred for its TLS handling and timeouts; falls back to WinINET.
Private Function HttpGetText(ByVal Url As String, ByRef httpStatus As Long, ByRef Body As String) As Boolean
    Dim http As Object
    On Error Resume Next
    Set http = CreateObject("MSXML2.ServerXMLHTTP.6.0")
    If Not http Is Nothing Then
        http.setTimeouts 10000, 10000, 15000, 30000
    Else
        Set http = CreateObject("MSXML2.XMLHTTP")
    End If
    If http Is Nothing Then Exit Function
    Err.Clear
    On Error GoTo failed
    http.open "GET", Url, False
    On Error Resume Next
    http.setRequestHeader "Accept", "application/rdap+json, application/json"
    http.setRequestHeader "User-Agent", "DomainManagerPro/" & App.Major & "." & App.Minor
    On Error GoTo failed
    http.send
    httpStatus = http.Status
    Body = http.responseText
    HttpGetText = True
    Exit Function
failed:
End Function

Private Function RdapFileExists(ByVal Path As String) As Boolean
    On Error Resume Next
    If Len(Path) = 0 Then Exit Function
    If Dir(Path, vbHidden Or vbNormal Or vbReadOnly Or vbSystem) <> vbNullString Then RdapFileExists = True
End Function

Private Function ReadTextFile(ByVal Path As String) As String
    On Error Resume Next
    Dim f As Long
    f = FreeFile
    Open Path For Binary Access Read As #f
    ReadTextFile = Space$(LOF(f))
    Get #f, 1, ReadTextFile
    Close #f
End Function

Private Sub SaveTextFile(ByVal Path As String, ByVal Contents As String)
    On Error Resume Next
    Dim f As Long
    f = FreeFile
    Open Path For Output As #f
    Print #f, Contents
    Close #f
End Sub

'--- JSON navigation helpers (values may be objects or primitives) ---

'Assign src to dest whether src holds an object or a primitive. When dest
'currently holds an object and src is a primitive, a plain Let-assignment
'would be routed to the object's default property, so release dest instead;
'callers treat Nothing the same as a missing member.
Private Sub VarAssign(ByRef dest As Variant, ByRef src As Variant)
    If IsObject(src) Then
        Set dest = src
    ElseIf IsObject(dest) Then
        Set dest = Nothing
    Else
        dest = src
    End If
End Sub

'Safe member access: Dictionary by string key or Collection by index.
'Returns Empty when the member is absent or the container type is wrong.
Private Function JItem(ByVal Container As Variant, ByVal KeyOrIndex As Variant) As Variant
    On Error GoTo missing
    Dim v As Variant
    Select Case TypeName(Container)
        Case "Dictionary"
            If Container.Exists(KeyOrIndex) Then
                VarAssign v, Container.Item(KeyOrIndex)
            End If
        Case "Collection"
            VarAssign v, Container.Item(KeyOrIndex)
    End Select
    If IsObject(v) Then
        Set JItem = v
    Else
        JItem = v
    End If
missing:
End Function

'Member access coerced to String; "" when absent or not a simple value.
Private Function JText(ByVal Container As Variant, ByVal KeyOrIndex As Variant) As String
    On Error GoTo missing
    Dim v As Variant
    VarAssign v, JItem(Container, KeyOrIndex)
    If Not IsObject(v) Then
        If Not IsEmpty(v) And Not IsNull(v) Then JText = CStr(v)
    End If
missing:
End Function