lam←{ ⎕IO⎕ML←1 1 ∆d←⍪('true' ('Lam' (,'t') ('Lam' (,'f') ('Var' (,'t'))))) ∆d,←('false' ('Lam' (,'t') ('Lam' (,'f') ('Var' (,'f'))))) ⍺←∆d⋄∆t←⍺⋄∆hi←{∆t,←⍺⍵}⋄∆hr←{∆t∘←((∆t↑[2]⍨¯1∘+),∆t↓[2]⍨⊢)⍵⍳⍨,1↑∆t}⋄err←{⍵⎕SIGNAL 8} hash←{{1e10|⍺+31×⍵}/128+1(220⌶)⍵}⋄sd←'₀₁₂₃₄₅₆₇₈₉'⋄l←'()λ.='⋄ad←{⍺,sd[,1+10⊥⍣¯1⊢⍵]} str←{'Lam'≡⊃⍵:∊'(λ'(2⊃⍵)'. '(∇3⊃⍵)')'⋄'Var'≡⊃⍵:2⊃⍵⋄'App'≡⊃⍵:∊'('(∇2⊃⍵)' '(∇3⊃⍵)')'} lx←{0=≢⍵:⍬⋄(⊃⍵)∊l:(⊂0,⊃⍵),∇1↓⍵⋄3≠(⎕UCS 10 32)⍳⊃⍵:∇1↓⍵⋄'#'=⊃⍵:∇⍵↓⍨⍵⍳⎕UCS 10 ×k←⊥⍨⌽⍵∊sd,⎕A,⎕C⎕A:(⊂1,k↑⍵),∇k↓⍵⋄err'eltoken'⍵} pr←{L←0'λ'⋄P←0'('⋄E←0'='⋄C←0')'⋄D←0'.' at←{P≡⊃⍵:{lx t←tr(1↓⍵)⋄C≢⊃lx:err'eparen'⋄(1↓lx) t}⍵ 1≡⊃⊃⍵:(1↓⍵)('Var'(1↓⊃⍵))⋄L≡⊃⍵:ab 1↓⍵⋄err'etoken'} ab←{i←⊥⍨⌽1=⊃¨⍵⋄i<1:err'elambda'⋄D≢⍵⊃⍨i+1:err'edot' lx tv←tr(1+i)↓⍵⋄nm←1↓¨i↑⍵⋄lx(nm{0=≢⍺:⍵⋄(¯1↓⍺)∇'Lam'(⊃⌽⍺)⍵}tv)} tr←{L≡⊃⍵:ab 1↓⍵⋄↑{(L≢⊃⍺)∧(1≢⊃⊃⍺)∧(P≢⊃⍺):⍺⍵⋄lx t←at ⍺⋄lx ∇'App'⍵ t}/at ⍵} bi←{k←⊃⍵⋄lx v←tr 2↓⍵⋄0≠≢lx:err'estray'⋄_←∆hr k⋄_←∆hi k v⋄⍬} E≡⊃1↓⍵:bi ⍵⋄⊃⌽tr ⍵} a←⍪''0⋄ac←{∆i←{i←(,1↑a)⍳⊂⍵⋄_←⍺{i>⊃⌽⍴a:a,←⍵ 0⋄a[2;i]+←⍺⋄0}⍵⋄⍵ad,a[2;i]} {'Var'≡⊃⍵:'Var' (0 ∆i ⊃⌽⍵)⋄'App'≡⊃⍵:'App' (∇2⊃⍵) (∇3⊃⍵) 'Lam'≡⊃⍵:(⊂'Lam'),((∇3⊃⍵) ,⍨⍥⊂ (1 ∆i 2⊃⍵))}⍵} de←{lk←{(⊂⍵)∊⍺:'Var'⍵⋄i←(⊂⍵)⍳⍨,1↑∆t⋄i>⊃⌽⍴∆t:'Var'⍵⋄⊃∆t[2;i]} {⍺←⊂''⋄'Var'≡⊃⍵:(⍺ lk ⊃⌽⍵)⋄'App'≡⊃⍵:'App' (⍺∇2⊃⍵) (⍺∇3⊃⍵) 'Lam'≡⊃⍵:(2↑⍵),⊂(⍺,⊂2⊃⍵)∇3⊃⍵}⍵} br←{'Lam'≡⊃⍵:(2↑⍵),⊂∇3⊃⍵⋄'Var'≡⊃⍵:⍵⋄'App'≢⊃⍵:err'eint' an bn←∇¨1↓⍵⋄'Lam'≢⊃an:⍵⋄an bn←1↓ac 'App' an bn⋄av←2⊃an {v←'Var'≡⊃⍵⋄v∧av≡2⊃⍵:bn⋄v:⍵⋄v←'Lam'≡⊃⍵⋄v∧av≡2⊃⍵:⍵⋄v:(2↑⍵),⊂∇3⊃⍵ 'App'≡⊃⍵:'App' (∇2⊃⍵) (∇3⊃⍵)}3⊃an} rd←{h←⍬⋄i←{⍵∊h:1⋄h,←⍵⋄0}⋄in←de ⍵⋄r←br⍣{(i hash ⍺)∨⍺≡⍵}in⋄(in≡r)∨(hash r)∊¯1↓h:err'einf'⋄r} ⍬≢ast←pr lx ⍵:str rd ast } ⍝ apl-misc-math - Copyright (C) Kamila Szewczyk, 2022. ⍝ Redistributed under the terms of the AGPLv3 license. ⍝ Load using: ⎕fix'file:///.../apl-misc-math/mm.apl'⋄mm.setup ⍝ Special thanks to Adám Brudzewsky. :Namespace mm ⍝ Default settings. The library works optimally with ⍝ higher precision arithmetic. ##.(⎕FR⎕PP)←1287 34 ⍝ Alter to change the precision of operations. ⍝ Note: A value too small will carry more error due to ⍝ floating point inaccurancy. epsilon←0.0000001 int_prec←0.0001 ⍝ Braces were supposed to make the result shy, but apparently they don't. ∇ {r}←setup (_tanh_sinh_pf _tanh_sinh_m2)←↓(○.5)×5 6∘.○int_prec×⍳÷int_prec _tanh_sinh_m2×←int_prec (_tanh_xk _tanh_wkd)←↓7 6∘.○_tanh_sinh_pf _tanh_sinh_m2÷←×⍨_tanh_wkd _erf_c←2÷(○1)*.5 euler_gamma←(+/∘÷∘⍳-⍟) lim_inf 1 ⍝ Alternatively: -digamma 1 'ok' ∇ ⍝ d⍺⍺/dx |x=⍵ derv←{epsilon÷⍨-/⍺⍺¨⍵+epsilon 0} ⍝ d^n⍺⍺/dx^n |x=⍵ nderv←{⍵⍵=1:⍺⍺ D ⍵ ⋄ ((⍺⍺ D) ∇∇ (⍵⍵-1)) ⍵} ⍝ The secant root-finding method. ⍵ is starting x1,x2 secant←{ f←⍺⍺⋄⊃⌽{ dy←-/y1 y2←f¨x1 x2←⍵ x2,x1-y1×dy÷⍨-/⍵ }⍣{epsilon>|-/⍺}⍵ } ⍝ Trim insignificant real/imaginary parts. ztrim←{¯9 ¯11+.○(⊢×epsilon<|)9 11∘.○⍵} ⍝ Durand-Kerner method for finding complex polynomial roots. ⍝ 0.4J0.9 was chosen arbitrarily as a starting point. It is ⍝ neither a real number nor a de Moivre number. durand_kerner←{ f←⊥∘((⊢÷⊃)⍵)⋄g←{⍵⍪⍉⍪f¨⍵} ztrim¨,1↑{ v←,1↑⍵⋄g{⍺-⍵÷×/0~⍨⍺-v}⌿⍵ }⍣⍺ g 0.4J0.9*⎕io-⍨⍳1-⍨≢⍵ } ⍝ The Faddeev-LeVerrier algorithm for finding the characteristic ⍝ polynomial of a square matrix. faddeev_leverrier←{ ⎕io←0⋄(≠/⍴⍵)∨2≠≢⍴⍵:⍬⋄n←≢⍵ M0←⍵⋄I←n n⍴1↑⍨1+n⋄⊃ { ⍵=0:1 I⋄(cp MP)←∇⍵-1⋄X←M0+.×MP c←(+/0 0⍉X)÷-⍵⋄(cp,c)(X+I×c) } n } ⍝ An extension to the Faddeev-LeVerrier implementation above that ⍝ also keeps track of the matrix used to compute the inverse. ⍝ The inverse can be obtained using inv cpoly←... and inv×-÷⊃⌽cpoly faddeev_leverrier_ex←{ ⎕io←0⋄(≠/⍴⍵)∨2≠≢⍴⍵:⍬⋄n←≢⍵⋄inv←⍬ M0←⍵⋄I←n n⍴1↑⍨1+n⋄cpoly←⊃ { ⍵=0:1 I⋄(cp MP)←∇⍵-1⋄X←M0+.×MP c←(+/0 0⍉X)÷-⍵ MC←X+I×c _←{⍵=n-1:inv∘←MC⋄0}⍵ (cp,c)MC } n inv cpoly } ⍝ Eigenvector computation. eigenvec←{ ⎕io←0⋄(≠/⍴⍵)∨2≠≢⍴⍵:⍬ n←≢⍵⋄I←n n⍴1↑⍨1+n⋄s←⍵-⍺×I q←1,⍨1↑⍨1-⍨⊃⌽⍴s⋄ztrim¨1,⍨∊⌹⍨∘-/q⊂1↓s } ⍝ A range function from dfns. range←{↑+/⍵{⍵×{⍵-⎕IO}⍳1+0⌈⌊(⍺⍺-⍺)÷⍵+⍵=0}\1 ¯1×-\2↑⍺,⍺+×⍵-⍺} ⍝ Simpson integration. Assumes bounds ⍺<⍵. simpson←{ h←(⍵-⍺)÷S←÷int_prec (h÷3)×+/(⍺+⍥⍺⍺ ⍵),⍺((⍺⍺⊣+h×⊢)×2×1+2|⊢⍤0)⍳S } ⍝ Trapezoidal rule. trapz←{ ⍺=⍵:0 sgn←¯1*⍺>⍵ a b←⍺(⌊,⌈)⍵ x←↑2,/(a+0 int_prec)range b sgn×+/0.5×int_prec×+/⍺⍺⍤0⊢x } ⍝ The tanh-sinh quadrature. tanh_sinh←{ ⍺>⍵:-⍵(⍺⍺∇∇)⍺ ⍺ ⍵≡0 1:+/_tanh_sinh_m2×⍺⍺¨_tanh_xk a b←⍺ ⍵⋄g←⍺⍺ (b-a)×+/_tanh_sinh_m2×{g a+⍵×b-a}¨_tanh_xk } ⍝ Some APLCart stuff I dislike grabbing over and over again. median←2÷⍨1⊥⊢⌷⍨∘⊂⍋⌷⍨∘⊂∘⌈2÷⍨0 1+≢ stddev←≢÷⍨2*∘÷⍨(≢×+.*∘2)-2*⍨+⌿ diag←{⍵⊂⍤⊢⌸⍥,⍨+/↑⍳⍴⍵} ⍝ Antidiagonals as a vector of vectors. ⍝ Partition a n-element index array according to an invertible ⍝ complexity function. part_f←{⌽⌽¨(⌽⍳⍵)⊂⍨⍸⍣¯1⌊⍺⍺⍳⌊⍺⍺⍣¯1⊢⍵} ⍝ Complexity functions. Used in the partitioning algoithm, ⍝ they include an additional n factor. Onbang←⊢×! ⍝ O(n!) Onlogn←×⍨×⍟ ⍝ O(n log n) Ologn←⊢×⍟ ⍝ O(log n) Osqrtn←⊢×(.5*⍨⊢) ⍝ O(sqrt(n)) On3←⊢*∘4 ⍝ O(n^3) On2←⊢*∘3 ⍝ O(n^2) On←×⍨ ⍝ O(n) O1←⊢ ⍝ O(1) ⍝ A primitive approximation of limits at infinity. lim_inf←{0::⍺⍺ ⍵⋄x←⍺⍺¨ 0 1+⍵⋄epsilon<|-/x:⍺⍺∇∇(1+⍵)⋄⊃x} ⍝ The error function. erf←{_erf_c×0(*∘-×⍨)simpson⍵} ⍝ The sine integrals. Si←{0 (1∘○÷⊢)simpson ⍵} si←{(mm.Si ⍵)-○.5} ⍝ The cosine integrals. Cin←{0 {⍵÷⍨1-2○⍵}simpson ⍵} Ci←{mm.euler_gamma + (⍟-mm.Cin)⍵} ⍝ Offset logarithmic integral. Li←{2 (÷∘⍟)mm.simpson ⍵} ⍝ Partial derivatives. invariant_a←{⍵⍵ ⍺⍺ ⍵} invariant_b←{⍵ ⍺⍺ ⍵⍵} pderv_a←{epsilon÷⍨-/(⍺⍺ invariant_b ⍵)¨⍺+epsilon 0} ⍝ Partial derivative df/d⍺ pderv_b←{epsilon÷⍨-/(⍺⍺ invariant_a ⍺)¨⍵+epsilon 0} ⍝ Partial derivative df/d⍵ ⍝ The digamma function. digamma←(!¯1∘+)derv÷(!¯1∘+) ⍝ Gradient vector. nabla_grad←{⍺(⍺⍺ pderv_a,⍺⍺ pderv_b)⍵} :EndNamespace sim←{ eunderspec←'Underspecified system. Missing the definition of nodes: ' enoint←'Failed to ensure integrity of the system' epref←'Invalid prefix in specifier ' ea←' requires no arguments.' ' requires one argument.' ' requires two arguments.' ⍺←0.5 code←{ (2⊃¨v/⍨x)@(⍸x←∊⊃¨v←⎕VFI¨⍵)⊢⍵ }¨' '(≠⊆⊢)¨⊃⎕NGET ⍵ 1 ind←⊃¨srt←code[⍋⊃¨code] sys←∪{⍵/⍨(2|⎕DR)¨⍵}↑,/2↓¨srt vrf←sys∊⍥∊ind 0=∧/vrf:(∊eunderspec(⍕sys/⍨~vrf))⎕SIGNAL 8 (≢≠⊃∘⌽)ind:enoint ⎕SIGNAL 8 leds←⍸(⊂'LED')≡¨2⊃¨srt unpref←{'x'≠1↑⍵:(epref ⍵)⎕SIGNAL 8 ⋄ 1↓⍵} load←{∊'v[',(⍕⍵),']'} fmt←{{⍵/⍨(∨\∧∘⌽∨\∘⌽)' '≠⍵}∊('⍝'(≠⊆⊢)∊' '⍺' '),¨⍵,⊂⍬} state←⎕NS ⍬ ⋄ state.v←0⍴⍨≢srt ⋄ state.t←0 arity←⊂'HIGH' 'LOW' arity,←⊂'NOT' 'LED' 'BUTTON' 'CLOCK' arity,←⊂'AND' 'OR' 'XOR' 'XNOR' chka←{ 0=∨/ind←(⊂⍺)∘∊¨arity:0 ⍵≠¯1+⍸ind:(∊⍺,ea[⍸ind])⎕SIGNAL 8 ⋄ 1 } src←∊'⋄'(1↓∘,,⍤0)(⊂'t+←1⋄⍬'),⍨{ var op args←2(↑,⊂⍤↓)⍵ ⋄ _←op chka≢args av←load¨var,args op≡'AND':'⍝←⍝∧⍝'fmt av⋄op≡'OR':'⍝←⍝∨⍝'fmt av op≡'XOR':'⍝←⍝≠⍝'fmt av⋄op≡'XNOR':'⍝←⍝=⍝'fmt av op≡'NOT':'⍝←~⍝'fmt av⋄op≡'HIGH':'⍝←1'fmt⊂av op≡'LOW':'⍝←0'fmt⊂av⋄op≡'LED':'' op≡'BUTTON':'⍝←0≠⍝ t'fmt(⊂load var),args op≡'CLOCK':'⍝←0=⍝|t'fmt(⊂load var),⊂unpref⊃args (∊'unrecognised op 'op)⎕SIGNAL 8 }¨srt ⍺∘{ _←'state'⍎src ⎕←∊'Time: '(⍕state.t)' LEDs: '(⍕leds,¨state.v[3⊃¨srt[leds]]) ⎕DL ⍺ }⍣{0}⊢⍬ } dx←{ ⍝ import dfns dfns←{⍵⊣⍵.⎕CY'dfns'}⎕NS⍬ ⍝ namespace for symbol implementations ns←⎕NS ⍬ ⍝ code page cp←'⌶%⍺⍵_abcdefghijklmnopqrstuvwxyz¯.' cp,←'⍬0123456789⊢∆ABCDEFGHIJKLMNOPQRS' cp,←'TUVWXYZ⍙[/⌿\⍀<≤=≥>≠∨∧-+÷×?∊"#&@:' cp,←'⍷⋄←⍝)]⍴~↑↓⍳○*⌈⌊∇∘(⊂⊃∩∪⊥⊤|;,⍱⍲⍒⍋⍉' cp,←'⌽⊖⍟⌹!⍕⍎⍫⍪≡≢⎕⍞⍣⍭√⍛⍢⍍…⍙φ⍗⍐⍦⍁⍮Φ⍡' cp,←∊(⎕UCS 32)(⎕UCS 10) ⍝ custom operations t←⊂'~' '_Neg' ⋄ ns._Neg←{0=⍵} t,←⊂'⍭' '_Pco' ⋄ ns._Pco←dfns.pco t,←⊂'√' '_Root' ⋄ ns._Root←{⍺←2 ⋄ ⍵*÷⍺} t,←⊂'<' '_Lt' ⋄ ns._Lt←{0=⎕NC'⍺':⍵-1 ⋄ ⍺<⍵} t,←⊂'>' '_Gt' ⋄ ns._Gt←{0=⎕NC'⍺':⍵+1 ⋄ ⍺>⍵} t,←⊂'⍛' '_Rc' ⋄ ns._Rc←{⍵⍵∘⍺⍺} t,←⊂'⍢' '_Round' ⋄ ns._Round←{⍺←1 ⋄ ⍺(⊢∘××⊣×∘⌈¯0.5+∘|÷⍨)⍵} t,←⊂'⍍' '_MatMul' ⋄ ns._MatMul←{0=⎕NC'⍺':(,⍨⍴1,⍴∘0)⍵ ⋄ ⍺+.×⍵} t,←⊂'…' '_Range' ⋄ ns._Range←{ ⍝ Adam Brudzewsky's Range function. ⍝ modified to follow a terser code style. ⎕IO←0 ⋄ c←0 2∊⍨10|⎕DR ⋄ t←1↓⍵ ⋄ d←c(e←⊃⍵) f←⎕UCS⍣d⊢0 ⋄ ⍺←f ⋄ l←-(2-d)⌊(≢⍺)⌊+/d=c¨¯2↑⍺ s←l↓⍺ ⋄ b←(¯1⌊l)↑¯2↑f,l↑⍺ ⋄ d:s,t,⍨⎕UCS(⎕UCS b)∇ ⎕UCS e F S←-⍨\2↑b,b+×e-b ⋄ s,t,⍨F+S×⍳0⌈1+⌊(e-F)÷S+S=0 } t,←⊂'⍙' '_MonadicDot' ⋄ ns._MonadicDot←{ ⍝ https://dfns.dyalog.com/n_alt.htm r c←⍴⍵ 0=r:⍵⍵⌿,⍵ 1≥c:⍺⍺⌿,⍵ M←~⍤1 0⍨⍳r ⍵[;⎕IO]⍺⍺.⍵⍵(∇⍤2)⍵[M;1↓⍳c] } t,←⊂'φ' '_Fib' ⋄ ns._Fib←{⍺←0 1 ⋄ 0=⍵:⊃⍺ ⋄ (1↓⍺,+/⍺)∇ ⍵-1} t,←⊂'⍗' '_PowerDown' ⋄ ns._PowerDown←{op←⍺⍺⍣¯1 ⋄ 0=⎕NC'⍺':op ⍵ ⋄ ⍺ op ⍵} t,←⊂'⍐' '_PowerUp' ⋄ ns._PowerUp←{op←⍺⍺⍣(¯1+2*31) ⋄ 0=⎕NC'⍺':op ⍵ ⋄ ⍺ op ⍵} t,←⊂'∧' '_And' ⋄ ns._And←{0=⎕NC'⍺':⍵[⍋⍵] ⋄ ⍺∧⍵} t,←⊂'∨' '_Or' ⋄ ns._Or←{0=⎕NC'⍺':⍵[⍒⍵] ⋄ ⍺∨⍵} t,←⊂'⍦' '_Middle' ⋄ ns._Middle←{⍺>0:(-⍺)↓⍺↓⍵ ⋄ x←⌈(|⍺)-⍨2÷⍨≢⍵ ⋄ (-x)↓x↓⍵} t,←⊂'⍁' '_Diagonal' ⋄ ns._Diagonal←{⍵⊢∘⊂⌸⍨⍥,+/↑⍳⍴⍵} t,←⊂'⍮' '_Pair' ⋄ ns._Pair←{ 0≠⎕NC'⍺':⍺ ⍵ ⍵=0:'0123456789' ⍵=1:'abcdefghijklmnopqrstuvwxyz' ⍵=2:'ABCDEFGHIJKLMNOPQRSTUVWXYZ' ⍵=3:'yaeiou' ⍵=4:'YAEIOU' ⍵=5:'YAEIOU' ⍵=6:819⌶⎕A~'YAEIOU' ⍵=7:⎕A~'YAEIOU' ⍵=8:4294967296 ⍵=9:4294967295 ⍵=10:2÷¯1+5*÷2 ⍝ golden ratio ⍵=11:⎕UCS 10 ⍵=12:3.1415 } t,←⊂'Φ' '_Totient' ⋄ ns._Totient←((×/⊢-≠)3∘dfns.pco) t,←⊂'⍲' '_Prefixes' ⋄ ns._Prefixes←{0=⎕NC'⍺':(⍳∘≢↑¨⊂)⍵ ⋄ ⍺⍲⍵} t,←⊂'⍱' '_Suffixes' ⋄ ns._Suffixes←{0=⎕NC'⍺':(⌽∘,¨,\∘⌽)⍵ ⋄ ⍺⍱⍵} t,←⊂'=' '_Equal' ⋄ ns._Equal←{0=⎕NC'⍺':(1=≢∘∪)⍵ ⋄ ⍺=⍵} t,←⊂'⍡' '_Filter' ⋄ ns._Filter←{⍵/⍨⍺⍺ ⍵} t,←⊂'⊤' '_DownTack' ⋄ ns._DownTack←{⍺←10⋄⍺⊥⍣¯1⊢⍵} t,←⊂'⌂' '_DX' ⋄ ns._DX←∇∇ ⍝ translation and execution k←,¯1↓⍉↑t ⋄ t3←{{0=≢⊃⍵:⊃⌽⍵ ⋄ ⊃⌽t⊃⍨⊃⍵}¨⍵,⍥⊂¨⍨{⍸∊k=⊃⍵}¨⍵} g←⍺⍺ ⋄ r←t3¨{⍵/⍨{0≠≢⍵}¨⍵}{{⍵↓⍨-'⍝'=⊃⊃⌽⍵}60⌶⍵}¨↓⎕CR'g' p←↑↑{∊⍺'⋄'⍵}/{∊⍺' '⍵}/¨r 2=⎕NC'⍺':⍺(ns⍎p)⍵ ⋄ (ns⍎p)⍵ } AddCentury←{ ⍝ ⍺ ←→ Century Window, Century Anchor Year ⍝ ⍵ ←→Decimal time number 60 ⍝ ← ←→ ⍵ with added century f w t←⍺ 1∊'YYYY'⍷f:⍵ y←⌊⍵÷10*4 b←y<100 ~∨/b:⍵ w>999:⍵+b×w×10*4 s x←0 100⊤w-⍨t c←b×s+y0)∧k[2;]≤l+31 28 31 30 31 30 31 31 30 31 30 31[11⌊0⌈k[1;]-1] ⍵×(k[5;]=⌈k[5;])∧g∧∧⌿(f(≤⍤¯1)k)∧c(>⍤¯1)k } :Class Jarvis ⍝ Dyalog Web Service Server ⍝ See https://dyalog.github.io/Jarvis for documentation (⎕ML ⎕IO)←1 1 ∇ 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⊤⊃Debug)∨.∧2 2 2⊤level :If 0≠⎕NC'value' r←value/⍨~r :EndIf ∇ ∇ {r}←{level}Log msg;ts :Access public overridable :If Logging>0∊⍴msg ts←fmtTS ⎕TS :If 1=≢⍴msg←⍕msg :OrIf 1=⊃⍴msg r←ts,' - ',msg :Else r←ts,∊(⎕UCS 13),msg :EndIf ⎕←r :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 :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 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 :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 (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←0.1⊥2↑LDRC.Version LDRC.X509Cert.LDRC←LDRC ⍝ reset X509Cert.LDRC reference Log'Local Conga 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~⊂'' :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 ⍝ DecodeBuffers + WSAutoAccept :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' 0 ⍝ 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 (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 (_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 conx←obj(⍳↓⊣)'.' :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' AddConnection conx :CaseList 'HTTPHeader' 'HTTPTrailer' 'HTTPChunk' 'HTTPBody' :If 0≠_connections.⎕NC conx ref←_connections⍎conx _taskThreads←⎕TNUMS∩_taskThreads,ref{⍺ HandleRequest ⍵}&wres 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 ∇ ∇ AddConnection conx :Hold '_connections' conx _connections.⎕NS'' _connections.index,←conx(⎕AI[3]) (_connections⍎conx).IP←2⊃2⊃LDRC.GetProp obj'PeerAddr' :EndHold ∇ ∇ RemoveConnection conx :Hold '_connections' _connections.⎕EX conx _connections.index/⍨←_connections.index[1;]≢¨⊂conx :EndHold ∇ ∇ CleanupConnections;conxNames;timedOut;dead;kids;connecting;connected :If _connections.lastCheck<⎕AI[3]-ConnectionTimeout×1000 :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 dead←(connected~conxNames),timedOut ⍝ (connections not in the index), timed out {0∊⍴⍵: ⋄ {}LDRC.Close ServerName,'.',⍵}¨dead ⍝ attempt to close them ⍝ remove timed out, or connections that are _connections.⎕EX(conxNames~connected~dead),timedOut _connections.index/⍨←_connections.index[1;]∊_connections.⎕NL ¯9 :EndIf _connections.lastCheck←⎕AI[3] :EndHold :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 req;data;evt;obj;rc;cert;fn (rc obj evt data)←req ⍝ from Conga.Wait :Hold obj :Select evt :Case 'HTTPHeader' ns.Req←MakeRequest data 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' ns.Req.ProcessBody data :Case 'HTTPChunk' ns.Req.ProcessChunk data :Case 'HTTPTrailer' ns.Req.ProcessTrailer data :EndSelect :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 :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 →0⊣'Could not parse query string as JSON'ns.Req.Fail 400 :EndTrap :Else →0⊣('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 did not fail 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.Response 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'=' tmp←⎕NS'' :If {¯1=⎕NC ⍵}name →0⊣'Invalid form field name for Jarvis'req.Fail 400 :EndIf 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 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 :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 GetFromTable←{(⍵[;1]⍳⊂,⍺)⊃⍵[;2],⊂''} split←{p←(⍺⍷⍵)⍳1 ⋄ ((p-1)↑⍵)(p↓⍵)} ⍝ Split ⍵ on first occurrence of ⍺ lc←0∘(819⌶) 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 ⍝ 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 length←GetHeader'content-length' Complete←('get'≡Method)∧0=⊃⊃(//)⎕VFI length ⍝ we're a GET and there's no content-length or content-length=0 Complete∨←(0∊⍴length)>∨/'chunked'⍷GetHeader'transfer-encoding' ⍝ or no length supplied and we're not chunked ∇ ∇ 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. 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) ∇ ∇ 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 MakeSessionId←{⎕IO←0 ⋄((0(819⌶)⎕A),⎕A,⎕D)[(?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 ∇ :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←0∘(819⌶) ⍝ lower case uc←1∘(819⌶) ⍝ 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 ∇ 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←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←,'G⊂9999/99/99 @ 99:99:99⊃'⎕FMT 100⊥6↑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 ∇ Deserialise←{ ⍝ Convert text to array ⍺←⍬ ⍝ 1=execute expression; 0=return expression ⎕IO←0 Char←0 2∊⍨10|⎕DR Num←2|⎕DR Null←∧/⎕NULL≡¨⊢ ⍝ can't use ∧.= because = is pervasive on deep arrays Ptr←6=10|⎕DR Basic←Char∨Num∨Null FirstNum←Num¨⊃⍤/⊢ FirstNs←{9∊⎕NC'⍵'}¨⊃⍤/⊢ sysVars←'⎕CT' '⎕DIV' '⎕IO' '⎕ML' '⎕PP' '⎕RL' '⎕RTL' '⎕WX' '⎕USING' '⎕AVU' '⎕DCT' '⎕FR' L←lc execute←FirstNum ⍺,1 caller←FirstNs ⍺,⊃⎕RSI q←'''' SEP←'⋄',⎕UCS 10 13 Unquot←{(⍺⍺ ⍵)×~≠\q=⍵} SepMask←∊∘SEP Unquot ParenLev←+\(ׯ3+7|¯3+'([{)]}'∘⍳)Unquot Paren←1⌽')(',⊢ Split←{1↓¨⍺⍺⊂Over(1∘,)⍵} Over←{(⍵⍵ ⍺)⍺⍺(⍵⍵ ⍵)} EachIfAny←{0=≢⍵:⍵ ⋄ ⍺ ⍺⍺¨⍵} EachNonempty←{⍺ ⍺⍺ EachIfAny Over((×≢¨⍵~¨' ')/⊢)⍵} Parse←{ 0=≢⍵:'' bot←0=⍺ (2≤≢⍵)>∨/¯1↓bot:⍺ SubParse ⍵ p←bot×SepMask ⍵ ∨/p:∊{1=≢⍵:',⊂',⍵ ⋄ ⍵}⍺(Paren ∇)EachNonempty Over(p Split)⍵ p←2(1,>/∨¯1↓0,pl):'Unmatched brackets'⎕SIGNAL 2 ∨/(pl=0)×SepMask w:'Multi-line input'⎕SIGNAL 11 (⊃⎕RSI)Execute⍣execute⊢pl Parse w ⍝ materialise namespace as child of calling namespace } :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 endpoints←{⍵/⍨0=CheckFunctionName ⍵}EndPoints CodeLocation :If 0∊⍴endpoints endpoints←'No Endpoints Found' :Else endpoints←∊{''}¨'/'@('.'=⊢)¨endpoints endpoints←'' :EndIf r←endpoints{i←⍵⍳'⍠' ⋄ ((i-1)↑⍵),⍺,i↓⍵}r r←⎕UCS'UTF-8'⎕UCS r ∇ :EndSection :EndClass