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="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, 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

    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>