source: project/release/3/http-fs/http-fs.scm @ 14955

Last change on this file since 14955 was 3666, checked in by felix winkelmann, 14 years ago

vfs, http-fs, manual changes

File size: 1.3 KB
Line 
1;;;; http-fs.scm
2
3
4(use vfs tinyclos http-client regex-case)
5
6
7(define-class <http-file-system> (<vfs:file-system>) ())
8
9(declare (hide follow-redirects))
10
11(define (follow-redirects url m attrs)
12  (let loop ((url url) (done (list url)))
13    (let-values (((ln headers i o) (http:send-request (http:make-request m url attrs))))
14      (regex-case ln
15        ("HTTP.*\\s+30[12]\\s+.*" _
16         (close-output-port o)
17         (close-input-port i)
18         (cond ((alist-ref "location" headers string-ci=?) =>
19                (lambda (loc)
20                  (if (member loc done)
21                      (error 'file-exists? "circular HTTP redirect" url loc)
22                      (loop loc (cons loc done)))))
23               (else (error 
24                      'file-exists?
25                      "HTTP redirection without target location"
26                      url) ) ) )
27        ("HTTP.*\\s+200\\s+.*" _ (values i o))
28        (else (values #f #f))))))
29
30(define-method (vfs:open-input-file (fs <http-file-system>) name modes)
31  (let-values (((i o) (follow-redirects
32                       name
33                       'GET '(("Connection" . "close")))))
34    (unless i 
35      (error 'open-input-file "file not found" name) )
36    (close-output-port o)
37    i) )
38
39(define-method (vfs:file-exists? (fs <http-file-system>) name)
40  (let-values (((i o) (follow-redirects name 'HEAD '(("Connection" . "close")))))
41    (cond (i (close-output-port o)
42             (close-input-port i)
43             #t)
44          (else #f) ) ) )
45
46(vfs:register-file-system "http" (make <http-file-system>))
Note: See TracBrowser for help on using the repository browser.