YTQRUTL ;SLC/KCM - RESTful API Utilities ; 1/25/2017
;;5.01;MENTAL HEALTH;**130,158,187**;Dec 30, 1994;Build 73
;
; External Reference ICR#
; ------------------ -----
; XLFJSON 6682
; XLFSTR 10104
; XLFUTL 2622
; XWBLIB 2238
;
;
; ^TMP("YTQRERRS",$J) place to list errors
;
; -- the HTTP request comes in the original RPC call
; HTTPREQ(1)="GET /path/goes/here?queryparam=avalue"
; HTTPREQ(2)="content-type=application/json"
; HTTPREQ(3)=""
; HTTPREQ(n)={json stuff...}
;
; -- HTTPREQ is parsed into these variables
; YTQRREQT("method")="GET"
; YTQRREQT("path")="path/goes/here"
; YTQRREQT("query")="queryparam=avalue"
; YTQRARGS(name)=value (names from path variables and query params)
; YTQRTREE(subscripts)=values (M-tree from JSON passed as request body)
;
; -- these are how the REST methods are invoked in matched routine
; GET: getCall(.YTQRARGS,.YTQRRSLT) returns .YTQRRSLT
; POST: locationURL=postCall(.YTQRARGS,.YTQRTREE) returns LOCATION header
; DELETE: delCall(.YTQRARGS) returns OK or error
;
; -- this array is built based on the return from the matched routine
; for GET: convert .YTQRTREE results into JSON
; for POST: set Location header based on return value of function
; HTTPRSP(.1)="HTTP/1.1 200 OK"
; HTTPRSP(.2)="Date: ..." (GMT date)
; HTTPRSP(.3)="Location: /path/to/resource"
; HTTPRSP(.4)="Content-Type: application/json"
; HTTPRSP(.5)="Content-Length: 42"
; HTTPRSP(.9)=""
; HTTPRSP(1..n)=JSON content
;
HANDLE(URLTAG,HTTPREQ,HTTPRSP) ; route REST request based on URL pattern
; URLTAG: tag^routine that begins mapping of path patterns to routines
; .HTTPREQ: GET/PUT/POST/DELETE request in HTTP form
; .HTTPRSP: response to caller in HTTP form
N YTQRREQT,YTQRERRS,YTQRARGS,YTQRTREE,YTQRRSLT,JSONBODY,CALL,LOCATION
K ^TMP("YTQRERRS",$J),^TMP("YTQ-JSON",$J)
D PARSHTTP(.HTTPREQ,.YTQRREQT,.JSONBODY) G:$G(YTQRERRS) XHANDLE
I $D(JSONBODY) D PARSJSON(.JSONBODY,.YTQRTREE) G:$G(YTQRERRS) XHANDLE
D MATCH(URLTAG,.CALL,.YTQRARGS) G:$G(YTQRERRS) XHANDLE
D QSPLIT(.YTQRARGS)
; treat PUT and POST the same for now
I "PUT,POST"[YTQRREQT("method") X "S LOCATION=$$"_CALL_"(.YTQRARGS,.YTQRTREE)" I 1
I YTQRREQT("method")="GET" D @(CALL_"(.YTQRARGS,.YTQRRSLT)")
I YTQRREQT("method")="DELETE" D @(CALL_"(.YTQRARGS)")
XHANDLE ; tag for exit if error
D RESPONSE(.YTQRRSLT,.LOCATION)
Q
PARSHTTP(HTTPREQ,YTQRREQT,JSONBODY) ; parse out header and body of HTTP HTTPREQ
N I,J,X
S YTQRREQT("method")=$P(HTTPREQ(1)," ")
;S YTQRREQT("path")=$P($P(HTTPREQ(1)," ",2),"?")
S YTQRREQT("path")=$P($P($P(HTTPREQ(1)," ",2,999)," HTTP/"),"?")
;S YTQRREQT("query")=$P($P(HTTPREQ(1)," ",2,999),"?",2,99)
S YTQRREQT("query")=$P($P($P(HTTPREQ(1)," ",2,999)," HTTP/"),"?",2,99)
F I=2:1 Q:'$L($G(HTTPREQ(I))) S X=HTTPREQ(I),YTQRREQT("header",$P(X,"="))=$P(X,"=",2,99)
F J=1:1 S I=$O(HTTPREQ(I)) Q:'I S JSONBODY(J)=HTTPREQ(I)
I '$D(YTQRREQT("method")) D SETERROR(400,"Missing HTTP method")
I '$D(YTQRREQT("path")) D SETERROR(400,"Missing URL path")
Q
PARSJSON(JSONBODY,YTQRTREE) ; parse JSON request into M tree structure
N ERRORS
D DECODE^XLFJSON("JSONBODY","YTQRTREE","ERRORS")
I $D(ERRORS)>0 D SETERROR(400,$G(ERRORS(1)))
Q
MATCH(TAG,CALL,ARGS) ; evaluate paths listed in TAG until match found (else 404)
; expects YTQRREQT to contain "path" and "method" nodes
; TAG contains the beginning tag where the paths are listed
; .ROUTINE contains TAG^ROUTINE, which will be called as TAG(.RESULTS,.ARGS)
; .ARGS will contain an array of any resolved path arguments
;
N I,J,X,PATH,PATHFND,RTN,PATTERN,SEGSOK,SEGPATH,SEGPTRN,ARGUMENT,TEST
S PATH=YTQRREQT("path"),PATHFND=0
S RTN=$P(TAG,"^",2),TAG=$P(TAG,"^") S:$L(RTN) RTN="^"_RTN
I $E(PATH)'="/" S PATH="/"_PATH ; ensure leading / for consistency
F I=1:1 S X=$P($T(@(TAG_"+"_I_RTN)),";;",2,99) Q:'$L(X) D Q:PATHFND
. K ARGS S PATTERN=$P(X," ",2)
. I $P(X," ")'=YTQRREQT("method") Q ; '=method -- continue
. I $L(PATTERN,"/")'=$L(PATH,"/") Q ; '=segCount -- continue
. S SEGSOK=1 F J=1:1:$L(PATH,"/") D Q:'SEGSOK ; check each path segment
. . S SEGPATH=$$URLDEC($P(PATH,"/",J),1)
. . S SEGPTRN=$$URLDEC($P(PATTERN,"/",J),1)
. . I $E(SEGPTRN)'=":" S SEGSOK=($$LOW^XLFSTR(SEGPTRN)=$$LOW^XLFSTR(SEGPATH)) Q
. . ; extract the :argument with optional pattern test
. . S SEGPTRN=$E(SEGPTRN,2,$L(SEGPTRN)) ; remove colon
. . S ARGUMENT=$P(SEGPTRN,"?"),TEST=$P(SEGPTRN,"?",2) ; get arg and test
. . I $L(TEST) S SEGSOK=(SEGPATH?@TEST) Q:'SEGSOK ; test pattern match
. . S ARGS(ARGUMENT)=SEGPATH ; ARGS(argName)=value
. I SEGSOK S PATHFND=1,CALL=$P(X," ",3)
I 'PATHFND D SETERROR(404,"No match to path found.")
Q
QSPLIT(ARGS) ; parses and decodes query fragments into ARGS
N I,X,NAME,VALUE
F I=1:1:$L(YTQRREQT("query"),"&") D
. S X=$$URLDEC($P(YTQRREQT("query"),"&",I))
. S NAME=$P(X,"="),VALUE=$P(X,"=",2,999)
. I $L(NAME) S ARGS($$LOW^XLFSTR(NAME))=VALUE
Q
RESPONSE(YTQRRSLT,LOCATION) ; build HTTPRSP based results or error
; from HANDLE, expects YTQRERRS (only defined if there were errors)
; YTQRERRS: positive number if there are errors to return
; YTQRRSLT: return value of the GET call
; LOCATION: return path of the POST call
K HTTPRSP
I $G(YTQRERRS) D BLDERRS(.HTTPRSP) QUIT
I $D(YTQRRSLT) D ; call is returning data (i.e., was a GET)
. I $E($G(YTQRRSLT),1,16)="^TMP(""YTQ-JSON""," D
. . ; contents of ^TMP("YTQ-JSON",$J) already in JSON format
. . S HTTPRSP=$NA(^TMP("YTQ-JSON",$J))
. . D ADDHDR(HTTPRSP,$$GVSIZE(HTTPRSP))
. . I '$$RTRNFMT^XWBLIB(4,1) D SETERROR(400,"Unable to return global array")
. E D
. . ; contents of YTQRRSLT need to be converted from nodes to JSON
. . D JSONRSP("YTQRRSLT",.HTTPRSP)
. . D ADDHDR("HTTPRSP",$$LVSIZE(.HTTPRSP))
E D ; call is returning location only (i.e., was a POST)
. I YTQRREQT("method")="DELETE" D ADDHDR("HTTPRSP",0) QUIT
. I '$L($G(LOCATION)) D SETERROR(400,"Location missing after POST") QUIT
. D ADDHDR("HTTPRSP",0,LOCATION)
I $G(YTQRERRS) D BLDERRS(.HTTPRSP) ; rebuild return value if we have errors
Q
JSONRSP(ROOT,HTTPRSP) ; encode response tree or error info as JSON
N ERRORS
K HTTPRSP
D ENCODE^XLFJSON(ROOT,"HTTPRSP","ERRORS")
I $D(ERRORS)>0 D SETERROR(400,"Unable to encode HTTPRSP: "_$G(ERRORS(1)))
Q
ADDHDR(DEST,SIZE,LOCATION) ; add header values to response
; S HTTPRSP(.2)="Date: "_$$GMT
I $L($G(LOCATION)) D
. S @DEST@(.3)="Location: "_$$URLENC(LOCATION)
I $G(SIZE)>0 D
. S @DEST@(.4)="Content-Type: application/json"
. S @DEST@(.5)="Content-Length: "_SIZE
S @DEST@(.1)="HTTP/1.1 "_$S($G(YTQRERRS):$$ERRHDR,1:"200 OK")
S @DEST@(.9)=""
Q
BLDERRS(HTTPRSP) ; Build response with error information
K HTTPRSP
D JSONRSP($NA(^TMP("YTQRERRS",$J,1)),.HTTPRSP)
D ADDHDR("HTTPRSP",$$LVSIZE(.HTTPRSP))
Q
;
URLDEC(X,PATH) ; Decode a URL-encoded string
; Q $ZCONVERT(X,"I","URL") ; uncomment for fastest performance on Cache
;
N I,OUT,FRAG,ASC
S:'$G(PATH) X=$TR(X,"+"," ") ; don't convert '+' in path fragment
F I=1:1:$L(X,"%") D
. I I=1 S OUT=$P(X,"%") Q
. S FRAG=$P(X,"%",I),ASC=$E(FRAG,1,2),FRAG=$E(FRAG,3,$L(FRAG))
. I $L(ASC) S OUT=OUT_$C($$BASE^XLFUTL(ASC,16,10)) ; hex to dec
. S OUT=OUT_FRAG
Q OUT
;
URLENC(X) ; Encode a string for use in a URL
; Q $ZCONVERT(X,"O","URL") ; uncomment for fastest performance on Cache
; =, &, %, +, non-printable
; {, } added JC 7-24-2012
N I,Y,Z,LAST
S Y=$P(X,"%") F I=2:1:$L(X,"%") S Y=Y_"%25"_$P(X,"%",I)
S X=Y,Y=$P(X,"&") F I=2:1:$L(X,"&") S Y=Y_"%26"_$P(X,"&",I)
S X=Y,Y=$P(X,"=") F I=2:1:$L(X,"=") S Y=Y_"%3D"_$P(X,"=",I)
S X=Y,Y=$P(X,"+") F I=2:1:$L(X,"+") S Y=Y_"%2B"_$P(X,"+",I)
S X=Y,Y=$P(X,"{") F I=2:1:$L(X,"{") S Y=Y_"%7B"_$P(X,"{",I)
S X=Y,Y=$P(X,"}") F I=2:1:$L(X,"}") S Y=Y_"%7D"_$P(X,"}",I)
S Y=$TR(Y," ","+")
S Z="",LAST=1
F I=1:1:$L(Y) I $A(Y,I)<32 D
. S CODE=$$BASE^XLFUTL($A(Y,I),10,16),CODE=$TR($J(CODE,2)," ","0")
. S Z=Z_$E(Y,LAST,I-1)_"%"_CODE,LAST=I+1
S Z=Z_$E(Y,LAST,$L(Y))
Q Z
;
LVSIZE(V) ; return the size of a local variable
Q:'$D(V) 0
N SIZE,I
S SIZE=0
I $D(V)#2 S SIZE=$L(V)
I $D(V)>1 S I="" F S I=$O(V(I)) Q:'I S SIZE=SIZE+$L(V(I))
Q SIZE
;
GVSIZE(ROOT) ; return the size of a global variable (assumes WP format)
Q:'$D(ROOT) 0 Q:'$L(ROOT) 0
N SIZE,I
S SIZE=0
I $D(@ROOT)#2 S SIZE=$L(@ROOT)
I $D(@ROOT)>1 S I=0 F S I=$O(@ROOT@(I)) Q:'I S SIZE=SIZE+$L(@ROOT@(I,0))
Q SIZE
;
SETERROR(CODE,MSG) ; set up error object
S ^TMP("YTQRERRS",$J,0)=$G(^(0))+1
S ^TMP("YTQRERRS",$J,1,"apiVersion")="1.0"
S ^TMP("YTQRERRS",$J,1,"error","code")=CODE
S ^TMP("YTQRERRS",$J,1,"error","message")=$$HTTPMSG(CODE)
S ^TMP("YTQRERRS",$J,1,"error","request")=$G(YTQRREQT("method"))_" "_$G(YTQRREQT("path"))_" "_$G(YTQRREQT("query"))
S ^TMP("YTQRERRS",$J,1,"error","errors",^TMP("YTQRERRS",$J,0),"message")=MSG
S YTQRERRS=1 ; Global indicator of errors
Q
HTTPMSG(CODE) ; return message for error code
I CODE=200 Q "OK"
I CODE=201 Q "CREATED"
I CODE=400 Q "BAD REQUEST"
I CODE=404 Q "NOT FOUND"
I CODE=500 Q "INTERNAL SERVER ERROR"
Q "UNKNOWN"
;
ERRTXT() ; return error message for non-HTTP RPC calls
N I,X
S X=""
S I=0 F S I=$O(^TMP("YTQRERRS",$J,1,"error","errors",I)) Q:'I D
. S X=X_$S($L(X):$C(13,10),1:"")
. S X=X_^TMP("YTQRERRS",$J,1,"error","errors",I,"message")
Q X
;
ERRHDR() ; return error header
N X
S X=$G(^TMP("YTQRERRS",$J,1,"error","code"))
S X=X_" "_$G(^TMP("YTQRERRS",$J,1,"error","message"))
I X'?3N1" "1.E S X="500 INTERNAL SERVER ERROR"
Q X
;
TR2WP(SRC,DEST,DELIM) ; Convert tree representation to FM WP
; SRC: glvn of source array (JSON node with wp text)
; DEST: glvn of destination array (will add [line,0] nodes)
;DELIM: string that represents line break -- defaults to $C(13,10)
N I,J,X,LN
S LN=0,X=$G(@SRC),DELIM=$G(DELIM,$C(13,10))
F J=1:1:$L(X,DELIM) S LN=LN+1,@DEST@(LN,0)=$P(X,$C(13,10),J)
S I=0 F S I=$O(@SRC@("\",I)) Q:'I D
. S X=@SRC@("\",I)
. F J=1:1:$L(X,DELIM) D
. . I J=1 S @DEST@(LN,0)=@DEST@(LN,0)_$P(X,DELIM,1) I 1
. . E S LN=LN+1,@DEST@(LN,0)=$P(X,DELIM,J)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYTQRUTL 10449 printed Dec 13, 2024@02:19:03 Page 2
YTQRUTL ;SLC/KCM - RESTful API Utilities ; 1/25/2017
+1 ;;5.01;MENTAL HEALTH;**130,158,187**;Dec 30, 1994;Build 73
+2 ;
+3 ; External Reference ICR#
+4 ; ------------------ -----
+5 ; XLFJSON 6682
+6 ; XLFSTR 10104
+7 ; XLFUTL 2622
+8 ; XWBLIB 2238
+9 ;
+10 ;
+11 ; ^TMP("YTQRERRS",$J) place to list errors
+12 ;
+13 ; -- the HTTP request comes in the original RPC call
+14 ; HTTPREQ(1)="GET /path/goes/here?queryparam=avalue"
+15 ; HTTPREQ(2)="content-type=application/json"
+16 ; HTTPREQ(3)=""
+17 ; HTTPREQ(n)={json stuff...}
+18 ;
+19 ; -- HTTPREQ is parsed into these variables
+20 ; YTQRREQT("method")="GET"
+21 ; YTQRREQT("path")="path/goes/here"
+22 ; YTQRREQT("query")="queryparam=avalue"
+23 ; YTQRARGS(name)=value (names from path variables and query params)
+24 ; YTQRTREE(subscripts)=values (M-tree from JSON passed as request body)
+25 ;
+26 ; -- these are how the REST methods are invoked in matched routine
+27 ; GET: getCall(.YTQRARGS,.YTQRRSLT) returns .YTQRRSLT
+28 ; POST: locationURL=postCall(.YTQRARGS,.YTQRTREE) returns LOCATION header
+29 ; DELETE: delCall(.YTQRARGS) returns OK or error
+30 ;
+31 ; -- this array is built based on the return from the matched routine
+32 ; for GET: convert .YTQRTREE results into JSON
+33 ; for POST: set Location header based on return value of function
+34 ; HTTPRSP(.1)="HTTP/1.1 200 OK"
+35 ; HTTPRSP(.2)="Date: ..." (GMT date)
+36 ; HTTPRSP(.3)="Location: /path/to/resource"
+37 ; HTTPRSP(.4)="Content-Type: application/json"
+38 ; HTTPRSP(.5)="Content-Length: 42"
+39 ; HTTPRSP(.9)=""
+40 ; HTTPRSP(1..n)=JSON content
+41 ;
HANDLE(URLTAG,HTTPREQ,HTTPRSP) ; route REST request based on URL pattern
+1 ; URLTAG: tag^routine that begins mapping of path patterns to routines
+2 ; .HTTPREQ: GET/PUT/POST/DELETE request in HTTP form
+3 ; .HTTPRSP: response to caller in HTTP form
+4 NEW YTQRREQT,YTQRERRS,YTQRARGS,YTQRTREE,YTQRRSLT,JSONBODY,CALL,LOCATION
+5 KILL ^TMP("YTQRERRS",$JOB),^TMP("YTQ-JSON",$JOB)
+6 DO PARSHTTP(.HTTPREQ,.YTQRREQT,.JSONBODY)
if $GET(YTQRERRS)
GOTO XHANDLE
+7 IF $DATA(JSONBODY)
DO PARSJSON(.JSONBODY,.YTQRTREE)
if $GET(YTQRERRS)
GOTO XHANDLE
+8 DO MATCH(URLTAG,.CALL,.YTQRARGS)
if $GET(YTQRERRS)
GOTO XHANDLE
+9 DO QSPLIT(.YTQRARGS)
+10 ; treat PUT and POST the same for now
+11 IF "PUT,POST"[YTQRREQT("method")
XECUTE "S LOCATION=$$"_CALL_"(.YTQRARGS,.YTQRTREE)"
IF 1
+12 IF YTQRREQT("method")="GET"
DO @(CALL_"(.YTQRARGS,.YTQRRSLT)")
+13 IF YTQRREQT("method")="DELETE"
DO @(CALL_"(.YTQRARGS)")
XHANDLE ; tag for exit if error
+1 DO RESPONSE(.YTQRRSLT,.LOCATION)
+2 QUIT
PARSHTTP(HTTPREQ,YTQRREQT,JSONBODY) ; parse out header and body of HTTP HTTPREQ
+1 NEW I,J,X
+2 SET YTQRREQT("method")=$PIECE(HTTPREQ(1)," ")
+3 ;S YTQRREQT("path")=$P($P(HTTPREQ(1)," ",2),"?")
+4 SET YTQRREQT("path")=$PIECE($PIECE($PIECE(HTTPREQ(1)," ",2,999)," HTTP/"),"?")
+5 ;S YTQRREQT("query")=$P($P(HTTPREQ(1)," ",2,999),"?",2,99)
+6 SET YTQRREQT("query")=$PIECE($PIECE($PIECE(HTTPREQ(1)," ",2,999)," HTTP/"),"?",2,99)
+7 FOR I=2:1
if '$LENGTH($GET(HTTPREQ(I)))
QUIT
SET X=HTTPREQ(I)
SET YTQRREQT("header",$PIECE(X,"="))=$PIECE(X,"=",2,99)
+8 FOR J=1:1
SET I=$ORDER(HTTPREQ(I))
if 'I
QUIT
SET JSONBODY(J)=HTTPREQ(I)
+9 IF '$DATA(YTQRREQT("method"))
DO SETERROR(400,"Missing HTTP method")
+10 IF '$DATA(YTQRREQT("path"))
DO SETERROR(400,"Missing URL path")
+11 QUIT
PARSJSON(JSONBODY,YTQRTREE) ; parse JSON request into M tree structure
+1 NEW ERRORS
+2 DO DECODE^XLFJSON("JSONBODY","YTQRTREE","ERRORS")
+3 IF $DATA(ERRORS)>0
DO SETERROR(400,$GET(ERRORS(1)))
+4 QUIT
MATCH(TAG,CALL,ARGS) ; evaluate paths listed in TAG until match found (else 404)
+1 ; expects YTQRREQT to contain "path" and "method" nodes
+2 ; TAG contains the beginning tag where the paths are listed
+3 ; .ROUTINE contains TAG^ROUTINE, which will be called as TAG(.RESULTS,.ARGS)
+4 ; .ARGS will contain an array of any resolved path arguments
+5 ;
+6 NEW I,J,X,PATH,PATHFND,RTN,PATTERN,SEGSOK,SEGPATH,SEGPTRN,ARGUMENT,TEST
+7 SET PATH=YTQRREQT("path")
SET PATHFND=0
+8 SET RTN=$PIECE(TAG,"^",2)
SET TAG=$PIECE(TAG,"^")
if $LENGTH(RTN)
SET RTN="^"_RTN
+9 ; ensure leading / for consistency
IF $EXTRACT(PATH)'="/"
SET PATH="/"_PATH
+10 FOR I=1:1
SET X=$PIECE($TEXT(@(TAG_"+"_I_RTN)),";;",2,99)
if '$LENGTH(X)
QUIT
Begin DoDot:1
+11 KILL ARGS
SET PATTERN=$PIECE(X," ",2)
+12 ; '=method -- continue
IF $PIECE(X," ")'=YTQRREQT("method")
QUIT
+13 ; '=segCount -- continue
IF $LENGTH(PATTERN,"/")'=$LENGTH(PATH,"/")
QUIT
+14 ; check each path segment
SET SEGSOK=1
FOR J=1:1:$LENGTH(PATH,"/")
Begin DoDot:2
+15 SET SEGPATH=$$URLDEC($PIECE(PATH,"/",J),1)
+16 SET SEGPTRN=$$URLDEC($PIECE(PATTERN,"/",J),1)
+17 IF $EXTRACT(SEGPTRN)'=":"
SET SEGSOK=($$LOW^XLFSTR(SEGPTRN)=$$LOW^XLFSTR(SEGPATH))
QUIT
+18 ; extract the :argument with optional pattern test
+19 ; remove colon
SET SEGPTRN=$EXTRACT(SEGPTRN,2,$LENGTH(SEGPTRN))
+20 ; get arg and test
SET ARGUMENT=$PIECE(SEGPTRN,"?")
SET TEST=$PIECE(SEGPTRN,"?",2)
+21 ; test pattern match
IF $LENGTH(TEST)
SET SEGSOK=(SEGPATH?@TEST)
if 'SEGSOK
QUIT
+22 ; ARGS(argName)=value
SET ARGS(ARGUMENT)=SEGPATH
End DoDot:2
if 'SEGSOK
QUIT
+23 IF SEGSOK
SET PATHFND=1
SET CALL=$PIECE(X," ",3)
End DoDot:1
if PATHFND
QUIT
+24 IF 'PATHFND
DO SETERROR(404,"No match to path found.")
+25 QUIT
QSPLIT(ARGS) ; parses and decodes query fragments into ARGS
+1 NEW I,X,NAME,VALUE
+2 FOR I=1:1:$LENGTH(YTQRREQT("query"),"&")
Begin DoDot:1
+3 SET X=$$URLDEC($PIECE(YTQRREQT("query"),"&",I))
+4 SET NAME=$PIECE(X,"=")
SET VALUE=$PIECE(X,"=",2,999)
+5 IF $LENGTH(NAME)
SET ARGS($$LOW^XLFSTR(NAME))=VALUE
End DoDot:1
+6 QUIT
RESPONSE(YTQRRSLT,LOCATION) ; build HTTPRSP based results or error
+1 ; from HANDLE, expects YTQRERRS (only defined if there were errors)
+2 ; YTQRERRS: positive number if there are errors to return
+3 ; YTQRRSLT: return value of the GET call
+4 ; LOCATION: return path of the POST call
+5 KILL HTTPRSP
+6 IF $GET(YTQRERRS)
DO BLDERRS(.HTTPRSP)
QUIT
+7 ; call is returning data (i.e., was a GET)
IF $DATA(YTQRRSLT)
Begin DoDot:1
+8 IF $EXTRACT($GET(YTQRRSLT),1,16)="^TMP(""YTQ-JSON"","
Begin DoDot:2
+9 ; contents of ^TMP("YTQ-JSON",$J) already in JSON format
+10 SET HTTPRSP=$NAME(^TMP("YTQ-JSON",$JOB))
+11 DO ADDHDR(HTTPRSP,$$GVSIZE(HTTPRSP))
+12 IF '$$RTRNFMT^XWBLIB(4,1)
DO SETERROR(400,"Unable to return global array")
End DoDot:2
+13 IF '$TEST
Begin DoDot:2
+14 ; contents of YTQRRSLT need to be converted from nodes to JSON
+15 DO JSONRSP("YTQRRSLT",.HTTPRSP)
+16 DO ADDHDR("HTTPRSP",$$LVSIZE(.HTTPRSP))
End DoDot:2
End DoDot:1
+17 ; call is returning location only (i.e., was a POST)
IF '$TEST
Begin DoDot:1
+18 IF YTQRREQT("method")="DELETE"
DO ADDHDR("HTTPRSP",0)
QUIT
+19 IF '$LENGTH($GET(LOCATION))
DO SETERROR(400,"Location missing after POST")
QUIT
+20 DO ADDHDR("HTTPRSP",0,LOCATION)
End DoDot:1
+21 ; rebuild return value if we have errors
IF $GET(YTQRERRS)
DO BLDERRS(.HTTPRSP)
+22 QUIT
JSONRSP(ROOT,HTTPRSP) ; encode response tree or error info as JSON
+1 NEW ERRORS
+2 KILL HTTPRSP
+3 DO ENCODE^XLFJSON(ROOT,"HTTPRSP","ERRORS")
+4 IF $DATA(ERRORS)>0
DO SETERROR(400,"Unable to encode HTTPRSP: "_$GET(ERRORS(1)))
+5 QUIT
ADDHDR(DEST,SIZE,LOCATION) ; add header values to response
+1 ; S HTTPRSP(.2)="Date: "_$$GMT
+2 IF $LENGTH($GET(LOCATION))
Begin DoDot:1
+3 SET @DEST@(.3)="Location: "_$$URLENC(LOCATION)
End DoDot:1
+4 IF $GET(SIZE)>0
Begin DoDot:1
+5 SET @DEST@(.4)="Content-Type: application/json"
+6 SET @DEST@(.5)="Content-Length: "_SIZE
End DoDot:1
+7 SET @DEST@(.1)="HTTP/1.1 "_$SELECT($GET(YTQRERRS):$$ERRHDR,1:"200 OK")
+8 SET @DEST@(.9)=""
+9 QUIT
BLDERRS(HTTPRSP) ; Build response with error information
+1 KILL HTTPRSP
+2 DO JSONRSP($NAME(^TMP("YTQRERRS",$JOB,1)),.HTTPRSP)
+3 DO ADDHDR("HTTPRSP",$$LVSIZE(.HTTPRSP))
+4 QUIT
+5 ;
URLDEC(X,PATH) ; Decode a URL-encoded string
+1 ; Q $ZCONVERT(X,"I","URL") ; uncomment for fastest performance on Cache
+2 ;
+3 NEW I,OUT,FRAG,ASC
+4 ; don't convert '+' in path fragment
if '$GET(PATH)
SET X=$TRANSLATE(X,"+"," ")
+5 FOR I=1:1:$LENGTH(X,"%")
Begin DoDot:1
+6 IF I=1
SET OUT=$PIECE(X,"%")
QUIT
+7 SET FRAG=$PIECE(X,"%",I)
SET ASC=$EXTRACT(FRAG,1,2)
SET FRAG=$EXTRACT(FRAG,3,$LENGTH(FRAG))
+8 ; hex to dec
IF $LENGTH(ASC)
SET OUT=OUT_$CHAR($$BASE^XLFUTL(ASC,16,10))
+9 SET OUT=OUT_FRAG
End DoDot:1
+10 QUIT OUT
+11 ;
URLENC(X) ; Encode a string for use in a URL
+1 ; Q $ZCONVERT(X,"O","URL") ; uncomment for fastest performance on Cache
+2 ; =, &, %, +, non-printable
+3 ; {, } added JC 7-24-2012
+4 NEW I,Y,Z,LAST
+5 SET Y=$PIECE(X,"%")
FOR I=2:1:$LENGTH(X,"%")
SET Y=Y_"%25"_$PIECE(X,"%",I)
+6 SET X=Y
SET Y=$PIECE(X,"&")
FOR I=2:1:$LENGTH(X,"&")
SET Y=Y_"%26"_$PIECE(X,"&",I)
+7 SET X=Y
SET Y=$PIECE(X,"=")
FOR I=2:1:$LENGTH(X,"=")
SET Y=Y_"%3D"_$PIECE(X,"=",I)
+8 SET X=Y
SET Y=$PIECE(X,"+")
FOR I=2:1:$LENGTH(X,"+")
SET Y=Y_"%2B"_$PIECE(X,"+",I)
+9 SET X=Y
SET Y=$PIECE(X,"{")
FOR I=2:1:$LENGTH(X,"{")
SET Y=Y_"%7B"_$PIECE(X,"{",I)
+10 SET X=Y
SET Y=$PIECE(X,"}")
FOR I=2:1:$LENGTH(X,"}")
SET Y=Y_"%7D"_$PIECE(X,"}",I)
+11 SET Y=$TRANSLATE(Y," ","+")
+12 SET Z=""
SET LAST=1
+13 FOR I=1:1:$LENGTH(Y)
IF $ASCII(Y,I)<32
Begin DoDot:1
+14 SET CODE=$$BASE^XLFUTL($ASCII(Y,I),10,16)
SET CODE=$TRANSLATE($JUSTIFY(CODE,2)," ","0")
+15 SET Z=Z_$EXTRACT(Y,LAST,I-1)_"%"_CODE
SET LAST=I+1
End DoDot:1
+16 SET Z=Z_$EXTRACT(Y,LAST,$LENGTH(Y))
+17 QUIT Z
+18 ;
LVSIZE(V) ; return the size of a local variable
+1 if '$DATA(V)
QUIT 0
+2 NEW SIZE,I
+3 SET SIZE=0
+4 IF $DATA(V)#2
SET SIZE=$LENGTH(V)
+5 IF $DATA(V)>1
SET I=""
FOR
SET I=$ORDER(V(I))
if 'I
QUIT
SET SIZE=SIZE+$LENGTH(V(I))
+6 QUIT SIZE
+7 ;
GVSIZE(ROOT) ; return the size of a global variable (assumes WP format)
+1 if '$DATA(ROOT)
QUIT 0
if '$LENGTH(ROOT)
QUIT 0
+2 NEW SIZE,I
+3 SET SIZE=0
+4 IF $DATA(@ROOT)#2
SET SIZE=$LENGTH(@ROOT)
+5 IF $DATA(@ROOT)>1
SET I=0
FOR
SET I=$ORDER(@ROOT@(I))
if 'I
QUIT
SET SIZE=SIZE+$LENGTH(@ROOT@(I,0))
+6 QUIT SIZE
+7 ;
SETERROR(CODE,MSG) ; set up error object
+1 SET ^TMP("YTQRERRS",$JOB,0)=$GET(^(0))+1
+2 SET ^TMP("YTQRERRS",$JOB,1,"apiVersion")="1.0"
+3 SET ^TMP("YTQRERRS",$JOB,1,"error","code")=CODE
+4 SET ^TMP("YTQRERRS",$JOB,1,"error","message")=$$HTTPMSG(CODE)
+5 SET ^TMP("YTQRERRS",$JOB,1,"error","request")=$GET(YTQRREQT("method"))_" "_$GET(YTQRREQT("path"))_" "_$GET(YTQRREQT("query"))
+6 SET ^TMP("YTQRERRS",$JOB,1,"error","errors",^TMP("YTQRERRS",$JOB,0),"message")=MSG
+7 ; Global indicator of errors
SET YTQRERRS=1
+8 QUIT
HTTPMSG(CODE) ; return message for error code
+1 IF CODE=200
QUIT "OK"
+2 IF CODE=201
QUIT "CREATED"
+3 IF CODE=400
QUIT "BAD REQUEST"
+4 IF CODE=404
QUIT "NOT FOUND"
+5 IF CODE=500
QUIT "INTERNAL SERVER ERROR"
+6 QUIT "UNKNOWN"
+7 ;
ERRTXT() ; return error message for non-HTTP RPC calls
+1 NEW I,X
+2 SET X=""
+3 SET I=0
FOR
SET I=$ORDER(^TMP("YTQRERRS",$JOB,1,"error","errors",I))
if 'I
QUIT
Begin DoDot:1
+4 SET X=X_$SELECT($LENGTH(X):$CHAR(13,10),1:"")
+5 SET X=X_^TMP("YTQRERRS",$JOB,1,"error","errors",I,"message")
End DoDot:1
+6 QUIT X
+7 ;
ERRHDR() ; return error header
+1 NEW X
+2 SET X=$GET(^TMP("YTQRERRS",$JOB,1,"error","code"))
+3 SET X=X_" "_$GET(^TMP("YTQRERRS",$JOB,1,"error","message"))
+4 IF X'?3N1" "1.E
SET X="500 INTERNAL SERVER ERROR"
+5 QUIT X
+6 ;
TR2WP(SRC,DEST,DELIM) ; Convert tree representation to FM WP
+1 ; SRC: glvn of source array (JSON node with wp text)
+2 ; DEST: glvn of destination array (will add [line,0] nodes)
+3 ;DELIM: string that represents line break -- defaults to $C(13,10)
+4 NEW I,J,X,LN
+5 SET LN=0
SET X=$GET(@SRC)
SET DELIM=$GET(DELIM,$CHAR(13,10))
+6 FOR J=1:1:$LENGTH(X,DELIM)
SET LN=LN+1
SET @DEST@(LN,0)=$PIECE(X,$CHAR(13,10),J)
+7 SET I=0
FOR
SET I=$ORDER(@SRC@("\",I))
if 'I
QUIT
Begin DoDot:1
+8 SET X=@SRC@("\",I)
+9 FOR J=1:1:$LENGTH(X,DELIM)
Begin DoDot:2
+10 IF J=1
SET @DEST@(LN,0)=@DEST@(LN,0)_$PIECE(X,DELIM,1)
IF 1
+11 IF '$TEST
SET LN=LN+1
SET @DEST@(LN,0)=$PIECE(X,DELIM,J)
End DoDot:2
End DoDot:1
+12 QUIT
