Commit 9b0200a8 authored by Johannes Metscher's avatar Johannes Metscher

Sample client vbscript (first version)

parent 9cd08f31
<%@ Language=VBScript %>
'//////////////////// HELPER FUNCTIONS ////////////////////
'Function is needed for HTTP Authentication
Function Base64Encode(sText)
Dim oXML, oNode
Set oXML = CreateObject("Msxml2.DOMDocument.3.0")
Set oNode = oXML.CreateElement("base64")
oNode.dataType = "bin.base64"
oNode.nodeTypedValue =Stream_StringToBinary(sText)
Base64Encode = oNode.text
Set oNode = Nothing
Set oXML = Nothing
End Function
'Stream_StringToBinary Function
'2003 Antonin Foller,
'Text - string parameter To convert To binary data
Function Stream_StringToBinary(Text)
Const adTypeText = 2
Const adTypeBinary = 1
'Create Stream object
Dim BinaryStream
Set BinaryStream = CreateObject("ADODB.Stream")
BinaryStream.Type = adTypeText
BinaryStream.CharSet = "us-ascii"
BinaryStream.WriteText Text
BinaryStream.Position = 0
BinaryStream.Type = adTypeBinary
BinaryStream.Position = 0
Stream_StringToBinary = BinaryStream.Read
Set BinaryStream = Nothing
End Function
'Create Unix Timestamp - Calculate seconds since 01-01-1970
Function UnixDate(oldDate)
UnixDate = DateDiff("s", "01/01/1970 00:00:00", oldDate)
End Function
'Process host because of encoding of id in url
'first split it, then encode the relevant string, then create string again with encoded id
'You can't URLencode the whole string
Function EncodeHost(sHost)
Dim sHostEncoded, hostArr, numberHostArr
If (InStr(sHost, "load") > 1) Or (InStr(sHost, "download") > 1) Then
sHostEncoded = ""
hostArr = Split(sHost, "/")
numberHostArr = UBound(hostArr)
hostArr(numberHostArr) = Server.URLEncode(hostArr(numberHostArr))
For Each x In hostArr
sHostEncoded = sHostEncoded & x & "/"
sHostEncoded = host
End If
EncodeHost = sHostEncoded
End Function
Const adTypeBinary = 1
Const adTypeText = 2
' accept a string and convert it to Bytes array in the selected Charset
Function StringToBytes(Str,Charset)
Dim Stream : Set Stream = Server.CreateObject("ADODB.Stream")
Stream.Type = adTypeText
Stream.Charset = Charset
Stream.WriteText Str
Stream.Position = 0
' rewind stream and read Bytes
Stream.Type = adTypeBinary
StringToBytes= Stream.Read
Set Stream = Nothing
End Function
' accept Bytes array and convert it to a string using the selected charset
Function BytesToString(Bytes, Charset)
Dim Stream : Set Stream = Server.CreateObject("ADODB.Stream")
Stream.Charset = Charset
Stream.Type = adTypeBinary
Stream.Write Bytes
Stream.Position = 0
' rewind stream and read text
Stream.Type = adTypeText
BytesToString= Stream.ReadText
Set Stream = Nothing
End Function
' This will alter charset of a string from 1-byte charset(as windows-1252)
' to another 1-byte charset(as windows-1251)
Function AlterCharset(Str, FromCharset, ToCharset)
Dim Bytes
Bytes = StringToBytes(Str, FromCharset)
AlterCharset = BytesToString(Bytes, ToCharset)
End Function
'//////////////////// Request FORM ////////////////////
'Start Error output - for debugging
'On Error Resume Next
'Set correct encoding for output & input
Response.Charset = "utf-8"
Response.CodePage = 65001
Session.CodePage = 65001
'Set global variables
Dim host, hostEncoded, username, password
Dim body, header, errors
'data equals data-form-input
Dim data, dataEncoded
Dim HttpReq, query
Dim newLicenseData
Dim authKey
'Create a dictionary for data
Set newLicenseData = Server.CreateObject("Scripting.Dictionary")
Set HttpReq = Server.CreateObject("MSXML2.ServerXMLHTTP")
'Set standard host & user credentials
host = ""
username = "test"
password = "test"
host = ""
username = "DHBAPIUser"
password = "password"
'Read Form data
query = Request.Form("data")
If query<>"" Then
'When query is available prepare for request sending
Dim d, ps
'Split query
d = Split(query, vbCrLf)
'Iterate through variable d - data
'Read from data text input field and save it in newLicenseData to send it in request
For Each e In d
ps = Split(e, "=>")
If UBound(ps) = 1 Then
If ps(0)<>"" Then
newLicenseData.add Trim(ps(0)), Trim(ps(1))
End If
End If
'Stick the parameter together in to one Dictionary
newLicenseData.add "postal", "42431"
newLicenseData.add "organisation_id", ""
newLicenseData.add "mail", ""
newLicenseData.add "training_course_id", ""
newLicenseData.add "firstname", "demo"
newLicenseData.add "lastname", "user"
newLicenseData.add "birthdate", UnixDate(DateAdd("y", -35, Now())) ' Unix timestamp
newLicenseData.add "gender", "w"
newLicenseData.add "street", "123 Fakestreet"
newLicenseData.add "city", "Augsburg"
newLicenseData.add "valid_until", UnixDate(DateAdd("y", +5, Now()))
newLicenseData.add "issue_date", UnixDate(Now())
newLicenseData.add "issue_place", ""
newLicenseData.add "honor_code", 1
newLicenseData.add "honor_code_date", UnixDate(DateAdd("y", -2, Now()))
newLicenseData.add "first_aid", 0
newLicenseData.add "first_aid_date", ""
End If
'Create key=>val schema for textfield
Dim tmpKeys
For Each tmpKeys In newLicenseData.Keys
data = data & tmpKeys & "=>" & newLicenseData(tmpKeys) & vbCrLf
'If query is available, get user credentials from form
If query <> "" Then
host = Request.Form("host")
username = Request.Form("username")
password = Request.Form("password")
hostEncoded = EncodeHost( host )
'Manually create Basic HTTP Authentication key through Base64 Function
authKey = Base64Encode(username & ":" & password)
'Open HTTP request to set all headers, etc. and then send it "POST", hostEncoded, False
'Set all HTTP Headers - except for download
HttpReq.setRequestHeader "Accept", "application/json"
HttpReq.setRequestHeader "Authorization", "Basic " & authKey
'Set to taste in ms
HttpReq.setTimeouts 10 * 1000, 10 * 1000, 10 * 1000, 30 * 1000
'Iterate through to every key-value to encode variables for post
tmpKeys = Null
For Each tmpKeys In newLicenseData.Keys
dataEncoded = dataEncoded & tmpKeys & "=" & newLicenseData(tmpKeys) & "&"
'Send request to server
'Set Responses in variables to display in HTML
header = HttpReq.status & "&nbsp;" & HttpReq.statusText & "<br>" & HttpReq.getAllResponseHeaders
body = HttpReq.responseText
errors = err.Description
'Set Response Header for correct encoding of displaying data in HTML
Response.AddHeader "Content-Type", "text/html;charset=utf-8"
'Outlier if download is asked for
If InStr(host, "download") Then
Response.Buffer = False
'Set filetype to pdf
'Response.ContentType = "application/pdf"
'Response.Charset = "UTF-8"
'Response.AddHeader "Content-Transfer-Encoding", "binary"
Response.AddHeader "Pragma", "no-cache"
Response.AddHeader "Expires", "0"
'Set filename of downloaded attachment
Response.AddHeader "Content-Disposition", "attachment; filename=Lizenz.pdf"
dim convertedBody
convertedBody = AlterCharset(body, "UTF-8" ,"ISO-8859-1")
Response.BinaryWrite convertedBody
End If
'If is no response yet, show some standard text
header = "no response sent yet"
body = "no response sent yet"
errors = "no response sent yet"
End If
<!DOCTYPE html>
<title>LiMS ASP Classic</title>
<meta http-equiv="Content-Type" content="text/html; charset=UTF-8" >
input[type="text"], textarea { width: 500px; }
label { display: block; }
<form method="POST" accept-charset="UTF-8">
<h1>Request form</h1>
<label for="host">Host and service</label>
<input type='text' name="host" value="<% response.write(host) %>"/>
<label for="username">Username</label>
<input type='text' name="username" value="<% response.write(username) %>"/>
<label for="password">Password</label>
<input type='password' name="password" value="<% response.write(password) %>"/>
<label for="data">Data</label>
<textarea type='text' name="data" rows="20"><% response.write(data) %></textarea>
<input type="submit" value="send request"/>
<h1>Reponse header</h1>
<pre><% response.write header %></pre>
<h1>Reponse body</h1>
<pre><% response.write body %></pre>
<h1>ASP errors</h1>
<pre><% response.write err %></pre>
<h1>Encoding infos</h1>
<pre>Charset: <% response.write Response.Charset %></pre>
<pre>CodePage: <% response.write Response.CodePage %></pre>
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment