diff --git a/scheme/lib/ecm-utilities.scm b/scheme/lib/ecm-utilities.scm deleted file mode 100644 index aeea61f..0000000 --- a/scheme/lib/ecm-utilities.scm +++ /dev/null @@ -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 - - -;; 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 diff --git a/scheme/lib/pop3.scm b/scheme/lib/pop3.scm index 1dfe068..968891b 100644 --- a/scheme/lib/pop3.scm +++ b/scheme/lib/pop3.scm @@ -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 @@ -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 diff --git a/scheme/lib/sunet-utilities.scm b/scheme/lib/sunet-utilities.scm index ca67e37..e407b98 100644 --- a/scheme/lib/sunet-utilities.scm +++ b/scheme/lib/sunet-utilities.scm @@ -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")))) \ No newline at end of file diff --git a/scheme/packages.scm b/scheme/packages.scm index 4f007f9..4a51921 100644 --- a/scheme/packages.scm +++ b/scheme/packages.scm @@ -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)))