├── .gitignore ├── Sample ├── Utils │ └── Reverse.dyalog ├── GetSignObject.dyalog ├── GetSign.dyalog └── GetSignWithRequest.dyalog ├── Tests ├── mixed │ ├── reverse.dyalog │ ├── Excluded.dyalog │ ├── loans.dyalog │ ├── loansclass.dyalog │ └── demo.txt ├── teardown.dyalog ├── unit.dyalogtest ├── test_httputils.dyalog ├── test_httpclient.dyalog ├── setup.dyalog ├── Secure │ ├── PickCert.dyalog │ └── TestSecure.dyalog └── run │ └── testClass.dyalog ├── Distribution └── JSONServer.dws ├── Documentation ├── Images │ ├── Zodiac1.png │ ├── Zodiac2.png │ └── Zodiac3.png └── README.md ├── Dockerfile ├── Docker ├── Dockerfile ├── README.md └── run ├── Demos ├── Client.demo └── Server.demo ├── README.md ├── JSONServer.dyalogbuild ├── Source ├── Updates.dyalog ├── MakeSALTns.dyalog ├── AutoStart.dyalog └── JSONServer.dyalog ├── JSONServer.demo ├── Jenkinsfile └── LICENSE /.gitignore: -------------------------------------------------------------------------------- 1 | 2 | -------------------------------------------------------------------------------- /Sample/Utils/Reverse.dyalog: -------------------------------------------------------------------------------- 1 | r←Reverse data 2 | r←⌽data 3 | -------------------------------------------------------------------------------- /Tests/mixed/reverse.dyalog: -------------------------------------------------------------------------------- 1 | r←reverse data 2 | r←⌽data 3 | -------------------------------------------------------------------------------- /Distribution/JSONServer.dws: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Dyalog/JSONServer/master/Distribution/JSONServer.dws -------------------------------------------------------------------------------- /Documentation/Images/Zodiac1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Dyalog/JSONServer/master/Documentation/Images/Zodiac1.png -------------------------------------------------------------------------------- /Documentation/Images/Zodiac2.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Dyalog/JSONServer/master/Documentation/Images/Zodiac2.png -------------------------------------------------------------------------------- /Documentation/Images/Zodiac3.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Dyalog/JSONServer/master/Documentation/Images/Zodiac3.png -------------------------------------------------------------------------------- /Dockerfile: -------------------------------------------------------------------------------- 1 | FROM dyalog/dyalog 2 | 3 | ADD Docker/run / 4 | ADD . /JSONServer 5 | 6 | RUN mkdir -p /app 7 | 8 | EXPOSE 8080 9 | -------------------------------------------------------------------------------- /Tests/teardown.dyalog: -------------------------------------------------------------------------------- 1 | r←teardown dummy 2 | ⍝ teardown DRC and Conga 3 | r←'' 4 | {}#.⎕EX'DRC' 'Conga' 'HttpCommand' 'test_httpcommand' 5 | -------------------------------------------------------------------------------- /Sample/GetSignObject.dyalog: -------------------------------------------------------------------------------- 1 | ns←GetSignObject ns 2 | ⍝ Return a sign object contain month, day (provided as input) and sign 3 | 4 | ns.sign←GetSign ns.(month day) 5 | -------------------------------------------------------------------------------- /Documentation/README.md: -------------------------------------------------------------------------------- 1 | ## Documentation for JSONServer can be found on [our wiki](https://github.com/Dyalog/JSONServer/wiki) 2 | This folder hosts images used on the wiki 3 | -------------------------------------------------------------------------------- /Tests/mixed/Excluded.dyalog: -------------------------------------------------------------------------------- 1 | r←Excluded data 2 | ⍝ this demo function should not be able to be called with ExcludeFns set to '[A-Z].*' 3 | r←'This function would be excluded if ExcludeFns had [A-Z].*' 4 | -------------------------------------------------------------------------------- /Tests/unit.dyalogtest: -------------------------------------------------------------------------------- 1 | DyalogTest : 0.1 2 | ID : JSONServer_Basic_Unit 3 | Description: Basic unit tests for JSONServer.dyalog 4 | 5 | Setup : setup 6 | Teardown: teardown 7 | ⍝Test : test_get 8 | -------------------------------------------------------------------------------- /Tests/test_httputils.dyalog: -------------------------------------------------------------------------------- 1 | :Namespace test_httputils 2 | 3 | (⎕IO ⎕ML)←1 1 4 | 5 | check←{⍺≡⍵:'' ⋄ (2⊃⎕SI),': Expected [',(1↓,(⎕UCS 13),⍕⍺),'] got [',(1↓,(⎕UCS 13),⍕⍵),']'} 6 | 7 | _true←⊂'true' 8 | 9 | :EndNamespace 10 | -------------------------------------------------------------------------------- /Tests/test_httpclient.dyalog: -------------------------------------------------------------------------------- 1 | {r}←test_httpclient dummy;result;t 2 | t←#.test_httpcommand 3 | result←#.HttpCommand.Get t._httpbin,'/gzip' 4 | r←(0 200,t._true,(⊂'gzip'))t.check result.(rc HttpStatus),((t.fromJSON result.Data).gzipped),⊂result.Headers #.HttpCommand.Lookup'content-encoding' 5 | -------------------------------------------------------------------------------- /Docker/Dockerfile: -------------------------------------------------------------------------------- 1 | FROM dyalog/dyalog:17.1-dbg 2 | 3 | RUN apt-get update && apt-get install -y git && \ 4 | apt-get clean && rm -Rf /var/lib/apt/lists/* 5 | 6 | RUN git clone https://github.com/Dyalog/JSONServer /JSONServer 7 | 8 | RUN mkdir /app 9 | 10 | EXPOSE 8080 11 | ADD run / 12 | -------------------------------------------------------------------------------- /Tests/setup.dyalog: -------------------------------------------------------------------------------- 1 | r←setup dummy;home 2 | ⍝ Setup test 3 | ⎕IO←⎕ML←1 4 | r←'' 5 | :Trap 0 6 | home←##.TESTSOURCE ⍝ hopefully good enough... 7 | {}⎕SE.SALT.Load 'HttpCommand' 8 | {}⎕SE.SALT.Load 'HttpUtils' 9 | {}#.⎕FIX'file://',home,'test_httputils.dyalog' 10 | :Else 11 | r←,⍕⎕DM 12 | :EndTrap 13 | -------------------------------------------------------------------------------- /Sample/GetSign.dyalog: -------------------------------------------------------------------------------- 1 | sign←GetSign date;dates;signs 2 | ⍝ Compute sign of the Zodiac from a 2-element integer vector containing [Month,Day] 3 | 4 | signs←13⍴'Capricorn' 'Aquarius' 'Pisces' 'Aries' 'Taurus' 'Gemini' 'Cancer' 'Leo' 'Virgo' 'Libra' 'Scorpio' 'Sagittarius' 5 | dates←119 218 320 419 520 620 722 822 922 1022 1121 1221 6 | sign←signs⊃⍨1+dates⍸100⊥2↑date 7 | -------------------------------------------------------------------------------- /Demos/Client.demo: -------------------------------------------------------------------------------- 1 | ⍝ Calling JSONServer 2 | )clear 3 | 4 | ]load HttpCommand 5 | cmd←⎕NEW HttpCommand 6 | cmd.(Command URL)←'POST' 'localhost:8080/GetSign' 7 | cmd.Headers⍪←'content-type' 'application/json' 8 | cmd.Params←⎕JSON 10 31 ⍝ '[10,31]' 9 | q←cmd.Run 10 | q.(rc Data) 11 | 12 | cmd.Params←'["October",31]' 13 | q←cmd.Run 14 | q.(rc HttpStatus HttpMessage) 15 | q.Data 16 | -------------------------------------------------------------------------------- /Docker/README.md: -------------------------------------------------------------------------------- 1 | # Dyalog JSON Server 2 | ## Usage 3 | ### Running the container: 4 | Run the container with the following command changing the path to your source 5 | ```sh 6 | docker run -p 8080 -v /path/to/source/code:/code dyalog/jsonserver:latest 7 | ``` 8 | ### Access the Web Interface 9 | 10 | Once the container is running, you will be able to navigate to http://localhost:8080, you will see a web form to query the REST Server. 11 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Dyalog JSONServer 2 | ## Note: JSONServer is no longer in active development and has been archived.
JSONServer's successor, [Jarvis](https://github.com/Dyalog/Jarvis) is the recommended framework for JSON-based web services. 3 | 4 | A light-weight APL-based HTTP server to call APL code from the net by passing arguments and results as JSON. 5 | ### Documentation 6 | Please see [our wiki](https://github.com/Dyalog/JSONServer/wiki). 7 | -------------------------------------------------------------------------------- /JSONServer.dyalogbuild: -------------------------------------------------------------------------------- 1 | DyalogBuild: 0.1 2 | ID : JSONServer, Version=0.9 3 | Description: Simple JSON Web Service 4 | Defaults : ⎕IO←⎕ML←1 5 | TARGET : Distribution/JSONServer.dws 6 | 7 | APL : Source/*.dyalog, Target=# 8 | LIB : HttpCommand, Target=# 9 | EXEC : MakeSALTns 10 | EXEC : ⎕EX 'MakeSALTns' 11 | LX : ⍎(⎕IO+0∊⍴2⎕NQ'.' 'GetEnvironment' 'AttachDebugger')⊃'⎕←''Autostart not run because AttachDebugger was set''' 'Server←AutoStart' -------------------------------------------------------------------------------- /Source/Updates.dyalog: -------------------------------------------------------------------------------- 1 | Updates;t;n;commits 2 | ⍝ check up to last 5 updates to repository 3 | :Trap 0 4 | t←HttpCommand.Get'http://api.github.com/repos/Dyalog/JSONServer/commits' 5 | n←5⌊≢commits←⎕JSON t.Data ⍝ last commit should be for this workspace 6 | ⎕←'The last ',(⍕n),' commits to repository http://github.com/Dyalog/JSONServer are:' 7 | ⎕←1↓∊(⎕UCS 13),¨¨(n↑commits).commit.(((⎕UCS 13),author.date)message) 8 | :Else 9 | ⎕←'!! unable to check updates - ',⍕2↑⎕DM 10 | :EndTrap 11 | -------------------------------------------------------------------------------- /JSONServer.demo: -------------------------------------------------------------------------------- 1 | )clear 2 | ]load /bb/JSONServer/Source/JSONServer 3 | srv←⎕NEW JSONServer 4 | srv.CodeLocation←'/bb/JSONServer/Sample/' 5 | srv.Port←8080 6 | srv.Start 7 | 8 | ⍝ Now make a call to it: 9 | ]load HTTPCommand 10 | cmd←⎕NEW HttpCommand 11 | cmd.(Command URL)←'POST' 'localhost:8080/GetSign' 12 | cmd.Headers⍪←'content-type' 'application/json' 13 | cmd.Params←'[10,31]' 14 | q←cmd.Run 15 | q.rc 16 | q.Data 17 | 18 | cmd.Params←'[10,31]' 19 | q←cmd.Run 20 | q.rc 21 | q.HttpStatus 22 | q.HttpMessage 23 | 24 | -------------------------------------------------------------------------------- /Sample/GetSignWithRequest.dyalog: -------------------------------------------------------------------------------- 1 | r←req GetSignWithRequest date;dates;signs 2 | ⍝ Compute sign of the Zodiac from a 2-element integer vector containing [Month,Day] 3 | r←⎕NS'' 4 | signs←13⍴'Capricorn' 'Aquarius' 'Pisces' 'Aries' 'Taurus' 'Gemini' 'Cancer' 'Leo' 'Virgo' 'Libra' 'Scorpio' 'Sagittarius' 5 | dates←119 218 320 419 520 620 722 822 922 1022 1121 1221 6 | r.sign←signs⊃⍨1+dates⍸100⊥2↑date 7 | r.ipAddr←req.PeerAddr 8 | :If ~0∊⍴req.PeerCert 9 | r.certSubj←req.PeerCert.Formatted.Subject 10 | :EndIf 11 | -------------------------------------------------------------------------------- /Jenkinsfile: -------------------------------------------------------------------------------- 1 | def json 2 | 3 | node ('Docker') { 4 | stage ('Checkout') { 5 | checkout scm 6 | } 7 | withDockerRegistry(credentialsId: '6d50b250-e0a3-4240-91de-b11a1b206597') { 8 | stage ('Build JSONServer Container') { 9 | json=docker.build('dyalog/jsonserver', '--no-cache .') 10 | } 11 | stage ('Publish JSONServer Container') { 12 | json.push(); 13 | } 14 | } 15 | stage ('Cleanup') { 16 | sh 'docker image prune -f' 17 | } 18 | } 19 | -------------------------------------------------------------------------------- /Tests/Secure/PickCert.dyalog: -------------------------------------------------------------------------------- 1 | r←PickCert store;certs 2 | r←⍬ 3 | :If 0∊⍴store ⋄ store←'My' ⋄ :EndIf 4 | :If 'W'=⊃3⊃#.⎕WG'APLVersion' 5 | :If ~0∊⍴certs←#.DRC.X509Cert.ReadCertFromStore'My' 6 | ⎕←'Select a certificate:' 7 | ⎕←(⍳≢certs),⍪certs.Formatted.Subject 8 | :Trap 0 9 | r←⎕⊃certs 10 | :Else 11 | ⎕←'No certificate selected' 12 | :EndTrap 13 | :Else 14 | ⎕←'No certificates in your Windows certificate store' 15 | :EndIf 16 | :Else 17 | ⎕←'This can run on Windows only.' 18 | :EndIf 19 | -------------------------------------------------------------------------------- /Demos/Server.demo: -------------------------------------------------------------------------------- 1 | ⍝ NB requires v16.0 or later 2 | ⍝ NB to run this demo: 3 | ⍝ Replace [JSONServer] in the lines below with the folder where you have downloaded or cloned the JSONServer repository 4 | )clear 5 | ⎕pw←1000 6 | )ns Zodiac 7 | ]load [JSONServer]/Sample/* -target=Zodiac 8 | ⎕VR 'Zodiac.GetSign' 9 | Zodiac.GetSign 10 31 10 | 11 | (halloween←⎕NS '').(month day)←10 31 12 | hweensign←Zodiac.GetSignObject halloween 13 | hweensign.(month day sign) 14 | ⎕JSON hweensign 15 | 16 | ]load [JSONServer]/Source/JSONServer 17 | srv←⎕NEW JSONServer 18 | srv.CodeLocation←#.Zodiac 19 | srv.Port←8080 20 | srv.Start 21 | ⍝ Now run the client demo 22 | srv.Stop 23 | 24 | )clear 25 | ]load [JSONServer]/Source/JSONServer 26 | ⎕←(srv rc)←JSONServer.Run (8080 '/devt/JSONServer/Sample') 27 | 28 | ⍝ dyalog [JSONServer]/Distribution/JSONServer.dws -Port=8080 -CodeLocation="[JSONServer]/Sample" 29 | -------------------------------------------------------------------------------- /Source/MakeSALTns.dyalog: -------------------------------------------------------------------------------- 1 | MakeSALTns 2 | ⍝ This program recreates the #.SALT namespace from ⎕SE's namespaces. 3 | ⍝ The #.SALT namespace is used when running in a runtime environment 4 | #.⎕EX'SALT' 5 | 'SALT'#.⎕NS'' 6 | #.SALT.⎕FIX¨⎕SRC¨⎕SE.(SALTUtils SALT Parser UnicodeFile) 7 | ⍝ To avoid cross reference between ⎕SE and # we do not use ⎕NS∘⎕OR 8 | 'Dyalog'#.SALT.⎕NS'⎕se.Dyalog.Callbacks' 9 | #.SALT.Dyalog.⎕FIX ⎕SRC ⎕SE.Dyalog.Utils 10 | #.SALT.⎕FX(fn+1)↓⎕CR 1⊃⎕SI 11 | ⎕←'#.SALT namespace recreated' 12 | →0 13 | 14 | fn: ⍝ This code defined in the namespace 15 | Boot 16 | ⍝ Move a local copy of SALT into ⎕SE 17 | ⎕SE.⎕FIX¨#.SALT.(⎕SRC¨SALTUtils SALT Parser UnicodeFile) 18 | 19 | ⍝ The Dyalog namespace is a bit more complicated 20 | ⎕EX'⎕se.Dyalog' ⋄ '⎕SE.Dyalog'⎕NS ⍬ 21 | 22 | ⍝ We cannot do 23 | ⍝ 'Dyalog'⎕SE.⎕NS ⎕OR'SALT.Dyalog' 24 | ⍝ because this will keep a reference to # in ⎕SE 25 | ⍝ so we do this: 26 | ⎕SE.Dyalog.⎕FIX ⎕SRC Dyalog.Utils 27 | '⎕se.Dyalog.Callbacks'⎕NS ⎕OR'Dyalog.Callbacks' 28 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2020 Dyalog Ltd. 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /Tests/Secure/TestSecure.dyalog: -------------------------------------------------------------------------------- 1 | TestSecure pathToJSONServer 2 | :If 0=⎕NC'JSONServer' 3 | ⎕SE.SALT.Load pathToJSONServer,'/Source/JSONServer.dyalog' 4 | :EndIf 5 | ⎕SE.SALT.Load pathToJSONServer,'/Sample/GetSign*.dyalog' 6 | js←⎕NEW JSONServer 7 | dyalog←2 ⎕NQ'.' 'GetEnvironment' 'Dyalog' 8 | js.Secure←1 9 | js.SSLValidation←64 ⍝ request, but do not require a certificate 10 | js.RootCertDir←dyalog,'\TestCertificates\Ca\' 11 | js.ServerCertFile←dyalog,'\TestCertificates\Server\localhost-cert.pem' 12 | js.ServerKeyFile←dyalog,'\TestCertificates\Server\localhost-key.pem' 13 | ⎕FX↑'r←ValidateRequest req' 'r←0' ':if ~0∊⍴req.PeerCert ⋄ ''Subject'' ''Valid From'' ''Valid To'',⍪⊃req.PeerCert.Formatted.(Subject ValidFrom ValidTo) ⋄ :EndIf ' 14 | js.Start 15 | ⎕←(⎕UCS 13),'⍝ To test using HttpCommand:' 16 | ⎕←'⍝ Make sure you have HttpCommand.Version 2.1.17 or later.' 17 | ⎕←' d←2 ⎕NQ ''.'' ''GetEnvironment'' ''dyalog''' 18 | ⎕←' key←d,''/TestCertificates/client/John Doe-key.pem''' 19 | ⎕←' cert←d,''/TestCertificates/client/John Doe-cert.pem''' 20 | ⎕←' r←HttpCommand.GetJSON''post'' ''localhost:8080/GetSign''(2,23)''''(cert key)' 21 | -------------------------------------------------------------------------------- /Tests/run/testClass.dyalog: -------------------------------------------------------------------------------- 1 | :Class testClass 2 | 3 | :Field public field1 4 | :Field _prop1←'prop1 value' 5 | 6 | :Property prop1 7 | :Access public 8 | ∇ r←Get 9 | r←_prop1 10 | ∇ 11 | 12 | ∇ Set arg 13 | _prop1←arg.NewValue 14 | ∇ 15 | :EndProperty 16 | 17 | ∇ make 18 | :Access public 19 | :Implements constructor 20 | field1←'default' 21 | ∇ 22 | 23 | ∇ make1 arg 24 | :Access public 25 | :Implements constructor 26 | field1←arg 27 | ∇ 28 | 29 | ∇ niladic 30 | :Access public 31 | ∇ 32 | 33 | ∇ r←niladic_result 34 | :Access public 35 | (r←⎕NS'').result←'Result from niladic_result' 36 | ∇ 37 | 38 | ∇ monadic rarg 39 | :Access public 40 | ∇ 41 | 42 | ∇ r←monadic_result rarg 43 | :Access public 44 | (r←⎕NS'').(result rarg)←'Result from monadic_result'rarg 45 | ∇ 46 | 47 | ∇ larg dyadic rarg 48 | :Access public 49 | ∇ 50 | 51 | ∇ r←larg dyadic_result rarg 52 | :Access public 53 | (r←⎕NS'').(result larg rarg)←'Result from dyadic_result'larg rarg 54 | ∇ 55 | 56 | :EndClass 57 | -------------------------------------------------------------------------------- /Source/AutoStart.dyalog: -------------------------------------------------------------------------------- 1 | {ref}←AutoStart;empty;validParams;mask;values;params;param;value;rc;msg;getEnv;NoSession;ts;t;commits;n;debug;tonum 2 | ⍝ JSONServer automatic startup 3 | ⍝ General logic: 4 | ⍝ Command line parameters take priority over configuration file which takes priority over default 5 | 6 | empty←0∊⍴ 7 | tonum←{0∊⍴⍵:⍵ ⋄ ∧/⊃t←⎕VFI ⍵:⊃(⎕IO+1)⊃t ⋄ ⍵} 8 | getEnv←{tonum 2 ⎕NQ'.' 'GetEnvironment'⍵} 9 | 10 | :If 0=⎕NC'⎕SE.SALT' 11 | #.SALT.Boot 12 | :EndIf 13 | 14 | validParams←'ConfigFile' 'CodeLocation' 'Port' 'InitializeFn' 'AllowedFns' 'Secure' 'RootCertDir' 'SSLValidation' 'ServerCertFile' 'ServerKeyFile' 'Debug' 15 | mask←~empty¨values←getEnv¨validParams 16 | params←mask⌿validParams,⍪values 17 | NoSession←~empty getEnv'NoSession' 18 | ref←'No server running' 19 | 20 | :If ~empty params 21 | ref←⎕NEW #.JSONServer 22 | :For (param value) :In ↓params ⍝ need to load one at a time because params can override what's in the configuration file 23 | param(ref{⍺⍺⍎⍺,'←⍵'})value 24 | :If 'ConfigFile'≡param 25 | :If 0≠⊃(rc msg)←ref.LoadConfiguration value 26 | →0⊣ref←'Error loading configuration file "',value,'": ',msg 27 | :EndIf 28 | :EndIf 29 | :EndFor 30 | 31 | :If 0≠⊃(rc msg)←ref.Start 32 | (∊⍕'Unable to start server - ',msg)⎕SIGNAL 16 33 | :EndIf 34 | 35 | :If NoSession∨'R'=3⊃#.⎕WG'APLVersion' ⍝ no session or runtime? 36 | :While ref.Running 37 | {}⎕DL 10 38 | :EndWhile 39 | :EndIf 40 | :EndIf 41 | -------------------------------------------------------------------------------- /Tests/mixed/loans.dyalog: -------------------------------------------------------------------------------- 1 | :Namespace loans 2 | 3 | ∇ r←payment npr 4 | ⍝ npr - [1] principal, [2] rate %, [3] term in years 5 | r←{0::'Error' ⋄ p r n←⍵÷1 1200(÷12) ⋄ 0.01×⌈100×p×r÷1-(1+r)*-n}npr 6 | ∇ 7 | 8 | ∇ r←afford_ns ns 9 | ⍝ returns array of what you can afford based on rates using a namespace 10 | ⍝ ns.rates - vector of rates (%) 11 | ⍝ ns.terms - vector of terms in years 12 | ⍝ ns.payments - desired payment 13 | r←{0::'Error' ⋄ r n m←⍵÷1200(÷12)1 ⋄ 0.01×⌈100×m∘.÷r(÷⍤¯1)1-(1+r)∘.*-n}ns.(rates terms payments) 14 | ∇ 15 | 16 | ∇ r←afford(rates terms payments) 17 | ⍝ returns array of what you can afford based on rates 18 | ⍝ rates - vector of rates (%) 19 | ⍝ terms - vector of terms in years 20 | ⍝ payments - desired payment 21 | r←{0::'Error' ⋄ r n m←⍵÷1200(÷12)1 ⋄ 0.01×⌈100×m∘.÷r(÷⍤¯1)1-(1+r)∘.*-n}rates terms payments 22 | ∇ 23 | 24 | ⍝ the functions below exist solely as test cases for different function syntaxes to be called by _Run 25 | 26 | ∇ niladic 27 | ⎕←(⊃⎕XSI),' called' 28 | ∇ 29 | 30 | ∇ r←niladic_result 31 | ⎕←(⊃⎕XSI),' called' 32 | r←'niladic_result result' 33 | ∇ 34 | 35 | ∇ monadic rarg 36 | ⎕←(⊃⎕XSI),' called' 37 | ∇ 38 | 39 | ∇ r←monadic_result rarg 40 | ⎕←(⊃⎕XSI),' called' 41 | r←'monadic_result result' 42 | ∇ 43 | 44 | ∇ larg dyadic rarg 45 | ⎕←(⊃⎕XSI),' called' 46 | ∇ 47 | 48 | ∇ r←larg dyadic_result rarg 49 | ⎕←(⊃⎕XSI),' called' 50 | r←'dyadic_result result' 51 | ∇ 52 | 53 | :EndNamespace 54 | -------------------------------------------------------------------------------- /Docker/run: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | ## This file replaces the Dyalog mapl script 4 | echo " _______ __ _ ____ _____ " 5 | echo "| __ \ \ / //\ | | / __ \ / ____|" 6 | echo "|_| | \ \_/ // \ | | | | | | | " 7 | echo " | |\ // /\ \ | | | | | | | _ " 8 | echo " ____| | | |/ / \ \| |___| |__| | |__| |" 9 | echo "|_____/ |_/_/ \_\______\____/ \_____|" 10 | echo "" 11 | echo "https://www.dyalog.com" 12 | echo "" 13 | echo "*************************************************************************************" 14 | echo "* This software is for non-commercial evaluation ONLY *" 15 | echo "* https://www.dyalog.com/uploads/documents/Private_Personal_Educational_Licence.pdf *" 16 | echo "*************************************************************************************" 17 | echo "" 18 | 19 | export MAXWS=${MAXWS-256M} 20 | 21 | export DYALOG=/opt/mdyalog/17.1/64/unicode/ 22 | export WSPATH=/opt/mdyalog/17.1/64/unicode/ws 23 | export TERM=dumb 24 | export APL_TEXTINAPLCORE=${APL_TEXTINAPLCORE-1} 25 | export TRACE_ON_ERROR=1 26 | export SESSION_FILE="${SESSION_FILE-$DYALOG/default.dse}" 27 | 28 | export Port=8080 29 | 30 | if [ $(ls /app 2>/dev/null | wc -l) -gt 0 ]; then 31 | echo "Application code found in /app." 32 | CODEL=/app 33 | else 34 | echo "No application found in /app. Running with sample app" 35 | CODEL=/JSONServer/Sample 36 | fi 37 | export CodeLocation=${CodeLocation-$CODEL} 38 | 39 | 40 | cd /JSONServer 41 | 42 | if [ -n "$RIDE_INIT" ]; then 43 | $DYALOG/dyalog +s -q /JSONServer/Distribution/JSONServer.dws 44 | else 45 | $DYALOG/dyalog -s /JSONServer/Distribution/JSONServer.dws 46 | fi 47 | -------------------------------------------------------------------------------- /Tests/mixed/loansclass.dyalog: -------------------------------------------------------------------------------- 1 | :Class loansclass 2 | 3 | :field public rates←5 6 4 | :field public terms←10 15 20 30 5 | :field public principals←100000 150000 200000 6 | 7 | ∇ make 8 | :Access public 9 | :Implements constructor 10 | ∇ 11 | 12 | ∇ make1 ns;name 13 | :Access public 14 | :Implements constructor 15 | :For name :In ns.⎕NL ¯2 16 | :Select name 17 | :Case 'rates' 18 | rates←ns.rates 19 | :Case 'terms' 20 | terms←ns.rates 21 | :Case 'principals' 22 | principals←ns.rates 23 | :EndSelect 24 | :EndFor 25 | ∇ 26 | 27 | ∇ r←payments 28 | :Access public 29 | ⍝ return array of payments for principals ∘. rates ∘. terms 30 | r←{0::'Error' ⋄ p r n←⍵÷1 1200(÷12) ⋄ 0.01×⌈100×p∘.×r(÷⍤¯1)1-(1+r)∘.*-n}principals rates terms 31 | ∇ 32 | 33 | ⍝ the methods below exist to be able to test the ability to execute methods of any syntax using _Run 34 | 35 | ∇ niladic 36 | :Access public 37 | ⎕←(⊃⎕XSI),' called' 38 | ∇ 39 | 40 | ∇ r←niladic_result 41 | :Access public 42 | ⎕←(⊃⎕XSI),' called' 43 | r←'niladic_result result' 44 | ∇ 45 | 46 | ∇ monadic rarg 47 | :Access public 48 | ⎕←(⊃⎕XSI),' called' 49 | ∇ 50 | 51 | ∇ r←monadic_result rarg 52 | :Access public 53 | ⎕←(⊃⎕XSI),' called' 54 | r←'monadic_result result' 55 | ∇ 56 | 57 | ∇ larg dyadic rarg 58 | :Access public 59 | ⎕←(⊃⎕XSI),' called' 60 | ∇ 61 | 62 | ∇ r←larg dyadic_result rarg 63 | :Access public 64 | ⎕←(⊃⎕XSI),' called' 65 | r←'dyadic_result result' 66 | ∇ 67 | 68 | :EndClass 69 | -------------------------------------------------------------------------------- /Tests/mixed/demo.txt: -------------------------------------------------------------------------------- 1 | ⍝ Demo/Test script 2 | &' 3 | ]load HttpCommand 4 | ]load /git/JSONServer/Source/JSONServer 5 | )copy dfns disp 6 | 7 | 8 | &' 9 | ⍝ --- define a couple utilities --- 10 | showJSON←{0∊⍴⍵:⍵ ⋄ 1(⎕JSON⍠'Compact' 0)0⎕JSON ⍵} 11 | showReq←{req←disp 'URL' 'Params',⍪⍺.(URL Params) ⋄ resp←disp 'HTTP Status' 'Data',⍪(⍕⍵.(HttpStatus HttpMessage))(showJSON ⍵.Data) ⋄ ⍪,'Request' 'Response',⍪req resp} 12 | 13 | &' 14 | ⍝ --- Create the Server --- 15 | &' 16 | srv←⎕NEW JSONServer ⍝ create the server 17 | srv.ClassInterface←1 ⍝ turn class interface on 18 | srv.CodeLocation←'/git/JSONServer/Tests/mixed/' ⍝ where to load the code from 19 | srv.Port←8080 ⍝ port to listen on 20 | srv.ExcludeFns←'_*' '[A-Z].*' ⍝ exclude any functions beginning with _ or uppercase 21 | srv.Start ⍝ start the server 22 | 23 | &' 24 | ⍝ --- Create the client --- 25 | &' 26 | cmd←⎕NEW HttpCommand ⍝ create a client 27 | baseURL←'http://localhost:8080/' ⍝ base URL 28 | cmd.Command←'post' ⍝ all JSONServer requests are "post" 29 | 'content-type' cmd.AddHeader 'application/json' ⍝ set the content-type 30 | 31 | &' 32 | ⍝ --- Simple function call --- 33 | &' 34 | #.CodeLocation.⎕VR 'reverse' 35 | ⎕←cmd.URL←baseURL,'reverse' ⍝ function to call 36 | cmd.Params←'"Dyalog JSONServer"' ⍝ data to pass (simple string in this case) 37 | resp←cmd.Run ⍝ submit the request 38 | &' 39 | ⍝ --- HttpCommand.Run returns a namespace --- 40 | resp.⎕NL ¯2 ¯9 41 | resp.(HttpStatus HttpMessage) ⍝ check the status 42 | resp.Data ⍝ show the response's data 43 | cmd showReq resp 44 | &' 45 | ⍝ --- functions in namespaces can be referenced directly in the URL --- 46 | ⎕←cmd.URL←baseURL,'loans/payment' ⍝ loan payment calulator 47 | cmd.Params←'[100000,5.5,30]' ⍝ principal, interest rate, years 48 | cmd showReq cmd.Run 49 | &' 50 | ⍝ --- ExcludedFns is used to exclude or hide functions from JSONServer --- 51 | &' 52 | cmd.URL←baseURL,'Excluded' ⍝ should not be allowed because of ExcludeFns 53 | cmd showReq cmd.Run ⍝ submit the request 54 | srv.ExcludeFns 55 | &' 56 | srv.ExcludeFns←'_*' ⍝ remove the [A-Z].* exclusion 57 | &' 58 | cmd showReq cmd.Run 59 | &' 60 | ⍝ --- Class Interface --- 61 | ⍝ uses "built-in" functions _New _Get _Set _Run _Classes _Instances _Serialize 62 | &' 63 | cmd.URL←baseURL,'_Classes' ⍝ what classes are available? 64 | cmd.Params←'' ⍝ no arguments 65 | cmd showReq cmd.Run 66 | &' 67 | ⍝ Note: Every class interface function returns "rc" and "message" 68 | &' 69 | ⍝ --- Create an instance --- 70 | &' 71 | cmd.URL←baseURL,'_New' 72 | cmd.Params←'{"className":"loansclass"}' 73 | resp←cmd.Run ⍝ submit the request 74 | cmd showReq resp 75 | &' 76 | instance←(⎕JSON resp.Data).instanceName ⍝ grab the instance name for later use 77 | &' 78 | ⍝ --- Let's try creating an instance of a class that doesn't exist --- 79 | &' 80 | cmd.Params←'{"className":"BadClassName"}' 81 | cmd showReq cmd.Run 82 | &' 83 | ⍝ --- Setting a public field or property with _Set --- 84 | &' 85 | cmd.URL←baseURL,'_Set' ⍝ set a field or property 86 | cmd.Params←'{"instanceName":"',instance,'","what":"rates","value":[5,6,7]}' 87 | cmd showReq cmd.Run 88 | &' 89 | ⍝ --- Retrieving a public field or property with _Get --- 90 | &' 91 | cmd.URL←baseURL,'_Get' 92 | cmd.Params←'{"instanceName":"',instance,'","what":"terms"}' 93 | cmd showReq cmd.Run 94 | &' 95 | ⍝ --- Retrieving all public fields or properties with _Serialize --- 96 | &' 97 | cmd.URL←baseURL,'_Serialize' 98 | cmd.Params←'{"instanceName":"',instance,'"}' 99 | cmd showReq cmd.Run 100 | &' 101 | ⍝ --- Running a public method --- 102 | &' 103 | CodeLocation⍎instance,'.payments' ⍝ note - result is rank 3 which cannot be represented in JSON 104 | cmd.URL←baseURL,'_Run' 105 | cmd.Params←'{"instanceName":"',instance,'","methodName":"payments"}' 106 | cmd showReq cmd.Run 107 | &' 108 | srv.FlattenOutput←2 ⍝ flatten output and issue a warning message 109 | cmd showReq cmd.Run 110 | &' 111 | srv.FlattenOutput←1 ⍝ flatten output without warning message 112 | cmd showReq cmd.Run 113 | &' 114 | ⍝ --- _Run can be used to call any function, not just those in a class 115 | &' 116 | cmd.URL←baseURL,'_Run' 117 | cmd.Params←'{"methodName":"reverse","rarg":[2,4,6,8,10]}' 118 | cmd showReq cmd.Run 119 | &' 120 | ⍝ --- Passing arguments as data --- 121 | &' 122 | cmd.URL←baseURL,'loans/afford' ⍝ how much can I afford to borrow? 123 | cmd.Params←'[[5,6,7],[10,15],1000]' ⍝ interest rates, # years, desired maximum payment 124 | cmd showReq cmd.Run 125 | &' 126 | ⍝ --- Passing arguments as a namespace 127 | &' 128 | cmd.URL←baseURL,'loans/afford_ns' 129 | cmd.Params←'{"rates":[3,4,5],"terms":[10,20],"payments":[1000,1500]}' 130 | cmd showReq cmd.Run 131 | 132 | 133 | 134 | 135 | 136 | 137 | -------------------------------------------------------------------------------- /Source/JSONServer.dyalog: -------------------------------------------------------------------------------- 1 | :Class JSONServer 2 | 3 | (⎕ML ⎕IO)←1 1 4 | 5 | :Field Public AcceptFrom←⍬ ⍝ IP addresses to accept requests from - empty means accept from any IP address 6 | :Field Public DenyFrom←⍬ ⍝ IP addresses to refuse requests from - empty means deny none 7 | :Field Public Port←8080 ⍝ Default port to listen on 8 | :Field Public BlockSize←10000 ⍝ Conga block size 9 | :Field Public CodeLocation←# ⍝ application code location 10 | :Field Public InitializeFn←'Initialize' ⍝ name of the application "bootstrap" function 11 | :Field Public ValidateRequestFn←'ValidateRequest' ⍝ name of the request validation function 12 | :Field Public ConfigFile←'' ⍝ configuration file path (if any) 13 | :Field Public LoadableFiles←'*.apl*' '*.dyalog' ⍝ files that can be loaded if loading from folder 14 | :Field Public Logging←0 ⍝ turn logging on/off 15 | :Field Public HtmlInterface←1 ⍝ allow the HTML interface 16 | :Field Public Debug←0 ⍝ 0 = all errors are trapped, 1 = stop on an error, 2 = stop on intentional error before processing request 17 | :Field Public ClassInterface←1 ⍝ allow for the instantiation and use of classes, 0=no, 1=yes but restrict classes/instance names to not contain #, 2=yes but allow # in class/instance names 18 | :Field Public FlattenOutput←0 ⍝ 0=no, 1=yes, 2=yes with notification 19 | :Field Public Traverse←0 ⍝ traverse subordinate namespaces to search for classes (applies only if ClassInterface>0) 20 | :Field Public IncludeFns←'' ⍝ vector of vectors for function names to be included (can use regex or ? and * as wildcards) 21 | :Field Public ExcludeFns←'' ⍝ vector of vectors for function names to be excluded (can use regex or ? and * as wildcards) 22 | 23 | :Field _includeRegex←'' ⍝ compiled regex from IncludeFns 24 | :Field _excludeRegex←'' ⍝ compiled regex from ExcludeFns 25 | 26 | ⍝ Fields related to running a secure server (to be implemented) 27 | :Field Public Secure←0 ⍝ SSL isn't available yet 28 | :Field Public RootCertDir←'' 29 | :Field Public SSLValidation←64 ⍝ request, but do not require a client certificate 30 | :Field Public ServerCertFile←'' 31 | :Field Public ServerKeyFile←'' 32 | 33 | 34 | :Field Folder←'' ⍝ folder that user supplied in CodeLocation from which to load code 35 | :Field _configLoaded←0 36 | :Field _stop←0 ⍝ set to 1 to stop server 37 | :Field _started←0 38 | :Field _stopped←1 39 | 40 | ∇ r←Version 41 | :Access public shared 42 | r←'JSONServer' '1.6' '2019-11-14' 43 | ∇ 44 | 45 | ∇ {r}←Log msg;ts 46 | :Access public overridable 47 | ts←,'I4,,ZI2,,ZI2,< @ >,ZI2,<:>,ZI2,<:>,ZI2'⎕FMT 1 6⍴⎕TS 48 | :If 1=≢⍴msg←⍕msg 49 | :OrIf 1=⊃⍴msg 50 | r←ts,' - ',msg 51 | :Else 52 | r←ts,∊(⎕UCS 13),msg 53 | :EndIf 54 | ⎕←r 55 | ∇ 56 | 57 | ∇ make 58 | :Access public 59 | :Implements constructor 60 | ∇ 61 | 62 | ∇ make1 args;port;loc 63 | :Access public 64 | :Implements constructor 65 | ⍝ args[1] port to listen on 66 | ⍝ [2] charvec function folder or ref to codelocation 67 | (Port CodeLocation)←2↑args,(≢,args)↓Port CodeLocation 68 | ∇ 69 | 70 | ∇ Close 71 | :Implements destructor 72 | {0:: ⋄ #.DRC.Close ServerName}⍬ 73 | ∇ 74 | 75 | ∇ UpdateRegex arg;t 76 | :Implements Trigger IncludeFns, ExcludeFns 77 | t←makeRegEx¨(⊂'')~⍨∪,⊆arg.NewValue 78 | :If arg.Name≡'IncludeFns' 79 | _includeRegex←t 80 | :Else 81 | _excludeRegex←t 82 | :EndIf 83 | ∇ 84 | 85 | ∇ r←Run args;msg;rc 86 | :Access shared public 87 | :Trap 0 88 | (rc msg)←(r←⎕NEW ⎕THIS args).Start 89 | :Else 90 | (r rc msg)←'' ¯1 ⎕DMX.EM 91 | :EndTrap 92 | r←(r(rc msg)) 93 | ∇ 94 | 95 | ∇ (rc msg)←Start 96 | :Access public 97 | 98 | :If _started 99 | CheckRC(rc msg)←¯1 'Server thinks it''s already started' 100 | :EndIf 101 | 102 | :If _stop 103 | CheckRC(rc msg)←¯1 'Server is in the process of stopping' 104 | :EndIf 105 | 106 | CheckRC(rc msg)←LoadConfiguration 107 | CheckRC(rc msg)←CheckPort 108 | CheckRC(rc msg)←LoadConga 109 | CheckRC(rc msg)←CheckCodeLocation 110 | CheckRC(rc msg)←StartServer 111 | Log'JSONServer started on port ',⍕Port 112 | Log'Serving code in ',(⍕CodeLocation),(Folder≢'')/' (populated with code from "',Folder,'")' 113 | :If HtmlInterface 114 | Log'Click http',(~Secure)↓'s://localhost:',(⍕Port),' to access web interface' 115 | :EndIf 116 | ∇ 117 | 118 | ∇ (rc msg)←Stop;ts 119 | :Access public 120 | :If _stop 121 | CheckRC(rc msg)←¯1 'Server is already stopping' 122 | :EndIf 123 | :If ~_started 124 | CheckRC(rc msg)←¯1 'Server is not running' 125 | :EndIf 126 | ts←⎕AI[3] 127 | _stop←1 128 | Log'Stopping server...' 129 | :While ~_stopped 130 | :If 10000<⎕AI[3]-ts 131 | CheckRC(rc msg)←¯1 'Server seems stuck' 132 | :EndIf 133 | :EndWhile 134 | _started←_stop←0 135 | ∇ 136 | 137 | ∇ r←Running 138 | :Access public 139 | r←~_stop 140 | ∇ 141 | 142 | ∇ (rc msg)←CheckPort;p 143 | (rc msg)←3('Invalid port: ',∊⍕Port) 144 | ExitIf 0=p←⊃⊃(//)⎕VFI⍕Port 145 | ExitIf{(⍵>32767)∨(⍵<1)∨⍵≠⌊⍵}p 146 | (rc msg)←0 '' 147 | ∇ 148 | 149 | ∇ (rc msg)←LoadConfiguration;config;public;set 150 | :Access public 151 | (rc msg)←0 '' 152 | →_configLoaded⍴0 ⍝ did we already load from AutoStart? 153 | :If ~0∊⍴ConfigFile 154 | :Trap 0/0 155 | :If ⎕NEXISTS ConfigFile 156 | config←⎕JSON⊃⎕NGET ConfigFile 157 | public←⎕THIS⍎'⎕NL ¯2.2' ⍝ find all the public fields in this class 158 | set←public{⍵/⍨⍵∊⍺}config.⎕NL ¯2 159 | config{⍎⍵,'←⍺⍎⍵'}¨set 160 | :Else 161 | →0⊣(rc msg)←6('Configuation file "',ConfigFile,'" not found') 162 | :EndIf 163 | _configLoaded←1 164 | :Else 165 | →0⊣(rc msg)←⎕DMX.EN ⎕DMX.('Error loading configuration file: ',EM,(~0∊⍴Message)/' (',Message,')') 166 | :EndTrap 167 | :EndIf 168 | ∇ 169 | 170 | ∇ (rc msg)←LoadConga;dyalog 171 | (rc msg)←0 '' 172 | 173 | :If 0=#.⎕NC'Conga' 174 | dyalog←{⍵,'/'↓⍨'/\'∊⍨¯1↑⍵}2 ⎕NQ'.' 'GetEnvironment' 'DYALOG' 175 | :Trap 0 176 | 'Conga'#.⎕CY dyalog,'ws/conga' 177 | :Else 178 | (rc msg)←1 'Unable to copy Conga' 179 | →0 180 | :EndTrap 181 | :EndIf 182 | 183 | :Trap 999 ⍝ Conga.Init signals 999 on error 184 | #.DRC←#.Conga.Init'JSONServer' 185 | :Else 186 | (rc msg)←2 'Unable to initialize Conga' 187 | →0 188 | :EndTrap 189 | ∇ 190 | 191 | ∇ (rc msg)←CheckCodeLocation;root;folder;m;res;tmp 192 | (rc msg)←0 '' 193 | :If 0∊⍴CodeLocation 194 | CheckRC(rc msg)←4 'CodeLocation is empty!' 195 | :EndIf 196 | :Select ⊃{⎕NC'⍵'}CodeLocation ⍝ need dfn because CodeLocation is a field and will always be nameclass 2 197 | :Case 9 ⍝ reference, just use it 198 | :Case 2 ⍝ variable, could be file path or ⍕ of reference from ConfigFile 199 | :If 326=⎕DR tmp←{0::⍵ ⋄ '#'≠⊃⍵:⍵ ⋄ ⍎⍵}CodeLocation 200 | :AndIf 9={⎕NC'⍵'}tmp ⋄ CodeLocation←tmp 201 | :Else 202 | :If isRelPath CodeLocation 203 | :If 'CLEAR WS'≡⎕WSID 204 | root←⊃1 ⎕NPARTS'' 205 | :Else 206 | root←⊃1 ⎕NPARTS ⎕WSID 207 | :EndIf 208 | :Else 209 | root←'' 210 | :EndIf 211 | folder←∊1 ⎕NPARTS root,CodeLocation 212 | :Trap 0 213 | :If 1≠1 ⎕NINFO folder 214 | CheckRC(rc msg)←5('CodeLocation "',(∊⍕CodeLocation),'," is not a folder.') 215 | :EndIf 216 | :Case 22 ⍝ file name error 217 | CheckRC(rc msg)←6('CodeLocation "',(∊⍕CodeLocation),'," was not found.') 218 | :Else ⍝ anything else 219 | CheckRC(rc msg)←7((⎕DMX.(EM,' (',Message,') ')),'occured when validating CodeLocation "',(∊⍕CodeLocation),'"') 220 | :EndTrap 221 | CodeLocation←⍎'CodeLocation'#.⎕NS'' 222 | (rc msg)←CodeLocation LoadFromFolder Folder←folder 223 | :EndIf 224 | :Else 225 | CheckRC(rc msg)←5 'CodeLocation is not valid, it should be either a namespace/class reference or a file path' 226 | :EndSelect 227 | 228 | :If ~0∊⍴InitializeFn ⍝ initialization function specified? 229 | :If 3=CodeLocation.⎕NC InitializeFn ⍝ does it exist? 230 | :If 1 0 0≡⊃CodeLocation.⎕AT InitializeFn ⍝ result-returning niladic? 231 | res←,⊆CodeLocation⍎InitializeFn ⍝ run it 232 | CheckRC(rc msg)←2↑res,(⍴res)↓¯1('"',(⍕CodeLocation),'.',InitializeFn,'" did not return a 0 return code') 233 | :Else 234 | CheckRC(rc msg)←8('"',(⍕CodeLocation),'.',InitializeFn,'" is not a niladic result-returning function') 235 | :EndIf 236 | :EndIf 237 | :EndIf 238 | 239 | Validate←{0} ⍝ dummy validation function 240 | 241 | :If ~0∊⍴ValidateRequestFn ⍝ Request validation function specified? 242 | :If 3=CodeLocation.⎕NC ValidateRequestFn ⍝ does it exist? 243 | :If 1 1 0≡⊃CodeLocation.⎕AT ValidateRequestFn ⍝ result-returning monadic? 244 | Validate←CodeLocation⍎ValidateRequestFn 245 | :Else 246 | CheckRC(rc msg)←8('"',(⍕CodeLocation),'.',ValidateRequestFn,'" is not a monadic result-returning function') 247 | :EndIf 248 | :EndIf 249 | :EndIf 250 | ∇ 251 | 252 | Exists←{0:: ¯1 (⍺,' "',⍵,'" is not a valid folder name.') ⋄ ⎕NEXISTS ⍵:0 '' ⋄ ¯1 (⍺,' "',⍵,'" was not found.')} 253 | 254 | ∇ (rc msg)←StartServer;r;cert;secureParams;accept;deny 255 | msg←'Unable to start server' 256 | accept←'Accept'ipRanges AcceptFrom 257 | deny←'Deny'ipRanges DenyFrom 258 | secureParams←⍬ 259 | :If Secure 260 | :If ~0∊⍴RootCertDir ⍝ on Windows not specifying RootCertDir will use MS certificate store 261 | CheckRC(rc msg)←'RootCertDir'Exists RootCertDir 262 | CheckRC(rc msg)←{(⊃⍵)'Error setting RootCertDir'}#.DRC.SetProp'.' 'RootCertDir'RootCertDir 263 | :EndIf 264 | CheckRC(rc msg)←'ServerCertFile'Exists ServerCertFile 265 | CheckRC(rc msg)←'ServerKeyFile'Exists ServerKeyFile 266 | cert←⊃#.DRC.X509Cert.ReadCertFromFile ServerCertFile 267 | cert.KeyOrigin←'DER'ServerKeyFile 268 | secureParams←('X509'cert)('SSLValidation'SSLValidation) 269 | :EndIf 270 | :If 98 10048∊⍨rc←1⊃r←#.DRC.Srv'' ''Port'http'BlockSize,secureParams,accept,deny ⍝ 98=Linux, 10048=Windows 271 | CheckRC(rc msg)←10('Server could not start - port ',(⍕Port),' is already in use') 272 | :ElseIf 0=rc 273 | (_started _stopped)←1 0 274 | ServerName←2⊃r 275 | {}#.DRC.SetProp'.' 'EventMode' 1 ⍝ report Close/Timeout as events 276 | {}#.DRC.SetProp ServerName'FIFOMode' 0 277 | {}#.DRC.SetProp ServerName'DecodeBuffers' 15 ⍝ decode all buffers 278 | Connections←#.⎕NS'' 279 | RunServer 280 | msg←'' 281 | :Else 282 | CheckRC rc'Error creating server' 283 | :EndIf 284 | ∇ 285 | 286 | ∇ RunServer 287 | {}Server&⍬ 288 | ∇ 289 | 290 | ∇ Server arg;wres;rc;obj;evt;data;ref;ip;congaError 291 | 292 | :If 0≠#.DRC.⎕NC⊂'Error' ⋄ congaError←#.DRC.Error ⍝ Conga 3.2 moved Error into the library instance 293 | :Else ⋄ congaError←#.Conga.Error ⍝ Prior to 3.2 Error was in the namespace 294 | :EndIf 295 | 296 | :While ~_stop 297 | wres←#.DRC.Wait ServerName 2500 ⍝ Wait for WaitTimeout before timing out 298 | ⍝ wres: (return code) (object name) (command) (data) 299 | (rc obj evt data)←4↑wres 300 | :Select rc 301 | :Case 0 302 | :Select evt 303 | :Case 'Error' 304 | _stop←ServerName≡obj 305 | :If 0≠4⊃wres 306 | Log'RunServer: DRC.Wait reported error ',(⍕congaError 4⊃wres),' on ',(2⊃wres),GetIP obj 307 | :EndIf 308 | Connections.⎕EX obj 309 | 310 | :Case 'Connect' 311 | obj Connections.⎕NS'' 312 | (Connections⍎obj).IP←2⊃2⊃#.DRC.GetProp obj'PeerAddr' 313 | 314 | :CaseList 'HTTPHeader' 'HTTPTrailer' 'HTTPChunk' 'HTTPBody' 315 | {}(Connections⍎obj){t←⍺ HandleRequest ⍵ ⋄ ⎕EX t/⍕⍺}&wres 316 | 317 | :CaseList 'Closed' 'Timeout' 318 | 319 | :Else ⍝ unhandled event 320 | ∘∘∘ 321 | Log'Unhandled Conga event:' 322 | Log⍕wres 323 | :EndSelect ⍝ evt 324 | 325 | :Case 1010 ⍝ Object Not found 326 | ⍝ Log'Object ''',ServerName,''' has been closed - Web Server shutting down' 327 | →0 328 | 329 | :Else 330 | Log'Conga wait failed:' 331 | Log wres 332 | :EndSelect ⍝ rc 333 | :EndWhile 334 | {}#.DRC.Close ServerName 335 | _stopped←1 336 | ∇ 337 | 338 | ∇ r←ns HandleRequest req;data;evt;obj;rc;cert 339 | (rc obj evt data)←req 340 | r←0 341 | :Hold obj 342 | :Select evt 343 | :Case 'HTTPHeader' 344 | ns.Req←⎕NEW Request data 345 | 346 | :If Logging 347 | ⎕←('G⊂9999/99/99 @ 99:99:99⊃'⎕FMT 100⊥6↑⎕TS)data 348 | :EndIf 349 | 350 | ns.Req.PeerCert←'' 351 | ns.Req.PeerAddr←2⊃2⊃#.DRC.GetProp obj'PeerAddr' 352 | 353 | :If Secure 354 | (rc cert)←2↑#.DRC.GetProp obj'PeerCert' 355 | :If rc=0 356 | ns.Req.PeerCert←cert 357 | :Else 358 | ns.Req.PeerCert←'Could not obtain certificate' 359 | :EndIf 360 | :EndIf 361 | 362 | :Case 'HTTPBody' 363 | ns.Req.ProcessBody data 364 | :If Logging 365 | ⎕←('G⊂9999/99/99 @ 99:99:99⊃'⎕FMT 100⊥6↑⎕TS)data 366 | :EndIf 367 | :Case 'HTTPChunk' 368 | ns.Req.ProcessChunk data 369 | :Case 'HTTPTrailer' 370 | ns.Req.ProcessTrailer data 371 | :EndSelect 372 | 373 | :If ns.Req.Complete 374 | :If ns.Req.Response.Status=200 375 | 376 | :If Debug=2 ⍝ framework debug 377 | ∘∘∘ 378 | :EndIf 379 | 380 | :If 0≠HandleJSONRequest ns 381 | {}#.DRC.Close obj 382 | Connections.⎕EX obj 383 | →0 384 | :EndIf 385 | :EndIf 386 | r←obj Respond ns.Req.Response 387 | :EndIf 388 | :EndHold 389 | ∇ 390 | 391 | ∇ r←HandleJSONRequest ns;payload;fn;resp;valence;nc 392 | r←0 393 | ExitIf HtmlInterface∧ns.Req.Page≡'/favicon.ico' 394 | r←Validate ns.Req 395 | 396 | :If 0∊⍴fn←1↓'.'@('/'∘=)ns.Req.Page 397 | ExitIf('No function specified')ns.Req.Fail 400×~HtmlInterface∧'get'≡ns.Req.Method 398 | ns.Req.Response.Headers←1 2⍴'Content-Type' 'text/html' 399 | ns.Req.Response.JSON←HtmlPage 400 | →0 401 | :EndIf 402 | 403 | :Trap Debug↓0 404 | payload←{0∊⍴⍵:⍵ ⋄ 0 ⎕JSON ⍵}ns.Req.Body 405 | :Else 406 | →0⍴⍨'Could not parse payload as JSON'ns.Req.Fail 400 407 | :EndTrap 408 | 409 | :If ClassInterface 410 | :AndIf (⊂fn)∊'_Classes' '_Delete' '_Get' '_Instances' '_New' '_Run' '_Serialize' '_Set' 411 | :Trap Debug↓0 412 | resp←(⍎fn)payload 413 | :Else 414 | ns.Req.Response.JSON←1 ⎕JSON ⎕DMX.(EM Message) 415 | ExitIf('Error running method "',fn,'"')ns.Req.Fail 500 416 | :EndTrap 417 | :Else 418 | nc←{0::¯1 ⋄ CodeLocation.⎕NC⊆∊⍕⍵}fn 419 | ExitIf('Invalid function name')ns.Req.Fail 400ׯ1=nc 420 | ExitIf('Invalid function "',fn,'"')ns.Req.Fail 404×3≠⌊nc ⍝ is it a function? 421 | ExitIf('Invalid function "',fn,'"')ns.Req.Fail CheckFunctionName fn 422 | valence←(2↑|⊃CodeLocation.⎕AT fn)-0 3.3=|nc ⍝ derived or primitive functions may be scalar only 423 | ExitIf('"',fn,'" is not a monadic result-returning function')ns.Req.Fail 400×1 1≢valence 424 | 425 | :Trap Debug↓0 426 | :If 2=valence[2] ⍝ dyadic 427 | resp←ns.Req(CodeLocation⍎fn)payload 428 | :Else 429 | resp←(CodeLocation⍎fn)payload 430 | :EndIf 431 | :Else 432 | ns.Req.Response.JSON←1 ⎕JSON ⎕DMX.(EM Message) 433 | ExitIf('Error running method "',fn,'"')ns.Req.Fail 500 434 | :EndTrap 435 | :EndIf 436 | :Trap Debug↓0 437 | ns.Req.Response.JSON←⎕UCS'UTF-8'⎕UCS 1 ⎕JSON resp 438 | :Else 439 | :If FlattenOutput>0 440 | :Trap 0 441 | ns.Req.Response.JSON←⎕UCS'UTF-8'⎕UCS JSON resp 442 | :If FlattenOutput=2 443 | :If 0=⊃payload has'methodName' 444 | fn←payload.methodName 445 | :EndIf 446 | Log'"',fn,'" returned data of rank > 1' 447 | :EndIf 448 | :Else 449 | ExitIf'Could not format payload as JSON'ns.Req.Fail 500 450 | :EndTrap 451 | :Else 452 | ExitIf'Could not format payload as JSON'ns.Req.Fail 500 453 | :EndIf 454 | :EndTrap 455 | ∇ 456 | 457 | ∇ r←obj Respond res;status;z 458 | status←(⊂'HTTP/1.1'),res.((⍕Status)StatusText) 459 | :If res.Status≠200 ⍝ if failed response, replace headers 460 | res.Headers←1 2⍴'content-type' 'text/html' 461 | :EndIf 462 | res.Headers⍪←'server'(⊃Version) 463 | res.Headers⍪←'date'(2⊃#.DRC.GetProp'.' 'HttpDate') 464 | :If Logging 465 | ⎕←('G⊂9999/99/99 @ 99:99:99⊃'⎕FMT 100⊥6↑⎕TS)status res.Headers res.JSON 466 | :EndIf 467 | :If 0≠1⊃z←#.DRC.Send obj(status,res.Headers res.JSON)1 468 | Log'Conga error when sending response',GetIP obj 469 | Log⍕z 470 | :EndIf 471 | Connections.⎕EX obj 472 | r←1 473 | ∇ 474 | 475 | ∇ ip←GetIP objname 476 | ip←{6::'' ⋄ ' (IP Address ',(⍕(Connections⍎⍵).IP),')'}objname 477 | ∇ 478 | 479 | ∇ r←CheckFunctionName fn 480 | ⍝ checks the requested function name and returns 481 | ⍝ 0 if the function is allowed 482 | ⍝ 404 (not found) if the list of allowed functions is non-empty and fn is not in the list 483 | ⍝ 403 (forbidden) if fn is in the list of disallowed functions 484 | :Access public 485 | r←0 486 | fn←,⊆,fn 487 | ExitIf r←⊃403 404 0[¯1 0⍳CodeLocation.⎕NC fn] 488 | ExitIf r←403×fn∊InitializeFn ValidateRequestFn 489 | :If ~0∊⍴_includeRegex 490 | ExitIf r←404×0∊⍴(_includeRegex ⎕S'%')fn 491 | :EndIf 492 | :If ~0∊⍴_excludeRegex 493 | r←403×~0∊⍴(_excludeRegex ⎕S'%')fn 494 | :EndIf 495 | ∇ 496 | 497 | :Class Request 498 | :Field Public Instance Complete←0 ⍝ do we have a complete request? 499 | :Field Public Instance Input←'' 500 | :Field Public Instance Host←'' ⍝ host header field 501 | :Field Public Instance Headers←0 2⍴⊂'' ⍝ HTTPRequest header fields (plus any supplied from HTTPTrailer event) 502 | :Field Public Instance Method←'' ⍝ HTTP method (GET, POST, PUT, etc) 503 | :Field Public Instance Page←'' ⍝ Requested URI 504 | :Field Public Instance Body←'' ⍝ body of the request 505 | :Field Public Instance PeerAddr←'unknown'⍝ client IP address 506 | :Field Public Instance PeerCert←0 0⍴⊂'' ⍝ client certificate 507 | :Field Public Instance HTTPVersion←'' 508 | :Field Public Instance Cookies←0 2⍴⊂'' 509 | :Field Public Instance Response 510 | 511 | GetFromTable←{(⍵[;1]⍳⊂lc ,⍺)⊃⍵[;2],⊂''} 512 | split←{p←(⍺⍷⍵)⍳1 ⋄ ((p-1)↑⍵)(p↓⍵)} ⍝ Split ⍵ on first occurrence of ⍺ 513 | lc←(819⌶) 514 | begins←{⍺≡(⍴⍺)↑⍵} 515 | 516 | ∇ {r}←{a}Fail w 517 | :Access public 518 | r←a{⍺←'' 519 | 0≠⍵:⍵⊣Response.(Status StatusText)←⍵('Bad Request',(3×0∊⍴⍺)↓' - ',⍺) 520 | ⍵}w 521 | ∇ 522 | 523 | ∇ make args;query;origin;length 524 | :Access public 525 | :Implements constructor 526 | (Method Input HTTPVersion Headers)←args 527 | Headers[;1]←lc Headers[;1] ⍝ header names are case insensitive 528 | Method←lc Method 529 | 530 | Response←⎕NS'' 531 | Response.(Status StatusText Headers JSON)←200 'OK'(1 2⍴'Content-Type' 'application/json; charset=utf-8')'' 532 | 533 | Host←'host'GetFromTable Headers 534 | (Page query)←'?'split Input 535 | Page←PercentDecode Page 536 | Complete←('get'≡Method)∨(length←'content-length'GetFromTable Headers)≡,'0' ⍝ we're a GET or 0 content-length 537 | Complete∨←(0∊⍴length)>∨/'chunked'⍷'transfer-encoding'GetFromTable Headers ⍝ or no length supplied and we're not chunked 538 | :If Complete 539 | :AndIf ##.HtmlInterface∧~(⊂Page)∊(,'/')'/favicon.ico' 540 | →0⍴⍨'(Request method should be POST)'Fail 405×'post'≢Method 541 | →0⍴⍨'(Bad URI)'Fail 400×'/'≠⊃Page 542 | →0⍴⍨'(Content-Type should be application/json)'Fail 400×~'application/json'begins lc'content-type'GetFromTable Headers 543 | :EndIf 544 | →0⍴⍨'(Cannot accept query parameters)'Fail 400×~0∊⍴query 545 | ∇ 546 | 547 | ∇ ProcessBody args 548 | :Access public 549 | Body←args 550 | Complete←1 551 | ∇ 552 | 553 | ∇ ProcessChunk args 554 | :Access public 555 | ⍝ args is [1] chunk content [2] chunk-extension name/value pairs (which we don't expect and won't process) 556 | Body,←1⊃args 557 | ∇ 558 | 559 | ∇ ProcessTrailer args;inds;mask 560 | :Access public 561 | args[;1]←lc args[;1] 562 | mask←(≢Headers)≥inds←Headers[;1]⍳args[;1] 563 | Headers[mask/inds;2]←mask/args[;2] 564 | Headers⍪←(~mask)⌿args 565 | Complete←1 566 | ∇ 567 | 568 | ∇ r←PercentDecode r;rgx;rgxu;i;j;z;t;m;⎕IO;lens;fill 569 | :Access public shared 570 | ⍝ Decode a Percent Encoded string https://en.wikipedia.org/wiki/Percent-encoding 571 | ⎕IO←0 572 | ((r='+')/r)←' ' 573 | rgx←'[0-9a-fA-F]' 574 | rgxu←'%[uU]',(4×⍴rgx)⍴rgx ⍝ 4 characters 575 | r←(rgxu ⎕R{{⎕UCS 16⊥⍉16|'0123456789ABCDEF0123456789abcdef'⍳⍵}2↓⍵.Match})r 576 | :If 0≠⍴i←(r='%')/⍳⍴r 577 | :AndIf 0≠⍴i←(i≤¯2+⍴r)/i 578 | z←r[j←i∘.+1 2] 579 | t←'UTF-8'⎕UCS 16⊥⍉16|'0123456789ABCDEF0123456789abcdef'⍳z 580 | lens←⊃∘⍴¨'UTF-8'∘⎕UCS¨t ⍝ UTF-8 is variable length encoding 581 | fill←i[¯1↓+\0,lens] 582 | r[fill]←t 583 | m←(⍴r)⍴1 ⋄ m[(,j),i~fill]←0 584 | r←m/r 585 | :EndIf 586 | ∇ 587 | 588 | ∇ r←GetHeader name 589 | :Access Public Instance 590 | r←(lc name)GetFromTable Headers 591 | ∇ 592 | 593 | :EndClass 594 | 595 | :Section ClassInterface 596 | 597 | has←{ ⍝ checks that arguments exist in a namespace 598 | 9≠⎕NC'⍺':11 'Request parameters are not bundled in an object' 599 | names←,⊆⍵ 600 | ∨/mask←0=⍺.⎕NC names:6('Request is missing parameter',(1=+/mask)↓'s: ',2↓∊', '∘,¨mask/names) 601 | 0 '' 602 | } 603 | 604 | ∇ r←initResult w 605 | r←⎕NS'' 606 | r.(rc message)←0 '' 607 | :If ~0∊⍴w 608 | r⍎¨(,⊆w),¨⊂'←''''' 609 | :EndIf 610 | ∇ 611 | 612 | ∇ r←{type}checkName name;mask;t 613 | type←⊃{6::⍵ ⋄ type}1 ⍝ 1=instance, 2=class 614 | r←0 '' 615 | :Select ⊃ClassInterface 616 | :Case 0 617 | r←11 'Class interface has not been enabled' 618 | :Case 1 619 | :If '#'∊name 620 | r←11('Invalid ',(type⊃'instance' 'class'),' location: "',name,'"') 621 | :EndIf 622 | :EndSelect 623 | :If (9.2 9.4[type])≢CodeLocation.⎕NC⊂name 624 | r←6((type⊃'Instance ' 'Class '),name,' not found') 625 | :EndIf 626 | :If ∨/mask←∨/¨(⍷∘name)¨t←'JSONServer.' 'Conga.' 'DRC.' 627 | r←11('Request cannot refer to ',⊃mask/t) 628 | :EndIf 629 | ∇ 630 | 631 | ∇ r←_Classes dummy 632 | ⍝ returns class names 633 | r←initResult'classes' 634 | r.classes←'JSONServer' 'HttpCommand'~⍨(¯9.4 traverse)CodeLocation 635 | ∇ 636 | 637 | ∇ r←_Delete instances;mask;t 638 | r←initResult'deleted' 'notDeleted' 639 | :If 9=⎕NC'instances' 640 | CheckRC r.(rc message)←instances has'instanceName' 641 | instances←instances.instanceName 642 | :EndIf 643 | instances←,⊆instances 644 | :If ∨/mask←0≠⊃¨t←1 checkName¨instances 645 | r.message←2⊃¨mask/t 646 | r.rc←{(1+1=≢⍵)⊃999,⍵}∪1⊃¨t ⍝ 999 indicates multiple errors 647 | →0 648 | :EndIf 649 | ⎕EX instances 650 | r.(deleted notDeleted)←1↓¨(0 1,0=⎕NC instances)⌸'zz' 'zz',instances 651 | ∇ 652 | 653 | ∇ r←_Get ns 654 | ⍝ ns.instanceName - instance name 655 | ⍝ ns.what - public field, property, or niladic method name 656 | r←initResult'value' 657 | 658 | CheckRC r.(rc message)←ns has'instanceName' 'what' 659 | CheckRC r.(rc message)←1 checkName ns.instanceName 660 | 661 | :Trap 0 662 | r.value←⍎'CodeLocation.',ns.instanceName,'.',ns.what 663 | :Else 664 | r.(rc message)←⎕DMX.EN(⎕DMX.EM,' while attempting to retrieve ',ns.instanceName,'.',ns.what) 665 | :EndTrap 666 | ∇ 667 | 668 | ∇ r←_Instances dummy 669 | ⍝ returns instance names 670 | r←initResult'instances' 671 | r.instances←(¯9.2 traverse)CodeLocation 672 | ∇ 673 | 674 | ∇ r←_New ns;arguments;class;none;instance 675 | ⍝ create an instance of a class 676 | ⍝ class is a namespace (JSON array) of 677 | ⍝ className - character vector name of the class to instantiate 678 | ⍝ [arguments] - optional array of arguments to pass in the constructor 679 | 680 | r←initResult'instanceName' 681 | arguments←none←⊂'none' ⍝ JSON cannot have scalar strings 682 | :If 9=⎕NC'ns' 683 | CheckRC r.(rc message)←ns has'className' 684 | class←ns.className 685 | arguments←{6::arguments ⋄ ⍵.arguments}ns 686 | :Else 687 | class←ns 688 | :EndIf 689 | 690 | CheckRC r.(rc message)←2 checkName class 691 | 692 | :Repeat 693 | instance←class,'_',⎕D[?5⍴10] 694 | :Until 0=CodeLocation.⎕NC instance 695 | :Trap 0 696 | ⍎'CodeLocation.',instance,'←CodeLocation.⎕NEW CodeLocation.',class,(arguments≢none)/' arguments' 697 | r.instanceName←instance 698 | :Else 699 | r.(rc message)←⎕DMX.EN(⎕DMX.EM,' while attempting to create instance of ',class) 700 | :EndTrap 701 | ∇ 702 | 703 | ∇ r←_Run ns;mask;prefix;exec;rc 704 | r←initResult'' 705 | mask←0≠ns.⎕NC'instanceName' 'rarg' 'larg' 706 | 707 | CheckRC r.(rc message)←ns has'methodName' 708 | prefix←'CodeLocation.' 709 | :If mask[1] ⍝ instanceName? 710 | CheckRC r.(rc message)←1 checkName ns.instanceName 711 | :If 3≠⌊|(CodeLocation⍎ns.instanceName).⎕NC⊂ns.methodName 712 | CheckRC r.(rc message)←6('"',ns.methodName,'" is not a public method in ',ns.instanceName) 713 | :EndIf 714 | prefix,←ns.instanceName,'.' 715 | :Else ⍝ not using an instance, validate the name against Include/Exclude filters 716 | :If 0×rc←CheckFunctionName ns.methodName 717 | CheckRC r.(rc message)←6('"',ns.methodName,'" is not a valid function to run') 718 | :EndIf 719 | :EndIf 720 | :Select 2⊥mask[2 3] 721 | :Case 0 ⍝ niladic 722 | exec←prefix,ns.methodName 723 | :Case 1 ⍝ error 724 | CheckRC r.(rc message)←2 'Left argument supplied with no right argument' 725 | :Case 2 ⍝ monadic 726 | exec←prefix,ns.methodName,' ns.rarg' 727 | :Case 3 ⍝ dyadic 728 | exec←'ns.larg ',prefix,ns.methodName,' ns.rarg' 729 | :EndSelect 730 | 731 | :Trap Debug↓0 732 | r.result←0(85⌶)exec 733 | :Case 85 734 | r.message←'No result returned' 735 | :Else 736 | r.(rc message)←⎕DMX.EN(⎕DMX.EM,' while attempting to execute ',prefix,ns.methodName) 737 | :EndTrap 738 | ∇ 739 | 740 | ∇ r←_Serialize ns;name;ref;value;instanceName 741 | ⍝ ns.instanceName - instance name to serialize 742 | r←initResult'' 743 | r.data←⎕NS'' 744 | instanceName←ns 745 | :If 9=⌊⎕NC'ns' 746 | CheckRC r.(rc message)←ns has'instanceName' 747 | instanceName←ns.instanceName 748 | :EndIf 749 | 750 | ref←CodeLocation⍎instanceName 751 | 752 | :For name :In ref.⎕NL ¯2 753 | :Trap 0 754 | value←ref⍎name 755 | r.data(name{⍺⍎⍺⍺,'←⍵'})value 756 | :Else 757 | r.message,←⊂⎕DMX.EM,' while attempting to retrieve ',instanceName,'.',name 758 | r.rc⌈←999×r.rc≠0 759 | :EndTrap 760 | :EndFor 761 | ∇ 762 | 763 | ∇ r←_Set ns 764 | ⍝ ns.instanceName - instance name 765 | ⍝ ns.what - public field or property 766 | ⍝ ns.value - value to set 767 | r←initResult'' 768 | CheckRC r.(rc message)←ns has'instanceName' 'what' 'value' 769 | CheckRC r.(rc message)←1 checkName ns.instanceName 770 | 771 | :Select ⌊|(CodeLocation⍎ns.instanceName).⎕NC⊂ns.what 772 | :Case 2 773 | :Trap 0 774 | ⍎'CodeLocation.',ns.instanceName,'.',ns.what,'←ns.value' 775 | r.message←'' 776 | :Else 777 | r.(rc message)←⎕DMX.EN(⎕DMX.EM,' while attempting to set ',ns.instanceName,'.',ns.what) 778 | :EndTrap 779 | :Case 0 780 | r.(rc message)←6('"',ns.what,'" is not a field or property in ',ns.instanceName) 781 | :Else 782 | r.(rc message)←11('"',ns.what,'" is not a valid field or property name') 783 | :EndSelect 784 | ∇ 785 | 786 | 787 | ∇ r←{start}(type traverse)root;ns 788 | ⍝ return classes or instances, traversing subordinate namespaces if Traverse is set to 1 789 | :If 0=⎕NC'start' ⋄ start←'' ⋄ :EndIf 790 | r←start∘,¨root.⎕NL type 791 | :If Traverse 792 | :For ns :In (root.⎕NL ¯9.1)~⊂'Conga' 793 | r,←(start,ns,'.')(type traverse)root⍎ns 794 | :EndFor 795 | :EndIf 796 | ∇ 797 | 798 | :EndSection 799 | 800 | :Section Utilities 801 | 802 | ExitIf←→⍴∘0 803 | CheckRC←ExitIf(0∘≠⊃) 804 | 805 | ∇ r←flatten w 806 | ⍝ "flatten" arrays of rank>1 807 | ⍝ JSON cannot represent arrays of rank>1, so we "flatten" them into vectors of vectors (of vectors...) 808 | :Access public shared 809 | r←{(↓⍣(¯1+≢⍴⍵))⍵}w 810 | ∇ 811 | 812 | ∇ r←a splitOn w 813 | :Access public shared 814 | r←a⊆⍨~a∊w 815 | ∇ 816 | 817 | ∇ r←type ipRanges string 818 | :Access public shared 819 | r←'' 820 | :Select ≢ranges←{('.'∊¨⍵){⊂1↓∊',',¨⍵}⌸⍵}string JSONServer.splitOn',' 821 | :Case 0 822 | →0 823 | :Case 1 824 | r←,⊂((1+'.'∊⊃ranges)⊃'IPV6' 'IPV4')(⊃ranges) 825 | :Case 2 826 | r←↓'IPV4' 'IPV6',⍪ranges 827 | :EndSelect 828 | r←⊂(('Accept' 'Deny'⍳⊂type)⊃'AllowEndPoints' 'DenyEndPoints')r 829 | ∇ 830 | 831 | 832 | ∇ r←leaven w 833 | ⍝ "leaven" JSON vectors of vectors (of vectors...) into higher rank arrays 834 | :Access public shared 835 | r←{ 836 | 0 1∊⍨≡⍵:⍵ 837 | 1=⍴∪≢¨⍵:↑∇¨⍵ 838 | ⍵ 839 | }w 840 | ∇ 841 | 842 | ∇ r←isRelPath w 843 | ⍝ is path w a relative path? 844 | r←{{~'/\'∊⍨(⎕IO+2×('Win'≡3↑⊃#.⎕WG'APLVersion')∧':'∊⍵)⊃⍵}3↑⍵}w 845 | ∇ 846 | 847 | lc←(819⌶) ⍝ lower case 848 | 849 | ∇ r←makeRegEx w 850 | ⍝ convert a simple search using ? and * to regex 851 | :Access public shared 852 | r←{0∊⍴⍵:⍵ 853 | ¯1=⎕NC('A'@(∊∘'?*'))r←⍵:('/'=⊣/⍵)↓(¯1×'/'=⊢/⍵)↓⍵ ⍝ already regex? (remove leading/trailing '/' 854 | r←∊(⊂'\.')@('.'=⊢)r ⍝ escape any periods 855 | r←'.'@('?'=⊢)r ⍝ ? → . 856 | r←∊(⊂'.*')@('*'=⊢)r ⍝ * → .* 857 | '^',r,'$' ⍝ add start and end of string markers 858 | }w 859 | ∇ 860 | 861 | ∇ (rc msg)←{root}LoadFromFolder path;type;name;nsName;parts;ns;files;folders;file;folder;ref;r;m;findFiles;pattern 862 | :Access public 863 | ⍝ Loads an APL "project" folder 864 | (rc msg)←0 '' 865 | root←{6::⍵ ⋄ root}# 866 | findFiles←{⊃{(⍵=2)/⍺}/0 1(⎕NINFO⍠1)∊1 ⎕NPARTS path,'/',⍵} 867 | files←'' 868 | :For pattern :In ,⊆,LoadableFiles 869 | files,←findFiles pattern 870 | :EndFor 871 | folders←⊃{(⍵=1)/⍺}/0 1(⎕NINFO⍠1)∊1 ⎕NPARTS path,'/*' 872 | :For file :In files 873 | ⎕SE.SALT.Load file,' -target=',⍕root 874 | :EndFor 875 | :For folder :In folders 876 | nsName←2⊃1 ⎕NPARTS folder 877 | ref←0 878 | :Select root.⎕NC⊂nsName 879 | :Case 9.1 ⍝ namespace 880 | ref←root⍎nsName 881 | :Case 0 ⍝ not defined 882 | ref←⍎nsName root.⎕NS'' 883 | :Else ⍝ oops 884 | msg,←'"',folder,'" cannot be mapped to a valid namespace name',⎕UCS 13 885 | :EndSelect 886 | :If ref≢0 887 | (r m)←ref LoadFromFolder folder 888 | r←rc⌈r 889 | msg,←m 890 | :EndIf 891 | :EndFor 892 | msg←¯1↓msg 893 | ∇ 894 | :EndSection 895 | 896 | :Section JSON 897 | 898 | ∇ r←{debug}JSON array;typ;ic;drop;ns;preserve;quote;qp;eval;t;n 899 | ⍝ JSONify namespaces/arrays with elements of rank>1 900 | :Access public shared 901 | debug←{6::⍵ ⋄ debug}0 902 | array←{(↓⍣(¯1+≢⍴⍵))⍵}array 903 | :Trap debug↓0 904 | :If {(0∊⍴⍴⍵)∧0=≡⍵}array ⍝ simple? 905 | r←{⎕PP←34 ⋄ (2|⎕DR ⍵)⍲∨/b←'¯'=r←⍕⍵:r ⋄ (b/r)←'-' ⋄ r}array 906 | →0⍴⍨2|typ←⎕DR array ⍝ numbers? 907 | :Select ⎕NC⊂'array' 908 | :CaseList 9.4 9.2 909 | ⎕SIGNAL(⎕THIS≡array)/⊂('EN' 11)('Message' 'Array cannot be a class') 910 | :Case 9.1 911 | r←,'{' 912 | :For n :In n←array.⎕NL-2 9.1 913 | r,←'"',(∊((⊂'\'∘,)@(∊∘'"\'))n),'":' ⍝ name 914 | r,←(debug JSON array⍎n),',' ⍝ the value 915 | :EndFor 916 | r←'}',⍨(-1<⍴r)↓r 917 | :Else ⋄ r←1⌽'""',escapedChars array 918 | :EndSelect 919 | :Else ⍝ is not simple (array) 920 | r←'['↓⍨ic←isChar array 921 | :If 0∊⍴array ⋄ →0⊣r←(1+ic)⊃'[]' '""' 922 | :ElseIf ic ⋄ r,←1⌽'""',escapedChars,array ⍝ strings are displayed as such 923 | :ElseIf 2=≡array 924 | :AndIf 0=≢⍴array 925 | :AndIf isChar⊃array ⋄ →0⊣r←⊃array 926 | :Else ⋄ r,←1↓∊',',¨debug JSON¨,array 927 | :EndIf 928 | r,←ic↓']' 929 | :EndIf 930 | :Else ⍝ :Trap 0 931 | (⎕SIGNAL/)⎕DMX.(EM EN) 932 | :EndTrap 933 | ∇ 934 | 935 | isChar←{0 2∊⍨10|⎕DR ⍵} 936 | escapedChars←{ 937 | str←⍵ 938 | ~1∊b←str∊fnrbt←'"\/',⎕UCS 12 10 13 8 9:str 939 | (b/str)←'\"' '\\' '\/' '\f' '\n' '\r' '\b' '\t'[fnrbt⍳b/str] 940 | str 941 | } 942 | 943 | :EndSection 944 | 945 | :Section HTML 946 | ∇ r←ScriptFollows;n 947 | :Access public shared 948 | n←2 949 | r←{⍵/⍨'⍝'≠⊃¨⍵}{1↓¨⍵/⍨∧\'⍝'=⊃¨⍵}{⍵{((∨\⍵)∧⌽∨\⌽⍵)/⍺}' '≠⍵}¨(1+n⊃⎕LC)↓↓(180⌶)n⊃⎕XSI 950 | r←2↓∊(⎕UCS 13 10)∘,¨r 951 | ∇ 952 | 953 | ∇ r←HtmlPage 954 | :Access public shared 955 | r←ScriptFollows 956 | ⍝ 957 | ⍝ 958 | ⍝ 959 | ⍝ 960 | ⍝JSONServer 961 | ⍝ 962 | ⍝ 963 | ⍝
964 | ⍝ Request 965 | ⍝
966 | ⍝ 967 | ⍝ 968 | ⍝ 969 | ⍝ 970 | ⍝ 971 | ⍝ 972 | ⍝ 973 | ⍝ 974 | ⍝ 975 | ⍝ 976 | ⍝ 977 | ⍝ 978 | ⍝
979 | ⍝
980 | ⍝
981 | ⍝
982 | ⍝ Response 983 | ⍝
984 | ⍝
985 | ⍝
986 | ⍝ 1009 | ⍝ 1010 | ⍝ 1011 | ∇ 1012 | :EndSection 1013 | 1014 | :EndClass 1015 | --------------------------------------------------------------------------------