wsc-mvc/test-app/Controllers/SelfTestController.wsc

<?xml version="1.0"?>
<?component error="true" debug="false"?>
<component>
<registration
    description="WscMvc SelfTestController"
    progid="WscMvc.SelfTestController"
    version="1.00"
    classid="{D2634944-4646-4C55-956E-4C05E7E10904}">
</registration>

<public>
    <method name="RunSelfTest">
        <parameter name="logDir"/>
        <parameter name="dbConnectionString"/>
        <parameter name="body"/>
    </method>
</public>

<script language="VBScript">
<![CDATA[
Option Explicit

' HTTP+JSON test harness, callable as GET /self-test from any CLI (curl,
' Invoke-WebRequest, etc.) - no cscript/PowerShell/WSH access to the VM
' required. Runs the same checks as tests/Test-Components.vbs, in-process,
' against the live registered components. Intentionally returns raw
' Err.Description in failure details: unlike Default.asp's own error
' handling (which must never leak internals to an arbitrary client), this
' route IS the diagnostics surface, so its whole job is to say what broke.
' This is a dev/test-milestone tool, not a production data endpoint -
' revisit whether it should be gated/removed during M6 hardening.
Sub RunSelfTest(logDir, dbConnectionString, body)
    Dim checks, allPass
    checks = ""
    allPass = True

    ' --- RequestContext basic contract ---
    Dim ctx1, ctx1Ok, ctx1Detail
    ctx1Ok = False
    ctx1Detail = ""
    On Error Resume Next
    Set ctx1 = CreateObject("WscMvc.RequestContext")
    If Err.Number = 0 Then ctx1.Initialize "/self-test-a", "GET", logDir
    If Err.Number <> 0 Then
        ctx1Detail = Err.Description
        Err.Clear
    ElseIf ctx1.Path <> "/self-test-a" Then
        ctx1Detail = "Path roundtrip mismatch: got [" & ctx1.Path & "]"
    ElseIf ctx1.HttpMethod <> "GET" Then
        ctx1Detail = "HttpMethod roundtrip mismatch: got [" & ctx1.HttpMethod & "]"
    ElseIf Len(ctx1.CorrelationId) = 0 Then
        ctx1Detail = "CorrelationId was empty"
    ElseIf ctx1.ElapsedMs() < 0 Then
        ctx1Detail = "ElapsedMs was negative"
    Else
        ctx1Ok = True
    End If
    On Error Goto 0
    checks = AppendCheck(checks, "request_context_contract", ctx1Ok, ctx1Detail)
    allPass = allPass And ctx1Ok

    ' --- Two contexts must not collide on correlation id ---
    Dim ctx2, distinctOk, distinctDetail
    distinctOk = False
    distinctDetail = ""
    On Error Resume Next
    Set ctx2 = CreateObject("WscMvc.RequestContext")
    ctx2.Initialize "/self-test-b", "GET", logDir
    If Err.Number <> 0 Then
        distinctDetail = Err.Description
        Err.Clear
    ElseIf ctx1.CorrelationId = ctx2.CorrelationId Then
        distinctDetail = "Both contexts produced the same CorrelationId: " & ctx1.CorrelationId
    Else
        distinctOk = True
    End If
    On Error Goto 0
    checks = AppendCheck(checks, "correlation_id_uniqueness", distinctOk, distinctDetail)
    allPass = allPass And distinctOk

    ' --- Shared Application must isolate route sets. The test app must not
    ' activate or test production's HomeController. ---
    Dim app, ctxUnknown, unkStatus, unkType, unkBody, unkAllow, unkOk, unkDetail
    unkOk = False
    unkDetail = ""
    On Error Resume Next
    Set app = CreateObject("WscMvc.Application")
    Set ctxUnknown = CreateObject("WscMvc.RequestContext")
    ctxUnknown.Initialize "/hello", "GET", logDir
    unkStatus = "" : unkType = "" : unkBody = "" : unkAllow = ""
    app.Run ctxUnknown, "tests", "", "", unkStatus, unkType, unkBody, unkAllow
    If Err.Number <> 0 Then
        unkDetail = Err.Description
        Err.Clear
    ElseIf unkStatus <> "404 Not Found" Then
        unkDetail = "Expected 404 Not Found, got [" & unkStatus & "]"
    Else
        unkOk = True
    End If
    On Error Goto 0
    checks = AppendCheck(checks, "test_app_rejects_production_route", unkOk, unkDetail)
    allPass = allPass And unkOk

    ' --- Method dispatch contract: test app self-test route supports both
    ' GET and POST, and reports an Allow header for unsupported methods. ---
    Dim router, ctxPost, postStatus, postType, postBody, postAllow, postHandler, postOk, postDetail
    postOk = False
    postDetail = ""
    On Error Resume Next
    Set router = CreateObject("WscMvc.Router")
    Set ctxPost = CreateObject("WscMvc.RequestContext")
    ctxPost.Initialize "/self-test", "POST", logDir
    postStatus = "" : postType = "" : postBody = "" : postAllow = "" : postHandler = ""
    router.Match ctxPost, "tests", postStatus, postType, postBody, postAllow, postHandler
    If Err.Number <> 0 Then
        postDetail = Err.Description
        Err.Clear
    ElseIf postHandler <> "SelfTest.RunSelfTest" Then
        postDetail = "Expected SelfTest.RunSelfTest handler, got [" & postHandler & "]"
    ElseIf postStatus <> "" Then
        postDetail = "Expected empty status for matched route, got [" & postStatus & "]"
    Else
        postOk = True
    End If
    On Error Goto 0
    checks = AppendCheck(checks, "post_self_test_route", postOk, postDetail)
    allPass = allPass And postOk

    Dim ctxDelete, delStatus, delType, delBody, delAllow, delHandler, delOk, delDetail
    delOk = False
    delDetail = ""
    On Error Resume Next
    Set ctxDelete = CreateObject("WscMvc.RequestContext")
    ctxDelete.Initialize "/self-test", "DELETE", logDir
    delStatus = "" : delType = "" : delBody = "" : delAllow = "" : delHandler = ""
    router.Match ctxDelete, "tests", delStatus, delType, delBody, delAllow, delHandler
    If Err.Number <> 0 Then
        delDetail = Err.Description
        Err.Clear
    ElseIf delStatus <> "405 Method Not Allowed" Then
        delDetail = "Expected 405 Method Not Allowed, got [" & delStatus & "]"
    ElseIf delAllow <> "GET, POST" Then
        delDetail = "Expected Allow [GET, POST], got [" & delAllow & "]"
    Else
        delOk = True
    End If
    On Error Goto 0
    checks = AppendCheck(checks, "delete_self_test_allow_header", delOk, delDetail)
    allPass = allPass And delOk

    ' --- Database connectivity under the real IIS app-pool identity (M5).
    ' This is the genuinely open question SPEC SS10/SS15's "validate app pool
    ' identity... where applicable" discipline calls for: WSH/direct component
    ' tests only prove the contract under the interactive dev account. SQL
    ' auth over TCP (not LocalDB's Windows-integrated named pipes) doesn't
    ' depend on the caller's OS identity, but this is still verified for real
    ' here rather than assumed, exactly because this route runs inside the
    ' real worker process under ApplicationPoolIdentity - see
    ' docs/DECISIONS.md for the LocalDB attempt that failed this exact check.
    ' NOTE: this probes ADODB.Connection directly, bypassing WscMvc.Database,
    ' solely to see the real underlying driver error - Database.Open
    ' deliberately discards Err.Description (SPEC SS10: never leak connection
    ' strings/internals to a client), which is correct for the production
    ' error boundary but useless for diagnosing *why* connectivity fails.
    ' SelfTestController is the one place intentionally exempted from that
    ' rule (see file header comment).
    Dim rawConn, dbOk, dbDetail, dbRs, dbSkipped
    dbOk = False
    dbDetail = ""
    dbSkipped = False

    If Len(Trim(dbConnectionString)) = 0 Then
        ' No db.connectionstring provisioned on this deployment - an
        ' environment-provisioning fact, not a framework defect, so this
        ' reports as passing-but-skipped rather than dragging down "ok"
        ' (same NOT-RUN-not-FAIL discipline as tests/Test-Components.vbs).
        dbSkipped = True
        dbOk = True
        dbDetail = "skipped: db.connectionstring not provisioned on this deployment"
    End If

    If Not dbSkipped Then
        On Error Resume Next
        Set rawConn = CreateObject("ADODB.Connection")
        If Err.Number <> 0 Then
            dbDetail = "CreateObject: " & Err.Description
            Err.Clear
        End If
        On Error Goto 0
    End If

    If Len(dbDetail) = 0 Then
        On Error Resume Next
        rawConn.Open dbConnectionString
        If Err.Number <> 0 Then
            dbDetail = "Open: " & Err.Number & " - " & Err.Description
            Err.Clear
        End If
        On Error Goto 0
    End If

    If Len(dbDetail) = 0 Then
        On Error Resume Next
        Set dbRs = rawConn.Execute("SELECT 1")
        If Err.Number <> 0 Then
            dbDetail = "Execute: " & Err.Number & " - " & Err.Description
            Err.Clear
        Else
            dbOk = True
            dbRs.Close
        End If
        On Error Goto 0
    End If

    On Error Resume Next
    If Not rawConn Is Nothing Then rawConn.Close
    Err.Clear
    On Error Goto 0

    checks = AppendCheck(checks, "database_connectivity_under_app_pool_identity", dbOk, dbDetail)
    allPass = allPass And dbOk
    Set rawConn = Nothing

    Set ctx1 = Nothing
    Set ctx2 = Nothing
    Set ctxUnknown = Nothing
    Set ctxPost = Nothing
    Set ctxDelete = Nothing
    Set router = Nothing
    Set app = Nothing

    body = "{""ok"":" & LCase(CStr(allPass)) & ",""checks"":[" & checks & "]}"
End Sub

Function AppendCheck(checksSoFar, name, pass, detail)
    Dim entry
    entry = "{""name"":""" & JsonEscape(name) & """,""pass"":" & LCase(CStr(pass)) & _
        ",""detail"":""" & JsonEscape(detail) & """}"
    If Len(checksSoFar) = 0 Then
        AppendCheck = entry
    Else
        AppendCheck = checksSoFar & "," & entry
    End If
End Function

Function JsonEscape(s)
    Dim result
    result = s
    result = Replace(result, "\", "\\")
    result = Replace(result, """", "\""")
    result = Replace(result, vbCrLf, "\n")
    result = Replace(result, vbCr, "\n")
    result = Replace(result, vbLf, "\n")
    result = Replace(result, vbTab, "\t")
    JsonEscape = result
End Function
]]>
</script>
</component>