| 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 |