eliminating ecm-utilities, code partial moved to sunet-utilities
This commit is contained in:
interp
parent
5efcb2923e
commit
6f2c0d7991
|
|
@ -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
|
||||
|
|
@ -1,6 +1,6 @@
|
|||
;;; 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>
|
||||
|
||||
|
|
@ -127,50 +127,54 @@
|
|||
|
||||
;;: [host x logfile] -> connection
|
||||
(define (pop3-connect . args)
|
||||
(let* ((host (or (getenv "MAILHOST")
|
||||
(safe-first args)))
|
||||
(logfile (safe-second args))
|
||||
(LOG (and logfile
|
||||
(open-output-file logfile
|
||||
(if (file-exists? logfile)
|
||||
(bitwise-ior open/write open/append)
|
||||
(bitwise-ior open/write open/create))
|
||||
#o600)))
|
||||
(hst-info (host-info host))
|
||||
(hostname (host-info:name hst-info))
|
||||
(srvc-info (service-info "pop3" "tcp"))
|
||||
(sock (socket-connect protocol-family/internet
|
||||
socket-type/stream
|
||||
hostname
|
||||
(service-info:port srvc-info)))
|
||||
(connection (make-pop3-connection hostname
|
||||
sock
|
||||
LOG "" "" #f #f)))
|
||||
(pop3-log connection
|
||||
(format #f "~%-- ~a: opened POP3 connection to ~a"
|
||||
;; (date->string (date))
|
||||
"Dummy date" ; (format-time-zone) is broken in v0.5.1
|
||||
hostname))
|
||||
(let-optionals
|
||||
args
|
||||
((host-arg #f)
|
||||
(logfile #f))
|
||||
(let* ((host (or (getenv "MAILHOST")
|
||||
host-arg))
|
||||
(LOG (and logfile
|
||||
(open-output-file logfile
|
||||
(if (file-exists? logfile)
|
||||
(bitwise-ior open/write open/append)
|
||||
(bitwise-ior open/write open/create))
|
||||
#o600)))
|
||||
(hst-info (host-info host))
|
||||
(hostname (host-info:name hst-info))
|
||||
(srvc-info (service-info "pop3" "tcp"))
|
||||
(sock (socket-connect protocol-family/internet
|
||||
socket-type/stream
|
||||
hostname
|
||||
(service-info:port srvc-info)))
|
||||
(connection (make-pop3-connection hostname
|
||||
sock
|
||||
LOG "" "" #f #f)))
|
||||
(pop3-log connection
|
||||
(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
|
||||
(let* ((banner (pop3-read-response connection))
|
||||
(match (regexp-search (rx (posix-string "\\+OK .* (<[^>]+>)")) banner))
|
||||
(challenge (and match (match:substring match 1))))
|
||||
(set-pop3-connection:challenge connection challenge))
|
||||
|
||||
connection))
|
||||
;; read the challenge the server sends in its welcome banner
|
||||
(let* ((banner (pop3-read-response connection))
|
||||
(match (regexp-search (rx (posix-string "\\+OK .* (<[^>]+>)")) banner))
|
||||
(challenge (and match (match:substring match 1))))
|
||||
(set-pop3-connection:challenge connection challenge))
|
||||
|
||||
connection)))
|
||||
|
||||
|
||||
;; first try standard USER/PASS authentication, and switch to APOP
|
||||
;; authentication if the server prefers.
|
||||
;;: [string x string] -> status
|
||||
(define (pop3-login connection . args)
|
||||
(let* ((netrc (and (< (length args) 2) (netrc:parse)))
|
||||
(login (or (safe-first args)
|
||||
(netrc:lookup-login netrc (pop3-connection:host-name connection) #f)
|
||||
(let ((netrc (and (< (length args) 2) (netrc:parse))))
|
||||
(let-optionals
|
||||
args
|
||||
((login (or (netrc:lookup-login netrc (pop3-connection:host-name connection) #f)
|
||||
(call-error "must provide a login" pop3-login args)))
|
||||
(password (or (safe-second args)
|
||||
(netrc:lookup-password netrc (pop3-connection:host-name connection) #f)
|
||||
(password (or (netrc:lookup-password netrc
|
||||
(pop3-connection:host-name connection) #f)
|
||||
(call-error "must provide a password" pop3-login args))))
|
||||
(with-handler
|
||||
(lambda (result punt)
|
||||
|
|
@ -183,7 +187,7 @@
|
|||
(pop3-send-command connection (format #f "PASS ~a" password))
|
||||
(set-pop3-connection:login connection login)
|
||||
(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
|
||||
|
|
|
|||
|
|
@ -26,3 +26,31 @@
|
|||
(format #f "~A"
|
||||
(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"))))
|
||||
|
|
@ -214,13 +214,6 @@
|
|||
read-crlf-line-timeout
|
||||
write-crlf))
|
||||
|
||||
(define-interface ecm-utilities-interface
|
||||
(export system-fqdn
|
||||
safe-first
|
||||
safe-second
|
||||
write-crlf
|
||||
dump))
|
||||
|
||||
(define-interface ls-interface
|
||||
(export ls-crlf?
|
||||
ls
|
||||
|
|
@ -233,7 +226,9 @@
|
|||
(define-interface sunet-utilities-interface
|
||||
(export host-name-or-ip
|
||||
on-interrupt
|
||||
socket-address->string))
|
||||
socket-address->string
|
||||
dump
|
||||
system-fqdn))
|
||||
|
||||
(define-interface handle-fatal-error-interface
|
||||
(export with-fatal-error-handler*
|
||||
|
|
@ -454,7 +449,6 @@
|
|||
srfi-13
|
||||
let-opt
|
||||
receiving
|
||||
|
||||
ascii
|
||||
srfi-14
|
||||
bitwise
|
||||
|
|
@ -465,7 +459,6 @@
|
|||
(define-structure url url-interface
|
||||
(open defrec-package
|
||||
receiving
|
||||
|
||||
srfi-13
|
||||
srfi-14
|
||||
uri
|
||||
|
|
@ -483,9 +476,10 @@
|
|||
conditions
|
||||
signals
|
||||
error-package
|
||||
ecm-utilities
|
||||
srfi-13
|
||||
let-opt
|
||||
sunet-utilities
|
||||
crlf-io
|
||||
scheme)
|
||||
(files (lib ftp)))
|
||||
|
||||
|
|
@ -522,9 +516,9 @@
|
|||
records
|
||||
scsh
|
||||
error-package
|
||||
ecm-utilities
|
||||
srfi-13
|
||||
conditions signals handle
|
||||
sunet-utilities
|
||||
let-opt
|
||||
scheme)
|
||||
(files (lib netrc)))
|
||||
|
|
@ -536,8 +530,9 @@
|
|||
handle
|
||||
conditions
|
||||
signals
|
||||
ecm-utilities
|
||||
srfi-13
|
||||
let-opt
|
||||
crlf-io
|
||||
scheme)
|
||||
(files (lib pop3)))
|
||||
|
||||
|
|
@ -612,12 +607,6 @@
|
|||
scheme)
|
||||
(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
|
||||
(open scheme handle
|
||||
big-scheme bitwise
|
||||
|
|
@ -638,6 +627,7 @@
|
|||
format-net
|
||||
sigevents
|
||||
let-opt
|
||||
srfi-13
|
||||
handle-fatal-error)
|
||||
(files (lib sunet-utilities)))
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue