Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: YTQRUTL

YTQRUTL.m

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