' Mursketori API - Visual Basic 6 module: Laboratory
'
' Full laboratory operations:
'   - List all assigned piles (optionally filtered by quarry)
'   - Mark a pile as KL-tested with expiry date
'   - Clear a test mark
'   - Upload a lab report PDF
'   - Upload a CE certificate PDF
'   - Delete a lab report
'   - Delete a CE certificate
'
' Setup:
'   1. Project > Add Module > Existing, select this file.
'   2. Project > References, tick:
'      - Microsoft WinHTTP Services, version 5.1  (winhttp.dll)
'        This one reference is enough for both JSON calls and file uploads.
'   3. Set LAB_API_KEY below to your laboratory API key from siteadmin.
'

Option Explicit

' =============================================================================
' Configuration
' =============================================================================

Public Const V1_API_BASE  As String = "https://mursketori.com/API/v1"
Public Const LAB_API_BASE As String = "https://mursketori.com/API/v1/lab"
Public Const LAB_API_KEY  As String = "mrsk_your_lab_key_here"

' =============================================================================
' Core JSON request
' =============================================================================

' method : "GET", "POST", "DELETE"
' path   : e.g. "/piles.php" or "/mark_tested.php"
' body   : JSON string; omit for GET
'
Public Function LabRequest(ByVal method As String, _
                            ByVal path   As String, _
                            Optional ByVal body As String = "") As String
    Dim http As Object
    Set http = CreateObject("WinHttp.WinHttpRequest.5.1")
    http.Open method, LAB_API_BASE & path, False
    http.SetRequestHeader "Authorization", "Bearer " & LAB_API_KEY
    http.SetRequestHeader "Accept", "application/json"
    If Len(body) > 0 Then
        http.SetRequestHeader "Content-Type", "application/json"
        http.Send body
    Else
        http.Send
    End If
    LabRequest = http.ResponseText
    Set http = Nothing
End Function

' --- Generic v1 request (used for /quarries.php etc.) -------------------------
'
Public Function V1ApiRequest(ByVal method As String, _
                             ByVal path   As String, _
                             Optional ByVal body As String = "") As String
    Dim http As Object
    Set http = CreateObject("WinHttp.WinHttpRequest.5.1")
    http.Open method, V1_API_BASE & path, False
    http.SetRequestHeader "Authorization", "Bearer " & LAB_API_KEY
    http.SetRequestHeader "Accept", "application/json"
    If Len(body) > 0 Then
        http.SetRequestHeader "Content-Type", "application/json"
        http.Send body
    Else
        http.Send
    End If
    V1ApiRequest = http.ResponseText
    Set http = Nothing
End Function

' =============================================================================
' JSON helper  (simple key/value extractor)
' =============================================================================

Public Function JsonValue(ByVal json As String, ByVal key As String) As String
    Dim search  As String
    Dim pos     As Long
    Dim rest    As String
    Dim endPos  As Long
    Dim endPos2 As Long

    search = Chr(34) & key & Chr(34) & ":"
    pos = InStr(json, search)
    If pos = 0 Then Exit Function

    rest = LTrim(Mid(json, pos + Len(search)))

    If Left(rest, 1) = Chr(34) Then
        rest   = Mid(rest, 2)
        endPos = InStr(rest, Chr(34))
        If endPos > 0 Then JsonValue = Left(rest, endPos - 1)
    Else
        endPos  = InStr(rest, ",")
        endPos2 = InStr(rest, "}")
        If endPos2 > 0 And (endPos2 < endPos Or endPos = 0) Then endPos = endPos2
        If endPos > 0 Then
            JsonValue = Trim(Left(rest, endPos - 1))
        Else
            JsonValue = Trim(rest)
        End If
    End If
End Function

' =============================================================================
' LIST PILES
' =============================================================================

' --- All piles assigned to this laboratory -----------------------------------
' Returns raw JSON string.
'
Public Function ListPiles() As String
    ListPiles = LabRequest("GET", "/piles.php")
End Function

' --- Piles filtered by quarry ------------------------------------------------
' Returns raw JSON string containing only piles from the given quarry.
'
Public Function ListPilesByQuarry(ByVal quarryId As Long) As String
    ListPilesByQuarry = LabRequest("GET", "/piles.php?quarry_id=" & quarryId)
End Function

' =============================================================================
' MARK TESTED / CLEAR TEST MARK
' =============================================================================

' --- Mark a pile as KL-tested ------------------------------------------------
' validUntil: date string "YYYY-MM-DD", e.g. "2027-06-30"
' Returns True on success.
'
Public Function MarkTested(ByVal pileId     As Long, _
                            ByVal validUntil As String) As Boolean
    Dim body As String
    body = "{" & _
           """pile_id"":"     & pileId     & "," & _
           """tested"":true," & _
           """valid_until"":""" & validUntil & """" & _
           "}"
    Dim resp As String
    resp = LabRequest("POST", "/mark_tested.php", body)
    MarkTested = (InStr(resp, """updated"":true") > 0)
    If Not MarkTested Then
        MsgBox "MarkTested error: " & JsonValue(resp, "error"), vbCritical
    End If
End Function

' --- Clear test mark ---------------------------------------------------------
' Returns True on success.
'
Public Function ClearTested(ByVal pileId As Long) As Boolean
    Dim body As String
    body = "{""pile_id"":" & pileId & ",""tested"":false}"
    Dim resp As String
    resp = LabRequest("POST", "/mark_tested.php", body)
    ClearTested = (InStr(resp, """updated"":true") > 0)
    If Not ClearTested Then
        MsgBox "ClearTested error: " & JsonValue(resp, "error"), vbCritical
    End If
End Function

' =============================================================================
' UPLOAD DOCUMENT  (PDF file via multipart/form-data)
' =============================================================================
'
' docType  : "lab_report"  or  "ce_certificate"
' filePath : full local path, e.g. "C:\Reports\report.pdf"
'
' Requires: ADODB.Stream        -- NO reference needed, used via CreateObject (late binding, available on all Windows XP+)
'           WinHttp.WinHttpRequest.5.1 -- same object used for JSON calls; only one reference needed.
'
' Each successful upload costs 1 credit from the laboratory account.
' Returns True on success.
'
Public Function UploadDocument(ByVal pileId   As Long, _
                                ByVal docType  As String, _
                                ByVal filePath As String) As Boolean
    On Error GoTo UploadErr

    ' --- 1. Read PDF file into a byte array --------------------------------------
    Dim fNum    As Integer
    Dim fBytes() As Byte
    fNum = FreeFile
    Open filePath For Binary Access Read As #fNum
    If LOF(fNum) = 0 Then
        Close #fNum
        MsgBox "UploadDocument error: file is empty or not found.", vbCritical
        UploadDocument = False
        Exit Function
    End If
    ReDim fBytes(LOF(fNum) - 1)
    Get #fNum, , fBytes
    Close #fNum

    ' --- 2. Build multipart body entirely in binary mode -------------------------
    ' ADODB.Stream does not allow switching Type after text has been written.
    ' We therefore keep Type=1 (binary) for the whole stream and append the
    ' text parts as ANSI byte arrays with StrConv(..., vbFromUnicode).

    Dim boundary As String
    boundary = "----MursketoriBoundary7MA4YWxkTrZu0gW"

    Dim CRLF As String
    CRLF = vbCrLf

    Dim fileName As String
    fileName = Mid(filePath, InStrRev(filePath, "\") + 1)

    Dim st As Object
    Set st = CreateObject("ADODB.Stream")
    st.Type = 1          ' adTypeBinary
    st.Open

    ' Helper for text-to-bytes.  StrConv returns a Variant; ADODB.Stream.Write
    ' is safer when given an explicitly typed Byte() variable.
    Dim txtBytes() As Byte

    ' Text part 1: pile_id
    txtBytes = StrConv("--" & boundary & CRLF & _
                       "Content-Disposition: form-data; name=""pile_id""" & CRLF & CRLF & _
                       CStr(pileId) & CRLF, vbFromUnicode)
    st.Write txtBytes

    ' Text part 2: doc_type
    txtBytes = StrConv("--" & boundary & CRLF & _
                       "Content-Disposition: form-data; name=""doc_type""" & CRLF & CRLF & _
                       docType & CRLF, vbFromUnicode)
    st.Write txtBytes

    ' Text part 3: file header
    txtBytes = StrConv("--" & boundary & CRLF & _
                       "Content-Disposition: form-data; name=""file""; filename=""" & _
                       fileName & """" & CRLF & _
                       "Content-Type: application/pdf" & CRLF & CRLF, vbFromUnicode)
    st.Write txtBytes

    ' Binary file body
    st.Write fBytes

    ' Closing boundary
    txtBytes = StrConv(CRLF & "--" & boundary & "--" & CRLF, vbFromUnicode)
    st.Write txtBytes

    ' Read complete body into byte array
    st.Position = 0
    Dim bodyBytes() As Byte
    bodyBytes = st.Read
    st.Close
    Set st = Nothing

    ' --- 3. Send with WinHTTP ----------------------------------------------------
    ' WinHttpRequest accepts a byte array in Send() much more reliably than
    ' MSXML2.ServerXMLHTTP, which is why we use it here as well.
    Dim http As Object
    Set http = CreateObject("WinHttp.WinHttpRequest.5.1")
    http.Open "POST", LAB_API_BASE & "/documents.php", False
    http.SetRequestHeader "Authorization", "Bearer " & LAB_API_KEY
    http.SetRequestHeader "Content-Type", "multipart/form-data; boundary=" & boundary
    http.SetRequestHeader "Accept", "application/json"
    http.Send bodyBytes

    Dim resp As String
    resp = http.ResponseText
    Set http = Nothing

    UploadDocument = (InStr(resp, """uploaded"":true") > 0)
    If Not UploadDocument Then
        MsgBox "UploadDocument error: " & JsonValue(resp, "error"), vbCritical
    End If
    Exit Function

UploadErr:
    MsgBox "UploadDocument runtime error " & Err.Number & ": " & Err.Description, vbCritical
    On Error Resume Next
    If Not st Is Nothing Then st.Close
    Set st = Nothing
    UploadDocument = False
End Function

' =============================================================================
' DELETE DOCUMENT
' =============================================================================

' --- Delete lab report -------------------------------------------------------
' Returns True if deleted, False if not found or error.
'
Public Function DeleteLabReport(ByVal pileId As Long) As Boolean
    Dim body As String
    body = "{""pile_id"":" & pileId & ",""doc_type"":""lab_report""}"
    Dim resp As String
    resp = LabRequest("DELETE", "/documents.php", body)
    DeleteLabReport = (InStr(resp, """deleted"":true") > 0)
End Function

' --- Delete CE certificate ---------------------------------------------------
' Returns True if deleted, False if not found or error.
'
Public Function DeleteCECertificate(ByVal pileId As Long) As Boolean
    Dim body As String
    body = "{""pile_id"":" & pileId & ",""doc_type"":""ce_certificate""}"
    Dim resp As String
    resp = LabRequest("DELETE", "/documents.php", body)
    DeleteCECertificate = (InStr(resp, """deleted"":true") > 0)
End Function

' =============================================================================
' Demo: exercise all functions on the first assigned pile
' =============================================================================

Public Sub RunDemo()
    ' List all piles
    Dim pileJson As String
    pileJson = ListPiles()
    MsgBox "=== Assigned piles (raw JSON) ===" & vbCrLf & Left(pileJson, 500), _
           vbInformation, "Mursketori Lab Demo"

    ' Extract first pile ID from JSON (looks for first "id": N)
    Dim firstId As String
    firstId = JsonValue(pileJson, "id")
    If Len(firstId) = 0 Or Not IsNumeric(firstId) Then
        MsgBox "No piles assigned -- cannot continue demo.", vbExclamation
        Exit Sub
    End If
    Dim pileId As Long
    pileId = CLng(firstId)

    ' Mark tested
    If MarkTested(pileId, "2027-12-31") Then
        MsgBox "Pile #" & pileId & " marked as tested until 2027-12-31.", _
               vbInformation, "Mursketori Lab Demo"
    End If

    ' Clear tested
    If ClearTested(pileId) Then
        MsgBox "Pile #" & pileId & " test mark cleared.", _
               vbInformation, "Mursketori Lab Demo"
    End If

    ' Upload -- point this at a real PDF file to test
    Dim pdfPath As String
    pdfPath = "C:\Temp\sample_report.pdf"
    If Dir(pdfPath) <> "" Then
        If UploadDocument(pileId, "lab_report", pdfPath) Then
            MsgBox "Lab report uploaded for pile #" & pileId, _
                   vbInformation, "Mursketori Lab Demo"
        End If

        ' Delete it again
        If DeleteLabReport(pileId) Then
            MsgBox "Lab report deleted for pile #" & pileId, _
                   vbInformation, "Mursketori Lab Demo"
        End If
    Else
        MsgBox "Upload skipped -- place a PDF at " & pdfPath & " to test.", _
               vbExclamation, "Mursketori Lab Demo"
    End If

    MsgBox "Demo complete.", vbInformation, "Mursketori Lab Demo"
End Sub

' =============================================================================
' LIST QUARRIES
' =============================================================================

' --- All quarries assigned to this laboratory -------------------------------
' Returns raw JSON string.  Lab key: all assigned quarries.
'
Public Function ListQuarries() As String
    ListQuarries = V1ApiRequest("GET", "/quarries.php")
End Function

' --- Quarries of a specific owner assigned to this lab ----------------------
' Returns raw JSON string filtered by ownerid.
'
Public Function ListQuarriesByOwner(ByVal ownerId As Long) As String
    ListQuarriesByOwner = V1ApiRequest("GET", "/quarries.php?ownerid=" & ownerId)
End Function