diff --git a/.gitignore b/.gitignore
index c98a276..b5cae27 100644
--- a/.gitignore
+++ b/.gitignore
@@ -8,3 +8,9 @@ dcms_db/
env
DCMS.code-workspace
CI/run-tests-in-docker.sh
+packages/*
+!packages/apl-dependencies.txt
+!packages/apl-buildlist.json
+nuget-packages/*
+!nuget-packages/_nuget-packages.csproj
+dcms.dws
diff --git a/APLSource/RefreshData.aplf b/APLSource/RefreshData.aplf
index 487f25a..3e19faa 100644
--- a/APLSource/RefreshData.aplf
+++ b/APLSource/RefreshData.aplf
@@ -1,8 +1,8 @@
r←RefreshData timer
- :Trap 202
+ :Trap 202 404
import.youtube.RefreshData''
:Else
- ⎕←'DATA NOT REFRESHED. Could not access YouTube API.'
+ ⎕←'DATA NOT REFRESHED. ',⎕DMX.Message
:EndTrap
read.BuildCache''
⎕←r←'Refreshed data at ',⍕⎕TS
diff --git a/APLSource/Run.aplf b/APLSource/Run.aplf
index 303be2b..3539a16 100644
--- a/APLSource/Run.aplf
+++ b/APLSource/Run.aplf
@@ -1,19 +1,5 @@
Run debug;app_dir;LoadDependency
- ⎕←'Setting up...'
- ⎕←'Loading dependencies...'
- :If 0=#.⎕NC'Conga'
- 'Conga'#.⎕CY'conga'
- #.DRC←#.Conga.Init''
- :EndIf
- 'GLOBAL'⎕NS''
GLOBAL.debug←debug
- 'SQA'SQL.⎕CY'sqapl'
- #.⎕CY'isolate'
- LoadDependency←{0=##.⎕NC ⍵:⎕SE.Link.Import ##,⍥⊂GetEnv ⍵}
- LoadDependency¨'Jarvis' 'HttpCommand'
- ⎕←'Setting app_dir'
- GLOBAL.app_dir←app_dir←{'/'=⊃⌽⍵:⍵ ⋄ '/',⍨⍵}GetEnv'app_dir'
- Unidecode.MakeCharMap app_dir,'/APLSource/charmap.json'
⍝ Initialise SQL schema
GLOBAL.secrets←ReadJSON GetEnv'SECRETS'
⎕←'Initialising SQAPL...'
diff --git a/APLSource/Setup.aplf b/APLSource/Setup.aplf
new file mode 100644
index 0000000..2dc1eb0
--- /dev/null
+++ b/APLSource/Setup.aplf
@@ -0,0 +1,27 @@
+ Setup
+⍝ Load dependencies into the active workspace
+ ⎕←'Setting up...'
+ :Trap 0
+ 'GLOBAL'⎕NS''
+ GLOBAL.app_dir←app_dir←{'/'=⊃⌽⍵:⍵ ⋄ '/',⍨⍵}GetEnv'APP_DIR'
+ ⎕←'App directory is ',app_dir
+ ⎕←'Loading dependencies...'
+ :If 0=#.⎕NC'Conga'
+ 'Conga'#.⎕CY'conga'
+ #.DRC←#.Conga.Init''
+ ⎕←'Conga initalised'
+ :EndIf
+ 'SQA'SQL.⎕CY'sqapl'
+ ⎕←'SQAPL loaded into SQL.SQA'
+ #.⎕CY'isolate'
+ ⎕←'Isolate loaded into #'
+ Unidecode.MakeCharMap app_dir,'/APLSource/charmap.json'
+ ⎕←'Loading Tatin packages...'
+ ⎕←⍪⎕SE.Tatin.LoadDependencies (GetEnv'PKG') #
+ ⎕←'Loading NuGet packages...'
+ ⎕←⍪⎕USING←##.NuGet.Using GetEnv'PKG_NUGET'
+ :Else
+ ⎕←'Could not set up DCMS'
+ ⎕←1⎕JSON⎕OPT'Compact'0⊢⎕DMX
+ ⎕OFF 1
+ :EndTrap
\ No newline at end of file
diff --git a/APLSource/Version.aplf b/APLSource/Version.aplf
index 0c2e848..a293745 100644
--- a/APLSource/Version.aplf
+++ b/APLSource/Version.aplf
@@ -1,2 +1,2 @@
version←Version
- version←'3.23.0'
+ version←'3.24.0'
diff --git a/APLSource/import/youtube/GetVideos.aplf b/APLSource/import/youtube/GetVideos.aplf
index 127e7f8..9ad18c3 100644
--- a/APLSource/import/youtube/GetVideos.aplf
+++ b/APLSource/import/youtube/GetVideos.aplf
@@ -7,11 +7,12 @@
q,←'&part=snippet'
q,←'&maxResults=100'
r←#.HttpCommand.GetJSON'Get'q
- 0≠r.rc:r.msg ⎕SIGNAL 202
+ 0≠r.rc:⎕SIGNAL⊂('EN'202)('Message' r.msg)('Vendor' (#.DCMS.GetEnv'URL'))
200≠r.HttpStatus:r.HttpMessage ⎕SIGNAL r.HttpStatus
⍝ ←: id youtube_id title description channel_id channel category_id published_at created_at updated_at updated_by
- id←r.Data.items.id
- _←{0=≢⍵:'' ⋄ ('YouTube videos ID= (',⍵,') not available.')⎕SIGNAL 404}1↓∊','∘,¨⍵/⍨~⍵∊id
+ 0=⎕NC'r.Data.items':⎕SIGNAL⊂('EN'404)('Message' 'No items received from YouTube API')('Vendor' (#.DCMS.GetEnv'URL'))
+ id←{0∊⍴⍵:⍬ ⋄ ⍵.id}r.Data.items
+ _←{0=≢⍵:'' ⋄ ⎕SIGNAL⊂('EN'404)('Message' ('YouTube videos ID= (',⍵,') not available.'))('Vendor' (#.DCMS.GetEnv'URL'))}1↓∊','∘,¨⍵/⍨~⍵∊id
res←'maxres' 'medium' 'default' 'high' 'standard'
r.Data.items.thumbnail←res ChooseBestThumbnail r.Data.items
↑r.Data.items.((⊂id),snippet.(title description channelId channelTitle ⍬ publishedAt),⊂thumbnail) ⍝ ⍬ for category_id
diff --git a/APLSource/read/videos/Query.aplf b/APLSource/read/videos/Query.aplf
index 580b5fe..043570b 100644
--- a/APLSource/read/videos/Query.aplf
+++ b/APLSource/read/videos/Query.aplf
@@ -1,4 +1,4 @@
- res←Query req;p;v;Q;CACHE;C;fm;to;ddn;in_range;i;data;pg;ppg;presenter;filter;event;Norm
+ res←Query req;C;CACHE;Norm;Q;Stem;data;ddn;event;filter;fm;i;in_range;p;pg;ppg;presenter;stemmer;terms;to;v
(p v)←↓⍉req.QueryParams ⋄ v←RLTB¨v,⊂'' ⋄ v[⍸'null'∘≡¨v]←⊂'' ⋄ Q←{v⊃⍨p⍳⊆⍵}
CACHE←##.##.CACHE
C←CACHE.videos.(index_cols⊃⍨fields⍳⊂)
@@ -22,8 +22,14 @@
filter←in_range∧presenter∧event
Norm←##.##.Unidecode.NormaliseText
+ stemmer←⎕NEW #.DCMS.Porter2Stemmer.EnglishPorter2Stemmer
+ Stem←{
+ stemmed←stemmer.Stem⊆⍵
+ stemmed.Value
+ }
⍝ Rank by search terms
- i←(Norm Q'search')Rank filter⌿CACHE.videos.index_all
+ terms←Stem¨', '(~⍤∊⍨⊆⊢)Norm Q'search'
+ i←terms Rank filter⌿CACHE.videos.index_all
⍝ Sort
data←(filter⌿CACHE.videos.values)[i;]
diff --git a/APLSource/read/videos/Rank.aplf b/APLSource/read/videos/Rank.aplf
index e3d1fd5..290ae40 100644
--- a/APLSource/read/videos/Rank.aplf
+++ b/APLSource/read/videos/Rank.aplf
@@ -1,11 +1,11 @@
Rank←{
-⍝ ⍺: Simple char vec space- or comma-separated search terms
+⍝ ⍺: Nested list of search terms
⍝ ⍵: Text search index array
⍝ ←: Indices of rows in results
⍝ Only results which contain at least one instance of one of the search terms
⍝ Ranked descending term-frequency inverse-document-frequency
0∊⍴⍺:⍳≢⍵ ⍝ No search terms provided, return all results
- trm←', '(~⍤∊⍨⊆⊢)⍺
+ trm←⍺
loc←trm⍷¨⊂⍵
idx←(any←⊃∨/∨/¨loc)⌿⍵
loc←any∘⌿¨loc
diff --git a/Admin/RunTests.aplf b/Admin/RunTests.aplf
new file mode 100644
index 0000000..1222a94
--- /dev/null
+++ b/Admin/RunTests.aplf
@@ -0,0 +1,11 @@
+ r←RunTests keepalive;result
+ r←Tests.Run GetEnv'URL'
+ :If keepalive
+ :Return
+ :EndIf
+ :If 1≡r
+ ⎕←'All tests passed.',⎕UCS 10
+ ⎕OFF 0
+ :Else
+ ⎕OFF 1
+ :EndIf
diff --git a/Admin/Tests/DummyData/Test_GetStemmedWord.aplf b/Admin/Tests/DummyData/Test_GetStemmedWord.aplf
new file mode 100644
index 0000000..22aff95
--- /dev/null
+++ b/Admin/Tests/DummyData/Test_GetStemmedWord.aplf
@@ -0,0 +1,9 @@
+ Test_GetStemmedWord←{
+⍝ Test free text search results include result from stemmed word
+ H←##.##.##.HttpCommand
+ url←⍵,'/videos?search=fugiativity'
+ res←H.GetJSON'GET'url
+ 200≠res.HttpStatus:0
+ 0∊⍴res.Data:0
+ 'fugiat'(∨/⍷)1 ⎕JSON res.Data
+ }
diff --git a/Admin/Tests/DummyData/Test_GetStemmedWords.aplf b/Admin/Tests/DummyData/Test_GetStemmedWords.aplf
new file mode 100644
index 0000000..e55c8bb
--- /dev/null
+++ b/Admin/Tests/DummyData/Test_GetStemmedWords.aplf
@@ -0,0 +1,10 @@
+ Test_GetStemmedWords←{
+⍝ Test free text search results include result from multiple stemmed words
+ H←##.##.##.HttpCommand
+ (stemmable stems)←↓⍉##.generator.stemmable
+ url←⍵,'/videos?search=',⊃(⊣,'%20',⊢)/stemmable
+ res←H.GetJSON'GET'url
+ 200≠res.HttpStatus:0
+ 0∊⍴res.Data:0
+ ∧/stems∘.(∨/⍷)⊂1 ⎕JSON res.Data
+ }
diff --git a/Admin/Tests/General/Test_Stemming.aplf b/Admin/Tests/General/Test_Stemming.aplf
new file mode 100644
index 0000000..5efc30b
--- /dev/null
+++ b/Admin/Tests/General/Test_Stemming.aplf
@@ -0,0 +1,5 @@
+ Test_Stemming←{
+ stemmer←⎕NEW #.DCMS.Porter2Stemmer.EnglishPorter2Stemmer
+ word←stemmer.Stem⊂'words'
+ 'word'≡word.Value
+ }
diff --git a/Admin/Tests/InsertDummyData.aplf b/Admin/Tests/InsertDummyData.aplf
index 438a02f..e635f83 100644
--- a/Admin/Tests/InsertDummyData.aplf
+++ b/Admin/Tests/InsertDummyData.aplf
@@ -1,4 +1,4 @@
- InsertDummyData;D;GEN;WrapBackticks;WrapColons;cid;col_spec;column;data;fn_cols;gen;idx;keywords;length;lipsum;n;name;opt;opt_cols;person_names;remove_columns;spec_fns;spec_opts;sql;table;thing_names;tid;type;type_spec;type_sql;types
+ InsertDummyData;D;NotFixedKeys;WrapBackticks;WrapColons;category;cid;col_spec;column;data;event;event_type;fixed_keys;keywords;lipsum;n;name;nvids;organisation;person;person_names;presentation;presentation_media;presentation_type;presenter;sql;stems;table;thing_names;tid;type;type_spec;videos;youtube_video
⍝ Insert dummy data into the database for testing
⍝ First tests considered:
⍝ - /videos?search= should return all videos with matching terms
@@ -8,9 +8,9 @@
⍝ Start by generating joined data and deconstructing it into the normalised database, then loop over each table and insert.
-
⍝ CONFIG
keywords←generator.keywords
+ stems←generator.stemmable[;2]
person_names←'Geoff' 'Streeter' 'John' 'Scholes' 'Iverson' 'Dolor' 'Fugiat' 'Orange' 'Rich' 'Park' 'Jada' 'Andrade' 'Andy' 'Karen' 'Fiona' 'Jason' 'Peter' 'Silas'
thing_names←'APL' 'Meeting' 'Seeds' 'Conference' 'Dyalog' 'Alpha' 'Omega'
lipsum←generator.lipsum
@@ -54,7 +54,8 @@
presentation←()
presentation.event_id←?n⍴n
presentation.code←(vocab:⎕A,⎕D ⋄ max:2 ⋄ unique:1)generator.Name n
- presentation.title←(vocab:lipsum ⋄ max:30)generator.Text n
+ presentation.title←stems
+ presentation.title,←(vocab:lipsum ⋄ max:30)generator.Text n-≢stems
presentation.title[1],←⊂' dolor' ⍝ Ensure a keyword is present in search results
presentation.type_id←?n⍴n
presentation.description←(vocab:lipsum ⋄ max:65535)generator.Text n
@@ -63,16 +64,21 @@
presentation.⎕DF'presentation'
presenter←()
- presenter.(presentation_id person_id)←↓⍉{?⍵⍴⍛⍴n}⍣{∧/≠⍵}n 2⍴0
+ ⍝ Using fixed keys in the presenter and presentation_media tables ensures that stems are found in video results for testing
+ presenter.(presentation_id person_id)←fixed_keys←(1 2)(1 2)
+ NotFixedKeys←{~∨/,(↑fixed_keys)⍷⍤1 2⊢⍵}
+ presenter.(presentation_id person_id),←↓⍉{?⍵⍴⍛⍴n}⍣{(NotFixedKeys ⍺)∧∧/≠⍺}(n-≢fixed_keys)2⍴0
presenter.⎕DF'presenter'
⍝ Videos is not a table to insert, but its data is used in other tables and must be consistent, so we create it here and re-use it below
videos←()
videos.presentation_id←?n⍴n
- videos.youtube_id←↓{(⎕A,⎕C ⎕A)[?⍵⍴⍛⍴2×26]}⍣{∧/≠⍵}n 11⍴0
+ videos.youtube_id←↓{(⎕A,⎕C ⎕A)[?⍵⍴⍛⍴2×26]}⍣{∧/≠⍺}n 11⍴0
+ nvids←≢∪videos.youtube_id
presentation_media←(type:n⍴⊂'youtube_video')
- presentation_media.(presentation_id media_id)←↓⍉{?⍵⍴⍛⍴n}⍣{∧/≠⍵}n 2⍴0 ⍝ Random unique pairs of numbers
+ presentation_media.(presentation_id media_id)←fixed_keys←(1 2)(1 2)
+ presentation_media.(presentation_id media_id),←↓⍉{?⍵⍴⍛⍴n nvids}⍣{(NotFixedKeys ⍺)∧∧/≠⍺}(n-≢fixed_keys)2⍴0 ⍝ Random unique pairs of numbers
presentation_media.⎕DF'presentation_media'
youtube_video←(
diff --git a/Admin/Tests/generator/stemmable.apla b/Admin/Tests/generator/stemmable.apla
new file mode 100644
index 0000000..c97d058
--- /dev/null
+++ b/Admin/Tests/generator/stemmable.apla
@@ -0,0 +1,4 @@
+[
+ 'ingenuity' 'ingenu'
+ 'amicable' 'amic'
+]
diff --git a/CI/activate.apls b/CI/activate.apls
new file mode 100755
index 0000000..3da2d6b
--- /dev/null
+++ b/CI/activate.apls
@@ -0,0 +1,2 @@
+#!/usr/bin/dyalogscript DYALOG_INITSESSION=1
+⎕←⎕SE.UCMD'activate all -reset'
diff --git a/CI/install.apls b/CI/install.apls
new file mode 100755
index 0000000..701b47a
--- /dev/null
+++ b/CI/install.apls
@@ -0,0 +1,18 @@
+#!/usr/bin/dyalogscript DYALOG_INITSESSION=1
+⎕←'Installing application dependencies...'
+
+root←2 ⎕NQ # 'GetEnvironment' 'APP_DIR'
+pkg←root,'/packages'
+nuget←root,'/nuget-packages'
+
+:Trap 0
+ ⎕SE.Tatin.ReInstallDependencies pkg
+ ⎕SE.Tatin.LoadPackages 'NuGet' ⎕THIS
+ NuGet.Publish nuget
+ ⎕←'Application dependencies installed in ',pkg,' and ',nuget
+ ⎕OFF 0
+:Else
+ ⎕←'Could not install dependencies.'
+ ⎕←1⎕JSON⎕OPT'Compact'0⊢⎕DMX
+ ⎕OFF 1
+:EndTrap
diff --git a/CI/run-tests-in-docker.sh b/CI/run-tests-in-docker.sh
index a72300a..020283d 100755
--- a/CI/run-tests-in-docker.sh
+++ b/CI/run-tests-in-docker.sh
@@ -7,8 +7,11 @@ else
fi
## Populate env file
-echo CONFIGFILE=/app/CI/testing.dcfg >> ${PWD}/env
-echo RIDE_INIT=HTTP:*:4502 >> ${PWD}/env
+rm ${PWD}/env
+echo YOUTUBE=http://localhost:8088/ >> ${PWD}/env
+echo APP_DIR=/app >> ${PWD}/env
+echo CONFIGFILE=/app/CI/test.dcfg >> ${PWD}/env
+echo RIDE_INIT=SERVE:*:4502 >> ${PWD}/env
echo SQL_SERVER=db >> ${PWD}/env
echo SQL_DATABASE=dyalog_cms >> ${PWD}/env
echo SQL_USER=dcms >> ${PWD}/env
@@ -26,4 +29,4 @@ echo COMPOSE IS: $COMPOSE
echo "Use docker inspect to get the IP of the running container"
$COMPOSE pull
-$COMPOSE -f docker-compose.yml up
+$COMPOSE -f docker-compose.yml up db web --force-recreate --abort-on-container-exit
diff --git a/CI/test.dcfg b/CI/test.dcfg
new file mode 100644
index 0000000..fc861d1
--- /dev/null
+++ b/CI/test.dcfg
@@ -0,0 +1,10 @@
+{
+ Extend: "../dcms.dcfg",
+ Settings: {
+ LX: "⎕TRAP ← 0 'C' '⎕←''Error during setup for test run'' ⋄ ⎕←1⎕JSON⎕OPT''Compact''0⊢⎕DMX ⋄ ⎕OFF 1' ⋄\
+ ⎕SE.Link.Import 'DCMS' '[APP_DIR]/APLSource' ⋄\
+ ⎕SE.Link.Import 'Admin' '[APP_DIR]/Admin' ⋄\
+ DCMS.Setup ⋄ DCMS.Run [DEBUG] ⋄\
+ Admin.RunTests 0"
+ }
+}
\ No newline at end of file
diff --git a/CI/testing.dcfg b/CI/testing.dcfg
deleted file mode 100644
index 9abfc04..0000000
--- a/CI/testing.dcfg
+++ /dev/null
@@ -1,15 +0,0 @@
-{
- Extend: "../run.dcfg",
- Settings: {
- ADMIN_DIR: "[APP_DIR]/Admin",
- DCMS_DIR: "[APP_DIR]/APLSource",
-
- YOUTUBE: "http://localhost:8088/",
-
- LX: "⎕←⎕SE.Link.Import 'Admin' '[ADMIN_DIR]' ⋄\
- ⎕←⎕SE.Link.Import 'DCMS' '[DCMS_DIR]' ⋄\
- DCMS.Run 1 ⋄\
- result←Admin.Tests.Run Admin.GetEnv'URL' ⋄\
- :If 1≡result ⋄ ⎕←'All tests passed.',⎕UCS 10 ⋄ ⎕OFF 0 ⋄ :Else ⋄ ⎕OFF 1 ⋄ :EndIf"
- }
-}
diff --git a/Dockerfile b/Dockerfile
new file mode 100644
index 0000000..1b997be
--- /dev/null
+++ b/Dockerfile
@@ -0,0 +1,7 @@
+FROM dyalog/techpreview:latest
+
+USER root
+RUN /tmp/dotnet-install.sh -c 8.0 -i /opt/dotnet
+RUN apt-get update && apt-get install -y zip && apt-get clean && rm -Rf /var/lib/apt/lists/*
+
+USER dyalog
diff --git a/Jenkinsfile b/Jenkinsfile
index 3574026..5f4133e 100644
--- a/Jenkinsfile
+++ b/Jenkinsfile
@@ -6,23 +6,36 @@ def DockerDB
def DockerDyalog
def Testfile = "/tmp/dcms-CI.log"
def Branch = env.BRANCH_NAME.toLowerCase()
+def Home = "/app/home"
node ('Docker') {
stage ('Checkout') {
checkout scm
}
- stage ('Update Dyalog') {
+ stage ('Build container') {
withDockerRegistry(credentialsId: '0435817a-5f0f-47e1-9dcc-800d85e5c335') {
- DockerDyalog=docker.image('dyalog/techpreview:latest')
- DockerDyalog.pull()
+ DockerDyalog = docker.build("dcms-build", "-f $WORKSPACE/Dockerfile .")
}
}
stage ('Update MariaDB') {
- withDockerRegistry(credentialsId: '0435817a-5f0f-47e1-9dcc-800d85e5c335') {
+ withDockerRegistry(credentialsId: '0435817a-5f0f-47e1-9dcc-800d85e5c335') {
DockerDB=docker.image('mariadb:10.8.2') // Until build machine is updated
DockerDB.pull()
}
}
+ stage ('Install dependencies') {
+ sh "mkdir -p $WORKSPACE/home"
+ try {
+ DockerDyalog.inside("-t -u 6203 -v $WORKSPACE:/app -e HOME=${Home} -e APP_DIR=/app -e DOTNET_ROOT=/opt/dotnet --entrypoint=''"){
+ sh "/app/CI/activate.apls"
+ sh "/app/CI/install.apls"
+ }
+ } catch(e) {
+ println 'Could not install Tatin or NuGet dependencies.'
+ sh "docker rmi dcms-build"
+ throw new Exception("${e}")
+ }
+ }
stage ('Test service') {
DockerAppDB = DockerDB.run ("-e MYSQL_RANDOM_ROOT_PASSWORD=true -e MYSQL_DATABASE=dyalog_cms -e MYSQL_USER=dcms -e MYSQL_PASSWORD=apl")
@@ -37,7 +50,7 @@ node ('Docker') {
withCredentials([file(credentialsId: '205bc57d-1fae-4c67-9aeb-44c1144f071c', variable: 'DCMS_SECRETS')]) {
try {
- DockerApp = DockerDyalog.run ("-t -u 6203 -v $DCMS_SECRETS:$DCMS_SECRETS -e HOME=/tmp -e CONFIGFILE=/app/CI/testing.dcfg -e SECRETS=$DCMS_SECRETS -e SQL_SERVER=${DBIP} -e SQL_DATABASE=dyalog_cms -e SQL_USER=dcms -e SQL_PASSWORD=apl -e SQL_PORT=3306 -v $WORKSPACE:/app")
+ DockerApp = DockerDyalog.run ("-t -u 6203 -v $DCMS_SECRETS:$DCMS_SECRETS -e HOME=${Home} -e CONFIGFILE=/app/CI/test.dcfg -e APP_DIR=/app -e YOUTUBE=http://localhost:8088/ -e SECRETS=$DCMS_SECRETS -e SQL_SERVER=${DBIP} -e SQL_DATABASE=dyalog_cms -e SQL_USER=dcms -e SQL_PASSWORD=apl -e SQL_PORT=3306 -v $WORKSPACE:/app")
println(DockerApp.id)
sh "docker logs -f ${DockerApp.id}"
def out = sh script: "docker inspect ${DockerApp.id} --format='{{.State.ExitCode}}'", returnStdout: true
@@ -53,6 +66,7 @@ node ('Docker') {
sh "${WORKSPACE}/CI/githubComment.sh ${DockerApp.id} ${commit_id}"
}
DockerApp.stop()
+ sh "docker rmi dcms-build"
echo "Throwing Exception..."
echo "Exception is: ${e}"
throw new Exception("${e}");
@@ -101,12 +115,12 @@ node ('Docker') {
echo SQL_PASSWORD=apl >> ${WORKSPACE}/env
echo SQL_PORT=3306 >> ${WORKSPACE}/env
echo SECRETS=/app/secrets/secrets.json5 >> ${WORKSPACE}/env
- echo RIDE_INIT=http:*:4502 >> ${WORKSPACE}/env
echo MYSQL_DATABASE=dyalog_cms >> ${WORKSPACE}/env
echo MYSQL_USER=dcms >> ${WORKSPACE}/env
echo MYSQL_PASSWORD=apl >> ${WORKSPACE}/env
echo MYSQL_PORT=3306 >> ${WORKSPACE}/env
- echo CONFIGFILE=/app/run.dcfg >> ${WORKSPACE}/env
+ echo YOUTUBE=https://www.googleapis.com/youtube/v3/ >> ${WORKSPACE}/env
+ echo APP_DIR=/app
echo MYSQL_RANDOM_ROOT_PASSWORD=1 >> ${WORKSPACE}/env
'''
diff --git a/dcms.dcfg b/dcms.dcfg
new file mode 100644
index 0000000..13cef9e
--- /dev/null
+++ b/dcms.dcfg
@@ -0,0 +1,18 @@
+{
+ Settings: {
+ MAXWS: "2G",
+ PW: 300,
+ SERVICE_URL: "http://localhost",
+ SERVICE_PORT: 8080,
+ URL: "[SERVICE_URL]:[SERVICE_PORT]",
+ DEBUG: 0,
+ log_file: "[APP_DIR]/dyalog_log_file.dlf",
+ SCHEMA_DEFS: "[APP_DIR]/sql/*.sql",
+
+ PKG: "[APP_DIR]/packages",
+ PKG_NUGET: "[APP_DIR]/nuget-packages",
+
+ LX: "⎕SE.Link.Import 'DCMS' '[APP_DIR]/APLSource' ⋄\
+ DCMS.Setup ⋄ DCMS.Run [DEBUG]"
+ }
+}
diff --git a/dev.dcfg b/dev.dcfg
index 044b45c..33c11f9 100644
--- a/dev.dcfg
+++ b/dev.dcfg
@@ -1,24 +1,13 @@
{
+ Extend: "dcms.dcfg",
Settings: {
- MAXWS: "2G",
- PW: 300,
-
- APP_DIR: "/app",
- SERVICE_URL: "http://localhost",
SERVICE_PORT: 8081,
- URL: "[SERVICE_URL]:[SERVICE_PORT]",
DEBUG: 1,
- log_file: "[app_dir]/dyalog_log_file.dlf",
- schema_defs: "[app_dir]/sql/*.sql",
-
- Jarvis: "/app/packages/Jarvis.dyalog",
- HttpCommand: "/app/packages/HttpCommand.dyalog",
YOUTUBE: "http://localhost:8088/",
LX: "⎕←⎕SE.Link.Create 'DCMS' '[APP_DIR]/APLSource' ⋄\
- ⎕←⎕SE.Link.Create 'Admin' '[APP_DIR]/Admin' ⋄\
- ⎕CS DCMS ⋄\
- Run [DEBUG]",
+ ⎕←⎕SE.Link.Create 'Admin' '[APP_DIR]/Admin' ⋄\
+ DCMS.Setup ⋄ DCMS.Run [DEBUG]"
}
}
diff --git a/docs/api.md b/docs/api.md
index 792a4c3..837df5f 100644
--- a/docs/api.md
+++ b/docs/api.md
@@ -50,6 +50,8 @@ Returns a list of video objects
#### search
`?search=q` where `q` is a list of search terms separated by URL-encoded space (`'%20'`), comma (`','`) or plus (`'+'`). Free text search of titles, descriptions, presenters and events.
+The search uses the [Porter2Stemmer](./packages.md#porter2stemmer-nuget-package) NuGet package.
+
#### sort
`?sort=o` where `o` is one of:
- `relevance`
diff --git a/docs/dev.md b/docs/dev.md
index 880c153..61f0077 100644
--- a/docs/dev.md
+++ b/docs/dev.md
@@ -2,31 +2,31 @@
DCMS is developed using Dyalog in Docker. This allows us to develop and deploy with the same environment.
## Development, Testing and Deployment
-Three [configuration files](https://docs.dyalog.com/20.0/unix-installation-and-configuration-guide/configuration-parameters/configuration-files/) are used to launch the system for the purposes of development, testing and deployment.
+[Configuration files](https://docs.dyalog.com/20.0/unix-installation-and-configuration-guide/configuration-parameters/configuration-files/) are used to launch the system for the purposes of development, testing and deployment.
-1. The [**dev.dcfg**](../dev.dcfg) configuration is used for development. The script [**dev**](../dev) can be used on Linux to set required environment variables and launch Dyalog from this configuration file.
- ```sh
- ./dev
- ```
-2. The [**CI/testing.dcfg**](../CI/testing.dcfg) is used to launch the application and execute the test suite. The script [**CI/run-tests-in-docker.sh**](../CI/run-tests-in-docker.sh) can be used on Linux to run these tests using Docker.
- ```sh
- ./CI/run-tests-in-docker.sh
- ```
-3. The [**run.dcfg**](../run.dcfg) configuration is used to launch the application in production.
+The base configuration is in [**dcms.dcfg**](../dcms.dcfg). Other configuration files use this as a base with the "Extend" keyword, and when run in Docker for testing and in production, Dyalog is launched using **dcms.dws** which automatically uses settings found in the base configuration file.
-## Test scenarios and the Mock YouTube service
-The **Admin** namespace includes the **MockYT** service that lets us test using the YouTube API with dummy data. This service is started by **dev.dcfg** and **testing.dcfg** if the environment variable `YOUTUBE` contains `'localhost'`.
+The [**dev.dcfg**](../dev.dcfg) configuration is used for development. The script [**dev**](../dev) can be used on Linux to set required environment variables and launch Dyalog from this configuration file.
-While developing in Dyalog, you can run tests with:
+```sh
+./dev
+```
+
+To run tests during development, do:
```apl
Admin.(Tests.Run GetEnv'URL')
```
-This will test HTTP endpoints, insert dummy data into the database, rebuild the cache (calling the mock YouTube service to get e.g. video description data) and test the HTTP endpoints again.
+The system is built as a binary workspace **dcms.dws** for testing and deployment. Use the build script [**CI/build-with-docker.sh**](../CI/build-with-docker.sh) to build the application workspace.
-The `Admin.Tests.Test` function takes a namespace of functions that begin with `Test` and runs them, printing to the session in the case of an error or failure. The overall function returns `1` if all tests pass and `0` otherwise.
+Then, to run the deployment testing scenario locally, do:
+
+```sh
+./CI/run-tests-in-docker.sh
+```
-The `Admin.Tests.General` test suite should pass when the system is newly started with a fresh database and when the service has data in the cache ready to serve. These are like regression tests.
+## Packages
+This application depends on [Tatin and NuGet packages](./packages.md). During development, these are loaded using Tatin and the .NET SDK. For testing and production, the application source and dependencies are loaded into the active workspace which is saved as a binary workspace file.
-The `Admin.Tests.DummyData` is more like an integration test suite.
+Using the built application workspace then only requires the .NET runtime.
diff --git a/docs/install.md b/docs/install.md
index 9754f9c..042180b 100644
--- a/docs/install.md
+++ b/docs/install.md
@@ -1,9 +1,5 @@
# Installation and Configuration
-Development config in **dev.dcfg**. Runtime config in **run.dcfg**.
-
-To run locally, use Dyalog with `CONFIGFILE=/path/to/dev.dcfg` or **right-click → Run with Dyalog** on Windows.
-
-To run in a production-like environment, do `docker-compose up` from within the repository root folder.
+The system is developed using Link with Dyalog in a Docker container. This page contains information relevant to anybody modifying to system to run in a different environment.
## Install ODBC drivers on the host system
!!!Warning
@@ -71,15 +67,6 @@ grant all privileges on dyalog_cms to user dcms
- app_dir
- service_url
-## Configuring secrets and database information
-Docker secrets are used to store:
-- External API keys (e.g. YouTube)
-
-## data sources
-Most manually updated source data is specified in **data_sources.json5**.
-
-Some data is fetched from external APIs. API keys are specified
-
## debug
Global debug flag. Used as `#.GLOBAL.debug` in order to not have to re-read environment.
diff --git a/docs/packages.md b/docs/packages.md
new file mode 100644
index 0000000..b658525
--- /dev/null
+++ b/docs/packages.md
@@ -0,0 +1,16 @@
+# Packages
+The system depends on some Tatin and NuGet packages. These can be updated using an installed Dyalog system with Tatin activated. Since Tatin is not activated by default in the current version of Dyalog, the packages cannot be updated using the Dyalog Docker container.
+
+Instead, we use the [rikedyp/dyalogci](#) image to install Tatin and NuGet dependencies in production.
+
+## Jarvis
+The web service is based on the [Jarvis](https://dyalog.github.io/Jarvis) web service framework which allows APL functions to be exposed as HTTP endpoints.
+
+## HttpCommand
+The [HttpCommand](https://dyalog.github.io/HttpCommand) package is used to interact with external HTTP APIs.
+
+## NuGet
+The [Dyalog/NuGet](https://github.com/Dyalog/nuget) package is used to facilitate easy use of NuGet packages.
+
+## Porter2Stemmer NuGet Package
+The [Porter2Stemmer](https://www.nuget.org/packages/Porter2Stemmer) NuGet package is used so that search queries can be stemmed, for example "packages" becomes "package", so that results are less dependent on exact spelling.
diff --git a/nuget-packages/_nuget-packages.csproj b/nuget-packages/_nuget-packages.csproj
new file mode 100644
index 0000000..f0cb842
--- /dev/null
+++ b/nuget-packages/_nuget-packages.csproj
@@ -0,0 +1,3 @@
+
net8.0
_nuget_packages
enable
enable
Latest
+
+
diff --git a/packages/HttpCommand.dyalog b/packages/HttpCommand.dyalog
deleted file mode 100644
index d27b2ea..0000000
--- a/packages/HttpCommand.dyalog
+++ /dev/null
@@ -1,1571 +0,0 @@
-:Class HttpCommand
-⍝ General HTTP Commmand utility
-⍝ Documentation is found at https://dyalog.github.io/HttpCommand/
-
- ⎕ML←⎕IO←1
-
- ∇ r←Version
- ⍝ Return the current version
- :Access public shared
- r←'HttpCommand' '5.8.0' '2024-07-17'
- ∇
-
-⍝ Request-related fields
- :field public Command←'get' ⍝ HTTP command (method)
- :field public URL←'' ⍝ requested resource
- :field public Params←'' ⍝ request parameters
- :field public Headers←0 2⍴⊂'' ⍝ request headers - name, value
- :field public ContentType←'' ⍝ request content-type
- :field public Cookies←⍬ ⍝ request cookies - vector of namespaces
- :field public Auth←'' ⍝ authentication string
- :field public AuthType←'' ⍝ authentication type
- :field public BaseURL←'' ⍝ base URL to use when making multiple requests to the same host
- :field public ChunkSize←0 ⍝ set to size of chunk if using chunked transfer encoding
- :field public shared HeaderSubstitution←'' ⍝ delimiters to indicate environment/configuration settings be substituted in headers, set to '' to disable
-
-
-⍝ Proxy-related fields - only used if connecting through a proxy server
- :field public ProxyURL←'' ⍝ address of the proxy server
- :field public ProxyAuth←'' ⍝ authentication string, if any, for the proxy server
- :field public ProxyAuthType←'' ⍝ authentication type, if any, for the proxy server
- :field public ProxyHeaders←0 2⍴⊂'' ⍝ any headers that the proxy server might need
-
-⍝ Conga-related fields
- :field public BufferSize←200000 ⍝ Conga buffersize
- :field public WaitTime←5000 ⍝ Timeout in ms on Conga Wait call
- :field public Cert←⍬ ⍝ X509 instance if using HTTPS
- :field public SSLFlags←32 ⍝ SSL/TLS flags - 32 = accept cert without checking it
- :field public Priority←'NORMAL:!CTYPE-OPENPGP' ⍝ GnuTLS priority string
- :field public PublicCertFile←'' ⍝ if not using an X509 instance, this is the client public certificate file
- :field public PrivateKeyFile←'' ⍝ if not using an X509 instance, this is the client private key file
- :field public shared LDRC ⍝ HttpCommand-set reference to Conga after CongaRef has been resolved
- :field public shared CongaPath←'' ⍝ path to user-supplied conga workspace (assumes shared libraries are in the same path)
- :field public shared CongaRef←'' ⍝ user-supplied reference to Conga library
- :field public shared CongaVersion←'' ⍝ Conga [major minor build]
-
-⍝ Operational fields
- :field public SuppressHeaders←0 ⍝ set to 1 to suppress HttpCommand-supplied default request headers
- :field public MaxPayloadSize←¯1 ⍝ set to ≥0 to take effect
- :field public Timeout←10 ⍝ seconds to wait for a response before timing out, negative means reset timeout if any activity
- :field public RequestOnly←¯1 ⍝ set to 1 if you only want to return the generated HTTP request, but not actually send it
- :field public OutFile←'' ⍝ name of file to send payload to (format is same as ⎕NPUT right argument)
- :field public Secret←1 ⍝ suppress displaying credentials in Authorization header
- :field public MaxRedirections←10 ⍝ set to 0 if you don't want to follow any redirected references, ¯1 for unlimited
- :field public KeepAlive←1 ⍝ default to not close client connection
- :field public TranslateData←0 ⍝ set to 1 to translate XML or JSON response data
- :field public UseZip←0 ⍝ zip request payload (0-no, 1-use gzip, 2-use deflate)
- :field public ZipLevel←1 ⍝ default compression level (0-9)
- :field public shared Debug←0 ⍝ set to 1 to disable trapping, 2 to stop just before creating client
- :field public readonly shared ValidFormUrlEncodedChars←'&=ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-._~*+~%'
-
- :field Client←'' ⍝ Conga client ID
- :field ConxProps←'' ⍝ when a client is made, its connection properties are saved so that if either changes, we close the previous client
- :field origCert←¯1 ⍝ used to check if Cert changed between calls
-
- ∇ make
- ⍝ No argument constructor
- :Access public
- :Implements constructor
- ∇
-
- ∇ make1 args;settings;invalid
- ⍝ Constructor arguments - [Command URL Params Headers Cert SSLFlags Priority]
- :Access public
- :Implements constructor
- →0⍴⍨0∊⍴args
- args←(eis⍣({9.1≠⎕NC⊂,'⍵'}⊃args)⊢args)
- :Select {⊃⎕NC⊂,'⍵'}⊃args
- :Case 2.1 ⍝ array
- Command URL Params Headers Cert SSLFlags Priority←7↑args,(⍴args)↓Command URL Params Headers Cert SSLFlags Priority
- :Case 9.1 ⍝ namespace
- :If 0∊⍴invalid←(settings←args.⎕NL ¯2.1 ¯9.1)~(⎕NEW⊃⊃⎕CLASS ⎕THIS).⎕NL ¯2.2
- args{⍎⍵,'←⍺⍎⍵'}¨settings
- :Else ⋄ ('Invalid HttpCommand setting(s): ',,⍕invalid)⎕SIGNAL 11
- :EndIf
- :Else ⋄ 'Invalid constructor argument'⎕SIGNAL 11
- :EndSelect
- ∇
-
- ∇ {ns}←initResult ns
- ⍝ initialize the namespace result
- :Access shared
- ns.(Command URL rc msg HttpVersion HttpStatus HttpMessage Headers Data PeerCert Redirections Cookies OutFile Elapsed BytesWritten)←'' '' ¯1 '' ''⍬''(0 2⍴⊂'')''⍬(0⍴⊂'')⍬'' 0 ¯1
- ns.GetHeader←{⎕IO←⎕ML←1 ⋄ ⍺←Headers ⋄ ⍺{1<|≡⍵:⍺∘∇¨⍵ ⋄ (⍺[;2],⊂'')⊃⍨⍺[;1](⍳{(⍵⍵ ⍺)⍺⍺(⍵⍵ ⍵)}{2::0(819⌶)⍵ ⋄ ¯3 ⎕C ⍵})⊆,⍵}⍵} ⍝ return header value or '' if not found
- ns.⎕FX'∇r←IsOK' 'r←0 2≡rc,⌊.01×HttpStatus' '∇'
- ∇
-
- ∇ Goodbye
- :Implements destructor
- {}{0::'' ⋄ LDRC.Names'.'⊣LDRC.Close ⍵}⍣(~0∊⍴Client)⊢Client
- ∇
-
- ∇ r←Config;i
- ⍝ Returns current configuration
- :Access public
- r←↑{6::⍵'not set' ⋄ ⍵(⍎⍵)}¨(⎕THIS⍎'⎕NL ¯2.2')~⊂'ValidFormUrlEncodedChars'
- :If (≢r)≥i←r[;1]⍳⊂'Auth'
- :AndIf Secret
- r[i;2]←⊂'>>> Secret setting is 1 <<<'
- :EndIf
- ∇
-
- ∇ r←Run
- ⍝ Attempt to run the HTTP command
- :Access public
- RequestOnly←0⌈RequestOnly
- Result←initResult #.⎕NS''
- :Trap Debug↓0
- r←(Cert SSLFlags Priority PublicCertFile PrivateKeyFile)HttpCmd Command URL Params Headers
- :Else ⍝ :Trap
- r←Result
- r.(rc msg)←¯1('Unexpected ',⊃{⍺,' at ',⍵}/2↑⎕DMX.DM)
- :EndTrap
- setDisplayFormat r
- exit:
- ∇
-
- ∇ r←Show;ro
- ⍝ Show the request to be sent to the server
- :Access public
- ro←RequestOnly
- RequestOnly←1
- r←Run
- RequestOnly←ro
- ∇
-
- ∇ {r}←setDisplayFormat r;rc;msg;stat;data
- ⍝ set the display format for the namespace result for most HttpCommand commands
- :If 9.1=nameClass r
- rc←'rc: ',⍕r.rc
- msg←' | msg: ',⍕r.msg
- stat←' | HTTP Status: ',(⍕r.HttpStatus),' "',r.HttpMessage,'"'
- data←' | ',{¯1≠r.BytesWritten:(⍕r.BytesWritten),' bytes written to ',r.OutFile ⋄ '≢Data: ',(⍕≢⍵),(9.1=nameClass ⍵)/' (namespace)'}r.Data
- r.⎕DF 1⌽'][',rc,msg,stat,data
- :EndIf
- ∇
-
- ∇ r←{requestOnly}Get args
- ⍝ Shared method to perform an HTTP GET request
- ⍝ args - [URL Params Headers Cert SSLFlags Priority]
- :Access public shared
- :If 0=⎕NC'requestOnly' ⋄ requestOnly←¯1 ⋄ :EndIf
- :If 2.1=nameClass⊃args ⋄ args←((⊂'GET'),eis args) ⋄ :EndIf
- →∆EXIT⍴⍨9.1=nameClass r←requestOnly New args
- r←r.Run
- ∆EXIT:
- ∇
-
- ∇ r←{requestOnly}Do args
- ⍝ Shared method to perform any HTTP request
- ⍝ args - [Command URL Params Headers Cert SSLFlags Priority]
- :Access public shared
- :If 0=⎕NC'requestOnly' ⋄ requestOnly←¯1 ⋄ :EndIf
- →∆EXIT⍴⍨9.1=nameClass r←requestOnly New args
- r←r.Run
- ∆EXIT:
- ∇
-
- ∇ r←{requestOnly}New args
- ⍝ Shared method to create new HttpCommand
- ⍝ args - [Command URL Params Headers Cert SSLFlags Priority]
- ⍝ requestOnly - initial setting for RequestOnly
- :Access public shared
- :If 0=⎕NC'requestOnly' ⋄ requestOnly←¯1 ⋄ :EndIf
- r←''
- :Trap Debug↓0
- :If 0∊⍴args
- r←##.⎕NEW ⎕THIS
- :Else
- r←##.⎕NEW ⎕THIS(eis⍣(9.1≠nameClass⊃args)⊢args)
- :EndIf
- r.RequestOnly←requestOnly
- :Else
- r←initResult #.⎕NS''
- r.(rc msg)←¯1 ⎕DMX.EM
- setDisplayFormat r
- →∆EXIT
- :EndTrap
- ∆EXIT:
- ∇
-
- ∇ r←{requestOnly}GetJSON args;cmd
- ⍝ Shared method to perform an HTTP request with JSON data as the request and response payloads
- ⍝ args - [Command URL Params Headers Cert SSLFlags Priority]
- :Access public shared
- :If 0=⎕NC'requestOnly' ⋄ requestOnly←¯1 ⋄ :EndIf
-
- →∆EXIT⍴⍨9.1=nameClass cmd←requestOnly New args
- :If 0∊⍴cmd.Command ⋄ cmd.Command←(1+0∊⍴cmd.Params)⊃'POST' 'GET' ⋄ :EndIf
- :If ~(⊂lc cmd.Command)∊'get' 'head'
- :If 0∊⍴cmd.ContentType ⋄ cmd.ContentType←'application/json;charset=utf-8' ⋄ :EndIf
- :If ~0∊⍴cmd.Params
- :Trap Debug↓0
- cmd.Params←JSONexport cmd.Params
- :Else
- →∆DONE⊣r.(rc msg)←¯1 'Could not convert parameters to JSON format'
- :EndTrap
- :EndIf
- :EndIf
- r←cmd.Run
- →cmd.RequestOnly⍴∆EXIT
-
- :If r.rc=0
- →∆DONE⍴⍨204=r.HttpStatus ⍝ exit if "no content" HTTP status
- :If ¯1=r.BytesWritten ⍝ if not writing to file
- :If ∨/'application/json'⍷lc r.Headers getHeader'content-type'
- JSONimport r
- :Else ⋄ →∆DONE⊣r.(rc msg)←¯2 'Response content-type is not application/json'
- :EndIf
- :EndIf
- :EndIf
- ∆DONE: ⍝ reset ⎕DF if messages have changed
- setDisplayFormat r
- ∆EXIT:
- ∇
-
- ∇ r←{ro}Fix args;z;url;target
- ⍝ retrieve and fix APL code loads the latest version from GitHub
- ⍝ args is:
- ⍝ [1] URL of code to fix - if the URL has 'github' (but not 'raw.githubusercontent.com') in it, we do some gratuitous massaging
- ⍝ [2] (optional) reference to namespace in which to fix the code (default ##)
- ⍝ example: HttpCommand.Fix 'github/Dyalog/Jarvis/Source/Jarvis.dyalog' #.
- :Access public shared
- (url target)←2↑(,⊆args),##
- :If 0=⎕NC'ro' ⋄ ro←0 ⋄ :EndIf
- r←z←ro Get{ ⍝ convert url if necessary
- ~∨/'github'⍷⍵:⍵ ⍝ if not github just
- ∨/'raw.githubusercontent.com'⍷⍵:⍵ ⍝ already refers to
- t←'/'(≠⊆⊢)⍵
- i←⍸<\∨/¨'github'∘⍷¨t
- 'https://raw.githubusercontent.com',∊'/',¨(2↑i↓t),(⊂'master'),(2+i)↓t
- }url
- →ro⍴0
- :If z.rc≠0
- r←z.(rc msg)
- :ElseIf z.HttpStatus≠200
- r←¯1(⍕z)
- :Else
- :Trap 0
- r←0(⍕target{0::⍺.⎕FX ⍵ ⋄ ⍺.⎕FIX ⍵}{⍵⊆⍨~⍵∊⎕UCS 13 10 65279}z.Data)
- :Else
- r←¯1('Could not ⎕FIX file: ',2↓∊': '∘,¨⎕DMX.(EM Message))
- :EndTrap
- :EndIf
- ∇
-
- ∇ r←Init
- :Access Public
- r←(Initialize initResult ⎕NS'').(rc msg)
- r[1]×←~0∊⍴2⊃r ⍝ set to 0 if no error message from Conga initialization
- ∇
-
- ∇ r←Initialize r;ref;root;nc;n;ns;congaCopied;class;path
- ⍝↓↓↓ Check if LDRC exists (VALUE ERROR (6) if not), and is LDRC initialized? (NONCE ERROR (16) if not)
- r.msg←''
- :Hold 'HttpCommandInit'
- :If {6 16 999::1 ⋄ ''≡LDRC:1 ⋄ 0⊣LDRC.Describe'.'}''
- LDRC←''
- :If ~0∊⍴CongaRef ⍝ did the user supply a reference to Conga?
- :If 0∊⍴LDRC←r ResolveCongaRef CongaRef
- r.msg,⍨←'Could not initialize Conga using CongaRef "',(⍕CongaRef),'" due to '
- →∆END
- :EndIf
- :Else
- :For root :In ## #
- ref nc←root{1↑¨⍵{(×⍵)∘/¨⍺ ⍵}⍺.⎕NC ⍵}ns←'Conga' 'DRC'
- :If 9=⊃⌊nc ⋄ :Leave ⋄ :EndIf
- :EndFor
-
- :If 9=⊃⌊nc
- :If 0∊⍴LDRC←r ResolveCongaRef(root⍎∊ref)
- →∆END⊣r.msg,⍨←'Could not initialize Conga from "',(∊(⍕root)'.'ref),'" due to '
- :EndIf
- →∆COPY↓⍨{999::0 ⋄ 1⊣LDRC.Describe'.'}'' ⍝ it's possible that Conga was saved in a semi-initialized state
- :Else
- ∆COPY:
- class←⊃⊃⎕CLASS ⎕THIS
- :If ~0∊⍴CongaPath
- CongaPath←∊1 ⎕NPARTS CongaPath,'/'
- →∆END↓⍨0∊⍴r.msg←(~⎕NEXISTS CongaPath)/'CongaPath "',CongaPath,'" does not exist'
- →∆END↓⍨0∊⍴r.msg←(1≠1 ⎕NINFO CongaPath)/'CongaPath "',CongaPath,'" is not a folder'
- :EndIf
- congaCopied←0
- :For n :In ns
- :For path :In (1+0∊⍴CongaPath)⊃(⊂CongaPath)((dyalogRoot,'ws/')'') ⍝ if CongaPath specifiec, use it exclusively
- :Trap Debug↓0
- n class.⎕CY path,'conga'
- LDRC←r ResolveCongaRef(class⍎n)
- :If 0∊⍴LDRC
- r.msg,⍨←n,' was copied from "',path,'conga", but encountered '
- →∆END
- :EndIf
- →∆COPIED⊣congaCopied←1
- :EndTrap
- :EndFor
- :EndFor
- →∆END↓⍨0∊⍴r.msg←(~congaCopied)/'neither Conga nor DRC were successfully copied'
- ∆COPIED:
- :EndIf
- :EndIf
- :EndIf
- CongaVersion←LDRC.Version
- LDRC.X509Cert.LDRC←LDRC ⍝ reset X509Cert.LDRC reference
- :If 0≠⊃LDRC.SetProp'.' 'EventMode' 1
- r.msg←'Unable to set EventMode on Conga root'
- :EndIf
- ∆END:
- :EndHold
- ∇
-
- ∇ LDRC←r ResolveCongaRef CongaRef;failed;z
- ⍝ Attempt to resolve what CongaRef refers to
- ⍝ CongaRef can be a charvec, reference to the Conga or DRC namespaces, or reference to an iConga instance
- ⍝ LDRC is '' if Conga could not be initialized, otherwise it's a reference to the the Conga.LIB instance or the DRC namespace
-
- LDRC←'' ⋄ failed←0
- :Select nameClass CongaRef ⍝ what is it?
- :Case 9.1 ⍝ namespace? e.g. CongaRef←DRC or Conga
- ∆TRY:
- :Trap Debug↓0
- :If 2 3≢⌊CongaRef.⎕NC'DllVer' 'Init'
- r.msg←'it does not refer to a valid Conga interface'
- →∆EXIT⊣LDRC←''
- :EndIf
- :If ∨/'.Conga'⍷⍕CongaRef ⍝ Conga?
- LDRC←CongaPath CongaRef.Init'HttpCommand'
- :ElseIf 0≡⊃CongaRef.Init CongaPath ⍝ DRC?
- LDRC←CongaRef
- :Else ⍝ should never get to here, but... (paranoia)
- r.msg←'it does not refer to a valid Conga interface'
- →∆EXIT⊣LDRC←''
- :End
- :Else ⍝ if HttpCommand is reloaded and re-executed in rapid succession, Conga initialization may fail, so we try twice
- :If failed
- →∆EXIT⊣LDRC←''⊣r.msg←∊{⍺,(~0∊⍴⍵)/': ',⍵}/⎕DMX.(EM Message)
- :Else
- →∆TRY⊣failed←1
- :EndIf
- :EndTrap
- :Case 9.2 ⍝ instance? e.g. CongaRef←Conga.Init ''
- :If 3=⌊|CongaRef.⎕NC⊂'Clt' ⍝ if it looks like a valid Conga reference
- LDRC←CongaRef ⍝ an instance is already initialized
- :EndIf
- :Case 2.1 ⍝ variable? e.g. CongaRef←'#.Conga'
- :Trap Debug↓0
- :If 9≠z←⎕NC⍕CongaRef
- →∆EXIT⊣r.msg←'CongaRef ',(1+z=0)⊃'is invalid' 'was not found'
- :EndIf
- LDRC←r ResolveCongaRef(⍎∊⍕CongaRef)
- :Else
- r.msg←∊{⍺,(~0∊⍴⍵)/': ',⍵}/⎕DMX.(EM Message)
- :EndTrap
- :EndSelect
- ∆EXIT:
- ∇
-
- ∇ (rc secureParams)←CreateSecureParams certs;cert;flags;priority;public;private;nmt;msg;t
- ⍝ certs is:
- ⍝ cert - X509Cert instance or (PublicCertFile PrivateKeyFile)
- ⍝ flags - SSL flags
- ⍝ priority - GnuTLS priority
- ⍝ public - PublicCertFile
- ⍝ private - PrivateKeyFile
-
- certs←,⊆certs
- (cert flags priority public private)←5↑certs,(≢certs)↓'' 0 'NORMAL:!CTYPE-OPENPGP' '' ''
-
- LDRC.X509Cert.LDRC←LDRC ⍝ make sure the X509 instance points to the right LDRC
-
- :If 0∊⍴cert ⍝ if X509 (or public private) not supplied
- ∆CHECK:
- ⍝ if cert is empty, check PublicCertFile and PrivateKeyFile
- :If ∨/nmt←(~0∊⍴)¨public private ⍝ either file name not empty?
- :If ∧/nmt ⍝ if so, both need to be non-empty
- :If ∨/t←{0::1 ⋄ ~⎕NEXISTS ⍵}¨public private ⍝ either file not exist?
- →∆FAIL⊣msg←'Not found',4↓∊t/'PublicCertFile' 'PrivateKeyFile'{' and ',⍺,' "',(∊⍕⍵),'"'}¨public private
- :EndIf
- :Trap Debug↓0
- cert←⊃LDRC.X509Cert.ReadCertFromFile public
- :Else
- →∆FAIL⊣msg←'Unable to decode PublicCertFile "',(∊⍕public),'" as certificate'
- :EndTrap
- cert.KeyOrigin←'DER'private
- :Else
- →∆FAIL⊣msg←(⊃nmt/'PublicCertFile' 'PrivateKeyFile'),' is empty' ⍝ both must be specified
- :EndIf
- :Else
- cert←⎕NEW LDRC.X509Cert
- :EndIf
- :ElseIf 2=⍴cert ⍝ 2-element vector of public/private file names?
- public private←cert
- →∆CHECK
- :ElseIf {0::1 ⋄ 'X509Cert'≢{⊃⊢/'.'(≠⊆⊢)⍵}⍕⎕CLASS ⍵}cert
- →∆FAIL⊣msg←'Invalid certificate parameter'
- :EndIf
- secureParams←('x509'cert)('SSLValidation'flags)('Priority'priority)
- →rc←0
- ∆FAIL:(rc secureParams)←¯1 msg ⍝ failure
- ∇
-
- ∇ {r}←certs HttpCmd args;url;parms;hdrs;urlparms;p;b;secure;port;host;path;auth;req;err;done;data;datalen;rc;donetime;ind;len;obj;evt;dat;z;msg;timedOut;certfile;keyfile;simpleChar;defaultPort;cookies;domain;t;replace;outFile;toFile;startSize;options;congaPath;progress;starttime;outTn;secureParams;ct;forceClose;headers;cmd;file;protocol;conx;proxied;proxy;cert;noCT;simpleParms;noContentLength;connectionClose;tmpFile;tmpTn;redirected;encoding;compType;isutf8;boundary
- ⍝ issue an HTTP command
- ⍝ certs - X509Cert|(PublicCertFile PrivateKeyFile) SSLValidation Priority PublicCertFile PrivateKeyFile
- ⍝ args - [1] HTTP method
- ⍝ [2] URL in format [HTTP[S]://][user:pass@]url[:port][/path[?query_string]]
- ⍝ {3} parameters is using POST - either a namespace or URL-encoded string
- ⍝ {4} HTTP headers in form {↑}(('hdr1' 'val1')('hdr2' 'val2'))
- ⍝ {5} cookies in form {↑}(('cookie1' 'val1')('cookie2' 'val2'))
- ⍝ Makes secure connection if left arg provided or URL begins with https:
-
- ⍝ Result: namespace containing (conga return code) (HTTP Status) (HTTP headers) (HTTP body) [PeerCert if secure]
- args←,⊆args
- (cmd url parms headers cookies)←args,(⍴args)↓'' ''(⎕NS'')'' ''
-
- :If 0∊⍴cmd ⋄ cmd←'GET' ⋄ :EndIf
-
- r←Result
- toFile←redirected←outTn←tmpTn←0 ⍝ initial settings
- tmpFile←''
-
- url←,url
- url←BaseURL makeURL url
- cmd←uc,cmd
-
- ⍝ Do some cursory parameter checking
- →∆END↓⍨0∊⍴r.msg←'No URL specified'/⍨0∊⍴url ⍝ exit early if no URL
- →∆END↓⍨0∊⍴r.msg←'URL is not a simple character vector'/⍨~isSimpleChar url
- →∆END↓⍨0∊⍴r.msg←'Cookies are not character'/⍨(0∊⍴cookies)⍱1↑isChar cookies
- →∆END↓⍨0∊⍴r.msg←'Headers are not character'/⍨(0∊⍴headers)⍱1↑isChar headers
-
- :If ~RequestOnly ⍝ don't bother initializing Conga if only returning request
- →∆END↓⍨0∊⍴(Initialize r).msg
- :EndIf
-
- ∆GET:
-
- ⍝ do header initialization here because we may return here on a redirect
- :Trap 7
- hdrs←makeHeaders headers
- :Else
- →∆END⊣r.msg←'Improper header format'
- :EndTrap
-
- conx←ConxProps ConnectionProperties r.URL←url
- →∆END↓⍨0∊⍴r.msg←conx.msg
- (protocol secure auth host port path urlparms defaultPort)←conx.(protocol secure auth host port path urlparms defaultPort)
- secure∨←⍲/{0∊⍴⍵}¨certs[1 4] ⍝ we're also secure if we have a cert or a PublicCertFile
-
- :If proxied←~0∊⍴ProxyURL
- :If CongaVersion(~atLeast)3 4 1626 ⍝ Conga build that introduced proxy support
- →∆END⊣r.msg←'Conga version 3.4.1626 or later is required to use a proxy'
- :EndIf
- proxy←ConnectionProperties ProxyURL
- →∆END↓⍨0∊⍴r.msg←proxy.msg
- proxy.headers←makeHeaders ProxyHeaders
- :EndIf
-
- r.(Secure Host Port Path)←secure(lc host)port({{'/',¯1↓⍵/⍨⌽∨\'/'=⌽⍵}⍵↓⍨'/'=⊃⍵}path)
-
- :If ~SuppressHeaders
- hdrs←'Host'(hdrs addHeader)host,((~defaultPort)/':',⍕port)
- hdrs←'User-Agent'(hdrs addHeader)deb'Dyalog-',1↓∊'/',¨2↑Version
- hdrs←'Accept'(hdrs addHeader)'*/*'
- hdrs←'Accept-Encoding'(hdrs addHeader)'gzip, deflate'
-
- :If ~0∊⍴Auth
- :If (1<|≡Auth)∨':'∊Auth ⍝ (userid password) or userid:password
- :AndIf ('basic'≡lc AuthType)∨0∊⍴AuthType
- Auth←Base64Encode ¯1↓∊(,⊆Auth),¨':'
- AuthType←'Basic'
- :EndIf
- hdrs←'Authorization'(hdrs setHeader)deb AuthType,' ',⍕Auth
- :EndIf
-
- :If '∘???∘'≡hdrs getHeader'cookie' ⍝ if the user has specified a cookie header, it takes precedence
- :AndIf ~0∊⍴cookies←r applyCookies Cookies
- hdrs←'Cookie'(hdrs addHeader)formatCookies cookies
- :EndIf
-
- :If ~0∊⍴auth
- hdrs←'Authorization'(hdrs addHeader)auth
- :EndIf
-
- :If 0≠ChunkSize
- hdrs←'Transfer-Encoding'(hdrs addHeader)'chunked'
- :EndIf
-
- :If proxied
- :If ~0∊⍴ProxyAuth
- :If (1<|≡ProxyAuth)∨':'∊ProxyAuth ⍝ (userid password) or userid:password
- :AndIf ('basic'≡lc ProxyAuthType)∨0∊⍴ProxyAuthType
- ProxyAuth←Base64Encode ¯1↓∊(,⊆ProxyAuth),¨':'
- ProxyAuthType←'Basic'
- :EndIf
- proxy.headers←'Proxy-Authorization'(proxy.headers setHeader)deb ProxyAuthType,' ',⍕ProxyAuth
- :EndIf
- :If ~0∊⍴proxy.auth
- proxy.headers←'Proxy-Authorization'(proxy.headers addHeader)proxy.auth
- :EndIf
- :EndIf
- :EndIf
-
- noCT←(0∊⍴ContentType)∧('∘???∘'≡hdrs getHeader'content-type') ⍝ no content-type specified
- :If noCT⍲0∊⍴parms ⍝ do we have any parameters or a content-type
- simpleParms←{2≠⎕NC'⍵':0 ⋄ 1≥|≡⍵}parms ⍝ simple vector or scalar and not a reference
-
- :If (⊆cmd)∊'GET' 'HEAD' ⍝ if the command is GET or HEAD
- :AndIf noCT
- ⍝ params needs to be URLEncoded and will be appended to the query string
- :If simpleParms
- parms←∊⍕parms ⍝ deal with possible numeric
- parms←UrlEncode⍣(~∧/parms∊HttpCommand.ValidFormUrlEncodedChars)⊢parms ⍝ URLEncode if necessary
- :Else ⍝ parms is a namespace or a name/value pairs array
- parms←UrlEncode parms
- :EndIf
-
- urlparms,←(0∊⍴urlparms)↓'&',parms
- parms←''
-
- :Else ⍝ not a GET or HEAD command or content-type has been specified
- :If ~SuppressHeaders
- :If noCT ⍝ no content-type specified, try to work out what it should be
- :If simpleParms ⍝ if parms is simple
- :If (isJSON parms)∨isNum parms ⍝ and looks like JSON or is numeric
- hdrs←'Content-Type'(hdrs addHeader)'application/json;charset=utf-8'
- :Else
- hdrs←'Content-Type'(hdrs addHeader)'application/x-www-form-urlencoded'
- :EndIf
- :Else ⍝ not simpleParms
- hdrs←'Content-Type'(hdrs addHeader)'application/json;charset=utf-8'
- :EndIf
- :ElseIf ~0∊⍴ContentType ⍝ ContentType has been specified
- hdrs←'Content-Type'(hdrs setHeader)ContentType ⍝ it overrides a pre-existing content-type header
- :EndIf
- :EndIf
-
- simpleChar←{1<≢⍴⍵:0 ⋄ (⎕DR ⍵)∊80 82}parms
-
- :Select ⊃';'(≠⊆⊢)lc hdrs getHeader'Content-Type'
- :Case 'application/x-www-form-urlencoded'
- :If ~simpleChar ⍝ if not simple character...
- :OrIf ~∧/parms∊ValidFormUrlEncodedChars ⍝ or not valid URL-encoded
- parms←UrlEncode parms ⍝ encode it
- :EndIf
- :Case 'application/json'
- :If ~isJSON parms ⍝ if it's not already JSON
- parms←JSONexport parms ⍝ JSONify it
- :Else
- parms←SafeJSON parms
- :EndIf
- :Case 'multipart/form-data'
- :If 9.1≠nameClass parms ⍝ must be a namespace
- →∆END⊣r.msg←'Params must be a namespace when using "multipart/form-data" content type'
- :Else
- boundary←50{⍵[?⍺⍴≢⍵]}⎕D,⎕A,⎕C ⎕A
- hdrs←'Content-Type'(hdrs setHeader)'multipart/form-data; boundary=',boundary
- (parms msg)←boundary multipart parms
- :If ~0∊⍴msg
- →∆END⊣r.msg←msg
- :EndIf
- :EndIf
- :Else
- parms←∊⍕parms
- :EndSelect
-
- :Select UseZip
- :Case 1 ⍝ gzip
- :Trap 0
- parms←toChar 2⊃3 ZipLevel Zipper sint parms
- hdrs←'Content-Encoding'(hdrs setHeader)'gzip'
- :Else
- r.msg←'gzip encoding on request payload failed'
- :EndTrap
- :Case 2 ⍝ deflate
- :Trap 0
- parms←toChar 2⊃2 ZipLevel Zipper sint parms
- hdrs←'Content-Encoding'(hdrs setHeader)'deflate'
- :Else
- r.msg←'deflate encoding on request payload failed'
- :EndTrap
- :EndSelect
-
- :If RequestOnly>SuppressHeaders ⍝ Conga supplies content-length, but for RequestOnly we need to insert it
- :AndIf 0=ChunkSize
- hdrs←'Content-Length'(hdrs addHeader)⍕⍴parms
- :EndIf
- :EndIf
- :EndIf
-
- hdrs⌿⍨←~0∊¨≢¨hdrs[;2] ⍝ remove any headers with empty values
-
- :If 0≠ChunkSize
- parms←ChunkSize Chunk parms
- :EndIf
-
- :If RequestOnly
- r←cmd,' ',(path,(0∊⍴urlparms)↓'?',urlparms),' HTTP/1.1',(∊{NL,⍺,': ',∊⍕⍵}/privatize environment hdrs),NL,NL,parms
- →∆EXIT
- :EndIf
-
- (outFile replace)←2↑{⍵,(≢⍵)↓'' 0}eis OutFile
- :If 0=outTn ⍝ if we don't already have an output file tied
- :If toFile←~0∊⍴outFile ⍝ if we're directing the response payload to file
- :Trap Debug↓0
- outFile←1 ⎕NPARTS outFile
- :If ~⎕NEXISTS⊃outFile
- →∆END⊣r.msg←'Output file folder "',(⊃outFile),'" does not exist'
- :EndIf
- :If 0∊⍴∊1↓outFile ⍝ no file name specified, try to use the name from the URL
- :If ~0∊⍴file←∊1↓1 ⎕NPARTS path
- outFile←(⊃outFile),file
- :Else ⍝ no file name specified and none in the URL
- →∆END⊣r.msg←'No file name specified in OutFile or URL'
- :EndIf
- :EndIf
- :If ⎕NEXISTS outFile←∊outFile
- :If (0=replace)∧0≠2 ⎕NINFO outFile
- →∆END⊣r.msg←'Output file "',outFile,'" is not empty'
- :Else
- outTn←outFile ⎕NTIE 0
- {}0 ⎕NRESIZE⍣(1=replace)⊢outTn
- :EndIf
- :Else
- outTn←outFile ⎕NCREATE 0
- :EndIf
- startSize←⎕NSIZE outTn
- r.OutFile←outFile
- tmpFile←tempFolder,'/',(∊1↓1 ⎕NPARTS outFile) ⍝ create temporary file to work with
- tmpTn←tmpFile(⎕NCREATE⍠'Unique' 1)0 ⍝ create with a unique name
- tmpFile←∊1 ⎕NPARTS ⎕NNAMES[⎕NNUMS⍳tmpTn;] ⍝ save the name for ⎕NDELETE later
- :Else
- →∆END⊣r.msg←({⍺,(~0∊⍴⍵)/' (',⍵,')'}/⎕DMX.(EM Message)),' occurred while trying to initialize output file "',(⍕outFile),'"'
- :EndTrap
- :EndIf
- :EndIf
-
- secureParams←''
- :If secure
- :AndIf 0≠⊃(rc secureParams)←CreateSecureParams certs
- →∆END⊣r.(rc msg)←rc secureParams
- :EndIf
-
- :If proxied
- proxy.secureParams←''
- :If proxy.secure
- :AndIf 0≠⊃(rc proxy.secureParams)←CreateSecureParams'' 0
- →∆END⊣r.(rc msg)←rc('PROXY: ',proxy.secureParams)
- :EndIf
- :EndIf
-
- stopIf Debug=2
-
- :If ~0∊⍴Client ⍝ do we have a client already?
- :If 0∊⍴ConxProps ⍝ should never happen (have a client but no connection properties)
- Client←'' ⍝ reset client
- :ElseIf ConxProps.(Host Port Secure certs)≢r.(Host Port Secure),⊂certs ⍝ something's changed, reset
- ⍝ don't set message for same domain
- r.msg←(ConxProps.Host≢over{lc ¯2↑'.'(≠⊆⊢)⍵}r.Host)/'Connection properties changed, connection reset'
- {}{0::'' ⋄ LDRC.Close ⍵}Client
- Client←ConxProps←''
- :ElseIf 'Timeout'≢3⊃LDRC.Wait Client 0 ⍝ nothing changed, make sure client is alive
- Client←ConxProps←'' ⍝ connection dropped, reset
- :EndIf
- :EndIf
-
- starttime←⎕AI[3]
- donetime←⌊starttime+1000×|Timeout ⍝ time after which we'll time out
-
- :If 0∊⍴Client
- options←''
- :If CongaVersion atLeast 3 3
- options←⊂'Options'LDRC.Options.DecodeHttp
- :EndIf
-
- :If ~proxied
- :If 0≠⊃(err Client)←2↑rc←LDRC.Clt''host port'http'BufferSize,secureParams,options
- Client←''
- →∆END⊣r.(rc msg)←err('Conga client creation failed ',,⍕1↓rc)
- :EndIf
- :Else ⍝ proxied
- forceClose←1 ⍝ any error forces client to close, forceClose gets reset later if no proxy connection errors
- ⍝ connect to proxy
- :If 0≠⊃(err Client)←2↑rc←LDRC.Clt''proxy.host proxy.port'http'BufferSize proxy.secureParams,options
- Client←''
- →∆END⊣r.(rc msg)←err('Conga proxy client creation failed ',,⍕1↓rc)
- :EndIf
-
- ⍝ connect to proxied host
- :If 0≠err←⊃rc←LDRC.Send Client('CONNECT'(host,':',⍕port)'HTTP/1.1'proxy.headers'')
- →∆END⊣r.(rc msg)←err('Proxy CONNECT failed: ',⍕1↓rc)
- :EndIf
-
- :If 0≠err←⊃rc←LDRC.Wait Client 1000
- →∆END⊣r.(rc msg)←err('Proxy CONNECT wait failed: ',∊⍕1↓rc)
- :Else
- (err obj evt dat)←4↑rc
- :If evt≢'HTTPHeader'
- →∆END⊣r.(rc msg)←err('Proxy CONNECT did not respond with HTTPHeader event: ',∊⍕1↓rc)
- :EndIf
- :If '200'≢2⊃dat
- r.(msg HttpStatus HttpMessage Headers)←(⊂'Proxy CONNECT response failed'),1↓dat
- r.HttpStatus←⊃toInt r.HttpStatus
- datalen←⊃toInt{0∊⍴⍵:'¯1' ⋄ ⍵}r.GetHeader'Content-Length' ⍝ ¯1 if no content length not specified
- →(datalen≠0)↓∆END,∆LISTEN
- :EndIf
- :EndIf
-
- ⍝ if secure, upgrade to SSL
- :If proxied∧secure
- cert←1 2⊃secureParams
- :AndIf 0≠err←⊃rc←LDRC.SetProp Client'StartTLS'(cert.AsArg,('SSLValidation' 0)('Address'host))
- →∆END⊣r.(rc msg)←err('Proxy failed to upgrade to secure connection: ',∊⍕1↓rc)
- :EndIf
- :EndIf
-
- :If CongaVersion(~atLeast)3 3
- :AndIf 0≠err←⊃rc←LDRC.SetProp Client'DecodeBuffers' 15 ⍝ set to decode HTTP messages
- →∆END⊣r.(rc msg)←err('Could not set DecodeBuffers on Conga client "',Client,'": ',,⍕1↓rc)
- :EndIf
- :EndIf
-
- (ConxProps←⎕NS'').(Host Port Secure certs)←r.(Host Port Secure),⊂certs ⍝ preserve connection settings for subsequent calls
-
- :If 0=⊃rc←LDRC.Send Client(cmd(path,(0∊⍴urlparms)↓'?',urlparms)'HTTP/1.1'(environment hdrs)parms)
-
- ∆LISTEN:
- forceClose←~KeepAlive
- (timedOut done data progress noContentLength connectionClose)←0 0 ⍬ 0 0 0
-
- :Trap 1000 ⍝ in case break is pressed while listening
- :While ~done
- :If ~done←0≠err←1⊃rc←LDRC.Wait Client WaitTime
- (err obj evt dat)←4↑rc
- :Select evt
- :Case 'HTTPHeader'
- :If 1=≡dat
- →∆END⊣r.(rc Data msg)←¯1 dat'Conga failed to parse the response HTTP header' ⍝ HTTP header parsing failed?
- :Else
- r.(HttpVersion HttpStatus HttpMessage Headers)←4↑dat
- r.HttpStatus←toInt r.HttpStatus
- redirected←3=⌊0.01×r.HttpStatus
- datalen←⊃toInt{0∊⍴⍵:'¯1' ⋄ ⍵}r.GetHeader'Content-Length' ⍝ ¯1 if no content length not specified
- connectionClose←'close'≡lc r.GetHeader'Connection'
- noContentLength←datalen=¯1
- done←(cmd≡'HEAD')∨(0=datalen)∨204=r.HttpStatus
- →∆END⍴⍨forceClose←r CheckPayloadSize datalen ⍝ we have a payload size limit
- :EndIf
- :Case 'HTTPBody'
- →∆END⍴⍨forceClose←r CheckPayloadSize(≢data)+≢dat
- :If toFile>redirected ⍝ don't write redirect response payload to file
- →∆END⍴⍨forceClose←r CheckPayloadSize(⎕NSIZE tmpTn)+≢dat
- dat ⎕NAPPEND tmpTn
- ⎕NUNTIE ⍬
- :Else
- data,←dat
- :EndIf
- done←~noContentLength ⍝ if not content-length specified and not chunked - keep listening
- :Case 'HTTPChunk'
- :If 1=≡dat
- →∆END⊣r.(Data msg)←dat'Conga failed to parse the response HTTP chunk' ⍝ HTTP chunk parsing failed?
- :ElseIf toFile>redirected ⍝ don't write redirect response payload to file
- →∆END⍴⍨forceClose←r CheckPayloadSize(⎕NSIZE tmpTn)+≢1⊃dat
- (1⊃dat)⎕NAPPEND tmpTn
- ⎕NUNTIE ⍬
- :Else
- →∆END⍴⍨forceClose←r CheckPayloadSize(≢data)+≢1⊃dat
- data,←1⊃dat
- :EndIf
- :Case 'HTTPTrailer'
- :If 2≠≢⍴dat
- →∆END⊣r.(Data msg)←dat'Conga failed to parse the response HTTP trailer' ⍝ HTTP trailer parsing failed?
- :Else
- r.Headers⍪←dat ⋄ done←1
- :EndIf
- :Case 'HTTPFail'
- data,←dat
- r.Data←data
- r.msg←'Conga could not parse the HTTP reponse'
- →∆END
- :Case 'HTTPError'
- data,←dat
- r.Data←data
- :If noContentLength∧connectionClose
- r.(rc msg)←0 ''
- done←1
- :Else
- rc.msg←'Response payload not completely received'
- →∆END
- :EndIf
- :Case 'BlockLast' ⍝ BlockLast included for pre-Conga v3.4 compatibility for RFC7230 (Sec 3.3.3 item 7)
- →∆END⍴⍨forceClose←r CheckPayloadSize(≢data)+≢dat
- :If toFile0=MaxRedirections ⍝ if redirected and allowing redirections
- :If MaxRedirections<.=¯1,≢r.Redirections ⋄ →∆END⊣r.(rc msg)←¯1('Too many redirections (',(⍕MaxRedirections),')')
- :Else
- :If ''≢url←r.GetHeader'location' ⍝ if we were redirected use the "location" header field for the URL
- :If '/'=⊃url ⋄ url,⍨←host ⋄ :EndIf ⍝ if a relative redirection, use the current host
- r.Redirections,←t←#.⎕NS''
- t.(URL HttpVersion HttpStatus HttpMessage Headers Data)←r.(URL HttpVersion HttpStatus HttpMessage Headers Data)
- {}LDRC.Close Client
- cmd←(1+303=r.HttpStatus)⊃cmd'GET' ⍝ 303 (See Other) is always followed by a 'GET'. See https://developer.mozilla.org/en-US/docs/Web/HTTP/Status/303
- →∆GET
- :Else
- r.msg←'Redirection detected, but no "location" header supplied.' ⍝ should never happen from a properly functioning server
- :EndIf
- :EndIf
- :EndIf
- :If secure
- :AndIf 0=⊃z←LDRC.GetProp Client'PeerCert'
- r.PeerCert←2⊃z
- :EndIf
- :EndIf
- :Else
- :If 1081=⊃rc ⍝ 1081 could be due to an error in Conga that fails on long URLs, so try sending request as a character vector
- :If 0=⊃rc←LDRC.Send Client(cmd,' ',(path,(0∊⍴urlparms)↓'?',urlparms),' HTTP/1.1',NL,(∊': 'NL,⍨¨⍤1⊢hdrs),NL,parms)
- →∆LISTEN
- :EndIf
- :EndIf
- r.msg←'Conga error while attempting to send request: ',,⍕1↓rc
- :EndIf
- r.rc←1⊃rc ⍝ set the return code to the Conga return code
- ∆END:
- ⎕NUNTIE tmpTn,outTn
- {0:: ⋄ ⎕NDELETE ⍵}tmpFile
- Client←{0::'' ⋄ KeepAlive>forceClose:⍵ ⋄ ''⊣LDRC.Close ⍵}Client
- ∆EXIT:
- ∇
-
- ∇ r←size Chunk payload;l;n;last;lens;hlens;mask
- :Access public shared
- ⍝ Split payload into chunks for chunked transfer-encoding
- l←≢payload ⍝ payload length
- n←⌊l÷size ⍝ number of whole chunk
- last←l-n×size ⍝ size of last chunk
- lens←(n⍴size),last,(last≠0)/0 ⍝ chunk lengths + 0 for terminating chunk
- hlens←d2h¨lens ⍝ hex lengths
- mask←0 1 0(⊢⊢⍤/(⍴⊢)⍴⊣),(2+≢¨hlens),lens,[1.1]2 ⍝ expansion mask
- r←mask\payload ⍝ expand payload
- r[⍸~mask]←2⌽∊NL∘,¨hlens,¨⊂NL ⍝ insert chunk information
- ∇
-
- ∇ rc←r CheckPayloadSize size
- ⍝ checks if payload exceeds MaxPayloadSize
- rc←0
- :If MaxPayloadSize≠¯1
- :AndIf size>MaxPayloadSize
- r.(rc msg)←¯1 'Payload length exceeds MaxPayloadSize'
- rc←1
- :EndIf
- ∇
-
- ∇ (timedOut donetime progress)←obj checkTimeOut(donetime progress);tmp;snap
- ⍝ check if request has timed out
- →∆EXIT↓⍨timedOut←⎕AI[3]>donetime ⍝ exit unless donetime hasn't passed
- →∆EXIT↓⍨Timeout<0 ⍝ if Timeout<0, reset donetime if there's progress
- →∆EXIT↓⍨0=⊃tmp←LDRC.Tree obj ⍝ look at the current state of the connection
- snap←2 2⊃tmp ⍝ second element shoulf contain the state
- :If ~0∊⍴snap ⍝ if we have any...
- snap←(⊂∘⍋⌷⊢)↑(↑2 2⊃tmp)[;1] ⍝ ...progress should be in elements [4 5]
- :EndIf
- →∆EXIT⍴⍨progress≡snap ⍝ exit if nothing further received
- (timedOut donetime progress)←0(donetime+WaitTime)snap ⍝ reset ticker
- ∆EXIT:
- ∇
-
- ∇ {r}←type UnzipFile tn;data
- :Access public shared
- ⍝ Unzip an output file
- ⍝ type is compression type: ¯2 for gzip, ¯3 for deflate
- ⍝ tn is the tie number of the file to unzip
- ⍝ r is 0 for success or ⎕EN
- :Trap 0
- data←⎕NREAD tn 83,(⎕NSIZE tn),0
- data←⎕UCS 256|type Zipper data
- 0 ⎕NRESIZE tn
- data ⎕NAPPEND tn
- ⎕NUNTIE ⍬
- r←0
- :Else
- r←⎕EN
- :EndTrap
- ∇
-
- ∇ (payload msg)←boundary multipart parms;name;value;filename;contentType;content
- ⍝ format multipart/form-data payload
- ⍝ parms is a namespace with named objects
- ⍝
- msg←payload←''
- :For name :In parms.⎕NL ¯2
- payload,←'--',boundary
- (value contentType)←2↑(⊆parms⍎name),⊂''
- payload,←NL,'Content-Disposition: form-data; name="',name,'"'
- :If ~0∊⍴contentType
- payload,←NL,'Content-Type: ',contentType
- :EndIf
- :If '@<'∊⍨⊃value
- :If ⎕NEXISTS 1↓value
- :AndIf 2=1 ⎕NINFO 1↓value
- payload,←('@'=⊃value)/'; filename="',(∊¯2↑1 ⎕NPARTS value),'"'
- (contentType content)←contentType readFile 1↓value
- payload,←NL,'Content-Type: ',contentType,NL,NL
- payload,←content,NL
- :Else
- →0⊣msg←'File not found: "',(1↓value),'"'
- :EndIf
- :Else
- payload,←NL,NL,(∊⍕value),NL
- :EndIf
- :EndFor
- payload,←'--',boundary,'--'
- ∇
-
- ∇ (contentType content)←contentType readFile filename;ext;tn
- ⍝ return file content in a manner consistent with multipart/form-data
- :Access public shared
- :If 0∊⍴contentType
- ext←⎕C 3⊃1 ⎕NPARTS filename
- :If ext≡'.txt' ⋄ contentType←'text/plain'
- :Else ⋄ contentType←'application/octet-stream'
- :EndIf
- :EndIf
- tn←filename ⎕NTIE 0
- content←⎕NREAD tn,(⎕DR''),¯1
- ⎕NUNTIE tn
- ∇
-
- NL←⎕UCS 13 10
- toChar←{(⎕DR'')⎕DR ⍵}
- fromutf8←{0::(⎕AV,'?')[⎕AVU⍳⍵] ⋄ 'UTF-8'⎕UCS ⍵} ⍝ Turn raw UTF-8 input into text
- utf8←{3=10|⎕DR ⍵: 256|⍵ ⋄ 'UTF-8' ⎕UCS ⍵}
- sint←{⎕IO←0 ⋄ 83=⎕DR ⍵:⍵ ⋄ 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 ¯128 ¯127 ¯126 ¯125 ¯124 ¯123 ¯122 ¯121 ¯120 ¯119 ¯118 ¯117 ¯116 ¯115 ¯114 ¯113 ¯112 ¯111 ¯110 ¯109 ¯108 ¯107 ¯106 ¯105 ¯104 ¯103 ¯102 ¯101 ¯100 ¯99 ¯98 ¯97 ¯96 ¯95 ¯94 ¯93 ¯92 ¯91 ¯90 ¯89 ¯88 ¯87 ¯86 ¯85 ¯84 ¯83 ¯82 ¯81 ¯80 ¯79 ¯78 ¯77 ¯76 ¯75 ¯74 ¯73 ¯72 ¯71 ¯70 ¯69 ¯68 ¯67 ¯66 ¯65 ¯64 ¯63 ¯62 ¯61 ¯60 ¯59 ¯58 ¯57 ¯56 ¯55 ¯54 ¯53 ¯52 ¯51 ¯50 ¯49 ¯48 ¯47 ¯46 ¯45 ¯44 ¯43 ¯42 ¯41 ¯40 ¯39 ¯38 ¯37 ¯36 ¯35 ¯34 ¯33 ¯32 ¯31 ¯30 ¯29 ¯28 ¯27 ¯26 ¯25 ¯24 ¯23 ¯22 ¯21 ¯20 ¯19 ¯18 ¯17 ¯16 ¯15 ¯14 ¯13 ¯12 ¯11 ¯10 ¯9 ¯8 ¯7 ¯6 ¯5 ¯4 ¯3 ¯2 ¯1[utf8 ⍵]}
- lc←{2::0(819⌶)⍵ ⋄ ¯3 ⎕C ⍵} ⍝ lower case conversion
- uc←{2::1(819⌶)⍵ ⋄ 1 ⎕C ⍵} ⍝ upper case conversion
- ci←{(lc ⍺)⍺⍺ lc ⍵} ⍝ case insensitive operator
- deb←' '∘(1↓,(/⍨)1(⊢∨⌽)0,≠) ⍝ delete extraneous blanks
- dlb←{(+/∧\' '=⍵)↓⍵} ⍝ delete leading blanks
- dltb←{(⌽dlb)⍣2⊢⍵} ⍝ delete leading and trailing blanks
- iotaz←((≢⊣)(≥×⊢)⍳)
- nameClass←{⎕NC⊂,'⍵'} ⍝ name class of argument
- splitOnFirst←{(⍺↑⍨¯1+p)(⍺↓⍨p←⌊/⍺⍳⍵)} ⍝ split ⍺ on first occurrence of ⍵ (removing first ⍵)
- splitOn←≠⊆⊣ ⍝ split ⍺ on all ⍵ (removing ⍵)
- h2d←{⎕IO←0 ⋄ 16⊥'0123456789abcdef'⍳lc ⍵} ⍝ hex to decimal
- d2h←{⎕IO←0 ⋄ '0123456789ABCDEF'[((1∘⌈≢)↑⊢)16(⊥⍣¯1)⍵]} ⍝ decimal to hex
- getchunklen←{¯1=len←¯1+⊃(NL⍷⍵)/⍳⍴⍵:¯1 ¯1 ⋄ chunklen←h2d len↑⍵ ⋄ (⍴⍵)⍵),1} ⍝ checks if ⍺ is at least version ⍵
- Zipper←219⌶
- tempFolder←739⌶0
-
- makeURL←{ ⍝ build URL from BaseURL (⍺) and URL (⍵)
- ~0∊⍴'^https?\:\/\/'⎕S 3⍠('IC' 1)⊢⍵:⍵ ⍝ URL begins with http:// or https://
- 0∊⍴⍺:⍵ ⍝ no BaseURL
- t←'/'=⊃⍵ ⍝ URL begins with '/'?
- '/'=⊃⌽⍺:⍺,t↓⍵ ⍝ BaseURL ends with '/'
- ⍺,t↓'/',⍵ ⍝ insert '/' if not already there
- }
-
- ∇ r←makeHeaders w
- r←{
- 0::¯1 ⍝ any error
- ¯1∊⍵:⍵
- 0∊⍴⍵:0 2⍴⊂'' ⍝ empty
- 1≥|≡⍵:∇{ ⍝ simple array
- 2=⍴⍵:1⊂⍵ ⍝ degenerate case of scalar name and value ('n' 'v' ≡ 'nv')
- dlb¨¨((,⍵)((~∊)⊆⊣)NL)splitOnFirst¨':'
- }⍵
- 2=⍴⍴⍵:{ ⍝ matrix
- 0∊≢¨⍵[;1]:¯1 ⍝ no empty names
- 0 1 1/0,,¨⍵ ⍝ ensure it's 2 columns
- }⍵
- 3=|≡⍵:∇{ ⍝ depth 3
- 2|≢⊃,/⍵:¯1 ⍝ ensure an even number of element
- ↑⍵
- }(eis,)¨⍵
- 2=|≡⍵:∇{
- ∧/':'∊¨⍵:⍵ splitOnFirst¨':'
- ((0.5×⍴⍵),2)⍴⍵
- }⍵
- ¯1
- }w
- 'Invalid Headers format'⎕SIGNAL 7/⍨r≡¯1
- ∇
-
- ∇ r←JSONexport data
- :Trap 11
- r←SafeJSON 1(3⊃⎕RSI,##).⎕JSON data ⍝ attempt to export
- :Else
- r←SafeJSON 1(3⊃⎕RSI,##).⎕JSON⍠'HighRank' 'Split'⊢data ⍝ Dyalog v18.0 and later
- :EndTrap
- ∇
-
- JSONimport←{
- 0::⍵.(rc msg)←¯2 'Could not translate JSON payload'
- 11::⍵.Data←0(3⊃⎕RSI,##).⎕JSON ⍵.Data
- ⍵.Data←0(3⊃⎕RSI,##).⎕JSON⍠'Dialect' 'JSON5'⊢⍵.Data}
-
- ∇ r←GetEnv var
- ⍝ return enviroment variable setting for var
- :Access public shared
- r←2 ⎕NQ'.' 'GetEnvironment'var
- ∇
-
- ∇ r←dyalogRoot
- ⍝ return path to interpreter
- r←{⍵,('/\'∊⍨⊢/⍵)↓'/'}{0∊⍴t←GetEnv'DYALOG':⊃1 ⎕NPARTS⊃2 ⎕NQ'.' 'GetCommandLineArgs' ⋄ t}''
- ∇
-
- ∇ ns←{ConxProps}ConnectionProperties url;p;defaultPort;ind;msg;protocol;secure;auth;host;port;path;urlparms
-
- :If 0=⎕NC'ConxProps' ⋄ ConxProps←'' ⋄ :EndIf
-
- ns←⎕NS''
- msg←''
- (protocol secure host path urlparms)←ConxProps parseURL url
-
- :If ~(⊂protocol)∊'' 'http:' 'https:'
- →∆END⊣msg←'Invalid protocol: ',¯1↓protocol
- :EndIf
-
- auth←''
- :If 0≠p←¯1↑⍸host='@' ⍝ Handle user:password@host...
- auth←('Basic ',(Base64Encode(p-1)↑host))
- host←p↓host
- :EndIf
-
- ⍝ This next section is a chicken and egg scenario trying to figure out
- ⍝ whether to use HTTPS as well as what port to use
-
- :If defaultPort←(≢host)0)∧(port≤65535)∧port=⌊port
- →∆END⊣msg←'Invalid port: ',⍕port
- :EndIf
-
- secure∨←(0∊⍴protocol)∧port=443 ⍝ if just port 443 was specified, without any protocol, use SSL
-
- :If defaultPort∧secure
- port←443
- :EndIf
-
- ns.(protocol secure auth host port path urlparms defaultPort)←protocol secure auth host port path urlparms defaultPort
-
- ∆END:
- ns.msg←msg
- ∇
-
- ∇ (protocol secure host path urlparms)←{conx}parseURL url;path;p;ind
- ⍝ Parses a URL and returns
- ⍝ secure - Boolean whether running HTTPS or not based on leading http://
- ⍝ host - domain or IP address
- ⍝ path - path on the host for the requested resource, if any
- ⍝ urlparms - URL query string, if any
- :If 0=⎕NC'conx' ⋄ conx←'' ⋄ :EndIf
- (url urlparms)←2↑(url splitOnFirst'?'),⊂''
- p←⍬⍴2+⍸<\'://'⍷url
- protocol←lc(0⌈p-2)↑url
- secure←protocol beginsWith'https:'
- url←p↓url ⍝ Remove HTTP[s]:// if present
- (host path)←url splitOnFirst'/' ⍝ Extract host and path from url
- ind←host iotaz'@' ⍝ any credentials?
- host←(ind↑host),lc ind↓host ⍝ host (domain) is case-insensitive (credentials are not)
- :If ~0∊⍴conx ⍝ if we have an existing connection
- :AndIf 0∊⍴protocol ⍝ and no protocol was specified
- secure←(conx.Host≡host)∧conx.Secure ⍝ use the protocol from the existing connection
- :EndIf
- path←'/',∊(⊂'%20')@(=∘' ')⊢path ⍝ convert spaces in path name to %20
- ∇
-
- ∇ r←parseHttpDate date;d
- ⍝ Parses a RFC 7231 format date (Ddd, DD Mmm YYYY hh:mm:ss GMT)
- ⍝ returns Extended IDN format
- ⍝ this function does almost no validation of its input, we expect a properly formatted date
- ⍝ ill-formatted dates return ⍬
- :Trap 0
- d←{⍵⊆⍨⍵∊⎕A,⎕D}uc date
- r←1 0 1 1 1 1\toInt¨d[4 2 5 6 7]
- r[2]←(3⊃d)⍳⍨12 3⍴'JANFEBMARAPRMAYJUNJULAUGSEPOCTNOVDEC'
- r←TStoIDN r
- :Else
- r←⍬
- :EndTrap
- ∇
-
- ∇ idn←TStoIDN ts
- ⍝ Convert timestamp to extended IDN format
- :Trap 2 11 ⍝ syntax error if pre-v18.0, domain error if
- idn←¯1 1 ⎕DT⊂ts
- :Else
- idn←(2 ⎕NQ'.' 'DateToIDN'(3↑ts))+(24 60 60 1000⊥4↑3↓ts)÷86400000
- :EndTrap
- ∇
-
- ∇ ts←IDNtoTS idn
- ⍝ Convert extended IDN to timestamp
- :Trap 2 ⍝ syntax error if pre-v18.0
- ts←⊃1 ¯1 ⎕DT idn
- :Else
- ts←3↑2 ⎕NQ'.' 'IDNToDate'(⌊idn)
- ts,←⌊0.5+24 60 60 1000⊤86400000×1|⍬⍴idn
- :EndTrap
- ∇
-
- ∇ idn←Now
- ⍝ Return extended IDN for current time
- idn←TStoIDN ⎕TS
- ∇
-
- ∇ cookies←parseCookies(headers host path);cookie;segs;setcookie;seg;value;name;domain
- ⍝ Parses set-cookie headers into cookie array
- ⍝ Attempts to follow RFC6265 https://datatracker.ietf.org/doc/html/rfc6265
- cookies←⍬
- :For setcookie :In headers tableGet'set-cookie'
- segs←dltb¨¨2↑¨'='splitOnFirst⍨¨dltb¨setcookie splitOn';'
- (cookie←#.⎕NS'').(Name Value Host Domain Path HttpOnly Secure Expires SameSite Creation Other)←'' ''host'' '/' 0 0 '' ''Now''
- →∆NEXT⍴⍨0∊≢¨cookie.(Name Value)←⊃segs
- segs←1↓segs
-
- segs/⍨←⌽(⍳∘≢=⍳⍨)⌽lc⊃¨segs ⍝ select the last occurence of each attribute
- :For name value :In segs
- :Select lc name
- :Case 'expires'
- :If ''≡cookie.Expires ⍝ if Expires was set already from MaxAge, MaxAge takes precedence
- →∆NEXT⍴⍨0∊⍴cookie.Expires←parseHttpDate value ⍝ ignore cookies with invalid expires dates
- :EndIf
- :Case 'max-age' ⍝ specifies number of seconds after which cookie expires
- cookie.Expires←Now+seconds toInt value
- :Case 'domain' ⍝ RCF 6265 Sec. 5.2.3
- →∆NEXT⍴⍨0∊⍴domain←lc value ⍝ cookies with empty domain values are ignored
- :If domain≡host
- domain←host
- :ElseIf host endsWith domain←('.'=⊃domain)↓'.',domain
- cookie.Domain←domain
- :Else ⋄ →∆NEXT
- :EndIf
- :Case 'path' ⍝ RCF 6265 Sec. 5.2.4
- :If '/'=⊃value ⋄ cookie.Path←value ⋄ :EndIf
- :Case 'secure' ⋄ cookie.Secure←1
- :Case 'httponly' ⋄ cookie.HttpOnly←1
- :Case 'samesite' ⋄ cookie.SameSite←value
- :Else ⋄ cookie.Other,←⊂dltb¨name value ⍝ catch all in case something else was sent with cookie
- :EndSelect
- :EndFor
- cookies,←cookie
- ∆NEXT:
- :EndFor
- ∇
-
- NotExpired←{
- 0∊⍴⍵.Expires:1
- Now≤⍵.Expires
- }
-
- domainMatch←{
- ⍝ ⍺ - host, ⍵ - cookie.(domain host)
- dom←(1+0∊⍴1⊃⍵)⊃⍵
- ⍺≡dom:1
- (⍺ endsWith dom)∧'.'=⊃dom
- }
-
- pathMatch←{
- ⍝ ⍺ - requested path, ⍵ - cookie path
- ⍺ beginsWith ⍵
- }
-
- ∇ cookies←cookies updateCookies new;cookie;ind
- ⍝ update internal cookies based on result of ParseCookies
- :If 0∊⍴cookies
- cookies←new
- :Else
- :For cookie :In new
- :If 0≠ind←cookies.Name iotaz⊂cookie.Name
- :If 0∊⍴cookie.Value ⍝ deleted cookie?
- cookie←(ind≠⍳≢cookies)/cookies
- :Else
- cookies[ind]←cookie
- :EndIf
- :Else
- cookies,←cookie
- :EndIf
- :EndFor
- :EndIf
- :If ~0∊⍴cookies
- cookies/⍨←NotExpired¨cookies ⍝ remove any expired cookies
- :EndIf
- ∇
-
- ∇ r←state applyCookies cookies;mask
- ⍝ return which cookies to send based on current request and
- r←⍬
- →0⍴⍨0∊⍴mask←1⍴⍨≢cookies ⍝ exit if no cookies
- →0↓⍨∨/mask∧←cookies.Secure≤state.Secure ⍝ HTTPS only filter
- →0↓⍨∨/mask←mask\state.Host∘domainMatch¨mask/cookies.(Domain Host)
- →0↓⍨∨/mask←mask\state.Path∘pathMatch¨mask/cookies.Path
- →0↓⍨∨/mask←mask\NotExpired¨mask/cookies
- r←mask/cookies
- ∇
-
- ∇ r←formatCookies cookies
- r←2↓∊cookies.('; ',Name,'=',Value)
- ∇
-
- ∇ {r}←name AddHeader value;hdrs
- ⍝ add a header unless it's already defined
- :Access public
- :Trap 7
- r←Headers←name(Headers addHeader)value
- :Else
- ⎕EM ⎕SIGNAL ⎕EN
- :EndTrap
- ∇
-
- ∇ hdrs←name(hdrs addHeader)value
- ⍝ add a header unless it's already defined
- hdrs←makeHeaders hdrs
- hdrs⍪←('∘???∘'≡hdrs getHeader name)⌿⍉⍪name value
- ∇
-
- ∇ {r}←name SetHeader value;ind
- ⍝ set a header value, overwriting any existing one
- :Access public
- :Trap 7
- r←Headers←name(Headers setHeader)value
- :Else
- ⎕EM ⎕SIGNAL ⎕EN
- :EndTrap
- ∇
-
- ∇ hdrs←name(hdrs setHeader)value;ind
- hdrs←makeHeaders hdrs
- ind←hdrs[;1](⍳ci)eis name
- hdrs↑⍨←ind⌈≢hdrs
- hdrs[ind;]←name(⍕value)
- ∇
-
- ∇ {r}←RemoveHeader name
- ⍝ remove a header
- :Access public
- :Trap 7
- Headers←makeHeaders Headers
- :Else
- ⎕EM ⎕SIGNAL ⎕EN
- :EndTrap
- Headers⌿⍨←Headers[;1](≢¨ci)eis name
- r←Headers
- ∇
-
- ∇ hdrs←environment hdrs;beg;end;escape;hits;regex
- ⍝ substitute any header names or values that begin with '$env:' with the named environment variable
- :If ~0∊⍴HeaderSubstitution
- (beg end)←2⍴HeaderSubstitution
- escape←'.^$*+?()[]{\|-'∘{m←∊(1+⍺∊⍨t←⌽⍵)↑¨1 ⋄ t←m\t ⋄ t[⍸~m]←'\' ⋄ ⌽t} ⍝ chars that need escaping in regex
- regex←(escape beg),'[[:alpha:]].*?',escape end
- hdrs←(⍴hdrs)⍴regex ⎕R{0∊⍴e←GetEnv(≢beg)↓(-≢end)↓⍵.Match:⍵.Match ⋄ e}⊢,hdrs
- :EndIf
- ∇
-
- ∇ hdrs←privatize hdrs
- ⍝ suppress displaying Authorization header value if Private=1
- :If Secret
- hdrs[⍸hdrs[;1](∊ci)'Authorization' 'Proxy-Authorization';2]←⊂'>>> Secret setting is 1 <<<'
- :EndIf
- ∇
-
- ∇ r←{a}eis w;f
- ⍝ enclose if simple
- f←{⍺←1 ⋄ ,(⊂⍣(⍺=|≡⍵))⍵}
- :If 0=⎕NC'a' ⋄ r←f w
- :Else ⋄ r←a f w
- :EndIf
- ∇
-
- base64←{(⎕IO ⎕ML)←0 1 ⍝ from dfns workspace - Base64 encoding and decoding as used in MIME.
- chars←'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/'
- bits←{,⍉(⍺⍴2)⊤⍵} ⍝ encode each element of ⍵ in ⍺ bits, and catenate them all together
- part←{((⍴⍵)⍴⍺↑1)⊂⍵} ⍝ partition ⍵ into chunks of length ⍺
- 0=2|⎕DR ⍵:2∘⊥∘(8∘↑)¨8 part{(-8|⍴⍵)↓⍵}6 bits{(⍵≠64)/⍵}chars⍳⍵ ⍝ decode a string into octets
- four←{ ⍝ use 4 characters to encode either
- 8=⍴⍵:'=='∇ ⍵,0 0 0 0 ⍝ 1,
- 16=⍴⍵:'='∇ ⍵,0 0 ⍝ 2
- chars[2∘⊥¨6 part ⍵],⍺ ⍝ or 3 octets of input
- }
- cats←⊃∘(,/)∘((⊂'')∘,) ⍝ catenate zero or more strings
- cats''∘four¨24 part 8 bits ⍵
- }
-
- ∇ r←{cpo}Base64Encode w
- ⍝ Base64 Encode
- ⍝ Optional cpo (code points only) suppresses UTF-8 translation
- ⍝ if w is integer skip any conversion
- :Access public shared
- :If (⎕DR w)∊83 163 ⋄ r←base64 w
- :ElseIf 0=⎕NC'cpo' ⋄ r←base64'UTF-8'⎕UCS w
- :Else ⋄ r←base64 ⎕UCS w
- :EndIf
- ∇
-
- ∇ r←{cpo}Base64Decode w
- ⍝ Base64 Decode
- ⍝ Optional cpo (code points only) suppresses UTF-8 translation
- :Access public shared
- :If 0=⎕NC'cpo' ⋄ r←'UTF-8'⎕UCS base64 w
- :Else ⋄ r←⎕UCS base64 w
- :EndIf
- ∇
-
- ∇ r←DecodeHeader buf;len;d
- ⍝ Decode HTTP Header
- r←0(0 2⍴⊂'')
- :If 0 'name=fred&type=student'
- ⍝ - a namespace containing variable(s) to be encoded
- ⍝ r is a character vector of the URLEncoded data
-
- :Access Public Shared
- ⎕IO←0
- format←{
- 1=≡⍵:⍺(,⍕⍵)
- ↑⍺∘{⍺(,⍕⍵)}¨⍵
- }
- :If 0=⎕NC'name' ⋄ name←'' ⋄ :EndIf
- noname←0
- :If 9.1=⎕NC⊂'data'
- data←⊃⍪/{0∊⍴t←⍵.⎕NL ¯2:'' ⋄ ⍵{⍵ format ⍺⍎⍵}¨t}data
- :Else
- :Select |≡data
- :CaseList 0 1
- :If 1≥|≡data
- noname←0∊⍴name
- data←name(,data)
- :EndIf
- :Case 3 ⍝ nested name/value pairs (('abc' '123')('def' '789'))
- data←⊃,/data
- :EndSelect
- :EndIf
- hex←'%',¨,∘.,⍨⎕D,6↑⎕A
- xlate←{
- i←⍸~⍵∊'abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789-_.~*'
- 0∊⍴i:⍵
- ∊({⊂∊hex['UTF-8'⎕UCS ⍵]}¨⍵[i])@i⊢⍵
- }
- data←xlate∘⍕¨data
- r←noname↓¯1↓∊data,¨(⍴data)⍴'=&'
- ∇
-
- ∇ r←UrlDecode r;rgx;rgxu;i;j;z;t;m;⎕IO;lens;fill
- :Access public shared
- ⎕IO←0
- ((r='+')/r)←' '
- rgx←'[0-9a-fA-F]'
- rgxu←'%[uU]',(4×⍴rgx)⍴rgx ⍝ 4 characters
- r←(rgxu ⎕R{{⎕UCS 16⊥⍉16|'0123456789ABCDEF0123456789abcdef'⍳⍵}2↓⍵.Match})r
- :If 0≠⍴i←(r='%')/⍳⍴r
- :AndIf 0≠⍴i←(i≤¯2+⍴r)/i
- z←r[j←i∘.+1 2]
- t←'UTF-8'⎕UCS 16⊥⍉16|'0123456789ABCDEF0123456789abcdef'⍳z
- lens←⊃∘⍴¨'UTF-8'∘⎕UCS¨t ⍝ UTF-8 is variable length encoding
- fill←i[¯1↓+\0,lens]
- r[fill]←t
- m←(⍴r)⍴1 ⋄ m[(,j),i~fill]←0
- r←m/r
- :EndIf
- ∇
-
- ∇ w←SafeJSON w;i;c;⎕IO
- ⍝ Convert Unicode chars to \uXXXX
- ⎕IO←0
- →0⍴⍨0∊⍴i←⍸127⊃⍵:1 ⍝ newer version
- (⊃⍺)=⊃⍵:(1↓⍺)∇ 1↓⍵
- ¯1 ⍝ older version
- }
- {}LDRC.Close'.' ⍝ close Conga
- LDRC←'' ⍝ reset local reference so that Conga gets reloaded
- :Trap Debug↓0
- ns←⎕NS''
- code←{⍵⊆⍨~⍵∊⎕UCS 13 10 65279}'UTF-8'⎕UCS ⎕UCS z.Data
- vers←(0 ns.⎕FIX code).Version Version
- :If 1=⊃newer/{2⊃'.'⎕VFI 2⊃⍵}¨vers
- ##.⎕FIX code
- (rc msg)←1(deb⍕,'Upgraded to' 'from',⍪vers)
- :Else
- (rc msg)←0(deb⍕'Already using the most current version: ',2⊃vers)
- :EndIf
- :Else
- msg←'Could not ⎕FIX new HttpCommand: ',2↓∊': '∘,¨⎕DMX.(EM Message)
- :EndTrap
- :Else
- r←¯1('Unexpected ',⊃{⍺,' at ',⍵}/2↑⎕DMX.DM)
- :EndTrap
- ∇
-:EndClass
diff --git a/packages/Jarvis.dyalog b/packages/Jarvis.dyalog
deleted file mode 100644
index 4af5692..0000000
--- a/packages/Jarvis.dyalog
+++ /dev/null
@@ -1,2209 +0,0 @@
-:Class Jarvis
-⍝ Dyalog Web Service Server
-⍝ See https://dyalog.github.io/Jarvis for documentation
-
- (⎕ML ⎕IO)←1 1
-
- ∇ r←Version
- :Access public shared
- r←'Jarvis' '1.18.5' '2025-02-05'
- ∇
-
- ∇ Documentation
- :Access public shared
- ⎕←'See https://dyalog.github.io/Jarvis'
- ∇
-
- ⍝ User hooks settings
- :Field Public AppCloseFn←'' ⍝ name of the function to run on application (server) shutdown
- :Field Public AppInitFn←'' ⍝ name of the application "bootstrap" function
- :Field Public AuthenticateFn←'' ⍝ name of function to perform authentication,if empty, no authentication is necessary
- :Field Public SessionInitFn←'' ⍝ Function name to call when initializing a session
- :Field Public ValidateRequestFn←'' ⍝ name of the request validation function
-
- ⍝ Operational settings
- :Field Public CodeLocation←'#' ⍝ reference to application code location, if the user specifies a folder or file, that value is saved in CodeSource
- :Field Public ConnectionTimeout←30 ⍝ HTTP/1.1 connection timeout in seconds
- :Field Public Debug←0 ⍝ 0 = all errors are trapped, 1 = stop on an error, 2 = stop on intentional error before processing request, 4 = Jarvis framework debugging, 8 = Conga event logging
- :Field Public DefaultContentType←'application/json; charset=utf-8'
- :Field Public ErrorInfoLevel←1 ⍝ level of information to provide if an APL error occurs, 0=none, 1=⎕EM, 2=⎕SI
- :Field Public Hostname←'' ⍝ external-facing host name
- :Field Public HTTPAuthentication←'basic' ⍝ valid settings are currently 'basic' or ''
- :Field Public JarvisConfig←'' ⍝ configuration file path (if any). This parameter was formerly named ConfigFile
- :Field Public LoadableFiles←'*.apl?,*.dyalog' ⍝ file patterns that can be loaded if loading from folder
- :Field Public Logging←1 ⍝ turn logging on/off
- :Field Public Paradigm←'JSON' ⍝ either 'JSON' or 'REST'
- :Field Public Report404InHTML←1 ⍝ Report HTTP 404 status (not found) in HTML (only valid if HTML interface is enabled)
- :Field Public UseZip←0 ⍝ Use compression if client allows it, 0- don't compress, 0<- compress if UseZip≤≢payload
- :Field Public ZipLevel←3 ⍝ default compression level (0-9)
- :Field APLVersion ⍝ Dyalog APL major.minor version number
- :Field TokenBase←0 ⍝ base for tokens (possibly updated in Start if ⎕TALLOC is available)
-
- ⍝ Container-related settings
- :Field Public DYALOG_JARVIS_THREAD←'' ⍝ 0 = Run in thread 0, 1 = Use separate thread and ⎕TSYNC, 'DEBUG' = Use separate thread and return to immediate execution, "AUTO" = if InTerm use "DEBUG" otherwise 1
- :Field Public DYALOG_JARVIS_CODELOCATION←'' ⍝ If supplied, overrides CodeLocation in config file
- :Field Public DYALOG_JARVIS_PORT←'' ⍝ If supplied, overrides Port both default port and config file
-
- ⍝ Session settings
- :Field Public SessionIdHeader←'Jarvis-SessionID' ⍝ Name of the header field for the session token
- :Field Public SessionUseCookie←0 ⍝ 0 - just use the header; 1 - use an HTTP cookie
- :Field Public SessionPollingTime←1 ⍝ how frequently (in minutes) we should poll for timed out sessions
- :Field Public SessionTimeout←0 ⍝ 0 = do not use sessions, ¯1 = no timeout , 0< session timeout time (in minutes)
- :Field Public SessionCleanupTime←60 ⍝ how frequently (in minutes) do we clean up timed out session info from _sessionsInfo
-
- ⍝ JSON mode settings
- :Field Public AllowFormData←0 ⍝ do we allow POST form data in JSON paradigm?
- :Field Public AllowGETs←0 ⍝ do we allow calling endpoints with HTTP GETs?
- :Field Public HTMLInterface←¯1 ⍝ ¯1=unassigned, 0/1=dis/allow the HTML interface, 'Path to HTML[/home-page]', or '' 'fn'
- :Field Public JSONInputFormat←'D' ⍝ set this to 'M' to have Jarvis convert JSON request payloads to the ⎕JSON matrix format
-
- ⍝ REST mode settings
- :Field Public ParsePayload←1 ⍝ 1=parse request payload based on content-type header (REST only)
- :Field Public RESTMethods←'Get,Post,Put,Delete,Patch,Options'
-
- ⍝ CORS settings
- :Field Public EnableCORS←1 ⍝ set to 0 to disable CORS
- :Field Public CORS_Origin←'*' ⍝ default value for Access-Control-Allow-Origin header (set to 1 to reflect request Origin)
- :Field Public CORS_Methods←¯1 ⍝ ¯1 = set based on paradigm, 1 = reflect the request's requested method
- :Field Public CORS_Headers←'*' ⍝ default value for Access-Control-Allow-Headers header (set to 1 to reflect request Headers)
- :Field Public CORS_MaxAge←60 ⍝ default value (in seconds) for Access-Control-Max-Age header
-
- ⍝ Conga-related settings
- :Field Public AcceptFrom←⍬ ⍝ Conga: IP addresses to accept requests from - empty means accept from any IP address
- :Field Public BufferSize←10000 ⍝ Conga: buffer size
- :Field Public DenyFrom←⍬ ⍝ Conga: IP addresses to refuse requests from - empty means deny none
- :Field Public DOSLimit←¯1 ⍝ Conga: DOSLimit, ¯1 means use default
- :Field Public FIFO←1 ⍝ Conga: Use FIFO mode?
- :Field Public Port←8080 ⍝ Conga: Default port to listen on
- :Field Public RootCertDir←'' ⍝ Conga: Root CA certificate folder
- :field Public Priority←'NORMAL:!CTYPE-OPENPGP' ⍝ Conga: Priorities for GnuTLS when negotiation connection
- :Field Public Secure←0 ⍝ 0 = use HTTP, 1 = use HTTPS
- :field Public ServerCertSKI←'' ⍝ Conga: Server cert's Subject Key Identifier from store
- :Field Public ServerCertFile←'' ⍝ Conga: public certificate file
- :Field Public ServerKeyFile←'' ⍝ Conga: private key file
- :Field Public ServerName←'' ⍝ Server name, '' means Conga assigns it
- :Field Public SSLValidation←64 ⍝ Conga: request, but do not require a client certificate
- :Field Public WaitTimeout←15000 ⍝ ms to wait in LDRC.Wait
-
- :Field Public Shared LDRC←'' ⍝ Jarvis-set reference to Conga after CongaRef has been resolved
- :Field Public Shared CongaPath←'' ⍝ user-supplied path to Conga workspace and/or shared libraries
- :Field Public Shared CongaRef←'' ⍝ user-supplied reference to Conga library instance
- :Field CongaVersion←'' ⍝ Conga version
-
- :Property CodeSource
- :Access Public
- ∇ r←get
- r←_codeSource
- ∇
- :EndProperty
-
- ⍝ IncludeFns/ExcludeFns Properties
- :Property IncludeFns, ExcludeFns
- ⍝ IncludeFns and ExcludeFns are vectors the defined endpoint (function) names to expose or hide respectively
- ⍝ They can be function names, simple wildcarded patterns (e.g. 'Foo*'), or regex
- :Access Public
- ∇ r←get ipa
- r←⍎'_',ipa.Name
- ∇
- ∇ set ipa
- :Select ipa.Name
- :Case 'IncludeFns'
- _includeRegex←makeRegEx¨(⊂'')~⍨∪,⊆_IncludeFns←ipa.NewValue
- :Case 'ExcludeFns'
- _excludeRegex←makeRegEx¨(⊂'')~⍨∪,⊆_ExcludeFns←ipa.NewValue
- :EndSelect
- ∇
- :EndProperty
-
- ⍝↓↓↓ some of these private fields are also set in ∇init so that a server can be stopped, updated, and restarted
- :Field _rootFolder←'' ⍝ root folder for relative file paths
- :Field _codeSource←'' ⍝ file or folder that code was loaded from, if applicable
- :Field _configLoaded←0 ⍝ indicates whether config was already loaded by Autostart
- :Field _htmlFolder←'' ⍝ folder containing HTML interface files, if any
- :Field _htmlDefaultPage←'index.html' ⍝ default page name if HTMLInterface is set to serve from a folder
- :Field _htmlEnabled←0 ⍝ is the HTML interface enabled?
- :Field _htmlRootFn←'' ⍝ function name if serving HTML root from a function rather than file
- :Field _stop←0 ⍝ set to 1 to stop server
- :Field _started←0 ⍝ is the server started
- :Field _stopped←1 ⍝ is the server stopped
- :field _paused←0 ⍝ is the server paused
- :Field _sessionThread←¯1 ⍝ thread for the session cleanup process
- :Field _serverThread←¯1 ⍝ thread for the HTTP server
- :Field _taskThreads←⍬ ⍝ vector of thread handling requests
- :Field _sessions←⍬ ⍝ vector of session namespaces
- :Field _sessionsInfo←0 5⍴'' '' 0 0 0 ⍝ [;1] id [;2] ip addr [;3] creation time [;4] last active time [;5] ref to session
- :Field _IncludeFns←'' ⍝ private IncludeFns
- :Field _ExcludeFns←'' ⍝ private ExcludeFns
- :Field _includeRegex←'' ⍝ private compiled regex from _IncludeFns
- :Field _excludeRegex←'' ⍝ private compiled regex from _ExcludeFns
- :Field _connections ⍝ namespace containing open connections
-
- ∇ r←Config
- ⍝ returns current configuration
- :Access public
- r←↑{⍵(⍎⍵)}¨⎕THIS⍎'⎕NL ¯2.2 ¯2.1 ¯2.3'
- ∇
-
- ∇ r←{value}DebugLevel level
- ⍝ monadic: return 1 if level is within Debug (powers of 2)
- ⍝ example: stopIf DebugLevel 2 ⍝ sets a stop if Debug contains 2
- ⍝ dyadic: return value unless level is within Debug (powers of 2)
- ⍝ example: :Trap 0 DebugLevel 5 ⍝ set Trap 0 unless Debug contains 1 or 4 in its
- r←∨/(2 2 2 2⊤⊃Debug)∨.∧2 2 2 2⊤level
- :If 0≠⎕NC'value'
- r←value/⍨~r
- :EndIf
- ∇
-
- ∇ r←Thread
- ⍝ return the thread that the server is running in
- :Access public
- r←_serverThread
- ∇
-
- ∇ {msg}←{level}Log msg;ts;fmsg
- :Access public overridable
- :If Logging>0∊⍴msg
- ts←((ErrorInfoLevel=2)/(2⊃⎕SI),'[',(⍕2⊃⎕LC),'] '),fmtTS ⎕TS
- :If 1=≢⍴fmsg←⍕msg
- :OrIf 1=⊃⍴fmsg
- fmsg←ts,' - ',fmsg
- :Else
- fmsg←ts,∊(⎕UCS 13),fmsg
- :EndIf
- ⎕←fmsg
- :EndIf
- ∇
-
- ∇ r←New arg
- ⍝ create a new instance of Jarvis
- :Access public shared
- :If 0∊⍴arg
- r←##.⎕NEW ⎕THIS
- :Else
- r←##.⎕NEW ⎕THIS arg
- :EndIf
- ∇
-
- ∇ make
- :Access public
- :Implements constructor
- MakeCommon
- ∇
-
- ∇ make1 args;rc;msg;char;t
- :Access public
- :Implements constructor
- ⍝ args is one of
- ⍝ - a simple character vector which is the name of a configuration file
- ⍝ - a reference to a namespace containing named configuration settings
- ⍝ - a depth 1 or 2 vector of
- ⍝ [1] integer port to listen on
- ⍝ [2] charvec function folder or ref to code location
- ⍝ [3] paradigm to use ('JSON' or 'REST')
- MakeCommon
- :If char←isChar args ⍝ character argument? it's either config filename or CodeLocation folder
- :If ~⎕NEXISTS args
- →0⊣Log'Unable to find "',args,'"'
- :ElseIf 2=t←1 ⎕NINFO args ⍝ normal file
- :If (lc⊢/⎕NPARTS args)∊'.json' '.json5' ⍝ json files are configuration
- :If 0≠⊃(rc msg)←LoadConfiguration JarvisConfig←args
- Log'Error loading configuration: ',msg
- :EndIf
- :Else
- CodeLocation←args ⍝ might be a namespace script or class
- :EndIf
- :ElseIf 1=t ⍝ folder means it's CodeLocation
- CodeLocation←args
- :Else ⍝ not a file or folder
- Log'Invalid constructor argument "',args,'"'
- :EndIf
- :ElseIf 9.1={⎕NC⊂,'⍵'}args ⍝ namespace?
- :If 0≠⊃(rc msg)←LoadConfiguration args
- Log'Error loading configuration: ',msg
- :EndIf
- :Else
- :If 326=⎕DR args
- :AndIf 0∧.=≡¨2↑args ⍝ if 2↑args is (port ref) (both scalar)
- args[1]←⊂,args[1] ⍝ nest port so ∇default works properly
- :EndIf
-
- (Port CodeLocation Paradigm JarvisConfig)←args default Port CodeLocation Paradigm JarvisConfig
- :EndIf
- ∇
-
- ∇ MakeCommon
- APLVersion←⊃⊃(//)⎕VFI{⍵/⍨2>+\'.'=⍵}2⊃#.⎕WG'APLVersion'
- :Trap 11
- JSONin←0 ##.##.⎕JSON⍠('Dialect' 'JSON5')('Format'JSONInputFormat)⊢ ⋄ {}JSONin'1'
- JSONout←1 ##.##.⎕JSON⍠'HighRank' 'Split'⊢ ⋄ {}JSONout 1
- JSONread←0 ##.##.⎕JSON⍠'Dialect' 'JSON5'⊢ ⍝ for reading configuration files
- :Else
- JSONin←0 ##.##.⎕JSON⍠('Format'JSONInputFormat)⊢
- JSONout←1 ##.##.⎕JSON⊢
- JSONread←0 ##.##.⎕JSON⊢
- :EndTrap
- ∇
-
- ∇ r←args default defaults
- args←,⊆args
- r←(≢defaults)↑args,(≢args)↓defaults
- ∇
-
- ∇ Close
- :Implements destructor
- {0:: ⋄ {}LDRC.Close ServerName}⍬
- ∇
-
- ∇ r←Run args;msg;rc
- ⍝ args is one of
- ⍝ - a simple character vector which is the name of a configuration file
- ⍝ - a reference to a namespace containing named configuration settings
- ⍝ - a depth 1 or 2 vector of
- ⍝ [1] integer port to listen on
- ⍝ [2] charvec function folder or ref to code location
- ⍝ [3] paradigm to use ('JSON' or 'REST')
- :Access shared public
- :Trap 0
- (rc msg)←(r←New args).Start
- :Else
- (r rc msg)←'' ¯1 ⎕DMX.EM
- :EndTrap
- r←(r(rc msg))
- ∇
-
- ∇ (rc msg)←Start;html;homePage;t
- :Access public
- :Trap 0 DebugLevel 1
- Log'Starting ',⍕2↑Version
- :If _started
- :If 0(,2)≡LDRC.GetProp ServerName'Pause'
- rc←1⊃LDRC.SetProp ServerName'Pause' 0
- →0 If(rc'Failed to unpause server')
- (rc msg)←0 'Server resuming operations'
- →0
- :EndIf
- →0 If(rc msg)←¯1 'Server thinks it''s already started'
- :EndIf
-
- :If _stop
- →0 If(rc msg)←¯1 'Server is in the process of stopping'
- :EndIf
-
- :If 'CLEAR WS'≡⎕WSID
- :If ⎕NEXISTS JarvisConfig
- :AndIf 2=⊃1 ⎕NINFO JarvisConfig
- _rootFolder←⊃1 ⎕NPARTS JarvisConfig
- :Else
- _rootFolder←⊃1 ⎕NPARTS SourceFile
- :EndIf
- :Else
- _rootFolder←⊃1 ⎕NPARTS ⎕WSID
- :EndIf
-
- →0 If(rc msg)←LoadConfiguration JarvisConfig
- →0 If(rc msg)←CheckPort
- →0 If(rc msg)←CheckCodeLocation
- →0 If(rc msg)←Setup
- →0 If(rc msg)←LoadConga
-
- :If 19≤APLVersion ⍝ ⎕TALLOC appeared in v19.0
- TokenBase←⎕TALLOC 1 'Jarvis'
- :EndIf
-
- homePage←1 ⍝ default is to use built-in home page
- :Select ⊃HTMLInterface
- :Case 0 ⍝ explicitly no HTML interface, carry on
- _htmlEnabled←0
- :Case 1 ⍝ explicitly turned on
- :If Paradigm≢'JSON'
- Log'HTML interface is only available using JSON paradigm'
- :Else
- _htmlEnabled←1
- :EndIf
- :Case ¯1 ⍝ turn on if JSON paradigm
- _htmlEnabled←Paradigm≡'JSON' ⍝ if not specified, HTML interface is enabled for JSON paradigm
- :Else
- :If 1<|≡HTMLInterface ⍝ is it '' 'function'?
- t←2⊃HTMLInterface
- :If 1 1 0≡⊃CodeLocation.⎕AT t
- _htmlRootFn←t
- _htmlEnabled←1
- :Else
- →0 If(rc msg)←¯1('HTML root function "',(⍕CodeLocation),'.',t,'" is not a monadic, result-returning function.')
- :EndIf
- :Else ⍝ otherwise it's 'file/folder'
- _htmlEnabled←1
- html←1 ⎕NPARTS((isRelPath HTMLInterface)/_rootFolder),HTMLInterface
- :If isDir∊html
- _htmlFolder←{⍵,('/'=⊢/⍵)↓'/'}∊html
- :Else
- _htmlFolder←1⊃html
- _htmlDefaultPage←∊1↓html
- :EndIf
- homePage←⎕NEXISTS html←_htmlFolder,_htmlDefaultPage
- Log(~homePage)/'HTML home page file "',(∊html),'" not found.'
- :EndIf
- :EndSelect
-
- :If EnableCORS ⍝ if we've enabled CORS
- :AndIf ¯1∊CORS_Methods ⍝ but not set any pre-flighted methods
- :If Paradigm≡'JSON'
- CORS_Methods←'GET,POST,OPTIONS' ⍝ allowed JSON methods are GET, POST, and OPTIONS
- :Else
- CORS_Methods←1↓∊',',¨RESTMethods[;1] ⍝ allowed REST methods are what the service supports
- :EndIf
- :EndIf
-
- CORS_Methods←uc CORS_Methods
-
- →0 If(rc msg)←StartServer
-
- Log'Jarvis starting in "',Paradigm,'" mode on port ',⍕Port
- Log'Serving code in ',(⍕CodeLocation),(CodeSource≢'')/' (populated with code from "',CodeSource,'")'
- Log(_htmlEnabled∧homePage)/'Click http',(~Secure)↓'s://',MyAddr,':',(⍕Port),' to access web interface'
-
- :Else ⍝ :Trap
- (rc msg)←¯1 ⎕DMX.EM
- :EndTrap
- ∇
-
- ∇ (rc msg)←Stop;ts;tokens
- :Access public
- :If _stop
- →0⊣(rc msg)←¯1 'Server is already stopping'
- :EndIf
- :If ~_started
- →0⊣(rc msg)←¯1 'Server is not running'
- :EndIf
- ts←⎕AI[3]
- _stop←1
- Log'Stopping server...'
- {0:: ⋄ {}LDRC.Close 2⊃LDRC.Clt'' ''Port'http'}''
- :While ~_stopped
- :If WaitTimeout<⎕AI[3]-ts
- →0⊣(rc msg)←¯1 'Server seems stuck'
- :EndIf
- :EndWhile
- :If 0≠TokenBase
- :If ~0∊⍴tokens←TokenBase ⎕TALLOC 2 ⍝ any lingering tokens?
- {}⎕TGET tokens ⍝ remove them
- :EndIf
- TokenBase ⎕TALLOC ¯1 ⍝ remove token pool
- :Else
- {}⎕TGET{⍵/⍨1=1 100000000⍸⍵}⎕TPOOL ⍝ remove tokens in the Conga connection number range
- :EndIf
- (rc msg)←0 'Server stopped'
- ∇
-
- ∇ (rc msg)←Pause
- :Access public
- →0 If~_started⊣(rc msg)←¯1 'Server is not running'
- →0 If 2=⊃2⊃LDRC.GetProp ServerName'Pause'⊣(rc msg)←¯2 Error'Server is already paused'
- →0 If 0≠rc←⊃LDRC.SetProp ServerName'Pause' 2⊣msg←'Error attempting to pause server'
- Log'Pausing server...'
- (rc msg)←0 'Server paused'
- ∇
-
- ∇ (rc msg)←Reset
- :Access Public
- ⎕TKILL _serverThread,_sessionThread,_taskThreads
- _sessions←⍬
- _sessionsInfo←0 5⍴0
- _stopped←~_stop←_started←0
- (rc msg)←0 'Server reset (previously set options are still in effect)'
- ∇
-
- ∇ r←Running
- :Access public
- r←~_stopped
- ∇
-
- ∇ (rc msg)←CheckPort;p
- ⍝ check for valid port number
- :If DYALOG_JARVIS_PORT≢'' ⍝ environment variable takes precedence
- Port←DYALOG_JARVIS_PORT
- :EndIf
- (rc msg)←3('Invalid port: ',∊⍕Port)
- →0 If 0=p←⊃⊃(//)⎕VFI⍕Port
- →0 If{(⍵>32767)∨(⍵<1)∨⍵≠⌊⍵}p
- (rc msg)←0 ''
- ∇
-
- ∇ (rc msg)←{force}LoadConfiguration value;config;public;set;file
- :Access public
- :If 0=⎕NC'force' ⋄ force←0 ⋄ :EndIf
- (rc msg)←0 ''
- →(_configLoaded>force)⍴0 ⍝ did we already load from AutoStart?
- :Trap 0 DebugLevel 1
- :If isChar value
- :If '#.'≡2↑value ⍝ check if a namespace reference
- :AndIf 9.1=⎕NC⊂value
- config←⍎value
- →Load
- :EndIf
- file←JarvisConfig
- :If ~0∊⍴value
- file←value
- :EndIf
- →0 If 0∊⍴file
- :If ⎕NEXISTS file
- config←JSONread⊃⎕NGET file
- :Else
- →0⊣(rc msg)←6('Configuation file "',file,'" not found')
- :EndIf
- :ElseIf 9.1={⎕NC⊂,'⍵'}value ⍝ namespace?
- config←value
- :EndIf
- Load:
- public←⎕THIS⍎'⎕NL ¯2.2 ¯2.1 ¯2.3' ⍝ find all the public fields in this class
- :If ~0∊⍴set←public∩config.⎕NL ¯2 ¯9
- config{⍎⍵,'←⍺⍎⍵'}¨set
- :EndIf
- _configLoaded←1
- :Else
- →0⊣(rc msg)←⎕DMX.EN ⎕DMX.('Error loading configuration: ',EM,(~0∊⍴Message)/' (',Message,')')
- :EndTrap
- ∇
-
- ∇ (rc msg)←LoadConga;ref;root;nc;n;ns;congaCopied;class;path
- ⍝↓↓↓ Check if LDRC exists (VALUE ERROR (6) if not), and is LDRC initialized? (NONCE ERROR (16) if not)
-
- (rc msg)←1 ''
-
- :Hold 'JarvisInitConga'
- :If {6 16 999::1 ⋄ ''≡LDRC:1 ⋄ 0⊣LDRC.Describe'.'}''
- LDRC←''
- :If ~0∊⍴CongaRef ⍝ did the user supply a reference to Conga?
- LDRC←ResolveCongaRef CongaRef
- →∆END↓⍨0∊⍴msg←(''≡LDRC)/'CongaRef (',(⍕CongaRef),') does not point to a valid instance of Conga'
- :Else
- :For root :In ##.## #
- ref nc←root{1↑¨⍵{(×⍵)∘/¨⍺ ⍵}⍺.⎕NC ⍵}ns←'Conga' 'DRC'
- :If 9=⊃⌊nc ⋄ :Leave ⋄ :EndIf
- :EndFor
-
- :If 9=⊃⌊nc
- LDRC←ResolveCongaRef root⍎∊ref
- →∆END↓⍨0∊⍴msg←(''≡LDRC)/(⍕root),'.',(∊ref),' does not point to a valid instance of Conga'
- →∆COPY↓⍨{999::0 ⋄ 1⊣LDRC.Describe'.'}'' ⍝ it's possible that Conga was saved in a semi-initialized state
- Log'Conga library found at ',(⍕root),'.',∊ref
- :Else
- ∆COPY:
- class←⊃⊃⎕CLASS ⎕THIS
- congaCopied←0
- :For n :In ns
- :For path :In (1+0∊⍴CongaPath)⊃(⊂CongaPath)((DyalogRoot,'ws/')'') ⍝ if CongaPath specified, use it exclusively
- :Trap Debug↓0
- n class.⎕CY path,'conga'
- LDRC←ResolveCongaRef(class⍎n)
- →∆END↓⍨0∊⍴msg←(''≡LDRC)/n,' was copied from ',path,'conga but is not valid'
- Log n,' copied from ',path,'conga'
- →∆COPIED⊣congaCopied←1
- :EndTrap
- :EndFor
- :EndFor
- →∆END↓⍨0∊⍴msg←(~congaCopied)/'Neither Conga nor DRC were successfully copied from [DYALOG]/ws/conga'
- ∆COPIED:
- :EndIf
- :EndIf
- :EndIf
- CongaVersion←1 0.1+.×2↑LDRC.Version
- LDRC.X509Cert.LDRC←LDRC ⍝ reset X509Cert.LDRC reference
- Log'Local Conga v',(⍕CongaVersion),' reference is ',⍕LDRC
- rc←0
- ∆END:
- :EndHold
- ∇
-
- ∇ LDRC←ResolveCongaRef CongaRef;z;failed
- ⍝ Attempt to resolve what CongaRef refers to
- ⍝ CongaRef can be a charvec, reference to the Conga or DRC namespaces, or reference to an iConga instance
- ⍝ LDRC is '' if Conga could not be initialized, otherwise it's a reference to the the Conga.LIB instance or the DRC namespace
-
- LDRC←'' ⋄ failed←0
- :Select nameClass CongaRef ⍝ what is it?
- :Case 9.1 ⍝ namespace? e.g. CongaRef←DRC or Conga
- ∆TRY:
- :Trap 0 DebugLevel 1
- :If ∨/'.Conga'⍷⍕CongaRef ⋄ LDRC←CongaPath CongaRef.Init'Jarvis' ⍝ is it Conga?
- :ElseIf 0≡⊃CongaRef.Init CongaPath ⋄ LDRC←CongaRef ⍝ DRC?
- :Else ⋄ →∆EXIT⊣LDRC←''
- :End
- :Else ⍝ if Jarvis is reloaded and re-executed in rapid succession, Conga initialization may fail, so we try twice
- :If failed ⋄ →∆EXIT⊣LDRC←''
- :Else ⋄ →∆TRY⊣failed←1
- :EndIf
- :EndTrap
- :Case 9.2 ⍝ instance? e.g. CongaRef←Conga.Init ''
- LDRC←CongaRef ⍝ an instance is already initialized
- :Case 2.1 ⍝ variable? e.g. CongaRef←'#.Conga'
- :Trap 0 DebugLevel 1
- LDRC←ResolveCongaRef(⍎∊⍕CongaRef)
- :EndTrap
- :EndSelect
- ∆EXIT:
- ∇
-
- ∇ (rc msg secureParams)←CreateSecureParams;cert;certs;msg;inds
- ⍝ return Conga parameters for running HTTPS, if Secure is set to 1
-
- LDRC.X509Cert.LDRC←LDRC ⍝ make sure the X509 instance points to the right LDRC
- (rc secureParams msg)←0 ⍬''
- :If Secure
- :If ~0∊⍴RootCertDir ⍝ on Windows not specifying RootCertDir will use MS certificate store
- →∆EXIT If(rc msg)←'RootCertDir'Exists RootCertDir
- →∆EXIT If(rc msg)←{(⊃⍵)'Error setting RootCertDir'}LDRC.SetProp'.' 'RootCertDir'RootCertDir
-⍝ The following is commented out because it seems the GnuTLS knows to use the operating system's certificate collection even on non-Windows platforms
-⍝ :ElseIf ~isWin
-⍝ →∆EXIT⊣(rc msg)←¯1 'No RootCertDir spcified'
- :EndIf
- :If 0∊⍴ServerCertSKI ⍝ no certificate ID specified, check for Cert and Key files
- →∆EXIT If(rc msg)←'ServerCertFile'Exists ServerCertFile
- →∆EXIT If(rc msg)←'ServerKeyFile'Exists ServerKeyFile
- :Trap 0 DebugLevel 1
- cert←⊃LDRC.X509Cert.ReadCertFromFile ServerCertFile
- :Else
- (rc msg)←⎕DMX.EN('Unable to decode ServerCertFile "',(∊⍕ServerCertFile),'" as a certificate')
- →∆EXIT
- :EndTrap
- cert.KeyOrigin←'DER'ServerKeyFile
- :ElseIf isWin ⍝ ServerCertSKI only on Windows
- certs←LDRC.X509Cert.ReadCertUrls
- :If 0∊⍴certs
- →∆EXIT⊣(rc msg)←8 'No certificates found in Microsoft Certificate Store'
- :Else
- inds←1+('id=',ServerCertSKI,';')⎕S{⍵.BlockNum}⍠'Greedy' 0⊢2⊃¨certs.CertOrigin
- :If 1≠≢inds
- rc←9
- msg←(0 2⍸≢inds)⊃('Certificate with id "',ServerCertSKI,'" was not found in the Microsoft Certificate Store')('There is more than one certificate with Subject Key Identifier "',ServerCertSKI,'" in the Microsoft Certificate Store')
- →∆EXIT
- :EndIf
- cert←certs[⊃inds]
- :EndIf
- :Else ⍝ ServerCertSKI is defined, but we're not running Windows
- →∆EXIT⊣(rc msg)←10 'ServerCertSKI is currently valid only under Windows'
- :EndIf
- secureParams←('X509'cert)('SSLValidation'SSLValidation)('Priority'Priority)
- :EndIf
- ∆EXIT:
- ∇
-
- ∇ (rc msg)←CheckCodeLocation;root;m;res;tmp;fn;path
- (rc msg)←0 ''
- :If DYALOG_JARVIS_CODELOCATION≢'' ⍝ environment variable take precedence
- CodeLocation←DYALOG_JARVIS_CODELOCATION
- :EndIf
- :If 0∊⍴CodeLocation
- :If 0∊⍴JarvisConfig ⍝ if there's a configuration file, use its folder for CodeLocation
- →0⊣(rc msg)←4 'CodeLocation is empty!'
- :Else
- CodeLocation←⊃1 ⎕NPARTS JarvisConfig
- :EndIf
- :EndIf
- :Select ⊃{⎕NC'⍵'}CodeLocation ⍝ need dfn because CodeLocation is a field and will always be nameclass 2
- :Case 9 ⍝ reference, just use it
- :Case 2 ⍝ variable, could be file path or ⍕ of reference from JarvisConfig
- :If 326=⎕DR tmp←{0::⍵ ⋄ '#'≠⊃⍵:⍵ ⋄ ⍎⍵}CodeLocation
- :AndIf 9={⎕NC'⍵'}tmp ⋄ CodeLocation←tmp
- :Else
- root←(isRelPath CodeLocation)/_rootFolder
- path←∊1 ⎕NPARTS root,CodeLocation
- :Trap 0 DebugLevel 1
- :If 1=t←1 ⎕NINFO path ⍝ folder?
- CodeLocation←⍎'CodeLocation'#.⎕NS''
- _codeSource←path
- →0 If(rc msg)←CodeLocation LoadFromFolder path
- :ElseIf 2=t ⍝ file?
- CodeLocation←#.⎕FIX'file://',path
- _codeSource←path
- :Else
- →0⊣(rc msg)←5('CodeLocation "',(∊⍕CodeLocation),'" is not a folder or script file.')
- :EndIf
-
- :Case 22 ⍝ file name error
- →0⊣(rc msg)←6('CodeLocation "',(∊⍕CodeLocation),'" was not found.')
- :Else ⍝ anything else
- →0⊣(rc msg)←7((⎕DMX.(EM,' (',Message,') ')),'occured when validating CodeLocation "',(∊⍕CodeLocation),'"')
- :EndTrap
- :EndIf
- :Else
- →0⊣(rc msg)←5 'CodeLocation is not valid, it should be either a namespace/class reference or a file path'
- :EndSelect
-
- :For fn :In AppInitFn AppCloseFn ValidateRequestFn AuthenticateFn SessionInitFn _htmlRootFn~⊂''
- :If 3≠CodeLocation.⎕NC fn
- msg,←(0∊⍴msg)↓',"CodeLocation.',fn,'" was not found '
- :EndIf
- :EndFor
- →0 If rc←8×~0∊⍴msg
-
- :If ~0∊⍴AppInitFn ⍝ initialization function specified?
- :Select ⊃CodeLocation.⎕AT AppInitFn
- :Case 1 0 0 ⍝ result-returning niladic?
- stopIf DebugLevel 2
- res←CodeLocation⍎AppInitFn ⍝ run it
- :Case 1 1 0 ⍝ result-returning monadic?
- stopIf DebugLevel 2
- res←(CodeLocation⍎AppInitFn)⎕THIS ⍝ run it
- :Else
- →0⊣(rc msg)←8('"',(⍕CodeLocation),'.',AppInitFn,'" is not a niladic or monadic result-returning function')
- :EndSelect
- :If 0≠⊃res
- →0⊣(rc msg)←2↑res,(≢res)↓¯1('"',(⍕CodeLocation),'.',AppInitFn,'" did not return a 0 return code')
- :EndIf
- :EndIf
-
-
- :If ~0∊⍴AppCloseFn ⍝ application close function specified?
- :If 1 0 0≢⊃CodeLocation.⎕AT AppCloseFn ⍝ result-returning niladic?
- →0⊣(rc msg)←8('"',(⍕CodeLocation),'.',AppCloseFn,'" is not a niladic result-returning function')
- :EndIf
- :EndIf
-
- Validate←{0} ⍝ dummy validation function
- :If ~0∊⍴ValidateRequestFn ⍝ Request validation function specified?
- :If ∧/(⊃CodeLocation.⎕AT ValidateRequestFn)∊¨1(1 ¯2)0 ⍝ result-returning monadic or ambivalent?
- Validate←CodeLocation⍎ValidateRequestFn
- :Else
- →0⊣(rc msg)←8('"',(⍕CodeLocation),'.',ValidateRequestFn,'" is not a monadic result-returning function')
- :EndIf
- :EndIf
-
- Authenticate←{0} ⍝ dummy authentication function
- :If ~0∊⍴AuthenticateFn ⍝ authentication function specified?
- :If ∧/(⊃CodeLocation.⎕AT AuthenticateFn)∊¨1(1 ¯2)0 ⍝ result-returning monadic or ambivalent?
- Authenticate←CodeLocation⍎AuthenticateFn
- :Else
- →0⊣(rc msg)←8('"',(⍕CodeLocation),'.',AuthenticateFn,'" is not a monadic result-returning function')
- :EndIf
- :EndIf
- ∇
-
- ∇ (rc msg)←Setup
- ⍝ perform final setup before starting server
- (rc msg)←0 ''
- Paradigm←uc Paradigm
- :Select Paradigm
- :Case 'JSON'
- RequestHandler←HandleJSONRequest
- :Case 'REST'
- RequestHandler←HandleRESTRequest
- :If 2>≢⍴RESTMethods
- RESTMethods←↑2⍴¨'/'(≠⊆⊢)¨','(≠⊆⊢),RESTMethods
- :EndIf
- :Else
- (rc msg)←¯1 'Invalid paradigm'
- :EndSelect
- ∇
-
- Exists←{0:: ¯1 (⍺,' "',⍵,'" is not a valid folder name.') ⋄ ⎕NEXISTS ⍵:0 '' ⋄ ¯1 (⍺,' "',⍵,'" was not found.')}
-
- ∇ (rc msg)←StartServer;r;cert;secureParams;accept;deny;mask;certs;options
- msg←'Unable to start server'
- accept←'Accept'ipRanges AcceptFrom
- deny←'Deny'ipRanges DenyFrom
- →∆EXIT If⊃(rc msg secureParams)←CreateSecureParams
-
- {}LDRC.SetProp'.' 'EventMode' 1 ⍝ report Close/Timeout as events
-
- options←''
-
- :If 3.3≤CongaVersion ⍝ can we set DecodeBuffers at server creation?
- options←⊂'Options'(5+32×FIFO) ⍝ WSAutoAccept (1) + DecodeBuffers (4) + EnableFifo (32)
- :EndIf
-
- :If 3.4≤CongaVersion ⍝ DOSLimit support started with v3.4
- :AndIf DOSLimit≠¯1 ⍝ not using Conga's default value
- :If 0≠⊃LDRC.SetProp'.' 'DOSLimit'DOSLimit
- →∆EXIT⊣(rc msg)←¯1 'Invalid DOSLimit setting: ',∊⍕DOSLimit
- :EndIf
- :EndIf
-
- _connections←⎕NS''
- _connections.index←2 0⍴'' 0 ⍝ row-oriented for faster lookup
- _connections.lastCheck←0
-
- :If 0=rc←1⊃r←LDRC.Srv ServerName''Port'http'BufferSize,secureParams,accept,deny,options
- ServerName←2⊃r
- :If 3.3>CongaVersion
- {}LDRC.SetProp ServerName'FIFOMode'FIFO ⍝ deprecated in Conga v3.2
- {}LDRC.SetProp ServerName'DecodeBuffers' 15 ⍝ 15 ⍝ decode all buffers
- {}LDRC.SetProp ServerName'WSFeatures' 1 ⍝ auto accept WS requests
- :EndIf
- :If 0∊⍴Hostname ⍝ if Host hasn't been set, set it to the default
- Hostname←'http',(~Secure)↓'s://',(2 ⎕NQ'.' 'TCPGetHostID'),((~Port∊80 443)/':',⍕Port),'/'
- :EndIf
- InitSessions
- (rc msg)←RunServer
- :Else
- Log msg←'Error ',(⍕rc),' creating server',(rc∊98 10048)/': port ',(⍕Port),' is already in use' ⍝ 98=Linux, 10048=Windows
- :EndIf
- ∆EXIT:
- ∇
-
- ∇ (rc msg)←RunServer;thread
- thread←lc,⍕DYALOG_JARVIS_THREAD
- :If (⊂thread)∊'' 'auto'
- :If InTerm ⍝ do we have an interactive terminal?
- thread←'debug'
- :Else
- thread←,'1'
- :EndIf
- :EndIf
- :Select thread
- :Case ,'0' ⍝ Run in thread 0
- _serverThread←0
- (rc msg)←Server''
- QuadOFF
- :Case ,'1' ⍝ Run in non-0 thread, use ⎕TSYNC
- (rc msg)←⎕TSYNC _serverThread←Server&⍬
- QuadOFF
- :Case 'debug'
- _serverThread←Server&⍬
- (rc msg)←0 'Server started'
- :Else
- (rc msg)←¯1 'Invalid setting for DYALOG_JARVIS_THREAD'
- :EndSelect
- ∇
-
- ∇ {r}←Server arg;wres;rc;obj;evt;data;ref;ip;msg;tmp;conx;conn
- (_started _stopped)←1 0
- :While ~_stop
- :Trap 0 DebugLevel 1
- wres←LDRC.Wait ServerName WaitTimeout ⍝ Wait for WaitTimeout before timing out
- ⍝ wres: (return code) (object name) (command) (data)
- (rc obj evt data)←4↑wres
- :If DebugLevel 8
- :AndIf evt≢'Timeout'
- Log'Server: ',∊⍕rc obj evt
- :EndIf
- conx←obj(⍳↓⊣)'.'
- conn←TokenForConnection⍣(~0∊⍴conx)⊢conx ⍝ connection (token) number - need to add 1 because connections start at 0
- :Select rc
- :Case 0
- :Select evt
- :Case 'Error'
- _stop←ServerName≡obj ⍝ if we got an error on the server itself, signal to stop
- :If 0≠4⊃wres
- Log'Server: DRC.Wait reported error ',(⍕4⊃wres),' on ',(2⊃wres),GetIP obj
- :EndIf
- RemoveConnection conx ⍝ Conga closes object on an Error event
-
- :Case 'Connect'
- obj AddConnection conx
-
- :CaseList 'HTTPHeader' 'HTTPTrailer' 'HTTPChunk' 'HTTPBody'
- :If (DebugLevel 8)∧evt≡'HTTPHeader'
- Log'Server: HTTPHeader Method/URL: ',∊⍕2↑4⊃wres
- :EndIf
- :If 0≠_connections.⎕NC conx
- ref←_connections⍎conx
- wres ⎕TPUT conn
- _taskThreads←⎕TNUMS∩_taskThreads,ref{⍺ HandleRequest ⍵}&(obj conn)
- ref.Time←⎕AI[3]
- :Else
- Log'Server: Object ''_connections.',conx,''' was not found.'
- {0:: ⋄ {}LDRC.Close ⍵}obj
- :EndIf
-
- :Case 'Closed'
- RemoveConnection conx
-
- :Case 'Timeout'
-
- :Else ⍝ unhandled event
- Log'Server: Unhandled Conga event:'
- Log⍕wres
- :EndSelect ⍝ evt
-
- :Case 1010 ⍝ Object Not found
- :If ~_stop
- Log'Server: Object ''',ServerName,''' has been closed - Jarvis shutting down'
- _stop←1
- :EndIf
- :Else
- Log'Server: Conga wait failed:'
- Log wres
- :EndSelect ⍝ rc
-
- CleanupConnections
-
- :Else ⍝ :Trap
- Log'*** Server error ',msg←1 ⎕JSON⍠'Compact' 0⊢⎕DMX
- r←¯1 msg
- →Exit
- :EndTrap
- :EndWhile
-
- r←0 'Server stopped'
-
- Exit:
-
- :If ~0∊⍴AppCloseFn
- r←CodeLocation⍎AppCloseFn
- :EndIf
-
- Close
- ⎕TKILL _sessionThread
- (_stop _started _stopped)←0 0 1
- ∇
-
- ∇ r←TokenForConnection conx
- ⍝ return token for connection name (CONnnnnnnnn)
- r←1+⊃⊃(//)⎕VFI conx∩⎕D
- :If 0≠TokenBase ⍝ if ⎕TALLOC is available...
- r←⍎,('<',(⍕TokenBase),'.>,ZI8')⎕FMT r
- :EndIf
- ∇
-
- ∇ obj AddConnection conx;IP;res
- :Hold '_connections'
- conx _connections.⎕NS''
- _connections.index,←conx(⎕AI[3])
- IP←''
- :Trap 0 DebugLevel 1
- :If 0=⊃res←LDRC.GetProp obj'PeerAddr'
- IP←2⊃2⊃res
- :EndIf
- :EndTrap
- (_connections⍎conx).IP←IP
- :EndHold
- ∇
-
- ∇ RemoveConnection conx;ref
- :Hold '_connections'
- :If 0=_connections.⎕NC conx
- Log'Attempt to remove non-existent connection ',⍕conx
- :Else
- ref←_connections⍎conx
- :If 9=|⌊ref.⎕NC⊂'Req'
- :AndIf ref.Req.KillOnDisconnect
- ⎕TKILL ref.Req.Thread
- :EndIf
- :EndIf
- _connections.⎕EX conx
- _connections.index/⍨←_connections.index[1;]≢¨⊂conx
- :EndHold
- CleanupTokens conx
- ∇
-
- ∇ CleanupConnections;conxNames;timedOut;dead;kids;connecting;connected;killed
- :If _connections.lastCheck<⎕AI[3]-ConnectionTimeout×1000
- killed←⍬
- :Hold '_connections'
- connecting←connected←⍬
- :If ~0∊⍴kids←2 2⊃LDRC.Tree ServerName ⍝ retrieve children of server
- ⍝ LDRC.Tree
- ⍝ connecting → status 3 1 - incoming connection
- ⍝ connected → status 3 4 - connected connection
- (connecting connected)←2↑{((2 2⍴3 1 3 4)⍪⍵[;2 3]){⊂1↓⍵}⌸'' '',⍵[;1]}↑⊃¨kids
- :EndIf
- conxNames←_connections.index[1;]~connecting
- timedOut←_connections.index[1;]/⍨ConnectionTimeout<0.001×⎕AI[3]-_connections.index[2;]
- :If ∨/{~0∊⍴⍵}¨connected conxNames
- :If ~0∊⍴timedOut
- timedOut/⍨←{6::1 ⋄ 0=(_connections⍎⍵).⎕NC⊂'Req'}¨timedOut
- :EndIf
- :If ~0∊⍴dead←(connected~conxNames),timedOut ⍝ (connections not in the index), timed out
- {0∊⍴⍵: ⋄ {}LDRC.Close ServerName,'.',⍵}¨dead ⍝ attempt to close them
- :EndIf
- ⍝ remove timed out, or connections that are
- _connections.⎕EX killed←(conxNames~connected~dead),timedOut
- _connections.index/⍨←_connections.index[1;]∊_connections.⎕NL ¯9
- :EndIf
- _connections.lastCheck←⎕AI[3]
- :EndHold
- CleanupTokens killed
- :EndIf
- ∇
-
- ∇ CleanupTokens conx
- ⍝ remove any lingering tokens from dead/removed connections
- :If ~0∊⍴conx
- conx←,⊆conx
- {}⎕TGET ⎕TPOOL∩TokenForConnection¨{⊃¯1↑⍵(≠⊆⊣)'.'}¨conx
- :EndIf
- ∇
-
- :Section RequestHandling
-
- ∇ r←ErrorInfo
- :Trap 0
- r←⍕ErrorInfoLevel↑⎕DMX.(EM({⍵↑⍨⍵⍳']'}2⊃DM))
- :Else
- r←''
- :EndTrap
- ∇
-
- ∇ req←MakeRequest args
- ⍝ create a request, use MakeRequest '' for interactive debugging
- ⍝ :Access public ⍝ uncomment for debugging
- :If 0∊⍴args
- req←⎕NEW Request
- :Else
- req←⎕NEW Request args
- :EndIf
- req.(Server ErrorInfoLevel)←⎕THIS ErrorInfoLevel
- ∇
-
- ∇ ns HandleRequest(obj conn);data;evt;obj;rc;cert;fn
- :Hold obj
- (rc obj evt data)←⊃⎕TGET conn ⍝ from Conga.Wait
- :Select evt
- :Case 'HTTPHeader'
- ns.Req←MakeRequest data
- ns.Req.Thread←⎕TID
- ns.Req.PeerCert←''
- ns.Req.PeerAddr←2⊃2⊃LDRC.GetProp obj'PeerAddr'
- ns.Req.Server←⎕THIS
-
- :If Secure
- (rc cert)←2↑LDRC.GetProp obj'PeerCert'
- :If rc=0
- ns.Req.PeerCert←cert
- :Else
- ns.Req.PeerCert←'Could not obtain certificate'
- :EndIf
- :EndIf
-
- :Case 'HTTPBody'
- ⍝↓↓↓ if Req doesn't exist, it's because it was marked complete previously and removed, and we just ignore this event
- ⍝ this can happen in the case where:
- ⍝ - the request is a POST request
- ⍝ - and no content-length header was provided
- ⍝ - and transfer-encoding is not "chunked"
- ⍝ Conga 3.5 addresses this by issuing and HTTPError event, but earlier Conga's
- →0⍴⍨0=ns.⎕NC'Req'
- ns.Req.Thread←⎕TID
- ns.Req.ProcessBody data
- :Case 'HTTPChunk'
- ns.Req.Thread←⎕TID
- ns.Req.ProcessChunk data
- :Case 'HTTPTrailer'
- ns.Req.Thread←⎕TID
- ns.Req.ProcessTrailer data
- :EndSelect
-
- ns.Req.Thread←⎕TID
-
- :If ns.Req.Complete
- :Select lc ns.Req.GetHeader'content-encoding' ⍝ zipped request?
- :Case '' ⍝ no encoding
- :If ns.Req.Charset≡'utf-8'
- ns.Req.Body←'UTF-8'⎕UCS ⎕UCS ns.Req.Body
- :EndIf
- :Case 'gzip'
- ns.Req.Body←⎕UCS 256|¯3 Zipper 83 ⎕DR ns.Req.Body
- :Case 'deflate'
- ns.Req.Body←⎕UCS 256|¯2 Zipper 83 ⎕DR ns.Req.Body
- :Else
- →resp⊣'Unsupported content-encoding'ns.Req.Fail 400
- :EndSelect
-
- :If _htmlEnabled∧ns.Req.Response.Status≠200
- ns.Req.Response.Headers←1 2⍴'Content-Type' 'text/html; charset=utf-8'
- ns.Req.Response.Payload←'',(⍕ns.Req.Response.((⍕Status),' ',StatusText)),'
'
- →resp
- :EndIf
-
- ⍝ Application-specified validation
- stopIf DebugLevel 4+2×~0∊⍴ValidateRequestFn
- rc←Validate ns.Req
- ns.Req.Fail 400×(ns.Req.Response.Status=200)∧0≠rc ⍝ default status 400 if not set by application
- →resp If rc≠0
-
- fn←1↓'.'@('/'∘=)ns.Req.Endpoint
-
- fn RequestHandler ns ⍝ RequestHandler is either HandleJSONRequest or HandleRESTRequest
-
- resp: obj Respond ns
-
- :EndIf
- :EndHold
- ∇
-
- ∇ fn HandleJSONRequest ns;payload;resp;valence;nc;debug;file;isGET
-
- →handle If~isGET←'get'≡ns.Req.Method
-
- :If AllowGETs ⍝ if we allow GETs
- :AndIf ~'.'∊ns.Req.Endpoint ⍝ and the endpoint doesn't have a '.' (file extension)
- →handle If 3=⌊|{0::0 ⋄ CodeLocation.⎕NC⊂⍵}fn ⍝ handle it if there's a matching function for the endpoint
- :EndIf
-
- →End If'Request method should be POST'ns.Req.Fail 405×~_htmlEnabled
-
- →handleHtml If~0∊⍴_htmlFolder
- ns.Req.Response.Headers←1 2⍴'Content-Type' 'text/html; charset=utf-8'
- ns.Req.Response.Payload←'400 Bad Request
'
- →End If'Bad URI'ns.Req.Fail 400×~0∊⍴fn ⍝ either fail with a bad URI or exit if favicon.ico (no-op)
-
- :If 0∊⍴_htmlRootFn
- ns.Req.Response.Payload←HtmlPage
- :Else
- ns.Req.Response.Payload←{1 CodeLocation.(85⌶)_htmlRootFn,' ⍵'}ns.Req
- :EndIf
- →End
-
- handleHtml:
- :If (,'/')≡ns.Req.Endpoint
- file←_htmlFolder,_htmlDefaultPage
- :Else
- file←_htmlFolder,('/'=⊣/ns.Req.Endpoint)↓ns.Req.Endpoint
- :EndIf
- file←∊1 ⎕NPARTS file
- file,←(isDir file)/'/',_htmlDefaultPage
- →End If ns.Req.Fail 400×~_htmlFolder begins file
- :If 0≠ns.Req.Fail 404×~⎕NEXISTS file
- →End If 0=Report404InHTML
- ns.Req.Response.Headers←1 2⍴'Content-Type' 'text/html; charset=utf-8'
- ns.Req.Response.Payload←'Not found: ',(file↓⍨≢_htmlFolder),'
'
- →End
- :EndIf
- ns.Req.Response.Payload←''file
- 'Content-Type'ns.Req.DefaultHeader ns.Req.ContentTypeForFile file
- →End
-
- handle:
- →End If HandleCORSRequest ns.Req
- →End If'No function specified'ns.Req.Fail 400×0∊⍴fn
- →End If'Unsupported request method'ns.Req.Fail 405×(⊂ns.Req.Method)(~∊)(~AllowGETs)↓'get' 'post'
- →End If'Cannot accept query parameters'ns.Req.Fail 400×AllowGETs⍱0∊⍴ns.Req.QueryParams
-
- :Select ns.Req.ContentType
-
- :Case 'application/json'
- :Trap 0 DebugLevel 1
- ns.Req.Payload←{0∊⍴⍵:⍵ ⋄ JSONin ⍵}ns.Req.Body
- :Else
- →End⊣'Could not parse payload as JSON'ns.Req.Fail 400
- :EndTrap
-
- :Case 'multipart/form-data'
- →End If'Content-Type should be "application/json"'ns.Req.Fail 400×~AllowFormData
- :Trap 0 DebugLevel 1
- ns.Req.Payload←ParseMultipartForm ns.Req
- →End If 200≠ns.Req.Response.Status ⍝ bail if parsing fails
- :Else
- →End⊣'Could not parse payload as "multipart/form-data"'ns.Req.Fail 400
- :EndTrap
-
- :Case ''
- →End If'No Content-Type specified'ns.Req.Fail 400×~isGET∧AllowGETs
- :Trap 0 DebugLevel 1
- :If 0∊⍴ns.Req.QueryParams
- ns.Req.Payload←''
- :ElseIf 1=≢⍴ns.Req.QueryParams ⍝ name/value pairs
- ns.Req.Payload←JSONin ns.Req.QueryParams
- :Else
- ns.Req.Payload←{JSONin{1⌽'}{',¯1↓∊'"',¨⍵[;,1],¨'":'∘,¨⍵[;,2],¨','}⍵}ns.Req.QueryParams
- :EndIf
- :Else
- →End⊣'Could not parse query string as JSON'ns.Req.Fail 400
- :EndTrap
-
- :Else
- →End⊣('Content-Type should be "application/json"',AllowFormData/' or "multipart/form-data"')ns.Req.Fail 400
- :EndSelect
-
- →End If CheckAuthentication ns.Req
-
- →End If('Invalid function "',fn,'"')ns.Req.Fail CheckFunctionName fn
- →End If('Invalid function "',fn,'"')ns.Req.Fail 404×3≠⌊|{0::0 ⋄ CodeLocation.⎕NC⊂⍵}fn ⍝ is it a function?
- valence←|⊃CodeLocation.⎕AT fn
- nc←CodeLocation.⎕NC⊂fn
- →End If('"',fn,'" is not a monadic result-returning function')ns.Req.Fail 400×(1 1 0≢×valence)>(0∧.=valence)∧3.3=nc
-
- resp←''
- :Trap 0 DebugLevel 1
- :Trap 85
- :If (2=valence[2])>3.3=nc ⍝ dyadic and not tacit
- stopIf DebugLevel 2
- resp←ns.Req{0 CodeLocation.(85⌶)'⍺ ',fn,' ⍵'}ns.Req.Payload ⍝ intentional stop for application-level debugging
- :Else
- stopIf DebugLevel 2
- resp←{0 CodeLocation.(85⌶)fn,' ⍵'}ns.Req.Payload ⍝ intentional stop for application-level debugging
- :EndIf
- :Else ⍝ no result from the endpoint
- :If 0∊⍴ns.Req.Response.Payload ⍝ no payload?
- :AndIf 200=ns.Req.Response.Status ⍝ endpoint did not change the status
- →End⊣ns.Req.Fail 204 ⍝ no content
- :EndIf
- :EndTrap
- :Else
- →End⊣ErrorInfo ns.Req.Fail 500
- :EndTrap
-
- →End If 204=ns.Req.Response.Status
-
- ⍝ Exit if
- ⍝ ↓↓↓↓↓↓↓ no response from endpoint,
- ⍝ and ↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓ endpoint did not set payload
- ⍝ and ↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓ endpoint failed the request
- →End If(0∊⍴resp)∧(0∊⍴ns.Req.Response.Payload)∧200≠ns.Req.Response.Status
-
- 'Content-Type'ns.Req.DefaultHeader DefaultContentType ⍝ set the header if not set
- :If ∨/'application/json'⍷ns.Req.(Response.Headers GetHeader'content-type') ⍝ if the response is JSON
- ns.Req ToJSON resp ⍝ convert it
- :Else
- ns.Req.Response.Payload←resp
- :EndIf
- :If 0∊⍴ns.Req.Response.Payload
- 'Content-Length'ns.Req.DefaultHeader 0
- :EndIf
- End:
- ∇
-
- ∇ formData←ParseMultipartForm req;boundary;body;part;headers;payload;disposition;type;name;filename;tmp
- boundary←crlf,'--',req.Boundary ⍝ the HTTP standard prepends '--' to the boundary
- body←req.Body
- formData←⎕NS''
- body←⊃body splitOnFirst boundary,'--' ⍝ drop off trailing boundary ('--' is appended to the trailing boundary)
- :For part :In (crlf,body)splitOn boundary ⍝ split into parts
- (headers payload)←part splitOnFirst crlf,crlf
- (disposition type)←deb¨2↑headers splitOn crlf
- (name filename)←deb¨2↑1↓disposition splitOn';'
- name←'"'~⍨2⊃name splitOn'='
- name↓⍨←¯2×'[]'≡¯2↑name ⍝ drop any trailing [] (we handle arrays automatically)
- :If {¯1=⎕NC ⍵}name
- →0⊣'Invalid form field name for Jarvis'req.Fail 400
- :EndIf
- tmp←⎕NS''
- filename←'"'~⍨2⊃2↑filename splitOn'='
- tmp.(Name Filename)←name filename
- tmp.Content←payload
- tmp.Content_Type←deb 2⊃2↑type splitOn':'
- :If 0=formData.⎕NC name ⋄ formData{⍺⍎⍵,'←⍬'}name ⋄ :EndIf
- formData(name{⍺⍎⍺⍺,',←⍵'})tmp
- :EndFor
- ∇
-
- ∇ fn HandleRESTRequest ns;ind;exec;valence;ct;resp
- →0 If HandleCORSRequest ns.Req
- →0 If CheckAuthentication ns.Req
-
- :If ParsePayload
- :Trap 0 DebugLevel 1
- :Select ct←ns.Req.ContentType
- :Case 'application/json'
- ns.Req.Payload←JSONin ns.Req.Body
- :Case 'application/xml'
- ns.Req.(Payload←⎕XML Body)
- :EndSelect
- :Else
- →0⊣('Unable to parse request body as ',ct)ns.Req.Fail 400
- :EndTrap
- :EndIf
-
- ind←RESTMethods[;1](⍳nocase)⊂ns.Req.Method
- →0 If ns.Req.Fail 405×(≢RESTMethods)'keep-alive'≡conx)∨'close'≡conx
- close∨←2≠⌊0.01×res.Status ⍝ close the connection on non-2XX status
- UseZip ContentEncode ns.Req
- :Select 1⊃z←LDRC.Send obj(status,res.Headers res.Payload)close
- :Case 0 ⍝ everything okay, nothing to do
- :Case 1008 ⍝ Wrong object class likely caused by socket being closed during the request
- ⍝ do nothing for now
- :Else
- Log'Respond: Conga error when sending response',GetIP obj
- Log⍕z
- :EndSelect
- ns.⎕EX'Req'
- ∇
-
- ∇ UseZip ContentEncode req;enc
- →End If 0=UseZip ⍝ is zipping enabled?
- →End If 0∊⍴enc←req.AcceptEncodings ⍝ does the client accept zipped responses?
- :If UseZip≤≢req.Response.Payload ⍝ payload exceeds size threshhold?
- :Select ⊃enc
- :Case 'gzip'
- :Trap 0
- req.Response.Payload←2⊃3 ZipLevel Zipper sint req.Response.Payload
- :Else
- Log'ContentEncode: gzip content-encoding failed'
- →End
- :EndTrap
- 'Content-Encoding'req.SetHeader'gzip'
- :Case 'deflate'
- :Trap 0
- req.Response.Payload←2⊃2 ZipLevel Zipper sint req.Response.Payload
- :Else
- Log'ContentEncode: deflate content-encoding failed'
- →End
- :EndTrap
- 'Content-Encoding'req.SetHeader'deflate'
- :Else
- Log'ContentEncode: unsupported content-encoding - ',⊃enc ⍝ this should NEVER happen
- :EndSelect
- :EndIf
- End:
- ∇
-
- :EndSection ⍝ Request Handling
-
- ∇ ip←GetIP objname
- ip←{6::'' ⋄ ' (IP Address ',(⍕(_connections⍎⍵).IP),')'}objname
- ∇
-
- ∇ r←CheckFunctionName fn
- ⍝ checks the requested function name and returns
- ⍝ 0 if the function is allowed
- ⍝ 404 (not found) either the function name does not exist, is not in IncludeFns (if defined), is in ExcludeFns (if defined)
- :Access public
- r←0
- :If 1<|≡fn
- r←CheckFunctionName¨fn
- :Else
- fn←⊆,fn
- →0 If r←404×fn∊AppInitFn AppCloseFn ValidateRequestFn AuthenticateFn SessionInitFn _htmlRootFn
- :If ~0∊⍴_includeRegex
- →0 If r←404×0∊⍴(_includeRegex ⎕S'%')fn
- :EndIf
- :If ~0∊⍴_excludeRegex
- r←404×~0∊⍴(_excludeRegex ⎕S'%')fn
- :EndIf
- :EndIf
- ∇
-
- :class Request
- :Field Public Instance AcceptEncodings←''⍝ content-encodings that the client will accept
- :Field Public Instance Boundary←'' ⍝ boundary for content-type 'multipart/form-data'
- :Field Public Instance Charset←'' ⍝ content charset (defaults to 'utf-8' if content-type is application/json)
- :Field Public Instance Complete←0 ⍝ do we have a complete request?
- :Field Public Instance ContentType←'' ⍝ content-type header value
- :Field Public Instance Cookies←0 2⍴⊂'' ⍝ cookie name/value pairs
- :Field Public Instance Input←''
- :Field Public Instance Headers←0 2⍴⊂'' ⍝ HTTPRequest header fields (plus any supplied from HTTPTrailer event)
- :Field Public Instance Method←'' ⍝ HTTP method (GET, POST, PUT, etc)
- :Field Public Instance Endpoint←'' ⍝ Requested URI
- :Field Public Instance KillOnDisconnect←0⍝ Kill request thread on disconnect
- :Field Public Instance Thread←¯1 ⍝ Thread number handling this request
- :Field Public Instance Body←'' ⍝ body of the request
- :Field Public Instance Payload←'' ⍝ parsed (if JSON or XML) payload
- :Field Public Instance PeerAddr←'unknown'⍝ client IP address
- :Field Public Instance PeerCert←0 0⍴⊂'' ⍝ client certificate
- :Field Public Instance HTTPVersion←''
- :Field Public Instance ErrorInfoLevel←1
- :Field Public Instance Response
- :Field Public Instance Server
- :Field Public Instance Session←⍬
- :Field Public Instance QueryParams←0 2⍴0
- :Field Public Instance UserID←''
- :Field Public Instance Password←''
- :Field Public Shared HttpStatus←↑(200 'OK')(201 'Created')(204 'No Content')(301 'Moved Permanently')(302 'Found')(303 'See Other')(304 'Not Modified')(305 'Use Proxy')(307 'Temporary Redirect')(400 'Bad Request')(401 'Unauthorized')(403 'Forbidden')(404 'Not Found')(405 'Method Not Allowed')(406 'Not Acceptable')(408 'Request Timeout')(409 'Conflict')(410 'Gone')(411 'Length Required')(412 'Precondition Failed')(413 'Request Entity Too Large')(414 'Request-URI Too Long')(415 'Unsupported Media Type')(500 'Internal Server Error')(501 'Not Implemented')(503 'Service Unavailable')
-
- ⍝ Content types for common file extensions
- :Field Public Shared ContentTypes←18 2⍴'txt' 'text/plain' 'htm' 'text/html' 'html' 'text/html' 'css' 'text/css' 'xml' 'text/xml' 'svg' 'image/svg+xml' 'json' 'application/json' 'zip' 'application/x-zip-compressed' 'csv' 'text/csv' 'pdf' 'application/pdf' 'mp3' 'audio/mpeg' 'pptx' 'application/vnd.openxmlformats-officedocument.presentationml.presentation' 'js' 'application/javascript' 'png' 'image/png' 'jpg' 'image/jpeg' 'bmp' 'image/bmp' 'jpeg' 'image/jpeg' 'woff' 'application/font-woff'
-
- GetFromTable←{(⍵[;1]⍳⊂,⍺)⊃⍵[;2],⊂''}
- split←{p←(⍺⍷⍵)⍳1 ⋄ ((p-1)↑⍵)(p↓⍵)} ⍝ Split ⍵ on first occurrence of ⍺
- lc←{2::0(819⌶)⍵ ⋄ ¯3 ⎕C ⍵}
- deb←{{1↓¯1↓⍵/⍨~' '⍷⍵}' ',⍵,' '}
-
- ∇ {r}←{message}Fail status
- ⍝ Set HTTP response status code and message if status≠0
- :Access public
- :If r←0≠1↑status
- :If 0=⎕NC'message'
- :If 500=status
- message←ErrorInfo
- :Else
- message←'' ⋄ :EndIf
- :EndIf
- message SetStatus status
- :EndIf
- ∇
-
- ∇ make
- ⍝ barebones constructor for interactive debugging (use Jarvis.MakeRequest '')
- :Access public
- :Implements constructor
- makeResponse
- ∇
-
- ∇ make1 args;query;origin;length;param;value;type;noLength;len
- ⍝ args is the result of Conga HTTPHeader event
- :Access public
- :Implements constructor
-
- (Method Input HTTPVersion Headers)←args
- Headers[;1]←lc Headers[;1] ⍝ header names are case insensitive
- Method←lc Method
-
- (ContentType param)←deb¨2↑(';'(≠⊆⊢)GetHeader'content-type'),⊂''
- ContentType←lc ContentType
- (type value)←2↑⊆deb¨'='(≠⊆⊢)param
- :Select lc type
- :Case '' ⍝ no parameter set
- Charset←(ContentType≡'application/json')/'utf-8'
- :Case 'charset'
- Charset←lc value
- :Case 'boundary'
- Boundary←value
- :EndSelect
-
- Cookies←ParseCookies Headers
-
- AcceptEncodings←ParseEncodings GetHeader'accept-encoding'
-
- makeResponse
-
- (Endpoint query)←'?'split Input
-
- :Trap 11 ⍝ trap domain error on possible bad UTF-8 sequence
- Endpoint←URLDecode Endpoint
- QueryParams←ParseQueryString query
- :If 'basic '≡lc 6↑auth←GetHeader'authorization'
- (UserID Password)←':'split Base64Decode 6↓auth
- :EndIf
- :Else
- Complete←1 ⍝ mark as complete
- Fail 400 ⍝ 400 = bad request
- →0
- :EndTrap
-
- noLength←0∊⍴length←GetHeader'content-length'
- len←⊃⊃(//)⎕VFI length
- Complete←('get'≡Method)∧noLength∨0=len ⍝ we're a GET and there's no content-length or content-length=0
- Complete∨←noLength>∨/'chunked'⍷GetHeader'transfer-encoding' ⍝ or no length supplied and we're not chunked
- Complete∨←noLength<0=len ⍝ or if content-length=0
- ∇
-
- ∇ makeResponse
- ⍝ create the response namespace
- Response←⎕NS''
- Response.(Status StatusText Payload)←200 'OK' ''
- Response.Headers←0 2⍴'' ''
- ∇
-
- ∇ ProcessBody args
- :Access public
- Body←args
- Complete←1
- ∇
-
- ∇ ProcessChunk args
- :Access public
- ⍝ args is [1] chunk content [2] chunk-extension name/value pairs (which we don't expect and won't process)
- Body,←1⊃args
- ∇
-
- ∇ ProcessTrailer args;inds;mask
- :Access public
- args[;1]←lc args[;1]
- mask←(≢Headers)≥inds←Headers[;1]⍳args[;1]
- Headers[mask/inds;2]←mask/args[;2]
- Headers⍪←(~mask)⌿args
- Complete←1
- ∇
-
- ∇ r←Hostname;h
- :Access public
- :If ~0∊⍴h←GetHeader'host'
- r←'http',(~Server.Secure)↓'s://',h
- :Else
- r←Server.Hostname
- :EndIf
- ∇
-
- ∇ params←ParseQueryString query
- params←0 2⍴⊂''
- →0⍴⍨0∊⍴query
- :If '='∊query ⍝ contains name=value?
- params←URLDecode¨2↑[2]↑'='(≠⊆⊢)¨'&'(≠⊆⊢)query
- :Else
- params←URLDecode query
- :EndIf
- ∇
-
- ∇ r←ParseEncodings encodings
- r←(⎕C(⊃¨';'(≠⊆⊢)¨','(≠⊆⊢)encodings~' '))∩'gzip' 'deflate'
- ∇
-
- ∇ cookies←ParseCookies headers;cookieHeader;cookie
- :Access public shared
- cookies←0 2⍴⊂''
- :For cookieHeader :In (headers[;1]≡¨⊂'cookie')/headers[;2]
- :For cookie :In (({⍵↓⍨+/∧\' '=⍵}⌽)⍣2)¨';'(≠⊆⊢)cookieHeader
- cookies⍪←2↑('='(≠⊆⊢)cookie),⊂''
- :EndFor
- :EndFor
- cookies←(⌽≠⌽cookies[;1])⌿cookies
- ∇
-
- ∇ r←URLDecode r;rgx;rgxu;i;j;z;t;m;⎕IO;lens;fill
- :Access public shared
- ⍝ Decode a Percent Encoded string https://en.wikipedia.org/wiki/Percent-encoding
- ⎕IO←0
- ((r='+')/r)←' '
- rgx←'[0-9a-fA-F]'
- rgxu←'%[uU]',(4×⍴rgx)⍴rgx ⍝ 4 characters
- r←(rgxu ⎕R{{⎕UCS 16⊥⍉16|'0123456789ABCDEF0123456789abcdef'⍳⍵}2↓⍵.Match})r
- :If 0≠⍴i←(r='%')/⍳⍴r
- :AndIf 0≠⍴i←(i≤¯2+⍴r)/i
- z←r[j←i∘.+1 2]
- t←'UTF-8'⎕UCS 16⊥⍉16|'0123456789ABCDEF0123456789abcdef'⍳z
- lens←⊃∘⍴¨'UTF-8'∘⎕UCS¨t ⍝ UTF-8 is variable length encoding
- fill←i[¯1↓+\0,lens]
- r[fill]←t
- m←(⍴r)⍴1 ⋄ m[(,j),i~fill]←0
- r←m/r
- :EndIf
- ∇
-
- base64←{⎕IO ⎕ML←0 1 ⍝ from dfns workspace - Base64 encoding and decoding as used in MIME.
- chars←'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/'
- bits←{,⍉(⍺⍴2)⊤⍵} ⍝ encode each element of ⍵ in ⍺ bits, and catenate them all together
- part←{((⍴⍵)⍴⍺↑1)⊂⍵} ⍝ partition ⍵ into chunks of length ⍺
- 0=2|⎕DR ⍵:2∘⊥∘(8∘↑)¨8 part{(-8|⍴⍵)↓⍵}6 bits{(⍵≠64)/⍵}chars⍳⍵ ⍝ decode a string into octets
- four←{ ⍝ use 4 characters to encode either
- 8=⍴⍵:'=='∇ ⍵,0 0 0 0 ⍝ 1,
- 16=⍴⍵:'='∇ ⍵,0 0 ⍝ 2
- chars[2∘⊥¨6 part ⍵],⍺ ⍝ or 3 octets of input
- }
- cats←⊃∘(,/)∘((⊂'')∘,) ⍝ catenate zero or more strings
- cats''∘four¨24 part 8 bits ⍵
- }
-
- ∇ r←{cpo}Base64Encode w
- ⍝ Base64 Encode
- ⍝ Optional cpo (code points only) suppresses UTF-8 translation
- ⍝ if w is numeric (single byte integer), skip any conversion
- :Access public shared
- :If 83=⎕DR w ⋄ r←base64 w
- :ElseIf 0=⎕NC'cpo' ⋄ r←base64'UTF-8'⎕UCS w
- :Else ⋄ r←base64 ⎕UCS w
- :EndIf
- ∇
-
- ∇ r←{cpo}Base64Decode w
- ⍝ Base64 Decode
- ⍝ Optional cpo (code points only) suppresses UTF-8 translation
- :Access public shared
- :If 0=⎕NC'cpo' ⋄ r←'UTF-8'⎕UCS base64 w
- :Else ⋄ r←⎕UCS base64 w
- :EndIf
- ∇
-
- ∇ r←{table}GetHeader name
- :Access Public Instance
- :If 0=⎕NC'table' ⋄ table←Headers ⋄ :EndIf
- table[;1]←lc table[;1]
- r←(lc name)GetFromTable table
- ∇
-
- ∇ name DefaultHeader value
- :Access public instance
- :If 0∊⍴Response.Headers GetHeader name
- name SetHeader value
- :EndIf
- ∇
-
- ∇ r←{endpoint}MakeURI resource
- :Access public instance
- ⍝ make a URI for a RESTful resource relative to the request endpoint
- :If 0≠⎕NC'endpoint'
- r←Hostname,endpoint,∊'/',¨⍕¨⊆resource
- :Else
- r←Hostname,Endpoint,∊'/',¨⍕¨⊆resource
- :EndIf
- ∇
-
- ∇ r←ErrorInfo
- :Trap 0
- r←⍕ErrorInfoLevel↑⎕DMX.(EM({⍵↑⍨⍵⍳']'}2⊃DM))
- :Else
- r←''
- :EndTrap
- ∇
-
- ∇ {(name value)}←name SetHeader value
- :Access Public Instance
- Response.Headers⍪←name(∊⍕value)
- ∇
-
- ∇ {(name cookie)}←name SetCookie cookie
- :Access public instance
- ⍝ create a response "set-cookie" header
- ⍝ cookie is the cookie value followed by any ;-delimited attributes
- 'set-cookie'SetHeader name,'=',cookie
- ∇
-
- ∇ {(name value)}←SetContentType contentType
- :Access public instance
- ⍝ shortcut function to set the response content-type header
- (name value)←'Content-Type'SetHeader contentType
- ∇
-
- ∇ value←GetCookie name
- :Access public instance
- ⍝ retrieve a request cookie
- value←(Cookies[;1]⍳⊆,name)⊃Cookies[;2],⊂''
- ∇
-
- ∇ {status}←{statusText}SetStatus status
- :Access public instance
- :If status≠0
- :If 0=⎕NC'statusText' ⋄ statusText←'' ⋄ :EndIf
- statusText←{0∊⍴⍵:⍵ ⋄ '('=⊣/⍵:⍵ ⋄ '(',⍵,')'}statusText
- statusText←deb((HttpStatus[;1]⍳status)⊃HttpStatus[;2],⊂''),' ',statusText
- Response.(Status StatusText)←status statusText
- :EndIf
- ∇
-
- ∇ r←ContentTypeForFile filename;ext
- :Access public instance
- ext←⊂1↓3⊃⎕NPARTS filename
- r←(ContentTypes[;1]⍳ext)⊃ContentTypes[;2],⊂'text/html'
- r,←('text/html'≡r)/'; charset=utf-8'
- ∇
-
- :EndClass
-
- :Section SessionHandler
-
- ∇ InitSessions
- ⍝ initialize session handling
- :If 0≠SessionTimeout ⍝ are we using sessions?
- _sessions←⍬
- _sessionsInfo←0 5⍴0 ⍝ [;1] id, [;2] IP address, [;3] creation time, [;4] last active time, [;5] ref to session
- ⎕RL←⍬
- :If 0 means no timeout and sessions are managed by the application
- _sessionThread←SessionMonitor&SessionTimeout
- :EndIf
- :EndIf
- ∇
-
- ∇ SessionMonitor timeout;expired;dead
- :Repeat
- :If 0<≢_sessionsInfo
- :Hold 'Sessions'
- :If ∨/expired←SessionTimeout IsExpired _sessionsInfo[;4] ⍝ any expired?
- ⍝ ↓↓↓ if a session expires, remove the namespace from _sessions
- ⍝ but leave the entry in _sessionsInfo (removing the namespace reference)
- ⍝ so that we can report to the user that his session timed out
- ⍝ if he returns before SessionCleanupTime passes
- _sessions~←expired/_sessionsInfo[;5] ⍝ remove from sessions list
- (expired/_sessionsInfo[;5])←0 ⍝ remove reference from _sessionsInfo
- :EndIf
- ⍝ ↓↓↓ SessionCleanupTime is used to clean up _sessionsInfo after a session has expired
- ⍝ In general SessionCleanupTime should be set to a value ≥ SessionTimeout
- :If ∨/dead←(0=_sessionsInfo[;5])∧SessionCleanupTime IsExpired _sessionsInfo[;4] ⍝ any expired sessions need their info removed?
- _sessionsInfo⌿⍨←~dead ⍝ remove from _sessionsInfo
- :EndIf
- :EndHold
- :EndIf
- {}⎕DL timeout×60
- :EndRepeat
- ∇
-
- MakeSessionId←{⎕IO←0 ⋄'abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789'[(?20⍴62),5↑1↓⎕TS]}
- IsExpired←{⍺≤0: 0 ⋄ (Now-⍵)>(⍺×60000)÷86400000}
-
- ∇ r←DateToIDNX ts
- ⍝ Date to IDN eXtended (will be replaced by ⎕DT when ⎕DT is in the latest 3 versions of Dyalog APL)
- r←(2 ⎕NQ'.' 'DateToIDN'(3↑ts))+(0 60 60 1000⊥¯4↑7↑ts)÷86400000
- ∇
-
- ∇ CreateSession req;ref;now;id;ts;rc
- id←MakeSessionId''
- now←Now
- :Hold 'Sessions'
- _sessions,←ref←⎕NS''
- _sessionsInfo⍪←id req.PeerAddr now now ref
- req.Session←ref
- :EndHold
- :If ~0∊⍴SessionInitFn
- :If 3=CodeLocation.⎕NC SessionInitFn
- :Trap 0 DebugLevel 1
- :Trap 85
- stopIf DebugLevel 2
- rc←SessionInitFn CodeLocation.{1(85⌶)⍺,' ⍵'}req
- :Else ⋄ rc←0
- :EndTrap
-
- :If 0≠rc
- (_sessions _sessionsInfo)←¯1↓¨_sessions _sessionsInfo
- →0⊣('Session intialization returned ',⍕rc)req.Fail 500
- :EndIf
- :Else
- →0⊣(⎕DMX.EM,' occurred during session initialization failed')req.Fail 500
- :EndTrap
- :Else
- →0⊣('Session initialization function "',SessionInitFn,'" not found')req.Fail 500
- :EndIf
- :EndIf
- :If SessionUseCookie
- SessionIdHeader req.SetCookie id,(SessionTimeout>0)/'; Max-Age=',⍕⌈60×SessionTimeout
- :Else
- SessionIdHeader req.SetHeader id
- :EndIf
- ∇
-
- ∇ r←KillSession id;ind
- ⍝ forcibly kill a session
- ⍝ r is 1 if session was killed, 0 if not found
- :Hold 'Sessions'
- :If r←(≢_sessionsInfo)≥ind←_sessionsInfo[;1]⍳⊆id
- _sessions~←_sessionsInfo[ind;5]
- _sessionsInfo⌿⍨←ind≠⍳≢_sessionsInfo
- :EndIf
- :EndHold
- ∇
-
- ∇ req TimeoutSession ind
- ⍝ assumes :Hold 'Sessions' is set in calling environment
- ⍝ removes session from _sessions and marks it as time out in _sessionsInfo
- _sessions~←_sessionsInfo[ind;5]
- _sessionsInfo⌿←ind≠⍳≢_sessionsInfo
- ∇
-
- ∇ ref←GetSession req;id
- :Access public
- ref←''
- →0⍴⍨0∊⍴id←GetSessionId req
- ref←(_sessionsInfo[;1]⍳⊂id)⊃(_sessionsInfo[;5],⊂'')
- ∇
-
- ∇ id←GetSessionId req
- :If SessionUseCookie
- id←req.GetCookie SessionIdHeader
- :Else
- id←req.GetHeader SessionIdHeader
- :EndIf
- ∇
-
- ∇ r←CheckSession req;ind;session;timedOut;id
- ⍝ check for valid session (only called if SessionTimeout≠0)
- r←1
- :Hold 'Sessions'
- id←GetSessionId req
- ind←_sessionsInfo[;1]⍳⊂id
- →0⍴⍨ind>≢_sessionsInfo
-
- :If 0∊⍴session←⊃_sessionsInfo[ind;5] ⍝ already timed out (session was already removed from _sessions)
- :OrIf SessionTimeout IsExpired _sessionsInfo[ind;4] ⍝ newly expired
- req TimeoutSession ind
- →0
- :EndIf
- ⍝ we have a valid session, refresh the cookie or set the header
- :If SessionUseCookie
- SessionIdHeader req.SetCookie id,(SessionTimeout>0)/'; Max-Age=',⍕⌈60×SessionTimeout
- :ElseIf
- SessionIdHeader req.SetHeader id
- :EndIf
- _sessionsInfo[ind;4]←Now
- req.Session←session
- r←0
- :EndHold
- ∇
-
- :EndSection
-
- :Section Utilities
-
- If←((0≠⊃)⊢)⍴⊣ ⍝ test for 0 return
- isChar←{0 2∊⍨10|⎕DR ⍵}
- toChar←{(⎕DR'')⎕DR ⍵}
- stripQuotes←{'""'≡2↑¯1⌽⍵:¯1↓1↓⍵ ⋄ ⍵} ⍝ strip leading and ending "
- deb←{{1↓¯1↓⍵/⍨~' '⍷⍵}' ',⍵,' '} ⍝ delete extraneous blanks
- dlb←{⍵↓⍨+/∧\' '=⍵} ⍝ delete leading blanks
- lc←{2::0(819⌶)⍵ ⋄ ¯3 ⎕C ⍵} ⍝ lower case
- uc←{2::1(819⌶)⍵ ⋄ 1 ⎕C ⍵} ⍝ upper case
- nameClass←{⎕NC⊂,'⍵'} ⍝ name class of argument
- nocase←{(lc ⍺)⍺⍺ lc ⍵} ⍝ case insensitive operator
- begins←{⍺≡(⍴⍺)↑⍵} ⍝ does ⍺ begin with ⍵?
- ends←{⍺≡(-≢⍺)↑⍵} ⍝ does ⍺ end with ⍵?
- match←{⍺ (≡nocase) ⍵} ⍝ case insensitive ≡
- sins←{0∊⍴⍺:⍵ ⋄ ⍺} ⍝ set if not set
- stopIf←{1∊⍵:-⎕TRAP←0 'C' '⎕←''Stopped for debugging... (Press Ctrl-Enter)''' ⋄ shy←0} ⍝ faster alternative to setting ⎕STOP
- show←{(2⊃⎕SI),'[',(⍕2⊃⎕LC),'] ',⍵} ⍝ debugging utility
- utf8←{3=10|⎕DR ⍵: 256|⍵ ⋄ 'UTF-8' ⎕UCS ⍵}
- fromutf8←{0::(⎕AV,'?')[⎕AVU⍳⍵] ⋄ 'UTF-8'⎕UCS ⍵} ⍝ Turn raw UTF-8 input into text
- sint←{⎕IO←0 ⋄ 83=⎕DR ⍵:⍵ ⋄ 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 ¯128 ¯127 ¯126 ¯125 ¯124 ¯123 ¯122 ¯121 ¯120 ¯119 ¯118 ¯117 ¯116 ¯115 ¯114 ¯113 ¯112 ¯111 ¯110 ¯109 ¯108 ¯107 ¯106 ¯105 ¯104 ¯103 ¯102 ¯101 ¯100 ¯99 ¯98 ¯97 ¯96 ¯95 ¯94 ¯93 ¯92 ¯91 ¯90 ¯89 ¯88 ¯87 ¯86 ¯85 ¯84 ¯83 ¯82 ¯81 ¯80 ¯79 ¯78 ¯77 ¯76 ¯75 ¯74 ¯73 ¯72 ¯71 ¯70 ¯69 ¯68 ¯67 ¯66 ¯65 ¯64 ¯63 ¯62 ¯61 ¯60 ¯59 ¯58 ¯57 ¯56 ¯55 ¯54 ¯53 ¯52 ¯51 ¯50 ¯49 ¯48 ¯47 ¯46 ¯45 ¯44 ¯43 ¯42 ¯41 ¯40 ¯39 ¯38 ¯37 ¯36 ¯35 ¯34 ¯33 ¯32 ¯31 ¯30 ¯29 ¯28 ¯27 ¯26 ¯25 ¯24 ¯23 ¯22 ¯21 ¯20 ¯19 ¯18 ¯17 ¯16 ¯15 ¯14 ¯13 ¯12 ¯11 ¯10 ¯9 ¯8 ¯7 ¯6 ¯5 ¯4 ¯3 ¯2 ¯1[utf8 ⍵]}
- Zipper←219⌶
-
- ∇ r←DyalogRoot
- r←{⍵,('/\'∊⍨⊢/⍵)↓'/'}{0∊⍴t←2 ⎕NQ'.' 'GetEnvironment' 'DYALOG':⊃1 ⎕NPARTS⊃2 ⎕NQ'.' 'GetCommandLineArgs' ⋄ t}''
- ∇
-
- ∇ r←MyAddr
- :Access public shared
- :Trap 0
- r←2 ⎕NQ #'TCPGetHostID'
- :Else
- r←'localhost'
- :EndTrap
- ∇
-
- ∇ r←crlf
- r←⎕UCS 13 10
- ∇
-
- ∇ QuadOFF
- ⍝ cover for ⎕OFF in case we want to add debugging
- ⎕OFF
- ∇
-
- ∇ r←Now
- r←DateToIDNX ⎕TS
- ∇
-
- ∇ r←InTerm;system
- :Access Public Shared
- ⍝ determine if interactive terminal is available
- →0⍴⍨r←~0∊⍴2 ⎕NQ'.' 'GetEnvironment' 'RIDE_INIT'
- →0⍴⍨r←'Win' 'Dev'≡system←3↑¨(⊂1 4)⌷'.'⎕WG'APLVersion'
- r←('Lin' 'Dev'≡system)∧{0::0 ⋄ 1⊣⎕SH'test -t 0'}''
- ∇
-
- ∇ r←fmtTS ts
- r←∊'YYYY-MM-DD @ hh.mm.ss.fff'(1200⌶)1 ⎕DT⊂⎕TS
- ∇
-
- ∇ r←a splitOn w
- ⍝ split a where w occurs (removing w from the result)
- r←a{⍺{(¯1+⊃¨⊆⍨⍵)↓¨⍵⊆⍺}(1+≢⍵)*⍵⍷⍺}w
- ∇
-
- ∇ r←a splitOnFirst w
- ⍝ split a on first occurence of w (removing w from the result)
- r←a{⍺{(¯1+⊃¨⊆⍨⍵)↓¨⍵⊆⍺}(1+≢⍵)*<\⍵⍷⍺}w
- ∇
-
- ∇ r←type ipRanges string;ranges
- r←''
- :Select ≢ranges←{('.'∊¨⍵){⊂1↓∊',',¨⍵}⌸⍵}string splitOn','
- :Case 0
- →0
- :Case 1
- r←,⊂((1+'.'∊⊃ranges)⊃'IPV6' 'IPV4')(⊃ranges)
- :Case 2
- r←↓'IPV4' 'IPV6',⍪ranges
- :EndSelect
- r←⊂(('Accept' 'Deny'⍳⊂type)⊃'AllowEndPoints' 'DenyEndPoints')r
- ∇
-
- ∇ r←isWin
- ⍝ are we running under Windows?
- r←'Win'≡3↑⊃#.⎕WG'APLVersion'
- ∇
-
- ∇ r←isRelPath w
- ⍝ is path w a relative path?
- r←{{~'/\'∊⍨(⎕IO+2×isWin∧':'∊⍵)⊃⍵}3↑⍵}w
- ∇
-
- ∇ r←isDir path
- ⍝ is path a directory?
- r←{22::0 ⋄ 1=1 ⎕NINFO ⍵}path
- ∇
-
- ∇ r←SourceFile;class
- :If 0∊⍴r←4⊃5179⌶class←⊃∊⎕CLASS ⎕THIS
- r←{6::'' ⋄ ∊1 ⎕NPARTS ⍵⍎'SALT_Data.SourceFile'}class
- :EndIf
- ∇
-
- ∇ r←makeRegEx w
- :Access public shared
- ⍝ convert a simple search using ? and * to regex
- r←{0∊⍴⍵:⍵
- {'^',(⍵~'^$'),'$'}{¯1=⎕NC('A'@(∊∘'?*'))r←⍵:('/'=⊣/⍵)↓(¯1×'/'=⊢/⍵)↓⍵ ⍝ already regex? (remove leading/trailing '/'
- r←∊(⊂'\.')@('.'=⊢)r ⍝ escape any periods
- r←'.'@('?'=⊢)r ⍝ ? → .
- r←∊(⊂'\/')@('/'=⊢)r ⍝ / → \/
- ∊(⊂'.*')@('*'=⊢)r ⍝ * → .*
- }⍵ ⍝ add start and end of string markers
- }w
- ∇
-
- ∇ (rc msg)←{root}LoadFromFolder path;type;name;nsName;parts;ns;files;folders;file;folder;ref;r;m;findFiles;pattern
- :Access public
- ⍝ Loads an APL "project" folder
- (rc msg)←0 ''
- root←{6::⍵ ⋄ root}#
- findFiles←{
- (names type hidden)←0 1 6(⎕NINFO⍠1)∊1 ⎕NPARTS path,'/',⍵
- names/⍨(~hidden)∧type=2
- }
- files←''
- :For pattern :In ','(≠⊆⊢)LoadableFiles
- files,←findFiles pattern
- :EndFor
- folders←{
- (names type hidden)←0 1 6(⎕NINFO⍠1)∊1 ⎕NPARTS path,'/*'
- names/⍨(~hidden)∧type=1
- }⍬
- :For file :In files
- :Trap 11
- 2(root ⍙FIX)'file://',file
- :Else
- msg,←'Unable to load file: ',file,⎕UCS 13
- :EndTrap
- :EndFor
- :For folder :In folders
- nsName←2⊃1 ⎕NPARTS folder
- ref←0
- :Select root.⎕NC⊂nsName
- :Case 9.1 ⍝ namespace
- ref←root⍎nsName
- :Case 0 ⍝ not defined
- ref←⍎nsName root.⎕NS''
- :Else ⍝ oops
- msg,←'"',folder,'" cannot be mapped to a valid namespace name',⎕UCS 13
- :EndSelect
- :If ref≢0
- (r m)←ref LoadFromFolder folder
- r←rc⌈r
- msg,←m
- :EndIf
- :EndFor
- msg←¯1↓msg
- rc←4××≢msg
- ∇
-
- ∇ {r}←{larg}(ref ⍙FIX)rarg;isArrayNotation;t;f;p
- ⍝ ⎕FIX cover that accommodates Array Notation and .apla files
- ⍝ revert to using ⎕FIX when it supports them
- larg←{6::⍵ ⋄ larg}1
- isArrayNotation←{~0 2∊⍨10|⎕DR ⍵:0 ⋄ {(⊃⍵)∊d←'[''¯.⊂⎕⍬',⎕D:1 ⋄ (2⊃2↑⍵)∊d,'( '}(∊⍵)~⎕UCS 9 32}
- :Trap 0
- :If 1=≡rarg
- :AndIf 'file://'≡7↑rarg
- :AndIf '.apla'≡lc⊃⌽p←⎕NPARTS f←7↓rarg
- :If larg=2
- r←ref⍎(2⊃p),'←',0 Deserialise⊃⎕NGET f
- :Else
- r←ref⍎0 Deserialise⊃⎕NGET f
- :EndIf
- :ElseIf isArrayNotation 1↓∊(⎕UCS 13),¨⊆rarg
- r←ref⍎0 Deserialise rarg
- :Else
- r←larg ref.⎕FIX rarg
- :EndIf
- :Else
- ⎕SIGNAL⊂t,⍪⎕DMX⍎1⌽')(',∊⍕t←'EN' 'EM' 'Message'
- :EndTrap
- ∇
-
- ∇ r←a Deserialise w;DEBUG;sysVars;Num;FirstNum;FirstNs
- :Access public shared
- ⍝ attempt to use the installed Deserialise
- :If 3=⎕SE.⎕NC'Dyalog.Array.Deserialise'
- r←a ⎕SE.Dyalog.Array.Deserialise w
- →0
- :EndIf
- ⍝ If Deserialise is not available in ⎕SE, the code below was lifted from the qSE repository commit 67a9ca1
- ⍝ Rather than embed the entirety of the Array namespace, just use Deserialise and the bits it depends on
- DEBUG←0
- sysVars←'⎕CT' '⎕DIV' '⎕IO' '⎕ML' '⎕PP' '⎕RL' '⎕RTL' '⎕WX' '⎕USING' '⎕AVU' '⎕DCT' '⎕FR'
- Num←2|⎕DR
- FirstNum←Num¨⊃⍤/⊢
- FirstNs←{9∊⎕NC'⍵'}¨⊃⍤/⊢
-
- ⍝ Deserialise code follows
- r←a{ ⍝ Convert text to array
- ⍺←⍬ ⍝ 1=safe exec expr; 0=return expr; ¯1=unsafe exec expr; ¯2=force APL model
- (model beSafe execute)←(¯2∘=,0∘⌈,1⌊|)FirstNum ⍺,1
- caller←FirstNs ⍺,⊃⎕RSI
-
- ⍝ Make normalised simple vector:
- w←↓⍣(2=≢⍴⍵)⊢⍵ ⍝ if mat, make nested
- w←{¯1↓∊⍵,¨⎕UCS 13}⍣(2=|≡w)⊢w ⍝ if nested, make simple
-
- beSafe>Safe w:⎕SIGNAL⊂('EN' 11)('Message' 'Unsafe array notation')
- ⍝ fall back to APL model on error
- ⍝ model∨/¯1↓bot:⍺ SubParse ⍵
- p←bot×SepMask ⍵
- ∨/p:∊{1=≢⍵:',⊂',⍵ ⋄ ⍵}⍺(Paren ∇)EachNonempty Over(p Split)⍵
- p←2(1,>/∨¯1↓0,0)∧(l≠1)∨(t=0))×+\(t=1)∧(l=1))⊆x ⍝ cut expression within level-1 parentheses
- 1=≢x:H ⍺ ∇⊃x ⍝ single expression : don't enclose with ¨
- DEBUG∧1<⌈/l:H ⍺ ∇¨x ⍝ force going through the hard code
- 10::H ⍺ ∇¨x ⋄ H ⍺⍎¨x ⍝ attempt to ⍎¨ with a single guard - otherwise dig each
- }
- DEBUG:⍺ ExecuteEach ⍵ ⍝ force going through the hard code
- 10::⍺ ExecuteEach ⍵ ⋄ ⍺⍎⍵ ⍝ attempt simple ⍎ and catch LIMIT ERROR
- }
-
- w←'''[^'']*''' '⍝.*'⎕R'&' ''⊢w ⍝ strip comments
- w/⍨←{(∨\⍵)∧⌽∨\⌽⍵}33≤⎕UCS w ⍝ strip leading/trailing non-printables
-
- pl←ParenLev w
- (0≠⊢/pl)∨(∨/0>pl):'Unmatched brackets'⎕SIGNAL 2
- ∨/(pl=0)×SepMask w:'Multi-line input'⎕SIGNAL 11
- caller Execute⍣execute⊢pl Parse w ⍝ materialise namespace as child of calling namespace
- }w
- ∇
-
- :EndSection
-
- :Section HTML
- ∇ r←ScriptFollows
- ⍝ return the subsequent block of comments as a text script
- r←{⍵/⍨'⍝'≠⊃¨⍵}{1↓¨⍵/⍨∧\'⍝'=⊃¨⍵}{⍵{((∨\⍵)∧⌽∨\⌽⍵)/⍺}' '≠⍵}¨(1+2⊃⎕LC)↓↓(180⌶)2⊃⎕XSI
- r←2↓∊(⎕UCS 13 10)∘,¨r
- ∇
-
- ∇ r←{path}EndPoints ref;ns
- :Access public
- :If 0=⎕NC'path' ⋄ path←''
- :Else ⋄ path,←'.'
- :EndIf
- r←path∘,¨{(⊂'')~⍨⍵.{⍵/⍨1 1 0≡×|⎕IO⊃⎕AT ⍵}¨⍵.⎕NL ¯3}ref ⍝ limit to result-returning monadic/dyadic/ambivalent functions
- :For ns :In ref.⎕NL ¯9.1
- r,←(path,ns)EndPoints ref⍎ns
- :EndFor
- ∇
-
- ∇ r←HtmlPage;endpoints
- :Access public
- r←ScriptFollows
-⍝
-⍝
-⍝
-⍝
-⍝
-⍝Jarvis
-⍝
-⍝
-⍝
-⍝
-⍝
-⍝
-⍝
-⍝