A funny observation related to the connection object

English
,
#1

Just for fun, I tried to connect to a server using a raw TCP socket connection.
While creating the socket I include tls handshaking into the tuning (at least that’s what I thought). But when testing and trying fine-tune to make it working I found that this might be too hard nut to bite just using pure Basic. Okay, things like SSL/TLS are not particularly easy to understand and especially to implement. Anyhow I couldn’t make it work. When I send a GET request the CloudFront responses:

HTTP/1.1 400 Bad Request
Server: CloudFront
Date: Mon, 05 May 2025 17:35:03 GMT
Content-Type: text/html
Content-Length: 915
Connection: close
X-Cache: Error from cloudfront
Via: 1.1 837bfbe95037e42cdc86bcbd263354ea.cloudfront.net (CloudFront)
X-Amz-Cf-Pop: HEL51-P2
X-Amz-Cf-Id: yVqAjzJX7AXHSr0gTvuj_lwzLF7NUOY0jFl-u123Mk4b-xi6m3CKtg==

<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">
<HTML><HEAD><META HTTP-EQUIV="Content-Type" CONTENT="text/html; charset=iso-8859-1">
<TITLE>ERROR: The request could not be satisfied</TITLE>
</HEAD><BODY>
<H1>400 ERROR</H1>
<H2>The request could not be satisfied.</H2>
<HR noshade size="1px">
Bad request.
We can't connect to the server for this app or website at this time. There might be too much traffic or a configuration error. Try again later, or contact the app or website owner.
<BR clear="all">
If you provide content to customers through CloudFront, you can find steps to troubleshoot and help prevent this error by reviewing the CloudFront documentation.
<BR clear="all">
<HR noshade size="1px">
<PRE>
Generated by cloudfront (CloudFront)
Request ID: yVqAjzJX7AXHSr0gTvuj_lwzLF7NUOY0jFl-u123Mk4b-xi6m3CKtg==
</PRE>
<ADDRESS>
</ADDRESS>
</BODY></HTML>

So I know that at least SSL/TLS handshaking does not work.

Here’s my code:

Sub HttpGet()

    Dim socket As Object
    Dim connection As Object
    Dim server As String
    Dim port As Integer
    Dim request As String
    Dim response As String
    Dim tls()

    server = "www.arvopaperi.fi"
    port = 443
    tls = Array(&H16,&H03,&H03,&H00,&HD5,&H01,&H00,&H00,&HD1,&H03,&H03,&H5B,&H8C,&H5A,&H1E,&H7A,&H2D)
    socket = createUnoService("com.sun.star.connection.Connector")
    connection = socket.connect("socket,host=" & server & ",port=" & port, tls)
    Erase tls
	
    request = "GET /api/pages/stocklist/XHEL HTTP/1.1" & chr(10)
    request = request & "Host: www.arvopaperi.fi" & chr(10)
    request = request & "Accept: application/json" & chr(10)
    request = request & "Accept-Encoding: *" & chr(10)
    request = request & "User-Agent: Mozilla/5.0 AppleWebKit/537.36 Chrome/83.0.4103.116" & chr(10)
    request = request & "Connection: keep-alive" & chr(10)
    request = request & "Keep-Alive: timeout=5, max=100" & chr(10)
    request = request & "Connection: close"

    Dim requestBytes() As Byte
    requestBytes = StrConv(request, vbUnicode)
    connection.Write(requestBytes)
    connection.flush()
    Erase requestBytes

    Dim responseBytes() As String
    Dim size As Long
    size = 50000
    connection.Read(responseBytes, size)	
    connection.Close()
	
    Dim i& :For i = 0 To Ubound(responseBytes)
        response = response & chr(responseBytes(i))
        If responseBytes(i) = 0 Then Exit For
    Next i
	
    MsgBox response
    Erase response : rsponse = ""
    connection =  Nothing
    socket = Nothing
	
End Sub

Then I recalled an earlier tuning based on old VBA-tuning that I made a long ago. In the original I used MSXML2.serverXMLHTTP.6.0 object for HTTP request. But I wanted to implement it with LO Basic without any external stuff. I succeed and it was so simple that I couldn’t almost understand how easy it actually was.

Here’s the code that I used to retrieve a json string from the server containing the Helsinki Stock Exchange stock list

    Dim URL As String
    URL = "https://www.arvopaperi.fi/api/pages/stocklist/XHEL"
    Dim response As String
    ReDim StrArray() As String
    
    GlobalScope.BasicLibraries.LoadLibrary("ScriptForge")
    Set FSO = CreateScriptService("FileSystem")
   	Dim inputFile As Object        
	Set inputFile = FSO.OpenTextFile(URL)
	response = inputFile.ReadAll()
	inputFile.CloseFile()
	Set FSO = Nothing

Trying to get that json string using socket is really hard because of any kind of security layers, and the simplest macro you can imagine shows the middle finger to all that’s related to the security of HTTP communication. Think about that! :woozy_face:

#2

Further studies to get HTTP POST request working with LO Basic macros.
Result:

Sub GetJavaToUseInBasic

	Dim Java2Basic As Object
	Java2Basic = getProcessServiceManager().createInstance("com.sun.star.loader.Java2", "file:///C:/Program Files/LibreOffice/program/classes/java_websocket.jar")
	MsgBox "Typename: " & TypeName(Java2Basic) & " - IsEmpty: " & IsEmpty(Java2Basic) 'Returns "Typename: Java - IsEmpty: False"
	'According to Documentation:
	'Included Services - Summary: allows to access a java component stored with a .jar file
	'Conclusion: The above promised is pure BS!
	Java2Basic = Nothing
	
End Sub
#3

Here’s another way to get json over the internet:
HelsinkiGetStocks.ods (17.0 KB)

#4

WEBSERVICE

#5

could add an entry in Macros/General - The Document Foundation Wiki
and/or here https://dev.blog.documentfoundation.org/ :pray:

#6

This works:

Sub Main

	Dim svc As Object, Lipsum As String
	svc = createUnoService( "com.sun.star.sheet.FunctionAccess" ) 
	' use %3F (url escape character for question mark)
	XML_String = svc.callFunction("WEBSERVICE",array("http://www.lipsum.com/feed/xml%3Famount=2&what=paras&start=Yes"))
	Lipsum = svc.callFunction("FILTERXML", array(XML_String, "/feed/lipsum" ))
	Print Lipsum
	
	'To show XML data
	'Print XML_String
	
End Sub
#7

A solution found:
Sending HTTP POST request using pure Basic without any external tool like curl or any ComObjects (CreateObject method)

REM  *****  BASIC  *****
Option VBASupport 1

Dim POST_URL  As String 
Dim POST_BODY As String

Dim gResponseStream As Object
Dim gCommandListener As Object
Dim gResponseListener As Object
Dim gInteractionListener As Object
Dim gProgressListener As Object
Dim basePath As String
Dim xmlData As String

Private InitDone  As Boolean
Private Map1(0 To 63)  As Byte
Private Map2(0 To 127) As Byte

Sub Main
	
	basePath = ConvertFromUrl(Left(thisComponent.URL, InStrRev(thisComponent.URL, "/")))
	Open basePath & "ToServer.xml" For Input As #1
    POST_BODY  = Input$(LOF(1) ,1) : CLose #1
	POST_URL = "https://extservicestest.matkahuolto.fi/mpaketti/mhshipmentxml"
	On local ERR GoTo Err
	
	gCommandListener = CreateUnoListener("XCommandEnv_", "com.sun.star.ucb.XWebDAVCommandEnvironment")
	gResponseListener = CreateUnoListener("XActiveDataSink_", "com.sun.star.io.XActiveDataSink")
	gInteractionListener = CreateUnoListener("XInteractionHandle_", "com.sun.star.task.XInteractionHandler")
	gProgressListener = CreateUnoListener("XProgressHandle_", "com.sun.star.ucb.XProgressHandler")
	broker = createUnoService("com.sun.star.ucb.UniversalContentBroker")
	contentID = broker.createContentIdentifier(POST_URL)
	ucbContent = broker.queryContent(contentID)
	postStream  = CreateUnoService("com.sun.star.io.Pipe")
	textOutputStream  = CreateUnoService("com.sun.star.io.TextOutputStream")
	textOutputStream.setOutputStream(postStream)
	textOutputStream.writeString(POST_BODY)
	textOutputStream.closeOutput()
	
	DIM postCommand as new com.sun.star.ucb.Command 
	postCommand.Name     = "post"
	postCommand.Handle   = -1

	postArgs  = CreateUnoStruct("com.sun.star.ucb.PostCommandArgument2")
	postArgs.Source = postStream
	postArgs.Sink = gResponseListener 
	postArgs.MediaType = "application/xml"
	postArgs.Referer = ""
	postCommand.Argument = postArgs
	
	ucbContent.execute(postCommand, 0, gCommandListener)
	
	responseStream = gResponseListener.getInputStream()
	textStream = CreateUnoService("com.sun.star.io.TextInputStream")
	textStream.setInputStream (responseStream)
	textStream.setEncoding ("UTF8")
	Dim delimiters() as String, response As String
	xmlData = textStream.readString(delimiters, False)
	textStream.closeInput()
	ucbContent = Nothing
	postStream = Nothing
	textOutputStream = Nothing
	
	SaveToPdf
	
	Exit Sub
	
Err: MsgBox("UCB error")

End Sub

Function XActiveDataSink_setInputStream(inputStream As Variant)
	gResponseStream = inputStream
End Function

Function XActiveDataSink_getInputStream() As Variant
	XActiveDataSink_getInputStream = gResponseStream
End Function

Function XCommandEnv_getUserRequestHeaders(uri as String, method as Variant)

	Dim headers(1) As New com.sun.star.beans.StringPair
	headers(0).First = "Accept-Language"
	headers(0).Second = "*"
	headers(1).First = "Cookie"
	headers(1).Second = "XDEBUG_SESSION=netbeans-xdebug"
	XCommandEnv_getUserRequestHeaders = headers
	
End Function

Function XCommandEnv_getInteractionHandler()
	MsgBox("XCommandEnv_getInteractionHandler")
	XCommandEnv_getInteractionHandler = gInteractionListener
End Function

Sub XInteractionHandle_handle(request as Object)
	MsgBox("XInteractionHandle_handle")
End sub

Sub XProgressHandle_push (status as Variant) : MsgBox("XProgressHandle_push") : End Sub
Sub XProgressHandle_update(status as Variant) : MsgBox("XProgressHandle_update") : End Sub
Sub XProgressHandle_pop() : MsgBox("XProgressHandle_pop") : End Sub

Sub SaveToPdf

	Dim slen As Long, elen As Long, mlen As Long
	
	Select Case InStr(xmlData, "<ErrorNbr>")
		Case 0
			slen = InStr(xmlData, "<ShipmentPdf>") + Len( "<ShipmentPdf>")
			elen  = InStr(xmlData, "</ShipmentPdf>")
			mlen = elen - slen
			base64Str = Mid(xmlData, slen, mlen)
			Dim pdfData() As Byte
			pdfData = Base64Decode(base64Str)
			base64Str = ""
			Dim pdfName As String
			slen = InStr(xmlData, "<PdfName>") + Len("<PdfName>")
			elen  = InStr(xmlData, "</PdfName>")
			mlen = elen - slen
			pdfName = Mid(xmlData, slen, mlen)
			If Dir(basePath & pdfName) Then Kill basePath & pdfName
			Open basePath & pdfName For Binary As #1
			Put #1, , pdfData : Close #1
			Erase pdfData : response = ""
		Case Else
			
	End Select
	
End Sub

Function Base64Decode(ByVal s As String) As Variant
    
    If Not InitDone Then Init
    Dim IBuf() As Byte: IBuf = ConvertStringToBytes(s)
    Dim ILen As Long: ILen = UBound(IBuf) + 1
    If ILen Mod 4 <> 0 Then MsgBox "ERROR: The Base64 encoded input string is not divisible by 4."
    Do While ILen > 0
        If IBuf(ILen - 1) <> Asc("=") Then Exit Do
        ILen = ILen - 1
    Loop
    Dim OLen As Long: OLen = (ILen * 3) \ 4
    Dim Out() As Byte
    ReDim Out(0 To OLen - 1) As Byte
    Dim ip As Long
    Dim op As Long
    Do While ip < ILen
	Dim i0 As Byte: i0 = IBuf(ip): ip = ip + 1
	Dim i1 As Byte: i1 = IBuf(ip): ip = ip + 1
	Dim i2 As Byte: If ip < ILen Then i2 = IBuf(ip): ip = ip + 1 Else i2 = Asc("A")
	Dim i3 As Byte: If ip < ILen Then i3 = IBuf(ip): ip = ip + 1 Else i3 = Asc("A")
	If i0 > 127 Or i1 > 127 Or i2 > 127 Or i3 > 127 Then _
		MsgBox "ERROR: Illegal character in Base64 encoded data."
	Dim b0 As Byte: b0 = Map2(i0)
	Dim b1 As Byte: b1 = Map2(i1)
	Dim b2 As Byte: b2 = Map2(i2)
	Dim b3 As Byte: b3 = Map2(i3)
	If b0 > 63 Or b1 > 63 Or b2 > 63 Or b3 > 63 Then _
             MsgBox "ERROR: Illegal character in Base64 encoded data."
	Dim o0 As Byte: o0 = (b0 * 4) Or (b1 \ &H10)
	Dim o1 As Byte: o1 = ((b1 And &HF) * &H10) Or (b2 \ 4)
	Dim o2 As Byte: o2 = ((b2 And 3) * &H40) Or b3
	Out(op) = o0: op = op + 1
	If op < OLen Then Out(op) = o1: op = op + 1
	If op < OLen Then Out(op) = o2: op = op + 1
	Loop
	Base64Decode = Out

End Function

Private Sub Init()
    
    Dim c As Integer, i As Integer
    i = 0
    For c = Asc("A") To Asc("Z"): Map1(i) = c: i = i + 1: Next
    For c = Asc("a") To Asc("z"): Map1(i) = c: i = i + 1: Next
    For c = Asc("0") To Asc("9"): Map1(i) = c: i = i + 1: Next
    Map1(i) = Asc("+"): i = i + 1
    Map1(i) = Asc("/"): i = i + 1

    For i = 0 To 127: Map2(i) = 255: Next
    For i = 0 To 63: Map2(Map1(i)) = i: Next
    InitDone = True

End Sub

Private Function ConvertStringToBytes(ByVal s As String) As Variant
    
    Dim b1() As Byte: b1 = s
    Dim l As Long: l = (UBound(b1) + 1) \ 2
    If l = 0 Then ConvertStringToBytes = b1: Exit Function
    Dim b2() As Byte
    ReDim b2(0 To l - 1) As Byte
    Dim p As Long
    For p = 0 To l - 1
        Dim c As Long: c = b1(2 * p) + 256 * CLng(b1(2 * p + 1))
        If c >= 256 Then c = Asc("?")
        b2(p) = c
	Next
	
    ConvertStringToBytes = b2
    
End Function

The original code for HTTP POST request can be found here.

This demo app sends HTTP POST request with a body (payload) to Oy Matkahuolto Ab test service and the server responses with xml data of which one of nodes contains a Base64 encoded string from which the app decodes a byte array an saves it to a .pdf file (resulting printable parcel label).
HttpPostWorking.odt (20.0 KB)

If interested to test my tuning you need to download test xml data (request payload) containing test user privileges.

1 Like
#8

… interesting code!

You can simplify it a bit by replacing

Dim gResponseStream As Object
...
gResponseListener = CreateUnoListener("XActiveDataSink_", "com.sun.star.io.XActiveDataSink")
...
Function XActiveDataSink_setInputStream(inputStream As Variant)
	gResponseStream = inputStream
End Function

Function XActiveDataSink_getInputStream() As Variant
	XActiveDataSink_getInputStream = gResponseStream
End Function`

with

gResponseListener =  CreateUnoService("com.sun.star.io.Pump")
1 Like
#9

I appreciate this… Simplifying code is always a good thing… as long as everything works… :grinning:

#10

Here’s the final tune-up coded in pure Basic without VBA-Support.
HttpPostRequestInPureBasic.odt (20.1 KB)

Open this in your browser and Save As XmlToServer.xml

EDIT:
Here’s another tuning I’ve been working on. I wanted to load XML data from HTTP response into an XMLDomDocument object without cycling the data through a temporary file using pure Basic without VBA support.
XmlDomDocumentFromString.odt (17.3 KB)

#11

Or more compactly:

Sub LoadXmlFromURI
    Dim oDom As Object
    oDom=CreateUnoService("com.sun.star.xml.dom.DocumentBuilder").parseURI("http://www.lipsum.com/feed/xml")
    ' ---
End Sub
#12

Thanks, it works like a charm. But unfortunately, it cannot be combined with my previous HTTP POST request example.

Impressum (Legal Info) | Datenschutzerklärung (Privacy Policy)   Content on this site is licensed under a Creative Commons Attribution Share Alike 3.0 license.