- 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 Jan 18, 2025@03:20:11 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