[OpenSPARC-T2-SAM] / obp / obp / pkg / netinet / uriparse.fth

\ ========== Copyright Header Begin ==========================================
\ 
\ Hypervisor Software File: uriparse.fth
\ 
\ Copyright (c) 2006 Sun Microsystems, Inc. All Rights Reserved.
\ 
\  - Do no alter or remove copyright notices
\ 
\  - Redistribution and use of this software in source and binary forms, with 
\    or without modification, are permitted provided that the following 
\    conditions are met: 
\ 
\  - Redistribution of source code must retain the above copyright notice, 
\    this list of conditions and the following disclaimer.
\ 
\  - Redistribution in binary form must reproduce the above copyright notice,
\    this list of conditions and the following disclaimer in the
\    documentation and/or other materials provided with the distribution. 
\ 
\    Neither the name of Sun Microsystems, Inc. or the names of contributors 
\ may be used to endorse or promote products derived from this software 
\ without specific prior written permission. 
\ 
\     This software is provided "AS IS," without a warranty of any kind. 
\ ALL EXPRESS OR IMPLIED CONDITIONS, REPRESENTATIONS AND WARRANTIES, 
\ INCLUDING ANY IMPLIED WARRANTY OF MERCHANTABILITY, FITNESS FOR A 
\ PARTICULAR PURPOSE OR NON-INFRINGEMENT, ARE HEREBY EXCLUDED. SUN 
\ MICROSYSTEMS, INC. ("SUN") AND ITS LICENSORS SHALL NOT BE LIABLE FOR 
\ ANY DAMAGES SUFFERED BY LICENSEE AS A RESULT OF USING, MODIFYING OR 
\ DISTRIBUTING THIS SOFTWARE OR ITS DERIVATIVES. IN NO EVENT WILL SUN 
\ OR ITS LICENSORS BE LIABLE FOR ANY LOST REVENUE, PROFIT OR DATA, OR 
\ FOR DIRECT, INDIRECT, SPECIAL, CONSEQUENTIAL, INCIDENTAL OR PUNITIVE 
\ DAMAGES, HOWEVER CAUSED AND REGARDLESS OF THE THEORY OF LIABILITY, 
\ ARISING OUT OF THE USE OF OR INABILITY TO USE THIS SOFTWARE, EVEN IF 
\ SUN HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES.
\ 
\ You acknowledge that this software is not designed, licensed or
\ intended for use in the design, construction, operation or maintenance of
\ any nuclear facility. 
\ 
\ ========== Copyright Header End ============================================
id: @(#)uriparse.fth 1.1 04/09/07
purpose: URI parsing routines
copyright: Copyright 2004 Sun Microsystems, Inc.  All Rights Reserved
copyright: Use is subject to license terms.

\ RFC 2396: Uniform Resource Identifiers (URI): Generic Syntax
\ RFC 3617: URI Scheme for TFTP

headerless

\ Check if this is an URI. Only "://" forms are accepted.
: is-uri? ( $ -- flag )  " ://" strstr ;

\ Extract URI scheme name
: uri>scheme ( uri$ -- scheme$ )
   ascii : left-parse-string  2swap 2drop
;

\ Split URI into component parts
: parse-uri ( uri$ -- file$ server$ scheme$ )
   ascii : left-parse-string  2swap  2 /string		( scheme$ $ )
   ascii / left-parse-string  2rot			( file$ srv$ scheme$ )
;

\ Split server string into component parts (host and port)
: parse-hostport ( server$ -- port$ host$ )
   ascii : left-parse-string
;

\ Server must be specified as an IP address
: check-host$-form ( host$ -- )
   inet-addr if  ." Illegal IP address"  -1 throw  else  drop  then
;

\ Port must be a decimal number
: check-port$-form ( port$ -- )
   $dnumber if  ." Illegal port number"  -1 throw  else  drop  then
;

\ Check syntax in server specification
: check-server$-form ( server$ -- )
   parse-hostport					( port$ host$ )
   check-host$-form					( port$ )
   dup if  check-port$-form  else  2drop  then		( )
;

d# 256  instance buffer:  htunescape-buf

\ Decode %xx escaped characters in a URI component.
: htunescape ( adr len -- buf buflen false | true )
   htunescape-buf 0  2swap			( buf 0 adr len )
   begin  dup  while				( buf n adr len )
      over c@  ascii % =  if			( buf n adr len )
         1 /string  dup 2 <  if			( buf n adr' len' )
            2drop 2drop true exit		( true )
         then					( buf n adr' len' )
         2dup 2 min $hnumber  if		( buf n adr' len' )
            2drop 2drop true exit		( true )
         then					( buf n adr' len' char )
         >r  2 /string  r>			( buf n adr' len' char )
      else					( buf n adr len )
         over c@ >r  1 /string  r>		( buf n adr' len' char )
      then					( buf n adr' len' char )
      >r  2over ca+  r> swap c!			( buf n adr' len' )
      2swap 1+ 2swap				( buf n' adr' len' )
   repeat  2drop false				( buf n' false )
;

\ Check escape encoding in file path
: check-file$-form ( $ -- )
   htunescape if  ." Incorrect escape encoding" -1 throw  else  2drop  then
;

\ HTTP URL syntax
\   http_URL = "http://" host [ ":" port ] [ path ]

: is-http-url? ( $ -- flag )
   2dup is-uri? if  uri>scheme " http" $case=  else  2drop false  then
;

: parse-http-url ( url$ -- file$ server$ )  parse-uri 2drop ;

: check-httpurl$-form ( url$ -- )
   parse-http-url  check-server$-form  check-file$-form 
;

\ TFTP URI syntax
\   tftpURI = "tftp://" host "/" [ file [ mode ] ]
\   mode    = ";"  "mode=" ( "netascii" / "octet" )

: is-tftp-uri? ( $ -- flag )
   2dup is-uri? if  uri>scheme " tftp" $case=  else  2drop false  then
;

: parse-tftp-uri ( uri$ -- mode$ file$ server$ )
   parse-uri  2drop  2swap  ascii ; left-parse-string  2rot
;

: tftpuri>srv ( uri$ -- host$ )
   parse-tftp-uri  2swap 2drop  2swap 2drop
;

\ Escape decoding has to be applied for filenames in TFTP URIs
: tftpuri>file ( uri$ -- file$ )
   parse-tftp-uri  2drop 2swap 2drop  2dup htunescape 0=  if
      2swap 2drop
   then
;

: check-tftp-mode$ ( mode$ -- )
   " mode=octet" $case= 0=  if  ." Invalid TFTP transfer mode" -1 throw  then
;

: check-tftpuri$-form ( tftpuri$ -- )
   parse-tftp-uri					( mode$ file$ host$ )
   check-host$-form					( mode$ file$ )
   check-file$-form					( mode$ )
   dup if  check-tftp-mode$  else  2drop  then		( )
;

\ Check HTTP proxy syntax
: check-htproxy$-form ( proxy$ -- )
   2dup ['] check-server$-form catch  if
      2drop ."  in HTTP proxy " type cr  -1 throw
   then  2drop
;

: (check-uri$-form) ( uri$ -- )
   2dup is-http-url?  if
      check-httpurl$-form
   else
      2dup is-tftp-uri?  if
         check-tftpuri$-form
      else
         ." Unknown URI scheme" -1 throw
      then
   then
;

\ Check URI syntax. Print out URI along with any error message
: check-uri$-form ( uri$ -- )
   2dup ['] (check-uri$-form) catch  if
      2drop  ."  in "  type cr  -1 throw
   then  2drop
;

headers
Commit	Line	Data
920dae64 AT	1	\ ========== Copyright Header Begin ==========================================
	2	\
	3	\ Hypervisor Software File: uriparse.fth
	4	\
	5	\ Copyright (c) 2006 Sun Microsystems, Inc. All Rights Reserved.
	6	\
	7	\ - Do no alter or remove copyright notices
	8	\
	9	\ - Redistribution and use of this software in source and binary forms, with
	10	\ or without modification, are permitted provided that the following
	11	\ conditions are met:
	12	\
	13	\ - Redistribution of source code must retain the above copyright notice,
	14	\ this list of conditions and the following disclaimer.
	15	\
	16	\ - Redistribution in binary form must reproduce the above copyright notice,
	17	\ this list of conditions and the following disclaimer in the
	18	\ documentation and/or other materials provided with the distribution.
	19	\
	20	\ Neither the name of Sun Microsystems, Inc. or the names of contributors
	21	\ may be used to endorse or promote products derived from this software
	22	\ without specific prior written permission.
	23	\
	24	\ This software is provided "AS IS," without a warranty of any kind.
	25	\ ALL EXPRESS OR IMPLIED CONDITIONS, REPRESENTATIONS AND WARRANTIES,
	26	\ INCLUDING ANY IMPLIED WARRANTY OF MERCHANTABILITY, FITNESS FOR A
	27	\ PARTICULAR PURPOSE OR NON-INFRINGEMENT, ARE HEREBY EXCLUDED. SUN
	28	\ MICROSYSTEMS, INC. ("SUN") AND ITS LICENSORS SHALL NOT BE LIABLE FOR
	29	\ ANY DAMAGES SUFFERED BY LICENSEE AS A RESULT OF USING, MODIFYING OR
	30	\ DISTRIBUTING THIS SOFTWARE OR ITS DERIVATIVES. IN NO EVENT WILL SUN
	31	\ OR ITS LICENSORS BE LIABLE FOR ANY LOST REVENUE, PROFIT OR DATA, OR
	32	\ FOR DIRECT, INDIRECT, SPECIAL, CONSEQUENTIAL, INCIDENTAL OR PUNITIVE
	33	\ DAMAGES, HOWEVER CAUSED AND REGARDLESS OF THE THEORY OF LIABILITY,
	34	\ ARISING OUT OF THE USE OF OR INABILITY TO USE THIS SOFTWARE, EVEN IF
	35	\ SUN HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES.
	36	\
	37	\ You acknowledge that this software is not designed, licensed or
	38	\ intended for use in the design, construction, operation or maintenance of
	39	\ any nuclear facility.
	40	\
	41	\ ========== Copyright Header End ============================================
	42	id: @(#)uriparse.fth 1.1 04/09/07
	43	purpose: URI parsing routines
	44	copyright: Copyright 2004 Sun Microsystems, Inc. All Rights Reserved
	45	copyright: Use is subject to license terms.
	46
	47	\ RFC 2396: Uniform Resource Identifiers (URI): Generic Syntax
	48	\ RFC 3617: URI Scheme for TFTP
	49
	50	headerless
	51
	52	\ Check if this is an URI. Only "://" forms are accepted.
	53	: is-uri? ( $ -- flag ) " ://" strstr ;
	54
	55	\ Extract URI scheme name
	56	: uri>scheme ( uri$ -- scheme$ )
	57	ascii : left-parse-string 2swap 2drop
	58	;
	59
	60	\ Split URI into component parts
	61	: parse-uri ( uri$ -- file$ server$ scheme$ )
	62	ascii : left-parse-string 2swap 2 /string ( scheme$ $ )
	63	ascii / left-parse-string 2rot ( file$ srv$ scheme$ )
	64	;
65
66	\ Split server string into component parts (host and port)
67	: parse-hostport ( server$ -- port$ host$ )
68	ascii : left-parse-string
69	;
70
71	\ Server must be specified as an IP address
72	: check-host$-form ( host$ -- )
73	inet-addr if ." Illegal IP address" -1 throw else drop then
74	;
75
76	\ Port must be a decimal number
77	: check-port$-form ( port$ -- )
78	$dnumber if ." Illegal port number" -1 throw else drop then
79	;
80
81	\ Check syntax in server specification
82	: check-server$-form ( server$ -- )
83	parse-hostport ( port$ host$ )
84	check-host$-form ( port$ )
85	dup if check-port$-form else 2drop then ( )
86	;
87
88	d# 256 instance buffer: htunescape-buf
89
90	\ Decode %xx escaped characters in a URI component.
91	: htunescape ( adr len -- buf buflen false \| true )
92	htunescape-buf 0 2swap ( buf 0 adr len )
93	begin dup while ( buf n adr len )
94	over c@ ascii % = if ( buf n adr len )
95	1 /string dup 2 < if ( buf n adr' len' )
96	2drop 2drop true exit ( true )
97	then ( buf n adr' len' )
98	2dup 2 min $hnumber if ( buf n adr' len' )
99	2drop 2drop true exit ( true )
100	then ( buf n adr' len' char )
101	>r 2 /string r> ( buf n adr' len' char )
102	else ( buf n adr len )
103	over c@ >r 1 /string r> ( buf n adr' len' char )
104	then ( buf n adr' len' char )
105	>r 2over ca+ r> swap c! ( buf n adr' len' )
106	2swap 1+ 2swap ( buf n' adr' len' )
107	repeat 2drop false ( buf n' false )
108	;
109
110	\ Check escape encoding in file path
111	: check-file$-form ( $ -- )
112	htunescape if ." Incorrect escape encoding" -1 throw else 2drop then
113	;
114
115	\ HTTP URL syntax
116	\ http_URL = "http://" host [ ":" port ] [ path ]
117
118	: is-http-url? ( $ -- flag )
119	2dup is-uri? if uri>scheme " http" $case= else 2drop false then
120	;
121
122	: parse-http-url ( url$ -- file$ server$ ) parse-uri 2drop ;
123
124	: check-httpurl$-form ( url$ -- )
125	parse-http-url check-server$-form check-file$-form
126	;
127
128	\ TFTP URI syntax
129	\ tftpURI = "tftp://" host "/" [ file [ mode ] ]
130	\ mode = ";" "mode=" ( "netascii" / "octet" )
131
132	: is-tftp-uri? ( $ -- flag )
133	2dup is-uri? if uri>scheme " tftp" $case= else 2drop false then
134	;
135
136	: parse-tftp-uri ( uri$ -- mode$ file$ server$ )
137	parse-uri 2drop 2swap ascii ; left-parse-string 2rot
138	;
139
140	: tftpuri>srv ( uri$ -- host$ )
141	parse-tftp-uri 2swap 2drop 2swap 2drop
142	;
143
144	\ Escape decoding has to be applied for filenames in TFTP URIs
145	: tftpuri>file ( uri$ -- file$ )
146	parse-tftp-uri 2drop 2swap 2drop 2dup htunescape 0= if
147	2swap 2drop
148	then
149	;
150
151	: check-tftp-mode$ ( mode$ -- )
152	" mode=octet" $case= 0= if ." Invalid TFTP transfer mode" -1 throw then
153	;
154
155	: check-tftpuri$-form ( tftpuri$ -- )
156	parse-tftp-uri ( mode$ file$ host$ )
157	check-host$-form ( mode$ file$ )
158	check-file$-form ( mode$ )
159	dup if check-tftp-mode$ else 2drop then ( )
160	;
161
162	\ Check HTTP proxy syntax
163	: check-htproxy$-form ( proxy$ -- )
164	2dup ['] check-server$-form catch if
165	2drop ." in HTTP proxy " type cr -1 throw
166	then 2drop
167	;
168
169	: (check-uri$-form) ( uri$ -- )
170	2dup is-http-url? if
171	check-httpurl$-form
172	else
173	2dup is-tftp-uri? if
174	check-tftpuri$-form
175	else
176	." Unknown URI scheme" -1 throw
177	then
178	then
179	;
180
181	\ Check URI syntax. Print out URI along with any error message
182	: check-uri$-form ( uri$ -- )
183	2dup ['] (check-uri$-form) catch if
184	2drop ." in " type cr -1 throw
185	then 2drop
186	;
187
188	headers