scsh-conservatory
/
sunet
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

eliminating ecm-utilities, code partial moved to sunet-utilities

This commit is contained in:
interp 2002-08-26 14:49:17 +00:00
parent 5efcb2923e
commit 6f2c0d7991
4 changed files with 79 additions and 114 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

57
scheme/lib/ecm-utilities.scm
View File

@ -1,57 +0,0 @@
;; ecm-utilities.scm -- Utility procedures for ecm-net code
;;
;; $Id: ecm-utilities.scm,v 1.1 2002/06/08 15:05:24 sperber Exp $
;;
;; Please send suggestions and bug reports to <emarsden@mail.dotcom.fr>
;; please tell me if this doesn't work on your system.
(define (system-fqdn)
(let ((sysname (system-name)))
(if (string-index sysname #\.)
sysname
(nslookup-fqdn))))
;; This doesn't work on my system. Probably it is not configured well.
;; Nevertheless, the alternative seems better to me
;(define (nslookup-fqdn)
; (let* ((cmd (format #f "nslookup ~a" (system-name)))
; (raw (string-join (run/strings (nslookup ,(system-name)))))
; (match (string-match "Name: +([-a-zA-Z0-9.]+)" raw)))
; (display raw)
; (match:substring match 1)))
(define (nslookup-fqdn)
(host-info:name (host-info (system-name))))
; another easy alternative:
; (car (run/strings (hostname "--long"))))
;; prefer this to :optional
(define (safe-first x) (and (not (null? x)) (car x)))
(define (safe-second x) (and (not (null? x)) (not (null? (cdr x))) (cadr x)))
(define (write-crlf port)
(write-string "\r\n" port)
(force-output port))
(define (dump fd)
(let loop ((c (read-char fd)))
(cond ((not (eof-object? c))
(write-char c)
(loop (read-char fd))))))
(define-syntax when
(syntax-rules ()
((when bool body1 body2 ...)
(if bool (begin body1 body2 ...)))))
(define-syntax unless
(syntax-rules ()
((unless bool body1 body2 ...)
(if (not bool) (begin body1 body2 ...)))))
;; EOF

78
scheme/lib/pop3.scm
View File

@ -1,6 +1,6 @@
;;; POP3.scm --- implement the POP3 maildrop protocol in the Scheme Shell ;;; POP3.scm --- implement the POP3 maildrop protocol in the Scheme Shell
;; ;;
;; $Id: pop3.scm,v 1.1 2002/06/08 15:05:24 sperber Exp $ ;; $Id: pop3.scm,v 1.2 2002/08/26 14:49:17 interp Exp $
;; ;;
;; Please send suggestions and bug reports to <emarsden@mail.dotcom.fr> ;; Please send suggestions and bug reports to <emarsden@mail.dotcom.fr>
@ -127,50 +127,54 @@
;;: [host x logfile] -> connection ;;: [host x logfile] -> connection
(define (pop3-connect . args) (define (pop3-connect . args)
(let* ((host (or (getenv "MAILHOST") (let-optionals
(safe-first args))) args
(logfile (safe-second args)) ((host-arg #f)
(LOG (and logfile (logfile #f))
(open-output-file logfile (let* ((host (or (getenv "MAILHOST")
(if (file-exists? logfile) host-arg))
(bitwise-ior open/write open/append) (LOG (and logfile
(bitwise-ior open/write open/create)) (open-output-file logfile
#o600))) (if (file-exists? logfile)
(hst-info (host-info host)) (bitwise-ior open/write open/append)
(hostname (host-info:name hst-info)) (bitwise-ior open/write open/create))
(srvc-info (service-info "pop3" "tcp")) #o600)))
(sock (socket-connect protocol-family/internet (hst-info (host-info host))
socket-type/stream (hostname (host-info:name hst-info))
hostname (srvc-info (service-info "pop3" "tcp"))
(service-info:port srvc-info))) (sock (socket-connect protocol-family/internet
(connection (make-pop3-connection hostname socket-type/stream
sock hostname
LOG "" "" #f #f))) (service-info:port srvc-info)))
(pop3-log connection (connection (make-pop3-connection hostname
(format #f "~%-- ~a: opened POP3 connection to ~a" sock
;; (date->string (date)) LOG "" "" #f #f)))
"Dummy date" ; (format-time-zone) is broken in v0.5.1 (pop3-log connection
hostname)) (format #f "~%-- ~a: opened POP3 connection to ~a"
;; (date->string (date))
"Dummy date" ; (format-time-zone) is broken in v0.5.1
hostname))
;; read the challenge the server sends in its welcome banner ;; read the challenge the server sends in its welcome banner
(let* ((banner (pop3-read-response connection)) (let* ((banner (pop3-read-response connection))
(match (regexp-search (rx (posix-string "\\+OK .* (<[^>]+>)")) banner)) (match (regexp-search (rx (posix-string "\\+OK .* (<[^>]+>)")) banner))
(challenge (and match (match:substring match 1)))) (challenge (and match (match:substring match 1))))
(set-pop3-connection:challenge connection challenge)) (set-pop3-connection:challenge connection challenge))
connection)) connection)))
;; first try standard USER/PASS authentication, and switch to APOP ;; first try standard USER/PASS authentication, and switch to APOP
;; authentication if the server prefers. ;; authentication if the server prefers.
;;: [string x string] -> status ;;: [string x string] -> status
(define (pop3-login connection . args) (define (pop3-login connection . args)
(let* ((netrc (and (< (length args) 2) (netrc:parse))) (let ((netrc (and (< (length args) 2) (netrc:parse))))
(login (or (safe-first args) (let-optionals
(netrc:lookup-login netrc (pop3-connection:host-name connection) #f) args
((login (or (netrc:lookup-login netrc (pop3-connection:host-name connection) #f)
(call-error "must provide a login" pop3-login args))) (call-error "must provide a login" pop3-login args)))
(password (or (safe-second args) (password (or (netrc:lookup-password netrc
(netrc:lookup-password netrc (pop3-connection:host-name connection) #f) (pop3-connection:host-name connection) #f)
(call-error "must provide a password" pop3-login args)))) (call-error "must provide a password" pop3-login args))))
(with-handler (with-handler
(lambda (result punt) (lambda (result punt)
@ -183,7 +187,7 @@
(pop3-send-command connection (format #f "PASS ~a" password)) (pop3-send-command connection (format #f "PASS ~a" password))
(set-pop3-connection:login connection login) (set-pop3-connection:login connection login)
(set-pop3-connection:password connection password) (set-pop3-connection:password connection password)
(set-pop3-connection:state connection 'connected))))) (set-pop3-connection:state connection 'connected))))))
;; Login to the server using APOP authentication (no cleartext ;; Login to the server using APOP authentication (no cleartext

28
scheme/lib/sunet-utilities.scm
View File

@ -26,3 +26,31 @@
(format #f "~A" (format #f "~A"
(format-internet-host-address host-address)))))) (format-internet-host-address host-address))))))
(define (dump fd)
(let loop ((c (read-char fd)))
(cond ((not (eof-object? c))
(write-char c)
(loop (read-char fd))))))
;; out from ecm-utilities.scm
;; please tell me if this doesn't work on your system.
(define (system-fqdn)
(let ((sysname (system-name)))
(if (string-index sysname #\.)
sysname
(nslookup-fqdn))))
;; This doesn't work on my system. Probably it is not configured well.
;; Nevertheless, the alternative seems better to me
;(define (nslookup-fqdn)
; (let* ((cmd (format #f "nslookup ~a" (system-name)))
; (raw (string-join (run/strings (nslookup ,(system-name)))))
; (match (string-match "Name: +([-a-zA-Z0-9.]+)" raw)))
; (display raw)
; (match:substring match 1)))
(define (nslookup-fqdn)
(host-info:name (host-info (system-name))))
; another easy alternative:
; (car (run/strings (hostname "--long"))))

28
scheme/packages.scm
View File

@ -214,13 +214,6 @@
read-crlf-line-timeout read-crlf-line-timeout
write-crlf)) write-crlf))
(define-interface ecm-utilities-interface
(export system-fqdn
safe-first
safe-second
write-crlf
dump))
(define-interface ls-interface (define-interface ls-interface
(export ls-crlf? (export ls-crlf?
ls ls
@ -233,7 +226,9 @@
(define-interface sunet-utilities-interface (define-interface sunet-utilities-interface
(export host-name-or-ip (export host-name-or-ip
on-interrupt on-interrupt
socket-address->string)) socket-address->string
dump
system-fqdn))
(define-interface handle-fatal-error-interface (define-interface handle-fatal-error-interface
(export with-fatal-error-handler* (export with-fatal-error-handler*
@ -454,7 +449,6 @@
srfi-13 srfi-13
let-opt let-opt
receiving receiving
ascii ascii
srfi-14 srfi-14
bitwise bitwise
@ -465,7 +459,6 @@
(define-structure url url-interface (define-structure url url-interface
(open defrec-package (open defrec-package
receiving receiving
srfi-13 srfi-13
srfi-14 srfi-14
uri uri
@ -483,9 +476,10 @@
conditions conditions
signals signals
error-package error-package
ecm-utilities
srfi-13 srfi-13
let-opt let-opt
sunet-utilities
crlf-io
scheme) scheme)
(files (lib ftp))) (files (lib ftp)))
@ -522,9 +516,9 @@
records records
scsh scsh
error-package error-package
ecm-utilities
srfi-13 srfi-13
conditions signals handle conditions signals handle
sunet-utilities
let-opt let-opt
scheme) scheme)
(files (lib netrc))) (files (lib netrc)))
@ -536,8 +530,9 @@
handle handle
conditions conditions
signals signals
ecm-utilities
srfi-13 srfi-13
let-opt
crlf-io
scheme) scheme)
(files (lib pop3))) (files (lib pop3)))
@ -612,12 +607,6 @@
scheme) scheme)
(files (lib crlf-io))) (files (lib crlf-io)))
(define-structure ecm-utilities ecm-utilities-interface
(open scsh
srfi-13
scheme)
(files (lib ecm-utilities)))
(define-structure ls ls-interface (define-structure ls ls-interface
(open scheme handle (open scheme handle
big-scheme bitwise big-scheme bitwise
@ -638,6 +627,7 @@
format-net format-net
sigevents sigevents
let-opt let-opt
srfi-13
handle-fatal-error) handle-fatal-error)
(files (lib sunet-utilities))) (files (lib sunet-utilities)))