Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
lims_connect
Project overview
Project overview
Details
Activity
Releases
Repository
Repository
Files
Commits
Branches
Tags
Contributors
Graph
Compare
Issues
0
Issues
0
List
Boards
Labels
Service Desk
Milestones
Merge Requests
0
Merge Requests
0
CI / CD
CI / CD
Pipelines
Jobs
Schedules
Operations
Operations
Incidents
Environments
Analytics
Analytics
CI / CD
Repository
Value Stream
Wiki
Wiki
Members
Members
Collapse sidebar
Close sidebar
Activity
Graph
Create a new issue
Jobs
Commits
Issue Boards
Open sidebar
pub
lims_connect
Commits
9b0200a8
Commit
9b0200a8
authored
Sep 06, 2017
by
Johannes Metscher
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Sample client vbscript (first version)
parent
9cd08f31
Changes
1
Hide whitespace changes
Inline
Side-by-side
Showing
1 changed file
with
295 additions
and
0 deletions
+295
-0
vba_sample_client/default.asp
vba_sample_client/default.asp
+295
-0
No files found.
vba_sample_client/default.asp
0 → 100644
View file @
9b0200a8
<
%@
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
,
http:
//
www.motobit.com
'
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.Open
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
&
"/"
Next
ELSE
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.Open
Stream.WriteText Str
Stream.Flush
Stream.Position = 0
' rewind stream and read Bytes
Stream.Type = adTypeBinary
StringToBytes= Stream.Read
Stream.Close
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.Open
Stream.Write Bytes
Stream.Flush
Stream.Position = 0
' rewind stream and read text
Stream.Type = adTypeText
BytesToString= Stream.ReadText
Stream.Close
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 = "https://bildungsnetz.ghostthinker.de/api/lims/request"
username = "test"
password = "test"
host = "https://bildungsnetz.ghostthinker.de/api/lims/load/DHoB-T-A-0011206"
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
Next
'Stick the parameter together in to one Dictionary
Else
newLicenseData.add "postal", "42431"
newLicenseData.add "organisation_id", ""
newLicenseData.add "mail", "test@example.com"
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
Next
'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
HttpReq.open "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)
&
"
&
"
Next
'Send request to server
HttpReq.send(dataEncoded)
'Set Responses in variables to display in HTML
header = HttpReq.status
&
"
"
&
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
Response.End
End If
'If is no response yet, show some standard text
Else
header = "no response sent yet"
body = "no response sent yet"
errors = "no response sent yet"
End If
%>
<!DOCTYPE html>
<html>
<head>
<title>
LiMS ASP Classic
</title>
<meta
http-equiv=
"Content-Type"
content=
"text/html; charset=UTF-8"
>
<style>
input
[
type
=
"text"
],
textarea
{
width
:
500px
;
}
label
{
display
:
block
;
}
</style>
</head>
<body>
<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>
<br/>
<input
type=
"submit"
value=
"send request"
/>
</form>
<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>
</body>
</html>
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment