- XUSAML ;ISD/HGW - Kernel SAML Token Implementation ; Apr 18, 2022@15:39
- ;;8.0;KERNEL;**655,659,630,701,731,771,779**;Jul 10, 1995;Build 5
- ;Per VA Directive 6402, this routine should not be modified.
- ;
- ; Implements the Kernel SAML Token message framework for the Identification and
- ; Access Management (IAM) Single Sign-On (SSO) security model.
- ;
- ; External References:
- ; Reference to ^%DT in ICR #10003
- ; Reference to $$ATTRIB^MXMLDOM in ICR #3561
- ; Reference to $$CHILD^MXMLDOM in ICR #3561
- ; Reference to $$EN^MXMLDOM in ICR #3561
- ; Reference to $$NAME^MXMLDOM in ICR #3561
- ; Reference to $$SIBLING^MXMLDOM in ICR #3561
- ; Reference to $$TEXT^MXMLDOM in ICR #3561
- ; Reference to $$VALUE^MXMLDOM in ICR #3561
- ; Reference to DELETE^MXMLDOM in ICR #3561
- ; Reference to TEXT^MXMLDOM in ICR #3561
- ; Reference to $$FMADD^XLFDT in ICR #10103
- ; Reference to $$NOW^XLFDT in ICR #10103
- ; Reference to $$TZ^XLFDT in ICR #10103
- ; Reference to $$TITLE^XLFSTR in ICR #10104
- ; Reference to $$LOW^XLFSTR in ICR #10104
- ; Reference to $$INVERT^XLFSTR in ICR #10104
- ; Reference to $$UP^XLFSTR in ICR #10104
- ; Reference to $$VALIDATE^XUCERT Private (XU to XU)
- ; Reference to $$AUTH^XUESSO2 Private (XU to XU)
- ;
- Q
- EN(DOC) ;Function. Main entry point
- ;This function parses and processes the VA Identity and Access Management (IAM) STS SAML token
- ; (version 2.0) and returns the DUZ of the user, if found. It does not log the user into VistA.
- ; Input: DOC = Closed reference to global root containing XML document (loaded STS SAML Token)
- ; Example: S Y=$$EN^XUSAML($NA(^TMP($J,1)))
- ; Return: Fail = "-1^Error Message"
- ; Success = DUZ
- ;ZEXCEPT: XOBDATA ;environment variable
- N HDL,XASSRT,XUPN,Y
- K ^TMP("XUSAML",$J)
- S Y="-1^Error parsing STS SAML Token",XUPN="",XASSRT=""
- S XOBDATA("XOB RPC","SECURITY","STATE")="notauthenticated"
- S XOBDATA("XOB RPC","SAML","ASSERTION")="notvalidated"
- ;--- Call parser
- S HDL=$$EN^MXMLDOM(DOC,"W")
- ;p701 determine ultimate failure based on XUERR and record them
- I HDL>0 D
- . D ND(HDL,1,1,.XUPN,.XASSRT) ;Traverse and process document
- . S Y="-1^Invalid SAML assertion"
- . D VALASSRT(.XASSRT,DOC,.XUERR) ;Validate SAML assertion
- . S Y=$$FINDUSER(.XUERR)
- . D DELETE^MXMLDOM(HDL)
- I $D(XUERR)>0 S DUZ("WARNINGS")=$$WARNINGS(.XUERR)
- I +Y'>0!'$$TOKVALID(.DUZ,.XUERR) D LOGFAIL(Y,.DUZ) S Y="-1^Invalid SAML assertion"
- I +Y>0 D
- . S XOBDATA("XOB RPC","SAML","ASSERTION")="validated"
- . S XOBDATA("XOB RPC","SECURITY","STATE")="authenticated"
- K ^TMP("XUSAML",$J)
- Q Y
- ND(HDL,ND,FS,XUPN,XASSRT) ;SR. Traverse tree
- N CH,SIB,TX
- D SH(HDL,ND,.XUPN,.XASSRT)
- S CH=0
- S CH=$$CHILD^MXMLDOM(HDL,ND,CH)
- I CH D ND(HDL,CH,1,.XUPN,.XASSRT)
- Q:'FS ;Don't follow the siblings of siblings
- S SIB=ND
- F S SIB=$$SIBLING^MXMLDOM(HDL,SIB) Q:'SIB D ND(HDL,SIB,0,.XUPN,.XASSRT)
- Q
- SH(HDL,ND,XUPN,XASSRT) ;SR. Process node elements
- ;ZEXCEPT: XOBDATA ;environment variable
- N ELE,I,NM,V,VV,XCHILD,XERR,XTEXT,XVALUE
- S ELE=$$NAME^MXMLDOM(HDL,ND)
- ; -------------------- saml:Subject Event Processing ---------------------------
- I (ELE="Subject")!(ELE="saml:Subject")!(ELE="ns2:Subject") D Q ;Subject element is required
- . S XASSRT("Subject")="yes"
- ;
- ; -------------------- saml:Subject Confirmation Data Event Processing ----------
- I (ELE="SubjectConfirmationData")!(ELE="saml:SubjectConfirmationData")!(ELE="ns2:SubjectConfirmationData") D Q
- . D EL(HDL,ND,.NM,.XUPN)
- . S XASSRT("Recipient")=$O(^TMP("XUSAML",$J,"Recipient",""))
- . S XASSRT("Address")=$O(^TMP("XUSAML",$J,"Address",""))
- ;
- ; -------------------- saml:Conditions Event Processing -------------------------
- I (ELE="Conditions")!(ELE="saml:Conditions")!(ELE="ns2:Conditions") D Q
- . D EL(HDL,ND,.NM,.XUPN)
- . S XASSRT("NotBefore")=$O(^TMP("XUSAML",$J,"NotBefore",""))
- . S XASSRT("NotOnOrAfter")=$O(^TMP("XUSAML",$J,"NotOnOrAfter",""))
- ;
- ; -------------------- saml:AuthnStatement Event Processing ---------------------
- I (ELE="AuthnStatement")!(ELE="saml:AuthnStatement")!(ELE="ns2:AuthnStatement") D Q
- . D EL(HDL,ND,.NM,.XUPN)
- . S XASSRT("AuthnInstant")=$O(^TMP("XUSAML",$J,"AuthnInstant",""))
- I (ELE="AuthnContextClassRef")!(ELE="saml:AuthnContextClassRef")!(ELE="ns2:AuthnContextClassRef") D Q
- . S XUPN="AuthnContextClassRef"
- . D CH(HDL,ND,XUPN)
- . S XASSRT("AuthnContextClassRef")=$G(^TMP("XUSAML",$J,"AuthnContextClassRef"))
- ;
- ; -------------------- saml:Attribute Event Processing --------------------------
- I (ELE="Attribute")!(ELE="saml:Attribute")!(ELE="ns2:Attribute") D Q
- . S XCHILD=$$CHILD^MXMLDOM(HDL,ND) ;Identify child (AttributeValue) of node ND
- . S XTEXT="" S XERR=$$TEXT^MXMLDOM(HDL,XCHILD,$NA(VV)) ;Get text of AttributeValue
- . I XERR=1 F I=1:1 Q:'$D(VV(I)) S XTEXT=XTEXT_VV(I)
- . S NM=""
- . F S NM=$$ATTRIB^MXMLDOM(HDL,ND,NM) Q:'$L(NM) D ;Get name of Attribute
- . . I $G(NM)="Name" D
- . . . S XVALUE=$$VALUE^MXMLDOM(HDL,ND,NM)
- . . . S ^TMP("XUSAML",$J,NM,XVALUE)=XTEXT ;Set up the ^TMP global for the Attribute
- Q
- CH(HDL,ND,XUPN) ;SR. Process text node
- N I,VV,Y
- I $G(XUPN)'="" D
- . S Y=""
- . D TEXT^MXMLDOM(HDL,ND,$NA(VV))
- . I $D(VV)>2 F I=1:1 Q:'$D(VV(I)) S Y=Y_VV(I)
- . I $P(XUPN,"^",2)="" D
- . . S ^TMP("XUSAML",$J,$P(XUPN,"^",1))=Y
- . E D
- . . S ^TMP("XUSAML",$J,$P(XUPN,"^",1),$P(XUPN,"^",2))=Y
- Q
- EL(HDL,ND,NM,XUPN) ;SR. Process element
- K XUPN S (NM,XUPN)=""
- F S NM=$$ATTRIB^MXMLDOM(HDL,ND,NM) Q:'$L(NM) D
- . I $L(NM) S XUPN=NM_"^"_$$VALUE^MXMLDOM(HDL,ND,NM)
- . I $P(XUPN,"^",2)="" D
- . . S ^TMP("XUSAML",$J,$P(XUPN,"^",1))=""
- . E D
- . . S ^TMP("XUSAML",$J,$P(XUPN,"^",1),$P(XUPN,"^",2))=""
- Q
- FINDUSER(XUERR) ;Function. Identify user
- ;ZEXCEPT: XOBDATA ;environment variable
- N VISTAID,X,XARRY,XAUTH,XCTXT,XDUZ,XEDIPI,XPASS,XC,XT,XUHOME,XUIAM,Z
- I '$$AUTH^XUESSO2() S XUERR("CALL-RTN")="" Q "-1^Not an authorized calling routine"
- S XDUZ="-1^User could not be identified"
- S XERR=""
- S DUZ("REMAPP")=""
- S XUIAM=1 ;Do not trigger IAM updates
- S XARRY(1)=$$TITLE^XLFSTR($E($G(^TMP("XUSAML",$J,"Name","urn:oasis:names:tc:xspa:1.0:subject:organization")),1,50)) ;Subject Organization
- S XARRY(2)=$$LOW^XLFSTR($E($G(^TMP("XUSAML",$J,"Name","urn:oasis:names:tc:xspa:1.0:subject:organization-id")),1,50)) ;Subject Organization ID
- S XARRY(3)=$G(^TMP("XUSAML",$J,"Name","uniqueUserId")) ;Unique User ID
- S XARRY(4)=$G(^TMP("XUSAML",$J,"Name","urn:oasis:names:tc:xspa:1.0:subject:subject-id")) ;Subject ID
- S:XARRY(4)'["," XARRY(4)=$P(XARRY(4)," ",2)_","_$P(XARRY(4)," ",1)_" "_$P(XARRY(4)," ",3,99) ;P701
- S XPASS=$$IDPASS($G(XASSRT("Recipient"))) ;Application ID
- I $G(XPASS)'="" D
- . S XT=$$GETCNTXT^XUESSO2(XPASS)
- . I +XT>0 D
- . . S DUZ("REMAPP")=XT_"^"_$P($G(^XWB(8994.5,XT,0)),U) ;Identify remote application
- . . S XCTXT=$P($G(^XWB(8994.5,XT,0)),U,2)
- . . I $G(XCTXT)'="" S XARRY(5)=XPASS
- E S XARRY(5)="" ;Application ID
- S XARRY(6)=$G(^TMP("XUSAML",$J,"Name","urn:va:ad:samaccountname")) ;Network Username
- S XARRY(7)=$G(^TMP("XUSAML",$J,"Name","urn:va:vrm:iam:secid")) ;SecID
- S XARRY(8)=$G(^TMP("XUSAML",$J,"Name","urn:oasis:names:tc:xspa:2.0:subject:npi")) ;NPI
- ;S XARRY(9)=$G(^TMP("XUSAML",$J,"Name","SSN")) ;SSN is not part of STS Token specification v2.0
- S XARRY(10)=$G(^TMP("XUSAML",$J,"Name","upn")) ;Active Directory User Principle Name (UPN)
- S XARRY(11)=$G(^TMP("XUSAML",$J,"Name","email")) ;E-Mail Address
- ;S ???=$G(^TMP("XUSAML",$J,"Name","urn:oasis:names:tc:xacml:2.0:subject:role")) ;Role-based access is not yet implemented
- S XAUTH=$$LOW^XLFSTR($G(^TMP("XUSAML",$J,"Name","authnsystem"))) ;SSOi, SSOe, or Other authentication
- S XUHOME=$$LOW^XLFSTR($G(^TMP("XUSAML",$J,"Name","urn:nhin:names:saml:homeCommunityId"))) ;Home Community ID
- S XEDIPI=$G(^TMP("XUSAML",$J,"Name","edipi")) ;DoD CAC card identifier
- S DUZ("MVIICN")=$G(^TMP("XUSAML",$J,"Name","urn:va:vrn:iam:mviicn")) ;ICN
- ; p771 trim values and lock on XARRY(7) SECID or XARRY(3) unique id
- S XARRY(3)=$TR($$LOW^XLFSTR($E($$TRIM^XLFSTR(XARRY(3)),1,40)),"^","%")
- S XARRY(7)=$TR($E($$TRIM^XLFSTR(XARRY(7)),1,40),"^","%")
- S XARRY(8)=$$TRIM^XLFSTR(XARRY(8))
- S XEDIPI=$$TRIM^XLFSTR(XEDIPI)
- S XARRY(11)=$$TRIM^XLFSTR(XARRY(11))
- ;
- I (XUHOME=$P($G(^XTV(8989.3,1,200)),U,3))&(XAUTH="ssoi") D ;SSOi
- . S XARRY(3)=XARRY(7) ;UID=SecID
- . S DUZ("AUTHENTICATION")="SSOI"
- . ; p731,p771 ensure user is found before adding new one and deal with concurrent queries from JLV
- . L +^VA(200,"ASECID",XARRY(7)):$G(DILOCKTM,10) I '$T S XDUZ="-1^Could not obtain LOCK" Q
- . S XDUZ=$$FINDUSER^XUESSO2(.XARRY) ;Identify existing user with SecID
- . I XDUZ'>0 S XARRY(9)=$$MPISSN(.XARRY) ; retry with SSN from MPI
- . I $G(XARRY(9))]"" S XDUZ=$$FINDUSER^XUESSO2(.XARRY)
- . I XDUZ>0 L -^VA(200,"ASECID",XARRY(7)) Q ; user found
- . ;Add new user on the fly
- . I $G(XARRY(5))'="" D
- . . I '$$TOKVALID(.DUZ,.XUERR) S XDUZ="-1^Cannot add untrusted token-data" Q
- . . S XDUZ=$$ADDUSER^XUESSO2(.XARRY)
- . L -^VA(200,"ASECID",XARRY(7)) ; end p731,p771
- ;
- E I (XUHOME=$P($G(^XTV(8989.3,1,200)),U,3))&(XAUTH="ssoe") D ;SSOe
- . I ($L($G(XARRY(1)))<3)!($L($G(XARRY(2)))<3) S XDUZ="-1^Invalid SORG or SORGID" Q
- . S XARRY(3)=XARRY(7) ;UID=SecID
- . I +DUZ("REMAPP")>0 D
- . . S DUZ("AUTHENTICATION")="SSOE"
- . . L +^VA(200,"ASECID",XARRY(7)):$G(DILOCKTM,10) I '$T S XDUZ="-1^Could not obtain LOCK" Q ; p731,p771
- . . S XDUZ=$$FINDUSER^XUESSO2(.XARRY) ;Identify existing user with SecID
- . . I XDUZ'>0 S XARRY(9)=$$MPISSN(.XARRY) ; retry with SSN from MPI
- . . I $G(XARRY(9))]"" S XDUZ=$$FINDUSER^XUESSO2(.XARRY)
- . . I (+XDUZ<0)&($G(XARRY(5))'="") D
- . . . I '$$TOKVALID(.DUZ,.XUERR) S XDUZ="-1^Cannot add untrusted token-data" Q
- . . . S XDUZ=$$ADDUSER^XUESSO2(.XARRY) ;Add new user on the fly
- . . L -^VA(200,"ASECID",XARRY(7)) ; end p731,p771
- ;
- E I (XARRY(2)["http://")!(XARRY(2)["https://")!((XARRY(2)["urn:oid:")&(XARRY(2)'=$P($G(^XTV(8989.3,1,200)),U,3))) D ; NHIN
- . I (+DUZ("REMAPP")>0)&(XAUTH="nhin") D
- . . I $G(XARRY(3))="" S XARRY(3)=XARRY(8) ;NHIN: UID is NPI if available (preferred)
- . . I $G(XARRY(3))="" S XARRY(3)=XEDIPI ;NHIN: DoD CAC card identifier
- . . I $G(XARRY(3))="" S XARRY(3)=XARRY(11) ;NHIN: UID is e-mail if available (alternative to NPI)
- . . S DUZ("AUTHENTICATION")="NHIN"
- . . L +^VA(200,"UID",XARRY(3)):$G(DILOCKTM,10) I '$T S XDUZ="-1^Could not obtain LOCK" Q ; p731,p771
- . . S XDUZ=$$FINDUSER^XUESSO2(.XARRY) ;Identify user by NPI or Unique User ID
- . . I +XDUZ<0 D
- . . . S XARRY(8)=""
- . . . S XDUZ=$$FINDUSER^XUESSO2(.XARRY) ;Identify user by Unique User ID only
- . . . I XDUZ'>0 S XARRY(9)=$$MPISSN(.XARRY) ; retry with SSN from MPI
- . . . I $G(XARRY(9))]"" S XDUZ=$$FINDUSER^XUESSO2(.XARRY)
- . . . I (+XDUZ<0)&($G(XARRY(5))'="") D
- . . . . I '$$TOKVALID(.DUZ,.XUERR) S XDUZ="-1^Cannot add untrusted token-data" Q
- . . . . S XDUZ=$$ADDUSER^XUESSO2(.XARRY) ;Add new user on the fly
- . . L -^VA(200,"UID",XARRY(3)) ; end p731
- ;
- I XDUZ<0 D ; record NAME and SECID to error
- . S XUERR("SECID")=""
- . S $P(XDUZ,U,3)=XARRY(4),$P(XDUZ,U,4)=XARRY(7)
- Q XDUZ
- VALASSRT(XASSRT,DOC,XUERR) ;Intrinsic Subroutine. Validate SAML assertion
- ;ZEXCEPT: XOBDATA ;environment variable
- N XAUTH,XD,XNOW,XPROOF
- S XOBDATA("XOB RPC","SAML","AUTHENTICATION TYPE")=$G(^TMP("XUSAML",$J,"Name","authenticationtype"))
- S XOBDATA("XOB RPC","SAML","PROOFING AUTHORITY")=$G(^TMP("XUSAML",$J,"Name","proofingauthority"))
- S XAUTH=$$LOW^XLFSTR($G(^TMP("XUSAML",$J,"Name","authnsystem")))
- S XPROOF=XOBDATA("XOB RPC","SAML","PROOFING AUTHORITY")
- ; Verify Level of Assurance (VA requires LOA-1 through LOA-3, but higher levels are accepted)
- K XOBDATA("XOB RPC","SAML","ASSURANCE LEVEL")
- S XD=$G(^TMP("XUSAML",$J,"Name","assurancelevel")) I (+XD<1)!(+XD="") S XD=1
- S XOBDATA("XOB RPC","SAML","ASSURANCE LEVEL")=XD
- S DUZ("LOA")=XD ;Set LOA environment variable for SIGN-ON log and permissions
- ;p701
- ;I (XAUTH'="nhin")&(XPROOF'="VA-JLV") D ;temporary for pre-SSOe JLV non-VA users
- D
- . ;Validate time stamps (e.g., NotBefore, NotOnOrAfter)
- . S XNOW=$$NOW^XLFDT
- . S XD=$$CONVTIME($G(XASSRT("AuthnInstant"))) I XD=-1 D ;invalid time stamp
- . . S XUERR("AuthnI")=""
- . S XD=$$CONVTIME($G(XASSRT("NotBefore"))) I (XD=-1)!(XD>XNOW) D ;token not valid yet
- . . S XUERR("NotBefore")=""
- . S XD=$$CONVTIME($G(XASSRT("NotOnOrAfter"))) D
- . . ;N DIF1,HR,DAY
- . . ;S HR=3600,DAY=86400
- . . ;S DIF1=$$FMDIFF^XLFDT(XD,XNOW,2) ;DIF1=$$ABS^XLFMTH(DIF1)
- . . ;I (XD=-1)!(DIF1>DAY) S XUERR("EXPIRED+")="" Q
- . . I XD<XNOW S XUERR("EXPIRED")=""
- . . ;
- . I '$D(XASSRT("AuthnContextClassRef")) D
- . . S XUERR("AuthnCCR")=""
- . ;Validate Digital Signature
- . D VALIDATE^XUCERT(DOC,.XUERR)
- . ;Validate Token Issuer (Subject of X509 Certificate used to sign token)
- . I '($G(XOBDATA("XOB RPC","SAML","ISSUER"))[$P($G(^XTV(8989.3,1,200)),U,1)) D
- . . S XUERR("ISSUER")=""
- . ;Token has been validated
- Q
- IDPASS(XUA) ;Intrinsic Function. Extract Application ID
- N RETURN,XTD,XTE
- S RETURN=$P($G(XUA),"/",4,99)
- S XTD=$$DT^XLFDT
- S XTE=$$FMADD^XLFDT(XTD,7)
- I $G(RETURN)'="" D
- . S ^XTMP("XUSAMLAPPID",0)=XTE_"^"_XTD_"^SAML Application ID" ;capture and log application ID from SAML token
- . S ^XTMP("XUSAMLAPPID",0,RETURN)=""
- ;. S RETURN=$$LOW^XLFSTR(RETURN) p779
- Q RETURN
- CONVTIME(TIME) ;Intrinsic Function. Convert XML time to FileMan format
- ;ZEXCEPT: %DT ;environment variable
- N X,XD,XOUT,XT,XZ,Y
- S XZ=0 I $G(TIME)["Z" S XZ=1 ;Zulu time (GMT)
- S XD=$P($G(TIME),"T",1) ;Date
- S XD=$P(XD,"-",2)_"/"_$P(XD,"-",3)_"/"_$P(XD,"-",1) ;Convert date to MM/DD/YYYY
- S XT=$P($G(TIME),"T",2) ;Time
- I XZ=1 S XT=$P(XT,"Z",1) ;Strip "Z" from time
- S X=XD_"@"_XT S %DT="RTS"
- D ^%DT S XOUT=Y
- I XOUT=-1 Q XOUT ;Invalid date/time
- I XZ=1 S XOUT=$$FMADD^XLFDT(XOUT,0,+$E($$TZ^XLFDT,1,3),0,0) ;Adjust from GMT
- K %DT(0)
- Q XOUT
- ;
- WARNINGS(XUERR) ;
- N X,Y
- S (X,Y)=""
- F S X=$O(XUERR(X)) Q:X="" S Y=Y_X_";"
- Q Y
- ;
- TOKVALID(DUZ,XUERR) ;
- N STRICT
- ;S STRICT=$P($G(^XTV(8989.3,1,"XUS")),"^",20)
- S STRICT=+$P($G(XOPT),U,20)
- I STRICT,$D(XUERR) Q 0
- I $G(DUZ("AUTHENTICATION"))="NHIN" Q 1
- I $D(XUERR("EXPIRED")) Q 0
- ;I $D(XUERR("DIGEST")),$D(XUERR("EXPIRED+")) Q 0
- Q 1
- ;
- LOGFAIL(IEN,DUZ) ; Record failed access
- N STRICT,WARN,XUF
- S STRICT=$P($G(XOPT),U,20)
- S WARN=$S(+STRICT:"STRICT ",1:"NON-STRICT ")
- I $G(DUZ("WARNINGS"))'="" S WARN=WARN_"Failed-verifications: "_$G(DUZ("WARNINGS"))
- I $P(IEN,U,2)'="" S WARN=WARN_" ERROR:"_$P(IEN,U,2)
- I $P(IEN,U,4)'="" S WARN=WARN_". SECID not linked to existing user, SECID:"_$P(IEN,U,4)_" NAME:"_$P(IEN,U,3)_" "
- S IEN=+IEN
- I IEN>0 S XUF(.3)=IEN S X=$P($G(^VA(200,IEN,1.1)),U,2)+1,$P(^(1.1),"^",2)=X
- S XUF(.1)=$E($G(DUZ("AUTHENTICATION")))
- S XUF(.2)=$G(XUF(.2))+1,XUF(XUF(.2))=WARN
- S XUF=2
- D FILE^XUSTZ
- Q
- ;
- MPISSN(XATR) ; Return SSN found in MPI
- N SSN,XMPI,XOUT
- S SSN=""
- S:$G(XATR(7))]"" XMPI("secId")=XATR(7)
- S:$G(XATR(6))]"" XMPI("samacctnm")=XATR(6)
- S:$G(XATR(10))]"" XMPI("VAemail")=XATR(10)
- N XI F XI="secId","samacctnm","VAemail" D Q:SSN]""
- . N XIN
- . I $G(XMPI(XI))]"" S XIN(XI)=XMPI(XI) D USER^XUIAMXML(.XOUT,.XIN) S SSN=$G(XOUT("pnid"))
- Q SSN
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXUSAML 15394 printed Jan 18, 2025@03:13:15 Page 2
- XUSAML ;ISD/HGW - Kernel SAML Token Implementation ; Apr 18, 2022@15:39
- +1 ;;8.0;KERNEL;**655,659,630,701,731,771,779**;Jul 10, 1995;Build 5
- +2 ;Per VA Directive 6402, this routine should not be modified.
- +3 ;
- +4 ; Implements the Kernel SAML Token message framework for the Identification and
- +5 ; Access Management (IAM) Single Sign-On (SSO) security model.
- +6 ;
- +7 ; External References:
- +8 ; Reference to ^%DT in ICR #10003
- +9 ; Reference to $$ATTRIB^MXMLDOM in ICR #3561
- +10 ; Reference to $$CHILD^MXMLDOM in ICR #3561
- +11 ; Reference to $$EN^MXMLDOM in ICR #3561
- +12 ; Reference to $$NAME^MXMLDOM in ICR #3561
- +13 ; Reference to $$SIBLING^MXMLDOM in ICR #3561
- +14 ; Reference to $$TEXT^MXMLDOM in ICR #3561
- +15 ; Reference to $$VALUE^MXMLDOM in ICR #3561
- +16 ; Reference to DELETE^MXMLDOM in ICR #3561
- +17 ; Reference to TEXT^MXMLDOM in ICR #3561
- +18 ; Reference to $$FMADD^XLFDT in ICR #10103
- +19 ; Reference to $$NOW^XLFDT in ICR #10103
- +20 ; Reference to $$TZ^XLFDT in ICR #10103
- +21 ; Reference to $$TITLE^XLFSTR in ICR #10104
- +22 ; Reference to $$LOW^XLFSTR in ICR #10104
- +23 ; Reference to $$INVERT^XLFSTR in ICR #10104
- +24 ; Reference to $$UP^XLFSTR in ICR #10104
- +25 ; Reference to $$VALIDATE^XUCERT Private (XU to XU)
- +26 ; Reference to $$AUTH^XUESSO2 Private (XU to XU)
- +27 ;
- +28 QUIT
- EN(DOC) ;Function. Main entry point
- +1 ;This function parses and processes the VA Identity and Access Management (IAM) STS SAML token
- +2 ; (version 2.0) and returns the DUZ of the user, if found. It does not log the user into VistA.
- +3 ; Input: DOC = Closed reference to global root containing XML document (loaded STS SAML Token)
- +4 ; Example: S Y=$$EN^XUSAML($NA(^TMP($J,1)))
- +5 ; Return: Fail = "-1^Error Message"
- +6 ; Success = DUZ
- +7 ;ZEXCEPT: XOBDATA ;environment variable
- +8 NEW HDL,XASSRT,XUPN,Y
- +9 KILL ^TMP("XUSAML",$JOB)
- +10 SET Y="-1^Error parsing STS SAML Token"
- SET XUPN=""
- SET XASSRT=""
- +11 SET XOBDATA("XOB RPC","SECURITY","STATE")="notauthenticated"
- +12 SET XOBDATA("XOB RPC","SAML","ASSERTION")="notvalidated"
- +13 ;--- Call parser
- +14 SET HDL=$$EN^MXMLDOM(DOC,"W")
- +15 ;p701 determine ultimate failure based on XUERR and record them
- +16 IF HDL>0
- Begin DoDot:1
- +17 ;Traverse and process document
- DO ND(HDL,1,1,.XUPN,.XASSRT)
- +18 SET Y="-1^Invalid SAML assertion"
- +19 ;Validate SAML assertion
- DO VALASSRT(.XASSRT,DOC,.XUERR)
- +20 SET Y=$$FINDUSER(.XUERR)
- +21 DO DELETE^MXMLDOM(HDL)
- End DoDot:1
- +22 IF $DATA(XUERR)>0
- SET DUZ("WARNINGS")=$$WARNINGS(.XUERR)
- +23 IF +Y'>0!'$$TOKVALID(.DUZ,.XUERR)
- DO LOGFAIL(Y,.DUZ)
- SET Y="-1^Invalid SAML assertion"
- +24 IF +Y>0
- Begin DoDot:1
- +25 SET XOBDATA("XOB RPC","SAML","ASSERTION")="validated"
- +26 SET XOBDATA("XOB RPC","SECURITY","STATE")="authenticated"
- End DoDot:1
- +27 KILL ^TMP("XUSAML",$JOB)
- +28 QUIT Y
- ND(HDL,ND,FS,XUPN,XASSRT) ;SR. Traverse tree
- +1 NEW CH,SIB,TX
- +2 DO SH(HDL,ND,.XUPN,.XASSRT)
- +3 SET CH=0
- +4 SET CH=$$CHILD^MXMLDOM(HDL,ND,CH)
- +5 IF CH
- DO ND(HDL,CH,1,.XUPN,.XASSRT)
- +6 ;Don't follow the siblings of siblings
- if 'FS
- QUIT
- +7 SET SIB=ND
- +8 FOR
- SET SIB=$$SIBLING^MXMLDOM(HDL,SIB)
- if 'SIB
- QUIT
- DO ND(HDL,SIB,0,.XUPN,.XASSRT)
- +9 QUIT
- SH(HDL,ND,XUPN,XASSRT) ;SR. Process node elements
- +1 ;ZEXCEPT: XOBDATA ;environment variable
- +2 NEW ELE,I,NM,V,VV,XCHILD,XERR,XTEXT,XVALUE
- +3 SET ELE=$$NAME^MXMLDOM(HDL,ND)
- +4 ; -------------------- saml:Subject Event Processing ---------------------------
- +5 ;Subject element is required
- IF (ELE="Subject")!(ELE="saml:Subject")!(ELE="ns2:Subject")
- Begin DoDot:1
- +6 SET XASSRT("Subject")="yes"
- End DoDot:1
- QUIT
- +7 ;
- +8 ; -------------------- saml:Subject Confirmation Data Event Processing ----------
- +9 IF (ELE="SubjectConfirmationData")!(ELE="saml:SubjectConfirmationData")!(ELE="ns2:SubjectConfirmationData")
- Begin DoDot:1
- +10 DO EL(HDL,ND,.NM,.XUPN)
- +11 SET XASSRT("Recipient")=$ORDER(^TMP("XUSAML",$JOB,"Recipient",""))
- +12 SET XASSRT("Address")=$ORDER(^TMP("XUSAML",$JOB,"Address",""))
- End DoDot:1
- QUIT
- +13 ;
- +14 ; -------------------- saml:Conditions Event Processing -------------------------
- +15 IF (ELE="Conditions")!(ELE="saml:Conditions")!(ELE="ns2:Conditions")
- Begin DoDot:1
- +16 DO EL(HDL,ND,.NM,.XUPN)
- +17 SET XASSRT("NotBefore")=$ORDER(^TMP("XUSAML",$JOB,"NotBefore",""))
- +18 SET XASSRT("NotOnOrAfter")=$ORDER(^TMP("XUSAML",$JOB,"NotOnOrAfter",""))
- End DoDot:1
- QUIT
- +19 ;
- +20 ; -------------------- saml:AuthnStatement Event Processing ---------------------
- +21 IF (ELE="AuthnStatement")!(ELE="saml:AuthnStatement")!(ELE="ns2:AuthnStatement")
- Begin DoDot:1
- +22 DO EL(HDL,ND,.NM,.XUPN)
- +23 SET XASSRT("AuthnInstant")=$ORDER(^TMP("XUSAML",$JOB,"AuthnInstant",""))
- End DoDot:1
- QUIT
- +24 IF (ELE="AuthnContextClassRef")!(ELE="saml:AuthnContextClassRef")!(ELE="ns2:AuthnContextClassRef")
- Begin DoDot:1
- +25 SET XUPN="AuthnContextClassRef"
- +26 DO CH(HDL,ND,XUPN)
- +27 SET XASSRT("AuthnContextClassRef")=$GET(^TMP("XUSAML",$JOB,"AuthnContextClassRef"))
- End DoDot:1
- QUIT
- +28 ;
- +29 ; -------------------- saml:Attribute Event Processing --------------------------
- +30 IF (ELE="Attribute")!(ELE="saml:Attribute")!(ELE="ns2:Attribute")
- Begin DoDot:1
- +31 ;Identify child (AttributeValue) of node ND
- SET XCHILD=$$CHILD^MXMLDOM(HDL,ND)
- +32 ;Get text of AttributeValue
- SET XTEXT=""
- SET XERR=$$TEXT^MXMLDOM(HDL,XCHILD,$NAME(VV))
- +33 IF XERR=1
- FOR I=1:1
- if '$DATA(VV(I))
- QUIT
- SET XTEXT=XTEXT_VV(I)
- +34 SET NM=""
- +35 ;Get name of Attribute
- FOR
- SET NM=$$ATTRIB^MXMLDOM(HDL,ND,NM)
- if '$LENGTH(NM)
- QUIT
- Begin DoDot:2
- +36 IF $GET(NM)="Name"
- Begin DoDot:3
- +37 SET XVALUE=$$VALUE^MXMLDOM(HDL,ND,NM)
- +38 ;Set up the ^TMP global for the Attribute
- SET ^TMP("XUSAML",$JOB,NM,XVALUE)=XTEXT
- End DoDot:3
- End DoDot:2
- End DoDot:1
- QUIT
- +39 QUIT
- CH(HDL,ND,XUPN) ;SR. Process text node
- +1 NEW I,VV,Y
- +2 IF $GET(XUPN)'=""
- Begin DoDot:1
- +3 SET Y=""
- +4 DO TEXT^MXMLDOM(HDL,ND,$NAME(VV))
- +5 IF $DATA(VV)>2
- FOR I=1:1
- if '$DATA(VV(I))
- QUIT
- SET Y=Y_VV(I)
- +6 IF $PIECE(XUPN,"^",2)=""
- Begin DoDot:2
- +7 SET ^TMP("XUSAML",$JOB,$PIECE(XUPN,"^",1))=Y
- End DoDot:2
- +8 IF '$TEST
- Begin DoDot:2
- +9 SET ^TMP("XUSAML",$JOB,$PIECE(XUPN,"^",1),$PIECE(XUPN,"^",2))=Y
- End DoDot:2
- End DoDot:1
- +10 QUIT
- EL(HDL,ND,NM,XUPN) ;SR. Process element
- +1 KILL XUPN
- SET (NM,XUPN)=""
- +2 FOR
- SET NM=$$ATTRIB^MXMLDOM(HDL,ND,NM)
- if '$LENGTH(NM)
- QUIT
- Begin DoDot:1
- +3 IF $LENGTH(NM)
- SET XUPN=NM_"^"_$$VALUE^MXMLDOM(HDL,ND,NM)
- +4 IF $PIECE(XUPN,"^",2)=""
- Begin DoDot:2
- +5 SET ^TMP("XUSAML",$JOB,$PIECE(XUPN,"^",1))=""
- End DoDot:2
- +6 IF '$TEST
- Begin DoDot:2
- +7 SET ^TMP("XUSAML",$JOB,$PIECE(XUPN,"^",1),$PIECE(XUPN,"^",2))=""
- End DoDot:2
- End DoDot:1
- +8 QUIT
- FINDUSER(XUERR) ;Function. Identify user
- +1 ;ZEXCEPT: XOBDATA ;environment variable
- +2 NEW VISTAID,X,XARRY,XAUTH,XCTXT,XDUZ,XEDIPI,XPASS,XC,XT,XUHOME,XUIAM,Z
- +3 IF '$$AUTH^XUESSO2()
- SET XUERR("CALL-RTN")=""
- QUIT "-1^Not an authorized calling routine"
- +4 SET XDUZ="-1^User could not be identified"
- +5 SET XERR=""
- +6 SET DUZ("REMAPP")=""
- +7 ;Do not trigger IAM updates
- SET XUIAM=1
- +8 ;Subject Organization
- SET XARRY(1)=$$TITLE^XLFSTR($EXTRACT($GET(^TMP("XUSAML",$JOB,"Name","urn:oasis:names:tc:xspa:1.0:subject:organization")),1,50))
- +9 ;Subject Organization ID
- SET XARRY(2)=$$LOW^XLFSTR($EXTRACT($GET(^TMP("XUSAML",$JOB,"Name","urn:oasis:names:tc:xspa:1.0:subject:organization-id")),1,50))
- +10 ;Unique User ID
- SET XARRY(3)=$GET(^TMP("XUSAML",$JOB,"Name","uniqueUserId"))
- +11 ;Subject ID
- SET XARRY(4)=$GET(^TMP("XUSAML",$JOB,"Name","urn:oasis:names:tc:xspa:1.0:subject:subject-id"))
- +12 ;P701
- if XARRY(4)'[","
- SET XARRY(4)=$PIECE(XARRY(4)," ",2)_","_$PIECE(XARRY(4)," ",1)_" "_$PIECE(XARRY(4)," ",3,99)
- +13 ;Application ID
- SET XPASS=$$IDPASS($GET(XASSRT("Recipient")))
- +14 IF $GET(XPASS)'=""
- Begin DoDot:1
- +15 SET XT=$$GETCNTXT^XUESSO2(XPASS)
- +16 IF +XT>0
- Begin DoDot:2
- +17 ;Identify remote application
- SET DUZ("REMAPP")=XT_"^"_$PIECE($GET(^XWB(8994.5,XT,0)),U)
- +18 SET XCTXT=$PIECE($GET(^XWB(8994.5,XT,0)),U,2)
- +19 IF $GET(XCTXT)'=""
- SET XARRY(5)=XPASS
- End DoDot:2
- End DoDot:1
- +20 ;Application ID
- IF '$TEST
- SET XARRY(5)=""
- +21 ;Network Username
- SET XARRY(6)=$GET(^TMP("XUSAML",$JOB,"Name","urn:va:ad:samaccountname"))
- +22 ;SecID
- SET XARRY(7)=$GET(^TMP("XUSAML",$JOB,"Name","urn:va:vrm:iam:secid"))
- +23 ;NPI
- SET XARRY(8)=$GET(^TMP("XUSAML",$JOB,"Name","urn:oasis:names:tc:xspa:2.0:subject:npi"))
- +24 ;S XARRY(9)=$G(^TMP("XUSAML",$J,"Name","SSN")) ;SSN is not part of STS Token specification v2.0
- +25 ;Active Directory User Principle Name (UPN)
- SET XARRY(10)=$GET(^TMP("XUSAML",$JOB,"Name","upn"))
- +26 ;E-Mail Address
- SET XARRY(11)=$GET(^TMP("XUSAML",$JOB,"Name","email"))
- +27 ;S ???=$G(^TMP("XUSAML",$J,"Name","urn:oasis:names:tc:xacml:2.0:subject:role")) ;Role-based access is not yet implemented
- +28 ;SSOi, SSOe, or Other authentication
- SET XAUTH=$$LOW^XLFSTR($GET(^TMP("XUSAML",$JOB,"Name","authnsystem")))
- +29 ;Home Community ID
- SET XUHOME=$$LOW^XLFSTR($GET(^TMP("XUSAML",$JOB,"Name","urn:nhin:names:saml:homeCommunityId")))
- +30 ;DoD CAC card identifier
- SET XEDIPI=$GET(^TMP("XUSAML",$JOB,"Name","edipi"))
- +31 ;ICN
- SET DUZ("MVIICN")=$GET(^TMP("XUSAML",$JOB,"Name","urn:va:vrn:iam:mviicn"))
- +32 ; p771 trim values and lock on XARRY(7) SECID or XARRY(3) unique id
- +33 SET XARRY(3)=$TRANSLATE($$LOW^XLFSTR($EXTRACT($$TRIM^XLFSTR(XARRY(3)),1,40)),"^","%")
- +34 SET XARRY(7)=$TRANSLATE($EXTRACT($$TRIM^XLFSTR(XARRY(7)),1,40),"^","%")
- +35 SET XARRY(8)=$$TRIM^XLFSTR(XARRY(8))
- +36 SET XEDIPI=$$TRIM^XLFSTR(XEDIPI)
- +37 SET XARRY(11)=$$TRIM^XLFSTR(XARRY(11))
- +38 ;
- +39 ;SSOi
- IF (XUHOME=$PIECE($GET(^XTV(8989.3,1,200)),U,3))&(XAUTH="ssoi")
- Begin DoDot:1
- +40 ;UID=SecID
- SET XARRY(3)=XARRY(7)
- +41 SET DUZ("AUTHENTICATION")="SSOI"
- +42 ; p731,p771 ensure user is found before adding new one and deal with concurrent queries from JLV
- +43 LOCK +^VA(200,"ASECID",XARRY(7)):$GET(DILOCKTM,10)
- IF '$TEST
- SET XDUZ="-1^Could not obtain LOCK"
- QUIT
- +44 ;Identify existing user with SecID
- SET XDUZ=$$FINDUSER^XUESSO2(.XARRY)
- +45 ; retry with SSN from MPI
- IF XDUZ'>0
- SET XARRY(9)=$$MPISSN(.XARRY)
- +46 IF $GET(XARRY(9))]""
- SET XDUZ=$$FINDUSER^XUESSO2(.XARRY)
- +47 ; user found
- IF XDUZ>0
- LOCK -^VA(200,"ASECID",XARRY(7))
- QUIT
- +48 ;Add new user on the fly
- +49 IF $GET(XARRY(5))'=""
- Begin DoDot:2
- +50 IF '$$TOKVALID(.DUZ,.XUERR)
- SET XDUZ="-1^Cannot add untrusted token-data"
- QUIT
- +51 SET XDUZ=$$ADDUSER^XUESSO2(.XARRY)
- End DoDot:2
- +52 ; end p731,p771
- LOCK -^VA(200,"ASECID",XARRY(7))
- End DoDot:1
- +53 ;
- +54 ;SSOe
- IF '$TEST
- IF (XUHOME=$PIECE($GET(^XTV(8989.3,1,200)),U,3))&(XAUTH="ssoe")
- Begin DoDot:1
- +55 IF ($LENGTH($GET(XARRY(1)))<3)!($LENGTH($GET(XARRY(2)))<3)
- SET XDUZ="-1^Invalid SORG or SORGID"
- QUIT
- +56 ;UID=SecID
- SET XARRY(3)=XARRY(7)
- +57 IF +DUZ("REMAPP")>0
- Begin DoDot:2
- +58 SET DUZ("AUTHENTICATION")="SSOE"
- +59 ; p731,p771
- LOCK +^VA(200,"ASECID",XARRY(7)):$GET(DILOCKTM,10)
- IF '$TEST
- SET XDUZ="-1^Could not obtain LOCK"
- QUIT
- +60 ;Identify existing user with SecID
- SET XDUZ=$$FINDUSER^XUESSO2(.XARRY)
- +61 ; retry with SSN from MPI
- IF XDUZ'>0
- SET XARRY(9)=$$MPISSN(.XARRY)
- +62 IF $GET(XARRY(9))]""
- SET XDUZ=$$FINDUSER^XUESSO2(.XARRY)
- +63 IF (+XDUZ<0)&($GET(XARRY(5))'="")
- Begin DoDot:3
- +64 IF '$$TOKVALID(.DUZ,.XUERR)
- SET XDUZ="-1^Cannot add untrusted token-data"
- QUIT
- +65 ;Add new user on the fly
- SET XDUZ=$$ADDUSER^XUESSO2(.XARRY)
- End DoDot:3
- +66 ; end p731,p771
- LOCK -^VA(200,"ASECID",XARRY(7))
- End DoDot:2
- End DoDot:1
- +67 ;
- +68 ; NHIN
- IF '$TEST
- IF (XARRY(2)["http://")!(XARRY(2)["https://")!((XARRY(2)["urn:oid:")&(XARRY(2)'=$PIECE($GET(^XTV(8989.3,1,200)),U,3)))
- Begin DoDot:1
- +69 IF (+DUZ("REMAPP")>0)&(XAUTH="nhin")
- Begin DoDot:2
- +70 ;NHIN: UID is NPI if available (preferred)
- IF $GET(XARRY(3))=""
- SET XARRY(3)=XARRY(8)
- +71 ;NHIN: DoD CAC card identifier
- IF $GET(XARRY(3))=""
- SET XARRY(3)=XEDIPI
- +72 ;NHIN: UID is e-mail if available (alternative to NPI)
- IF $GET(XARRY(3))=""
- SET XARRY(3)=XARRY(11)
- +73 SET DUZ("AUTHENTICATION")="NHIN"
- +74 ; p731,p771
- LOCK +^VA(200,"UID",XARRY(3)):$GET(DILOCKTM,10)
- IF '$TEST
- SET XDUZ="-1^Could not obtain LOCK"
- QUIT
- +75 ;Identify user by NPI or Unique User ID
- SET XDUZ=$$FINDUSER^XUESSO2(.XARRY)
- +76 IF +XDUZ<0
- Begin DoDot:3
- +77 SET XARRY(8)=""
- +78 ;Identify user by Unique User ID only
- SET XDUZ=$$FINDUSER^XUESSO2(.XARRY)
- +79 ; retry with SSN from MPI
- IF XDUZ'>0
- SET XARRY(9)=$$MPISSN(.XARRY)
- +80 IF $GET(XARRY(9))]""
- SET XDUZ=$$FINDUSER^XUESSO2(.XARRY)
- +81 IF (+XDUZ<0)&($GET(XARRY(5))'="")
- Begin DoDot:4
- +82 IF '$$TOKVALID(.DUZ,.XUERR)
- SET XDUZ="-1^Cannot add untrusted token-data"
- QUIT
- +83 ;Add new user on the fly
- SET XDUZ=$$ADDUSER^XUESSO2(.XARRY)
- End DoDot:4
- End DoDot:3
- +84 ; end p731
- LOCK -^VA(200,"UID",XARRY(3))
- End DoDot:2
- End DoDot:1
- +85 ;
- +86 ; record NAME and SECID to error
- IF XDUZ<0
- Begin DoDot:1
- +87 SET XUERR("SECID")=""
- +88 SET $PIECE(XDUZ,U,3)=XARRY(4)
- SET $PIECE(XDUZ,U,4)=XARRY(7)
- End DoDot:1
- +89 QUIT XDUZ
- VALASSRT(XASSRT,DOC,XUERR) ;Intrinsic Subroutine. Validate SAML assertion
- +1 ;ZEXCEPT: XOBDATA ;environment variable
- +2 NEW XAUTH,XD,XNOW,XPROOF
- +3 SET XOBDATA("XOB RPC","SAML","AUTHENTICATION TYPE")=$GET(^TMP("XUSAML",$JOB,"Name","authenticationtype"))
- +4 SET XOBDATA("XOB RPC","SAML","PROOFING AUTHORITY")=$GET(^TMP("XUSAML",$JOB,"Name","proofingauthority"))
- +5 SET XAUTH=$$LOW^XLFSTR($GET(^TMP("XUSAML",$JOB,"Name","authnsystem")))
- +6 SET XPROOF=XOBDATA("XOB RPC","SAML","PROOFING AUTHORITY")
- +7 ; Verify Level of Assurance (VA requires LOA-1 through LOA-3, but higher levels are accepted)
- +8 KILL XOBDATA("XOB RPC","SAML","ASSURANCE LEVEL")
- +9 SET XD=$GET(^TMP("XUSAML",$JOB,"Name","assurancelevel"))
- IF (+XD<1)!(+XD="")
- SET XD=1
- +10 SET XOBDATA("XOB RPC","SAML","ASSURANCE LEVEL")=XD
- +11 ;Set LOA environment variable for SIGN-ON log and permissions
- SET DUZ("LOA")=XD
- +12 ;p701
- +13 ;I (XAUTH'="nhin")&(XPROOF'="VA-JLV") D ;temporary for pre-SSOe JLV non-VA users
- +14 Begin DoDot:1
- +15 ;Validate time stamps (e.g., NotBefore, NotOnOrAfter)
- +16 SET XNOW=$$NOW^XLFDT
- +17 ;invalid time stamp
- SET XD=$$CONVTIME($GET(XASSRT("AuthnInstant")))
- IF XD=-1
- Begin DoDot:2
- +18 SET XUERR("AuthnI")=""
- End DoDot:2
- +19 ;token not valid yet
- SET XD=$$CONVTIME($GET(XASSRT("NotBefore")))
- IF (XD=-1)!(XD>XNOW)
- Begin DoDot:2
- +20 SET XUERR("NotBefore")=""
- End DoDot:2
- +21 SET XD=$$CONVTIME($GET(XASSRT("NotOnOrAfter")))
- Begin DoDot:2
- +22 ;N DIF1,HR,DAY
- +23 ;S HR=3600,DAY=86400
- +24 ;S DIF1=$$FMDIFF^XLFDT(XD,XNOW,2) ;DIF1=$$ABS^XLFMTH(DIF1)
- +25 ;I (XD=-1)!(DIF1>DAY) S XUERR("EXPIRED+")="" Q
- +26 IF XD<XNOW
- SET XUERR("EXPIRED")=""
- +27 ;
- End DoDot:2
- +28 IF '$DATA(XASSRT("AuthnContextClassRef"))
- Begin DoDot:2
- +29 SET XUERR("AuthnCCR")=""
- End DoDot:2
- +30 ;Validate Digital Signature
- +31 DO VALIDATE^XUCERT(DOC,.XUERR)
- +32 ;Validate Token Issuer (Subject of X509 Certificate used to sign token)
- +33 IF '($GET(XOBDATA("XOB RPC","SAML","ISSUER"))[$PIECE($GET(^XTV(8989.3,1,200)),U,1))
- Begin DoDot:2
- +34 SET XUERR("ISSUER")=""
- End DoDot:2
- +35 ;Token has been validated
- End DoDot:1
- +36 QUIT
- IDPASS(XUA) ;Intrinsic Function. Extract Application ID
- +1 NEW RETURN,XTD,XTE
- +2 SET RETURN=$PIECE($GET(XUA),"/",4,99)
- +3 SET XTD=$$DT^XLFDT
- +4 SET XTE=$$FMADD^XLFDT(XTD,7)
- +5 IF $GET(RETURN)'=""
- Begin DoDot:1
- +6 ;capture and log application ID from SAML token
- SET ^XTMP("XUSAMLAPPID",0)=XTE_"^"_XTD_"^SAML Application ID"
- +7 SET ^XTMP("XUSAMLAPPID",0,RETURN)=""
- End DoDot:1
- +8 ;. S RETURN=$$LOW^XLFSTR(RETURN) p779
- +9 QUIT RETURN
- CONVTIME(TIME) ;Intrinsic Function. Convert XML time to FileMan format
- +1 ;ZEXCEPT: %DT ;environment variable
- +2 NEW X,XD,XOUT,XT,XZ,Y
- +3 ;Zulu time (GMT)
- SET XZ=0
- IF $GET(TIME)["Z"
- SET XZ=1
- +4 ;Date
- SET XD=$PIECE($GET(TIME),"T",1)
- +5 ;Convert date to MM/DD/YYYY
- SET XD=$PIECE(XD,"-",2)_"/"_$PIECE(XD,"-",3)_"/"_$PIECE(XD,"-",1)
- +6 ;Time
- SET XT=$PIECE($GET(TIME),"T",2)
- +7 ;Strip "Z" from time
- IF XZ=1
- SET XT=$PIECE(XT,"Z",1)
- +8 SET X=XD_"@"_XT
- SET %DT="RTS"
- +9 DO ^%DT
- SET XOUT=Y
- +10 ;Invalid date/time
- IF XOUT=-1
- QUIT XOUT
- +11 ;Adjust from GMT
- IF XZ=1
- SET XOUT=$$FMADD^XLFDT(XOUT,0,+$EXTRACT($$TZ^XLFDT,1,3),0,0)
- +12 KILL %DT(0)
- +13 QUIT XOUT
- +14 ;
- WARNINGS(XUERR) ;
- +1 NEW X,Y
- +2 SET (X,Y)=""
- +3 FOR
- SET X=$ORDER(XUERR(X))
- if X=""
- QUIT
- SET Y=Y_X_";"
- +4 QUIT Y
- +5 ;
- TOKVALID(DUZ,XUERR) ;
- +1 NEW STRICT
- +2 ;S STRICT=$P($G(^XTV(8989.3,1,"XUS")),"^",20)
- +3 SET STRICT=+$PIECE($GET(XOPT),U,20)
- +4 IF STRICT
- IF $DATA(XUERR)
- QUIT 0
- +5 IF $GET(DUZ("AUTHENTICATION"))="NHIN"
- QUIT 1
- +6 IF $DATA(XUERR("EXPIRED"))
- QUIT 0
- +7 ;I $D(XUERR("DIGEST")),$D(XUERR("EXPIRED+")) Q 0
- +8 QUIT 1
- +9 ;
- LOGFAIL(IEN,DUZ) ; Record failed access
- +1 NEW STRICT,WARN,XUF
- +2 SET STRICT=$PIECE($GET(XOPT),U,20)
- +3 SET WARN=$SELECT(+STRICT:"STRICT ",1:"NON-STRICT ")
- +4 IF $GET(DUZ("WARNINGS"))'=""
- SET WARN=WARN_"Failed-verifications: "_$GET(DUZ("WARNINGS"))
- +5 IF $PIECE(IEN,U,2)'=""
- SET WARN=WARN_" ERROR:"_$PIECE(IEN,U,2)
- +6 IF $PIECE(IEN,U,4)'=""
- SET WARN=WARN_". SECID not linked to existing user, SECID:"_$PIECE(IEN,U,4)_" NAME:"_$PIECE(IEN,U,3)_" "
- +7 SET IEN=+IEN
- +8 IF IEN>0
- SET XUF(.3)=IEN
- SET X=$PIECE($GET(^VA(200,IEN,1.1)),U,2)+1
- SET $PIECE(^(1.1),"^",2)=X
- +9 SET XUF(.1)=$EXTRACT($GET(DUZ("AUTHENTICATION")))
- +10 SET XUF(.2)=$GET(XUF(.2))+1
- SET XUF(XUF(.2))=WARN
- +11 SET XUF=2
- +12 DO FILE^XUSTZ
- +13 QUIT
- +14 ;
- MPISSN(XATR) ; Return SSN found in MPI
- +1 NEW SSN,XMPI,XOUT
- +2 SET SSN=""
- +3 if $GET(XATR(7))]""
- SET XMPI("secId")=XATR(7)
- +4 if $GET(XATR(6))]""
- SET XMPI("samacctnm")=XATR(6)
- +5 if $GET(XATR(10))]""
- SET XMPI("VAemail")=XATR(10)
- +6 NEW XI
- FOR XI="secId","samacctnm","VAemail"
- Begin DoDot:1
- +7 NEW XIN
- +8 IF $GET(XMPI(XI))]""
- SET XIN(XI)=XMPI(XI)
- DO USER^XUIAMXML(.XOUT,.XIN)
- SET SSN=$GET(XOUT("pnid"))
- End DoDot:1
- if SSN]""
- QUIT
- +9 QUIT SSN
- +10 ;