[gforth] / gforth / fget.fs  

gforth: gforth/fget.fs

1 : pazsan 1.1 \ a http get command
2 :    
3 :     \ Copyright (C) 2000,2002,2003,2006,2007 Free Software Foundation, Inc.
4 :    
5 :     \ This file is part of Gforth.
6 :    
7 :     \ Gforth is free software; you can redistribute it and/or
8 :     \ modify it under the terms of the GNU General Public License
9 :     \ as published by the Free Software Foundation, either version 3
10 :     \ of the License, or (at your option) any later version.
11 :    
12 :     \ This program is distributed in the hope that it will be useful,
13 :     \ but WITHOUT ANY WARRANTY; without even the implied warranty of
14 :     \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 :     \ GNU General Public License for more details.
16 :    
17 :     \ You should have received a copy of the GNU General Public License
18 :     \ along with this program. If not, see http://www.gnu.org/licenses/.
19 :    
20 :     require unix/socket.fs
21 :     require string.fs
22 :    
23 :     Create crlf #cr c, #lf c,
24 :    
25 :     : writeln ( addr u fd -- )
26 :     dup >r write-file throw crlf 2 r> write-file throw ;
27 :    
28 :     : request ( host u request u proxy-host u port -- fid )
29 :     open-socket >r
30 :     s" GET " r@ write-file throw r@ write-file throw s" HTTP/1.1" r@ writeln
31 :     s" Host: " r@ write-file throw r@ writeln
32 :     s" Connection: close" r@ writeln
33 :     s" User-Agent: " r@ write-file throw
34 :     s" Gforth Proxy 0.1" r@ writeln
35 :     s" " r@ writeln r> ;
36 :    
37 :     Variable proxy \ s" proxy" proxy $! \ replace that with your proxy host
38 :     Variable proxy-port \ 8080 proxy-port ! \ replace that with your proxy port
39 :    
40 :     \ set proxy to your local proxy, and proxy-port to your local proxy port
41 :     \ if you need any.
42 :    
43 :     : http-open ( host u request u -- fid )
44 :     proxy @ 0= IF 2over 80 ELSE proxy $@ proxy-port @ THEN request ;
45 :    
46 :     wordlist Constant response
47 :     wordlist Constant response-values
48 :    
49 :     Variable response-string
50 :     Variable maxnum
51 :    
52 :     : get-rest ( addr -- ) source >in @ /string dup >in +! rot $! ;
53 :     : ?cr ( -- )
54 :     #tib @ 1 >= IF source 1- + c@ #cr = #tib +! THEN ;
55 :     : refill-loop ( -- flag ) base @ >r base off
56 :     BEGIN refill ?cr WHILE ['] interpret catch drop >in @ 0= UNTIL
57 :     true ELSE maxnum off false THEN r> base ! ;
58 :    
59 :     : response: ( -- ) name
60 :     Forth definitions 2dup 1- nextname Variable
61 :     response-values set-current nextname here cell - Create ,
62 :     DOES> @ get-rest ;
63 :     : >response response-values 1 set-order ;
64 :    
65 :     response set-current
66 :    
67 :     : HTTP/1.1 response-string get-rest >response ;
68 :     : HTTP/1.0 response-string get-rest >response ;
69 :    
70 :     \ response variables
71 :    
72 :     Forth definitions
73 :    
74 :     response: Allow:
75 :     response: Age:
76 :     response: Accept-Ranges:
77 :     response: Cache-Control:
78 :     response: Connection:
79 :     response: Proxy-Connection:
80 :     response: Content-Base:
81 :     response: Content-Encoding:
82 :     response: Content-Language:
83 :     response: Content-Length:
84 :     response: Content-Location:
85 :     response: Content-MD5:
86 :     response: Content-Range:
87 :     response: Content-Type:
88 :     response: Date:
89 :     response: ETag:
90 :     response: Expires:
91 :     response: Last-Modified:
92 :     response: Location:
93 :     response: Mime-Version:
94 :     response: Proxy-Authenticate:
95 :     response: Proxy-Connection:
96 :     response: Public:
97 :     response: Retry-After:
98 :     response: Server:
99 :     response: Transfer-Encoding:
100 :     response: Upgrade:
101 :     response: Via:
102 :     response: Warning:
103 :     response: WWW-Authenticate:
104 :     response: X-Cache:
105 :     response: X-Powered-By:
106 :    
107 :     Forth definitions
108 :    
109 :     \ response handling
110 :    
111 :     : get-response ( fid -- ior )
112 :     push-file loadfile ! loadline off blk off
113 :     response 1 set-order ['] refill-loop catch
114 :     only forth also pop-file ;
115 :    
116 :     \ data handling
117 :    
118 :     Variable data-buffer
119 :    
120 :     : clear-data ( -- )
121 :     s" " data-buffer $! ;
122 :     : add-chunk ( u fid -- u' )
123 :     swap data-buffer $@len dup >r + data-buffer $!len
124 :     data-buffer $@ r@ /string rot read-file throw
125 :     dup r> + data-buffer $!len ;
126 :     : read-sized ( u fid -- )
127 :     add-chunk drop ;
128 :     : read-to-end ( fid -- )
129 :     >r BEGIN $1000 r@ add-chunk $1000 <> UNTIL rdrop ;
130 :    
131 :     : read-chunked ( fid -- ) base @ >r hex >r
132 :     BEGIN pad $100 r@ read-line throw WHILE
133 :     pad swap s>number drop dup WHILE r@ add-chunk drop
134 :     pad 1 r@ read-line throw nip 0= UNTIL
135 :     ELSE drop THEN THEN rdrop r> base ! ;
136 :    
137 :     : read-data ( fid -- ) clear-data >r
138 :     Content-Length @ IF
139 :     Content-Length $@ s>number drop r> read-sized EXIT THEN
140 :     Transfer-Encoding @ IF
141 :     Transfer-Encoding $@ s" chunked" str= 0= IF
142 :     r> read-chunked EXIT THEN THEN
143 :     r> read-to-end ;
144 :    
145 :     : fslurp ( addr u -- addr u )
146 :     '/ $split -1 /string
147 :     http-open dup >r get-response throw r> read-data data-buffer $@ ;
CVS Admin

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help