2128 lines
84 KiB
Plaintext
2128 lines
84 KiB
Plaintext
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+y<x
|
||
⍵+c×10*6
|
||
}
|
||
|
||
BasicFormats←{
|
||
⍝ ⍵ ←→ Time Strings
|
||
⍝ ← ←→ Potential appropriate format strngs
|
||
m←↑⍵
|
||
w←1⊃⍴m
|
||
toWide←w∘{⍵/⍨⍺≥≢¨⍵}
|
||
noDays←{⍵/⍨~'D'∊¨⍵}
|
||
hasDays←{⍵/⍨'D'∊¨⍵}
|
||
i←⊂¨∪⍋¨,⍳3⍴3
|
||
sn←1∊∊(↓MonthNames'')⍷¨⊂⎕C m
|
||
fp←,i∘.⌷((4⍴sn 1)/(4 3 2)(4 2 2)(2 3 2)2)/¨¨⊂'YMD'
|
||
fp←fp,∪fp~¨⊂⊂'DD'
|
||
fd←1↓¨∊¨'/',¨¨fp
|
||
fu←{⍵/⍨~∨/'MMM'⍷↑⍵}∊¨fp
|
||
v←i∘.⌷⊂'YMD'
|
||
v,←sn/(1+2×v='M')/¨v
|
||
v,←∪v~¨'D'
|
||
b←⎕D∊⍨' ',m
|
||
r←+/2</b ⍝ Digit runs
|
||
d←+/~b[0;] ⍝ Number of delims
|
||
fw←1=≢∪b ⍝ Fixed width
|
||
1∧.≥r:fu,⊂'excel' ⍝ toWide fu ⍝ No delimiters
|
||
fw∧(d=1)∧2∧.=r:noDays toWide fd ⍝ Fixed without days
|
||
fw∧(d=2)∧3∧.=r:hasDays toWide fd ⍝ Fixed with days
|
||
z←toWide fu,fd,v
|
||
z←z[⍒≢¨z] ⍝ Preference for longer format.
|
||
z[⍒+/¨'YMD'∘∊¨z] ⍝ Preference for more elements
|
||
}
|
||
|
||
CheckPattern←{
|
||
(⊂⎕C ⍵)∊'excel'∘,¨'' '1900' '1904':''
|
||
a←'YMDhms'
|
||
fe←'YMYMDhms'/¨⍨4 3,6⍴2
|
||
ve←'MMYMDhms'/¨⍨4 3,6⍴1
|
||
s←⍵⊆⍨+\2≠/' ',⍵
|
||
p←s/⍨a∊⍨⊃¨s
|
||
t←' in pattern ',⍵
|
||
0=≢p:'No elements provided',t
|
||
~∧/p∊fe,ve:'Invalid element',t
|
||
e←⊃¨p
|
||
(⊢≢∧\)a∊e:'Missing elements',t
|
||
e≢∪e:'Duplicate elements',t
|
||
f←∨/p∊'YY' 'YYYY'
|
||
f∧~∧/p∊fe:'Invalid (for fixed-width) element',t
|
||
(~f)∧~∧/p∊ve:'Invalid (for variable-width) element',t
|
||
''
|
||
}
|
||
|
||
ErrorCheck←{
|
||
0=⎕NC'⍺':2 Signal'The function requires a left argument'
|
||
m←↑⍵
|
||
c←2=≢⍴m ⍝ Is char data
|
||
n←1=≢⍴m ⍝ Is Numeric datea
|
||
⍝ 80≠⎕DR m:11 Signal'The right argument must be a simple char mat or simple numeric vector'
|
||
f w t←ProcessLeftArgument ⍺
|
||
r←CheckPattern¨f
|
||
e←~r∊⊂''
|
||
∨/e:11 Signal⊃e/r
|
||
u←(∧/¨f∊¨⊂'YMDhms')∨(⎕C f)∊'excel'∘,¨'' '1900' '1904'
|
||
n∧~∧/u:11 Signal'Numeric data requires undelimited patterns.'
|
||
e←(~u)∧(1⊃2↑⍴m)<≢¨f
|
||
∨/e:11 Signal'The format pattern ',(⊃e/f),' is wider than the right argument'
|
||
f←{1=≢⍵:⊃⍵ ⋄ ⍵}f
|
||
f w t m
|
||
}
|
||
|
||
FixedMMM←{
|
||
b←'MMM'⍷⍺
|
||
~1∊b:⍺ ⍵
|
||
i←⍸b
|
||
f←' '@i⊢⍺
|
||
m←⍵
|
||
n←MonthNames''
|
||
m[;i+⍳3]←'ZI3'⎕FMT 1+n⍳⎕C m[;i+⍳3]
|
||
f m
|
||
}
|
||
|
||
ProcessLeftArgument←{
|
||
w t←50,⊃⎕TS
|
||
80=⎕DR↑⍵:(⊆⍵)w t
|
||
3↑(⊂⊆⊃⍵),(1↓⍵),t
|
||
}
|
||
|
||
Text2Date←{
|
||
⍝ ⍵ ←→ Char mat of time strings
|
||
⍝ ⍺ ←→ Format(s) [Century Window] [Century Anchor Year]
|
||
⍝ ← ←→ ⎕DT time number type 60 or 0 for invalid
|
||
⍺←⊢
|
||
300+⍳100::ReSignal ⎕DMX
|
||
(f w t m)←⍺ ErrorCheck ⍵
|
||
2=≡f:{⊃+/⍵×<\⍵≠0}({⍵ w t}¨f)∇¨⊂m
|
||
'excel'≡⎕C 5↑f:f Excel2Date m
|
||
k←+/'YMDhms'∊f
|
||
Validate f w t AddCentury k Default k Scale f Decode f Parse m
|
||
}
|
||
|
||
Validate←{
|
||
⍝ ⍵×60 0 ⎕DT ⍵
|
||
k←(0,5⍴100)⊤⍵×10*6
|
||
f c←(1752 1 1 0 0 0)(4000 13 32 24 60 60)
|
||
l←(k[1;]=2)∧(0=4|k[0;])=(0=100|k[0;])=0=400|k[0;]
|
||
g←(k[2;]>0)∧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←'<h3>',(⍕ns.Req.Response.((⍕Status),' ',StatusText)),'</h3>'
|
||
→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←'<!DOCTYPE html><html><head><meta content="text/html; charset=utf-8" http-equiv="Content-Type"><link rel="icon" href="data:,"></head><body><h2>400 Bad Request</h2></body></html>'
|
||
→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←'<h3>Not found: ',(file↓⍨≢_htmlFolder),'</h3>'
|
||
→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)<ind
|
||
exec←⊃RESTMethods[ind;2]
|
||
→0 If ns.Req.Fail 501×0∊⍴exec
|
||
|
||
resp←''
|
||
:Trap 0 DebugLevel 1
|
||
:Trap 85
|
||
stopIf DebugLevel 2
|
||
resp←{1 CodeLocation.(85⌶)exec,' ⍵'}ns.Req ⍝ intentional stop for application-level debugging
|
||
:EndTrap
|
||
:Else
|
||
→0⊣ns.Req.Fail 500
|
||
:EndTrap
|
||
→0 If 2≠⌊0.01×ns.Req.Response.Status
|
||
:If (ns.Req.(Response.Headers GetHeader'content-type')≡'')∧~0∊⍴DefaultContentType
|
||
'content-type'ns.Req.SetHeader DefaultContentType
|
||
:EndIf
|
||
:If 'application/json'match⊃';'(≠⊆⊢)ns.Req.(Response.Headers GetHeader'content-type')
|
||
ns.Req.Response ToJSON resp
|
||
:EndIf
|
||
∇
|
||
|
||
∇ r←HandleCORSRequest req;origin;reflect
|
||
r←0
|
||
→0 If~EnableCORS
|
||
→0 If 0∊⍴origin←req.GetHeader'Origin' ⍝ CORS requests have an Origin header
|
||
reflect←{(1+(,⍺)≡,1)⊃⍺ ⍵} ⍝ if CORS_xxx setting is 1, reflect the request's value
|
||
'Access-Control-Allow-Origin'req.DefaultHeader CORS_Origin reflect origin
|
||
→0 If~req.Method≡'options' ⍝ OPTIONS (with an Origin header) indicates a "pre-flighted" CORS request
|
||
→0 If 0∊⍴req.GetHeader'Access-Control-Request-Method' ⍝
|
||
'Access-Control-Allow-Methods'req.DefaultHeader CORS_Methods reflect req.GetHeader'Access-Control-Request-Method'
|
||
'Access-Control-Allow-Headers'req.DefaultHeader CORS_Headers reflect req.GetHeader'Access-Control-Request-Headers'
|
||
'Access-Control-Max-Age'req.DefaultHeader(⍕CORS_MaxAge)
|
||
req.SetStatus 204 ⍝ No Content
|
||
r←1
|
||
∇
|
||
|
||
∇ response ToJSON data
|
||
⍝ convert APL response payload to JSON
|
||
:Trap 0 DebugLevel 1
|
||
response.Payload←⎕UCS SafeJSON JSONout data
|
||
:Else
|
||
'Could not format result payload as JSON'ns.Req.Fail 500
|
||
:EndTrap
|
||
∇
|
||
|
||
∇ w←SafeJSON w;i;c;⎕IO
|
||
⍝ Convert Unicode chars to \uXXXX
|
||
⎕IO←0
|
||
→0⍴⍨0∊⍴i←⍸127<c←⎕UCS w
|
||
w[i]←{⊂'\u','0123456789ABCDEF'[16 16 16 16⊤⍵]}¨c[i]
|
||
w←∊w
|
||
∇
|
||
|
||
∇ r←CheckAuthentication req
|
||
⍝ Check request authentication
|
||
⍝ r is 0 if request processing can continue
|
||
r←1
|
||
:If 0=DoAuthentication req ⍝ might still want to do some authentication
|
||
:If 0≠SessionTimeout ⍝ using sessions?
|
||
:If 0≠CheckSession req ⍝ session is still valid?
|
||
CreateSession req
|
||
:EndIf
|
||
:EndIf
|
||
r←0
|
||
:EndIf
|
||
∇
|
||
|
||
∇ rc←DoAuthentication req;debug;old
|
||
⍝ rc is 0 if either no authentication is required or authentication succeeds
|
||
⍝
|
||
rc←0
|
||
:Trap 0 DebugLevel 1
|
||
stopIf DebugLevel 2×~0∊⍴AuthenticateFn
|
||
rc←Authenticate req ⍝ intentional stop for application-level debugging
|
||
:If rc≠0
|
||
req.Fail 401
|
||
:If HTTPAuthentication match'basic'
|
||
'WWW-Authenticate'req.SetHeader'Basic realm="Jarvis", charset="UTF-8"'
|
||
:EndIf
|
||
:EndIf
|
||
:Else ⍝ Authenticate errored
|
||
(⎕DMX.EM,' occured during authentication')req.Fail 500
|
||
rc←1
|
||
:EndTrap
|
||
∇
|
||
|
||
∇ obj Respond ns;status;z;res;close;conx
|
||
res←ns.Req.Response
|
||
status←(⊂ns.Req.HTTPVersion),res.((⍕Status)StatusText)
|
||
res.Headers⍪←'Server'(deb⍕2↑Version)
|
||
res.Headers⍪←'Date'(2⊃LDRC.GetProp'.' 'HttpDate')
|
||
conx←lc ns.Req.GetHeader'connection'
|
||
close←(('HTTP/1.0'≡ns.Req.HTTPVersion)>'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,</)bot
|
||
∨/1↓p:∊(p⊂⍺)∇¨p⊂⍵
|
||
⍵
|
||
}
|
||
ErrIfEmpty←{⍵⊣'Array doesn''t have a prototype'⎕SIGNAL 11/⍨(0=≢⍵)}
|
||
SubParse←{
|
||
('})]'⍳⊃⌽⍵)≠('{(['⍳⊃⍵):'Bad bracketing'⎕SIGNAL 2
|
||
(a w)←(1↓¯1∘↓)¨(⍺-1)⍵
|
||
'['=⊃⍵:Paren'{⎕ML←1⋄↑⍵}1/¨',Paren ErrIfEmpty a Parse w ⍝ high-rank
|
||
':'∊⍵/⍨(1=⍺)×~≠\q=⍵:a Namespace w ⍝ ns
|
||
'('=⊃⍵:Paren{⍵,'⎕NS⍬'/⍨0=≢⍵}a Parse w ⍝ vector/empty ns
|
||
⍵ ⍝ dfn
|
||
}
|
||
SysVar←(L sysVars)∊⍨' '~¨⍨L∘⊆
|
||
ParseLine←{
|
||
c←⍵⍳':'
|
||
1≥≢(c↓⍵)~' ':'Missing value'⎕SIGNAL 6
|
||
name←c↑⍵
|
||
(SysVar⍱¯1≠⎕NC)name:'Invalid name'⎕SIGNAL 2
|
||
name(name,'←',⍺ Parse Over((c+1)↓⊢)⍵)
|
||
}
|
||
Namespace←{
|
||
p←(0=⍺)×SepMask ⍵
|
||
(names assns)←↓⍉↑⍺ ParseLine EachNonempty Over(p Split)⍵
|
||
quadMask←SysVar names
|
||
quadAssns←'{⍵.(⍵',(∊'⊣',¨quadMask/assns),')}'
|
||
names/⍨←~quadMask
|
||
assns/⍨←~quadMask
|
||
∊'({'(assns,¨'⋄')quadAssns'⎕NS'('(, '∘,¨q,¨names,¨⊂q')')'}⍬)'
|
||
}
|
||
⍝ Make normalised simple vector:
|
||
w←↓⍣(2=≢⍴⍵)⊢⍵ ⍝ if mat, make nested
|
||
w←{¯1↓∊⍵,¨⎕UCS 13}⍣(2=|≡w)⊢w ⍝ if nested, make simple
|
||
w←'''[^'']*''' '⍝.*'⎕R'&' ''⊢w ⍝ strip comments
|
||
w/⍨←{(∨\⍵)∧⌽∨\⌽⍵}33≤⎕UCS w ⍝ strip leading/trailing non-printables
|
||
pl←ParenLev w
|
||
(0≠⊢/pl)∨(∨/0>pl):'Unmatched brackets'⎕SIGNAL 2
|
||
∨/(pl=0)×SepMask w:'Multi-line input'⎕SIGNAL 11
|
||
(⊃⎕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←'<b>No Endpoints Found</b>'
|
||
:Else
|
||
endpoints←∊{'<option value="',⍵,'">',⍵,'</option>'}¨'/'@('.'=⊢)¨endpoints
|
||
endpoints←'<select id="function" name="function">',endpoints,'</select>'
|
||
:EndIf
|
||
r←endpoints{i←⍵⍳'⍠' ⋄ ((i-1)↑⍵),⍺,i↓⍵}r
|
||
r←⎕UCS'UTF-8'⎕UCS r
|
||
∇
|
||
:EndSection
|
||
|
||
:EndClass |