home *** CD-ROM | disk | FTP | other *** search
/ Chip 2004 July / CHIP_CD_2004-07.iso / software / nncron_hit / files / nncron189.exe / plugins / http.spf next >
Text File  |  2004-02-19  |  8KB  |  328 lines
  1. \ File:         http.spf
  2. \ Author:       Nicholas Nemtsev
  3. \ Description:  http operations
  4. \ Date: 14.Apr.2003 (PAD relation words have been eliminated)
  5. \ Modified: 22.Sep.2003 (HTTP-RESULT and some bug fixed)
  6. \ Modified: 17.Feb.2004 + HTTPProxy-Authorization: username:password
  7. \ Modified: 19.Feb.2004 + port bug fixed (vPort -> vServerPort )
  8. \ Usage: HTTP-CHANGED: <URL>  ( -- ?)        - tests Last-Modified field
  9. \        HTTP-GET: <URL>      ( -- a u ior)  - downloads resource
  10. \        HTTP-LM: <URL>       ( -- a u ior)  - retrieves Last-Modified field
  11.  
  12. CLASS: HTTPConnection <SUPER SocketLine
  13.     var vServer
  14.     var vServerPort
  15.     var vPath
  16.     var vProxy
  17.     var vProxyPort
  18.     var vFieldList
  19.     var vURL
  20.     var vFH
  21.     var vUserAgent
  22.     var vAddField
  23.     var vProt
  24.     var vResultCode
  25.     var vProxy-Authorization
  26.  
  27. M: Proxy! S>ZALLOC vProxy ! ;
  28. M: ProxyPort! vProxyPort ! ;
  29. M: Server! S>ZALLOC vServer ! ;
  30. M: ServerPort! vServerPort ! ;
  31. M: Proxy-Authorization! S>ZALLOC vProxy-Authorization ! ;
  32.  
  33. M: URL ( a u -- )
  34.     2DUP S>ZALLOC vURL !
  35.     RE-SAVE
  36.     S" /(http\:\/\/)?([^\/:]*)(\:\d*)?(\/.*)?/i" RE-MATCH
  37.     IF
  38.         [ DEBUG? ] 
  39.         [IF]
  40.         ." All=" $0 TYPE CR
  41.         ." Server=" $2 TYPE CR
  42.         ." Port=" $3 TYPE CR
  43.         ." Path=" $4 TYPE CR
  44.         [THEN]
  45.         $1 ?DUP 0= IF DROP S" http://" THEN S>ZALLOC vProt !
  46.         $2 Server!
  47.         $3 ?DUP IF 1 /STRING S>NUM vServerPort ! ELSE DROP THEN
  48.         $4 ?DUP 0= IF DROP S" /" THEN S>ZALLOC vPath !
  49.     THEN
  50.     RE-REST
  51. ;
  52.  
  53. CONSTR: init ( a u -- )
  54.     init
  55.     80 vServerPort !
  56.     80 vProxyPort !
  57.     URL
  58.     S" Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 4.0)" DROP vUserAgent !
  59. ;
  60.  
  61. : free-fields 
  62.     [NONAME NodeValue DUP @ ?FREE DUP CELL+ @ ?FREE ?FREE NONAME] 
  63.     vFieldList DoList
  64.     vFieldList FreeList ;
  65.  
  66. DESTR: free free  
  67.     vPath   @ ?FREE2
  68.     vProxy  @ ?FREE
  69.     vServer @ ?FREE
  70.     vURL    @ ?FREE
  71.     vUserAgent @ ?FREE2
  72.     vProt @ ?FREE2
  73.     vProxy-Authorization @ ?FREE2
  74.     free-fields ;
  75.  
  76. M: AddField ( a-name u-name a-val u-val -- )  vFieldList SetProp ;
  77.  
  78. M: GetField ( a u -- a1 u1) vFieldList GetProp ;
  79.  
  80. DEBUG?
  81. [IF]
  82. : ShowFields
  83.     vFieldList 
  84.     BEGIN @ ?DUP WHILE
  85.       DUP
  86.       NodeValue DUP @AZ TYPE ." =" CELL+ @AZ TYPE CR
  87.     REPEAT
  88. ;
  89. [THEN]
  90.  
  91. M: SetAddr
  92.     vProxy @
  93.     IF vProxy @AZ
  94.        vProxyPort @ 
  95.     ELSE
  96.        vServer @AZ
  97.        vServerPort @ 
  98.     THEN
  99.     vPort ! Addr!
  100. ;
  101.             
  102. M: RequestString ( a1 u1 -- a2 u2)
  103.     0.
  104.     <# S"  HTTP/1.1" HOLDS 
  105.           vProxy @ IF \ vURL @AZ
  106.                        vPath @AZ HOLDS
  107.                        vServerPort @ ?DUP IF S>D #S [CHAR] : HOLD 2DROP THEN
  108.                        vServer @AZ HOLDS
  109.                        vProt @AZ HOLDS
  110.                    ELSE vPath @AZ  HOLDS THEN
  111.           BL HOLD
  112.           2SWAP HOLDS #> 
  113.     [ DEBUG? ] [IF] 2DUP TYPE CR [THEN]
  114. ;
  115.  
  116. M: SendOption ( a1 a2 u2 -- )
  117.     ROT @ ?DUP 
  118.     IF ASCIIZ> <# HOLDS S" : " HOLDS HOLDS 0. #> WriteLine 
  119.     ELSE 2DROP THEN ;
  120.  
  121. M: SendRequest ( a u -- )
  122.     SetAddr
  123.     Create Connect
  124.     RequestString  WriteLine
  125.     vUserAgent S" User-Agent" SendOption
  126. \    Wget/1.8"  WriteLine
  127.     vServer S" Host"          SendOption
  128.     S" Accept: */*"           WriteLine
  129.     vProxy-Authorization S" Proxy-Authorization" SendOption
  130.     vAddField @ ?DUP IF ASCIIZ> WriteLine THEN
  131. \    S" Connection: Keep-Alive" WriteLine
  132. \    S" Pragma: no-cache"
  133.     WriteCRLF ;
  134.  
  135. M: GetHeader ( -- )
  136.     free-fields
  137.     BEGIN ReadLine ?DUP WHILE
  138. \      ." --"  2DUP TYPE CR
  139.       2DUP S" /(.*): (.*)/" RE-MATCH
  140.       IF  $1 $2 AddField THEN
  141.       S" /HTTP\/\d\.\d (\d+) /" RE-MATCH
  142.       IF $1 S>NUM vResultCode ! THEN
  143.     REPEAT
  144.     DROP
  145. ;
  146.  
  147. M: HEAD ( -- ior)
  148.     [NONAME
  149.       S" HEAD" SendRequest
  150.       GetHeader
  151.       Close
  152.     NONAME] CATCH 
  153.     [ DEBUG? ] [IF] ShowFields [THEN]
  154. ;
  155.  
  156. M: GetBody { \ buf len-buf cont-len len -- }
  157.     S" Content-Length" GetField S>NUM TO cont-len
  158.     512 TO len-buf
  159.     len-buf ALLOCATE THROW TO buf 
  160.     LINE_BUFF_SIZE ReadFromPending DUP TO len
  161.     vFH @ WRITE-FILE THROW
  162.     BEGIN
  163.       len cont-len < cont-len 0= OR
  164.       IF
  165.           buf len-buf Sock ReadSocket DUP -1002 =
  166.           IF 2DROP FALSE ELSE THROW THEN
  167.           ?DUP
  168.       ELSE
  169.         FALSE
  170.       THEN
  171.     WHILE
  172.        DUP AT len +!
  173.        buf SWAP \ 2DUP TYPE CR
  174.        vFH @ WRITE-FILE THROW
  175.     REPEAT
  176.     buf FREE THROW
  177. ;
  178.  
  179. M: GET ( a u -- ior)
  180.     R/W MAKE-FILE THROW vFH !
  181.     [NONAME
  182.       S" GET" SendRequest
  183.       GetHeader
  184.       GetBody
  185.       Close
  186.     NONAME] CATCH 
  187.     vFH @ CLOSE-FILE DROP
  188. ;
  189.  
  190. M: Last-Modified ( -- a u ior)
  191.     HEAD ?DUP
  192.     IF S" " ROT 
  193.     ELSE
  194.       S" Last-Modified" GetField ?DUP 0=
  195.       IF DROP  S" Content-Length" GetField THEN
  196.       0
  197.     THEN
  198. ;
  199.  
  200. ;CLASS
  201.  
  202. USER-VALUE http
  203. USER-VALUE HTTP-RESULT
  204. VARIABLE HTTPProxy
  205. VARIABLE HTTPProxyPort   3128 HTTPProxyPort !
  206. VARIABLE HTTPProxy-Authorization
  207. VARIABLE HTTPProxy-Authorization-Type
  208.  
  209. : HTTPProxy: get-string S>ZALLOC HTTPProxy ! ;
  210. : HTTPProxyPort: get-number HTTPProxyPort ! ;
  211. : HTTPProxy-Authorization: 
  212.     get-string 
  213.     HTTPProxy-Authorization-Type @
  214.     CASE
  215.        0 OF
  216.            DUP 2* ALLOCATE THROW >R
  217.            R@ 0 TO 64offset base64
  218.            S" Basic %1 esPICKS%" EVAL-SUBST
  219.             [ DEBUG? ] 
  220.             [IF]
  221.                ." HTTPProxy-Authorization: " 2DUP TYPE CR 
  222.             [THEN]
  223.            R> FREE DROP
  224.        ENDOF
  225.     ENDCASE
  226.     S>ZALLOC HTTPProxy-Authorization !
  227. ;
  228.  
  229. WITH HTTPConnection
  230. : new-http
  231.     HTTPConnection NEW TO http
  232.     HTTPProxy @ ?DUP 
  233.     IF ASCIIZ> http => Proxy! HTTPProxyPort @ http => ProxyPort! 
  234.         HTTPProxy-Authorization @ ?DUP
  235.         IF ASCIIZ> http => Proxy-Authorization! THEN
  236.     THEN ;
  237.  
  238. : HTTP-LM ( a u -- a u ior)
  239.     new-http
  240.     http => Last-Modified
  241.     ?DUP 0= IF S>TEMP 0 THEN
  242.     http => vResultCode @ TO HTTP-RESULT
  243.     http => SELF DELETE
  244. ;
  245.  
  246.  
  247. : HTTP-GET { a u \ tmpname -- a u ior }
  248.     a u new-http
  249.     TempFile S>ZALLOC TO tmpname
  250.     tmpname ASCIIZ> http => GET ?DUP 0=
  251.     IF
  252.        tmpname ASCIIZ> FILE 0
  253.     ELSE
  254.        S" " ROT
  255.     THEN
  256.     http => vResultCode @ TO HTTP-RESULT
  257.     http DELETE
  258.     tmpname ASCIIZ> DELETE-FILE DROP
  259.     tmpname ?FREE
  260. ;
  261.  
  262. ENDWITH
  263.  
  264. VARIABLE HTTP-LIST  \ list of URL with corresponding Last-Modified
  265. VARIABLE HTTP-SEM
  266. : htime.txt S" etc\htime.txt" ;
  267.  
  268. : ?load-htime { \ len buf1 buf2 f -- }
  269.     HTTP-SEM GET
  270.     HTTP-LIST @ 0=
  271.     IF
  272.       htime.txt R/O OPEN-FILE-SHARED DUP 2 <>
  273.       IF
  274.          THROW TO f
  275.          1024 TO len
  276.          len CELL+ ALLOCATE THROW TO buf1
  277.          len CELL+ ALLOCATE THROW TO buf2
  278.          BEGIN buf1 len f READ-LINE THROW WHILE
  279.            buf1 SWAP
  280.            buf2 len f READ-LINE THROW DROP
  281.            buf2 SWAP HTTP-LIST GLOBAL SetProp LOCAL
  282.          REPEAT
  283.          DROP
  284.          f CLOSE-FILE DROP
  285.          buf1 ?FREE 
  286.          buf2 ?FREE
  287.       ELSE 2DROP THEN
  288.     THEN
  289.     HTTP-SEM RELEASE
  290. ;
  291. : htime-line htime.txt FAPPEND CRLF htime.txt FAPPEND ;
  292. : write-htime
  293.     HTTP-SEM GET
  294.     HTTP-LIST @ 
  295.     IF
  296.         htime.txt R/W MAKE-FILE THROW CLOSE-FILE DROP
  297.         [NONAME
  298.             NodeValue DUP @AZ htime-line 
  299.             CELL+ @AZ htime-line
  300.         NONAME] HTTP-LIST DoList
  301.     THEN
  302.     HTTP-SEM RELEASE
  303. ;
  304.  
  305. : HTTP-CHANGED { a u -- ? }
  306.     ?load-htime
  307.     a u HTTP-LM 0=
  308.     IF
  309.         2DUP a u HTTP-LIST GetProp COMPARE 
  310.         IF
  311.             HTTP-SEM GET
  312.             a u 2OVER HTTP-LIST GLOBAL SetProp LOCAL DROP ?FREE
  313.             HTTP-SEM RELEASE
  314.             write-htime
  315.             TRUE
  316.         ELSE
  317.             2DROP FALSE
  318.         THEN
  319.     ELSE 2DROP FALSE THEN
  320. ;
  321.  
  322. C" eval-string," FIND NIP
  323. [IF]
  324. : HTTP-CHANGED: eval-string, POSTPONE HTTP-CHANGED ; IMMEDIATE
  325. : HTTP-LM: eval-string, POSTPONE HTTP-LM ; IMMEDIATE
  326. : HTTP-GET: eval-string, POSTPONE HTTP-GET ; IMMEDIATE
  327. [THEN]
  328.