├── Sources ├── dev │ ├── Clear.dyalog │ ├── Dev.dyalog │ ├── Load.dyalog │ └── Build.dyalog ├── IIS-SAWS.docx ├── Samples.dyalog ├── WebServices.dyalog ├── BuildCertDir.dyalog ├── WebServiceSamples │ ├── MyWebService.dyalog │ ├── ClientSample.dyalog │ └── PriceCheck.dyalog ├── HTTPUtils.dyalog ├── WebServer.dyalog ├── Files.dyalog ├── SAWS.dyalog └── SOAP.dyalog ├── SAWS.DWS ├── dev.dws ├── README.md ├── Distribution ├── SAWS.DWS ├── IIS-SAWS.pdf ├── MiServerCGI.exe └── SAWS v1 4.pdf └── LICENSE /Sources/dev/Clear.dyalog: -------------------------------------------------------------------------------- 1 | Clear 2 | ⎕EX ⎕NL 2 3.2 4.2 9 -------------------------------------------------------------------------------- /SAWS.DWS: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Dyalog/SAWS/HEAD/SAWS.DWS -------------------------------------------------------------------------------- /dev.dws: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Dyalog/SAWS/HEAD/dev.dws -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | SAWS 2 | ==== 3 | 4 | SAWS - Stand Alone Web Service framework 5 | -------------------------------------------------------------------------------- /Distribution/SAWS.DWS: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Dyalog/SAWS/HEAD/Distribution/SAWS.DWS -------------------------------------------------------------------------------- /Sources/IIS-SAWS.docx: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Dyalog/SAWS/HEAD/Sources/IIS-SAWS.docx -------------------------------------------------------------------------------- /Distribution/IIS-SAWS.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Dyalog/SAWS/HEAD/Distribution/IIS-SAWS.pdf -------------------------------------------------------------------------------- /Distribution/MiServerCGI.exe: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Dyalog/SAWS/HEAD/Distribution/MiServerCGI.exe -------------------------------------------------------------------------------- /Distribution/SAWS v1 4.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Dyalog/SAWS/HEAD/Distribution/SAWS v1 4.pdf -------------------------------------------------------------------------------- /Sources/dev/Dev.dyalog: -------------------------------------------------------------------------------- 1 | Dev;z 2 | z←{(-⌊/(⌽⍵)⍳'\/')↓⍵}⎕WSID 3 | ⎕←' )clear' 4 | ⎕←' ]load "',z,'/sources/dev/*"' 5 | ⎕←' )wsid "',z,'/dev.dws"' 6 | ⎕←' ⎕LX←''Load''' 7 | ⎕←' )save' -------------------------------------------------------------------------------- /Sources/dev/Load.dyalog: -------------------------------------------------------------------------------- 1 | Load;path 2 | 3 | ⎕←⎕SE.SALT.Load'⍵\Sources\SAWS -target=#' 4 | ⎕←⎕SE.SALT.Load'⍵\Sources\HTTPUtils -target=#.SAWS' 5 | ⎕←⎕SE.SALT.Load'⍵\Sources\SOAP -target=#.SAWS' 6 | ⎕←⎕SE.SALT.Load'⍵\Sources\WebServer -target=#.SAWS' 7 | ⎕←⎕SE.SALT.Load'⍵\Sources\Files -target=#' 8 | ⎕←⎕SE.SALT.Load'⍵\Sources\BuildCertDir -target=#' 9 | ⎕←⎕SE.SALT.Load'⍵\Sources\WebServices -target=#' 10 | ⎕←'WebServiceSamples' ⎕NS '' 11 | ⎕←⎕SE.SALT.Load'⍵\Sources\WebServiceSamples\* -target=#.WebServiceSamples' 12 | path←(1-⌊/(⌽⎕WSID)⍳'\/')↓⎕WSID 13 | ⎕LX←'' 14 | ⎕←' )WSID "',⎕WSID←path,'SAWS"' -------------------------------------------------------------------------------- /Sources/dev/Build.dyalog: -------------------------------------------------------------------------------- 1 | Build;path 2 | ⍝ Build distribution workspace containing unsalted classes and namespaces 3 | 4 | (⎕IO ⎕ML)←1 1 5 | ⎕EX ⎕NL 9 6 | path←(1-⌊/(⌽⎕WSID)⍳'\/')↓⎕WSID 7 | 8 | ⎕←⎕SE.SALT.Load'⍵\Sources\SAWS -target=# -source=no -nolink' 9 | ⎕←⎕SE.SALT.Load'⍵\Sources\HTTPUtils -target=#.SAWS -source=no -nolink' 10 | ⎕←⎕SE.SALT.Load'⍵\Sources\SOAP -target=#.SAWS -source=no -nolink' 11 | ⎕←⎕SE.SALT.Load'⍵\Sources\WebServer -target=#.SAWS -source=no -nolink' 12 | ⎕←⎕SE.SALT.Load'⍵\Sources\Files -target=# -source=no -nolink' 13 | ⎕←⎕SE.SALT.Load'⍵\Sources\BuildCertDir -target=# -source=no -nolink' 14 | ⎕←⎕SE.SALT.Load'⍵\Sources\WebServices -target=# -source=no -nolink' 15 | ⎕←'WebServiceSamples' ⎕NS '' 16 | ⎕←⎕SE.SALT.Load'⍵\Sources\WebServiceSamples\* -target=#.WebServiceSamples -source=no -nolink' 17 | 18 | ⎕←'SAWS.Version set to:' 19 | ⎕←SAWS.Version←'Version built at ',,'ZI4,<->,ZI2,<->,ZI2,< >,ZI2,<:>,ZI2,<:>,ZI2'⎕FMT 1 6⍴⎕TS 20 | 21 | ⎕LX←'' 22 | ⎕←'⍝ Now:' 23 | ⎕←' )WSID "',⎕WSID←path,'Distribution\SAWS.dws"' 24 | ⎕←' )erase Build Clear Dev Load' 25 | ⎕←' )SAVE' -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2020 Dyalog Ltd. 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /Sources/Samples.dyalog: -------------------------------------------------------------------------------- 1 | :Namespace Samples 2 | ⍝ === VARIABLES === 3 | 4 | TestCertificates←'' 5 | 6 | 7 | ⍝ === End of variables definition === 8 | 9 | (⎕IO ⎕ML ⎕WX)←1 0 3 10 | 11 | ∇ r←CertPath;droptail;exists;file;ws 12 | ⍝ Return the path to the certificates 13 | 14 | file←'server/localhost-server-cert.pem' ⍝ Search for this file 15 | droptail←{(-⌊/(⌽⍵)⍳'\/')↓⍵} 16 | exists←{0::0 ⋄ 1{⍺}⎕NUNTIE ⍵ ⎕NTIE 0} 17 | 18 | :If exists(r←{⍵,('/'≠¯1↑⍵)/'/'}{(-'\'=¯1↑⍵)↓⍵}TestCertificates),file 19 | :ElseIf exists(r←'/TestCertificates/',⍨ws←droptail ⎕WSID),file 20 | :ElseIf exists(r←'/TestCertificates/',⍨ws←droptail ws),file 21 | :ElseIf exists(r←'../TestCertificates/'),file 22 | :ElseIf exists(r←'/TestCertificates/',⍨droptail 2 ⎕NQ'.' 'GetEnvironment' 'Dyalog'),file 23 | :Else 24 | ('Unable to locate file ',file)⎕SIGNAL 22 25 | :EndIf 26 | ∇ 27 | 28 | ∇ cert←ReadCert relfilename;certpath;fn 29 | ss←{⎕ML←1 ⍝ Approx alternative to xutils' ss. 30 | srce find repl←,¨⍵ ⍝ source, find and replace vectors. 31 | mask←find⍷srce ⍝ mask of matching strings. 32 | prem←(⍴find)↑1 ⍝ leading pre-mask. 33 | cvex←(prem,mask)⊂find,srce ⍝ partitioned at find points. 34 | (⍴repl)↓∊{repl,(⍴find)↓⍵}¨cvex ⍝ collected with replacements. 35 | } 36 | certpath←CertPath 37 | fn←certpath,relfilename,'-cert.pem' 38 | cert←⊃##.DRC.X509Cert.ReadCertFromFile fn 39 | cert.KeyOrigin←{(1⊃⍵)(ss(2⊃⍵)'-cert' '-key')}cert.CertOrigin 40 | ∇ 41 | 42 | ss←{⎕ML←1 ⍝ Approx alternative to xutils' ss. 43 | srce find repl←,¨⍵ ⍝ source, find and replace vectors. 44 | mask←find⍷srce ⍝ mask of matching strings. 45 | prem←(⍴find)↑1 ⍝ leading pre-mask. 46 | cvex←(prem,mask)⊂find,srce ⍝ partitioned at find points. 47 | (⍴repl)↓∊{repl,(⍴find)↓⍵}¨cvex ⍝ collected with replacements. 48 | } 49 | 50 | :EndNamespace -------------------------------------------------------------------------------- /Sources/WebServices.dyalog: -------------------------------------------------------------------------------- 1 | :Namespace WebServices 2 | ⍝ === VARIABLES === 3 | 4 | NL←(⎕ucs 13 10) 5 | 6 | 7 | ⍝ === End of variables definition === 8 | 9 | (⎕IO ⎕ML ⎕WX)←1 0 3 10 | 11 | ∇ lu←LU 12 | lu←'abcdefghijklmnopqrstuvwxyzàáâãåèéêëòóôõöøùúûäæü' 'ABCDEFGHIJKLMNOPQRSTUVWXYZÀÁÂÃÅÈÉÊËÒÓÔÕÖØÙÚÛÄÆÜ' 13 | ∇ 14 | 15 | beginsWith←{0∊l←⍴w←,⍵:1 16 | (l↑⍺)≡noCase w} 17 | 18 | ∇ r←extractXML(data method result);emsg;xml;rc;xmlmat 19 | ⍝ extracts XML result from the output message for a method 20 | rc←1 ⋄ xmlmat←0 5⍴⊂⍬ ⋄ emsg←'' 21 | :If 0≠⊃data 22 | emsg←'Invalid request' 23 | :ElseIf method≢2 1⊃data 24 | emsg←'Method not found' 25 | :ElseIf 0∊⍴xml←(2 2⊃data)getelement result 26 | emsg←'Result not found' 27 | :Else 28 | :Trap 0 29 | xmlmat←⎕XML xml 30 | rc←0 ⍝ success! 31 | :Else 32 | emsg←'Error pasring XML' 33 | :EndTrap 34 | :EndIf 35 | r←rc xmlmat emsg 36 | ∇ 37 | 38 | getelement←{(⍺[;2]⍳⊂⍵)⊃⍺[;3],⊂''} 39 | 40 | ∇ r←xml gettag arg;⎕ML;element;kids;attrs;gotattrs;mask;kidmask 41 | ⍝ returns tag(s) matching arg 42 | ⍝ arg[1] - tag name to match 43 | ⍝ arg[2] - Boolean indicating whether to include child tags (default - 0) 44 | ⍝ arg[3] - attribute name/value pairs to match (default - none) 45 | ⍝ xml - 4 or 5 column ⎕XML matrix 46 | ⍝ r - vector of matching tags 47 | ⎕ML←1 48 | r←⍬ 49 | :If 1=≡arg ⋄ arg←,⊂arg ⋄ :EndIf ⍝ only tag name supplied? 50 | element kids attrs←3↑arg,(⍴arg)↓'' 0 '' 51 | :If gotattrs←~0∊⍴attrs ⍝ if attrs is not empty 52 | :If (2=≡attrs)∧(1=⍴⍴attrs)∧0=2|¯1↑⍴attrs ⋄ attrs←((0.5××/⍴attrs),2)⍴attrs ⍝ attrs is a vector of name/value pairs 53 | :ElseIf 3=≡attrs ⋄ attrs←↑attrs ⍝ attrs is a vector of nested name/value pairs (('name1' 'value1')('name2' 'value2')) 54 | :EndIf 55 | :EndIf 56 | :If ∨/mask←xml[;2]≡¨⊂element ⍝ find matching tag names 57 | :If gotattrs ⋄ mask←mask\(⊂attrs){∧/∨⌿(4⊃⍵)∧.≡⍉⍺}¨↓mask⌿xml ⋄ :EndIf ⍝ if attributes, match all supplied 58 | :If kids ⋄ mask←(mask/⍳⍴mask){(-⍴⍵)↑1,∧\(⍺⊃⍵)<⍺↓⍵}¨⊂xml[;1] 59 | r←mask⌿¨⊂xml 60 | :Else ⋄ r←1⊂[1]mask⌿xml 61 | :EndIf 62 | :EndIf 63 | ∇ 64 | 65 | ∇ s←lCase s;b;⎕IO;i;n;l;u 66 | n←⍴↑l u←LU 67 | →(∨/b←n>i←u⍳s)↓⎕IO←0 68 | (b/s)←l[b/i] 69 | ∇ 70 | 71 | ∇ r←removetags xml 72 | r←'' 73 | :Trap 0 74 | r←¯2↓⊃,/(3⌷[2]⎕XML xml),¨⊂NL 75 | :Else 76 | :EndTrap 77 | ∇ 78 | 79 | tonum←{⎕ML←1 ⋄ t←⍵ ⋄ z←(('-'=t)/t)←'¯' ⋄ ⊃(//)⎕VFI t} 80 | 81 | ∇ s←uCase s;b;⎕IO;i;n;l;u 82 | n←⍴↑l u←LU 83 | →(∨/b←n>i←l⍳s)↓⎕IO←0 84 | (b/s)←u[b/i] 85 | ∇ 86 | 87 | noCase←{(lCase ⍺)⍺⍺ lCase ⍵} 88 | :EndNamespace -------------------------------------------------------------------------------- /Sources/BuildCertDir.dyalog: -------------------------------------------------------------------------------- 1 | :Namespace BuildCertDir 2 | 3 | base64←{⎕IO ⎕ML←0 1 ⍝ Base64 encoding and decoding as used in MIME. 4 | 5 | chars←'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/' 6 | bits←{,⍉(⍺⍴2)⊤⍵} ⍝ encode each element of ⍵ in ⍺ bits, 7 | ⍝ and catenate them all together 8 | part←{((⍴⍵)⍴⍺↑1)⊂⍵} ⍝ partition ⍵ into chunks of length ⍺ 9 | 10 | 0=2|⎕DR ⍵:2∘⊥∘(8∘↑)¨8 part{(-8|⍴⍵)↓⍵}6 bits{(⍵≠64)/⍵}chars⍳⍵ 11 | ⍝ decode a string into octets 12 | 13 | four←{ ⍝ use 4 characters to encode either 14 | 8=⍴⍵:'=='∇ ⍵,0 0 0 0 ⍝ 1, 15 | 16=⍴⍵:'='∇ ⍵,0 0 ⍝ 2 16 | chars[2∘⊥¨6 part ⍵],⍺ ⍝ or 3 octets of input 17 | } 18 | cats←⊃∘(,/)∘((⊂'')∘,) ⍝ catenate zero or more strings 19 | cats''∘four¨24 part 8 bits ⍵ 20 | } 21 | 22 | split←{1↓¨(⍺=⍺,⍵)⊂⍺,⍵} 23 | 24 | ∇ r←CopyCertificationChainFromStore(cert path);trustroot;trustca;rix;iix;⎕IO;foundroot;current 25 | ⍝ Follow certificate chain from "cert" until a root certificate is found, 26 | ⍝ Writing CER files for each cert in chain to "path" 27 | 28 | ⎕IO←1 29 | 30 | trustroot←#.DRC.X509Cert.ReadCertFromStore'root' 31 | trustca←#.DRC.X509Cert.ReadCertFromStore'CA' 32 | r←,current←cert 33 | 34 | :Repeat 35 | :If foundroot←(⍴trustroot)≥rix←trustroot.Formatted.Subject⍳⊂current.Formatted.Issuer 36 | ⍝ we have found the root cert 37 | (current←rix⊃trustroot)SaveAsCER path 38 | 39 | :ElseIf (⍴trustca)≥iix←trustca.Formatted.Subject⍳⊂current.Formatted.Issuer 40 | ⍝ we have found an intermediate cert 41 | (current←iix⊃trustca)SaveAsCER path 42 | :Else 43 | 'Unable to reach a root certificate'⎕SIGNAL 999 44 | :EndIf 45 | r,←⊂current 46 | 47 | :Until foundroot 48 | ∇ 49 | 50 | ∇ r←items GetDN DN;secs 51 | secs←'='split¨','split DN 52 | r←2⊃¨(secs,⊂'' '')[(1⊃¨secs)⍳items] 53 | ∇ 54 | 55 | ∇ r←cert SaveAsCER path;data;tn;name;filename 56 | ⍝ Save a X509 certificate as a CER file 57 | 58 | name←⊃(⊂,'CN')GetDN cert.Formatted.Subject 59 | filename←path,name,'.cer' 60 | data←⊃,/('X509 CERTIFICATE'{pre←{'-----',⍺,' ',⍵,'-----'} ⋄ (⊂'BEGIN'pre ⍺),⍵,⊂'END'pre ⍺}↓64{s←(⌈(⍴⍵)÷⍺),⍺ ⋄ s⍴(×/s)↑⍵}base64 cert.Cert),¨⊂⎕UCS 10 13 61 | ⍝ remember to create the directory 62 | :Trap 22 ⋄ tn←filename ⎕NCREATE 0 63 | :Else ⋄ tn←filename ⎕NTIE 0 ⋄ 0 ⎕NRESIZE tn 64 | :EndTrap 65 | data ⎕NAPPEND tn 80 66 | ⎕NUNTIE tn 67 | ∇ 68 | 69 | 70 | ∇ dir BuildCertChain url;server;port;r;pc;primary 71 | ⍝ dir - the folder in which to save the server's public certificate chain 72 | ⍝ url - the URL:port for the server (do not prepend http://) 73 | 'DRC'⎕CY'conga' 74 | {}DRC.Init'' 75 | server port←2↑'' '443'{⍵,(⍴⍵)↓⍺}':'split url 76 | :Trap 0 77 | #.Files.MkDir dir 78 | 'Unable to find or create folder'⎕SIGNAL(~#.Files.DirExists dir)/22 79 | :Else 80 | ↑⎕DM 81 | →0 82 | :EndTrap 83 | port←2⊃⎕VFI⍕port 84 | ⍝ this should give us a secure connection to the server but 32 means that the server certificate is not validated 85 | {}DRC.Clt'C1'server port('X509'(⎕NEW DRC.X509Cert))('SSLValidation' 32) 86 | ⍝ get the server certificate 87 | r←DRC.GetProp'C1' 'PeerCert' 88 | primary←1⊃2⊃r ⍝ lets take the first of the two certificates 89 | pc←⊃⌽primary.Chain 90 | ⍝ Close connection 91 | {}DRC.Close'C1' 92 | CopyCertificationChainFromStore pc dir 93 | 94 | ⎕←'Remember to provide "',dir,'" as the RootCertPath argument.' 95 | ∇ 96 | 97 | :EndNamespace -------------------------------------------------------------------------------- /Sources/WebServiceSamples/MyWebService.dyalog: -------------------------------------------------------------------------------- 1 | :Namespace MyWebService 2 | ⍝ === VARIABLES === 3 | 4 | NL←(⎕ucs 13 10) 5 | 6 | 7 | ⍝ === End of variables definition === 8 | 9 | (⎕IO ⎕ML ⎕WX)←1 3 3 10 | 11 | ∇ r←AplExec arg;expr;rslt;noatt;mls;execspace 12 | expr←(arg[;2]⍳⊂'Expression')⊃arg[;3],⊂'' ⍝ Extract Name from argument 13 | expr←expr~NL 14 | noatt←0 2⍴⊂'' ⍝ We do not set any attributes 15 | mls←0 4⍴0 16 | mls⍪←1 '' ''noatt 17 | :If 0≠⍴expr 18 | 'execspace'⎕NS'' ⍝ execute expression in empty namespace 19 | :Trap 0 20 | rslt←⍕'execspace'⍎expr 21 | rslt←⊃,/(↓rslt),¨⊂NL 22 | mls[1;2 3]←'Result'rslt 23 | :Else 24 | mls[1;2 3]←'Error'(1⊃⎕DM) 25 | :EndTrap 26 | :EndIf 27 | r←1 mls 28 | ∇ 29 | 30 | ∇ api←BuildAPI;method;arg;result;single 31 | ⍝ Must return the API description for the webservice 32 | 33 | api←0⍴⊂'' ⍝ initialize the API (right argument to API2WSDL and enabler of constructing datatyped args/results) 34 | single←{(⊃('datatype'⍵)('minimum' 1)('maximum' 1))} 35 | 36 | ⍝ --- Regression --- 37 | method←1 4⍴1 'Regression' ''(1 2⍴'pattern' 2) 38 | 39 | result←arg←0 4⍴0 40 | 41 | arg⍪←1 'Data' ''(⊃('datatype' 'string')('minimum' 1)('maximum' 1)) 42 | arg⍪←1 'Degree' ''(⊃('datatype' 'integer')('minimum' 1)('maximum' 1)) 43 | 44 | result⍪←1 'RegResult' ''(1 2⍴'minimum' 0) 45 | result⍪←2 'Coeff0' ''(single'double') 46 | result⍪←2 'Coeff1' ''(single'double') 47 | result⍪←2 'Coeff2' ''(single'double') 48 | result⍪←2 'Residual' ''(single'double') 49 | api←api,⊂method arg result 50 | 51 | ⍝ Describe the method for Executing an APL expression 52 | method←1 4⍴1 'AplExec' ''(1 2⍴'pattern' 2) 53 | 54 | arg←1 4⍴1 'Expression' ''(⊃('datatype' 'string')('minimum' 1)('maximum' 1)) 55 | 56 | result←0 4⍴0 57 | result⍪←1 'Result' ''(⊃('datatype' 'string')('minimum' 1)('maximum' 1)) 58 | result⍪←1 'Error' ''(⊃('datatype' 'string')('minimum' 1)('maximum' 1)) 59 | 60 | api←api,⊂method arg result 61 | ∇ 62 | 63 | ∇ r←Regression arg;noatt;nums;result;getarg;degree;iLN 64 | ⍝ WebService Method to return statistics 65 | 66 | getarg←{(arg[;2]⍳⊂⍵)⊃arg[;3],⊂''} ⍝ Argument picker 67 | 68 | nums←tonum getarg'Data' ⍝ Extract Name from argument 69 | degree←⊃tonum⍕getarg'Degree' 70 | 71 | iLN←⎕NEW LinReg(nums degree) 72 | 73 | r←('Coeff0' 'Coeff1' 'Coeff2' 'Residual'),[1.5](3↑iLN.Coefficients),iLN.Residual 74 | 75 | noatt←0 2⍴⊂'' ⍝ All simple types 76 | result←1 4⍴1 'RegResult' ''noatt 77 | result⍪←2,r,⊂noatt 78 | 79 | r←1 result 80 | ∇ 81 | 82 | tonum←{↑(//)⎕VFI ⍵} 83 | 84 | :Class LinReg 85 | ⍝ Wrap regression "DSL" as a Class 86 | 87 | ⍝ --- Input Data --- 88 | :Field Public Degree←1 89 | :Field Public Data←⍬ 90 | :Field Public TempFolder←'c:\tmp\' ⍝ Where Charts will appear 91 | 92 | ⍝ --- Output --- 93 | :Field Public FX←⍬ 94 | :Field Public Coefficients←⍬ 95 | :Field Public Residual←0 96 | 97 | ⍝ --- Constructors 98 | 99 | ∇ LinReg0 ⍝ iLN←⎕NEW LinReg 100 | :Access Public 101 | :Implements Constructor 102 | ∇ 103 | 104 | ∇ LinReg1 data 105 | ⍝ iLN←⎕NEW LinReg (Data [Degree]) 106 | :Access Public 107 | :Implements Constructor 108 | :If (2=|≡data)∧2=⍴data ⋄ data Degree←data ⋄ :EndIf ⍝ Degree included? 109 | {}Fit data 110 | ∇ 111 | 112 | ⍝ --- Public Methods --- 113 | 114 | ∇ r←Regress 115 | :Access Public Instance 116 | Coefficients←Degree regress Data 117 | FX←(⍳⍴Data)evaluate Coefficients 118 | Residual←residual Data-FX 119 | ∇ 120 | 121 | ∇ r←Fit data 122 | :Access Public Instance 123 | Data←data ⋄ Regress ⋄ r←FX 124 | ∇ 125 | 126 | ∇ r←Chart title 127 | :Access Public Instance 128 | r←title rainplot Data FX 129 | ∇ 130 | 131 | ⍝ --- Private Methods --- 132 | avg←{+/⍵÷⍴⍵} 133 | residual←{avg (⍵-avg ⍵)*2} 134 | regress←{⍺←1 ⋄ ⍵⌹(⍳⍴⍵)∘.*0,⍳⍺} 135 | evaluate←{(⍺∘.*¯1+⍳⍴⍵)+.×⍵} 136 | 137 | :EndClass 138 | 139 | :EndNamespace -------------------------------------------------------------------------------- /Sources/HTTPUtils.dyalog: -------------------------------------------------------------------------------- 1 | :Namespace HTTPUtils 2 | ⍝ === VARIABLES === 3 | 4 | HTTPStatusCodes←40 2⍴100 'Continue' 101 'Switching Protocols' 200 'OK' 201 'Created' 202 'Accepted' 203 'Non-Authoritative Information' 204 'No Content' 205 'Reset Content' 206 'Partial Content' 300 'Multiple Choices' 301 'Moved Permanently' 302 'Found' 303 'See Other' 304 'Not Modified' 305 'Use Proxy' 307 'Temporary Redirect' 400 'Bad Request' 401 'Unauthorized' 402 'Payment Required' 403 'Forbidden' 404 'Not Found' 405 'Method Not Allowed' 406 'Not Acceptable' 407 'Proxy Authorization Required' 408 'Request Timeout' 409 'Conflict' 410 'Gone' 411 'Length Required' 412 'Precondition Failed' 413 'Request Entity Too Large' 414 'Request-URI Too Long' 415 'Unsupported Media Type' 416 'Requested Range Not Satisfiable' 417 'Expectation Failed' 500 'Internal Server Area' 501 'Not Implemented' 502 'Bad Gateway' 503 'Service Unavailable' 504 'Gateway Timeout' 505 'HTTP Version Not Supported' 5 | 6 | NL←(⎕ucs 13 10) 7 | 8 | 9 | ⍝ === End of variables definition === 10 | 11 | (⎕IO ⎕ML ⎕WX)←1 0 3 12 | 13 | ∇ HTTPCmd←DecodeCmd req;buf;input;args;z 14 | ⍝ Decode an HTTP command line: get /page&arg1=x&arg2=y 15 | ⍝ Return namespace containing: 16 | ⍝ Command: HTTP Command ('get' or 'post') 17 | ⍝ Headers: HTTP Headers as 2 column matrix or name/value pairs 18 | ⍝ Page: Requested page 19 | ⍝ Arguments: Arguments to the command (cmd?arg1=value1&arg2=value2) as 2 column matrix of name/value pairs 20 | 21 | input←1⊃,req←2⊃##.HTTPUtils.DecodeHeader req 22 | 'HTTPCmd'⎕NS'' ⍝ Make empty namespace 23 | HTTPCmd.Input←input 24 | HTTPCmd.Headers←{(0≠⊃∘⍴¨⍵[;1])⌿⍵}1 0↓req 25 | HTTPCmd.Command buf←' 'split input 26 | buf z←'http/'split buf 27 | HTTPCmd.Page args←'?'split buf 28 | HTTPCmd.Arguments←(args∨.≠' ')⌿↑'='∘split¨{1↓¨(⍵='&')⊂⍵}'&',args ⍝ Cut on '&' 29 | ∇ 30 | 31 | ∇ r←DecodeHeader buf;len;d 32 | ⍝ Decode HTML Header 33 | 34 | len←(¯1+⍴NL,NL)+⊃{((NL,NL)⍷⍵)/⍳⍴⍵}buf 35 | :If len>0 36 | d←(⍴NL)↓¨{(NL⍷⍵)⊂⍵}NL,len↑buf 37 | d←↑':'∘split¨d 38 | d[;1]←lc¨d[;1] 39 | :Else 40 | d←⍬ 41 | :EndIf 42 | r←len d 43 | ∇ 44 | 45 | ∇ code←Encode strg;raw;rows;cols;mat;alph 46 | ⍝ Base64 Encode 47 | raw←⊃,/11∘⎕DR¨strg 48 | cols←6 49 | rows←⌈(⊃⍴raw)÷cols 50 | mat←rows cols⍴(rows×cols)↑raw 51 | alph←'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 52 | alph,←'abcdefghijklmnopqrstuvwxyz' 53 | alph,←'0123456789+/' 54 | code←alph[⎕IO+2⊥⍉mat],(4|-rows)⍴'=' 55 | ∇ 56 | 57 | ∇ r←header GetValue(name type);i;h 58 | ⍝ Extract value from HTTP Header structure returned by DecodeHeader 59 | 60 | :If (1↑⍴header)'),¨r,¨⊂'' ⍝ enclose cells to make rows 103 | r←⊃,/(⊂''),¨r,¨⊂'',NL ⍝ enclose table rows 104 | r←'',r,'
' 105 | ∇ 106 | 107 | ∇ r←lc x;t 108 | t←⎕AV ⋄ t[⎕AV⍳⎕A]←'abcdefghijklmnopqrstuvwxyz' 109 | r←t[⎕AV⍳x] 110 | ∇ 111 | 112 | split←{p←(⍺⍷⍵)⍳1 ⋄ ((p-1)↑⍵)((p+(⍴,⍺)-⎕IO)↓⍵)} 113 | 114 | spliton←{⎕ML←0 ⋄ b←m←⍵⍷⍺ ⋄ b[⎕IO]←1 ⋄ ((b/m)×⍴,⍵)↓¨b⊂⍺} 115 | 116 | :EndNamespace -------------------------------------------------------------------------------- /Sources/WebServiceSamples/ClientSample.dyalog: -------------------------------------------------------------------------------- 1 | :Namespace ClientSample 2 | (⎕IO ⎕ML ⎕WX)←1 0 3 3 | 4 | :Class WWWeather: 'Form' 5 | ⎕io ⎕ml←1 6 | 7 | :field Countries ⍝ list of countries 8 | :field Cities ⍝ [;1] index into Countries [;2] city name 9 | :field lcCountries ⍝ lower case countries (so we don't have to convert every time we do lookup) 10 | :field public Available←0 ⍝ used to indicate if service is available 11 | :field public g ⍝ grid is public so that its data can be used by calling environment 12 | 13 | lc←{tt←⎕AV ⋄ tt[tt⍳⎕A]←'abcdefghijklmnopqrstuvwxyz' ⋄ tt[⎕av⍳⍵]} ⍝ lowercase 14 | grade←{⎕av⍋↑lc¨ ⍵} ⍝ case insensitive grade up 15 | match←{((⍴⍵)↑¨⍺)⍳⊂lc ⍵} ⍝ case insensitive match 16 | 17 | ∇ r←GetCities;method;z;data;cities;countrymask;xml;countries;ucountries 18 | ⍝ Get all countries/cities 19 | ⍝ r[1] - list of unique countries 20 | ⍝ r[2] - matrix of [;1] index into country list [;2] city name 21 | ⍝ 22 | ⍝ See: http://www.webservicex.net/globalweather.asmx?WSDL for WSDL description 23 | :Access Public 24 | r←⍬ ⍝ initialize result 25 | method←'GetCitiesByCountry' 26 | z←'www.webserviceX.NET' 80 'globalweather.asmx'#.SAWS.Call''method('CountryName' '') ⍝ make Web Service call 27 | :If 0=1⊃z ⍝ ok return code? 28 | :If method≡2 1⊃z 29 | data←,2 2⊃z 30 | :If 'GetCitiesByCountryResult'≡2⊃data ⍝ got a result? 31 | xml←⎕XML 3⊃data ⍝ convert the xml into APL 32 | countrymask←xml[;2]≡¨⊂'Country' ⍝ find the country elements 33 | countries←countrymask⌿xml[;3] 34 | cities←(¯1↓0,countrymask)⌿xml[;3] ⍝ city elements follow country elements 35 | ucountries←∪countries ⍝ unique countries 36 | ucountries←ucountries[grade ucountries] 37 | cities←(ucountries⍳countries),⍪cities 38 | cities←cities[grade cities[;2];] 39 | r←ucountries cities 40 | :EndIf 41 | :EndIf 42 | :EndIf 43 | ∇ 44 | 45 | ∇ r←GetWeatherInfo(Country City);z;method;data;xml 46 | ⍝ Gets Weather Information for Country/City 47 | ⍝ Country - country name 48 | ⍝ City - city name (full or partial) 49 | ⍝ r - [;1] element name [;2] element value 50 | ⍝ because data reported by this web service varies from location to location, we just return what we get 51 | :Access Public 52 | method←'GetWeather' 53 | z←'www.webserviceX.NET' 80 'globalweather.asmx'#.SAWS.Call''method(('CityName'City)('CountryName'Country)) 54 | r←1 2⍴'Status' 'Could not retrieve data' 55 | :If 0=1⊃z ⍝ ok return code? 56 | :If method≡2 1⊃z ⍝ method name match? 57 | data←,2 2⊃z ⍝ grab the data 58 | :If 'GetWeatherResult'≡2⊃data ⍝ result? 59 | :If '{Not }Found 70 | ⍝ name 71 | ⍝ quantity 72 | ⍝ price 73 | ⍝ 74 | name←(arg[;2]⍳⊂'ItemName')⊃arg[;3],⊂'' ⍝ get the ItemName element 75 | ind←DataBase[;1]⍳⊂name ⍝ look the name up 76 | resp←'ItemName' 'ItemQty' 'ItemPrice',[1.5](DataBase⍪name ⍬ ⍬)[ind;] ⍝ look up item information 77 | noatt←0 2⍴⊂'' ⍝ no attributes 78 | result←1 4⍴1 'ItemInfo'('Not Found'↓⍨4×ind≤⍬⍴⍴DataBase)noatt ⍝ ItemInfo level 79 | result⍪←2,resp,⊂noatt ⍝ item details 80 | r←1 result 81 | ∇ 82 | 83 | ∇ r←ListItems arg;result;noatt;mask;search 84 | ⍝ Implements the ListItems method for the PriceCheck web service 85 | ⍝ arg - 1 row MLS with string to filter items with 86 | ⍝ r[1] - 1 (indicates r[2] is an MLS) 87 | ⍝ r[2] - MLS containing the result 88 | ⍝ [;1] - depth of nesting (origin 1) 89 | ⍝ [;2] - element name 90 | ⍝ [;3] - element value 91 | ⍝ [;4] - 2 column attribute name/value pairs 92 | ⍝ The result represents a 2 level nested structure of 93 | ⍝ ItemList which contains 0 or more ItemNames 94 | ⍝ equivalent to the XML: 95 | ⍝ 96 | ⍝ First Item Name 97 | ⍝ Second Item Name 98 | ⍝ ... 99 | ⍝ 100 | noatt←0 2⍴⊂'' ⍝ no attributes 101 | result←1 4⍴1 'ItemList' ''noatt ⍝ build the ItemList Level 102 | search←arg #.WebServices.getelement'BeginsWith' 103 | mask←DataBase[;1]#.WebServices.beginsWith¨⊂search 104 | result⍪←2,(⊂'ItemName'),(mask⌿DataBase[;,1]),⊂noatt ⍝ Add the ItemNames from the database 105 | r←1 result 106 | ∇ 107 | 108 | ∇ r←OrderItem arg;ind;name;qty;price;resp;result;onhand 109 | ⍝ Implements the OrderItem method for the PriceCheck web service 110 | result←0 3⍴0 111 | name←arg #.WebServices.getelement'ItemName' ⍝ get the ItemName element 112 | result⍪←1 'OrderInfo' '' 113 | result⍪←2 'ItemName'name 114 | ind←DataBase[;1]⍳⊂name ⍝ look the name up 115 | :If ind≤''⍴⍴DataBase ⍝ item found? 116 | :If ''≢qty←arg #.WebServices.getelement'Qty' 117 | qty←#.WebServices.tonum qty 118 | result⍪←2 'OrderQty'qty 119 | :If qty≤onhand←DataBase[ind;2] 120 | result⍪←2 'OrderStatus' 'Complete' 121 | result⍪←2 'OrderTotal'(qty×(ind,3)⌷DataBase) 122 | :Else 123 | result⍪←2 'OrderStatus' 'Not Processed' 124 | result⍪←2 'Message'(⍕'Only'onhand'available') 125 | :EndIf 126 | :Else 127 | result⍪←2 'OrderStatus' 'Not Processed' 128 | result⍪←2 'Message'('Order quantity not specified') 129 | :EndIf 130 | :Else ⍝ item not found 131 | result⍪←2 'OrderStatus' 'Not Processed' 132 | result⍪←2 'Message'('Item not found') 133 | :EndIf 134 | result,←⊂0 2⍴⊂''⍝ no attributes for any elements 135 | r←1 result 136 | ∇ 137 | 138 | :EndNamespace -------------------------------------------------------------------------------- /Sources/WebServer.dyalog: -------------------------------------------------------------------------------- 1 | :Namespace WebServer 2 | ⍝ === VARIABLES === 3 | 4 | HOME←'' 5 | 6 | NL←(⎕ucs 13 10) 7 | 8 | stop←1 9 | 10 | 11 | ⍝ === End of variables definition === 12 | 13 | (⎕IO ⎕ML ⎕WX)←1 0 3 14 | 15 | ∇ z←FromRaw z;⎕IO 16 | :If 82=⊃⎕DR' ' 17 | ⎕IO←0 18 | z←⎕AV[(⎕NXLATE 0)⍳8 uns z] 19 | :Else 20 | z←⎕UCS 8 uns z ⍝ 8-but unsigned integers 21 | :EndIf 22 | ∇ 23 | 24 | ∇ r←GetAnswer(CMD BUF);URL;I;Status;Content 25 | ⍝ Default file handler. 26 | ⍝ Needs to return: 27 | ⍝ [1] - (charvec) HTTP status code. This can be 0 to just mean standard success. 28 | ⍝ [2] - (charvec) Additional HTTP headers. If none, just set to ''. 29 | ⍝ [3] - (charvec) HTTP content. If none, just set to ''. 30 | :If (⊂##.HTTPUtils.lc(I←CMD⍳' ')↑CMD)∊'get ' 'post ' 31 | URL←I↓CMD 32 | URL←(¯1+URL⍳' ')↑URL 33 | :If 'http:'≡##.HTTPUtils.lc 5↑URL ⍝ Drop leading server address 34 | URL←(¯1+(+\'/'=URL)⍳3)↓URL 35 | :EndIf 36 | URL←('/'=1↑URL)↓URL 37 | :If 0=⍴Content←GetFile HOME,URL,(0=⍴URL)/'index.htm' 38 | Status←'404 File Not Found' 39 | :Else 40 | Status←0 41 | :EndIf 42 | :Else 43 | Status←'500 Invalid command: ',CMD ⋄ Content←'' 44 | :EndIf 45 | r←Status''Content 46 | ∇ 47 | 48 | ∇ R←GetFile NAME 49 | :Trap 0 50 | NAME ⎕NTIE ¯1 51 | R←⎕NREAD ¯1(⎕DR'A'),2↑⎕NSIZE ¯1 52 | ⎕NUNTIE ¯1 53 | :Else 54 | R←'' 55 | :EndTrap 56 | ∇ 57 | 58 | ∇ ns HandleRequest arg;FindFirst;obj;buf;pos;I;z;hdr;req;CMD;status;content;rarg;Answer;conns;eoh 59 | ⍝ Handle a Web Server Request 60 | 61 | FindFirst←{(⍺⍷⍵)⍳1} 62 | conns←⍎ns ⍝ get a reference to the namespace for the connection 63 | obj buf←arg 64 | buf←FromRaw buf 65 | 66 | :If 0=conns.⎕NC'Buffer' 67 | conns.Buffer←⍬ 68 | :EndIf 69 | conns.Buffer,←buf 70 | conns.Handler←{6::conns.Handler←''≡5↑conns.Buffer ⋄ conns.Handler}⍬ ⍝ are we serving as a mapping handler? 71 | eoh←(1+conns.Handler)⊃(NL,NL)('') ⍝ end of header marker 72 | pos←(¯1+⍴eoh)+eoh FindFirst conns.Buffer 73 | 74 | :If pos>⍴conns.Buffer ⍝ Have we got everything ? 75 | :Return 76 | :ElseIf pos>I←(z←NL[2],'content-length:')FindFirst hdr←##.HTTPUtils.lc pos↑conns.Buffer 77 | :AndIf (⍴conns.Buffer) go back for more 79 | :EndIf 80 | 81 | :If conns.Handler ⍝ if we're running as a mapping handler 82 | (req conns.Buffer)←MakeHTTPRequest conns.Buffer ⍝ fake MiServer out by building an HTTP request from what we've got 83 | :Else 84 | req←pos↑conns.Buffer 85 | conns.Buffer←pos↓conns.Buffer 86 | :EndIf 87 | 88 | 89 | 90 | CMD←(¯1+req⍳NL[1])↑req 91 | 92 | ⍝ The function called is reponsible for returning: 93 | ⍝ [1] - (charvec) HTTP status code. This can be 0 to just mean standard success. 94 | ⍝ [2] - (charvec) Additional HTTP headers. If none, just set to ''. 95 | ⍝ [3] - (charvec) HTTP content. If none, just set to ''. 96 | 97 | :Trap 0/0 ⍝ be sure to cover any problems during ⍎ and cover a possibly-bogus result from it 98 | (status hdr content)←⍎HOME,' (cmd←##.HTTPUtils.DecodeCmd req) conns' 99 | :Else 100 | ##.SAWS_Error←⎕TS ⎕LC ⎕XSI ⎕DM 101 | (status hdr content)←'500 Internal Server Error' '' '' 102 | :EndTrap 103 | :If status≡'200 OK' ⋄ :AndIf 1∊'text/xml'⍷hdr ⋄ content←conns.Buffer ##.ResolveNamespaces content ⋄ :EndIf 104 | 105 | rarg←req conns.Buffer ⍝ ( is for HOME to utilize, e.g. HOME≡'##.SOAP.CongaSOAP rarg' 106 | :If 0≡status ⋄ status←'200 OK' ⋄ :EndIf 107 | :If 0≠⍴hdr ⋄ hdr←(-+/∧\(⌽hdr)∊NL)↓hdr ⋄ :EndIf 108 | :If ##.DEBUG ##.bit 2 ⋄ :AndIf 0<⍴##.AltResponse ⋄ content←##.AltResponse ⋄ :EndIf ⍝ if directed to substitute message, do so 109 | :If ##.DEBUG ##.bit 1 ⋄ ##.LastRunResponse←content ⋄ :EndIf ⍝ if directed to save last transaction, do so 110 | :If ##.TRACE ##.bit 0 111 | 1 ##.Output'>>> WebServer.HandleRequest <<<' 112 | 1 ##.Output'status: ',##.terse status~⎕UCS 10 113 | 1 ##.Output'hdr: ',##.terse hdr~⎕UCS 10 114 | 1 ##.Output'content: ',##.terse content~⎕UCS 10 115 | :EndIf 116 | 117 | Answer←((1+conns.Handler)⊃'HTTP/1.0 ' 'Status: '),status,NL,'Content-Length: ',(⍕⍴content),NL,hdr,NL,NL 118 | Answer←Answer,content 119 | 120 | Answer←ToRaw Answer 121 | :If ~0=1⊃z←##.DRC.Send obj Answer 1 ⍝ Send response and close connection 122 | ##.Output'Closed socket ',obj,' due to error: ',⍕z 123 | :EndIf 124 | {}⎕EX ns ⍝ erase the namespace after the connection is closed 125 | ∇ 126 | 127 | ∇ r←{path}HttpsRun arg;Common;cmd;name;port;wres;ref;nspc;sink;HOME;stop;certpath;flags;z;cert;secargs;secure;rc;objname;command;data 128 | ⍝ Ultra simple HTTPS (Web) Server 129 | ⍝ Assumes Conga available in ##.DRC 130 | 131 | :If 0=⎕NC'path' ⋄ certpath←##.Samples.CertPath,'ca' ⍝ if no certificate path specified, use sample 132 | :ElseIf 0∊⍴path ⋄ certpath←##.Samples.CertPath,'ca' ⍝ or if certificat path is empty, use sample 133 | :Else ⋄ certpath←path ⍝ otherwise use supplied path 134 | :EndIf 135 | certpath,←('/\'∊⍨¯1↑certpath)↓'/' 136 | 137 | {}##.DRC.Init'' 138 | HOME port name cert flags←5↑arg,(⍴arg)↓'' 445 'HTTPSRV'(⎕NEW ##.DRC.X509Cert)0 139 | secure←{0::0 ⋄ 1tsop<'⍷⌽req 193 | i←(⍴req)-i+5 194 | c←¯13↓(i+6)↓req 195 | req←(i↑req),'' 196 | :EndIf 197 | 198 | :Trap 11 199 | x←⎕XML req 200 | :Else 201 | ∘∘∘ 202 | :EndTrap 203 | v←'var'∘≡¨x[;2] 204 | v←↑{⎕ML←3 ⋄ (~<\'='=⍵)⊂⍵}¨v/x[;3] 205 | m l p s n q←v∘{3::2⊃⍵ ⋄ ⍺[;2]⊃⍨⍺[;1]⍳⊂1⊃⍵}¨↓'REQUEST_METHOD' 'CONTENT_LENGTH' 'PATH_INFO' 'SERVER_PROTOCOL' 'SERVER_NAME' 'QUERY_STRING',[1.1]'GET' '0' '' 'HTTP/1.0' 'localhost' '' 206 | l←⍕⍴c 207 | ⍝ p←p↓⍨¯5×'.saws'≡#.SAWS.HTTPUtils.lc ¯5↑p ⍝ drop off .saws 208 | r←(m,' ',p,((' '∨.≠q)/'?',q),' ',s,NL,'Host: ',n,NL,'Content-Length: ',l,NL,NL)c 209 | ∇ 210 | 211 | ∇ r←Run arg;HOME;port;name;Common;stop;rc;objname;command;data;nspc;wres 212 | ⍝ Ultra simple HTTP (Web) Server 213 | ⍝ Assumes Conga available in ##.DRC 214 | {}##.DRC.Init'' 215 | HOME port name←3↑arg,(⍴arg)↓'' 8080 'HTTPSRV' 216 | →(0≠1⊃r←##.DRC.Srv name''port'Raw' 10000)⍴0 ⍝ 217 | ##.Output'Web server ''',name,''' started on port ',⍕port 218 | ##.Output'Handling requests using ',HOME 219 | Common←⎕NS'' ⋄ stop←0 220 | :While ~stop 221 | wres←##.DRC.Wait name 10000 ⍝ Tick every 10 secs 222 | rc objname command data←4↑wres,(⍴wres)↓0 '' '' '' 223 | :Select rc 224 | :Case 0 ⍝ Good data from RPC.Wait 225 | :Select command 226 | :Case 'Error' 227 | :If name≡objname ⋄ stop←1 ⋄ :EndIf 228 | ##.Output'Error ',(⍕data),' on ',objname 229 | ⎕EX SpaceName objname 230 | :CaseList 'Block' 'BlockLast' 231 | :If 0=⎕NC nspc←SpaceName objname ⋄ nspc ⎕NS'' ⋄ :EndIf ⍝ create namespace for command 232 | :If 'BlockLast'≡command ⍝ if we got a blocklast, the connection has been closed... 233 | ⎕EX nspc ⍝ just cleanup the namespace 234 | :Else ⋄ r←nspc HandleRequest&objname data ⍝ Run page handler in new thread 235 | :EndIf 236 | :Case 'Connect' ⍝ Ignore 237 | :Else ⋄ ##.Output'Error ',⍕wres 238 | :EndSelect 239 | :Case 100 ⍝ Time out - put any "housekeeping" code here 240 | :Case 1010 ⍝ Object Not found 241 | ##.Output'Object ''',name,''' has been closed - Web Server shutting down' 242 | :Return 243 | :Else 244 | ##.Output'#.DRC.Wait failed:' 245 | ##.Output wres 246 | ∘ ⍝ intentional error 247 | :EndSelect 248 | :If 0<⎕NC'##.STOP' 249 | :If ##.STOP≡1 250 | stop←1 251 | :EndIf 252 | :EndIf 253 | :EndWhile 254 | {}##.DRC.Close name 255 | ##.Output'Web server ''',name,''' stopped ' 256 | ∇ 257 | 258 | ∇ r←SpaceName cmd 259 | ⍝ Generate namespace name from rpc command name 260 | r←'Common.C',Subst(2⊃{1↓¨('.'=⍵)⊂⍵}'.',cmd)'-=' '_∆' 261 | ∇ 262 | 263 | ∇ r←Subst arg;i;m;str;c;rep 264 | ⍝ Substictute character c in str with rep 265 | str c rep←arg 266 | i←c⍳str 267 | m←i≤⍴c 268 | (m/str)←rep[m/i] 269 | r←str 270 | ∇ 271 | 272 | ∇ r←TimeServer(CMD BUF);t 273 | ⍝ Example function for "RPC Server". 274 | 275 | ⍝ Needs to return: 276 | ⍝ [1] - (charvec) HTTP status code. This can be 0 to just mean standard success. 277 | ⍝ [2] - (charvec) Additional HTTP headers. If none, just set to ''. 278 | ⍝ [3] - (charvec) HTTP content. If none, just set to ''. 279 | 280 | :If (⊂##.HTTPUtils.lc CMD.Command)∊'get' 'post' 281 | t←,'ZI2,<:>,ZI2,<:>,ZI2'⎕FMT 1 3⍴3↓⎕TS 282 | r←0 ''('The time is ',t,' and you asked for the page:',CMD.Page) 283 | 284 | :Else 285 | r←('500 Invalid command: ',CMD.Command)'' '' 286 | :EndIf 287 | ∇ 288 | 289 | ∇ z←ToRaw z;⎕IO 290 | :If ⊃80≠⎕DR' ' 291 | ⎕IO←0 292 | z←(⎕NXLATE 0)[⎕AV⍳z] 293 | :Else 294 | z←8 int ⎕UCS z ⍝ 8-bit signed integers 295 | :EndIf 296 | ∇ 297 | 298 | int←{ ⍝ Signed from unsigned integer. 299 | ↑⍵{(⍺|⍵+⍺⍺)-⍵}/2*⍺-0 1 300 | } 301 | 302 | uns←{ ⍝ Unsigned from signed integer. 303 | (2*⍺)|⍵ 304 | } 305 | 306 | :EndNamespace -------------------------------------------------------------------------------- /Sources/Files.dyalog: -------------------------------------------------------------------------------- 1 | :Namespace Files 2 | 3 | ⍝ Provides cover functions for many file operations 4 | ⍝ Eventually all will be implemented for both Windows and *nix 5 | 6 | (⎕IO ⎕ML)←1 7 | 8 | ∇ r←text AppendText name;tn 9 | ⍝ Append text to existing file (must be single byte text) 10 | tn←name ⎕NTIE 0 11 | r←text ⎕NAPPEND tn(⎕DR' ') 12 | ⎕NUNTIE tn 13 | ∇ 14 | 15 | ∇ (tn name)←{ext}CreateTemp folder;cnt 16 | ⍝ Create a temp file 17 | ⍝ folder - folder to create temp file in 18 | ⍝ ext - file extension 19 | :If 0=⎕NC'ext' ⋄ ext←'tmp' ⋄ :EndIf 20 | :If 0∊⍴ext ⋄ ext←'tmp' ⋄ :EndIf 21 | cnt←tn←0 22 | :Repeat 23 | name←folder,('/\'∊⍨¯1↑folder)↓'/',⎕A[?8⍴⍴⎕A],'.',ext 24 | :Trap 22 ⋄ tn←name ⎕NCREATE 0 ⋄ :EndTrap 25 | cnt+←1 26 | :Until (cnt>20)∨tn≠0 27 | 'Unable to create temporary file'⎕SIGNAL tn↓22 28 | ∇ 29 | 30 | ∇ {protect}Copy FmTo;CopyFileX;GetLastError ⍝ Copy file Fm -> To 31 | :Select APLVersion 32 | :Case '*nix' 33 | ∘ 34 | :Case 'Win' 35 | :If 0=⎕NC'protect' ⍝ Copy fails if and 'To' exists. 36 | protect←0 ⍝ Default unprotected copy. 37 | :EndIf 38 | 'CopyFileX'⎕NA'I kernel32.C32∣CopyFile* <0T <0T I' 39 | :If 0=CopyFileX FmTo,protect 40 | ⎕NA'I4 kernel32.C32|GetLastError' 41 | 11 ⎕SIGNAL⍨'CopyFile error:',⍕GetLastError 42 | :EndIf 43 | :EndSelect 44 | ∇ 45 | 46 | ∇ Delete name;DeleteFileX;GetLastError;FindFirstFile;FindNextFile;FindClose;handle;rslt;ok;next;⎕IO;path 47 | ⎕IO←0 48 | :Select APLVersion 49 | :Case '*nix' 50 | _SH'rm ',unixfix name 51 | :Case 'Win' 52 | 'DeleteFileX'⎕NA'I kernel32.C32∣DeleteFile* <0T' 53 | ⎕NA'I4 kernel32.C32|GetLastError' 54 | :If ∨/'*?'∊name ⍝ wildcards? 55 | path←{(⌽∨\⌽⍵∊'\/')/⍵}name 56 | _FindDefine 57 | handle rslt←_FindFirstFile name 58 | :If 0=handle 59 | :Return ⍝ ('ntdir error:',⍕rslt)⎕SIGNAL 102 ⍝ file not found 60 | :EndIf 61 | :If '.'≠⊃6⊃rslt 62 | {}DeleteFileX⊂path,6⊃rslt 63 | :EndIf 64 | :While 1=0⊃ok next←_FindNextFile handle 65 | :If '.'≠⊃6⊃next 66 | {}DeleteFileX⊂path,6⊃next 67 | :EndIf 68 | :EndWhile 69 | :If 0 18∨.≠ok next 70 | ('ntdir error:',⍕next)⎕SIGNAL 11 ⍝ DOMAIN 71 | :EndIf 72 | {}FindClose handle 73 | :Else 74 | :If 0=DeleteFileX⊂name 75 | 11 ⎕SIGNAL⍨'DeleteFile error:',⍕GetLastError 76 | :EndIf 77 | :EndIf 78 | :EndSelect 79 | ∇ 80 | 81 | ∇ rslt←{amsk}Dir path;handle;next;ok;⎕IO;attrs;FindFirstFileX;FindNextFileX;FindClose;FileTimeToLocalFileTime;FileTimeToSystemTime;GetLastError 82 | ⍝ 'FIX ME'⎕SIGNAL 11 83 | ⍝ Amsk is a 32 element bool attribute mask. 84 | ⍝ Only files with attributes corresponding to 1-s in the mask will be returned. 85 | ⍝ '*'s mark default attribute mask. 86 | ⍝ 87 | ⍝ * [31] <=> READONLY 88 | ⍝ [30] <=> HIDDEN 89 | ⍝ * [29] <=> SYSTEM 90 | ⍝ [28] <=> undocumented 91 | ⍝ * [27] <=> DIRECTORY 92 | ⍝ * [26] <=> ARCHIVE 93 | ⍝ [25] <=> DEVICE 94 | ⍝ * [24] <=> NORMAL - only set if no other bits are set 95 | ⍝ * [23] <=> TEMPORARY 96 | ⍝ * [22] <=> SPARSE FILE 97 | ⍝ * [21] <=> REPARSE POINT 98 | ⍝ * [20] <=> COMPRESSED 99 | ⍝ * [19] <=> OFFLINE 100 | ⍝ * [18] <=> NOT CONTENT INDEXED 101 | ⍝ * [17] <=> ENCRYPTED 102 | ⍝ * rest <=> undocumented (but in the default set so that 103 | ⍝ Microsoft can extend them) 104 | ⍝ rslt is a vector of character vectors of filenames 105 | 106 | ⎕IO←0 107 | :Select APLVersion 108 | :Case '*nix' 109 | ∘ 110 | :Case 'Win' 111 | :If 0=⎕NC'amsk' 112 | amsk←~(⍳32)∊30 28 25 ⍝ Default attribute mask. 113 | :EndIf 114 | _FindDefine 115 | handle rslt←_FindFirstFile path 116 | :If 0=handle 117 | ('ntdir error:',⍕rslt)⎕SIGNAL 102 ⍝ file not found 118 | :EndIf 119 | rslt←,⊂rslt 120 | :While 1=0⊃ok next←_FindNextFile handle 121 | rslt,←⊂next 122 | :EndWhile 123 | :If 0 18∨.≠ok next 124 | ('ntdir error:',⍕next)⎕SIGNAL 11 ⍝ DOMAIN 125 | :EndIf 126 | ok←FindClose handle 127 | rslt←↓[0]↑rslt 128 | attrs←(32⍴2)⊤0⊃rslt ⍝ Get attributes into bits 129 | rslt←(amsk∧.≥attrs)⌿6⊃rslt ⍝ bin unwanted files and info 130 | :EndSelect 131 | ∇ 132 | 133 | ∇ r←DirExists path 134 | r←0 135 | :Select APLVersion 136 | :Case '*nix' 137 | :Trap 11 138 | r←0<⍴_SH'ls -adl ',unixfix path 139 | :EndTrap 140 | :Case 'Win' 141 | r←0<⍬⍴⍴'.'List path 142 | :EndSelect 143 | ∇ 144 | 145 | ∇ rslt←{amsk}DirX path;handle;next;ok;attrs;⎕IO;FindFirstFileX;FindNextFileX;FindClose;FileTimeToLocalFileTime;FileTimeToSystemTime;GetLastError 146 | ⍝ 'FIX ME'⎕SIGNAL 11 147 | ⍝ Amsk is a 32 element bool attribute mask. 148 | ⍝ Only files with attributes corresponding to 1-s in the mask will be returned. 149 | ⍝ Amsk defaults to all attributes. 150 | ⍝ 0⊃rslt <=> 32 column boolean matrix of attribute bits 151 | ⍝ [;31] <=> READONLY 152 | ⍝ [;30] <=> HIDDEN 153 | ⍝ [;29] <=> SYSTEM 154 | ⍝ [;28] <=> undocumented 155 | ⍝ [;27] <=> DIRECTORY 156 | ⍝ [;26] <=> ARCHIVE 157 | ⍝ [;25] <=> undocumented 158 | ⍝ [;24] <=> NORMAL - only set if no other bits are set 159 | ⍝ [;23] <=> TEMPORARY 160 | ⍝ [;22] <=> SPARSE FILE 161 | ⍝ [;21] <=> REPARSE POINT 162 | ⍝ [;20] <=> COMPRESSED 163 | ⍝ [;19] <=> OFFLINE 164 | ⍝ [;18] <=> NOT CONTENT INDEXED 165 | ⍝ [;17] <=> ENCRYPTED 166 | ⍝ rest <=> undocumented 167 | ⍝ 1⊃rslt <=> 7 column numeric matrix expressing the file creation time in ⎕TS format 168 | ⍝ if the file system does not support this then all columns are 0 169 | ⍝ 2⊃rslt <=> 7 column numeric matrix expressing the file last access time in ⎕TS format 170 | ⍝ if the file system does not support this then all columns are 0 171 | ⍝ 3⊃rslt <=> 7 column numeric matrix expressing the file last write time in ⎕TS format 172 | ⍝ 4⊃rslt <=> numeric vector giving the file size accurate up to 53 bits 173 | ⍝ 5⊃rslt <=> vector of character vectors giving the file names 174 | ⍝ 6⊃rslt <=> vector of character vectors giving the 8.3 file name for file systems 175 | ⍝ where it is appropriate and different from the file name 176 | ⎕IO←0 177 | :Select APLVersion 178 | :Case '*nix' 179 | ∘ 180 | :Case 'Win' 181 | :If 0=⎕NC'amsk' 182 | amsk←32⍴1 183 | :EndIf 184 | _FindDefine 185 | handle rslt←_FindFirstFile path 186 | :If 0=handle 187 | ('ntdir error:',⍕rslt)⎕SIGNAL 102 ⍝ file not found 188 | :EndIf 189 | rslt←,⊂rslt 190 | :While 1=0⊃ok next←_FindNextFile handle 191 | rslt,←⊂next 192 | :EndWhile 193 | :If 0 18∨.≠ok next 194 | ('ntdir error:',⍕next)⎕SIGNAL 11 ⍝ DOMAIN 195 | :EndIf 196 | ok←FindClose handle 197 | rslt←↓[0]↑rslt 198 | (0⊃rslt)←⍉attrs←(32⍴2)⊤0⊃rslt ⍝ Get attributes into bits 199 | rslt←(amsk∧.≥attrs)∘⌿¨rslt ⍝ bin unwanted files and info 200 | rslt[1 2 3]←↑¨_Filetime_to_TS¨¨rslt[1 2 3] ⍝ put times into ⎕ts format 201 | (4⊃rslt)←0(2*32)⊥⍉↑4⊃rslt ⍝ combine size elements 202 | rslt/⍨←5≠⍳8 ⍝ bin the reserved elements 203 | :EndSelect 204 | ∇ 205 | 206 | ∇ r←Exists name 207 | ⍝ Does file exist? 208 | r←1 209 | :Trap 22 210 | :Trap 19 ⍝ file access error means file exists 211 | ⎕NUNTIE(unixfix name)⎕NTIE 0 212 | :EndTrap 213 | :Else 214 | r←0 215 | :EndTrap 216 | ∇ 217 | 218 | ∇ r←GetCurrentDirectory;GCD;GetLastError 219 | ⍝ Get Current Directory 220 | :Select APLVersion 221 | :Case '*nix' 222 | r←⊃_SH'pwd' 223 | :Case 'Win' 224 | 'GCD'⎕NA'I kernel32.C32∣GetCurrentDirectory* I4 >0T' 225 | :If 0≠1⊃r←GCD 256 256 226 | r←2⊃r 227 | :Else 228 | ⎕NA'I4 kernel32.C32|GetLastError' 229 | 11 ⎕SIGNAL⍨'GetCurrentDirectory error:',⍕GetLastError 230 | :EndIf 231 | :EndSelect 232 | ∇ 233 | 234 | ∇ r←GetText name;tn 235 | ⍝ Read a text file as single byte text 236 | tn←(unixfix name)⎕NTIE 0 ⋄ r←⎕NREAD tn(⎕DR' ')(⎕NSIZE tn) ⋄ ⎕NUNTIE tn 237 | ∇ 238 | 239 | ∇ r←LikelyURL w 240 | →0↓⍨r←(⎕DR w)∊80 82 241 | r←{(0∊⍴⍵)<∧/⍵∊'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789%-._~:/?#[]@!$&''()*+,;='}w ⍝ identify likely URIs 242 | ∇ 243 | 244 | ∇ r←{file}List path;z;rslt;handle;next;ok;attrs;⎕IO;FindFirstFileX;FindNextFileX;FindClose;FileTimeToLocalFileTime;FileTimeToSystemTime;GetLastError;isFile;filter 245 | ⍝ Return matrix containing 246 | ⍝ [;0] Name [;1] Length [;2] LastAccessTime [;3] IsDirectory 247 | ⎕IO←0 248 | :If isFile←2=⎕NC'file' ⋄ filter←(0<⍴,file)/'/',file ⋄ :Else ⋄ filter←'/*' ⋄ :EndIf 249 | filter←('/\'∊⍨¯1↑path)↓filter 250 | r←0 4⍴'' 0 0 0 251 | 252 | :Select APLVersion 253 | :Case '*nix' 254 | →(0∊⍴rslt←1 _SH'ls -al --time-style=full-iso ',unixfix path,isFile/filter)⍴0 255 | rslt←↑rslt 256 | rslt←' ',('total '≡6⍴rslt)↓[0]rslt 257 | →(0=1↑⍴r←((1↑⍴rslt),4)⍴0)⍴0 258 | z←∧⌿' '=rslt ⍝ entirely blank columns 259 | z←z∧10>+\z ⍝ Do not split file names 260 | rslt←z⊂rslt 261 | r[;3]←'d'=(0⊃rslt)[;1] ⍝ IsDirectory 262 | r[;1]←(~r[;3])×1⊃⎕VFI,4⊃rslt ⍝ Size 263 | z←,(5⊃rslt),6⊃rslt ⋄ ((z∊'-:')/z)←' ' ⋄ z←((1↑⍴r),6)⍴1⊃⎕VFI z 264 | r[;2]←↓⌊z,1000×1|z[;5] ⍝ Add msec to Timestamp 265 | r[;0]←{(⌽~∨\⌽⍵='/')/⍵}¨{(-+/∧\' '=⌽⍵)↓¨↓⍵}0 1↓8⊃rslt ⍝ Name 266 | 267 | :Case 'Win' 268 | ⍝ See DirX for explanations of results of _FindNextFile etc 269 | _FindDefine 270 | handle rslt←_FindFirstFile path,filter 271 | :If 0=handle 272 | :Return ⍝ ('ntdir error:',⍕rslt)⎕SIGNAL 102 ⍝ file not found 273 | :EndIf 274 | rslt←,⊂rslt 275 | :While 1=0⊃ok next←_FindNextFile handle 276 | rslt,←⊂next 277 | :EndWhile 278 | :If 0 18∨.≠ok next 279 | ('ntdir error:',⍕next)⎕SIGNAL 11 ⍝ DOMAIN 280 | :EndIf 281 | ok←FindClose handle 282 | rslt←↓[0]↑rslt 283 | →(0=1↑⍴r←((1↑⍴0⊃rslt),4)⍴0)⍴0 284 | (0⊃rslt)←⍉attrs←(32⍴2)⊤0⊃rslt ⍝ Get attributes into bits 285 | r[;3]←(0⊃rslt)[;27] ⍝ IsDirectory? 286 | r[;1]←0(2*32)⊥⍉↑4⊃rslt ⍝ combine size elements 287 | r[;2]←_Filetime_to_TS¨3⊃rslt ⍝ As ⎕TS vector 288 | r[;0]←6⊃rslt ⍝ Name 289 | :EndSelect 290 | r←r[⍋↑r[;0];] 291 | ∇ 292 | 293 | ∇ MkDir path;CreateDirectory;GetLastError;err 294 | ⍝ Create a folder 295 | :If ~DirExists path 296 | :Select APLVersion 297 | :Case '*nix' 298 | 1 _SH'mkdir ',unixfix path 299 | ('mkdir error on ',path)⎕SIGNAL 11/⍨~DirExists path 300 | :Case 'Win' 301 | ⎕NA'I kernel32.C32∣CreateDirectory* <0T I4' ⍝ Try for best function 302 | →(0≠CreateDirectory path 0)⍴0 ⍝ 0 means "default security attributes" 303 | ⎕NA'I4 kernel32.C32|GetLastError' 304 | err ⎕SIGNAL⍨'CreateDirectory error:',⍕err←GetLastError 305 | :EndSelect 306 | :EndIf 307 | ∇ 308 | 309 | ∇ Move filenames;MoveFileX;MoveFileExA;GetLastError;err 310 | ⍝ Move (from to) - move/rename file 311 | :Select APLVersion 312 | :Case '*nix' 313 | ∘ 314 | :Case 'Win' 315 | ⎕NA'I kernel32.C32∣MoveFileEx* <0T <0T I4' ⍝ Try for best function 316 | :If 0≠MoveFileExA filenames,3 ⍝ REPLACE_EXISTING (1) + COPY_ALLOWED (2) 317 | :Return 318 | :EndIf 319 | ⎕NA'I4 kernel32.C32|GetLastError' 320 | :Select err←GetLastError 321 | :Case 120 ⍝ ERROR_CALL_NOT_IMPLIMENTED 322 | 'MoveFileX'⎕NA'I Kernel32.C32∣MoveFile* <0T <0T' ⍝ accept 2nd best - win 95 323 | :If 0≠MoveFileX filenames 324 | :Return 325 | :EndIf 326 | err←GetLastError 327 | :EndSelect 328 | 11 ⎕SIGNAL⍨'MoveFile error:',⍕err 329 | :EndSelect 330 | ∇ 331 | 332 | ∇ r←text PutText name;tn 333 | ⍝ Write text to file (must be single byte text) 334 | :Trap 0 335 | tn←name ⎕NCREATE 0 336 | :Else 337 | tn←name ⎕NTIE 0 338 | 0 ⎕NRESIZE tn 339 | :EndTrap 340 | 341 | r←text ⎕NAPPEND tn(⎕DR' ') 342 | ⎕NUNTIE tn 343 | ∇ 344 | 345 | ∇ RmDir path;RemoveDirectoryA;GetLastError 346 | ⍝ Remove folder/directory 347 | :Select APLVersion 348 | :Case '*nix' 349 | ∘ 350 | :Case 'Win' 351 | ⎕NA'I kernel32.C32∣RemoveDirectory* <0T' 352 | →(0≠RemoveDirectory,⊂path)⍴0 353 | ⎕NA'I4 kernel32.C32|GetLastError' 354 | 11 ⎕SIGNAL⍨'RemoveDirectory error:',⍕GetLastError 355 | :EndSelect 356 | ∇ 357 | 358 | ∇ SetCurrentDirectory path;SCD;GetLastError 359 | ⍝ Set Current Directory 360 | :Select APLVersion 361 | :Case '*nix' 362 | ∘ 363 | :Case 'Win' 364 | 'SCD'⎕NA'I kernel32.C32∣SetCurrentDirectory* <0T' 365 | →(0≠SCD,⊂path)⍴0 366 | ⎕NA'I4 kernel32.C32|GetLastError' 367 | 11 ⎕SIGNAL⍨'SetCurrentDirectory error:',⍕GetLastError 368 | :EndSelect 369 | ∇ 370 | 371 | ∇ r←{noext}SplitFilename filename;filesep;mask;path;file;ext 372 | ⍝ splits a filename into: path name ext 373 | noext←{6::0 ⋄ noext}'' 374 | filesep←(~IsWin)↓'\/' 375 | mask←⌽∨\⌽filename∊filesep 376 | path←mask/filename 377 | file←(~mask)/filename 378 | :If noext 379 | r←path file 380 | :Else 381 | mask←∨\⌽<\⌽'.'=file 382 | ext←mask/file 383 | file←(~mask)/file 384 | r←path file ext 385 | :EndIf 386 | ∇ 387 | 388 | 389 | :Section Windows 390 | ∇ rslt←_Filetime_to_TS filetime;⎕IO 391 | :If 1≠0⊃rslt←FileTimeToLocalFileTime filetime(⎕IO←0) 392 | :OrIf 1≠0⊃rslt←FileTimeToSystemTime(1⊃rslt)0 393 | rslt←0 0 ⍝ if either call failed then zero the time elements 394 | :EndIf 395 | rslt←1 1 0 1 1 1 1 1/1⊃rslt ⍝ remove day of week 396 | ∇ 397 | 398 | ∇ _FindDefine;WIN32_FIND_DATA 399 | WIN32_FIND_DATA←'{I4 {I4 I4} {I4 I4} {I4 I4} {U4 U4} {I4 I4} T[260] T[14]}' 400 | 'FindFirstFileX'⎕NA'I4 kernel32.C32|FindFirstFile* <0T >',WIN32_FIND_DATA 401 | 'FindNextFileX'⎕NA'U4 kernel32.C32|FindNextFile* I4 >',WIN32_FIND_DATA 402 | ⎕NA'kernel32.C32|FindClose I4' 403 | ⎕NA'I4 kernel32.C32|FileTimeToLocalFileTime <{I4 I4} >{I4 I4}' 404 | ⎕NA'I4 kernel32.C32|FileTimeToSystemTime <{I4 I4} >{I2 I2 I2 I2 I2 I2 I2 I2}' 405 | ⎕NA'I4 kernel32.C32∣GetLastError' 406 | ∇ 407 | 408 | ∇ rslt←_FindFirstFile name;⎕IO 409 | rslt←FindFirstFileX name(⎕IO←0) 410 | :If ¯1=0⊃rslt ⍝ INVALID_HANDLE_VALUE 411 | rslt←0 GetLastError 412 | :Else 413 | (1 6⊃rslt)_FindTrim←0 ⍝ shorten the file name at the null delimiter 414 | (1 7⊃rslt)_FindTrim←0 ⍝ and for the alternate name 415 | :EndIf 416 | ∇ 417 | 418 | ∇ rslt←_FindNextFile handle;⎕IO 419 | rslt←FindNextFileX handle(⎕IO←0) 420 | :If 1≠0⊃rslt 421 | rslt←0 GetLastError 422 | :Else 423 | (1 6⊃rslt)_FindTrim←0 ⍝ shorten the filename 424 | (1 7⊃rslt)_FindTrim←0 ⍝ shorten the alternate name 425 | :EndIf 426 | ∇ 427 | 428 | ∇ name←name _FindTrim ignored;⎕IO 429 | ⍝ Truncates a character vector at the null delimiting byte. 430 | ⍝ The null is not included in the result. 431 | ⎕IO←0 432 | name↑⍨←name⍳⎕UCS 0 433 | ∇ 434 | 435 | ∇ {r}←{suppress}_CMD cmd 436 | :If 0=⎕NC'suppress' ⋄ suppress←0 ⋄ :EndIf 437 | r←'' 438 | :Trap 0 439 | r←⎕CMD cmd 440 | :Else 441 | ('shell command failed: ',cmd)⎕SIGNAL 11/⍨~suppress 442 | :EndTrap 443 | ∇ 444 | 445 | ∇ r←IsWin 446 | r←'Win'≡APLVersion 447 | ∇ 448 | 449 | :endsection 450 | 451 | :section *nix 452 | ∇ {r}←{suppress}_SH cmd 453 | ⍝ SH cover to suppress any error messages 454 | ⍝ suppress will suppress error from being signaled 455 | :If 0=⎕NC'suppress' ⋄ suppress←0 ⋄ :EndIf 456 | r←'' 457 | :Trap 0 458 | r←⎕SH cmd,' 2>/dev/null' 459 | :Else 460 | ('shell command failed: ',cmd)⎕SIGNAL 11/⍨~suppress 461 | :EndTrap 462 | ∇ 463 | 464 | ∇ f←unixfix f 465 | ⍝ replaces Windows file separator \ with Unix file separator / 466 | ⍝ this approach is mindnumbingly simple and probably dangerous 467 | ⍝ which is why we call unixfix very cautiously 468 | :If '*nix'≡APLVersion ⋄ ((f='\')/f)←'/' ⋄ :EndIf 469 | ∇ 470 | 471 | ∇ r←APLVersion 472 | :Select 3↑⊃'.'⎕WG'APLVersion' 473 | :CaseList 'Lin' 'AIX' 'Sol' 474 | r←'*nix' 475 | :Case 'Win' 476 | r←'Win' 477 | :Else 478 | ... ⍝ unknown version 479 | :EndSelect 480 | ∇ 481 | :endsection 482 | 483 | ∇ r←a FREAD w;t 484 | t←w ⎕FSTIE 0 485 | r←⎕FREAD t a 486 | ⎕FUNTIE t 487 | ∇ 488 | :EndNamespace -------------------------------------------------------------------------------- /Sources/SAWS.dyalog: -------------------------------------------------------------------------------- 1 | :Namespace SAWS 2 | ⍝ === VARIABLES === 3 | 4 | URL←Service←LastCallRequest←LastCallResponse←AltResponse←AltRequest←LastRunRequest←LastRunResponse←'' 5 | SILENT←DEBUG←TRACE←0 6 | 7 | _←⍬ 8 | _,←,⊂'' '' 32 | STYLE←_ 33 | 34 | ⎕ex '_' 35 | 36 | ⍝ === End of variables definition === 37 | 38 | (⎕IO ⎕ML ⎕WX)←1 3 3 39 | 40 | ∇ r←larg Call rarg;service;method;arg;ok;cmd;port;req;hdr;z;page;protocol;host;lchost;req2send;mask;tmp;ss;http;body;resp;soapaction;xmlns;cert;secure;ssl;length;t;m;certdir;chunked;chunk;buffer;chunklength;done;data;datalen;header;wr;getchunklen;h2d;len 41 | ⍝ Invoke a Web Service 42 | 43 | ⍝ larg[1] - host name 44 | ⍝ larg[2] - port number (defaults to 80 for http, 443 for https) 45 | ⍝ larg[3] - page name (defaults to service name) 46 | ⍝ larg[4] - soapaction (if empty, we build a default value) 47 | ⍝ larg[5] - Client certificate OR 1 to run securely 48 | ⍝ larg[6] - SSLValidation flags (see Conga documentation) 49 | ⍝ larg[7] - Root certificate directory 50 | 51 | ⍝ rarg takes one of two forms: 52 | ⍝ 1) a simple character vector representing the entire SOAP over HTTP message; OR 53 | ⍝ 2) a 3 item nested vector containing: 54 | ⍝ [1] service - web service name 55 | ⍝ [2] method - web service method to execute 56 | ⍝ [3] arg which can take two forms: 57 | ⍝ 1) a simple character vector representing the entire SOAP message (we build the HTTP part); OR 58 | ⍝ 2) the arguments to the web service method in one of the following forms: 59 | ⍝ ('name' 'value' {'name2' 'value2' ... 'nameN' 'valueN'}) 60 | ⍝ (N,2)⍴'name' 'value' ... 'nameN' 'valueN' 61 | ⍝ (('name' 'value'){('name2' 'value2')...('nameN' 'valueN')}) 62 | ⍝ (N,3)⍴ level 'name' 'value' ... levelN 'nameN' 'valueN' 63 | 64 | ⍝ r[1] return code (0=no error, 1=SOAP Fault, 2=Conga Error, 3=HTTP Error, ¯1=could not understand request) 65 | ⍝ [2] details if an error, or the result of the SOAP call 66 | 67 | :If 0=⎕NC'DRC' ⋄ 'DRC'⎕CY'conga' ⋄ :EndIf 68 | 69 | :If 0≠1⊃z←DRC.Init'' ⋄ r←2 z ⍝ flag Conga error 70 | :GoTo exit 71 | :EndIf 72 | 73 | h2d←{⎕IO←0 ⋄ 16⊥'0123456789abcdef'⍳HTTPUtils.lc ⍵} ⍝ hex to decimal 74 | getchunklen←{¯1=len←¯1+1↑(NL⍷⍵)/⍳⍴⍵:¯1 ¯1 ⋄ chunklen←h2d len↑⍵ ⋄ (⍴⍵)>> SAWS.Call <<<' 137 | 1 Output'hdr= ',terse((~mask←∨\ss⍷req2send)/req2send)~⎕UCS 10 138 | 1 Output'req= ',terse tmp←(⍴ss)↓mask/req2send 139 | 1 Output'xml= ',terse ⎕XML ⎕XML tmp 140 | :EndIf 141 | 142 | ok cmd←2↑z←DRC.Clt''host port'Text',secure/('X509'cert)('SSLValidation'ssl) ⍝ Connect to server 143 | :If 0≠ok ⋄ r←2 z ⍝ flag Conga error 144 | :GoTo exit 145 | :EndIf 146 | 147 | :If 0≠1⊃z←DRC.Send cmd req2send 148 | r←2 z ⍝ Send it (flag Conga error, if any) 149 | :GoTo exit 150 | :EndIf 151 | 152 | resp←'' ⍝ initialize the response 153 | length←0 154 | chunked chunk buffer chunklength←0 '' '' 0 155 | done data datalen header←0 ⍬ 0(0 ⍬) 156 | :Repeat 157 | :If ~done←0≠1⊃wr←DRC.Wait cmd 5000 ⍝ Wait up to 5 secs 158 | :If wr[3]∊'Block' 'BlockLast' ⍝ If we got some data 159 | :If chunked 160 | chunk←4⊃wr 161 | :ElseIf 0<⍴data,←4⊃wr 162 | :AndIf 0=1⊃header 163 | header←HTTPUtils.DecodeHeader data 164 | :If 0<1⊃header 165 | data←(1⊃header)↓data 166 | :If chunked←∨/'chunked'⍷(2⊃header)HTTPUtils.GetValue'Transfer-Encoding' '' 167 | chunk←data 168 | data←'' 169 | :Else 170 | datalen←1⊃((2⊃header)HTTPUtils.GetValue'Content-Length' 'Numeric'),¯1 ⍝ ¯1 if no content length not specified 171 | :EndIf 172 | :EndIf 173 | :EndIf 174 | :Else 175 | r←2 wr ⍝ Error? 176 | {}DRC.Close cmd 177 | :GoTo exit 178 | :EndIf 179 | :If chunked 180 | buffer,←chunk 181 | :While done<¯1≠1⊃(len chunklength)←getchunklen buffer 182 | :If (⍴buffer)≥4+len+chunklength 183 | data,←chunklength↑(len+2)↓buffer 184 | buffer←(chunklength+len+4)↓buffer 185 | :If done←0=chunklength ⍝ chunked transfer can add headers at the end of the transmission 186 | header[2]←⊂(2⊃header)⍪2⊃HTTPUtils.DecodeHeader buffer 187 | :EndIf 188 | :EndIf 189 | :EndWhile 190 | :Else 191 | done←done∨'BlockLast'≡3⊃wr ⍝ Done if socket was closed 192 | :If datalen>0 193 | done←done∨datalen≤⍴data ⍝ ... or if declared amount of data rcvd 194 | :Else 195 | done←done∨':Envelope>'{⍺≡(-⍴⍺)↑⍵}data 196 | :EndIf 197 | :EndIf 198 | :EndIf 199 | :Until done 200 | resp←data 201 | ⍝ :Repeat 202 | ⍝ :If 0≠1⊃z←DRC.Wait cmd 5000 ⍝ Loop, collecting pieces of response 203 | ⍝ r←2 z ⍝ flag Conga error 204 | ⍝ {}DRC.Close cmd 205 | ⍝ :GoTo exit 206 | ⍝ :ElseIf z[3]∊'Block' 'BlockLast' 207 | ⍝ resp←resp,4⊃z 208 | ⍝ :Trap 0 209 | ⍝ :If length=0 210 | ⍝ :AndIf ∨/m←(NL,NL)⍷resp 211 | ⍝ :AndIf ~0∊⍴t←(2⊃HTTPUtils.DecodeHeader resp)HTTPUtils.GetValue'content-length' 'Numeric' 212 | ⍝ length←t+3+m⍳1 213 | ⍝ :EndIf 214 | ⍝ :EndTrap 215 | ⍝ :EndIf 216 | ⍝ :Until ('BlockLast'≡3⊃z)∨(length≤⍴resp)∨':Envelope>'{⍺≡(-⍴⍺)↑⍵}resp ⍝ Until error or all data received 217 | 218 | {}DRC.Close cmd 219 | :If DEBUG bit 1 ⋄ LastCallResponse←resp ⋄ :EndIf 220 | r←¯1 'Empty response from host' 221 | :If ~0∊⍴resp 222 | http←HTTPUtils.ParseHTTPResponse(resp(2⊃header)) ⍝ build http struct and split off body 223 | :If 200≠http.StatusCode 224 | r←3((http.(StatusCode Reason)),⊂resp) ⍝ flag HTTP error 225 | :GoTo exit 226 | :EndIf 227 | r←SOAP.DecodeResponse http.MessageBody ⍝ if no error 228 | r[1]←(0 1 ¯1,r[1])[1 0 ¯1⍳r[1]] ⍝ adjust result to return 0 for no error 229 | :EndIf 230 | exit: 231 | ∇ 232 | 233 | ∇ r←host DefineService arg;service;page;mask;ref;api;ns;expfns;pvm;wsdl;svcname;port;url 234 | ⍝ Builds the web service definition 235 | ⍝ host - host name and port, used to get the port for the service 236 | ⍝ 237 | ⍝ arg[1] - page name for the service 238 | ⍝ arg[2] - Service (namespace name or reference to namespace containing the service) 239 | ⍝ If arg[2]≡'', we search for a namespace matching the supplied page name 240 | ⍝ arg[3] - root URL for the service (in the form 'HTTP{S}://...') 241 | ⍝ 242 | ⍝ r[1] - return code (0-success, 1-failure) 243 | ⍝ r[2] - service definition (success), or '' (failure) 244 | ⍝ [1] API 245 | ⍝ [2] ExportedFns 246 | ⍝ [3] ServiceName 247 | ⍝ [4] WSDL 248 | ⍝ [5] namespace 249 | page service url←arg 250 | :If 'http'≢HTTPUtils.lc 4↑url ⋄ url←'http://',url ⋄ :EndIf 251 | :If 0∊⍴host ⋄ port←'80' ⍝ default to port 80 (HTTP) 252 | :Else ⋄ port←1↓(∨\':'=host)/host ⍝ otherwise try to extract port 253 | :If 0∊⍴port ⋄ port←'80' ⍝ if no port specificed, default to port 80 (HTTP) 254 | :EndIf 255 | :EndIf 256 | 257 | r←1 '' ⍝ initialize result 258 | 259 | :If ~0∊⍴service ⍝ if service namespace name supplied 260 | ns←service ⍝ use it 261 | :Else 262 | ns←MatchNamespace page ⍝ otherwise, try to find namespace matching the page name 263 | :EndIf 264 | 265 | :If ~0∊⍴ns 266 | mask←'API' 'ExportedFns' 'ServiceName' 'WSDL' 'BuildAPI'∊(ref←⍎ns).⎕NL ¯2 ¯3 267 | :If ∧/4↑mask ⍝ are all components defined? 268 | r←0((ref.(API ExportedFns ServiceName WSDL)),⊂ns) ⍝ use them 269 | :ElseIf mask[5] ⍝ do we have BuildAPI? 270 | svcname←ns~'#' ⋄ ((svcname='.')/svcname)←'/' ⋄ svcname←('/'=⍬⍴svcname)↓svcname 271 | api←ref.BuildAPI 272 | expfns←2⊃¨,¨1⊃¨api ⍝ exported functions based on the API 273 | pvm←0 2⍴⊂'' 274 | pvm←pvm⍪'name'svcname 275 | pvm←pvm⍪'serviceURL'(url,':',port,'/',svcname,'/') ⍝ where the SOAP method calls are actually sent to 276 | pvm←pvm⍪'wsdlURL'(url,':',port,'/',svcname,'?WSDL/') ⍝ location of the WSDL XML document 277 | wsdl←SOAP.PrepareWSDL api pvm ⍝ build the WSDL 278 | r←0(api expfns svcname wsdl ns) 279 | :EndIf 280 | :EndIf 281 | ∇ 282 | 283 | ∇ R←HandleRequest(cmd session);method;arg;ok;type;res;status;hdr;mpvm;TIME;buffer;name;ns;api;wsdl;expfns;WSDL;ServiceName;ExportedFns;API;rc;svc;ServiceNS;host;lcprefix 284 | ⍝ Web Service handler build for embedding in the Conga sample Web Server 285 | ⍝ Return HTTP return code, HTTP headers, HTTP body 286 | ⍝ buffer is ignored, entire input expected to be in "cmd" 287 | 288 | buffer←session.Buffer 289 | :If ~0∊⍴Prefix 290 | cmd.Page←(lcprefix←HTTPUtils.lc Prefix){⍵↓⍨(⍴⍺)×⍺≡(⍴⍺)↑HTTPUtils.lc ⍵}cmd.Page 291 | cmd.Input←lcprefix{0=i←1↑{⍵/⍳⍴⍵}⍺⍷HTTPUtils.lc ⍵:⍵ ⋄ (i↑⍵),(i+⍴⍺)↓⍵}cmd.Input 292 | :EndIf 293 | :If DEBUG bit 1 ⋄ LastRunRequest←buffer ⋄ :EndIf 294 | :If TRACE bit 0 295 | 1 Output'>>> SAWS.HandleRequest <<<' 296 | 1 Output'Command: ',terse(cmd.Command~⎕UCS 10) 297 | 1 Output'Page: ',terse(cmd.Page~⎕UCS 10) 298 | 1 Output'buffer: ',terse(buffer~⎕UCS 10) 299 | TIME←⎕AI[2] 300 | :EndIf 301 | 302 | host←cmd.Headers HTTPUtils.GetValue('host' '') ⍝ get the host name 303 | rc svc←host DefineService cmd.Page Service URL ⍝ build the service definition (Service and URL are defined in SAWS.Run) 304 | 305 | :If 0≠rc ⍝ failed to define service? 306 | type←¯1 ⋄ res←'Service.Invalid' 'The Web Service definition is not valid' 307 | status←'500 Internal Server Error' 308 | res←type SOAP.EncodeResponse res 309 | hdr←'content-type: text/xml' 310 | :Else 311 | API ExportedFns ServiceName WSDL ServiceNS←svc 312 | name←HTTPUtils.lc ServiceName 313 | 314 | :If ('get /',name,'?wsdl')≡(10+⍴name)↑cmd.Input ⋄ :AndIf ' /'∨.=1↑(10+⍴name)↓cmd.Input ⍝ Display WSDL? 315 | res←WSDL ⋄ status←'200 OK' 316 | hdr←'content-type: text/xml' 317 | :ElseIf ('get /',name)≡(5+⍴name)↑cmd.Input 318 | :OrIf (('post /',name,'/')≡(7+⍴name)↑cmd.Input)∧~(⊂'soapaction')∊cmd.Headers[;1] 319 | res status←ServiceHTML(cmd buffer) 320 | hdr←'content-type: text/html' 321 | :Else 322 | ⍝ Since our WSDL (based on our API) says to use 'document/literal', no 323 | ⍝ datatyping will be passed in the SOAP, so we need to pass the global API 324 | ⍝ in order to describe to DecodeRequest how to datatypize everything. 325 | (ok res)←API SOAP.DecodeRequest buffer 326 | 327 | :If ok ⍝ success in decoding? 328 | (method arg mpvm)←res 329 | 330 | :If (⊂method)∊ExportedFns ⍝ Is the call allowed? 331 | :Trap (~DEBUG bit 0)/0 332 | (type res)←⍎ServiceNS,'.',method,' arg' 333 | :If type≠¯1 ⋄ res←method res mpvm ⋄ :EndIf 334 | :Else 335 | res←'Server.Unexpected' 'The Web Service generated an unexpected error.'(¯2↓∊⎕DM,¨⊂NL) 336 | type←¯1 337 | :EndTrap 338 | :Else ⍝ Not in list of allowed methods 339 | res←'Client.Permission' 'The method call is not allowed.'method 340 | type←¯1 341 | :EndIf 342 | 343 | :Else ⍝ bad request 344 | type←¯1 345 | :EndIf 346 | 347 | status←(1+type≠¯1)⊃'500 Internal Server Error' '200 OK' 348 | res←type SOAP.EncodeResponse res 349 | hdr←'content-type: text/xml' 350 | :EndIf 351 | :EndIf 352 | R←status hdr res 353 | ∇ 354 | 355 | ∇ r←{a}Init w 356 | ⍝ Initialize SAWS 357 | ⍝ w - dummy for consistency with Conga, SQAPL, etc 358 | ⍝ a - 1=hard initialization, 0=soft initialization 359 | a←{0::⍵ ⋄ a}1 360 | :If 0=⎕NC'DRC' ⋄ 'DRC'⎕CY'conga' ⋄ :EndIf 361 | :If a=1 362 | ⎕TKILL ⎕TNUMS ⍝ Kill any existing threads 363 | r←¯1 DRC.Init'' ⍝ Initialize CONGA 364 | :EndIf 365 | URL←Service←LastCallRequest←LastCallResponse←AltResponse←AltRequest←LastRunRequest←LastRunResponse←'' 366 | SILENT←DEBUG←TRACE←0 367 | ∇ 368 | 369 | ∇ r←IsSecure cert;IsCert;ind;⎕ML 370 | ⍝ tests if cert contains a valid certificate 371 | ⎕ML←1 372 | r←{0::0 ⋄ (⎕CLASS DRC.X509Cert)≡⎕CLASS ⍵}cert 373 | ∇ 374 | 375 | ∇ r←MatchNamespace page;db;ind;chunk;nss;mask;nsslc;⎕IO;⎕ML;fns;root 376 | ⍝ Finds namespace matching the page name for the web service 377 | ⍝ Will find nested namespaces (e.g. /webservices/service1 maps to #.WebServices.Service1) 378 | ⍝ Note: Because page names are case insensitive we treat namespaces as case insensitive (#.Foo ≡ #.foo) 379 | ⍝ page - page (service name) possibly with a method name as well (/WebServices/Service1/Method1) 380 | ⍝ root - the root to search from 381 | ⍝ r - namespace name where the service is defined, or '' if not found 382 | ⍝ 383 | ⎕ML ⎕IO←1 384 | page←HTTPUtils.lc page 385 | db←{(+/∧\' '=⍵)↓⍵} 386 | page←⌽db⌽db page ⍝ remove any leading or trailing blanks 387 | ((page='/')/page)←'.' ⍝ replace '/' with '.' 388 | r←'' 389 | root←'#'⍝ start with root namespace 390 | :While ~0∊⍴page 391 | page←('.'=⍬⍴page)↓page ⍝ drop off leading '.' 392 | chunk←(¯1+ind←page⍳'.')↑page ⍝ grab 393 | nsslc←HTTPUtils.lc¨nss←(⍎root).⎕NL ¯9.1 ⍝ 394 | mask←nsslc≡¨⊂chunk 395 | :Select +/mask 396 | :Case 0 ⍝ namespace not found, could be a method name 397 | :If '.'∊ind↓page ⋄ :Return 398 | :Else ⋄ r←root ⋄ :Return 399 | :EndIf 400 | :Case 1 ⍝ 1 namespace found 401 | root,←'.',⊃mask/nss 402 | page←ind↓page 403 | :Else ⍝ more than 1 namespace found (i.e. #.FOO and #.foo) 404 | :Return 405 | :EndSelect 406 | :EndWhile 407 | r←root 408 | ∇ 409 | 410 | ∇ r←NL ⍝ return newline (CRLF) 411 | r←⎕UCS 13 10 412 | ∇ 413 | 414 | ∇ {trace}Output msg 415 | ⍝ Simple output function, all output to the session should be funneled through here 416 | :If SILENT≤{0::0 ⋄ ⍎⍵}'trace' 417 | ⎕←msg 418 | :EndIf 419 | ∇ 420 | 421 | ∇ r←ParseHTTP stream;ind;http;body;httpstruct 422 | ⍝ parses an HTTP message 423 | ⍝ 424 | ind←¯1+((NL,NL)⍷stream)⍳1 425 | http←(ind⌊⍴stream)↑stream 426 | httpstruct←⎕NS'' 427 | body←(4+ind)↓stream 428 | ∇ 429 | 430 | ∇ r←request ResolveNamespaces response;xmlresp;nsdefs;nsrefs;refs;ancinds;i;defs;found;⎕ML;xmlreq;reqdefs;missing;mask;hit;updated 431 | ⍝ resolves any missing namespace references in the response 432 | ⎕ML←1 433 | nsdefs←{⍵{⍵/6↓⍺}'xmlns:'≡6↑⍵} ⍝ namespace definitions 434 | nsrefs←{{((':'∊⍵)∧'xmlns:'≢6↑⍵)/(∧\':'≠⍵)/⍵}(∧\'='≠⍵)/⍵} 435 | xmlresp←⎕XML response 436 | ancinds←ancestors xmlresp[;1] 437 | defs←nsdefs¨¨1⌷[2]¨xmlresp[;4] 438 | ⍝ find any unresolved namespace references 439 | refs←((⊂¨nsrefs¨xmlresp[;2]),¨nsrefs¨¨1⌷[2]¨xmlresp[;4])~¨⊂⊂'' 440 | updated←0 441 | :For i :In ⍳⊃⍴xmlresp 442 | :If 0∊found←(i⊃refs)∊⊃,/(i⊃ancinds)⊃¨⊂defs ⍝ any unresolved? 443 | :If 0=⎕NC'xmlreq' 444 | xmlreq←⎕XML request 445 | reqdefs←nsdefs¨¨1⌷[2]¨xmlreq[;4] 446 | :EndIf 447 | :For missing :In (~found)/i⊃refs 448 | mask←missing∊¨¨reqdefs ⍝ this is dangerous, should match up tags 449 | :Select +/hit←1∊¨mask 450 | :Case 0 ⍝ not found, just skip it and hope 451 | :Case 1 ⍝ got a match, add the namespace reference to the Envelope element 452 | xmlresp[1;4]←⊂((⊂1 4)⊃xmlresp)⍪(⊃hit/mask)⌿⊃hit⌿xmlreq[;4] 453 | refs←((⊂¨nsrefs¨xmlresp[;2]),¨nsrefs¨¨1⌷[2]¨xmlresp[;4])~¨⊂⊂'' 454 | updated←1 455 | :Else ⍝ got more than one match, ambiguousness! 456 | 'Ambiguous namespace reference'⎕SIGNAL 701 457 | :EndSelect 458 | :EndFor 459 | :EndIf 460 | :EndFor 461 | :If updated 462 | r←('whitespace' 'preserve'⎕XML xmlresp)~NL 463 | :Else 464 | r←response 465 | :EndIf 466 | ∇ 467 | 468 | ∇ {r}←{svc}Run arg;thread;srvname;port 469 | ⍝ Run a Web Service using the Conga Demo WebServer 470 | ⍝ svc - name of or reference to the namespace containing the service definition 471 | ⍝ arg[1] - port to run on (default 8080) 472 | ⍝ arg[2] - run in a separate thread? (default 0) 473 | ⍝ arg[3] - server name (default 'HTTPSRV') 474 | ⍝ arg[4] - url for host (default 'localhost') 475 | ⍝ arg[5] - prefix to remove if running behind other web server via CGI 476 | ⍝ 477 | ⍝ If Service is supplied, the server runs only that Web Service with the supplied port and server name 478 | ⍝ Note: Multiple Web Services can be run simultaneously provided that each one is run in a separate thread 479 | ⍝ and has a separate port and server name 480 | ⍝ 481 | ⍝ If Service is not supplied, SAWS searchs for a namespace corresponding to the Web Service name 482 | ⍝ effectively allowing multiple Web Services to be run from a single server 483 | ⍝ 484 | :If 0=⎕NC'DRC' ⋄ 'DRC'⎕CY'conga' ⋄ :EndIf 485 | {}DRC.Init'' 486 | ⎕EX'STOP' ⍝ remove STOP flag 487 | port thread srvname URL Prefix←5↑arg,(⍴,arg)↓8080 0 'HTTPSRV' 'localhost' '' 488 | :If 0∊⍴srvname ⋄ srvname←'HTTPSRV' ⋄ :EndIf 489 | :If 0∊⍴URL ⋄ URL←'localhost' ⋄ :EndIf 490 | :If 0=⎕NC'svc' ⋄ Service←'' 491 | :Else ⋄ Service←⍕svc 492 | :EndIf 493 | :If thread 494 | r←WebServer.Run&'##.HandleRequest'port srvname 495 | :Else 496 | r←WebServer.Run'##.HandleRequest'port srvname 497 | :EndIf 498 | ∇ 499 | 500 | ∇ {r}←{svc}RunSecure arg;thread;srvname;port;certpath;cert;sslflags 501 | ⍝ Run a Secure Web Service using the Conga WebServer 502 | ⍝ svc - name of or reference to the namespace containing the service definition 503 | ⍝ arg[1] - port to run on (default 8080) 504 | ⍝ arg[2] - run in a separate thread? (default 0) 505 | ⍝ arg[3] - server name (default 'HTTPSRV') 506 | ⍝ arg[4] - root URL for service 507 | ⍝ arg[5] - prefix to remove if running behind other web server via CGI 508 | ⍝ arg[6] - path for certificates, if empty or non-existent, use path from #.Samples.CertPath 509 | ⍝ arg[7] - server certificate (DRC.X509Cert instance) or empty/non-existent if not using certificate 510 | ⍝ arg[8] - SSL flags (default 96) 511 | ⍝ 512 | ⍝ If Service is supplied, the server runs only that Web Service with the supplied port and server name 513 | ⍝ Note: Multiple Web Services can be run simultaneously provided that each one is run in a separate thread 514 | ⍝ and has a separate port and server name 515 | ⍝ 516 | ⍝ If Service is not supplied, SAWS searchs for a namespace corresponding to the Web Service name 517 | ⍝ effectively allowing multiple Web Services to be run from a single server 518 | ⍝ 519 | 520 | :If 0=⎕NC'DRC' ⋄ 'DRC'⎕CY'conga' ⋄ :EndIf 521 | {}DRC.Init'' 522 | ⎕EX'STOP' ⍝ remove STOP flag 523 | port thread srvname URL Prefix certpath cert sslflags←8↑arg,(⍴,arg)↓445 0 'HTTPSRV' 'localhost' '' ''(⎕NEW DRC.X509Cert)96 524 | :If 0∊⍴srvname ⋄ srvname←'HTTPSRV' ⋄ :EndIf 525 | :If 0∊⍴URL ⋄ URL←'localhost' ⋄ :EndIf 526 | :If 0=⎕NC'svc' ⋄ Service←'' 527 | :Else ⋄ Service←⍕svc 528 | :EndIf 529 | :If thread 530 | r←certpath WebServer.HttpsRun&'##.HandleRequest'port srvname cert sslflags 531 | :Else 532 | r←certpath WebServer.HttpsRun'##.HandleRequest'port srvname cert sslflags 533 | :EndIf 534 | ∇ 535 | 536 | ∇ (res status)←ServiceHTML(cmd buffer);⎕IO;method;post;inmls;intxt;innames;outmls;outtxt;outnames;i;dec;replace;f;name;lcname;len;svc;svcmls;ind;ismls 537 | ⍝ simple HTML interface for methods 538 | ⎕IO←1 539 | replace←{ ⍝ inefficent but functional replacement function 540 | ⎕IO←1 ⋄ ⍺←'' ⋄ txt start end←,¨⍵ 541 | 0=⍴txt:⍺ 542 | s←⍴start 543 | start≢s↑txt:(⍺,1↑txt)∇(1↓txt)start end 544 | n←{⍬≡0⍴⍵:⍵ ⋄ s+(s↓txt)⍳⍵}end 545 | (⍺,⍺⍺(n↑txt))∇(n↓txt)start end 546 | } 547 | dec←{ ⍝ hex string → integer 548 | ⎕ML ⎕IO←0 549 | 16⊥16|'0123456789abcdef0123456789ABCDEF'⍳⍵ 550 | } 551 | len←⍴lcname←HTTPUtils.lc ServiceName 552 | 553 | :If ('post /',lcname)≡(6+len)↑cmd.Input 554 | method←{(∧\⍵≠' ')/⍵}(7+len)↓cmd.Input 555 | post←1 556 | :ElseIf ('get /',lcname)≡(5+len)↑cmd.Input 557 | method←{(∧\⍵≠' ')/⍵}{('/'=1↑⍵)↓⍵}(5+len)↓cmd.Input 558 | :If (⍴method)≥i←method⍳'?' ⍝ parameters passed in URL? 559 | buffer←i↓method ⍝ if so, make it look like a post operation 560 | method←(i-1)↑method 561 | post←1 562 | :Else 563 | post←0 564 | :EndIf 565 | :Else 566 | :GoTo NOTFOUND 567 | :EndIf 568 | 569 | :If method∧.=' ' ⍝ No method named 570 | res←'',(1⊃,,/STYLE,¨⎕UCS 13),'',ServiceName,'' 571 | res,←'' 572 | res,←'

',ServiceName,'


' 573 | res,←'

The following operations are supported. For a formal definition, please review the Service Description.

' 574 | res,←'
    ' 575 | :For f :In ExportedFns 576 | res,←'
  • ',f,'
    • ' 577 | :EndFor 578 | res,←'
' 579 | status←'200 OK' 580 | :Return 581 | :EndIf 582 | 583 | :If (1+⍴API)=i←(HTTPUtils.lc¨ExportedFns)⍳⊂method 584 | :GoTo NOTFOUND 585 | :EndIf 586 | method←i⊃ExportedFns 587 | 588 | svc inmls outmls←(i⊃API) ⍝ the API give MLS input and output 589 | ⍝⍝ we just need to fill the value fields now 590 | svcmls←4⊃,svc 591 | :If post 592 | ⍝ Get values from a POST operation on the generated HTML page. 593 | ⍝ It relies on the order of the html inputs to be the same as the API description. 594 | ⍝ PS : the last one is the submit button, ignore it. 595 | ⍝ Syntax of buffer : name1=value1&name2=value2&... 596 | intxt←(↑⍴inmls)↑{(⍵⍳'=')↓⍵}¨{(⍵≠'&')⊂⍵}buffer 597 | ⍝ replace '+' by '%20' 598 | intxt←{{'%20'}replace ⍵'+' 1}¨intxt 599 | ⍝ decode percent-encoded values 600 | intxt←{{⎕UCS dec 2↑1↓⍵}replace ⍵'%' 3}¨intxt 601 | ⍝ decode unicode characters, but only for input to function 602 | ⍝ the html text will keep the &#NNNN; pattern 603 | inmls[;3]←{{⎕IO←1 ⋄ ⎕UCS 2⊃⎕VFI 2↓¯1↓⍵}replace ⍵'&#' ';'}¨intxt 604 | 605 | inmls←2⊃inmls #.SAWS.SOAP.SOAP2Data inmls 606 | 607 | :Trap (~DEBUG bit 0)/0 ⍝ Are we in debug mode? 608 | (ismls outmls)←⍎ServiceNS,'.',method,' inmls' 609 | :Else 610 | res←'The Web Service generated an unexpected error:',NL,(¯2↓∊⎕DM,¨⊂NL) 611 | :GoTo ERROR 612 | :EndTrap 613 | 614 | :If ismls=¯1 615 | res←,⍕outmls 616 | :GoTo ERROR 617 | :ElseIf 0=ismls ⍝ if the result is not an MLS (meaning it's APL data), fake it for the HTTP interface 618 | outmls←1 4⍴1 'Result'outmls(0 2⍴⊂'') 619 | :EndIf 620 | :Else 621 | ⍝ default input value 622 | intxt←inmls[;3] 623 | :EndIf 624 | outtxt←,∘⍕¨outmls[;3] 625 | 626 | ⍝ replace unicode with HTML pattern &#NNNN; 627 | outtxt←{{128>⎕UCS ⍵:⍵ ⋄ '&#',(⍕⎕UCS ⍵),';'}replace ⍵'' 1}¨outtxt 628 | ⍝ replace newlines with
629 | outtxt←{{'
'}replace ⍵ NL(⍴NL)}¨outtxt 630 | 631 | res←'',(1⊃,,/STYLE,¨⊂NL),'',ServiceName,': ',method,'' 632 | res,←'' 633 | res,←'

',ServiceName,': ',method,'


' 634 | :If (⍬⍴⍴svcmls)≥ind←svcmls[;1]⍳⊂'documentation' 635 | res,←'

',method,': ',((⊂ind,2)⊃svcmls),'

' 636 | :EndIf 637 | res,←'

' 638 | 639 | innames outnames←(inmls[;2])(outmls[;2]) ⍝ names of variables 640 | 641 | :If ~0∊⍴innames 642 | res,←'

Please enter the input parameter',(1=⍬⍴⍴innames)↓'s for the ',method,' method:

' 643 | res,←'' 644 | res,←↑,/innames{''}¨intxt 645 | res,←'
',⍺,'
' 646 | :EndIf 647 | 648 | res,←'

' 649 | 650 | :If post ⍝ We should have results? 651 | res,←'' 652 | :If 0∊⍴outnames 653 | res,←'' 654 | :Else 655 | res,←↑,/outnames{''}¨outtxt 656 | :EndIf 657 | res,←'
No Result
',⍺,'',⍵,'
' 658 | :EndIf 659 | 660 | res,←'
' 661 | res,←'

Return to main page

',NL 662 | res,←'
' 663 | status←'200 OK' 664 | :Return 665 | 666 | ERROR: 667 | status←'500 Internal Server Error' 668 | :Return 669 | 670 | NOTFOUND: 671 | status←'404 Not Found' 672 | res←'Error 404 : page not found.' 673 | :Return 674 | ∇ 675 | 676 | ∇ {r}←Stop srvname 677 | ⍝ Stop the Web Service server 678 | ⍝ srvname - name of the server to stop (defaults to 'HTTPSRV' if srvname≡'') 679 | ⍝ r[1] - 0 (success), otherwise error code 680 | ⍝ r[2] - error name if r[1]≠0 681 | ⍝ r[3] - error description if r[1]≠0 682 | :If 0∊⍴srvname ⋄ r←DRC.Close¨DRC.Names'.' 683 | :Else ⋄ r←DRC.Close srvname 684 | :EndIf 685 | ∇ 686 | 687 | ∇ {address}Test close;Start;i;n;Time;r;port 688 | ⍝ Start Web Service and make some calls to it 689 | ⍝ address - web server address (defaults to 'localhost') 690 | ⍝ close - =0 just start Web Service, =1 run test, =¯1 service already started, just run test 691 | 692 | port←8080 693 | :If 0=⎕NC'address' ⋄ address←'localhost' ⋄ :EndIf 694 | 695 | :If close≠¯1 696 | {}Init'' 697 | #.WebServiceSamples.MyWebService Run port 1 ⍝ Start Server 698 | ⎕DL 1 ⍝ Give it time to wake up 699 | :EndIf 700 | 701 | :If close=0 702 | Output'Server ''HTTPSRV'' still running... To stop it, type:' ⋄ '' 703 | Output'SAWS.Stop ''''' 704 | →0 705 | :EndIf 706 | 707 | Output'Running'(n←100)'tests...' 708 | Start←3⊃⎕AI 709 | 710 | :For i :In ⍳n 711 | r←address port Call'MyWebService' 'Regression'('Data' '2 4 6 8.1' 'Degree' 1 'Factor' 1000) 712 | :EndFor 713 | 714 | Time←(3⊃⎕AI)-Start 715 | Output i'calls in'Time'msec ='(1⍕÷Time÷1000×n)'calls/sec' 716 | Output'Response:'r 717 | 718 | :If close=1 ⋄ Stop'' ⋄ :EndIf ⍝ Server should shut down 719 | ∇ 720 | 721 | ∇ {address}TestSecure close;Start;i;n;Time;r;port;clientcert;servercert 722 | ⍝ Start Web Service and make some calls to it 723 | ⍝ address - web server address (defaults to 'localhost') 724 | ⍝ close - =0 just start Web Service, =1 run test, =¯1 service already started, just run test 725 | 726 | port←8080 727 | :If 0=⎕NC'address' ⋄ address←'localhost' ⋄ :EndIf 728 | :If close≠¯1 729 | {}Init'' 730 | servercert←Samples.ReadCert'server/server' ⍝ read the server certificate 731 | clientcert←Samples.ReadCert'client/client' ⍝ read the client certificate 732 | #.MyWebService RunSecure port 1 '' '' '' ''servercert 96 ⍝ Start Server 733 | ⎕DL 1 ⍝ Give it time to wake up 734 | :EndIf 735 | 736 | :If close=0 737 | Output'Server ''HTTPSRV'' still running... To stop it, type:' ⋄ '' 738 | Output'SAWS.Stop ''''' 739 | →0 740 | :EndIf 741 | 742 | Output'Running'(n←100)'tests using client certificate' 743 | Start←3⊃⎕AI 744 | 745 | :For i :In ⍳n 746 | r←address port'' ''clientcert 16 Call'MyWebService' 'Regression'('Data' '2 4 6 8.1' 'Degree' 1 'Factor' 1000) 747 | :If 0=10|i ⋄ Output i ⋄ :EndIf 748 | :EndFor 749 | 750 | Time←(3⊃⎕AI)-Start 751 | Output i'calls in'Time'msec ='(1⍕÷Time÷1000×n)'calls/sec' 752 | Output'Response:'r 753 | 754 | Output'Running'(n←100)'tests using blank client certificate' 755 | Start←3⊃⎕AI 756 | 757 | :For i :In ⍳n 758 | r←address port'' ''(⎕NEW DRC.X509Cert)32 Call'MyWebService' 'Regression'('Data' '2 4 6 8.1' 'Degree' 1 'Factor' 1000) 759 | :If 0=10|i ⋄ Output i ⋄ :EndIf 760 | :EndFor 761 | 762 | Time←(3⊃⎕AI)-Start 763 | Output i'calls in'Time'msec ='(1⍕÷Time÷1000×n)'calls/sec' 764 | Output'Response:'r 765 | :If close=1 ⋄ Stop'' ⋄ :EndIf ⍝ Server should shut down 766 | ∇ 767 | 768 | ∇ r←ancestors v;bv;i;inds;mask;plens;scope;where;⎕IO 769 | ⎕IO←1 770 | r←(⍴v)⍴⊂⍬ 771 | where←{⍵/⍳⍴⍵} 772 | plens←{⍵{⍵-⍨1↓⍵,1+⍴⍺}(where ⍵)} 773 | :For i :In 0,⍳⌈/v 774 | mask←i=v 775 | scope←i 'pattern' is assumed to 1 29 | ⍝ [2]-non-empty, [3]-non-empty ==> 'pattern' is assumed to 2 30 | ⍝ [2]-empty, [3]-non-empty ==> 'pattern' is assumed to 4 31 | ⍝ To show that your method adheres to a 'pattern' of 3, the 'pattern' 32 | ⍝ has to be set to 3 in the PVM. 33 | ⍝ ∘ 'documentation' - charvec of associated documentation 34 | ⍝ [2] - argument/request description, as an MLS 35 | ⍝ [3] - result/response description, as an MLS 36 | ⍝ Each MLS (those in elements 2 and 3 above) describes the allowable structure 37 | ⍝ of the data (intended as the argument or result). It is a sort of model 38 | ⍝ or prototype along with a few attributes to more fully describe it. 39 | ⍝ So, the 1st and 2nd columns of the MLS look much like the real data would. 40 | ⍝ The 3rd column, the content, is empty for now (perhaps it will be used 41 | ⍝ later for something in the future, e.g. example data). 42 | ⍝ The 4th column consists of PVMs where the following attributes are utilized: 43 | ⍝ 'datatype' - it can be one of the following: 'string' 'boolean' 'integer' 'double' 44 | ⍝ Default: '' ==> container element 45 | ⍝ It may also be a datatype defined by http://www.w3.org/TR/xmlschema-2/; 46 | ⍝ to specifically use one of those, use the "xsd:" prefix, e.g. 'xsd:dateTime' 47 | ⍝ Note: The datatypes listed above actually do correspond (same names exactly) 48 | ⍝ with real xsd datatypes. However, it is intended that you are 49 | ⍝ able to pass generic datatypes and these would get mapped 50 | ⍝ to the appropriate ones should they ever vary from WSDL schema. 51 | ⍝ 'minimum' - the minimum number of times that this element must occur, PER PARENT. Default: 0 52 | ⍝ 'maximum' - the maximum number of times that this element must occur, PER PARENT. Default: ∆MV ==> unlimited 53 | ⍝ 'documentation' - charvec of associated documentation 54 | ⍝ Note that minimum and maximum are not describing the minimum/maximum value 55 | ⍝ of the content; they are describing the structure of the elements. They 56 | ⍝ are commonly used for showing whether some element is single or multiple 57 | ⍝ but they can be further utilized to describe requiredness or a maximum 58 | ⍝ count of some element at some level. 59 | ⍝ The following describes a single required element: ⊃('minimum' 1)('maximum' 1). 60 | ⍝ The following describes an optional array of elements, of any length: 1 2⍴'minimum' 0 61 | ⍝ pvm - PVM containing the primary information about the Web Service 62 | ⍝ name - name of the Web Service 63 | ⍝ serviceURL - URL/address of the Web Service. This is where the SOAP-XML 64 | ⍝ methods/requests are actually sent to. 65 | ⍝ wsdlURL - associated WSDL URL. This should be the URL of where to retrieve 66 | ⍝ the complete WSDL document, as XML (what this function is 67 | ⍝ generating the MLS for) 68 | ⍝ Default: ,'/wsdl' 69 | ⍝ R - an MLS that describes a formal WSDL, consisting of all of the methods. 70 | ⍝ Running this through MLS2XML generates a WSDL document that is 71 | ⍝ suitable for using in a Web Service. 72 | ⍝ 73 | ⍝ EXAMPLE: 74 | ⍝ api←0⍴⊂'' ⍝ initialize the right argument to API2WSDL 75 | ⍝ ⍝ Describe the method for updating information on several people in one call. 76 | ⍝ method←'UpdatePersons' 77 | ⍝ arg←0 4⍴0 78 | ⍝ arg←arg⍪1 'person' '' (1 2⍴ 'minimum' 0) 79 | ⍝ arg←arg⍪2 'lastname' '' (⊃('datatype' 'string') ('minimum' 1)('maximum' 1)) 80 | ⍝ arg←arg⍪2 'firstname' '' (⊃('datatype' 'string') ('minimum' 1)('maximum' 1)) 81 | ⍝ arg←arg⍪2 'dob' '' (⊃('datatype' 'xsd:date')('minimum' 1)('maximum' 1)) 82 | ⍝ arg←arg⍪2 'phones' '' (⊃ ('minimum' 0)('maximum' 3)) 83 | ⍝ arg←arg⍪3 'phonenum' '' (⊃('datatype' 'string') ('minimum' 1)('maximum' 1)) 84 | ⍝ arg←arg⍪3 'type' '' (⊃('datatype' 'integer') ('minimum' 0)('maximum' 1)) 85 | ⍝ result←0 4⍴0 86 | ⍝ result←result⍪1 'success' '' (⊃'datatype' 'boolean') ('minimum' 1)('maximum' 1)) 87 | ⍝ api←api,⊂method arg result 88 | ⍝ ⍝ Describe the method for ... 89 | ⍝ method←'...' 90 | ⍝ arg←... 91 | ⍝ result←... 92 | ⍝ api←api,⊂method arg result 93 | ⍝ ⍝ Describe the method for ... 94 | ⍝ method←'...' 95 | ⍝ arg←... 96 | ⍝ result←... 97 | ⍝ api←api,⊂method arg result 98 | ⍝ 99 | ⍝ ... API2WSDL api ==> 100 | ⍝ 101 | ⍝ SUBFNS: ∆MV PVMGetVal PVMGetVals Parent 102 | ⍝ ----------------------------------------------------------------------------------- 103 | epvm←0 2⍴⊂'' 104 | 105 | :If 0=⎕NC'pvm' ⋄ pvm←epvm ⋄ :EndIf 106 | serviceURL←'serviceURL' 'http://Unspecified/WebService/'PVMGetVal pvm 107 | serviceURL←serviceURL,('/'≠¯1↑serviceURL)/'/' 108 | props←'' 109 | props←props,⊂'name' 'UnspecifiedWebService' 110 | props←props,⊂'wsdlURL'(serviceURL,'wsdl/') 111 | (name wsdlURL)←props PVMGetVals pvm 112 | :If '/'≠¯1↑wsdlURL ⋄ wsdlURL←wsdlURL,'/' ⋄ :EndIf 113 | typesURL←serviceURL,'schema/' 114 | 115 | ⍝ For each method-part, get the method's name, pattern, documentation. 116 | :For I :In ⍳⍴api 117 | method←I 1⊃api 118 | :If B←1<≡method 119 | (mname mpvm)←method[1;2 4] 120 | (pattern doc)←'pattern'('documentation' '')PVMGetVals mpvm 121 | :Else 122 | mname←method 123 | doc←'' 124 | :EndIf 125 | :If ~B ⋄ :OrIf pattern≡∆MV 126 | pattern←(1 2 4)[(1 0)(1 1)(0 1)⍳⊂×↑¨⍴¨(I⊃api)[2 3]] 127 | :EndIf 128 | ((I 1)⊃api)←mname pattern doc 129 | :EndFor 130 | 131 | pvm←epvm 132 | pvm←pvm⍪'name'name 133 | pvm←pvm⍪'targetNamespace'wsdlURL 134 | pvm←pvm⍪'xmlns:tns'wsdlURL 135 | pvm←pvm⍪'xmlns:mytypes'typesURL 136 | pvm←pvm⍪'xmlns' 'http://schemas.xmlsoap.org/wsdl/' 137 | pvm←pvm⍪'xmlns:xsd' 'http://www.w3.org/2001/XMLSchema' 138 | pvm←pvm⍪'xmlns:soap' 'http://schemas.xmlsoap.org/wsdl/soap/' 139 | pvm←pvm⍪'xmlns:soapenc' 'http://schemas.xmlsoap.org/soap/encoding/' 140 | pvm←pvm⍪'xmlns:http' 'http://schemas.xmlsoap.org/wsdl/http/' 141 | pvm←pvm⍪'xmlns:mime' 'http://schemas.xmlsoap.org/wsdl/mime/' 142 | 143 | R←1 4⍴1 'definitions' ''pvm 144 | 145 | ⍝ Types: 146 | R←R⍪2 'types' ''epvm 147 | R←R⍪3 'xsd:schema' ''(2 2⍴'targetNamespace'typesURL'elementFormDefault' 'qualified') 148 | :For I :In ⍳⍴api 149 | (method request response)←I⊃api 150 | mname←1⊃method 151 | :For J :In ⍳2 152 | :If 0∊rmls←J⊃request response ⋄ :Continue ⋄ :EndIf 153 | :If J=2 ⋄ mname←mname,'Response' ⋄ :EndIf 154 | R←R⍪4 'xsd:element' ''(1 2⍴'name'mname) 155 | R←R⍪5 'xsd:complexType' ''epvm 156 | R←R⍪6 'xsd:sequence' ''epvm 157 | 158 | rmls←0 '' ''epvm⍪rmls ⍝ (just so we can have a parent for the top-level nodes too because, in the general case, we have to look to the parent to see what depth we should start at) 159 | D←(↑⍴rmls)⍴7 ⍝ starting depths 160 | :For K :In 1↓⍳↑⍴rmls 161 | d←D[K Parent rmls[;1]] 162 | (type min max doc)←('datatype' '')('minimum' 0)('maximum' 'unbounded')('documentation' '')PVMGetVals((⊂K 4)⊃rmls) 163 | rpvm←⊃('name'((⊂K 2)⊃rmls))('minOccurs'min)('maxOccurs'max) 164 | ⍝:IF min=0 ⋄ rpvm←rpvm⍪'nillable' 'true' ⋄ :ENDIF ⍝ *** - ??? 165 | :If 0<⍴doc ⋄ doc←1 4⍴(d+1)'documentation'doc epvm ⋄ :Else ⋄ doc←0 4⍴0 ⋄ :EndIf 166 | 167 | :If 0≠⍴type 168 | :If ~':'∊type 169 | ⍝type←('string' 'boolean' 'integer' 'double'⍳⊂type)⊃'string' 'boolean' 'integer' 'double' ⍝ don't have to run this since the mapping is a noop 170 | type←'xsd:',type 171 | :EndIf 172 | rpvm←rpvm⍪'type'type 173 | R←R⍪(d'xsd:element' ''rpvm)⍪doc 174 | :Else 175 | R←R⍪(d'xsd:element' ''rpvm)⍪doc 176 | R←R⍪⊃((d+1)'xsd:complexType' ''epvm)((d+2)'xsd:sequence' ''epvm) 177 | D[K]←d+3 178 | :EndIf 179 | :EndFor 180 | :EndFor 181 | :EndFor 182 | 183 | ⍝ Messages: 184 | :For I :In ⍳⍴api 185 | (mname pattern)←2↑I 1⊃api 186 | :If pattern<4 187 | R←R⍪2 'message' ''(1 2⍴'name'(mname,'MessageIn')) 188 | R←R⍪3 'part' ''(2 2⍴'name' 'parameters' 'element'('mytypes:',mname)) ⍝ (we'll use 'parameters' as the name simply because that's what .NET uses) 189 | :EndIf 190 | :If pattern>1 191 | R←R⍪2 'message' ''(1 2⍴'name'(mname,'MessageOut')) 192 | R←R⍪3 'part' ''(2 2⍴'name' 'parameters' 'element'('mytypes:',mname,'Response')) 193 | :EndIf 194 | :EndFor 195 | 196 | ⍝ Operations: 197 | R←R⍪2 'portType' ''(1 2⍴'name'(name,'_PortType')) 198 | :For I :In ⍳⍴api 199 | (mname pattern doc)←I 1⊃api 200 | R←R⍪3 'operation' ''(1 2⍴'name'mname) 201 | :If 0<⍴doc 202 | R←R⍪4 'documentation'doc epvm 203 | :EndIf 204 | :If pattern<4 205 | R←R⍪4 'input' ''(1 2⍴'message'('tns:',mname,'MessageIn')) 206 | :EndIf 207 | :If pattern>1 208 | R←R⍪4 'output' ''(1 2⍴'message'('tns:',mname,'MessageOut')) 209 | :EndIf 210 | :EndFor 211 | 212 | ⍝ Bindings: 213 | R←R⍪2 'binding' ''(2 2⍴'name'(name,'_Binding')'type'('tns:',name,'_PortType')) 214 | R←R⍪3 'soap:binding' ''(2 2⍴'style' 'document' 'transport' 'http://schemas.xmlsoap.org/soap/http') 215 | ⍝A←5 'soap:body' '' (3 2⍴'use' 'literal' 'encodingStyle' 'http://schemas.xmlsoap.org/soap/encoding/' 'namespace' ('urn:',name)) 216 | A←5 'soap:body' ''(1 2⍴'use' 'literal') ⍝ for the "wrapped" convention, you are NOT supposed to include or 'encodingStyle' or 'namespace' 217 | :For I :In ⍳⍴api 218 | (mname pattern)←2↑I 1⊃api 219 | R←R⍪3 'operation' ''(1 2⍴'name'mname) 220 | R←R⍪4 'soap:operation' ''(1 2⍴'soapAction'mname) 221 | :If pattern<4 222 | R←R⍪4 'input' ''epvm 223 | R←R⍪A 224 | :EndIf 225 | :If pattern>1 226 | R←R⍪4 'output' ''epvm 227 | R←R⍪A 228 | :EndIf 229 | :EndFor 230 | 231 | ⍝ Service: 232 | R←R⍪2 'service' ''(1 2⍴'name'name) 233 | R←R⍪3 'port' ''(2 2⍴'name'(name,'_Port')'binding'('tns:',name,'_Binding')) 234 | R←R⍪4 'soap:address' ''(1 2⍴'location'serviceURL) 235 | ∇ 236 | 237 | ∇ R←APL2SOAP rarg;tree;I;stypes;B;⍙mv;applyB;nullB;atomsB;inds;tags;inherit 238 | ⍝ Transform some arbitrary APL data into a SOAP-MLS 239 | ⍝ ----------------------------------------------------------------------------------- 240 | ⍝ SYNTAX: R←APL2SOAP rarg 241 | ⍝ 242 | ⍝ ARGS/RESULT: 243 | ⍝ rarg - any APL data 244 | ⍝ R - SOAP-MLS 245 | ⍝ 246 | ⍝ SUBFNS: ∆MV WHERE ⍙APL2SOAP_Recurse ConcatMats 247 | ⍝ ----------------------------------------------------------------------------------- 248 | 249 | ⍙mv←∆MV ⍝ initialize for globals use 250 | tree←1 ⍙APL2SOAP_Recurse rarg ⍝ normalize the data, via recursion, to make it easy to transform hereafter 251 | atomsB←0≠tree[;4] ⍝ atoms (have data; they're not just containers) 252 | applyB←0atomsB 272 | R[I;2]←⊂'array' ⍝ (this is just a convention, as is the child 'a' initialized in up above) 273 | R[I;4]←(⊂1 2⍴'xsi:type' 'SOAP-ENC:Array')⍪¨⊂[2](⊂'SOAP-ENC:arrayType'),[1.5]stypes[I],¨'[',¨(1↓¨∊¨',',¨¨⍕¨¨tree[I;3]),¨']' 274 | 275 | ⍝ Plug in special attribute showing NULL (more rare so check for 1∊ up front) 276 | :If 1∊nullB 277 | ⍝ Yes, this use of setting xsi:null="1" appears to be inconsistent. Why not 278 | ⍝ have 'xsd:null' up above with the other datatypes and then we wouldn't need to 279 | ⍝ special case anything here? Regardless of that, it appears that we still do 280 | ⍝ need xsd:null so that we can describe an array of nulls, e.g. 'xsi:null[2,3]'. 281 | I←WHERE nullB∧atomsB 282 | R[I;4]←⊂1 2⍴'xsi:null' 1 283 | 284 | I←WHERE nullB>atomsB 285 | R[I;4]←(⊂1 2⍴'xsi:type' 'SOAP-ENC:Array')⍪¨⊂[2](⊂'SOAP-ENC:arrayType'),[1.5](⊂'xsd:null'),¨'[',¨(1↓¨∊¨',',¨¨⍕¨¨tree[I;3]),¨']' 286 | :EndIf 287 | 288 | ⍝ =================================================================================== 289 | ⍝ We have to special case some types of APLish data. 290 | ⍝ SOAP considers character vectors to be at the atomic level. No shape needs to be 291 | ⍝ described for them. So, neither an APL character scalar nor a multi-dimensional 292 | ⍝ character array has a real analog in SOAP since you cannot describe its shape unless 293 | ⍝ you umbrella it with an 'array' tag which implies it is nested. 294 | ⍝ Essentially, we just can't have the SOAP 'array' element serve double-duty 295 | ⍝ (it can't serve the purpose of nestedness and an array-shape descriptor). 296 | ⍝ We'll have to add our own special property in order to overcome this. 297 | ⍝ This way, we will at least always ensure that the following is true for any data: 298 | ⍝ data≡SOAP2APL APL2SOAP data 299 | :If 1∊B←¯1=tree[;4] 300 | I←WHERE B 301 | R[I;3]←,¨R[I;3] 302 | R[I;4]←R[I;4]⍪¨⊂[2](⊂'APL-ENC:shape'),[1.5]⍕¨tree[I;3] 303 | :EndIf 304 | ∇ 305 | 306 | ∇ R←I Ancestors dv 307 | ⍝ Return the indices of the ancestors for some specified index 308 | ⍝ ----------------------------------------------------------------------------------- 309 | ⍝ SYNTAX: R←I Ancestors dv 310 | ⍝ 311 | ⍝ ARGS/RESULT: 312 | ⍝ dv - depth vector 313 | ⍝ I - index to find the ancestors of 314 | ⍝ R - indices of the ancestors, in ascending order 315 | ⍝ ----------------------------------------------------------------------------------- 316 | dv←dv+1-⌊/dv ⍝ normalize 317 | R←I-(⌽(I-1)↑dv)⍳⍳dv[I]-1 318 | ∇ 319 | 320 | ∇ R←depth BeginDepth R 321 | ⍝ Simple cover - begin the depth of an MLS with the value specified 322 | ⍝ ----------------------------------------------------------------------------------- 323 | ⍝ SYNTAX: R←depth BeginDepth mls 324 | ⍝ 325 | ⍝ ARGS/RESULT: 326 | ⍝ mls - Markup Language Structure or any matrix where the first column is 327 | ⍝ a depth vector 328 | ⍝ depth - integer depth to begin at 329 | ⍝ R - adjusted MLS 330 | ⍝ 331 | ⍝ EXAMPLE: 332 | ⍝ mls←0 4⍴'' 333 | ⍝ mls←mls⍪3 'this' ... 334 | ⍝ mls←mls⍪4 'that' ... 335 | ⍝ mls←mls⍪5 'other' ... 336 | ⍝ mls←mls⍪4 'stuff' ... 337 | ⍝ mls←mls⍪4 'more' ... 338 | ⍝ 2 BeginDepth mls ==> 2 'this' ... 339 | ⍝ 3 'that' ... 340 | ⍝ 4 'other' ... 341 | ⍝ 3 'stuff' ... 342 | ⍝ 3 'more' ... 343 | ⍝ ----------------------------------------------------------------------------------- 344 | R[;⎕IO]←R[;⎕IO]-(↑R)-depth 345 | ∇ 346 | 347 | BeginsWith←{⍵≡(⍴⍵)↑⍺} 348 | 349 | Children←{dv←⍵+1-⌊/⍵ ⋄ res←¯1+(dv[⍺] is intended as an MLS as opposed 367 | ⍝ to just some arbitrary APL data. Note that, if an MLS, the content of 368 | ⍝ any given row may itself still be arbitrary APL data. If an MLS were a 369 | ⍝ real APL datatype, you wouldn't need to pass . When going from 370 | ⍝ SOAP to APL, it can be determined if it is destined as an MLS or as 371 | ⍝ arbitrary APL data by inspecting the top-level element's 'xsi:type' 372 | ⍝ property. 373 | ⍝ encoding - applies when is 1. See MLS2SOAP. Default: 1 374 | ⍝ R - SOAP-MLS 375 | ⍝ 376 | ⍝ EXAMPLES: 377 | ⍝ mls←⊃(1 'prop' 10 (0 2⍴⊂'')) (1 'prop2' (20 30) (0 2⍴⊂'')) 378 | ⍝ 1) 0 Data2SOAP mls ==> 379 | ⍝ 1 'array' '' (2 2⍴'xsi:type' 'SOAP-ENC:Array' 'SOAP-ENC:arrayType' 'xsd:ur-type[2,4]') 380 | ⍝ 2 'a' 1 (1 2⍴'xsi:type' 'xsd:boolean') 381 | ⍝ 2 'a' 'prop' (1 2⍴'xsi:type' 'xsd:string') 382 | ⍝ 2 'a' 10 (1 2⍴'xsi:type' 'xsd:int') 383 | ⍝ 2 'array' '' (2 2⍴'xsi:type' 'SOAP-ENC:Array' 'SOAP-ENC:arrayType' 'xsd:string[0,2]') 384 | ⍝ 3 'a' '' (0 2⍴⊂'') 385 | ⍝ 2 'a' 1 (1 2⍴'xsi:type' 'xsd:boolean') 386 | ⍝ 2 'a' 'prop2' (1 2⍴'xsi:type' 'xsd:string') 387 | ⍝ 2 'array' '' (2 2⍴'xsi:type' 'SOAP-ENC:Array' 'SOAP-ENC:arrayType' 'xsd:int[2]') 388 | ⍝ 3 'a' 20 (0 2⍴⊂'') 389 | ⍝ 3 'a' 30 (0 2⍴⊂'') 390 | ⍝ 2 'array' '' (2 2⍴'xsi:type' 'SOAP-ENC:Array' 'SOAP-ENC:arrayType' 'xsd:string[0,2]') 391 | ⍝ 3 'a' '' (0 2⍴⊂'') 392 | ⍝ 2) 1 Data2SOAP mls ==> 393 | ⍝ 1 'prop' 10 (1 2⍴'xsi:type' 'xsd:int') 394 | ⍝ 1 'prop2' '' (0 2⍴⊂'') 395 | ⍝ 2 'array' '' (2 2⍴'xsi:type' 'SOAP-ENC:Array' 'SOAP-ENC:arrayType' 'xsd:int[2]') 396 | ⍝ 3 'a' 20 (0 2⍴⊂'') 397 | ⍝ 3 'a' 30 (0 2⍴⊂'') 398 | ⍝ 399 | ⍝ NOTES: 400 | ⍝ - According to the SOAP specification (section 5.1), if a given element has 401 | ⍝ non-empty content, it may not have subelements. For now, you must just be 402 | ⍝ careful about passing such an MLS. 403 | ⍝ 404 | ⍝ SUBFNS: MLS2SOAP APL2SOAP 405 | ⍝ ----------------------------------------------------------------------------------- 406 | (isMLS encoding)←2↑larg,1 407 | :If isMLS ⋄ R←encoding MLS2SOAP R ⋄ :Else ⋄ R←APL2SOAP R ⋄ :EndIf 408 | ∇ 409 | 410 | ∇ R←{larg}DecodeRequest xml;⎕IO 411 | ⍝ Decode a SOAP-XML request 412 | ⍝ ----------------------------------------------------------------------------------- 413 | ⍝ SYNTAX: R←{decoding} {noCheckArray} DecodeRequest xml 414 | ⍝ 415 | ⍝ ARGS/RESULT: 416 | ⍝ xml - SOAP-XML that is intended as a complete method-call 417 | ⍝ decoding - see in ⍙DecodeMethod except that [type] should not be 418 | ⍝ passed when using the 3rd format of . 419 | ⍝ Default: 1 420 | ⍝ noCheckArray - see ⍙DecodeMethod. Default: 0 421 | ⍝ R - [1] - success boolean 422 | ⍝ [2] - if success (R[1]=1): 423 | ⍝ [1] - name of the method 424 | ⍝ [2] - method argument as an MLS or arbitrary APL data 425 | ⍝ [3] - PVM for the attributes applied to the method, 426 | ⍝ e.g. ==> 1 2⍴'xmlns' '...' 427 | ⍝ if failure (R[1]=0): 428 | ⍝ 3-element vector describing a SOAP Fault. If passed to 429 | ⍝ SOAPFault and then to MLS2XML, it yields a complete SOAP 430 | ⍝ Fault XML string (complete body of an HTTP response). 431 | ⍝ Important: Whenever such XML is returned, you should also 432 | ⍝ return an HTTP status of '500 Internal Server Error'. 433 | ⍝ 434 | ⍝ SUBFNS: APLType ⍙DecodeMethod 435 | ⍝ ----------------------------------------------------------------------------------- 436 | ⎕IO←1 437 | ⎕SHADOW'⎕ML' 438 | ⎕ML←3 ⍝ Protect. Even though we set ⎕ML to 3 in this namespace, a caller could localize it and then run ⎕CS, thereby setting it globally here.) 439 | 440 | :If 0=⎕NC'larg' ⋄ larg←1 0 441 | :ElseIf 1=×/⍴larg ⋄ larg←(larg 0)0 442 | :Else 443 | :If 0<≡2⊃larg ⋄ larg←larg 0 ⋄ :EndIf 444 | :If 0<≡1⊃larg ⋄ larg[1]←⊂(1⊃larg)0 ⋄ :EndIf 445 | :EndIf 446 | 447 | R←larg ⍙DecodeMethod xml 448 | ∇ 449 | 450 | ∇ R←{larg}DecodeResponse xml;⎕IO 451 | ⍝ Decode a SOAP-XML response 452 | ⍝ ----------------------------------------------------------------------------------- 453 | ⍝ SYNTAX: R←{decoding} {noCheckArray} DecodeResponse xml 454 | ⍝ 455 | ⍝ ARGS/RESULT: 456 | ⍝ xml - SOAP-XML (result of calling some method via SOAP) 457 | ⍝ decoding - see in ⍙DecodeMethod except that [type] should not be 458 | ⍝ passed when using the 3rd format of . 459 | ⍝ Default: 1 460 | ⍝ noCheckArray - see ⍙DecodeMethod. Default: 0 461 | ⍝ R - result as APL data 462 | ⍝ [1] - 1 - success 463 | ⍝ 0 - failure - a SOAP Fault structure is in 2nd element 464 | ⍝ ¯1 - failure - the SOAP message could not be decoded 465 | ⍝ [2] - if success (R[1]=1): 466 | ⍝ [1] - name of the method 467 | ⍝ [2] - method result as an MLS or arbitrary APL data 468 | ⍝ [3] - PVM for the attributes applied to the method, 469 | ⍝ e.g. ==> 1 2⍴'xmlns' '...' 470 | ⍝ if failure (R[1]≤0): 471 | ⍝ SOAP Fault structure (see ∇SOAPFault) 472 | ⍝ 473 | ⍝ SUBFNS: APLType ⍙DecodeMethod 474 | ⍝ ----------------------------------------------------------------------------------- 475 | ⎕IO←1 476 | ⎕SHADOW'⎕ML' 477 | ⎕ML←3 ⍝ Protect. Even though we set ⎕ML to 3 in this namespace, a caller could localize it and then run ⎕CS, thereby setting it globally here.) 478 | 479 | :If 0=⎕NC'larg' ⋄ larg←1 0 480 | :ElseIf 1=×/⍴larg ⋄ larg←(larg 1)0 481 | :Else 482 | :If 0<≡2⊃larg ⋄ larg←larg 0 ⋄ :EndIf 483 | :If 0<≡1⊃larg ⋄ larg[1]←⊂(1⊃larg)1 ⋄ :EndIf 484 | :EndIf 485 | 486 | ⍝ We'll just leverage ⍙DecodeMethod since it's doing the work we need here but we 487 | ⍝ need to modify the method name (drop 'Response' part). 488 | :If ↑R←larg ⍙DecodeMethod xml 489 | R←2⊃R 490 | :If 1∊':Fault'⍷1⊃R ⍝ Did the server send back a SOAP Fault structure? (the method "name" is 'SOAP-ENV:Fault') 491 | R←0((2⊃R)[;3]) 492 | :Else 493 | R[1]←⊂{(¯8×'Response'≡¯8↑⍵)↓⍵}1⊃R ⍝ 'FooResponse' ==> 'Foo' 494 | R←1 R 495 | :EndIf 496 | :Else ⍝ this SOAP is invalid somehow and we constructed our own SOAP Fault structure in ⍙DecodeMethod 497 | R←¯1(2⊃R) 498 | :EndIf 499 | ∇ 500 | 501 | ∇ R←I Descendants dv 502 | ⍝ Return the indices of the descendants for some specified index 503 | ⍝ ----------------------------------------------------------------------------------- 504 | ⍝ SYNTAX: R←I Descendants dv 505 | ⍝ 506 | ⍝ ARGS/RESULT: 507 | ⍝ dv - depth vector 508 | ⍝ I - index to find the descendants of 509 | ⍝ R - indices of the descendants, in ascending order 510 | ⍝ ----------------------------------------------------------------------------------- 511 | R←I+⍳¯1+(dv[I]≥I↓dv)⍳1 512 | ∇ 513 | 514 | ∇ R←I DescendantsAndSelf dv 515 | ⍝ Return the indices of the descendants and self for some specified index 516 | ⍝ ----------------------------------------------------------------------------------- 517 | ⍝ SYNTAX: R←I DescendantsAndSelf dv 518 | ⍝ 519 | ⍝ ARGS/RESULT: 520 | ⍝ dv - depth vector 521 | ⍝ I - index to find the descendants of 522 | ⍝ R - indices of the descendants and self, in ascending order 523 | ⍝ ----------------------------------------------------------------------------------- 524 | R←I+¯1+⍳(dv[I]≥I↓dv)⍳1 525 | ∇ 526 | 527 | ∇ R←{larg}EncodeRequest rarg;⎕IO;A 528 | ⍝ Encode a SOAP-XML request 529 | ⍝ ----------------------------------------------------------------------------------- 530 | ⍝ SYNTAX: R←{isMLS} {encoding} {xmlencoding} EncodeRequest method methodarg {methodpvm} 531 | ⍝ 532 | ⍝ ARGS/RESULT: 533 | ⍝ method - name of the method intended to be called 534 | ⍝ methodarg - argument to the method 535 | ⍝ methodpvm - PVM to apply to the method element. Default: 0 2⍴⊂'' 536 | ⍝ isMLS - see in Data2SOAP. Default: 1 537 | ⍝ encoding - see in ⍙EncodeMethod except that [type] should not be 538 | ⍝ passed when using the 3rd format of . 539 | ⍝ Default: 0 (which is in alignment with WSDL binding use="literal") 540 | ⍝ xmlencoding - see in MLS2XML. Default: 'UTF-8' 541 | ⍝ R - SOAP-XML intended as a complete method-call 542 | ⍝ 543 | ⍝ SUBFNS: APLType ⍙EncodeMethod 544 | ⍝ ----------------------------------------------------------------------------------- 545 | ⎕IO←1 546 | ⎕SHADOW'⎕ML' 547 | ⎕ML←3 ⍝ Protect. Even though we set ⎕ML to 3 in this namespace, a caller could localize it and then run ⎕CS, thereby setting it globally here.) 548 | 549 | A←1 0 'UTF-8' 550 | :If 0=⎕NC'larg' ⋄ larg←A 551 | :Else ⋄ larg←larg,(×/⍴larg)↓A 552 | :If 0<≡2⊃larg ⋄ larg[2]←⊂(2⊃larg)0 ⋄ :EndIf 553 | :EndIf 554 | 555 | R←larg ⍙EncodeMethod rarg 556 | ∇ 557 | 558 | ∇ R←{larg}EncodeResponse rarg;⎕IO;A 559 | ⍝ Encode a SOAP-XML response 560 | ⍝ ----------------------------------------------------------------------------------- 561 | ⍝ SYNTAX: 1) R←{type} {encoding} {xmlencoding} EncodeResponse method methodres {methodpvm} 562 | ⍝ 2) R←¯1 {''} {xmlencoding} EncodeResponse rarg_to_SOAPFault 563 | ⍝ 564 | ⍝ ARGS/RESULT: 565 | ⍝ method - name of the method yielding 566 | ⍝ methodres - result of calling (see in Data2SOAP) 567 | ⍝ methodpvm - PVM to apply to the method element (usually just the same as that 568 | ⍝ passed in the original SOAP request) 569 | ⍝ Default: 0 2⍴⊂'' 570 | ⍝ rarg_to_SOAPFault - see rarg of ∇SOAPFault. 571 | ⍝ Important: Whenever this is returned, you should also return 572 | ⍝ an HTTP status of '500 Internal Server Error'. 573 | ⍝ type - 0 or 1: see in EncodeRequest/Data2SOAP. 574 | ⍝ ¯1: return a complete SOAP Fault structure as the result (see 575 | ⍝ SOAPFault), as XML. 576 | ⍝ Default: 1 577 | ⍝ encoding - see in ⍙EncodeMethod except that [type] should not be 578 | ⍝ passed when using the 3rd format of . 579 | ⍝ Default: 0 (which is in alignment with WSDL binding use="literal") 580 | ⍝ xmlencoding - see ∇MLS2XML. Default: 'UTF-8' 581 | ⍝ R - SOAP-XML intended to be passed back as a result, typicall in an HTTP body 582 | ⍝ 583 | ⍝ SUBFNS: APLType ⍙EncodeMethod MLS2XML SOAPFault 584 | ⍝ ----------------------------------------------------------------------------------- 585 | ⎕IO←1 586 | ⎕SHADOW'⎕ML' 587 | ⎕ML←3 ⍝ Protect. Even though we set ⎕ML to 3 in this namespace, a caller could localize it and then run ⎕CS, thereby setting it globally here.) 588 | 589 | A←1 0 'UTF-8' 590 | :If 0=⎕NC'larg' ⋄ larg←A ⋄ :Else ⋄ larg←larg,(×/⍴larg)↓A ⋄ :EndIf 591 | 592 | :If 0≤↑larg 593 | :If 0<≡2⊃larg ⋄ larg[2]←⊂(2⊃larg)1 ⋄ :EndIf 594 | rarg[1]←⊂(1⊃rarg),'Response' 595 | R←larg ⍙EncodeMethod rarg 596 | :Else 597 | :If 3=≡rarg ⋄ rarg←2⊃rarg ⋄ :EndIf ⍝ (in case they included the method name first) 598 | R←(3⊃larg)MLS2XML SOAPFault rarg 599 | :EndIf 600 | ∇ 601 | 602 | EndsWith←{⍵≡(-⍴⍵)↑⍺} 603 | 604 | ∇ R←IsSimpleValue value 605 | :If 1<≡value ⍝ nested 606 | R←0 607 | :ElseIf (⎕DR value)∊82 80 160 320 ⍝ character 608 | R←↑1≥⍴⍴value 609 | :Else ⍝ numeric 610 | R←⍬≡⍴value 611 | :EndIf 612 | ∇ 613 | 614 | ∇ R←{encoding}MLS2SOAP R;mls;content;I;pvm;mv;J;type 615 | ⍝ Transform an MLS into a SOAP-MLS 616 | ⍝ ----------------------------------------------------------------------------------- 617 | ⍝ SYNTAX: R←{encoding} MLS2SOAP mls 618 | ⍝ 619 | ⍝ ARGS/RESULT: 620 | ⍝ mls - fully formed MLS 621 | ⍝ encoding - 0 - do not apply any datatype tagging to any elements 622 | ⍝ 1 - apply datatype tagging to each element according to its APL 623 | ⍝ datatype. However, for a given element, if its PVM contains the 624 | ⍝ attribute 'xsi:type', then its value is preserved (it's not 625 | ⍝ overwritten with the mapped APL datatype). 626 | ⍝ apimls - apply datatype tagging according to the passed API-MLS. 627 | ⍝ This API-MLS follows the format described in API2WSDL 628 | ⍝ (2nd or 3rd element for a given method description). 629 | ⍝ Observation: If all of the elements' datatypes are native to APL, then 630 | ⍝ the 3rd format for will yield the same result as =1. 631 | ⍝ Default: 1 632 | ⍝ R - SOAP-MLS. It's basically the same as the passed MLS but for each row, 633 | ⍝ a datatype is somehow applied as an attribute. Also, "non-simple" 634 | ⍝ content is spread out as more rows (a SOAP "array"). 635 | ⍝ 636 | ⍝ EXAMPLE: 637 | ⍝ mls←0 4⍴0 638 | ⍝ mls←mls⍪1 'prop1' 'this' (0 2⍴⊂'') 639 | ⍝ mls←mls⍪1 'prop2' (5 10) (0 2⍴⊂'') 640 | ⍝ mls←mls⍪1 'prop3' ('more' 7.5) (0 2⍴⊂'') 641 | ⍝ MLS2SOAP mls ==> 642 | ⍝ 1 'prop1' 'this' (1 2⍴'xsi:type' 'xsd:string') 643 | ⍝ 1 'prop2' '' (0 2⍴⊂'') 644 | ⍝ 2 'array' '' (2 2⍴'xsi:type' 'SOAP-ENC:Array' 'SOAP-ENC:arrayType' 'xsd:int[2]') 645 | ⍝ 3 'a' 5 (0 2⍴⊂'') 646 | ⍝ 3 'a' 10 (0 2⍴⊂'') 647 | ⍝ 1 'prop3' '' (0 2⍴⊂'') 648 | ⍝ 2 'array' '' (2 2⍴'xsi:type' 'SOAP-ENC:Array' 'SOAP-ENC:arrayType' 'xsd:ur-type[2]') 649 | ⍝ 3 'a' 'more' (1 2⍴'xsi:type' 'xsd:string') 650 | ⍝ 3 'a' 7.5 (1 2⍴'xsi:type' 'xsd:double') 651 | ⍝ 652 | ⍝ SUBFNS: ∆MV IsSimpleValue 653 | ⍝ PVMGetVal Ancestors MLSFind (if is an API-MLS) 654 | ⍝ APL2SOAP 655 | ⍝ ----------------------------------------------------------------------------------- 656 | :If 0=⎕NC'encoding' ⋄ encoding←1 ⋄ :EndIf 657 | 658 | mv←∆MV 659 | I←1 660 | :While I≤↑⍴R ⍝ (use :WHILE instead of :FOR because we may be expanding on the fly) 661 | (content pvm)←R[I;3 4] 662 | :If content≡mv ⍝ (check this BEFORE calling IsSimpleValue so we don't try to run a potential ⎕NULL through it [⎕DR]) 663 | :If ~0≡encoding ⋄ pvm←pvm⍪'xsi:null' 1 ⋄ :EndIf 664 | R[I;3 4]←''pvm ⍝ clean up - be sure to rid ∆mv (or ⎕NULL) from the content 665 | I←I+1 666 | 667 | :ElseIf IsSimpleValue content 668 | :If ~0≡encoding 669 | :If ~content≡'' 670 | :OrIf I=↑⍴R ⋄ :OrIf ≥/R[I+0 1;1] ⍝ this means "if no descendants" (SOAP doesn't actually allow for a container to have non-empty content at its level, but we will allow it) 671 | :If 1≡encoding 672 | :If ~(⊂'xsi:type')∊pvm[;1] ⍝ if not already specified, e.g. 1 2⍴'xsi:type' 'xsd:dateTime' 673 | R[I;4]←⊂pvm⍪'xsi:type'('xsd:',(82 80 160 320 83 163 323 645 11⍳⎕DR content)⊃(4⍴⊂'string'),(3⍴⊂'int'),'double' 'boolean') ⍝ (Be sure to use 'double', not 'float', since APL "float" is 64-bit, not 32-bit.) 674 | :EndIf 675 | :Else ⍝ API-MLS 676 | :If 0≠J←encoding MLSFind R[(I Ancestors R[;1]),I;2] 677 | :AndIf ~mv≡type←'datatype'PVMGetVal(⊂J 4)⊃encoding 678 | :If ~':'∊type ⋄ type←'xsd:',type ⋄ :EndIf 679 | R[I;4]←⊂pvm⍪'xsi:type'type 680 | :EndIf 681 | :EndIf 682 | :EndIf 683 | :EndIf 684 | I←I+1 685 | 686 | :Else ⍝ we'll have to form a SOAP "array" and shove it in underneath this row 687 | mls←APL2SOAP content 688 | R[I;3]←⊂'' ⍝ clear it out 689 | mls[;1]←mls[;1]+R[I;1] ⍝ adjust to fit under this parent 690 | R←(I↑[1]R)⍪mls⍪I↓[1]R 691 | I←I+1+↑⍴mls ⍝ move on to next row, adjusting for how many rows we just added 692 | :EndIf 693 | :EndWhile 694 | ∇ 695 | 696 | ∇ R←{encoding}MLS2XML mls;⍙mlchars;text;xlate;AV;apltype 697 | ⍝ Transform an MLS into XML 698 | ⍝ ----------------------------------------------------------------------------------- 699 | ⍝ SYNTAX: R←{encoding} MLS2XML mls 700 | ⍝ 701 | ⍝ ARGS/RESULT: 702 | ⍝ mls - fully-formed MLS 703 | ⍝ encoding - type of encoding for the resulting XML. 704 | ⍝ It can be one of the following: 705 | ⍝ '' - don't use any encoding 706 | ⍝ 'UTF-8' - this is the default 707 | ⍝ 'UTF-16', 'UTF-32' - can only be used in Dyalog 12 or later 708 | ⍝ R - XML 709 | ⍝ 710 | ⍝ SUBFNS: APLType ∆AV ∆MV 711 | ⍝ ⍙MLS2XML ⍙MLS2XML_SprTags ⍙MLS2XML_Beg ⍙MLS2XML_PVM ⍙MLS2XML_End MLS 712 | ⍝ TextRepl 713 | ⍝ UTF8Encode (unless using Dyalog 12) 714 | ⍝ ----------------------------------------------------------------------------------- 715 | :If 0=⎕NC'encoding' ⋄ encoding←'UTF-8' ⋄ :EndIf 716 | 717 | mls[;1]←mls[;1]-↑mls ⍝ adjust since ⎕XML uses depth-origin of 0 because it always has exactly 1 root (unless empty, of course) 718 | R←('whitespace' 'preserve')('markup' 'preserve')('unknown-entity' 'preserve')⎕XML mls ⍝ ['whitespace' 'preserve'] in this context actually means to NOT add whitespace/formatting to the result 719 | :If ~''≡encoding ⋄ R←⎕UCS encoding ⎕UCS R ⋄ :EndIf 720 | ∇ 721 | 722 | ∇ R←mls MLSFind path;B 723 | ⍝ Find the first matching path in some MLS 724 | ⍝∇∇{*:⎕ERROR 'DOMAIN ERROR'} 725 | ⍝ ----------------------------------------------------------------------------------- 726 | ⍝ SYNTAX: R←mls MLSFind path 727 | ⍝ 728 | ⍝ ARGS/RESULT: 729 | ⍝ path - hierarchical path to find, e.g. 'Parent' 'Child' 'Grandchild' 730 | ⍝ mls - fully formed MLS to find the path in (only the first 2 columns need to 731 | ⍝ be passed) 732 | ⍝ R - first row number of where the path is found; 0 if not found. 733 | ⍝ 734 | ⍝ NOTES: 735 | ⍝ - This does not currently work on an MLS that has multiple tags in a single element, 736 | ⍝ e.g. 1 4⍴1 (,¨'b' 'u') 'somtext' ∆epvm 737 | ⍝ ----------------------------------------------------------------------------------- 738 | 739 | :If 0∊⍴mls ⋄ R←0 ⋄ :Return ⋄ :EndIf 740 | 741 | :If 82=⎕DR path 742 | :If (↑⍴mls) bolt now with the value attached. 778 | R←R,pvm[J;2] 779 | :Return 780 | :EndIf 781 | :Until I=⍴ancestors 782 | R←0 '' ⍝ wasn't found 783 | ∇ 784 | 785 | ∇ R←mls MLSSubset rarg;defval;path 786 | ⍝ Get a descendant subset of a passed MLS, starting with the row or path 787 | ⍝ ----------------------------------------------------------------------------------- 788 | ⍝ SYNTAX: 1) R←mls MLSSubset path {defval} 789 | ⍝ 2) R←mls MLSSubset row 790 | ⍝ 791 | ⍝ ARGS/RESULT: 792 | ⍝ path - hierarchical path to find, e.g. 'Parent' 'Child' 'Grandchild' 793 | ⍝ defval - default value. This is returned as the result if the path is not found. 794 | ⍝ Default: ∆MV 795 | ⍝ row - scalar row number of the MLS (instead of finding the path) 796 | ⍝ mls - fully formed MLS 797 | ⍝ R - descendant subset MLS (depths are preserved) 798 | ⍝ 799 | ⍝ SUBFNS: ∆MV MLSFind DescendantsAndSelf 800 | ⍝ ----------------------------------------------------------------------------------- 801 | :If 0<≡rarg 802 | :If 3≤≡rarg ⋄ (path defval)←rarg 803 | :Else ⋄ (path defval)←rarg ∆MV 804 | :EndIf 805 | rarg←mls MLSFind path 806 | :If 0=rarg ⋄ R←defval ⋄ :Return ⋄ :EndIf 807 | :EndIf 808 | R←mls[rarg DescendantsAndSelf mls[;1];] 809 | ∇ 810 | 811 | ∇ R←MakePVP R 812 | :If 0=⍴⍴R ⍝ (check for Dyalog because of prototypes) 813 | R←0⍴⊂'' 814 | :ElseIf 2≠⍴R 815 | R←(↑R)(1↓R) 816 | :EndIf 817 | ∇ 818 | 819 | ∇ R←prop PVMGetVal pvm;B;defval;I;mv 820 | ⍝ Return the value of the specified property in the PVM; default to specified value or to ∆MV 821 | ⍝ ----------------------------------------------------------------------------------- 822 | :If B←1<≡prop ⋄ (prop defval)←prop ⋄ :EndIf 823 | 824 | mv←∆MV 825 | :If (↑⍴pvm)≥I←pvm[;1]⍳⊂prop 826 | R←(⊂I 2)⊃pvm 827 | :If B ⋄ :AndIf mv≡R ⍝ we should still override with defval if the value in the is just ∆mv 828 | R←defval 829 | :EndIf 830 | :ElseIf B 831 | R←defval 832 | :Else 833 | R←mv 834 | :EndIf 835 | ∇ 836 | 837 | ∇ R←props PVMGetVals pvm;B;I;mv 838 | ⍝ Return the values of the specified properties in the PVM; default to specified respective value or to ∆MV 839 | ⍝ ----------------------------------------------------------------------------------- 840 | mv←⊂∆MV 841 | :If 2=≡props 842 | R←(pvm[;2],mv)[pvm[;1]⍳props] 843 | :Else 844 | ⍝ Some default values were passed with one or more properties. 845 | pvm←(~pvm[;2]∊mv)⌿pvm ⍝ don't allow a value of ∆mv in the take precedence over a default value 846 | I←WHERE B←1=≡¨props 847 | props[I]←⊂[2]props[I],[1.5]mv 848 | props[I]←MakePVP¨props[I←WHERE~B] 849 | (props R)←⊂[1]⊃props 850 | I←pvm[;1]⍳props 851 | B←I≤↑⍴pvm 852 | R[WHERE B]←pvm[B/I;2] 853 | :EndIf 854 | ∇ 855 | 856 | ∇ R←I Parent dv 857 | ⍝ Return the index of the parent for some specified index 858 | ⍝ ----------------------------------------------------------------------------------- 859 | ⍝ SYNTAX: R←I Parent dv 860 | ⍝ 861 | ⍝ ARGS/RESULT: 862 | ⍝ dv - depth vector 863 | ⍝ I - index to find the parent of 864 | ⍝ R - index of the parent 865 | ⍝ ----------------------------------------------------------------------------------- 866 | R←I-(⌽(I-1)↑dv)⍳dv[I]-1 867 | ∇ 868 | 869 | ∇ R←{larg}PrepareWSDL rarg;⎕IO;api;decl;pvm;encoding;decl2 870 | ⍝ Prepare a WSDL document given a description of the API (cover for API2WSDL) 871 | ⍝ ----------------------------------------------------------------------------------- 872 | ⍝ SYNTAX: R←{encoding} {decl} PrepareWSDL api pvm 873 | ⍝ 874 | ⍝ ARGS/RESULT: 875 | ⍝ api - see API2WSDL 876 | ⍝ pvm - see API2WSDL 877 | ⍝ encoding - see MLS2XML 878 | ⍝ decl - additional processing instructions, e.g. for XSLT 879 | ⍝ R - XML form of the result returned from API2WSDL 880 | ⍝ 881 | ⍝ SUBFNS: APLType MLS2XML API2WSDL 882 | ⍝ ----------------------------------------------------------------------------------- 883 | ⎕IO←1 884 | ⎕SHADOW'⎕ML' 885 | ⎕ML←3 ⍝ Protect. Even though we set ⎕ML to 3 in this namespace, a caller could localize it and then run ⎕CS, thereby setting it globally here.) 886 | 887 | (api pvm)←rarg 888 | 889 | :If 0=⎕NC'larg' ⋄ (encoding decl2)←'UTF-8' '' 890 | :ElseIf 82=⎕DR larg ⋄ (encoding decl2)←larg'' 891 | :Else ⋄ (encoding decl2)←larg 892 | :EndIf 893 | 894 | decl←'' 897 | R←decl,decl2,encoding MLS2XML pvm API2WSDL api 898 | ∇ 899 | 900 | ∇ R←RepairDV dv;J;I 901 | ⍝ For a valid depth vector that had some elements removed, normalize it 902 | ⍝ ----------------------------------------------------------------------------------- 903 | dv←dv+1-⌊/dv ⍝ normalize 904 | I←⍳0⌈⌈/dv 905 | J←⍳⍴dv 906 | R←+/2 get as APL data 952 | R←1(SOAP2APL mls) 953 | :Else ⍝ the top-level is a natural MLS (there may be some embedded arrays but SOAP2MLS handles that) 954 | :If 0=⎕NC'decoding' ⋄ decoding←1 ⋄ :EndIf 955 | R←1(decoding SOAP2MLS mls) 956 | :EndIf 957 | :EndIf 958 | ∇ 959 | 960 | ∇ R←{decoding}SOAP2MLS R;I;mv;D;content;pvm;type;apimls;B;isAPI;tag;J;strippvm;PVM 961 | ⍝ Transform a SOAP-MLS into an MLS that contains normalized/datatype'd data 962 | ⍝ ----------------------------------------------------------------------------------- 963 | ⍝ SYNTAX: R←{decoding} SOAP2MLS mls 964 | ⍝ 965 | ⍝ ARGS/RESULT: 966 | ⍝ mls - SOAP-MLS 967 | ⍝ decoding - this is the type of decoding to perform. Default: 1 968 | ⍝ 0 - no decoding. Just form an MLS without applying any data 969 | ⍝ transformations. 970 | ⍝ 1 - expect datatype tagging for each element (except containers) 971 | ⍝ and transform them to their APL equivalent. For a given element, 972 | ⍝ if its PVM contains a value for 'xsi:type' that does not 973 | ⍝ transform to an APL datatype, then that attribute/value pair 974 | ⍝ is preserved in the MLS and the data/content is not affected. 975 | ⍝ apimls - expect no datatype tagging; apply data transformations 976 | ⍝ according to the passed API-MLS. 977 | ⍝ This API-MLS follows the format described in API2WSDL 978 | ⍝ (2nd or 3rd element for a given method description). 979 | ⍝ Note that regardless of what value is passed for , any 980 | ⍝ arbitrary APL data found in content is appropriately transformed. 981 | ⍝ R - MLS with the content transformed into normalized data (as specified by 982 | ⍝ the SOAP datatypes). The content of a given row can be arbitrary APL 983 | ⍝ data. SOAP allows for non-simple data using a SOAP "array" which can 984 | ⍝ be embedded in a true SOAP-MLS (the XML). 985 | ⍝ 986 | ⍝ EXAMPLE: 987 | ⍝ mls←0 4⍴0 988 | ⍝ mls←mls⍪1 'tag1' '' (0 2⍴⊂'') 989 | ⍝ mls←mls⍪2 'sub1' 'this' (1 2⍴'xsi:type' 'xsd:string') 990 | ⍝ mls←mls⍪2 'sub2' '5' (1 2⍴'xsi:type' 'xsd:int') 991 | ⍝ mls←mls⍪2 'sub3' '' (0 2⍴⊂'') 992 | ⍝ mls←mls⍪3 'array' '' (2 2⍴'xsi:type' 'SOAP-ENC:Array' 'SOAP-ENC:arrayType' 'xsd:ur-type[4]') 993 | ⍝ mls←mls⍪4 'a' '2' (1 2⍴'xsi:type' 'xsd:int') 994 | ⍝ mls←mls⍪4 'a' 'more' (1 2⍴'xsi:type' 'xsd:string') 995 | ⍝ mls←mls⍪4 'array' '' (2 2⍴'xsi:type' 'SOAP-ENC:Array' 'SOAP-ENC:arrayType' 'xsd:int[2]') 996 | ⍝ mls←mls⍪5 'a' '10' (0 2⍴⊂'') 997 | ⍝ mls←mls⍪5 'a' '20' (0 2⍴⊂'') 998 | ⍝ SOAP2MLS mls ==> 999 | ⍝ 1 'tag1' '' (0 2⍴⊂'') 1000 | ⍝ 2 'sub1' 'this' (0 2⍴⊂'') 1001 | ⍝ 2 'sub2' 5 (0 2⍴⊂'') 1002 | ⍝ 2 'sub3' (2 'more' (10 20)) (0 2⍴⊂'') 1003 | ⍝ 1004 | ⍝ SUBFNS: APLType ∆MV PVMGetVal Descendants Ancestors MLSFind RepairDV 1005 | ⍝ SOAP2APL 1006 | ⍝ ----------------------------------------------------------------------------------- 1007 | ⍝⍝⍝⍝ First, get rid of any extraneous elements (the ones that end in "_WSDLPart"). They 1008 | ⍝⍝⍝⍝ are just part of the WSDL machinery; WSDL needed them as wrappers in order to apply 1009 | ⍝⍝⍝⍝ any constraints to datatypes, e.g. 'minOccurs'. 1010 | ⍝⍝⍝:IF 1∊B←(¯9↑¨R[;2])∊⊂'_WSDLPart' ⋄ R←(~B)⌿R ⋄ R[;1]←RepairDV R[;1] ⋄ :ENDIF 1011 | 1012 | :If 0∊⍴R ⋄ :Return ⋄ :EndIf 1013 | 1014 | :If isAPI←2=⎕NC'decoding' 1015 | :If isAPI←0<≡decoding 1016 | apimls←decoding 1017 | :EndIf 1018 | :Else 1019 | decoding←1 1020 | :EndIf 1021 | 1022 | R[;1]←R[;1]-(↑R)-1 ⍝ normalize 1023 | I←1 1024 | mv←∆MV 1025 | :Repeat 1026 | (tag content pvm)←R[I;2 3 4] 1027 | strippvm←1 1028 | :If isAPI 1029 | :If (⍴tag)≥J←tag⍳':' ⍝ we're just going to remove any namespace prefixes that some SOAP encoder may have put there) 1030 | R[I;2]←⊂J↓tag 1031 | :EndIf 1032 | :If 0=J←apimls MLSFind R[(I Ancestors R[;1]),I;2] 1033 | :OrIf mv≡type←'datatype'PVMGetVal PVM←(⊂J 4)⊃apimls 1034 | :GoTo ∆end 1035 | :ElseIf (↑⍴pvm)≥J←pvm[;1]⍳⊂'xsi:null' ⋄ :AndIf (,'1')≡⍕(⊂J 2)⊃pvm ⍝ null specified? 1036 | type←'null' ⍝ so the value becomes ∆MV 1037 | :Else 1038 | strippvm←0 1039 | R[I;4]←⊂{⎕ML←1 ⋄ ↑∪↓⍵}pvm⍪PVM ⍝⍝⍝BPB add WSDL specification in if not there 1040 | :EndIf 1041 | :ElseIf 0=decoding ⍝ we'll only continue if we have some arbitrary to transform 1042 | :If ~(↑⍴pvm)≥J←pvm[;1]⍳⊂'xsi:type' ⍝ is there a datatype specified for this element? 1043 | :OrIf ~'Array'≡type←(type⍳':')↓type←(⊂J 2)⊃pvm 1044 | :GoTo ∆end 1045 | :EndIf 1046 | :ElseIf (↑⍴pvm)≥J←pvm[;1]⍳⊂'xsi:type' ⍝ is there a datatype specified for this element? 1047 | type←(⊂J 2)⊃pvm 1048 | type←(type⍳':')↓type ⍝ the type for comparison purposes 1049 | :ElseIf (↑⍴pvm)≥J←pvm[;1]⍳⊂'xsi:null' ⋄ :AndIf (,'1')≡⍕(⊂J 2)⊃pvm ⍝ null specified? 1050 | type←'null' 1051 | :Else 1052 | :GoTo ∆end 1053 | :EndIf 1054 | 1055 | :Select type 1056 | :Case 'string' ⍝ just capture it so we don't go into the :ELSE below 1057 | :CaseList 'int' 'float' 'double' 'boolean' 'integer' ⍝ 'integer' comes from an API-MLS but 'int' comes from 'xsd:int' 1058 | content←(⊂I 3)⊃R 1059 | :If (⎕DR content)∊82 80 160 320 1060 | ⍝⍝⍝BPB - this checking is disabled for now until we implement better validation 1061 | ⍝ "true" and "false" need to be supported as boolean values 1062 | ⍝ checking needs to be defered until we implement better SOAP FAULT support 1063 | ⍝ :If ''≡content ⍝ (this really shouldn't be allowed since null should have been used instead) 1064 | ⍝ R[I;3]←⊂mv 1065 | ⍝ :Else 1066 | ⍝ :If content[1]='-' ⋄ content[1]←'¯' ⋄ :EndIf 1067 | ⍝ R[I;3]←2 1⊃⎕VFI content 1068 | ⍝ :EndIf 1069 | :EndIf 1070 | :Case 'Array' ⍝ (was 'SOAP-ENC:Array') 1071 | D←I,I Descendants R[;1] 1072 | R[I-1;3]←⊂SOAP2APL R[D;] ⍝ tuck up into its parent's content 1073 | R←R[(⍳↑⍴R)~D;] ⍝ rid these descendants since they've just been absorbed 1074 | I←I-1 ⍝ account for the descendants having gone away 1075 | :GoTo ∆end ⍝ skip over the part that messes with the pvm for this row (this row has been removed by now) 1076 | 1077 | :Case 'null' 1078 | R[I;3]←⊂mv 1079 | 1080 | :Else ⍝ e.g. 'xsd:dateTime' 'xsd:base64' '' 1081 | ⍝ Leave the datatype attribute intact for the application developer to pick up on. 1082 | :GoTo ∆end 1083 | 1084 | :EndSelect 1085 | 1086 | ⍝ Remove the 'xsi:type' or 'xsi:null' attribute. We can end up with 1087 | ⍝ 0 2⍴⊂' ' or something like that (instead of the normalized 0 2⍴⊂'') 1088 | ⍝ so we'll check explicitly for whether that's about to happen and remedy. 1089 | :If strippvm 1090 | :If 1=↑⍴pvm ⋄ R[I;4]←⊂0 2⍴⊂'' 1091 | :Else ⋄ R[I;4]←⊂pvm[(⍳↑⍴pvm)~J;] 1092 | :EndIf 1093 | :EndIf 1094 | 1095 | ∆end: 1096 | :Until (↑⍴R) 'that and other' 1160 | ⍝ 1161 | ⍝ SUBFNS: APLType IsADS WHERE 1162 | ⍝ ----------------------------------------------------------------------------------- 1163 | 1164 | ⎕IO←1 ⍝ (yes, this is called by functions that set ⎕IO←0) 1165 | rk←⍴⍴xlate 1166 | 1167 | ⍝ Validate the arguments. 1168 | :If 1≠⍴⍴text ⋄ 'DOMAIN ERROR: TextRepl right argument'⎕SIGNAL 500 ⋄ :EndIf 1169 | :If ~rk∊1 2 ⋄ 'DOMAIN ERROR: TextRepl left argument'⎕SIGNAL 501 ⋄ :EndIf 1170 | 1171 | ⍝ Transform a repl-string into a normalized N×2 matrix of find/repl. 1172 | :If rk=1 1173 | xlate←1↓¨(+\xlate=↑xlate)⊂xlate 1174 | rows←0.5×⍴xlate 1175 | :If rows≠⌈rows 1176 | 'DOMAIN ERROR: TextRepl left argument'⎕SIGNAL 501 1177 | :EndIf 1178 | xlate←(rows,2)⍴xlate 1179 | :Else 1180 | rows←↑⍴xlate 1181 | :EndIf 1182 | 1183 | ⍝ Initialize. 1184 | R←text 1185 | allB←(⍴text)⍴0 1186 | avail←(⍴text)⍴1 1187 | ⍝ivec←⍳⍴text 1188 | 1189 | ⍝ For Dyalog, create a derived function for faster performance 1190 | ⍝ (also do this because there is no ⎕SS equivalent in Dyalog). 1191 | 1192 | :For row :In ⍳rows 1193 | (find repl)←xlate[row;] 1194 | B←find⍷text 1195 | findI←WHERE avail∧B ⍝ (avail^B)/ivec 1196 | R[findI]←⊂repl 1197 | allB[findI]←1 1198 | avail[¯1+∊findI+⊂⍳×/⍴find]←0 1199 | :EndFor 1200 | 1201 | R←∊(avail∨allB)/R 1202 | ∇ 1203 | 1204 | ∇ R←{larg}UTF8Decode utf8;ucs;type;bad;mult;good;b;f;len;class;i;⎕IO 1205 | ⍝ Decode a character vector that is encoded as UTF-8 1206 | ⍝ ----------------------------------------------------------------------------------- 1207 | ⍝ SYNTAX: R←{ifbad} UTF8Decode utf8 1208 | ⍝ 1209 | ⍝ ARGS/RESULT: 1210 | ⍝ utf8 - character vector that is encoded as UTF-8 1211 | ⍝ ifbad - how to treat "bad" unicode code points. A "bad" unicode code point just 1212 | ⍝ means it has no counterpart in ⎕AV. This isn't actually possible in Dyalog 12. 1213 | ⍝ The following values for are possible: 1214 | ⍝ 0 - insert the unicode code point (an integer for the decimal value) 1215 | ⍝ 1 - insert the XML form of '&#nnnn;', where nnnn is the decimal 1216 | ⍝ value for the unicode code point. However, '&' won't actually 1217 | ⍝ be used; unicode code point 27 (⎕TSESC) will be used instead. 1218 | ⍝ See ∇XMLUnescape for some discussion on why this is a reasonable convention. 1219 | ⍝ Default: 0 1220 | ⍝ R - decoded character vector (can be heterogeneous, actually; see above). 1221 | ⍝ 1222 | ⍝ NOTES: 1223 | ⍝ ∘ See also UTF8Encode. 1224 | ⍝ 1225 | ⍝ SUBFNS: 1226 | ⍝ APL+Win, Dyalog pre-12: ∆AV ∆AVU 1227 | ⍝ All: APLType 1228 | ⍝ ----------------------------------------------------------------------------------- 1229 | 1230 | R←'UTF-8'⎕UCS ⎕UCS utf8 1231 | ∇ 1232 | 1233 | ∇ R←UTF8Encode rarg;⎕IO;len;J;I;B;ucs;AV;DR 1234 | ⍝ Encode a character vector as UTF-8 1235 | ⍝ ----------------------------------------------------------------------------------- 1236 | ⍝ SYNTAX: R←UTF8Encode rarg 1237 | ⍝ 1238 | ⍝ ARGS/RESULT: 1239 | ⍝ rarg - character vector to be encoded as UTF-8. 1240 | ⍝ Actually, a given element can also be an integer for the unicode code 1241 | ⍝ point. This would only be necessary if not using Dyalog 12. Also, it 1242 | ⍝ would only ever be needed for a unicode code point that is not in ∆AVU, 1243 | ⍝ that is, it does not have a corresponding character in ⎕AV. 1244 | ⍝ This allows for roundtrips using UTF8Encode and UTF8Decode, e.g. 1245 | ⍝ p≡UTF8Decode UTF8Encode p←'AB',8734 8735,'CDE' 1246 | ⍝ R - UTF-8-encoded character vector 1247 | ⍝ 1248 | ⍝ NOTES: 1249 | ⍝ ∘ See also UTF8Decode, ∆AVU. 1250 | ⍝ ∘ Unless we're in Dyalog 12, this function obviously cannot accept any real 1251 | ⍝ unicode characters outside of ⎕AV. However, a given unicode code point can be 1252 | ⍝ passed as an integer instead. Also, the writer of some XML could just use 1253 | ⍝ '&#nnnn;' to specify such characters. 1254 | ⍝ ∘ Some characters in ⎕AV are not mapped to a unicode point (have 65533 in 1255 | ⍝ corresponding ∆AVU element) so take note that such characters will not make the 1256 | ⍝ round trip as so: a≡UTF8Decode UTF8Encode a←(∆AVU=65533)/⎕AV ==> 0 1257 | ⍝ 1258 | ⍝ SUBFNS: 1259 | ⍝ APL+Win, Dyalog pre-12: ∆AV ∆AVU 1260 | ⍝ All: APLType 1261 | ⍝ ----------------------------------------------------------------------------------- 1262 | 1263 | :If (⎕DR rarg)∊11 83 163 323 326 ⍝ this would be unusual, but it is allowed, and it nicely accommodates automated testing 1264 | B←(⎕DR¨rarg)∊11 83 163 323 1265 | (B/rarg)←⎕UCS B/rarg 1266 | :EndIf 1267 | R←⎕UCS'UTF-8'⎕UCS rarg 1268 | ∇ 1269 | 1270 | ∇ R←WHERE B 1271 | ⍝ This is good to have as a subroutine so it can be easily modified without having 1272 | ⍝ to change a lot of code that utilizes such a primitive action. 1273 | ⍝ In APL+Win, it is written as assembler (faster for "large" data and not prone to WS FULL). 1274 | ⍝ In Dyalog, we'll just use the standard idiom B/⍳⍴B, which is documented as being optimized. 1275 | R←B/⍳⍴B 1276 | ∇ 1277 | 1278 | ∇ R←{larg}XML2MLS xml;⎕IO;cell;cells;cells_2;content;curdepth;endmark;endsI;hasText;hasTextB;index_cells;inQuotes;isStartTag;isWholeTag;jumpRow;noBump;pvm;row_R;specialB;tag;wspace;AV;endmarks;begs;B;B2;I;clean;decode;S;pre;isADS;ign_bad_att;apltype;A 1279 | ⍝ Transform XML into an MLS 1280 | ⍝∇∇{*:→∆err} 1281 | ⍝ ----------------------------------------------------------------------------------- 1282 | ⍝ SYNTAX: R←{clean} {decode} {ignore_bad_attribs} XML2MLS xml 1283 | ⍝ 1284 | ⍝ ARGS/RESULT: 1285 | ⍝ xml - XML string, encoded as UTF-8 (or ASCII, of course, which is just a subset of UTF-8) 1286 | ⍝ clean - (optional) 1287 | ⍝ 0 - preserve whitespace (default) 1288 | ⍝ 1 - force deletion of extraneous whitespace unless an element's 1289 | ⍝ 'xml:space' attribute is set to 'preserve' (will look up at the 1290 | ⍝ ancestor tree to get the value). 1291 | ⍝ 2 - force deletion of extraneous whitespace. 1292 | ⍝ This is not currently available for Dyalog 12.1 or later. 1293 | ⍝ 3 - preserve whitespace but at least remove rows of the MLS that have 1294 | ⍝ '' as the tag and just whitespace for the content. 1295 | ⍝ This is not currently available for Dyalog 12.1 or later. 1296 | ⍝ decode - (optional) decode into unicode characters (or into ⎕AV if don't have unicode support yet) 1297 | ⍝ Default: 0 ==> do not decode; leave as UTF-8. 1298 | ⍝ ignore_bad_attribs - (optional) whether to ignore bad attribute sections instead 1299 | ⍝ of erroring. This is not currently available for Dyalog 12.1 or later. 1300 | ⍝ Default: 0 1301 | ⍝ R - MLS (encoded as UTF-8 unless in larg is set to 1) 1302 | ⍝ 1303 | ⍝ SUBFNS: 1304 | ⍝ APL+Win: States 1305 | ⍝ Dyalog: ⍙XML2MLS_Within 1306 | ⍝ Both: APLType IsADS ∆AV 1307 | ⍝ WHERE XMLUnescape UTF8Decode 1308 | ⍝ MLSFindAncProp (only if in is set to 1) 1309 | ⍝ 1310 | ⍝ NOTES: 1311 | ⍝ An XML parser should preserve all whitespace (unless it's outside of the root 1312 | ⍝ tag, of course). To respect the 'xml:space' attribute of any given tag and to 1313 | ⍝ perhaps tighten up an MLS, see . The 'xml:space' attribute is not really 1314 | ⍝ for parsers to respect; it is for the "application" to respect. It may have a 1315 | ⍝ value of 'default' or 'preserve'. 'default' simply means to let the application 1316 | ⍝ do whatever it deems appropriate. 'preserve' means that even the "application" 1317 | ⍝ should not delete extraneous whitespace. 1318 | ⍝ ----------------------------------------------------------------------------------- 1319 | ⎕IO←1 1320 | :Trap 0 1321 | :If 0=⎕NC'larg' ⋄ clean←decode←ign_bad_att←0 ⋄ :Else ⋄ (clean decode ign_bad_att)←3↑larg ⋄ :EndIf 1322 | 1323 | ⍝ =================================================================================== 1324 | :Select clean 1325 | :Case 0 1326 | A←'preserve' 1327 | :Case 1 1328 | A←'strip' ⍝ 'xml:space' is still respected though 1329 | :Case 2 ⍝ ⎕XML does not seem to have this option 1330 | ⍝ This will at least do the trick for automated testing purposes. 1331 | xml←(1 2⍴'xml:space="preserve"' 'xml2mls:space="preserve"')TextRepl xml 1332 | A←'strip' 1333 | :Case 3 ⍝ ⎕XML does not seem to have this option ==> accommodate below though, for testing 1334 | A←'preserve' 1335 | :EndSelect 1336 | 1337 | R←('whitespace'A)('markup' 'preserve')('unknown-entity' 'preserve')⎕XML xml 1338 | 1339 | :If 0∊⍴R 1340 | R←0 4⍴0 ⍝ (prototype for ⎕XML is 0 5⍴⊂⍬) 1341 | :Else 1342 | R←4↑[2]R 1343 | R[;1]←R[;1]+1 ⍝ adjust since ⎕XML uses depth-origin of 0; it always has exactly 1 root (unless empty, of course) 1344 | 1345 | :If clean=2 ⍝ undo our temporary kludge for allowing automated testing to run 1346 | :For I :In ⍳↑⍴R 1347 | pvm←(⊂I 4)⊃R 1348 | :If (↑⍴pvm)≥A←pvm[;1]⍳⊂'xml2mls:space' 1349 | pvm[A;1]←⊂'xml:space' 1350 | R[I;4]←⊂pvm 1351 | :EndIf 1352 | :EndFor 1353 | :ElseIf clean=3 ⍝ fixup so automated testing will work ==> ⍝ remove rows that have an empty tag and "empty" content 1354 | :AndIf 1∊B←R[;2]∊⊂'' 1355 | :AndIf 1∊B2←∧/¨(B/R[;3])∊¨⊂∆AV[10 11 14 33] 1356 | R←(~B\B2)⌿R 1357 | :EndIf 1358 | 1359 | :If decode 1360 | I←WHERE 0≠∊⍴¨R[;3] ⍝ (if we only work on the non-empty ones, we won't have to use the 1↓¨(+\A=⎕AV[1])⊂A algorithm) 1361 | A←∊⎕AV[1],¨R[I;3] 1362 | A←'UTF-8'⎕UCS ⎕UCS A 1363 | R[I;3]←(A≠⎕AV[1])⊂A ⍝ *** see if all of this is faster than: R[I;3]←(⊂'UTF-8') ⎕UCS¨ ⎕UCS¨ R[I;3] 1364 | :EndIf 1365 | :EndIf 1366 | 1367 | :Return 1368 | 1369 | :Else 1370 | :If ''≡xml~∆AV[10 11 14 33] 1371 | R←0 4⍴0 1372 | :Else 1373 | 'DOMAIN ERROR: The XML is not well-formed.'⎕SIGNAL 500 1374 | :EndIf 1375 | :EndTrap 1376 | ∇ 1377 | 1378 | ∇ R←∆AV 1379 | ⍝ Return ⎕AV in APL+Win order whether in APL+Win or in Dyalog. 1380 | ⍝ This returns ⎕AV in an order such that the 11 ⎕DR of it is in ascending order, 1381 | ⍝ which can be the real value of using ∆AV in algorithms. 1382 | R←⎕AV[⎕IO+0 43 44 58 91 92 6 7 1 9 2 10 5 3 11 235 220 221 222 223 224 225 226 227 228 229 230 8 219 238 217 250 4 204 215 216 61 12 218 13 185 248 180 169 194 168 46 156 48 49 50 51 52 53 54 55 56 57 240 193 160 162 164 172 231 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 155 158 249 167 16 237 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 123 192 125 175 95 124 126 191 190 245 246 176 177 161 163 196 195 253 254 203 96 207 64 183 198 197 205 206 181 182 159 157 186 187 188 189 166 251 243 63 62 59 60 127 252 128 247 244 47 165 209 208 45 184 179 200 199 201 202 239 94 14 173 241 210 178 174 15 242 129 97 98 99 130 131 132 100 101 134 102 103 104 105 106 107 108 135 109 110 111 112 136 171 137 113 114 115 138 116 117 139 140 141 142 118 143 144 145 146 147 148 149 150 119 151 152 153 120 154 121 211 212 122 213 170 214 232 233 234 236 93 133 255] 1383 | ∇ 1384 | 1385 | ∇ R←∆AVU 1386 | ⍝ This is like ⎕AVU in Dyalog 12. 1387 | ⍝ Return the unicode points that correspond to ⎕AV. 1388 | ⍝ In APL+Win, ∆AVU has 28 occurrences of 65533 ("REPLACEMENT CHARACTER"). 1389 | ⍝ In Dyalog, ∆AVU doesn't have any of those; they're all mapped. 1390 | ⍝ 1391 | ⍝ The following is a bit of information on some characters worthy of discussion: 1392 | ⍝ * ⍝ Dyalog uses 002A[42], as opposed to, e.g. 22C6, 2217 1393 | ⍝ - ⍝ Dyalog uses 002D[45], as opposed to, e.g. 2212 1394 | ⍝ ¯ ⍝ 00AF[175]. There's no reason to mess with this (SOAP utils convert real negative numbers to the appropriate character, '-', outside of any character conversions). 1395 | ⍝ ~ ⍝ Dyalog uses 007E[126], as opposed to, e.g. 223C 1396 | ⍝ | ⍝ Dyalog uses 007C[124], as opposed to, e.g. 2223 1397 | ⍝ (broken stile) ⍝ No reason to use anything but 00A6[166]. Dyalog doesn't have this in their ⎕AV. 1398 | ⍝ ^ ⍝ In Dyalog ⎕AV, there is a "LOGICAL AND" character for this 2227[8743] (which is 1399 | ⍝ ⍝ similar to "LOGICAL OR" at 2288[8744]). Dyalog also has a separate element, the 1400 | ⍝ ⍝ "CIRCUMFLEX ACCENT" character 005E[94]. In APL+Win, since there is only 1401 | ⍝ ⍝ one of them, we'll just use the ASCII character (∆AVU is set accordingly). 1402 | ⍝ In APL+Win, the default value of ∆AVU will incorporate what Dyalog uses, when 1403 | ⍝ applicable, in order to try to be as consistent as possible. 1404 | 1405 | R←⎕AVU 1406 | ∇ 1407 | 1408 | ∇ R←∆MV 1409 | ⍝ Return "missing value" 1410 | ⍝ 1411 | ⍝ Some problems with using ⎕NULL in Dyalog: 1412 | ⍝ ⎕DR ⎕NULL ==> DOMAIN ERROR 1413 | ⍝ ↑0⍴⎕NULL ==> NONCE ERROR (makes it difficult to use in automated testing, e.g. use of ∇GenAPLData) 1414 | ⍝ note: ↑1⍴⎕NULL ==> ⎕NULL (no problem here) 1415 | ⍝ 1416 | ⍝ You can set your own "missing value" by setting ∆mv to any homogeneous value of depth 1417 | ⍝ 1 or less. If it's not simple like that, it can get broken up by algorithms that 1418 | ⍝ inspect it and work on it recursively. 1419 | ⍝ ----------------------------------------------------------------------------------- 1420 | :If 0≠⎕NC'∆mv' ⋄ R←∆mv 1421 | :Else ⋄ R←(4⍴2)⍴'MV' ⍝2+¯2*31 1422 | :EndIf 1423 | ∇ 1424 | 1425 | ∇ R←depth ⍙APL2SOAP_Recurse data;type;dr;ch;chdr;I;B;s;A 1426 | ⍝ Private subroutine of APL2SOAP 1427 | ⍝ ----------------------------------------------------------------------------------- 1428 | ⍝ Return: 1429 | ⍝ [;1] - depth (as in "depth vector", not ≡) 1430 | ⍝ [;2] - data 1431 | ⍝ [;3] - shape 1432 | ⍝ [;4] - array-type 1433 | ⍝ 0 - non-"simple" 1434 | ⍝ 1 - "simple" 1435 | ⍝ ¯1 - special (APL character non-vec) 1436 | ⍝ ¯2 - NULL (according to what ∆MV returns) 1437 | ⍝ [;5] - DR. If array-type is 0: 1438 | ⍝ ∘ The DR of all its children are the same ==> use their DR 1439 | ⍝ and mark 0 as the DR for each child (unless a given child 1440 | ⍝ has children itself that it is already representing). 1441 | ⍝ If all of the children are arrays, use 326. 1442 | ⍝ ∘ If the children do not all have the same DR, use 807. 1443 | ⍝ If array-type is 1 or ¯1, use the DR of the data. 1444 | ⍝ If array-type is ¯2, use ¯1 as the DR. 1445 | ⍝ ----------------------------------------------------------------------------------- 1446 | ⍝ Special case for NULL. 1447 | :If data≡⍙mv ⍝ (⍙mv was localized in APL2SOAP) 1448 | R←1 5⍴depth'' 0 ¯2 ¯1 ⍝ be sure to rid ∆mv (or ⎕NULL) from the content (use '' instead of ) 1449 | :Return 1450 | :EndIf 1451 | 1452 | dr←⎕DR data 1453 | s←⍴data 1454 | 1455 | ⍝ =================================================================================== 1456 | ⍝ * APL data is considered to be a SOAP-array only if it is one of the following: 1457 | ⍝ ∘ nested 1458 | ⍝ ∘ numeric non-scalar 1459 | ⍝ * Put another way, it is NOT to be considered a SOAP-array if it is one the following: 1460 | ⍝ ∘ character vector 1461 | ⍝ ∘ numeric scalar 1462 | ⍝ * However, the following simply do not have a counterpart in SOAP: 1463 | ⍝ ∘ character data of any rank other than 1, e.g. 'A' or ⊃'this' 'that' 1464 | :Select dr 1465 | :CaseList 326 807 ⋄ type←0 1466 | :CaseList 82 80 160 320 ⋄ :If 1=⍴s ⋄ type←1 ⋄ :Else ⋄ type←¯1 ⋄ :EndIf 1467 | :Else ⋄ type←0=↑⍴s 1468 | :EndSelect 1469 | 1470 | ⍝ =================================================================================== 1471 | :If 0=type 1472 | :If 0∊s 1473 | ⍝ This is good for preserving the prototype but we want all the other attributes to remain intact. 1474 | ch←(depth+1)⍙APL2SOAP_Recurse↑1↑0⍴data 1475 | :Else 1476 | ⍝ ∇ConcatMats is faster than ↑⍪/ for large data. Using ⍪/ is especially 1477 | ⍝ inefficient simply because the bulk of the data that runs through 1478 | ⍝ ⍙APL2SOAP_Recurse is "simple" (ELSE case way down below); we could 1479 | ⍝ restructure everything to gather such 1-row results in a single step (big 1480 | ⍝ reshape). However, we seem to handle all of this more cleanly by just 1481 | ⍝ optimizing with ∇ConcatMats. 1482 | ⍝ (We could use the idiom ,/ (called "join") in Dyalog then reshape the 1483 | ⍝ data at the end of a cover function calling this.) 1484 | ⍝ch←↑⍪/(depth+1) ⍙APL2SOAP_Recurse¨ ,data 1485 | ch←ConcatMats(depth+1)⍙APL2SOAP_Recurse¨,data 1486 | :EndIf 1487 | 1488 | B←ch[;1]=depth+1 ⍝ where the direct children are (there can be other descendants here, of course) 1489 | I←WHERE B 1490 | :If 0∧.=ch[I;4] 1491 | dr←326 ⍝ use this DR to show that all of the children are also "arrays" 1492 | ch[WHERE B∧0≠ch[;4];5]←0 1493 | :ElseIf A∧.=chdr←↑A←ch[I;5] 1494 | dr←chdr ⍝ inherit the DR that is the same as all of the children 1495 | ch[WHERE B∧0≠ch[;4];5]←0 1496 | :Else 1497 | dr←807 ⍝ use this DR to show that the children are of varying datatypes (even though Dyalog doesn't actually have 807) 1498 | :EndIf 1499 | 1500 | R←depth''s type dr⍪ch ⍝ (might as well use '' as the spaceholder since it is appropriate for the final result in the calling function) 1501 | 1502 | :Else 1503 | R←1 5⍴depth data s type dr 1504 | 1505 | :EndIf 1506 | ∇ 1507 | 1508 | ∇ R←larg ⍙DecodeMethod xml;noCheckArray;decoding;mls;D;api;type;methods;B;J;I;A;method;mpvm;envns 1509 | ⍝ Private subroutine of DecodeRequest and DecodeResponse - Decode a SOAP-XML method/data 1510 | ⍝ ----------------------------------------------------------------------------------- 1511 | ⍝ SYNTAX: R←decoding noCheckArray ⍙DecodeMethod xml 1512 | ⍝ 1513 | ⍝ ARGS/RESULT: 1514 | ⍝ xml - SOAP-XML that is intended as a complete method-call 1515 | ⍝ decoding - applies when the XML yields an MLS (as opposed to arbitary APL data) 1516 | ⍝ This is the type of decoding to perform. Default: 1 1517 | ⍝ 0 - no decoding. Just form an MLS without applying any data 1518 | ⍝ transformations. 1519 | ⍝ 1 - expect datatype tagging for each element (except containers) 1520 | ⍝ and transform them to their APL equivalent. For a given element, 1521 | ⍝ if its PVM contains a value for 'xsi:type' that does not 1522 | ⍝ transform to an APL datatype, then that attribute/value pair 1523 | ⍝ is preserved in the MLS and the data/content is not affected. 1524 | ⍝ [api][type] - expect no datatype tagging; apply data transformations 1525 | ⍝ according to the passed API: 1526 | ⍝ api - associated API for any method that may be passed in . 1527 | ⍝ This API follows the format described in API2WSDL. 1528 | ⍝ type - 0-request, 1-response. Note, this only needs to be passed 1529 | ⍝ to determine which element to pick from the relevant 1530 | ⍝ method's api-structure. 1531 | ⍝ Note that regardless of what value is passed for , any 1532 | ⍝ arbitrary APL data found in content is appropriately transformed. 1533 | ⍝ noCheckArray - When not passed or set to 0, run the SOAP data through SOAP2Data 1534 | ⍝ in order to determine whether the data is a SOAP array (intended 1535 | ⍝ as some arbitrary APL) or it is some arbitrary XML (intended as an 1536 | ⍝ MLS). It can generally be determined if the data is for conversion 1537 | ⍝ to arbitrary APL (should be run through SOAP2APL) by seeing if the 1538 | ⍝ top-level element attribute 'xsi:type' is set to 'SOAP-ENC:Array'. 1539 | ⍝ However, the following is not a SOAP array and you may or may not 1540 | ⍝ want it to be slated for conversion to APL. 1541 | ⍝ 120 ⍝ (can get this by running: MLS2XML APL2SOAP 120) 1542 | ⍝ Hence, the reason for needing this argument. 1543 | ⍝ R - [1] - success boolean 1544 | ⍝ [2] - if success (R[1]=1): 1545 | ⍝ [1] - name of the method 1546 | ⍝ [2] - data for the method (as its argument or as its result) 1547 | ⍝ [3] - PVM for the attributes applied to the method, 1548 | ⍝ e.g. ==> 1 2⍴'xmlns' '...' 1549 | ⍝ if failure (R[1]=0): 1550 | ⍝ 3-element vector describing a SOAP Fault (see SOAPFault) 1551 | ⍝ 1552 | ⍝ SUBFNS: APLType XML2MLS Descendants SOAP2Data SOAP2APL 1553 | ⍝ ----------------------------------------------------------------------------------- 1554 | (decoding noCheckArray)←larg 1555 | 1556 | :Trap 0 1557 | mls←3 1 XML2MLS xml 1558 | :Else 1559 | I←1 ⋄ :GoTo ∆invalid 1560 | :EndTrap 1561 | 1562 | ⍝ The only child of the body is the function name element. The children of the 1563 | ⍝ the function name element make up the argument to the function (I don't think 1564 | ⍝ there are rows in the MLS beyond those children but we'll use Descendants 1565 | ⍝ to be safe). 1566 | 1567 | :If 0∊⍴envns←(<\mls[;2]EndsWith¨⊂':Envelope')/mls[;2] ⍝ find the Envelope tag 1568 | I←4 ⋄ :GoTo ∆invalid 1569 | :Else 1570 | envns←↑envns 1571 | envns←(envns⍳':')↑envns ⍝ grab the namespace name 1572 | :EndIf 1573 | 1574 | :If (↑⍴mls) is intended to be an MLS (see in Data2SOAP). 1650 | ⍝ encoding - This is applicable when is 1. 1651 | ⍝ 0 - do not apply any datatype tagging to any elements (presumably 1652 | ⍝ the receiving end will know how to work it out based on the 1653 | ⍝ API or WSDL) 1654 | ⍝ 1 - apply datatype tagging to each element according to its APL 1655 | ⍝ datatype. However, for a given element, if its PVM contains the 1656 | ⍝ attribute 'xsi:type', then its value is preserved (it's not 1657 | ⍝ overwritten with the mapped APL datatype). 1658 | ⍝ [api][type] - apply datatype tagging according to the passed API: 1659 | ⍝ api - associated API for any method that may be passed in rarg. 1660 | ⍝ This API follows the format described in API2WSDL. 1661 | ⍝ type - 0-request, 1-response. Note, this only needs to be passed 1662 | ⍝ to determine which element to pick from the relevant 1663 | ⍝ method's api-structure. 1664 | ⍝ Observation: If all of the elements' datatypes are native to APL, 1665 | ⍝ then the 3rd format for will yield the same result as 1666 | ⍝ =1. It can be quite advantageous to use an API since the 1667 | ⍝ application-developer can create new datatypes, e.g. a date (as an 1668 | ⍝ APL string), and it will get "transformed" by virtue of getting tagged 1669 | ⍝ with a valid SOAP datatype that means something to a consumer of the 1670 | ⍝ SOAP. Of course, the application-developer can add the tag himself 1671 | ⍝ (in the PVM) when constructing his MLS, but it is more elegant to not 1672 | ⍝ have to worry about that and just let the "machinery" handle such details. 1673 | ⍝ xmlencoding - see MLS2XML . Default: 'UTF-8' 1674 | ⍝ R - SOAP-XML that is suitable for the body an HTTP request/response 1675 | ⍝ 1676 | ⍝ SUBFNS: APLType WHERE Data2SOAP MLS2XML 1677 | ⍝ ----------------------------------------------------------------------------------- 1678 | 1679 | :If (⎕DR rarg)∊82 80 160 320 1680 | method←rarg 1681 | methoddata←'' 1682 | methodpvm←0 2⍴⊂'' 1683 | :ElseIf 1=×/⍴rarg 1684 | method←∊rarg 1685 | methoddata←'' 1686 | methodpvm←0 2⍴⊂'' 1687 | :Else 1688 | (method methoddata methodpvm)←3↑rarg,⊂0 2⍴⊂'' 1689 | (isMLS encoding xmlencoding)←larg 1690 | 1691 | :If 1<≡encoding 1692 | ⍝ Pluck out just this method's request-MLS or its response-MLS. 1693 | (api type)←encoding 1694 | methods←1⊃¨api 1695 | :If 1∊B←2=∊⍴¨⍴¨methods ⋄ (B/methods)←(⊂⊂1 2)⊃¨B/methods ⋄ :EndIf 1696 | :If 0=type ⋄ A←method ⋄ :Else ⋄ A←¯8↓method ⋄ :EndIf ⍝ if a response, have to drop trailing 'Response' 1697 | :If (⍴methods)≥I←methods⍳⊂A ⋄ encoding←(I,2+type)⊃api 1698 | :Else ⋄ encoding←0 4⍴0 1699 | :EndIf 1700 | :EndIf 1701 | 1702 | mls←isMLS encoding Data2SOAP methoddata 1703 | 1704 | ⍝ Convert real negative numbers to charvecs so that we can use the hyphen/minus 1705 | ⍝ character instead of the high-minus sign. It may be the case that some character 1706 | ⍝ conversion is performed on the result of this and it takes care of that conversion 1707 | ⍝ but we shouldn't depend on that. 1708 | B←(⎕DR¨mls[;3])∊83 163 323 645 1709 | ⍝ We thought about using the following instead but it doesn't take care of 1710 | ⍝ changing '¯' for the ∆MV when it returns the typical ∆mv instead of ⎕NULL. We 1711 | ⍝ really should never have a SOAP-MLS carry ∆MV (∆mv or ⎕NULL) in it at all now 1712 | ⍝ that we're using SOAP 'null' attributes to properly describe it. 1713 | ⍝B←323=∆DT¨ mls[;3] 1714 | :If 1∊B 1715 | I←WHERE B 1716 | mls[I;3]←⍕¨mls[I;3] 1717 | mls[I;3]←{res←⍵ ⋄ ((res='¯')/res)←'-' ⋄ res}¨mls[I;3] 1718 | :EndIf 1719 | 1720 | methoddata←xmlencoding MLS2XML mls 1721 | 1722 | :EndIf 1723 | 1724 | ⍝ Be sure to at least accommodate attribute/value pairs since they "could" follow 1725 | ⍝ the method name (passed and not being placed in the methodpvm). 1726 | I←¯1+method⍳' ' 1727 | etag←I↑method 1728 | stag←etag,I↓method 1729 | 1730 | :If 0≠↑⍴methodpvm ⋄ stag←stag,¯5↓2↓MLS2XML 1 4⍴1 'a' ''methodpvm ⋄ :EndIf 1731 | 1732 | R←'' 1733 | R←R,'<',stag,'>' 1734 | R←R,methoddata 1735 | R←R,'' 1736 | ∇ 1737 | 1738 | ∇ R←larg ⍙SOAP2APL_Recurse rarg;A;I;J;pvm;shape;type;type_parent;B 1739 | ⍝ Private subroutine of SOAP2APL 1740 | ⍝ ----------------------------------------------------------------------------------- 1741 | (I type_parent)←larg 1742 | (R pvm)←rarg 1743 | 1744 | ⍝ Determine the type. 1745 | :If (↑⍴pvm)≥J←⌊/pvm[;1]⍳'xsi:type' 'type' ⍝ is there a datatype specified for this element? 1746 | type←(⊂J 2)⊃pvm 1747 | :ElseIf (↑⍴pvm)≥J←pvm[;1]⍳⊂'xsi:null' ⋄ :AndIf (,'1')≡⍕(⊂J 2)⊃pvm ⍝ null specified? (check this before checking on parent) 1748 | type←'null' 1749 | :Else 1750 | type←type_parent ⍝ perhaps our parent contains the datatype? 1751 | :EndIf 1752 | :If (⍴type)≥J←type⍳':' ⋄ type←J↓type ⋄ :EndIf 1753 | 1754 | :Select type 1755 | :CaseList 'int' 'float' 'double' 'boolean' 1756 | :If (⎕DR R)∊82 80 160 320 1757 | :If ''≡R ⍝ (this really shouldn't be allowed since null should have been used instead) 1758 | R←∆MV 1759 | :Else 1760 | :If R[1]='-' ⋄ R[1]←'¯' ⋄ :EndIf 1761 | R←2 1⊃⎕VFI R 1762 | :EndIf 1763 | :EndIf 1764 | :Case 'Array' ⍝ (was 'SOAP-ENC:Array') 1765 | ⍝ Get the shape, if any. Also, get the parent's datatype in case we need 1766 | ⍝ it. We'll use the parent datatype in the next call (recursive) if a given 1767 | ⍝ child doesn't have its own datatype specified. 1768 | J←((-⍴A)↑¨pvm[;1])⍳⊂A←':arrayType' ⍝ (e.g. property is 'SOAP-ENC:arrayType') 1769 | :If B←(↑⍴pvm)≥J 1770 | type_parent←2⊃pvm[J;] 1771 | J←¯1+type_parent⍳'[' 1772 | shape←J↓type_parent ⍝ pick this up before we start modifying 1773 | type_parent←J↑type_parent 1774 | :If 'ur-type'≡type_parent 1775 | ⍝ 'ur-type' means the types for the children are mixed and should 1776 | ⍝ therefore be specified. Assign parent type to '' to nullify 1777 | ⍝ utilizing it in the next call. 1778 | type_parent←'' 1779 | :EndIf 1780 | :ElseIf (↑⍴pvm)≥J←pvm[;1]⍳⊂'xsi:null' ⋄ :AndIf (,'1')≡⍕(⊂J 2)⊃pvm ⍝ e.g. pvm is ⊃('xsi:type' 'SOAP-ENC:Array')('xsi:null' 1) 1781 | type_parent←'null' 1782 | :Else 1783 | type_parent←'' 1784 | :EndIf 1785 | 1786 | I←I Children ⍙depths 1787 | R←(I,¨⊂⊂type_parent)⍙SOAP2APL_Recurse¨⍙info[I] 1788 | 1789 | ⍝ If there was a shape specified, respect it. 1790 | :If B 1791 | ((shape∊',[]')/shape)←' ' 1792 | ⍝((shape∊'[]')/shape)←' ' 1793 | shape←2⊃⎕VFI shape 1794 | R←shape⍴R 1795 | :EndIf 1796 | 1797 | :Case 'string' 1798 | :If (↑⍴pvm)≥J←pvm[;1]⍳⊂'APL-ENC:shape' 1799 | shape←2⊃pvm[J;] 1800 | shape←2⊃⎕VFI shape 1801 | R←shape⍴R 1802 | :EndIf 1803 | 1804 | :Case 'null' ⍝ comes from 1 2⍴'xsi:null' 1 or from 1 2⍴'SOAP-ENC:arrayType' 'xsd:null[S...]' 1805 | R←∆MV 1806 | 1807 | ⍝:ELSE ⍝ anything unrecognized ==> no-op; leave alone 1808 | 1809 | :EndSelect 1810 | ∇ 1811 | 1812 | NoCase←{(TOUP ⍺)⍺⍺ TOUP ⍵} 1813 | 1814 | 1815 | :EndNamespace --------------------------------------------------------------------------------