This is the mail archive of the
guile@sourceware.cygnus.com
mailing list for the Guile project.
Re: Scheme book recommendations
>>>>> "Harvey" == Harvey J Stein <hjstein@bfr.co.il> writes:
Harvey> Mikael Djurfeldt <mdj@mdj.nada.kth.se> writes:
>> cwitty@newtonlabs.com (Carl R. Witty) writes:
>>
>> > Before you put this in any guile documentation, please add
>> warnings > that say that if you run this on a machine connected
>> to the Internet, > anybody in the world can do anything they
>> want to your files...
>>
>> Yes, actually, it might not be such a good idea to publish such
>> code at all. We should probably add code to at least verify
>> that the host is "safe":
Harvey> So you're only allowing everyone on the machine into your
Harvey> account instead of everyone on the internet? Still not so
Harvey> cool.
Why not an exemple on the client side ?
Here a ftp client, you can call by:
(ftpget host user pass couples)
where couples is a list of pairs, each pair
of the form (file . proc).
file is the remote file to get, and proc is a procedure of 2
arguments buf and n, where buf is a string with the first n characters
originating from the remote file, and you do what you want with them.
Exemple (a #f password argument asks you for one):
(ftpget "my-machine" "myself" #f
(list (cons "remote-file" (copy-file "local-copy"))))
where copy-file is defined below.
;;; Cree un fichier avec les repertoires qui y menent s'il n'existent pas
(define (open-output-file2 file)
(mkdirhier file)
(open-output-file file))
(define (mkdirhier file)
(let ((reg (make-regexp "([^/]*)/(.*)")))
(let loop ((prefix "")
(str file))
(let ((res (regexp-exec reg str)))
(if res
(let ((pref (substring str
(car (vector-ref res 2))
(cdr (vector-ref res 2)))))
;(display res) (newline)
(let ((dir (string-append prefix pref)))
(if (file-exists? dir)
(if (not (file-is-directory? dir))
(error "fichier ordinaire:" dir))
(mkdir dir)))
(loop (string-append prefix pref "/")
(substring str
(car (vector-ref res 3))
(cdr (vector-ref res 3))))))))))
(define (copy-file final-file)
(let* ((temp (string-append "tempo" (number->string (getpid))))
(port #f))
(lambda (buf n)
(if (not (output-port? port))
(set! port (open-output-file temp)))
(if (<= n 0)
(begin
;;; cree un fichier vide, mais surtout les bons repertoires
(close-port (open-output-file2 final-file))
(close-port port)
(rename-file temp final-file))
(display (substring buf 0 n) port)))))
(define ron-ron 300)
(define (ftpget host user pass couples)
(catch #t
(lambda ()
(ftpget-internal host user pass couples)
(set! ron-ron 300))
(lambda args
(write args (current-error-port))
(newline)
(display ";;; connection impossible, on saute ce ftpget...\n"
(current-error-port))
(sleep ron-ron)
(set! ron-ron (* 2 ron-ron)))))
(define (ftpget-internal host user pass couples)
(let* ((host-info (gethost host))
(typ-conn (hostent:addrtype host-info))
(so-cmd (socket typ-conn
SOCK_STREAM
(protoent:proto (getproto "tcp"))))
(reponse (lambda ()
(let loop ((li '())
(ch (read-char so-cmd)))
(cond ((eof-object? ch)
(list->string (reverse li)))
((char=? ch #\newline)
(list->string (reverse (cons ch li))))
(else
(loop (cons ch li) (read-char so-cmd)))))))
(buffer (make-string 4000))
(traite (lambda (x)
(let* ((file (car x))
(proc (cdr x))
(so-data (socket typ-conn
SOCK_STREAM
(protoent:proto (getproto "tcp"))))
(litfile (lambda (x)
(let loop ((n (recv! so-data buffer)))
(x buffer n)
(if (> n 0)
(loop (recv! so-data buffer)))))))
(send so-cmd "pasv\n")
(let* ((reg (make-regexp "([0-9]*),([0-9]*)\)"))
(rep (reponse))
(split (regexp-exec reg rep))
(indice0 (vector-ref split 2))
(indice1 (vector-ref split 3))
(port0 (string->number (substring rep
(car indice0)
(cdr indice0))))
(port1 (string->number (substring rep
(car indice1)
(cdr indice1)))))
(display rep)
(connect so-data
typ-conn
(car (hostent:addr-list host-info))
(+ port1 (* 256 port0))))
(send so-cmd (string-append "size " file "\n"))
(let ((res (reponse)))
(display res)
(if (string=? "550" (substring res 0 3))
(begin
(close-port so-data)
(error "fichier distant inexistant" file))))
(send so-cmd (string-append "retr " file "\n"))
(display (reponse))
(litfile proc)
(display (reponse))
(close-port so-data)))))
(connect so-cmd
typ-conn
(car (hostent:addr-list host-info))
(servent:port (getserv "ftp" "tcp")))
(display (reponse))
(send so-cmd (string-append "user " user "\n"))
(display (reponse))
(send so-cmd (string-append "pass "
(if pass
pass
(begin
(display "Entrez mot de passe:"
(current-error-port))
(read-line)))
"\n"))
(display (reponse))
(send so-cmd "type i\n")
(display (reponse))
(for-each (lambda (x)
(catch #t
(lambda ()
(traite x))
(lambda args
(write args (current-error-port))
(newline)
(display ";;; on saute ce fichier...\n"
(current-error-port)))))
couples)
(send so-cmd "quit\n")
(display (reponse))
(close-port so-cmd)))
--
B. Urban