diff --git a/scheme/ftpd/ftpd.scm b/scheme/ftpd/ftpd.scm new file mode 100644 index 0000000..2c31148 --- /dev/null +++ b/scheme/ftpd/ftpd.scm @@ -0,0 +1,1269 @@ +; RFC 959 ftp daemon + +; Mike Sperber +; Copyright (c) 1998 Michael Sperber. + +; It doesn't support the following desirable things: +; +; - Login by user; this requires crypt which scsh doesn't have +; - RESTART support +; - Banners from files on CWD +; - Lots of fancy stuff like ProFTPD, http://www.proftpd.org/ + + +; following things should be improved: +; +; - GET/RETR-command: ftpd reports "Can't open FILENAME for reading" if +; file actually doesn't exist. This is confusing. Reporting +; "FILENAME does not exist" is much better. +; - default value for ftpd should be looked up as in ftp.scm + +(define *logfile* #f) ; file-port to log to like wu-ftpd (analyzable with webalizer) + +(define-record session + control-input-port + control-output-port + anonymous-home + (logged-in? #f) + (authenticated? #f) + (anonymous? #f) + (root-directory #f) + (current-directory "") + (to-be-renamed #f) + (reverse-replies '()) + (reply-code #f) ; the last one wins + (type 'ascii) ; PLEASE set this to bin + (data-socket #f) + (passive-socket #f)) + +(define session (make-fluid #f)) + +(define (make-fluid-selector selector) + (lambda () (selector (fluid session)))) + +(define (make-fluid-setter setter) + (lambda (value) + (setter (fluid session) value))) + + +(define session-control-input-port (make-fluid-selector session:control-input-port)) +(define session-control-output-port (make-fluid-selector session:control-output-port)) + +(define session-anonymous-home (make-fluid-selector session:anonymous-home)) +(define session-logged-in? (make-fluid-selector session:logged-in?)) +(define session-authenticated? (make-fluid-selector session:authenticated?)) +(define session-anonymous? (make-fluid-selector session:anonymous?)) +(define session-root-directory (make-fluid-selector session:root-directory)) +(define session-current-directory (make-fluid-selector session:current-directory)) +(define session-to-be-renamed (make-fluid-selector session:to-be-renamed)) +(define session-reverse-replies (make-fluid-selector session:reverse-replies)) +(define session-reply-code (make-fluid-selector session:reply-code)) +(define session-type (make-fluid-selector session:type)) +(define session-data-socket (make-fluid-selector session:data-socket)) +(define session-passive-socket (make-fluid-selector session:passive-socket)) + +(define set-session-control-input-port + (make-fluid-setter set-session:control-input-port)) +(define set-session-control-output-port + (make-fluid-setter set-session:control-output-port)) +(define set-session-logged-in? (make-fluid-setter set-session:logged-in?)) +(define set-session-authenticated? (make-fluid-setter set-session:authenticated?)) +(define set-session-anonymous? (make-fluid-setter set-session:anonymous?)) +(define set-session-root-directory (make-fluid-setter set-session:root-directory)) +(define set-session-current-directory (make-fluid-setter set-session:current-directory)) +(define set-session-to-be-renamed (make-fluid-setter set-session:to-be-renamed)) +(define set-session-reverse-replies (make-fluid-setter set-session:reverse-replies)) +(define set-session-reply-code (make-fluid-setter set-session:reply-code)) +(define set-session-type (make-fluid-setter set-session:type)) +(define set-session-data-socket (make-fluid-setter set-session:data-socket)) +(define set-session-passive-socket (make-fluid-setter set-session:passive-socket)) + + +;;; LOG ------------------------------------------------------- +(define (log level format-message . args) + (syslog level + (apply format #f (string-append "(thread ~D) " format-message) + (thread-uid (current-thread)) args))) + +(define (log-command level command-name . argument) + (if (null? argument) + (log level "handling ~A-command" command-name) + (if (not (null? (cdr argument))) + (log level "handling ~A-command with argument ~S" + command-name argument) + (log level "handling ~A-command with argument ~S" ; does this ever happen? + command-name (car argument))))) + +;; Extended logging like wu.ftpd: +;; Each file up/download is protocolled + +; Mon Dec 3 18:52:41 1990 1 wuarchive.wustl.edu 568881 /files.lst.Z a _ o a chris@wugate.wustl.edu ftp 0 * +; +; %.24s %d %s %d %s %c %s %c %c %s %s %d %s +; 1 2 3 4 5 6 7 8 9 10 11 12 13 +; +; 1 current time in the form DDD MMM dd hh:mm:ss YYYY +; 2 transfer time in seconds +; 3 remote host name +; 4 file size in bytes +; 5 name of file +; 6 transfer type (a>scii, b>inary) +; 7 special action flags (concatenated as needed): +; C file was compressed +; U file was uncompressed +; T file was tar'ed +; _ no action taken +; 8 file was sent to user (o>utgoing) or received from +; user (i>ncoming) +; 9 accessed anonymously (r>eal, a>nonymous, g>uest) -- mostly for FTP +; 10 local username or, if guest, ID string given +; (anonymous FTP password) +; 11 service name ('ftp', other) +; 12 authentication method (bitmask) +; 0 none +; 1 RFC931 Authentication +; 13 authenticated user id (if available, '*' otherwise) +; +(define file-log + (let ((file-log-lock (make-lock))) + (lambda (start-transfer-seconds info full-path direction) + (if *logfile* + (begin + (obtain-lock file-log-lock) + (format *logfile* "~A ~A ~A ~A ~A ~A _ ~A a nop@ssword ftp 0 *~%" + (format-date "~a ~b ~d ~H:~M:~S ~Y" (date)) ; current date and time + (- (current-seconds) start-transfer-seconds) ; transfer time in secs + (socket-address->string (socket-remote-address (session-data-socket)) #f) ; remote host name + (file-info:size info) ; file size in bytes + (string-map (lambda (c) + (if (eq? c #\space) #\_ c)) + full-path) ; name of file (spaces replaced by "_") + (case (session-type) + ((ascii) "a") + ((image) "b") + (else "?")) ; transfer type + direction ; incoming / outgoing file + ; anonymous access + ; password (no password given) + ; service name + ; authentication mode + ; authenticated user id' + ) + (force-output *logfile*) + (release-lock file-log-lock)))))) + +;;; CONVERTERS ------------------------------------------------ +(define (protocol-family->string protocol-family) + (cond ((= protocol-family protocol-family/unspecified) + "unspecified") + ((= protocol-family protocol-family/internet) + "internet") + ((= protocol-family protocol-family/unix) + "unix") + (else "unknown"))) + +(define (socket->string socket) + (format #f "family: ~A, ~&local address: ~A, ~&remote address: ~A, ~&input-port ~A, ~&output-port ~A" + (protocol-family->string (socket:family socket)) + (socket-address->string (socket-local-address socket)) + (socket-address->string (socket-remote-address socket)) + (socket:inport socket) + (socket:outport socket))) + + +(define (socket-address->string socket-address . with-port?) + (let ((with-port? (optional with-port? #t))) + (receive (host-address service-port) + (socket-address->internet-address socket-address) + (if with-port? + (format #f "~A:~A" + (format-internet-host-address host-address) + (format-port service-port)) + (format #f "~A" + (format-internet-host-address host-address)))))) + +;;; ftpd ------------------------------------------------------- + +(define (ftpd anonymous-home . maybe-args) + (let-optionals + maybe-args + ((port 21) + (logfile #f)) + + (if logfile + (set! *logfile* (open-output-file logfile (bitwise-ior open/create open/append)))) + (with-syslog-destination + "ftpd" + #f + #f + #f + (lambda () + (log (syslog-level notice) + "starting daemon on port ~D with ~S as anonymous home and logfile ~S" + port (expand-file-name anonymous-home (cwd)) logfile) + + (bind-listen-accept-loop + protocol-family/internet + (lambda (socket address) + (let ((remote-address (socket-address->string address))) + (set-ftp-socket-options! socket) + (fork-thread + (spawn-to-handle-connection socket + address + anonymous-home + port + remote-address)))) + port))))) + +(define (spawn-to-handle-connection socket address anonymous-home port remote-address) + (lambda () + (call-with-current-continuation + (lambda (exit) + (with-errno-handler* + (lambda (errno packet) + (log (syslog-level notice) + "error with connection to ~A (~A)" + remote-address (car packet)) + (exit 'fick-dich-ins-knie)) + (lambda () + (let ((socket-string (socket->string socket))) + + (log (syslog-level notice) + "new connection to ~S" + remote-address) + + (log (syslog-level debug) "socket: ~S" socket-string) + + (dynamic-wind + (lambda () 'fick-dich-ins-knie) + (lambda () + (handle-connection (socket:inport socket) + (socket:outport socket) + (file-name-as-directory anonymous-home))) + (lambda () + (log (syslog-level debug) + "shutting down socket ~S" + socket-string) + (call-with-current-continuation + (lambda (exit) + (with-errno-handler* + (lambda (errno packet) + (log (syslog-level notice) + "error shutting down socket to ~A (~A)" + remote-address (car packet)) + (exit 'fick-dich-ins-knie)) + (lambda () + (shutdown-socket socket shutdown/sends+receives))))) + (log (syslog-level notice) + "closing connection to ~A and finishing thread" remote-address) + (log (syslog-level debug) + "closing socket ~S" socket-string) + (close-socket socket)))))))))) + +(define (ftpd-inetd anonymous-home . maybe-logfile) + (let ((logfile (optional maybe-logfile))) + (with-errno-handler + ((errno packet) + (else + (format (current-error-port) "[ftpd] Warning: Unable to write logs to ~S. Logging is now made to (current-error-port).~%[ftpd] (To disable logging at all, either leave the logfile argument or give #f as logfile)~%") + (set! *logfile* (current-error-port)))) + (if logfile + (set! *logfile* (open-output-file logfile (bitwise-ior open/create open/append)))))) + + (with-syslog-destination + "ftpd" + #f + #f + #f + (lambda () + (log (syslog-level notice) + "new connection on current input- and output-port with ~S as anonymous home" + (expand-file-name anonymous-home (cwd))) + + (log (syslog-level debug) + "inport: ~A, outport: ~A" + (current-input-port) + (current-output-port)) + + (handle-connection (current-input-port) + (current-output-port) + (file-name-as-directory anonymous-home))))) + +(define (set-ftp-socket-options! socket) + ;; If the client closes the connection, we won't lose when we try to + ;; close the socket by trying to flush the output buffer. + (set-port-buffering (socket:outport socket) bufpol/none) + + (set-socket-option socket level/socket socket/oob-inline #t)) + + +(define (handle-connection input-port output-port anonymous-home) + (log (syslog-level debug) + "handling connection with input port ~A, output port ~A and home ~A" + input-port + output-port + anonymous-home) + (call-with-current-continuation + (lambda (escape) + (with-handler + (lambda (condition more) + (log (syslog-level notice) + "hit error condition ~A (~S) -- exiting" + (condition-type condition) + (condition-stuff condition)) + (escape 'fick-dich-ins-knie)) + (lambda () + (let-fluid session (make-session input-port output-port + anonymous-home) + (lambda () + (display-banner) + (handle-commands)))))))) + +(define (display-banner) + (log (syslog-level debug) + "displaying banner (220)") + (register-reply! 220 + (string-append + "Scheme Untergrund ftp server (" + *ftpd-version* + ") ready."))) + +(define-condition-type 'ftpd-quit '()) +(define ftpd-quit? (condition-predicate 'ftpd-quit)) + +(define-condition-type 'ftpd-irregular-quit '()) +(define ftpd-irregular-quit? (condition-predicate 'ftpd-irregular-quit)) + +(define-condition-type 'ftpd-error '()) +(define ftpd-error? (condition-predicate 'ftpd-error)) + + +(define (handle-commands) + (log (syslog-level debug) "handling commands") + (call-with-current-continuation + (lambda (exit) + (with-handler + (lambda (condition more) + (if (ftpd-quit? condition) + (begin + (log (syslog-level debug) "quitting (write-accept-loop)") + (with-handler + (lambda (condition ignore) + (more)) + (lambda () + (write-replies) + (exit 'fick-dich-ins-knie)))) + (more))) + (lambda () + (log (syslog-level debug) + "starting write-accept-loop") + (let loop () + (write-replies) + (accept-command) + (loop))))))) + +(define (accept-command) + (let* ((timeout-seconds 90) + (command-line (read-crlf-line-timeout (session-control-input-port) + #f + (* 1000 timeout-seconds);timeout + 500))) ; max interval + (log (syslog-level debug) + "Command line: ~A" + command-line) + (cond ((eq? command-line 'timeout) + (log (syslog-level notice) "hit timelimit of ~D seconds (421)" + timeout-seconds) + (log (syslog-level debug) + "so closing control connection and quitting") + (register-reply! + 421 + (format #f "Timeout (~D seconds): closing control connection." + timeout-seconds) + (signal 'ftpd-quit))) + (else + (call-with-values + (lambda () (parse-command-line command-line)) + (lambda (command arg) + (handle-command command arg))))))) + +(define (handle-command command arg) +; (log (syslog-level debug) +; "handling command ~S with argument ~S" +; command arg) + (call-with-current-continuation + (lambda (escape) + (with-handler + (lambda (condition more) + (cond + ((error? condition) + (let ((reason (condition-stuff condition))) + (log (syslog-level notice) + "internal error occured: ~S (maybe reason: ~S) -- replying and escaping (451)" + condition reason) + (register-reply! 451 + (format #f "Internal error: ~S" reason)) + (escape 'fick-dich-ins-knie))) + ((ftpd-error? condition) + ; debug level because nearly every unsuccessful command ends + ; here (no args, can't change dir, etc.) + (log (syslog-level debug) + "ftpd error occured (maybe reason: ~S)-- escaping" (condition-stuff condition)) + (escape 'fick-dich-ins-knie)) + (else + (more)))) + (lambda () + (with-errno-handler* + (lambda (errno packet) + (let ((unix-error (car packet))) + (log (syslog-level notice) + "unix error occured: ~S -- replying (451) and escaping" + unix-error) + (register-reply! 451 + (format #f "Unix error: ~A." unix-error)) + (escape 'fick-dich-ins-knie))) + (lambda () + (dispatch-command command arg)))))))) + +(define (dispatch-command command arg) +; (log (syslog-level debug) +; "dispatching command ~S with argument ~S" +; command arg) + (cond + ((assoc command *command-alist*) + => (lambda (pair) + (log (syslog-level debug) + "command ~S was found in command-list and is executed with argument ~S" + (car pair) arg) + ((cdr pair) arg))) + (else + (log (syslog-level debug) "rejecting unknown command ~S (500) (argument: ~S)" + command arg) + (register-reply! 500 + (string-append + (format #f "Unknown command: \"~A\"" command) + (if (string=? "" arg) + "." + (format #f " (argument(s) \"~A\")." arg))))))) + + +(define (handle-user name) + (log-command (syslog-level info) "USER" name) + (cond + ((session-logged-in?) + (log (syslog-level info) "user ~S is already logged in (230)" + name) + (register-reply! 230 + "You are already logged in.")) + ((or (string=? "anonymous" name) + (string=? "ftp" name)) + (handle-user-anonymous)) + (else + (log (syslog-level info) "rejecting non-anonymous login (530)") + (register-reply! 530 + "Only anonymous logins allowed.")))) + +(define (handle-user-anonymous) + (log (syslog-level info) "anonymous user login (230)") + (set-session-logged-in? #t) + (set-session-authenticated? #t) + (set-session-anonymous? #t) + (set-session-root-directory (session-anonymous-home)) + (set-session-current-directory "") + + (register-reply! 230 "Anonymous user logged in.")) + +(define (handle-pass password) + (log-command (syslog-level info) "PASS" password) + (cond + ((not (session-logged-in?)) + (log (syslog-level info) "Rejecting password as user has not logged in yet. (530)") + (register-reply! 530 "You have not logged in yet.")) + ((session-anonymous?) + (log (syslog-level info) "Accepting password as user is logged in (200)") + (register-reply! 200 "Thank you.")) + (else + (log (syslog-level notice) "Reached unreachable case-branch while handling password (502)") + (register-reply! 502 "This can't happen.")))) + +(define (handle-quit foo) + (log-command (syslog-level info) "QUIT") + (log (syslog-level debug) "quitting (221)") + (register-reply! 221 "Goodbye! Au revoir! Auf Wiedersehen!") + (signal 'ftpd-quit)) + +(define (handle-syst foo) + (log-command (syslog-level info) "SYST") + (log (syslog-level debug) "telling system type (215)") + (register-reply! 215 "UNIX Type: L8")) + +(define (handle-cwd path) + (log-command (syslog-level info) "CWD" path) + (ensure-authenticated-login) + (let ((current-directory (assemble-path (session-current-directory) + path))) + (with-errno-handler* + (lambda (errno packet) + (let ((error-reason (car packet))) + (log (syslog-level info) + "can't change to directory \"~A\": ~A (550)" + path error-reason) + (signal-error! 550 + (format #f "Can't change directory to \"~A\": ~A." + path + error-reason)))) + (lambda () + (with-cwd* + (file-name-as-directory + (string-append (session-root-directory) current-directory)) + (lambda () ; I hate gratuitous syntax + (log (syslog-level info) + "changing current directory to \"/~A\" (250)" + current-directory) + (set-session-current-directory current-directory) + (register-reply! 250 + (format #f "Current directory changed to \"/~A\"." + current-directory)))))))) + +(define (handle-cdup foo) + (log-command (syslog-level info) "CDUP") + (handle-cwd "..")) + +(define (handle-pwd foo) + (log-command (syslog-level info) "PWD") + (ensure-authenticated-login) + (let ((current-directory (session-current-directory))) + (log (syslog-level info) "replying \"/~A\" as current directory (257)" + current-directory) + (register-reply! 257 + (format #f "Current directory is \"/~A\"." + current-directory)))) + + +(define (make-file-action-handler error-format-string action) + (lambda (path) + (ensure-authenticated-login) + (if (string=? "" path) + (begin + (log (syslog-level info) + "finishing processing command because of missing arguments (500)") + (signal-error! 500 "No argument."))) + (let ((full-path (string-append (session-root-directory) + (assemble-path (session-current-directory) + path)))) + (with-errno-handler* + (lambda (errno packet) + (let ((error-reason (car packet))) + (log (syslog-level info) + (string-append error-format-string " (550)") path error-reason) + (signal-error! 550 + (format #f error-format-string + path error-reason)))) + (lambda () + (action path full-path)))))) + +(define handle-dele + (make-file-action-handler + "Could not delete \"~A\": ~A." + (lambda (path full-path) + (log-command (syslog-level info) "DELE" path) + (delete-file full-path) + (log (syslog-level info) "deleted ~S (250)" full-path) + (log (syslog-level debug) "reporting about ~S" path) + (register-reply! 250 (format #f "Deleted \"~A\"." path))))) + +(define handle-mdtm + (make-file-action-handler + "Could not get info on \"~A\": ~A." + (lambda (path full-path) + (log-command (syslog-level info) "MDTM" path) + (let* ((info (file-info full-path)) + (the-date (date (file-info:mtime info) 0)) + (formatted-date (format-date "~Y~m~d~H~M~S" the-date))) + (log (syslog-level info) "reporting modification time of ~S: ~A (213)" + full-path + formatted-date) + (register-reply! 213 + formatted-date))))) + +(define handle-mkd + (make-file-action-handler + "Could not make directory \"~A\": ~A." + (lambda (path full-path) + (log-command (syslog-level info) "MKD" path) + (create-directory full-path #o755) + (log (syslog-level info) "created directory ~S (257)" full-path) + (log (syslog-level debug) "reporting about ~S" path) + (register-reply! 257 + (format #f "Created directory \"~A\"." path))))) + +(define handle-rmd + (make-file-action-handler + "Could not remove directory \"~A\": ~A." + (lambda (path full-path) + (log-command (syslog-level info) "RMD" path) + (delete-directory full-path) + (log (syslog-level info) "deleted directory ~S (250)" full-path) + (log (syslog-level debug) "reporting about ~S" path) + (register-reply! 250 + (format #f "Deleted directory \"~A\"." path))))) + + +(define handle-rnfr + (make-file-action-handler + "Could not get info on file \"~A\": ~A." + (lambda (path full-path) + (log-command (syslog-level info) "RNFR" path) + (file-info full-path) + (log (syslog-level info) + "RNFR-command accepted, waiting for RNTO-command (350)") + (register-reply! 350 "RNFR accepted. Gimme a RNTO next.") + (set-session-to-be-renamed full-path)))) + +(define (handle-rnto path) + (log-command (syslog-level info) "RNTO" path) + (ensure-authenticated-login) + (if (not (session-to-be-renamed)) + (begin + (log (syslog-level info) + "RNTO-command rejected: need RNFR-command before (503)") + (signal-error! 503 "Need RNFR before RNTO."))) + (if (string=? "" path) + (begin + (log (syslog-level info) + "No argument -- still waiting for (correct) RNTO-command (500)") + (signal-error! 500 "No argument."))) + (let ((full-path (string-append (session-root-directory) + (assemble-path (session-current-directory) + path)))) + + (if (file-exists? full-path) + (begin + (log (syslog-level info) "rename of ~S failed (already exists) (550)" + full-path) + (log (syslog-level debug) "reporting about ~S" + path) + (signal-error! + 550 + (format #f "Rename failed---\"~A\" already exists or is protected." + path)))) + + (with-errno-handler* + (lambda (errno packet) + (log (syslog-level info) + "failed to rename ~A (550)" path) + (signal-error! 550 + (format #f "Could not rename: ~A." path))) + (lambda () + (let ((old-name (session-to-be-renamed))) + (rename-file old-name full-path) + (log (syslog-level info) + "~S renamed to ~S - no more waiting for RNTO-command (250)" + old-name full-path) + (register-reply! 250 "File renamed.") + (set-session-to-be-renamed #f)))))) + +(define handle-size + (make-file-action-handler + "Could not get info on file \"~A\": ~A." + (lambda (path full-path) + (log-command (syslog-level info) "SIZE" path) + (let ((info (file-info full-path))) + (if (not (eq? 'regular (file-info:type info))) + (begin + (log (syslog-level info) + "rejecting SIZE-command as ~S is not a regular file (550)" + full-path) + (log (syslog-level debug) "reporting about ~S" path) + (signal-error! 550 + (format #f "\"~A\" is not a regular file." + path)))) + (let ((file-size (file-info:size info))) + (log (syslog-level info) + "reporting ~D as size of ~S (213)" + file-size full-path) + (register-reply! 213 (number->string file-size))))))) + + +(define (handle-type arg) + (log-command (syslog-level info) "TYPE" arg) + (cond + ((string-ci=? "A" arg) + (log (syslog-level info) "changed type to ascii (200)") + (set-session-type 'ascii)) + ((string-ci=? "I" arg) + (log (syslog-level info) "changed type to image (8-bit binary) (200)") + (set-session-type 'image)) + ((string-ci=? "L8" arg) + (log (syslog-level info) "changed type to image (8-bit binary) (200)") + (set-session-type 'image)) + (else + (log (syslog-level info) + "rejecting TYPE-command: unknown type (504)") + (signal-error! 504 + (format #f "Unknown TYPE: ~S." arg)))) + + (log (syslog-level debug) "reporting new type (see above)") + (register-reply! 200 + (format #f "TYPE is now ~A." + (case (session-type) + ((ascii) "ASCII") + ((image) "8-bit binary") + (else "somethin' weird, man"))))) + +(define (handle-mode arg) + (log-command (syslog-level info) "MODE" arg) + (cond + ((string=? "" arg) + (log (syslog-level info) "rejecting MODE-command: no arguments (500)") + (register-reply! 500 + "No arguments. Not to worry---I'd ignore them anyway.")) + ((string-ci=? "S" arg) + (log (syslog-level info) + "stream mode is (still) used for file-transfer (200)") + (register-reply! 200 "Using stream mode to transfer files.")) + (else + (log (syslog-level info) "mode ~S is not supported (504)" arg) + (register-reply! 504 (format #f "Mode \"~A\" is not supported." + arg))))) + +(define (handle-stru arg) + (log-command (syslog-level info) "STRU" arg) + (cond + ((string=? "" arg) + (log (syslog-level info) "rejecting STRU-command: no arguments (500)") + (register-reply! 500 + "No arguments. Not to worry---I'd ignore them anyway.")) + ((string-ci=? "F" arg) + (log (syslog-level info) "(still) using file structure to transfer files (200)") + (register-reply! 200 "Using file structure to transfer files.")) + (else + (log (syslog-level info) "file structure ~S is not supported (504)" arg) + (register-reply! 504 + (format #f "File structure \"~A\" is not supported." + arg))))) + +(define (handle-noop arg) + (log-command (syslog-level info) "NOOP") + (log (syslog-level debug) "successfully done nothing (200)") + (register-reply! 200 "Done nothing, but successfully.")) + +(define *port-arg-regexp* + (make-regexp "^([0-9]+),([0-9]+),([0-9]+),([0-9]+),([0-9]+),([0-9]+)$")) + +(define (parse-port-arg string) + (log (syslog-level debug) "parsing port-string ~S" string) + (cond + ((regexp-exec *port-arg-regexp* string) + => (lambda (match) + (let ((components + (map (lambda (match-index) + (string->number + (match:substring match match-index))) + '(1 2 3 4 5 6)))) + (if (any? (lambda (component) + (> component 255)) + components) + (begin + (log (syslog-level debug) + "rejecting PORT-command because of invalid arguments (port-component > 255) (501)") + (signal-error! 501 + "Invalid arguments to PORT."))) + (apply + (lambda (a1 a2 a3 a4 p1 p2) + (let ((address (+ (arithmetic-shift a1 24) + (arithmetic-shift a2 16) + (arithmetic-shift a3 8) + a4)) + (port (+ (arithmetic-shift p1 8) p2))) + (log (syslog-level debug) + "port-parse result: address ~D, port ~D (from compononets: address: ~A, ~A, ~A, ~A, port: ~A, ~A)" + address port + a1 a2 a3 a4 p1 p2) + (values address port))) + components)))) + (else + (log (syslog-level debug) "reporting syntax error in argument (500)") + (signal-error! 500 + "Syntax error in argument to PORT.")))) + + +(define (handle-port stuff) + (log-command (syslog-level info) "PORT" stuff) + (ensure-authenticated-login) + (maybe-close-data-connection) + (call-with-values + (lambda () (parse-port-arg stuff)) + (lambda (address port) + (let ((socket (create-socket protocol-family/internet + socket-type/stream))) + (log (syslog-level debug) + "created new socket (internet, stream, reusing address)") + (set-socket-option socket level/socket socket/reuse-address #t) + + (connect-socket socket + (internet-address->socket-address + address port)) + + (set-session-data-socket socket) + + (let ((formatted-internet-host-address + (format-internet-host-address address))) + (log (syslog-level info) + "connected to ~A, port ~A (200)" + formatted-internet-host-address port) + + (register-reply! 200 + (format #f "Connected to ~A, port ~A." + formatted-internet-host-address + port))))))) + + +(define (handle-pasv stuff) + (log-command (syslog-level info) "PASV") + (ensure-authenticated-login) + (maybe-close-data-connection) + (let ((socket (create-socket protocol-family/internet + socket-type/stream))) + + (set-socket-option socket level/socket socket/reuse-address #t) + + (bind-socket socket + (internet-address->socket-address (this-host-address) + 0)) + (listen-socket socket 1) + + (let ((address (socket-local-address socket))) + + (call-with-values + (lambda () (socket-address->internet-address address)) + (lambda (host-address port) + + (set-session-passive-socket socket) + + + (let ((formatted-this-host-address + (format-internet-host-address (this-host-address) ",")) + (formatted-port (format-port port))) + (log (syslog-level info) "accepting passive mode (on ~A,~A) (227)" + formatted-this-host-address formatted-port) + (register-reply! 227 + (format #f "Passive mode OK (~A,~A)" + formatted-this-host-address + formatted-port)))))))) + +(define (this-host-address) + (call-with-values + (lambda () + (socket-address->internet-address + (socket-local-address (port->socket (session-control-input-port) + protocol-family/internet)))) + (lambda (host-address control-port) + host-address))) + +(define (handle-nlst arg) + (log-command (syslog-level info) "NLST" arg) + (handle-listing arg '())) + +(define (handle-list arg) + (log-command (syslog-level info) "LIST" arg) + (handle-listing arg '(long))) + +(define (handle-listing arg preset-flags) + (ensure-authenticated-login) + (with-data-connection + (lambda () + (let ((args (split-arguments arg))) + (call-with-values + (lambda () + (partition-list + (lambda (arg) + (and (not (string=? "" arg)) + (char=? #\- (string-ref arg 0)))) + args)) + (lambda (flag-args rest-args) + + (if (and (not (null? rest-args)) + (not (null? (cdr rest-args)))) + (begin + (log (syslog-level info) "got more than one path argument - rejection (501)") + (signal-error! 501 "More than one path argument."))) + + (let ((path (if (null? rest-args) + "" + (car rest-args))) + (flags (arguments->ls-flags flag-args))) + + (if (not flags) + (begin + (log (syslog-level info) "got invalid flags (501)") + (signal-error! 501 "Invalid flag(s)."))) + (let ((all-flags (append preset-flags flags))) + (log (syslog-level info) + "sending file-listing for path ~S with flags ~A" + path all-flags) + + (generate-listing path all-flags))))))))) + +; Note this doesn't call ENSURE-AUTHENTICATED-LOGIN or +; ENSURE-DATA-CONNECTION. + +(define (generate-listing path flags) + (let ((full-path (string-append (session-root-directory) + (assemble-path (session-current-directory) + path)))) + (with-errno-handler* + (lambda (errno packet) + (let ((error-reason (car packet))) + (log (syslog-level info) + "can't access directory at ~A: ~A (451)" + path error-reason) + (signal-error! 451 + (format #f "Can't access directory at ~A: ~A." + path + error-reason)))) + (lambda () + (with-cwd* + (file-name-directory full-path) + (lambda () + (let ((nondir (file-name-nondirectory full-path))) + (let-fluid + ls-crlf? #t + (lambda () + (ls flags + (list + ;; work around OLIN BUG + (if (string=? nondir "") + "." + nondir)) + (socket:outport (session-data-socket)))))))))))) + +(define (handle-abor foo) + (log-command (syslog-level info) "ABOR") + (maybe-close-data-connection) + (log (syslog-level info) "closing data connection (226)") + (register-reply! 226 "Closing data connection.")) + +(define (handle-retr path) + (log-command (syslog-level info) "RETR") + (ensure-authenticated-login) + (let ((full-path (string-append (session-root-directory) + (assemble-path (session-current-directory) + path)))) + (with-fatal-error-handler* ; CALL-WITH-INPUT-FILE doesn't go through ERRNO + (lambda (condition more) + (let ((reason (condition-stuff condition))) + (log (syslog-level info) "failed to open ~S for reading (maybe reason: ~S) (550)" full-path reason) + (log (syslog-level debug) "replying error for file ~S (maybe reason: ~S)" path reason) + (signal-error! 550 + (format #f "Can't open \"~A\" for reading." + path)))) + (lambda () + (let ((info (file-info full-path)) + (start-transfer-seconds (current-seconds))) + (if (not (eq? 'regular (file-info:type info))) + (begin + (log (syslog-level info) "rejecting RETR-command as ~S is not a regular file (450)" + full-path) + (log (syslog-level debug) "reporting about ~S" path) + (signal-error! 450 + (format #f "\"~A\" is not a regular file." + path)))) + (call-with-input-file full-path + (lambda (file-port) + (with-data-connection + (lambda () + (case (session-type) + ((image) + (log (syslog-level info) + "sending file ~S (binary mode)" + full-path) + (log (syslog-level debug) "sending is from port ~S" file-port) + (copy-port->port-binary + file-port + (socket:outport (session-data-socket)))) + ((ascii) + (log (syslog-level info) "sending file ~S (ascii mode)" + full-path) + (log (syslog-level debug) "sending is from port ~S" file-port) + (copy-port->port-ascii + file-port + (socket:outport (session-data-socket))))) + (file-log start-transfer-seconds info full-path "o")))))))))) + +(define (current-seconds) + (receive (time ticks) (time+ticks) time)) + +(define (handle-stor path) + (log-command (syslog-level info) "STOR" path) + (ensure-authenticated-login) + (let ((full-path (string-append (session-root-directory) + (assemble-path (session-current-directory) + path)))) + (with-fatal-error-handler* + (lambda (condition more) + (let ((reason (condition-stuff condition))) + (log (syslog-level info) "can't open ~S for writing (maybe reason: ~S) (550)" full-path reason) + (log (syslog-level debug) "replying error for file ~S (maybe reason: ~S)" path reason) + (signal-error! 550 (format #f "Can't open \"~A\" for writing." path)))) + (lambda () + (let ((start-transfer-seconds (current-seconds))) + (call-with-output-file full-path + (lambda (file-port) + (with-data-connection + (lambda () + (let ((inport (socket:inport (session-data-socket)))) + (case (session-type) + ((image) + (log (syslog-level notice) + "storing data to ~S (binary mode)" + full-path) + (log (syslog-level debug) + "storing comes from socket-inport ~S (binary-mode)" + inport) + (copy-port->port-binary + (socket:inport (session-data-socket)) + file-port)) + ((ascii) + (log (syslog-level notice) + "storing data to ~S (ascii-mode)" + full-path) + (log (syslog-level debug) + "storing comes from socket-inport ~S (ascii-mode)" + inport) + (copy-ascii-port->port + (socket:inport (session-data-socket)) + file-port))) + (file-log start-transfer-seconds (file-info full-path) full-path "i") + )))))))))) + +(define (assemble-path current-directory path) + (log (syslog-level debug) "assembling path ~S" + path) + (let* ((interim-path + (if (not (file-name-rooted? path)) + (string-append (file-name-as-directory current-directory) + path) + path)) + (complete-path (if (file-name-rooted? interim-path) + (file-name-sans-rooted interim-path) + interim-path))) + (log (syslog-level debug) "name ~S assembled to ~S" + path complete-path) + (cond + ((normalize-path complete-path) + => (lambda (assembled-path) assembled-path)) + (else + (log (syslog-level debug) + "invalid pathname -- tried to pass root directory (501)") + (signal-error! 501 "Invalid pathname"))))) + +(define (ensure-authenticated-login) + (if (or (not (session-logged-in?)) + (not (session-authenticated?))) + (begin + (log (syslog-level debug) + "login authentication failed - user is not logged in (530)") + (signal-error! 530 "You're not logged in yet.")) + (log (syslog-level debug) "authenticated login ensured"))) + +(define (with-data-connection thunk) + (dynamic-wind ensure-data-connection + thunk + maybe-close-data-connection)) + +(define *window-size* 51200) + +(define (ensure-data-connection) + (if (and (not (session-data-socket)) + (not (session-passive-socket))) + (begin + (log (syslog-level debug) "no data connection (425)") + (signal-error! 425 "No data connection."))) + + (if (session-passive-socket) + (call-with-values + (lambda () (accept-connection (session-passive-socket))) + (lambda (socket socket-address) + (set-session-data-socket socket)))) + + (log (syslog-level debug) "opening data connection (150)") + (register-reply! 150 "Opening data connection.") + (write-replies) + + (set-socket-option (session-data-socket) level/socket + socket/send-buffer *window-size*) + (set-socket-option (session-data-socket) level/socket + socket/receive-buffer *window-size*)) + +(define (maybe-close-data-connection) + (if (or (session-data-socket) (session-passive-socket)) + (close-data-connection))) + +(define (close-data-connection) + (if (session-data-socket) + (close-socket (session-data-socket))) + (if (session-passive-socket) + (close-socket (session-passive-socket))) + (log (syslog-level debug) "closing data connection (226)") + (register-reply! 226 "Closing data connection.") + (set-session-data-socket #f) + (set-session-passive-socket #f)) + +(define *command-alist* + (list + (cons "NOOP" handle-noop) + (cons "USER" handle-user) + (cons "PASS" handle-pass) + (cons "QUIT" handle-quit) + (cons "SYST" handle-syst) + (cons "CWD" handle-cwd) + (cons "PWD" handle-pwd) + (cons "CDUP" handle-cdup) + (cons "DELE" handle-dele) + (cons "MDTM" handle-mdtm) + (cons "MKD" handle-mkd) + (cons "RMD" handle-rmd) + (cons "RNFR" handle-rnfr) + (cons "RNTO" handle-rnto) + (cons "SIZE" handle-size) + (cons "TYPE" handle-type) + (cons "MODE" handle-mode) + (cons "STRU" handle-stru) + (cons "PORT" handle-port) + (cons "PASV" handle-pasv) + (cons "NLST" handle-nlst) + (cons "LIST" handle-list) + (cons "RETR" handle-retr) + (cons "STOR" handle-stor) + (cons "ABOR" handle-abor))) + +(define (parse-command-line line) + (if (eof-object? line) ; Netscape does this + (signal 'ftpd-irregular-quit) + (let* ((line (string-trim-both line char-set:whitespace)) + (split-position (string-index line #\space))) + (if split-position + (values (string-map char-upcase (substring line 0 split-position)) + (string-trim-both (substring line + (+ 1 split-position) + (string-length line)) + char-set:whitespace)) + (values (string-map char-upcase line) ""))))) + +; Path names + +; This removes all internal ..'s from a path. +; NORMALIZE-PATH returns #f if PATH points to a parent directory. + +(define (normalize-path path) + (let loop ((components (split-file-name (simplify-file-name path))) + (reverse-result '())) + (cond + ((null? components) + (path-list->file-name (reverse reverse-result))) + ((string=? ".." (car components)) + (if (null? reverse-result) + #f + (loop (cdr components) (cdr reverse-result)))) + (else + (loop (cdr components) (cons (car components) reverse-result)))))) + +(define (file-name-rooted? file-name) + (and (not (string=? "" file-name)) + (char=? #\/ (string-ref file-name 0)))) + +(define (file-name-sans-rooted file-name) + (substring file-name 1 (string-length file-name))) + +(define split-arguments + (infix-splitter (make-regexp " +"))) + +; Reply handling + +; Replies must be synchronous with requests and actions. Therefore, +; they are queued on generation via REGISTER-REPLY!. The messages are +; printed via WRITE-REPLIES. For the nature of the replies, see RFC +; 959. + + +(define (write-replies) + (if (not (null? (session-reverse-replies))) + (let loop ((messages (reverse (session-reverse-replies)))) + (if (null? (cdr messages)) + (write-final-reply (car messages)) + (begin + (write-nonfinal-reply (car messages)) + (loop (cdr messages)))))) + (set-session-reverse-replies '())) + +(define (write-final-reply line) + (format (session-control-output-port) "~D ~A" (session-reply-code) line) + (log (syslog-level debug) "Reply: ~D ~A~%" (session-reply-code) line) + (write-crlf (session-control-output-port))) + +(define (write-nonfinal-reply line) + (format (session-control-output-port) "~D-~A" (session-reply-code) line) + (log (syslog-level debug) "Reply: ~D-~A~%" (session-reply-code) line) + (write-crlf (session-control-output-port))) + +(define (signal-error! code message) + (register-reply! code message) + (signal 'ftpd-error)) + +(define (register-reply! code message) + (set-session-reverse-replies + (cons message (session-reverse-replies))) + (set-session-reply-code code)) + +; Version + +(define *ftpd-version* "$Revision: 1.1 $") + +(define (copy-port->port-binary input-port output-port) + (let ((buffer (make-string *window-size*))) + (let loop () + (cond + ((read-string! buffer input-port) + => (lambda (length) + (write-string buffer output-port 0 length) + (loop)))))) + (force-output output-port)) + +(define (copy-port->port-ascii input-port output-port) + (let loop () + (let ((line (read-line input-port 'concat))) + (if (not (eof-object? line)) + (let ((length (string-length line))) + (cond + ((zero? length) + 'fick-dich-ins-knie) + ((char=? #\newline (string-ref line (- length 1))) + (write-string line output-port 0 (- length 1)) + (write-crlf output-port)) + (else + (write-string line output-port))) + (loop))))) + (force-output output-port)) + +(define (copy-ascii-port->port input-port output-port) + (let loop () + (let* ((line (read-crlf-line input-port + #f + 90000 ; timeout + 500)) ; max interval + (length (string-length line))) + (if (not (eof-object? line)) + (begin + (write-string line output-port 0 length) + (newline output-port) + (loop))))) + (force-output output-port)) + +; Utilities + +(define (optional maybe-arg default-exp) + (cond + ((null? maybe-arg) default-exp) + ((null? (cdr maybe-arg)) (car maybe-arg)) + (else (error "too many optional arguments" maybe-arg)))) diff --git a/scheme/lib/cgi-script.scm b/scheme/lib/cgi-script.scm new file mode 100644 index 0000000..0e519fc --- /dev/null +++ b/scheme/lib/cgi-script.scm @@ -0,0 +1,95 @@ +;;; NCSA's WWW Common Gateway Interface -- script-side code -*- Scheme -*- +;;; Copyright (c) 1995 by Olin Shivers. + +;;; See http://hoohoo.ncsa.uiuc.edu/cgi/interface.html for a sort of "spec". + +;;; Imports and non-R4RS'isms +;;; switch (control structure) +;;; getenv read-string (scsh) +;;; error +;;; parse-html-form-query (parse-html-forms package) + + +;;; This file provides routines to help you write programs in Scheme +;;; that can interface to HTTP servers using the CGI program interface +;;; to carry out HTTP transactions. + +;;; Other files/packages that will be of help: +;;; rfc822 For reading headers from entities. +;;; uri url For parsing and unparsing these things. Also for generally +;;; URI-decoding strings. +;;; htmlout For generating HTML output. + +;;; About HTML forms +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; This info is in fact independent of CGI, but important to know about, +;;; as many CGI scripts are written for responding to forms-entry in +;;; HTML browsers. +;;; +;;; The form's field data are turned into a single string, of the form +;;; name=val&name=val +;;; where the and parts are URI encoded to hide their +;;; &, =, and + chars, among other things. After URI encoding, the +;;; space chars are converted to + chars, just for fun. It is important +;;; to encode the spaces this way, because the perfectly general %xx escape +;;; mechanism might be insufficiently confusing. This variant encoding is +;;; called "form-url encoding." +;;; +;;; If the form's method is POST, +;;; Browser sends the form's field data in the entity block, e.g., +;;; "button=on&ans=yes". The request's Content-type: is application/ +;;; x-www-form-urlencoded, and the request's Content-length: is the +;;; number of bytes in the form data. +;;; +;;; If the form's method is GET, +;;; Browser sends the form's field data in the URL's part. +;;; (So the server will pass to the CGI script as $QUERY_STRING, +;;; and perhaps also on in argv[]). +;;; +;;; In either case, the data is "form-url encoded" (as described above). + +;;; ISINDEX queries: +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; (Likewise for ISINDEX URL queries from browsers.) +;;; Browser url-form encodes the query (see above), which then becomes the +;;; ? part of the URI. (Hence the CGI script will split the individual +;;; fields into argv[].) + + +;;; CGI interface: +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; - The URL's part is assigned to env var $QUERY_STRING, undecoded. +;;; - If it contains no raw "=" chars, it is split at "+" chars. The +;;; substrings are URI decoded, and become the elts of argv[]. You aren't +;;; supposed to rely on this unless you are replying to ISINDEX queries. +;;; - The CGI script is run with stdin hooked up to the socket. If it's going +;;; to read the entity, it should read $CONTENT_LENGTH bytes worth. +;;; - A bunch of env vars are set with useful values. +;;; - Entity block is passed to script on stdin; +;;; script writes reply to stdout. +;;; - If the script begins with "nph-" its output is the entire reply. +;;; Otherwise, when it replies to the server, it sends back a special +;;; little header that tells the server how to construct the real header +;;; for the reply. +;;; See the "spec" for further details. (URL above) + + +;;; (cgi-form-query) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Return the form data as an alist of decoded strings. +;;; So a query string like "button=on&reply=Oh,%20yes" becomes alist +;;; (("button" . "on") ("reply" . "Oh, yes")) +;;; This only works for GET and POST methods. + +(define (cgi-form-query) + (let ((request-method (getenv "REQUEST_METHOD"))) + (cond + + ((string=? request-method "GET") + (parse-html-form-query (getenv "QUERY_STRING"))) + + ((string=? request-method "POST") + (let ((nchars (string->number (getenv "CONTENT_LENGTH")))) + (parse-html-form-query (read-string nchars)))) + + (else (error "Method not handled."))))) ; Don't be calling me. diff --git a/scheme/lib/crlf-io.scm b/scheme/lib/crlf-io.scm new file mode 100644 index 0000000..f2d4445 --- /dev/null +++ b/scheme/lib/crlf-io.scm @@ -0,0 +1,53 @@ +;;; Read cr/lf and lf terminated lines. -*- Scheme -*- +;;; Copyright (c) 1995 by Olin Shivers. + +;;; External dependencies and non-R4RS'isms +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; ascii->char (To create a carriage-return) +;;; read-line write-string force-output (scsh I/O procs) +;;; receive values (MV return) +;;; let-optionals +;;; "\r\n" in strings for cr/lf. (Not R4RS) + +;;; (read-crlf-line [fd/port retain-crlf?]) -> string or EOF object +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Read a line terminated by either line-feed or EOF. If RETAIN-CRLF? is #f +;;; (the default), a terminating cr/lf or lf sequence is trimmed from the +;;; returned string. +;;; +;;; This is simple and inefficient. It would be save one copy if we didn't +;;; use READ-LINE, but replicated its implementation instead. + +(define (read-crlf-line . args) + (let-optionals args ((fd/port (current-input-port)) + (retain-crlf? #f)) + (let ((ln (read-line fd/port retain-crlf?))) + (if (or retain-crlf? (eof-object? ln)) + ln + (let ((slen (string-length ln))) ; Trim a trailing cr, if any. + (if (or (zero? slen) + (not (char=? (string-ref ln (- slen 1)) cr))) + ln + (substring ln 0 (- slen 1)))))))) + +(define cr (ascii->char 13)) + +(define (write-crlf port) + (write-string "\r\n" port) + (force-output port)) + +(define (read-crlf-line-timeout . args) + (let-optionals args ((fd/port (current-input-port)) + (retain-crlf? #f) + (timeout 8000) + (max-interval 500)) + (let loop ((waited 0) (interval 100)) + (cond ((> waited timeout) + 'timeout) + ((char-ready? fd/port) + (read-crlf-line fd/port retain-crlf?)) + (else (sleep interval) + (loop (+ waited interval) (min (* interval 2) + max-interval))))))) + + diff --git a/scheme/lib/dns.scm b/scheme/lib/dns.scm new file mode 100644 index 0000000..aad89c7 --- /dev/null +++ b/scheme/lib/dns.scm @@ -0,0 +1,1221 @@ +; +; dns.scm +; +; Implementation of the RFC1035 +; domain names - implementation and specification +; based on the PLT-implementation. +; +; +; TODO: +; - test, test, test +; - types from newer RFCs (41, unknown) +; - more documentation +; +; +; sample usage: +; +; (dns-lookup-name [nameserver]) --> +; (dns-lookup-ip [nameserver]) --> +; (dns-lookup-nameserver [nameserver]) --> +; (dns-lookup-mail-exchanger [nameserver]) --> +; +; (dns-lookup [nameserver]) --> +; (show-dns-message the whole message, human readable +; +; (concurrent-lookup ) +; +; some lookups return a hostname (e.g. mx). +; many applications need instead of a hostname a ip address. +; force-ip and force-ip-list guarantee that a ip address is +; returned. +; +; (force-ip ) --> +; (force-ip-list ) --> + + + +;;; should debug-msgs be printed out? +(define *debug* #f) + + +;; --- error conditions +(define-condition-type 'invalid-type '()) +(define invalid-type? (condition-predicate 'invalid-type)) + +(define-condition-type 'invalid-class '()) +(define invalid-class? (condition-predicate 'invalid-class)) + +(define-condition-type 'parse-error '()) +(define parse-error? (condition-predicate 'parse)) + +(define-condition-type 'unexpected-eof-from-server '()) +(define unexpected-eof-from-server? (condition-predicate 'unexpected-eof-from-server)) + +(define-condition-type 'bad-address '()) +(define bad-address? (condition-predicate 'bad-address)) + +(define-condition-type 'no-nameservers '()) +(define no-nameservers? (condition-predicate 'no-nameservers)) + +(define-condition-type 'not-a-hostname '()) +(define not-a-hostname? (condition-predicate 'not-a-hostname)) + +(define-condition-type 'not-a-ip '()) +(define not-a-ip? (condition-predicate 'not-a-ip)) + + +(define-condition-type 'dns-format-error '()) +(define dns-format-error? (condition-predicate 'dns-format-error)) + +(define-condition-type 'dns-server-failure '()) +(define dns-server-failure? (condition-predicate 'dns-server-failure)) + +(define-condition-type 'dns-name-error '()) +(define dns-name-error? (condition-predicate 'dns-name-error)) + +(define-condition-type 'dns-not-implemented '()) +(define dns-not-implemented? (condition-predicate 'dns-not-implemented)) + +(define-condition-type 'dns-refused '()) +(define dns-refused? (condition-predicate 'dns-refused)) + + +(define-condition-type 'dns-error '(dns-format-error + dns-server-failure + dns-name-error + dns-not-implemented + dns-refused)) + +(define dns-error? (condition-predicate 'dns-error)) + + +;; called by the error-handlers, prints out error descriptions +(define (dns-error-messages condition more) + (cond + ((invalid-type? condition) + (display "make-octet-question: invalid DNS query type\n")) + ((invalid-class? condition) + (display "make-octet-question: invalid DNS query class\n")) + ((parse-error? condition) + (display "parse: error parsing server message\n")) + ((unexpected-eof-from-server? condition) + (display "send-receive-message: unexpected EOF from server\n")) + ((bad-address? condition) + (display "dns-get-information: bad address (in combination with query type)\n")) + ((no-nameservers? condition) + (display "dns-find-nameserver: no nameservers found in /etc/resolv.conf\n")) + ((not-a-hostname? condition) + (display "no hostname given\n")) + ((not-a-ip? condition) + (display "no ip given\n")) + ((dns-format-error? condition) + (display "error from server: (1) format error\n")) + ((dns-server-failure? condition) + (display "error from server: (2) server failure\n")) + ((dns-name-error? condition) + (display "error from server: (3) name error\n")) + ((dns-not-implemented? condition) + (display "error from server: (4) not implemented\n")) + ((dns-refused? condition) + (display "error from server: (5) refused\n")) + (else (more)))) + + + +;;; -- globals and types + +;; off +(define *nul* (ascii->char 0)) + +;; on +(define *on* (ascii->char 1)) + +;; message types +(define types + '((unknown 0); types, which are not yet implemented + (a 1) ; a host address + (ns 2) ; an authoritative name server + (md 3) ; (obsolete) + (mf 4) ; (obsolete) + (cname 5) ; the canonical name for an alias + (soa 6) ; marks the start of a zone of authority + (mb 7) ; (experimental) + (mg 8) ; (experimental) + (mr 9) ; (experimental) + (null 10) ; (experimental) + (wks 11) ; a well known service description + (ptr 12) ; a domain name pointer + (hinfo 13) ; host information + (minfo 14) ; (experimental) + (mx 15) ; mail exchange + (txt 16))) ; text strings + +;; message classes +(define classes + '((in 1) ; the Internet + (cs 2) ; (obsolete) + (ch 3) ; the CHAOS class + (hs 4))) ; Hesoid + + +;;; -- useful stuff + +;; assoc the other way round +(define (cossa i l) + (if *debug* (display "cossa\n")) + (cond + ((null? l) 'unknown) + ((equal? (cadar l) i) + (car l)) + (else (cossa i (cdr l))))) + +;; encodes numbers (16bit) to octets +(define (number->octet-pair n) + (if *debug* (display "number->octet-pair\n")) + (list (ascii->char (arithmetic-shift n -8)) + (ascii->char (modulo n 256)))) + +;; decodes octets to numbers (16bit) +(define (octet-pair->number a b) + (if *debug* (display "octet-pair->number\n")) + (+ (arithmetic-shift (char->ascii a) 8) + (char->ascii b))) + +;; encodes numbers (32bit) to octets, needed for ttl +(define (number->octet-quad n) + (if *debug* (display "number->octet-quad\n")) + (list (ascii->char (arithmetic-shift n -24)) + (ascii->char (modulo (arithmetic-shift n -16) 256)) + (ascii->char (modulo (arithmetic-shift n -8) 256)) + (ascii->char (modulo n 256)))) + +;; decodes octets to numbers, needed for 32bit ttl +(define (octet-quad->number a b c d) + (if *debug* (display "octet-quad->number\n")) + (+ (arithmetic-shift (char->ascii a) 24) + (arithmetic-shift (char->ascii b) 16) + (arithmetic-shift (char->ascii c) 8) + (char->ascii d))) + +;; encodes a domain-name string to octets +(define (name->octets s) + (define (encode-portion s) + (cons + (ascii->char (string-length s)) + (string->list s))) + + (if *debug* (display "name->octets\n")) + (let loop ((s s)) + (cond + ((regexp-search (posix-string->regexp "^([^.]*)\\.(.*)") s) + => (lambda (match) + (append + (encode-portion (match:substring match 1)) + (loop (match:substring match 2))))) + (else + (if (= 0 (string-length s)) + (list *nul*) + (append + (encode-portion s) + (list *nul*))))))) + +;; for tcp: message has to be tagged with its length +(define (add-size-tag m) + (if *debug* (display "add-size-tag\n")) + (append (number->octet-pair (length m)) m)) + +;; converts an octeted-ip to an human readable ip-string +(define (ip->string s) + (if *debug* (display "ip->string\n")) + (format #f + "~a.~a.~a.~a" + (char->ascii (list-ref s 0)) + (char->ascii (list-ref s 1)) + (char->ascii (list-ref s 2)) + (char->ascii (list-ref s 3)))) + +;; converts an ip-string to octets +(define (string->ip s) + (if *debug* (display "string->ip\n")) + (let loop ((s s) + (result '())) + (cond + ((regexp-search (posix-string->regexp "^([^.]*)\\.(.*)") s) + => (lambda (match) + (loop (match:substring match 2) (append result (list (ascii->char (string->number (match:substring match 1)))))))) + (else + (append result (list (ascii->char (string->number s)))))))) + +;; calculates a "random" number, needed for message-ids +(define random + (let ((crank (make-random (modulo (time) (- (expt 2 27) 1))))) + (lambda (limit) + (quotient (* (modulo (crank) 314159265) + limit) + 314159265)))) + +;; checks if a string is a ip +(define (ip? s) + (if *debug* (display "ip-string->in-addr\n")) + (let loop ((s s) + (count 0)) + (cond + ((regexp-search (posix-string->regexp "^([^.]*)\\.(.*)") s) + => (lambda (match) + (let* ((portion (match:substring match 1)) + (number (string->number portion))) + (if (and number (< number 256)) + (loop (match:substring match 2) (+ count 1)) + #f)))) + (else + (let ((number (string->number s))) + (and number + (< number 256) + (= count 3) + #t)))))) + + +;; returns a in-addr.arpa name-string or #f (needed to resolve hostname by ip) +(define (ip-string->in-addr s) + (if *debug* (display "ip-string->in-addr\n")) + (let loop ((s s) + (count 0) + (result "")) + (cond + ((regexp-search (posix-string->regexp "^([^.]*)\\.(.*)") s) + => (lambda (match) + (let* ((portion (match:substring match 1)) + (number (string->number portion))) + (if (and number (< number 256)) + (loop (match:substring match 2) (+ count 1) (string-append portion "." result)) + #f)))) + (else + (let ((number (string->number s))) + (and number + (< number 256) + (= count 3) + (string-append s "." result "in-addr.arpa"))))))) + +;; filters types in a list of rrs +(define (filter-type list type) + (if *debug* (display "ip-string->in-addr\n")) + (filter (lambda (rr) + (eq? (rr:type rr) type)) + list)) + +;; sorts a mx-rr-list by preference. needed for dns-lookup-mail-exchanger. +(define (sort-by-preference mx-list) + (sort-list mx-list + (lambda (a b) + (< (rr-data-mx:preference (rr:data a)) (rr-data-mx:preference (rr:data b)))))) + + +;; returns a IP if available (additonal type-a processing) +(define (force-ip name) + (let loop ((result (dns-lookup-name name))) + (if (ip? result) + result + (loop (dns-lookup-name result))))) + +;; returns a list of IPs (additional type-a processing) +(define (force-ip-list names) + (map (lambda (elem) (force-ip elem)) names)) + + +;;; -- message constructors: encode to octet-messages + +;; makes an message header +(define (make-octet-header id qr opcode aa tc rd ra z rcode qdcount ancount nscount arcount) + (if *debug* (display "make-octet-header\n")) + (let* ((header-id (number->octet-pair id)) + (header-flags (list + (ascii->char (+ (arithmetic-shift qr 7) + (arithmetic-shift opcode 3) + (arithmetic-shift aa 2) + (arithmetic-shift tc 1) + rd)) + (ascii->char (+ (arithmetic-shift ra 7) + (arithmetic-shift z 4) + rcode)))) + (header-qdcount (number->octet-pair qdcount)) + (header-ancount (number->octet-pair ancount)) + (header-nscount (number->octet-pair nscount)) + (header-arcount (number->octet-pair arcount))) + (append header-id + header-flags + header-qdcount + header-ancount + header-nscount + header-arcount))) + + +;; a standard query header, usefull for most queries +(define (make-std-octet-query-header id question-count) + (if *debug* (display "make-std-octet-query-header\n")) + (let* ((qr 0) ; querytype: query 0, response 1 + (opcode 0) ; opcode: query 0, iquery 1 (OBSOLETE), status 2 + (aa 0) ; authorative answer (in answers only) + (tc 0) ; truncation (size matters only with UDP) + (rd 1) ; recursion desired: nameserver pursues the query recursivly (optional) + (ra 0) ; recursion available (in answers only) + (z 0) ; future use + (rcode 0) ; response code: error conditions (in answers only) + (qdcount question-count) + (ancount 0) ; answer count (in answers only) + (nscount 0) ; name server resources (in answers only) + (arcount 0)) ; additional records (in answers only) + + (make-octet-header id qr opcode aa tc rd ra z rcode qdcount ancount nscount arcount))) + + +;; makes a question (name, type, class) +(define (make-octet-question name type class) + (if *debug* (display "make-octet-question\n")) + (if (not (assoc type types)) + (signal 'invalid-type)) + (if (not (assoc class classes)) + (signal 'invalid-class)) + + (let* ((qname (name->octets name)) + (qtype (number->octet-pair (cadr (assoc type types)))) + (qclass (number->octet-pair (cadr (assoc class classes))))) + (append qname qtype qclass))) + + +;; makes a query-message (header and question only) +(define (make-octet-query-message id name type class) + (if *debug* (display "make-octet-query-message\n")) + (append + (make-std-octet-query-header id 1) + (make-octet-question name type class))) + + +;; makes a resource record for ans, nss, ars (name, type, class, ttl, data) +(define (make-octet-rr name type class ttl rdata) + (if *debug* (display "make-octet-rr\n")) + (let* ((name (name->octets name)) + (type (number->octet-pair (cadr (assoc type types)))) + (class (number->octet-pair (cadr (assoc class classes)))) + (ttl (number->octet-quad ttl)) + (rdlength (number->octet-pair (length rdata))) + (rdata rdata)) + (append name type class ttl rdlength rdata))) + + + +;;; -- parsed message records + +;;; -- dns-message: complete data-structure of an dns-lookup +(define-record dns-message + query + reply + cache? + protocol + tried-nameservers) + +;; message +(define-record message + header + questions + answers + nameservers + additionals + source) + +;; header +(define-record header + id + flags + qdc + anc + nsc + arc) + +;; flags +(define-record flags + querytype + opcode + auth + trunc + recursiondesired + recursionavailable + z + rcode) + +;; question +(define-record question + name + type + class) + +;; rr +(define-record rr + name + type + class + ttl + data) + +;; cache +(define-record cache + answer + ttl + time) + +;;; -- message parser + +;; parses a domain-name in an message. returns the name and the rest of the message. +(define (parse-name start message) + (if *debug* (display "parse-name\n")) + (let ((v (char->ascii (car start)))) + (cond + ((zero? v) + ;; End of name + (values #f (cdr start))) + ((zero? (bitwise-and #xc0 v)) + ;; Normal label + (let loop ((len v) + (start (cdr start)) + (accum '())) + (cond + ((zero? len) + (call-with-values + (lambda () (parse-name start message)) + (lambda (s start) + (let ((s0 (list->string (reverse! accum)))) + (values (if s + (string-append s0 "." s) + s0) + start))))) + (else (loop (- len 1) + (cdr start) + (cons (car start) accum)))))) + (else + ;; Compression offset + (let ((offset (+ (arithmetic-shift (bitwise-and #x3f v) 8) + (char->ascii (cadr start))))) + (call-with-values + (lambda () (parse-name (list-tail message offset) message)) + (lambda (s ignore-start) + (values s (cddr start))))))))) + +;; parses a question in a message. returns the question and the rest of the message. +(define (parse-question start message) + (if *debug* (display "parse-question\n")) + (call-with-values + (lambda () (parse-name start message)) + (lambda (name start) + (let ((type (car (cossa (octet-pair->number (car start) (cadr start)) types))) + (start (cddr start))) + (let ((class (car (cossa (octet-pair->number (car start) (cadr start)) classes))) + (start (cddr start))) + (values (make-question name type class) start)))))) + +;; parses a resourcerecord in a message. returns the rr and the rest of the message. +(define (parse-rr start message) + (if *debug* (display "parse-rr\n")) + (call-with-values + (lambda () (parse-name start message)) + (lambda (name start) + (let ((type (car (cossa (octet-pair->number (car start) (cadr start)) types))) + (start (cddr start))) + (let ((class (car (cossa (octet-pair->number (car start) (cadr start)) classes))) + (start (cddr start))) + (let ((ttl (octet-quad->number (car start) (cadr start) + (caddr start) (cadddr start))) + (start (cddddr start))) + (let ((len (octet-pair->number (car start) (cadr start))) + (start (cddr start))) + ;; Extract next len bytes of data: + (let loop ((len len) + (start start) + (accum '())) + (if (zero? len) + (values (make-rr name type class ttl (parse-rr-data type class (reverse! accum) message)) start) + (loop (- len 1) + (cdr start) + (cons (car start) accum))))))))))) + +;;; -- rr-data-type records + +(define-record rr-data-a + ip) + +(define-record rr-data-ns + name) + +(define-record rr-data-cname + name) + +;; ### +;; hinfo not correctly implemented, trying to find examples +(define-record rr-data-hinfo + data) + +(define-record rr-data-mx + preference + exchanger) + +(define-record rr-data-ptr + name) + +(define-record rr-data-soa + mname + rname + serial + refresh + retry + expire + minimum) + +;; ### same as hinfo +(define-record rr-data-txt + text) + +;; ### same as hinfo and txt +(define-record rr-data-wks + data) + +;; + +(define (parse-rr-data type class data message) + (if *debug* (display "parse-rr-data\n")) + (cond + ((eq? type 'a) + (make-rr-data-a (ip->string data))) + + ((eq? type 'ns) + (make-rr-data-ns (call-with-values + (lambda () (parse-name data message)) + (lambda (name rest) name)))) + + ((eq? type 'cname) + (make-rr-data-cname (call-with-values + (lambda () (parse-name data message)) + (lambda (name rest) name)))) + + ((eq? type 'mx) + (make-rr-data-mx (octet-pair->number (car data) (cadr data)) + (call-with-values + (lambda ()(parse-name (cddr data) message)) + (lambda (name rest) name)))) + + ((eq? type 'ptr) + (make-rr-data-ptr (call-with-values + (lambda () (parse-name data message)) + (lambda (name rest) name)))) + + ((eq? type 'soa) + (call-with-values + (lambda () (parse-name data message)) + (lambda (mname rest) + (call-with-values + (lambda () (parse-name rest message)) + (lambda (rname rest) + (let ((serial (octet-quad->number (car rest) (cadr rest) (caddr rest) (cadddr rest))) + (rest (cddddr rest))) + (let ((refresh (octet-quad->number (car rest) (cadr rest) (caddr rest) (cadddr rest))) + (rest (cddddr rest))) + (let ((retry (octet-quad->number (car rest) (cadr rest) (caddr rest) (cadddr rest))) + (rest (cddddr rest))) + (let ((expire (octet-quad->number (car rest) (cadr rest) (caddr rest) (cadddr rest))) + (rest (cddddr rest))) + (let ((minimum (octet-quad->number (car rest) (cadr rest) (caddr rest) (cadddr rest))) + (rest (cddddr rest))) + (make-rr-data-soa mname rname serial refresh retry expire minimum))))))))))) + + ((eq? type 'hinfo) + (make-rr-data-hinfo (list->string data))) + + ((eq? type 'txt) + (make-rr-data-txt (list->string data))) + + ((eq? type 'wks) + (make-rr-data-wks data)) + + (else (list data)))) + +;; parses n-times a message with parse. returns a list of parse-returns. +(define (parse-n parse start message n) + (if *debug* (display "parse-n\n")) + (let loop ((n n) (start start) (accum '())) + (if (zero? n) + (values (reverse! accum) start) + (call-with-values + (lambda () (parse start message)) + (lambda (rr start) + (loop (- n 1) start (cons rr accum))))))) + +;; parses a message-headers flags. returns the flags. +(define (parse-flags message) + (if *debug* (display "parse-flags\n")) + (let ((v0 (list-ref message 2)) + (v1 (list-ref message 3))) + ;; Check for error code: + (let ((rcode (bitwise-and #xf (char->ascii v1))) + (z (arithmetic-shift (bitwise-and 112 (char->ascii v1)) -4)) + (ra (arithmetic-shift (bitwise-and 64 (char->ascii v1)) -7)) + (rd (bitwise-and 1 (char->ascii v0))) + (tc (arithmetic-shift (bitwise-and 2 (char->ascii v0)) -1)) + (aa (arithmetic-shift (bitwise-and 4 (char->ascii v0)) -2)) + (opcode (arithmetic-shift (bitwise-and 120 (char->ascii v0)) -3)) + (qr (arithmetic-shift (bitwise-and 128 (char->ascii v0)) -7))) + (make-flags qr opcode aa tc rd ra z rcode)))) + + +;; parses a message-header. returns the header. +(define (parse-header message) + (if *debug* (display "parse-header\n")) + (let ((id (octet-pair->number (list-ref message 0) (list-ref message 1))) + (flags (parse-flags message)) + (qd-count (octet-pair->number (list-ref message 4) (list-ref message 5))) + (an-count (octet-pair->number (list-ref message 6) (list-ref message 7))) + (ns-count (octet-pair->number (list-ref message 8) (list-ref message 9))) + (ar-count (octet-pair->number (list-ref message 10) (list-ref message 11)))) + (make-header id flags qd-count an-count ns-count ar-count))) + + +;; parses a message. returns the parsed message. +(define (parse message) + (if *debug* (display "parse\n")) + (let* ((header (parse-header message)) + (start (list-tail message 12))) + (call-with-values + (lambda () (parse-n parse-question start message (header:qdc header))) + (lambda (qds start) + (call-with-values + (lambda () (parse-n parse-rr start message (header:anc header))) + (lambda (ans start) + (call-with-values + (lambda () (parse-n parse-rr start message (header:nsc header))) + (lambda (nss start) + (call-with-values + (lambda () (parse-n parse-rr start message (header:arc header))) + (lambda (ars start) + (if (not (null? start)) + (signal 'parse-error)) + (make-message header qds ans nss ars message))))))))))) + + + +;;; -- send, receive and validate message + +;; checks if the received reply is valid. returns #t or error-msg. +(define (reply-acceptable? reply query) + (if *debug* (display "reply-acceptable?\n")) + ;; Check correct id + (if (not (and (char=? (car reply) (car query)) + (char=? (cadr reply) (cadr query)))) + (display "send-receive-message: bad reply id from server")) + ;; Check for error code: + (let ((rcode (flags:rcode (parse-flags reply)))) + (if (not (zero? rcode)) + (case rcode + ((1) (signal 'dns-format-error)) + ((2) (signal 'dns-server-failure)) + ((3) (signal 'dns-name-error)) + ((4) (signal 'dns-not-implemented)) + ((5) (signal 'dns-refused)))))) + +;; #t if message is truncated (could happen via UDP) +(define (truncated? reply) + (let ((trunc (flags:trunc (parse-flags reply)))) + trunc)) + + +;; connects to nameserver and sends and receives messages. returns the reply. +;; here: via TCP +(define (send-receive-message-tcp nameserver question) + (if *debug* (display "send-receive-message\n")) + (let* ((query question) + (reply + (let ((socket (socket-connect protocol-family/internet + socket-type/stream + nameserver 53))) + (let ((r (socket:inport socket)) + (w (socket:outport socket))) + (dynamic-wind + (lambda () + 'nothing-to-be-done-before) + (lambda () + (display (list->string (add-size-tag query)) w) + (force-output w) + + (let ((a (read-char r)) + (b (read-char r))) + (let ((len (octet-pair->number a b))) + (let ((s (read-string len r))) + (if (not (= len (string-length s))) + (signal 'unexpected-eof-from-server)) + (string->list s))))) + (lambda () + (close-socket socket))))))) + (reply-acceptable? reply query) + (parse reply))) + +;; here: via UDP +(define (send-receive-message-udp nameserver question) + (if *debug* (display "send-receive-message\n")) + (let* ((query question) + (reply + (let ((socket (socket-connect protocol-family/internet + socket-type/datagram + nameserver 53))) + (let ((r (socket:inport socket)) + (w (socket:outport socket))) + (dynamic-wind + (lambda () + 'nothing-to-be-done-before) + (lambda () + (display (list->string query) w) + (force-output w) + (let ((s (read-string/partial 512 r))) ; 512 is the maximum udp-message size + (string->list s))) + (lambda () + (close-socket socket))))))) + (reply-acceptable? reply query) + (if (truncated? reply) + (send-receive-message-tcp nameserver question) + (parse reply)))) + + +;;; -- cache + +;; creates the cache, an emoty string-table +(define cache (make-string-table)) + +;; resets the cache +(define (dns-clear-cache) + (set! cache (make-string-table))) + +;; searches in a dns-msg for the shortest ttl. this is needed for cache-management. +(define (find-shortest-ttl dns-msg) + (if *debug* (display "find-shortest-ttl\n")) + (letrec ((minimum #f) + (find-shortest-ttl-1 + (lambda (dns-msg) + (cond + ((dns-message? dns-msg) + (find-shortest-ttl-1 (dns-message:reply dns-msg))) + ((message? dns-msg) + (for-each (lambda (x) (find-shortest-ttl-1 x)) (message:answers dns-msg)) + (for-each (lambda (x) (find-shortest-ttl-1 x)) (message:nameservers dns-msg)) + (for-each (lambda (x) (find-shortest-ttl-1 x)) (message:additionals dns-msg)) + minimum) + ((rr? dns-msg) + (cond + ((not minimum) (set! minimum (rr:ttl dns-msg))) + (else + (if (and (not minimum) (> minimum (rr:ttl dns-msg))) + (set! minimum (rr:ttl dns-msg)))))))))) + (find-shortest-ttl-1 dns-msg))) + +;; makes a dns-query. optional cache-check. +;; returns a dns-message with cache-flag and either cache-data or new received data. +(define (dns-query/cache question use-cache? protocol nameserver tried) + (if *debug* (display "dns-query/cache\n")) + (let ((send-receive-message + (cond + ((eq? protocol 'tcp) send-receive-message-tcp) + ((eq? protocol 'udp) send-receive-message-udp)))) + (let ((dns-query + (lambda () + (if *debug* (display "dns-query/cache:dns-query\n")) + ;; returns new retrieved data + (make-dns-message (parse question) (send-receive-message nameserver question) #f protocol (reverse tried)))) + (dns-query-with-cache + (lambda () + (if *debug* (display "dns-query/cache:dns-query-with-cache\n")) + (let* ((qds (message:questions (parse question))) + ;; cache-key relevant data + (name (question:name (car qds))) + (type (question:type (car qds))) + (class (question:class (car qds))) + (key (format #f "~a;~a;~a;~a" nameserver name type class)) + (found-data (table-ref cache key))) + (cond + ((and found-data + ;; checks if cached-data is still valid + (< (time) (+ (cache:time found-data) (cache:ttl found-data)))) + ;; returns cached data + (make-dns-message (parse question) (cache:answer found-data) #t protocol (reverse tried))) + (else + (let ((reply-msg (send-receive-message nameserver question))) + (if *debug* (display "write to cache\n")) + (table-set! cache key (make-cache reply-msg (find-shortest-ttl reply-msg) (time))) + ;; returns new retrieved data and updates cache + (make-dns-message (parse question) reply-msg #f protocol (reverse tried))))))))) + (if use-cache? + (dns-query-with-cache) + (dns-query))))) + +;; dns and recursion +;; recursion means, if the demanded information is not available from the +;; nameserver, another nameserver (usualy an authority) has to be contacted. +;; normally the recursion is done for us by the nameserver istself, but +;; this feature is technically optional (RFC 1035). +;; dns-get-information implements the resovler-side recursion. +;; it returns a dns-message +(define (dns-get-information question use-cache? protocol nameserver check-answer) + (if *debug* (display "dns-get-information\n")) + (letrec ((tried (list nameserver)) + ;; with every (even unanswerd) requests authoritative nameservers are sent back + ;; try-recursive tries to get information from these nameservers + (try-recursive + (lambda (auth? nss) + (if (or auth? (null? nss)) + (signal 'bad-address) + (let* ((ns (and (eq? (rr:type (car nss)) 'a) (rr-data-a:ip (rr:data (car nss))))) + (dns-msg (if (and ns + (not (member ns tried)) + (set! tried (cons ns tried))) + (dns-query/cache question use-cache? protocol ns tried) + (try-recursive auth? (cdr nss))))) + (check-success dns-msg))))) + ;; checks if the answer is useful. returns a dns-message. + (check-success + (lambda (dns-msg) + (if *debug* (display "dns-get-information:check-success\n")) + (let ((useful-answer? (check-answer dns-msg))) + (if useful-answer? + dns-msg + (let ((auth? (not (zero? (flags:auth (header:flags (message:header (dns-message:reply dns-msg))))))) + ;; other nameservers names are found in the nameserver-part, + ;; but their ip-adresses are found in the additonal-rrs + (other-nameservers (filter (lambda (elem) (eq? (rr:type elem) 'a)) + (message:additionals (dns-message:reply dns-msg))))) + (try-recursive auth? other-nameservers))))))) + (check-success (dns-query/cache question use-cache? protocol nameserver tried)))) + + + +;; parses the resolv.conf file and returns a list of found nameserver +(define (dns-find-nameserver-list) + (with-input-from-file "/etc/resolv.conf" + (lambda () + (let loop ((ns '())) + (let ((l (read-line))) + (cond + ((eof-object? l) + (if (null? ns) + (signal 'no-nameservers) + ns)) + ((regexp-search (posix-string->regexp "nameserver[ ]+([0-9]+\\.[0-9]+\\.[0-9]+\\.[0-9]+)") l) + => (lambda (match) + (loop (append ns (list (match:substring match 1)))))) + (else + (loop ns)))))))) + + +;; returns the first found nameserver +(define (dns-find-nameserver) + (let ((ns (dns-find-nameserver-list))) + (if (null? ns) + (signal 'no-nameservers) + (car ns)))) + + + +;; concurrent-lookup +;; starts a -lookup to all nameservers in (dns-find-nameserver-list) +(define (concurrent-lookup lookup name) + (let* ((return 'no-value) + (lock (make-lock)) + (queue (make-queue)) + (nameserver-list (dns-find-nameserver-list))) + + (obtain-lock lock) + + (spawn (lambda () + (for-each (lambda (nameserver) + (spawn + (lambda () + (display "query sent to ")(display nameserver)(display " \n") + (let* ((result (apply lookup (list name nameserver)))) + (enqueue! queue result) + (display "received reply from ")(display nameserver)(display ": ")(display result)(newline) + (release-lock lock))))) + (dns-find-nameserver-list)))) + + (let loop ((count (length nameserver-list))) + (obtain-lock lock) + (let ((result (dequeue! queue))) + (if (or result (= 1 (length nameserver-list))) + result + (loop (- count 1))))))) + +;; checks the arguments of the dns-lookup-* functions. +;; if a nameserver-name is given and not a nameserver-ip +;; (dns-lookup-name nameserver) is called. +(define (check-args args) + (if (null? args) + (dns-find-nameserver) + (let ((nameserver (car args))) + (if (ip? nameserver) + nameserver + (dns-lookup-name nameserver))))) + + +;; dns-lookup with more options than dns-lookup-* +;; optional: nameserver could be passed to the function. +(define (dns-lookup name type . args) + (call-with-current-continuation + (lambda (exit) + (with-handler + (lambda (condition more) + (dns-error-messages condition more) + (exit #f)) + (lambda () + (let* ((ip-string (ip-string->in-addr name)) + (question (if ip-string ; if name is a ip-addr, the query is a in-addr.arpa address + (make-octet-query-message (random 256) ip-string type 'in) + (make-octet-query-message (random 256) name type 'in))) + (use-cache? #t) + (protocol 'udp) + (nameserver (check-args args)) + (check-answer (lambda (dns-msg) #t)) + (dns-msg (dns-get-information question use-cache? protocol nameserver check-answer)) + (answers (message:answers (dns-message:reply dns-msg)))) + (if (not (null? answers)) + (for-each (lambda (x) (show-dns-message x)(newline)) answers) + (display "no answers received - but resolved information in other sections.\n")) + dns-msg)))))) + + + +;; looks up a hostname, returns an ip. +;; (dns-lookup-name [nameserver]) +(define (dns-lookup-name name . args) + (call-with-current-continuation + (lambda (exit) + (with-handler + (lambda (condition more) + (dns-error-messages condition more) + (exit #f)) + (lambda () + (let* ((ip-string (ip-string->in-addr name)) + (question (if ip-string ; if name is a ip-addr, the query is a in-addr.arpa address + (signal 'not-a-hostname) + (make-octet-query-message (random 256) name 'a 'in))) + (use-cache? #t) + (protocol 'udp) + (nameserver (check-args args)) + (check-answer (lambda (dns-msg) + (let* ((reply (dns-message:reply dns-msg)) + (answers (message:answers reply))) + (not (null? (filter-type answers 'a)))))) + (dns-msg (dns-get-information question use-cache? protocol nameserver check-answer)) + (answers (filter-type (message:answers (dns-message:reply dns-msg)) 'a))) + (rr-data-a:ip (rr:data (car answers))))))))) + + +;; looks up an ip, returns a hostname +;; (dns-inverse-lookup [nameserver]) +(define (dns-inverse-lookup ip . args) + (call-with-current-continuation + (lambda (exit) + (with-handler + (lambda (condition more) + (dns-error-messages condition more) + (exit #f)) + (lambda () + (let* ((ip-string (ip-string->in-addr ip)) + (question (if ip-string ; if name is a ip-addr, the query is a in-addr.arpa address + (make-octet-query-message (random 256) ip-string 'ptr 'in) + (signal 'not-a-ip))) + (use-cache? #t) + (protocol 'udp) + (nameserver (check-args args)) + (check-answer (lambda (dns-msg) + (let* ((reply (dns-message:reply dns-msg)) + (answers (message:answers reply))) + (not (null? (filter-type answers 'ptr)))))) + (dns-msg (dns-get-information question use-cache? protocol nameserver check-answer)) + (answers (filter-type (message:answers (dns-message:reply dns-msg)) 'ptr))) + (rr-data-ptr:name (rr:data (car answers))))))))) + +(define dns-lookup-ip dns-inverse-lookup) + + +;; looks up an authoritative nameserver for a hostname +;; returns a list of nameservers +;; (dns-lookup-nameserver [nameserver]) +(define (dns-lookup-nameserver name . args) + (call-with-current-continuation + (lambda (exit) + (with-handler + (lambda (condition more) + (dns-error-messages condition more) + (exit #f)) + (lambda () + (let* ((ip-string (ip-string->in-addr name)) + (question (if ip-string ; if name is a ip-addr, the query is a in-addr.arpa address + (signal 'not-a-hostname) + (make-octet-query-message (random 256) name 'ns 'in))) + (use-cache? #t) + (protocol 'udp) + (nameserver (check-args args)) + (check-answer (lambda (dns-msg) + (let* ((reply (dns-message:reply dns-msg)) + (answers (message:answers reply)) + (nameservers (message:nameservers reply))) + (or (not (null? (filter-type nameservers 'soa))) + (not (null? (filter-type answers 'ns))))))) + (dns-msg (dns-get-information question use-cache? protocol nameserver check-answer)) + (reply (dns-message:reply dns-msg)) + (soa (filter-type (message:nameservers reply) 'soa)) + (nss (filter-type (message:answers reply) 'ns)) + (add (filter-type (message:additionals reply) 'a))) + (if (null? nss) + (list (dns-lookup-name (rr-data-soa:mname (rr:data (car soa))))) + (map (lambda (elem) (rr-data-a:ip (rr:data elem))) add)))))))) + + +;; looks up a mail-exchanger for a hostname. +;; returns a list of mail-exchanger, sorted by their preference +;; if there are no mx-records in the answer-section, +;; implementation based on RFC2821 +;; (dns-lookup-mail-exchanger [nameserver]) +(define (dns-lookup-mail-exchanger name . args) + (call-with-current-continuation + (lambda (exit) + (with-handler + (lambda (condition more) + (dns-error-messages condition more) + (exit #f)) + (lambda () + (let* ((ip-string (ip-string->in-addr name)) + (question (if ip-string ; if name is a ip-addr, the query is a in-addr.arpa address + (signal 'not-a-hostname) + (make-octet-query-message (random 256) name 'mx 'in))) + (use-cache? #t) + (protocol 'tcp) + (nameserver (check-args args)) + (check-answer (lambda (dns-msg) + (let* ((reply (dns-message:reply dns-msg)) + (answers (message:answers reply)) + (nameservers (message:nameservers reply))) + (or (not (null? (filter-type answers 'mx))) + (not (null? (filter-type answers 'cname))) + (not (null? (filter-type answers 'a))))))) + (dns-msg (dns-get-information question use-cache? protocol nameserver check-answer)) + (reply (dns-message:reply dns-msg)) + (mx (filter-type (message:answers reply) 'mx)) + (soa (filter-type (message:nameservers reply) 'soa)) + (cname (filter-type (message:answers reply) 'cname)) + (a (filter-type (message:answers reply) 'a))) + + (cond + ((not (null? a)) + (list (rr-data-a:ip (rr:data (car a))))) + ((not (null? cname)) + (dns-lookup-mail-exchanger (rr-data-cname:name (rr:data (car cname))))) + ((null? mx) + (list (rr-data-soa:rname (rr:data (car soa))))) + (else + (map (lambda (elem) (rr-data-mx:exchanger (rr:data elem))) (sort-by-preference mx)))))))))) + + + + +;;; pretty-prints a dns-msg +(define (show-dns-message dns-msg) + (let* ((d + (lambda (n s1 s2) + (letrec ((loop (lambda (n) + (if (zero? n) + "" + (string-append " " (loop (- n 1))))))) + (display (loop n)) + (display s1) + (display ": ") + (display s2) + (newline))))) + + (cond + ((dns-message? dns-msg) + (begin + (d 0 "DNS-MESSAGE" "") + (d 1 "QUERY" "")(show-dns-message (dns-message:query dns-msg))(newline) + (d 1 "REPLY" "")(show-dns-message (dns-message:reply dns-msg))(newline) + (d 1 "CACHE?" (if (dns-message:cache? dns-msg) + "found in cache" + "not found in cache")) + (d 1 "PROTOCOL" (let ((protocol (dns-message:protocol dns-msg))) + (cond + ((eq? protocol 'tcp) "TCP") + ((eq? protocol 'udp) "UDP")))) + (d 1 "TRIED-NAMESERVERS" (if (> (length (dns-message:tried-nameservers dns-msg)) 1) + (begin + (display " had perform recursion: ") + (dns-message:tried-nameservers dns-msg)) + (begin + (display " without recursion: ") + (dns-message:tried-nameservers dns-msg)))))) + ((message? dns-msg) + (begin + (d 2 "MESSAGE" "") + (d 3 "Header " "")(show-dns-message (message:header dns-msg)) + (d 3 "Questions " "")(for-each (lambda (x) (show-dns-message x)(newline)) (message:questions dns-msg)) + (d 3 "Answers " "")(for-each (lambda (x) (show-dns-message x)(newline)) (message:answers dns-msg)) + (d 3 "Nameservers" "")(for-each (lambda (x) (show-dns-message x)(newline)) (message:nameservers dns-msg)) + (d 3 "Additionals" "")(for-each (lambda (x) (show-dns-message x)(newline)) (message:additionals dns-msg)))) + ((header? dns-msg) + (begin + (d 4 "id" (header:id dns-msg)) + (d 4 "Flags" "")(show-dns-message (header:flags dns-msg)) + (d 4 "question-count " (header:qdc dns-msg)) + (d 4 "answer-count " (header:anc dns-msg)) + (d 4 "nameserver-count " (header:nsc dns-msg)) + (d 4 "additional-count " (header:arc dns-msg)))) + ((flags? dns-msg) + (begin + (d 5 "querytype" (flags:querytype dns-msg)) + (d 5 "opcode" (flags:opcode dns-msg)) + (d 5 "auth" (flags:auth dns-msg)) + (d 5 "trunc" (flags:trunc dns-msg)) + (d 5 "recursiondesired" (flags:recursiondesired dns-msg)) + (d 5 "recursionavailable" (flags:recursionavailable dns-msg)) + (d 5 "z" (flags:z dns-msg)) + (d 5 "rcode" (flags:rcode dns-msg)))) + ((question? dns-msg) + (begin + (d 4 "name " (question:name dns-msg)) + (d 4 "type " (question:type dns-msg)) + (d 4 "class" (question:class dns-msg)))) + ((rr? dns-msg) + (begin + (d 4 "name " (rr:name dns-msg)) + (d 4 "type " (rr:type dns-msg)) + (d 4 "class" (rr:class dns-msg)) + (d 4 "ttl " (rr:ttl dns-msg)) + (d 4 "data " "") (show-dns-message (rr:data dns-msg)))) + ((rr-data-a? dns-msg) + (d 5 "ip " (rr-data-a:ip dns-msg))) + ((rr-data-ns? dns-msg) + (d 5 "name " (rr-data-ns:name dns-msg))) + ((rr-data-cname? dns-msg) + (d 5 "name " (rr-data-cname:name dns-msg))) + ((rr-data-mx? dns-msg) + (begin + (d 5 "preference " (rr-data-mx:preference dns-msg)) + (d 5 "exchanger " (rr-data-mx:exchanger dns-msg)))) + ((rr-data-ptr? dns-msg) + (d 5 "name " (rr-data-ptr:name dns-msg))) + ((rr-data-soa? dns-msg) + (begin + (d 5 "mname " (rr-data-soa:mname dns-msg)) + (d 5 "rname " (rr-data-soa:rname dns-msg)) + (d 5 "serial " (rr-data-soa:serial dns-msg)) + (d 5 "refresh " (rr-data-soa:refresh dns-msg)) + (d 5 "expire " (rr-data-soa:expire dns-msg)) + (d 5 "minimum " (rr-data-soa:expire dns-msg)))) + ;; ### + ((rr-data-hinfo? dns-msg) + (d 5 "data " (rr-data-hinfo:data dns-msg))) + ((rr-data-txt? dns-msg) + (d 5 "text " (rr-data-txt:text dns-msg))) + ((rr-data-wks? dns-msg) + (d 5 "data " (rr-data-wks:data dns-msg))) + + ))) diff --git a/scheme/lib/ecm-utilities.scm b/scheme/lib/ecm-utilities.scm new file mode 100644 index 0000000..aeea61f --- /dev/null +++ b/scheme/lib/ecm-utilities.scm @@ -0,0 +1,57 @@ +;; 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/format-net.scm b/scheme/lib/format-net.scm new file mode 100644 index 0000000..30f419e --- /dev/null +++ b/scheme/lib/format-net.scm @@ -0,0 +1,32 @@ +;; Does pretty-print of internet-addresses (IPv4) +;; ADDRESS address to pretty-print +;; SEPERATOR optional, defaults to ".", seperator between address-parts +;; Example: +;; (format-internet-host-address #x0a00ffff) +;; ==> "10.0.255.255" +;; (format-internet-host-address #x0a00ffff ":") +;; ==> "10:0:255:255" + +(define (format-internet-host-address address . maybe-separator) + + (let ((extract (lambda (shift) + (number->string + (bitwise-and (arithmetic-shift address (- shift)) + 255))))) + + (let-optionals maybe-separator ((separator ".")) + (string-append + (extract 24) separator (extract 16) separator + (extract 8) separator (extract 0))))) + +;; does pretty-print of ports +;; Example: +;; (format-port #x0aff) +;; => "10,255" + +(define (format-port port) + (string-append + (number->string (bitwise-and (arithmetic-shift port -8) 255)) + "," + (number->string (bitwise-and port 255)))) + diff --git a/scheme/lib/ftp-obsolete.scm b/scheme/lib/ftp-obsolete.scm new file mode 100644 index 0000000..1ec728c --- /dev/null +++ b/scheme/lib/ftp-obsolete.scm @@ -0,0 +1,24 @@ +; maps obsolete ftp-procedure names to new ftp procedure names +; by Andreas Bernauer (2002) + +(define ftp:connect ftp-connect) +(define ftp:login ftp-login) +(define ftp:type ftp-type) +(define ftp:rename ftp-rename) +(define ftp:delete ftp-delete) +(define ftp:cd ftp-cd) +(define ftp:cdup ftp-cdup) +(define ftp:pwd ftp-pwd) +(define ftp:rmdir ftp-rmdir) +(define ftp:mkdir ftp-mkdir) +(define ftp:modification-time ftp-modification-time) +(define ftp:size ftp-size) +(define ftp:abort ftp-abort) +(define ftp:quit ftp-quit) +(define ftp:ls ftp-ls) +(define ftp:dir ftp-dir) +(define ftp:get ftp-get) +(define ftp:put ftp-put) +(define ftp:append ftp-append) +(define ftp:quot ftp-quot) + diff --git a/scheme/lib/ftp.scm b/scheme/lib/ftp.scm new file mode 100644 index 0000000..8e1c637 --- /dev/null +++ b/scheme/lib/ftp.scm @@ -0,0 +1,575 @@ +;;; ftp.scm -- an FTP client library for the Scheme Shell +;; +;; $Id: ftp.scm,v 1.1 2002/06/08 15:05:24 sperber Exp $ +;; +;; Please send suggestions and bug reports to + + + +;;; Overview ========================================================= +;; +;; This module lets you transfer files between networked machines from +;; the Scheme Shell, using the File Transfer Protocol as described +;; in rfc959. The protocol specifies the behaviour of a server +;; machine, which runs an ftp daemon (not implemented by this module), +;; and of clients (that's us) which request services from the server. + + +;;; Entry points ======================================================= +;; +;; (ftp-connect host [logfile]) -> connection +;; Open a command connection with the remote machine HOST. +;; Optionally start logging the conversation with the server to +;; LOGFILE, which will be appended to if it already exists, and +;; created otherwise. Beware, the LOGFILE contains passwords in +;; clear text (it is created with permissions og-rxw) ! +;; +;; (ftp-login connection [login passwd]) -> status +;; Log in to the remote host. If a login and password are not +;; provided, they are first searched for in the user's ~/.netrc +;; file, or default to user "anonymous" and password "user@host" +;; +;; (ftp-type connection type) -> status +;; Change the transfer mode for future data connections. This may +;; be either 'ascii or 'text, respectively, for transfering text files, +;; or 'binary for transfering binary files. If type is a string it +;; is sent verbatim to the server. +;; +;; (ftp-rename connection oldname newname) -> status +;; Change the name of oldname on the remote host to newname +;; (assuming sufficient permissions). oldname and newname are +;; strings; if prefixed with "/" they are taken relative to the +;; server's root, and otherwise they are relative to the current +;; directory. Note that in the case of anonymous ftp (user +;; "anonymous" or "ftp"), the server root is different from the +;; root of the servers's filesystem. +;; +;; (ftp-delete connection file) -> status +;; Delete file from the remote host (assuming the user has +;; appropriate permissions). +;; +;; (ftp-cd connection dir) -> status +;; Change the current directory on the server. +;; +;; (ftp-cdup connection) -> status +;; Move to the parent directory on the server. +;; +;; (ftp-pwd connection) -> string +;; Return the current directory on the remote host, as a string. +;; +;; (ftp-ls connection) -> status +;; Provide a listing of the current directory's contents, in short +;; format, ie as a list of filenames. +;; +;; (ftp-dir connection) -> status +;; Provide a listing of the current directory's contents, in long +;; format. Most servers (Unix, MS Windows, MacOS) use a standard +;; format with one file per line, with the file size and other +;; information, but other servers (VMS, ...) use their own format. +;; +;; (ftp-get connection remote-file [local-file]) -> status | string +;; Download remote-file from the FTP server. If local-file is a +;; string, save the data to local-file on the local host; +;; otherwise save to a local file named remote-file. remote-file +;; and local-file may be absolute file names (with a leading `/'), +;; or relative to the current directory. It local-file is #t, +;; output data to (current-output-file), and if it is #f return +;; the data as a string. +;; +;; (ftp-put connection local-file [remote-file]) -> status +;; Upload local-file to the FTP server. If remote-file is +;; specified, the save the data to remote-file on the remote host; +;; otherwise save to a remote file named local-file. local-file +;; and remote-file may be absolute file names (with a leading +;; `/'), or relative to the current directory. +;; +;; (ftp-rmdir connection dir) -> status +;; Remove the directory DIR from the remote host (assuming +;; sufficient permissions). +;; +;; (ftp-mkdir connection dir) -> status +;; Create a new directory named DIR on the remote host (assuming +;; sufficient permissions). +;; +;; (ftp-modification-time connection file) -> date +;; Request the time of the last modification of FILE on the remote +;; host, and on success return a Scsh date record. This command is +;; not part of RFC959 and is not implemented by all servers, but +;; is useful for mirroring. +;; +;; (ftp-size connection file) -> integer +;; Return the size of FILE in bytes. +;; +;; (ftp-abort connection) -> status +;; Abort the current data transfer. Not particularly useful with +;; this implementation since the data transfer commands only +;; return once the transfer is complete. +;; +;; (ftp-quit connection) -> status +;; Close the connection to the remote host. The connection object +;; is useless after a quit command. + + +;;; Unimplemented ===================================================== +;; +;; This module has no support for sites behind a firewall (because I +;; am unable to test it). It shouldn't be very tricky; it only +;; requires using passive mode. Might want to add something like the +;; /usr/bin/ftp command `restrict', which implements data port range +;; restrictions. +;; +;; The following rfc959 commands are not implemented: +;; +;; * ACCT (account; this is ignored by most servers) +;; * SMNT (structure mount, for mounting another filesystem) +;; * REIN (reinitialize connection) +;; * LOGOUT (quit without interrupting ongoing transfers) +;; * STRU (file structure) +;; * ALLO (allocate space on server) + + +;;; Portablitity ===================================================== +;; +;; * the netrc.scm module for parsing ~/.netrc files +;; * scsh socket code +;; * scsh records +;; * receive for multiple values +;; * Scheme48 signals/handlers + + +;;; Related work ====================================================== +;; +;; * rfc959 describes the FTP protocol; see +;; http://www.cis.ohio-state.edu/htbin/rfc/rfc959.html +;; +;; * /anonymous@sunsite.unc.edu:/pub/Linux/libs/ftplib.tar.gz is a +;; library similar to this one, written in C, by Thomas Pfau +;; +;; * FTP.pm is a Perl module with similar functionality (available +;; from http://www.perl.com/CPAN) +;; +;; * Emacs gets transparent remote file access from ange-ftp.el by +;; Ange Norman. However, it cheats by using /usr/bin/ftp +;; +;; * Siod (a small-footprint Scheme implementation by George Carette) +;; comes with a file ftp.scm with a small subset of these functions +;; defined + + +;;; TODO ============================================================ +;; +;; * handle passive mode and firewalls +;; * Unix-specific commands such as SITE UMASK, SITE CHMOD +;; * object-based interface? (like SICP message passing) +;; * improved error handling +;; * a lot of the calls to format could be replaced by calls to +;; string-join. Maybe format is easier to read? + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Communication is initiated by the client. The server responds to +;; each request with a three digit status code and an explanatory +;; message, and occasionally with data (which is sent via a separate, +;; one-off channel). The client starts by opening a command connection +;; to a well known port on the server machine. Messages send to the +;; server are of the form +;; +;; CMD [ arg ] +;; +;; Replies from the server are of the form +;; +;; xyz Informative message +;; +;; where xyz is a three digit code which indicates whether the +;; operation succeeded or not, whether the server is waiting for more +;; data, etc. The server may also send multiline messages of the form +;; +;; xyz- Start of multiline message +;; [ + More information ]* +;; xyz End of multiline message +;; +;; Some of the procedures in this module extract useful information +;; from the server's reply, such as the size of a file, or the name of +;; the directory we have moved to. These procedures return either the +;; extracted information, or #f to indicate failure. Other procedures +;; return a "status", which is either the server's reply as a string, +;; or #f to signify failure. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; beware, the log file contains password information! +;;: string [ x string x port] -> connection +(define (ftp-connect host . args) + (let-optionals* args ((logfile #f)) + (let* ((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 "ftp" "tcp")) + (sock (socket-connect protocol-family/internet + socket-type/stream + hostname + (service-info:port srvc-info))) + (connection (make-ftp-connection hostname + sock + LOG "" ""))) + (ftp-log connection + (format #f "~%-- ~a: opened ftp connection to ~a" + (date->string (date)) ; doesn't seem to be buggy in v0.6 + ;"Dummy date" ; (format-time-zone) is buggy in v0.5.1 + hostname)) + (ftp-read-response connection "220") ; the initial welcome banner + connection))) + +;; Send user information to the remote host. Args are optional login +;; and password. If they are not provided, the Netrc module is used to +;; try to determine a login and password for the server. If not found we +;; default to login "anonymous" with password user@host. +;;: connection [ x string x password ] -> status +(define (ftp-login connection . args) + (let ((netrc-record (netrc:parse))) + (let-optionals* args + ((login + (netrc:lookup-login netrc-record + (ftp-connection:host-name connection))) + (password + (netrc:lookup-password netrc-record + (ftp-connection:host-name connection)))) + (set-ftp-connection:login connection login) + (set-ftp-connection:password connection password) + (ftp-send-command connection (format #f "USER ~a" login) "...") ; "331" + (ftp-send-command connection (format #f "PASS ~a" password) "2..")))) ; "230" + +;; Type must be one of 'binary or 'text or 'ascii, or a string which will be +;; sent verbatim +;;: connection x symbol|string -> status +(define (ftp-type connection type) + (let ((ttype (cond + ((string? type) type) + ((eq? type 'binary) "I") + ((or (eq? type 'ascii) + (eq? type 'text)) "A") + (else + (call-error "type must be one of 'binary or 'text or 'ascii" ftp-type type))))) + (ftp-send-command connection (format #f "TYPE ~a" ttype)))) + +;;: connection x string x string -> status +(define (ftp-rename connection oldname newname) + (ftp-send-command connection (format #f "RNFR ~a" oldname) "35.") + (ftp-send-command connection (format #f "RNTO ~a" newname) "25.")) + +;;: connection x string -> status +(define (ftp-delete connection file) + (ftp-send-command connection (format #f "DELE ~a" file) "25.")) + +;;: connection x string -> status +(define (ftp-cd connection dir) + (ftp-send-command connection (format #f "CWD ~a" dir))) + +;;: connection -> status +(define (ftp-cdup connection) + (ftp-send-command connection "CDUP" "250")) + + +;;: on success return the new directory as a string +(define (ftp-pwd connection) + (let* ((response (ftp-send-command connection "PWD" "2..")) ;; 257 + (match (string-match "[0-9][0-9][0-9] \"(.*)\" " (or response "")))) + (match:substring match 1))) + +;;: connection x string -> status +(define (ftp-rmdir connection dir) + (ftp-send-command connection (format #f "RMD ~a" dir))) + +;;: connection x string -> status +(define (ftp-mkdir connection dir) + (ftp-send-command connection (format #f "MKD ~a" dir))) + +;; On success return a Scsh date record. This message is not part of +;; rfc959 but seems to be supported by many ftp servers (it's useful +;; for mirroring) +;;: connection x string -> date +(define (ftp-modification-time connection file) + (let* ((response (ftp-send-command connection + (format #f "MDTM ~a" file))) + (match (string-match "[0-9][0-9][0-9] ([0-9]+)" (or response ""))) + (timestr (and match (match:substring match 1)))) + (and timestr + (let ((year (substring timestr 0 4)) + (month (substring timestr 4 6)) + (mday (substring timestr 6 8)) + (hour (substring timestr 8 10)) + (min (substring timestr 10 12)) + (sec (substring timestr 12 14))) + (make-date (string->number sec) + (string->number min) + (string->number hour) + (string->number mday) + (string->number month) + (- (string->number year) 1900)))))) + +;; On success return the size of the file in bytes. +;;: connection x string -> integer +(define (ftp-size connection file) + (let* ((response (ftp-send-command connection + (format #f "SIZE ~a" file) + "2.."))) + (and (string? response) + (string->number (substring response + 4 (- (string-length response) 1)))))) + +;; Abort the current data transfer. Maybe we should close the data +;; socket? +;;: connection -> status +(define (ftp-abort connection) + (ftp-send-command connection "ABOR")) + +;;: connection -> status +(define (ftp-quit connection) + (ftp-send-command connection "QUIT" "221") + (close-socket (ftp-connection:command-socket connection))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; The following commands require the use of a data connection as well +;; as the command connection. The command and the server's reply are +;; transmitted via the command connection, while the data is +;; transmitted via the data connection (you could have guessed that, +;; right?). +;; +;; The data socket is created by the client, who sends a PORT command +;; to the server to indicate on which port it is ready to accept a +;; connection. The port command specifies an IP number and a port +;; number, in the form of 4+2 comma-separated bytes. The server then +;; initiates the data transfer. A fresh data connection is created for +;; each data transfer (unlike the command connection which stays open +;; during the entire conversation with the server). +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;: connection [ x string ] -> status +(define (ftp-ls connection . maybe-dir) + (let* ((sock (ftp-open-data-connection connection))) + (ftp-send-command connection + (ftp-build-command-string "NLST" maybe-dir) + "1..") + (receive (newsock newsockaddr) + (accept-connection sock) + (dump (socket:inport newsock)) + (close-socket newsock) + (close-socket sock) + (ftp-read-response connection "2..")))) + +;;: connection [ x string ] -> status +(define (ftp-dir connection . maybe-dir) + (let* ((sock (ftp-open-data-connection connection))) + (ftp-send-command connection + (ftp-build-command-string "LIST" maybe-dir) + "1..") + (receive (newsock newsockaddr) + (accept-connection sock) + (dump (socket:inport newsock)) + (close-socket newsock) + (close-socket sock) + (ftp-read-response connection "2..")))) + + +;; maybe-local may be a filename to which the data should be written, +;; or #t to write data to stdout (to current-output-port to be more +;; precise), or #f to stuff the data in a string (which is returned), +;; or nothing to output to a local file with the same name as the +;; remote file. +;;: connection x string [x string | #t | #f] -> status | string +(define (ftp-get connection remote-file . maybe-local) + (let* ((sock (ftp-open-data-connection connection)) + (local (if (pair? maybe-local) + (car maybe-local) + 'empty)) + (OUT (cond ((string? local) (open-output-file local)) + ((eq? local #t) (current-output-port)) + ((eq? local #f) (make-string-output-port)) + (else + (open-output-file remote-file))))) + (ftp-send-command connection + (format #f "RETR ~a" remote-file) + "150") + (receive (newsock newsockaddr) + (accept-connection sock) + (with-current-output-port OUT + (dump (socket:inport newsock))) + (close-socket newsock) + (close-socket sock) + (let ((status (ftp-read-response connection "2.."))) + (if (string? local) (close OUT)) + (if (eq? local #f) + (string-output-port-output OUT) + status))))) + + +;; FIXME: should have an optional argument :rename which defaults to +;; false, which would make us upload to a temporary name and rename at +;; the end of the upload. This atomicity is important for ftp or http +;; servers which are serving a load, and to avoid problems with "no +;; space on device". + +;; optional argument maybe-remote-file is the name under which we wish +;; the file to appear on the remote machine. If omitted the file takes +;; the same name on the FTP server as on the local host. +;;: connection x string [ x string ] -> status +(define (ftp-put connection local-file . maybe-remote-file) + (let-optionals* maybe-remote-file ((remote-file #f)) + (let* ((sock (ftp-open-data-connection connection)) + (IN (open-input-file local-file)) + (cmd (format #f "STOR ~a" (or remote-file local-file)))) + (ftp-send-command connection cmd "150") + (receive (newsock newsockaddr) + (accept-connection sock) + (with-current-output-port (socket:outport newsock) (dump IN)) + (close (socket:outport newsock)) ; send the server EOF + (close-socket newsock) + (let ((status (ftp-read-response connection "2.."))) + (close IN) + (close-socket sock) + status))))) + +;;: connection x string [x string] -> status +(define (ftp-append connection local-file . maybe-remote-file) + (let-optionals* maybe-remote-file ((remote-file #f)) + (let* ((sock (ftp-open-data-connection connection)) + (IN (open-input-file local-file)) + (cmd (format #f "APPE ~a" (or remote-file local-file)))) + (ftp-send-command connection cmd "150") + (receive (newsock newsockaddr) + (accept-connection sock) + (with-current-output-port (socket:outport newsock) + (dump IN)) + (close (socket:outport newsock)) ; send the server EOF + (close-socket newsock) + (let ((status (ftp-read-response connection "2.."))) + (close IN) + (close-socket sock) + status))))) + +;; send a command verbatim to the remote server and wait for a +;; response. +;;: connection x string -> status +(define (ftp-quot connection cmd) + (ftp-send-command connection cmd)) + + +;; ------------------------------------------------------------------------ +;; no exported procedures below + +(define (ftp-open-data-connection connection) + (let* ((sock (create-socket protocol-family/internet + socket-type/stream)) + (sockaddr (internet-address->socket-address + internet-address/any + 0))) ; 0 to accept any port + (set-socket-option sock level/socket socket/reuse-address #t) + (set-socket-option sock level/socket socket/linger 120) + (bind-socket sock sockaddr) + (listen-socket sock 0) + (ftp-send-command connection ; send PORT command + (ftp-build-PORT-string (socket-local-address sock))) + sock)) + + + +;; TODO: Unix-specific commands +;; SITE UMASK 002 +;; SITE IDLE 60 +;; SITE CHMOD 755 filename +;; SITE HELP + + + +;; We cache the login and password to be able to relogin automatically +;; if we lose the connection (a la ange-ftp). Not implemented. +(define-record ftp-connection + host-name + command-socket + logfd + login + password) + +(define-condition-type 'ftp-error '(error)) +(define ftp-error? (condition-predicate 'ftp-error)) + + +(define (ftp-build-PORT-string sockaddr) + (let* ((hst-info (host-info (system-name))) + (ip-address (car (host-info:addresses hst-info)))) + (receive (hst-address srvc-port) + (socket-address->internet-address sockaddr) + (let* ((num32 ip-address) + (num24 (arithmetic-shift num32 -8)) + (num16 (arithmetic-shift num24 -8)) + (num08 (arithmetic-shift num16 -8)) + (byte0 (bitwise-and #b11111111 num08)) + (byte1 (bitwise-and #b11111111 num16)) + (byte2 (bitwise-and #b11111111 num24)) + (byte3 (bitwise-and #b11111111 num32))) + (format #f "PORT ~a,~a,~a,~a,~a,~a" + byte0 byte1 byte2 byte3 + (arithmetic-shift srvc-port -8) ; high order byte + (bitwise-and #b11111111 srvc-port) ; lower order byte + ))))) + + +(define (ftp-send-command connection command . maybe-expected) + (let-optionals* maybe-expected ((expected "2..")) + (let* ((sock (ftp-connection:command-socket connection)) + (OUT (socket:outport sock))) + (write-string command OUT) + (write-crlf OUT) + (ftp-log connection (format #f "<- ~a" command)) + (ftp-read-response connection expected)))) + + +;; This is where we check that the server's 3 digit status code +;; corresponds to what we expected. EXPECTED is a string of the form +;; "250", which indicates we are expecting a 250 code from the server, +;; or "2.." which means that we only require the first digit to be 2 +;; and don't care about the rest. If the server's response doesn't +;; match EXPECTED, we raise an ftp-error (which is catchable; look at +;; pop3.scm to see how). Since this is implemented as a regexp, you +;; can also specify more complicated acceptable responses of the form +;; "2[4-6][0-9]". The code permits you to match the server's verbose +;; message too, but beware that the messages change from server to +;; server. +(define (ftp-read-response connection . maybe-expected) + (let-optionals* maybe-expected ((expected "2..")) + (let* ((sock (ftp-connection:command-socket connection)) + (IN (socket:inport sock)) + (response (read-line IN))) + (ftp-log connection (format #f "-> ~a" response)) + (or (string-match expected response) + (signal 'ftp-error response)) + ;; handle multi-line responses + (if (equal? (string-ref response 3) #\-) + (let loop ((code (string-append (substring response 0 3) " ")) + (line (read-line IN))) + (ftp-log connection (format #f "-> ~a" line)) + (set! response (string-join (list response line "\n"))) + (or (string-match code line) + (loop code (read-line IN))))) + response))) + + +(define (ftp-build-command-string str . opt-args) + (if (string? opt-args) + (string-join (list str arg)) + str)) + +(define (ftp-log connection line) + (let ((LOG (ftp-connection:logfd connection))) + (and LOG + (write-string line LOG) + (write-string "\n" LOG) + (force-output LOG)))) + +;; EOF diff --git a/scheme/lib/htmlout.scm b/scheme/lib/htmlout.scm new file mode 100644 index 0000000..d409068 --- /dev/null +++ b/scheme/lib/htmlout.scm @@ -0,0 +1,195 @@ +;;; Simple code for doing structured html output. -*- Scheme -*- +;;; Copyright (c) 1995 by Olin Shivers. + +;;; External dependencies +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; format ; Output +;;; receive values ; Multiple-value return + +;;; - An attribute-quoter, that will map an attribute value to its +;;; HTML text representation -- surrounding it with single or double quotes, +;;; as appropriate, etc. + +;;; Printing HTML tags. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; All the emit-foo procedures have the same basic calling conventions: +;;; (emit-foo out ... [ ...]) +;;; - OUT is either a port or #t for the current input port. +;;; - Each attribute is either a (name . value) pair, which is printed as +;;; name="value" +;;; or a single symbol or string, which is simply printed as-is +;;; (this is useful for attributes that don't have values, such as the +;;; ISMAP attribute in tags). + + + +;;; + +(define (emit-tag out tag . attrs) + (let ((out (fmt->port out))) + (display "<" out) + (display tag out) + (for-each (lambda (attr) + (display #\space out) + (cond ((pair? attr) ; name="val" + (display (car attr) out) + (display "=\"" out) ; Should check for + (display (cdr attr) out) ; internal double-quote + (display #\" out)) ; etc. + (else + (display attr out)))) ; name + attrs) + (display #\> out))) + + +;;; + +(define (emit-close-tag out tag) + (format out "" tag)) + + +;;;

+ +(define (emit-p . args) ; (emit-p [out attr1 ...]) + (receive (out attrs) (if (pair? args) + (let* ((out (car args))) + (values (if (eq? out #t) (current-output-port) out) + (cdr args))) + (values (current-output-port) args)) + + (apply emit-tag out 'p attrs) + (newline out) + (newline out))) + + +;;; Make Money Fast!!! + +(define (emit-title out title) ; Takes no attributes. + (format out "~a~%~%" title)) + +(define (emit-header out level text . attribs) + (apply with-tag* out (string-append "H" (number->string level)) + (lambda () (display text (fmt->port out))) + attribs)) + +;;; ...and so forth. Could stand to define a bunch of little emitters for the +;;; various tags. (define-tag-emitter ...) + + +;;; Printing out balanced ... pairs. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; (with-tag out tag (attr-elt ...) body ...) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Execute the body forms between a ... pair. +;;; The (ATTR-ELT ...) list specifies the attributes for the . +;;; It is rather like a LET-list, having the form +;;; ((name val) ...) +;;; Each NAME must be a symbol, and each VAL must be a Scheme expression +;;; whose value is the string to use as attribute NAME's value. Attributes +;;; that have no value (e.g., ISMAP) can be specified as attr-elt NAME, +;;; instead of (NAME VALUE). +;;; +;;; For example, +;;; (let ((hp "http://clark.lcs.mit.edu/~shivers")) ; My home page. +;;; (with-tag port A ((href hp-url) (name "hp")) +;;; (display "home page" port))) +;;; outputs +;;; home page + +(define-syntax with-tag + (syntax-rules () + ((with-tag out tag (attr-elt ...) body ...) + (with-tag* out 'tag (lambda () body ...) + (%hack-attr-elt attr-elt) + ...)))) + +;;; Why does this have to be top-level? +;;; Why can't this be a LET-SYNTAX inside of WITH-TAG? + +(define-syntax %hack-attr-elt + (syntax-rules () ; Build attribute-list element: + ((%hack-attr-elt (name val)) ; (name elt) => (cons 'name elt) + (cons 'name val)) + ((%hack-attr-elt name) 'name))) ; name => 'name + + +;;; Execute THUNK between a ... pair. + +(define (with-tag* out tag thunk . attrs) + (apply emit-tag out tag attrs) + (let ((out (fmt->port out))) + (call-with-values thunk + (lambda results + (newline out) + (emit-close-tag out tag) + (apply values results))))) + + +(define (fmt->port x) + (if (eq? x #t) (current-output-port) x)) + +;;; Translate text to HTML, mapping special chars such as <, >, &, and +;;; double-quote to their HTML escape sequences. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; Note iso8859-1 above 127 is perfectly OK + +(define *html-entity-alist* + (list + (cons (ascii->char 60) "<") + (cons (ascii->char 62) ">") + (cons (ascii->char 38) "&") + (cons (ascii->char 34) """))) + +(define *html-entities* + (list->char-set (map car *html-entity-alist*))) + +(define *html-entity-table* + (let ((v (make-vector 256 #f))) + (for-each (lambda (entry) + (vector-set! v + (char->ascii (car entry)) + (cdr entry))) + *html-entity-alist*) + v)) + +(define (string-set-substring! t start s) + (let* ((l (string-length s)) + (end (+ l start))) + (do ((i start (+ 1 i))) + ((= i end) t) + (string-set! t i (string-ref s (- i start)))))) + +(define (escape-html s) + (let ((target-length + (string-fold (lambda (c i) + (+ i + (if (char-set-contains? *html-entities* c) + (string-length + (vector-ref *html-entity-table* + (char->ascii c))) + 1))) + 0 + s))) + (if (= target-length (string-length s)) + s + (let ((target (make-string target-length))) + (string-fold + (lambda (c i) + (+ i + (if (char-set-contains? *html-entities* c) + (let ((entity (vector-ref *html-entity-table* (char->ascii c)))) + (string-set-substring! target i entity) + (string-length entity)) + (begin + (string-set! target i c) + 1)))) + 0 + s) + target)))) + +(define (emit-text s . maybe-port) + (if (null? maybe-port) + (write-string (escape-html s)) + (write-string (escape-html s) (fmt->port (car maybe-port))))) diff --git a/scheme/lib/ls.scm b/scheme/lib/ls.scm new file mode 100644 index 0000000..9979bef --- /dev/null +++ b/scheme/lib/ls.scm @@ -0,0 +1,332 @@ +; ls clone in scsh + +; Mike Sperber +; Copyright (c) 1998 Michael Sperber. + +; This currently does a whole bunch of stats on every file in some +; cases. In a decent OS implementation, this stuff is cached, so +; there isn't any problem, at least not in theory :-) + +; FLAGS is a list of symbols from: +; +; all - include stuff starting with "." +; recursive - guess what +; long - output interesting information per file +; directory - display only the information for the directory named +; flag - flag files as per their types +; columns - sorts output vertically in a multicolumn format + +(define ls-crlf? (make-fluid #f)) + +(define (ls flags paths . maybe-port) + (let* ((port (optional maybe-port (current-output-port))) + (paths (if (null? paths) + (list (cwd)) + paths)) + (only-one? (null? (cdr paths)))) + (call-with-values + (lambda () (parse-flags flags)) + (lambda (all? recursive? long? directory? flag? columns?) + (real-ls paths + (if only-one? #f "") + all? recursive? long? directory? flag? columns? + port))))) + +(define (parse-flags flags) + (let ((all? (memq 'all flags)) + (recursive? (memq 'recursive flags)) + (long? (memq 'long flags)) + (directory? (memq 'directory flags)) + (flag? (memq 'flag flags)) + (columns? (memq 'columns flags))) + (values all? recursive? long? directory? flag? columns?))) + +(define (real-ls paths prefix + all? recursive? long? directory? flag? columns? + port) + (let ((first #t)) + (for-each + (lambda (path) + (if first + (set! first #f) + (ls-newline port)) + (if prefix + (format port "~A~A:~%" prefix path)) + (ls-path path all? recursive? long? directory? flag? columns? port)) + paths))) + +(define (ls-path path all? recursive? long? directory? flag? columns? port) + (cond + ((and (not directory?) ;; go into directories + (or (and (file-name-directory? path) ;; path specifies directory + (file-directory? path #t)) ;; either as a symlink (if the names end with a slash) + (file-directory? path #f))) ;; or not + (ls-directory path all? recursive? long? directory? flag? columns? port)) + (else + (if (or long? flag?) ;; see LS-DIRECTORY for details + (ls-file (cons path (file-info path #f)) long? flag? port) + (ls-file (cons path #f) long? flag? port))))) + +(define (ls-directory directory all? recursive? long? directory? flag? columns? port) +; terminology: a FILE-NAME is the name of a file +; a FILE is a pair whose car is a file-name and whose cdr is +; either its file-info-object or #f (if not needed) +; a INFO is a file-info-object + (let* ((directory (file-name-as-directory directory)) + (substantial-directory (string-append directory ".")) + (file-names (directory-files substantial-directory all?))) + (with-cwd* + substantial-directory + (lambda () + (let ((files (if (or recursive? long? flag?) ; these are the flags for which we need the file-info + (map (lambda (file-name) + (cons file-name (file-info file-name #f))) + file-names) + (map (lambda (file-name) (cons file-name #f)) + file-names)))) + + (if (and (not long?) + columns?) + (ls-files-columns files flag? port) + (ls-files-column files long? flag? port)) + + (if recursive? + (let ((directories + (map (lambda (file) (car file)) + (filter (lambda (file) + (eq? (file-info:type (cdr file)) 'directory)) + files)))) + (if (not (null? directories)) + (begin + (ls-newline port) + (real-ls directories directory + all? recursive? long? directory? flag? columns? + port)))))))))) + +(define *width* 79) + +(define (ls-files-columns files flag? port) + (let* ((max-file-name-width + (if (null? files) + 0 + (apply max (map (lambda (file) (string-length (car file))) files)))) + (max-file-name-width + (if flag? + (+ 1 max-file-name-width) + max-file-name-width)) + + (column-width (+ 2 max-file-name-width)) + + (columns (quotient *width* + column-width)) + (columns (if (zero? columns) + 1 + columns)) + + (number-of-files (length files)) + (rows (quotient (+ number-of-files (- columns 1)) + columns)) + + (tails + (do ((column 0 (+ 1 column)) + (tails (make-vector columns))) + ((= column columns) + tails) + (vector-set! tails column + (list-tail-or-null files (* rows column)))))) + + (do ((row 0 (+ 1 row))) + ((= row rows)) + (do ((column 0 (+ 1 column))) + ((= column columns)) + (let ((tail (vector-ref tails column))) + (if (not (null? tail)) + (let* ((file (car tail)) + (width (display-file file flag? port))) + (display-spaces (- column-width width) port) + (vector-set! tails column (cdr tail)))))) + (ls-newline port)))) + +(define (list-tail-or-null list index) + (let loop ((list list) (index index)) + (cond + ((null? list) list) + ((zero? index) list) + (else (loop (cdr list) (- index 1)))))) + +(define (ls-files-column files long? flag? port) + (for-each + (lambda (file) + (ls-file file long? flag? port)) + files)) + +(define (ls-file file long? flag? port) + (if long? + (ls-file-long file flag? port) + (ls-file-short file flag? port))) + +(define (ls-file-short file flag? port) + (display-file file flag? port) + (ls-newline port)) + +(define (ls-file-long file flag? port) + (let ((info (cdr file))) + (display-permissions info port) + (display-decimal-justified (file-info:nlinks info) 4 port) + (write-char #\space port) + (let* ((uid (file-info:uid info)) + (user-name + (call-with-current-continuation + (lambda (escape) + (with-handler + (lambda (condition more) + (escape (number->string uid))) + (lambda () + (user-info:name (user-info uid)))))))) + (display-padded user-name 9 port)) + (let* ((gid (file-info:gid info)) + (group-name + (call-with-current-continuation + (lambda (escape) + (with-handler + (lambda (condition more) + (escape (number->string gid))) + (lambda () + (group-info:name (group-info gid)))))))) + (display-padded group-name 9 port)) + (display-decimal-justified (file-info:size info) 7 port) + (write-char #\space port) + (display-time (file-info:mtime info) port) + (write-char #\space port) + (display-file file flag? port) + (if (eq? (file-info:type info) 'symlink) + (begin + (display " -> " port) + (display (read-symlink (car file)) port))) + (ls-newline port))) + +(define *year-seconds* (* 365 24 60 60)) + +(define (display-time the-time port) + (let ((time-difference (abs (- (time) the-time))) + (date (date the-time 0))) + (if (< time-difference *year-seconds*) + (display (format-date "~b ~d ~H:~M" date) port) + (display (format-date "~b ~d ~Y " date) port)))) + +(define (display-file file flag? port) + (let ((file-name (car file))) + (display file-name port) + (if (maybe-display-flag (cdr file) flag? port) + (+ 1 (string-length file-name)) + (string-length file-name)))) + +(define (maybe-display-flag info flag? port) + (and flag? + (begin + (cond + ((eq? (file-info:type info) 'directory) + (write-char #\/ port)) + ((eq? (file-info:type info) 'symlink) + (write-char #\@ port)) + ; 'executable: bits 0, 3 or 6 are set: + ; that means, 'AND' with 1+8+64=73 results in a nonzero-value + ; note: there is no distinction between user's, group's and other's permissions + ; (as the real GNU-ls does not) + ((not (zero? (bitwise-and (file-info:mode info) 73))) + (write-char #\* port)) + ((eq? (file-info:type info) 'socket) + (write-char #\= port)) + ((eq? (file-info:type info) 'fifo) + (write-char #\| port))) + #t))) + +(define (display-permissions info port) + (case (file-info:type info) + ((directory) + (write-char #\d port)) + ((symlink) + (write-char #\l port)) + ((fifo) + (write-char #\p port)) + (else + (write-char #\- port))) + (let ((mode (file-info:mode info)) + (bit 8)) + (for-each + (lambda (id) + (if (not (zero? (bitwise-and (arithmetic-shift 1 bit) + mode))) + (write-char id port) + (write-char #\- port)) + (set! bit (- bit 1))) + '(#\r #\w #\x #\r #\w #\x #\r #\w #\x)))) + +(define (display-decimal-justified number width port) + (display-justified (number->string number) width port)) + +(define (display-justified string width port) + (let ((length (string-length string))) + (if (< length width) + (display-spaces (- width length) port)) + (display string port))) + +(define (display-padded string width port) + (let ((length (string-length string))) + (display string port) + (if (< length width) + (display-spaces (- width length) port)))) + +(define (display-spaces number port) + (do ((i 0 (+ 1 i))) + ((= i number)) + (write-char #\space port))) + +;; Convert Unix-style arguments to flags suitable for LS. + +(define (arguments->ls-flags args) + (let loop ((args args) (flags '())) + (if (null? args) + flags + (cond + ((argument->ls-flags (car args)) + => (lambda (new-flags) + (loop (cdr args) (append new-flags flags)))) + (else #f))))) + +(define (argument->ls-flags arg) + (let ((arg (if (symbol? arg) + (symbol->string arg) + arg))) + (if (or (string=? "" arg) + (not (char=? #\- (string-ref arg 0)))) + #f + (let loop ((chars (cdr (string->list arg))) (flags '())) + (cond + ((null? chars) + flags) + ((char->flag (car chars)) + => (lambda (flag) + (loop (cdr chars) (cons flag flags)))) + (else #f)))))) + +(define (char->flag char) + (case char + ((#\a) 'all) + ((#\R) 'recursive) + ((#\l) 'long) + ((#\d) 'directory) + ((#\F) 'flag) + ((#\C) 'columns) + (else #f))) + +(define (optional maybe-arg default-exp) + (cond + ((null? maybe-arg) default-exp) + ((null? (cdr maybe-arg)) (car maybe-arg)) + (else (error "too many optional arguments" maybe-arg)))) + +(define (ls-newline port) + (if (fluid ls-crlf?) + (write-crlf port) + (newline port))) \ No newline at end of file diff --git a/scheme/lib/netrc.scm b/scheme/lib/netrc.scm new file mode 100644 index 0000000..8804f15 --- /dev/null +++ b/scheme/lib/netrc.scm @@ -0,0 +1,393 @@ +;;; netrc.scm -- parse authentication information contained in ~/.netrc +;; +;; $Id: netrc.scm,v 1.1 2002/06/08 15:05:24 sperber Exp $ +;; +;; Please send suggestions and bug reports to + + + +;;; Overview ===================================================== +;; +;; On Unix systems the ~/.netrc file (in the user's home directory) +;; may contain information allowing automatic login to remote hosts. +;; The format of the file is defined in the ftp(1) manual page. +;; Example lines are +;; +;; machine ondine.cict.fr login marsden password secret +;; default login anonymous password user@site +;; +;; The ~/.netrc file should be protected by appropriate permissions, +;; and (like /usr/bin/ftp) this library will refuse to read the file if +;; it is badly protected. (unlike /usr/bin/ftp this library will always +;; refuse to read the file -- /usr/bin/ftp refuses it only if the password +;; is given for a non-default account). Appropriate permissions are set +;; if only the user has permissions on the file. +;; +;; Note following restrictions / differences: +;; * The macdef statement (defining macros) is not supported. +;; * The settings for one machine must be on a single line. +;; * The is no error proof while reading the file. +;; * default need not be the last line of the netrc-file + + + +;;; Entry points ======================================================= +;; +;; What you probably want, is to read out the default netrc-file. Do the +;; following: +;; +;; (let ((netrc-record (netrc:parse))) +;; (netrc:lookup netrc-record "name of the machine")) +;; +;; and you will receive three values: login-name, password and account-name. +;; If you only want the login-name or the password, use netrc:lookup-login +;; or netrc:lookup-password resp. +;; +;; You will get either the login / password for the specified machine, +;; or a default login / password if the machine is unknown. +;; +;; +;; (user-mail-address) -> string +;; Calculate the user's email address, as per the Emacs function of +;; the same name. Will take into account the environment variable +;; REPLYTO, if set. Otherwise the mail-address will look like +;; user@hostname. +;; +;; (netrc:parse [filename [fallback-password [fallback-login]]]) +;; -> netrc-record +;; * parses the netrc file and returns a netrc-record, containing all +;; necessary information for the following procedures. +;; * FILENAME defaults to "~/.netrc" +;; FALLBACK-PASSWORD defaults to the result of (user-mail-address) +;; FALLBACK-LOGIN defaults to "anonymous" +;; * if the netrc file does not provide a default password or a default +;; login (stated by the "default" statement), FALLBACK-PASSWORD and +;; FALLBACK-LOGIN will be used as default password or login, respectively. +;; (thus, user-mail-address is only called if the netrc file does not +;; contain a default specification) +;; * if the netrc file does not exist, a netrc-record filled with +;; default values is returned. +;; * if the netrc file does not have the correct permissions, a message is +;; printed to current error port and a netrc-record filled with default +;; values is returned. +;; +;; (netrc:try-parse filename fallback-password fallback-login) -> netrc-record +;; parses the netrc file and returns a netrc-record, containing all +;; necessary information for the following procedures. +;; if there is no file called FILENAME, the according error will be raised +;; if the specified file does not have the correct permissions set, +;; a netrc-refuse-warning will be signalled. +;; so if you don't like the error handling of netrc:parse, use +;; netrc:try-parse and catch the signalled conditions. +;; +;; (netrc:lookup netrc-record machine [default?]) -> string x string x string +;; Return the login,password,account information for MACHINE +;; specified by the netrc file. +;; If DEFAULT? is #t, default values are returned if no such +;; MACHINE is specified in the netrc file. Otherwise, #f,#f,#f +;; is returned +;; +;; (netrc:lookup-password netrc-record machine [default?]) -> string +;; Return the password information for MACHINE specified by the +;; netrc file. +;; If DEFAULT? is #t, the default password is returned if no such +;; MACHINE is specified. Otherwise, #f is returned. +;; +;; (netrc:lookup-login netrc-record machine [default?]) -> string +;; Return the login information for MACHINE specified by the +;; netrc file. +;; If DEFAULT? is #t, the default login is returned if no such +;; MACHINE is specified. Otherwise, #f is returned. +;; +;; (netrc:default-login netrc-record) -> string +;; Return the default login specified by the netrc file or "anonymous" +;; +;; (netrc:default-password netrc-record) -> string +;; Return the default password specified by the netrc file or +;; the mail-addres (result of (user-mail-address)) + + + +;;; Related work ======================================================== +;; +;; * Graham Barr has written a similar library for Perl, called +;; Netrc.pm +;; +;; * ange-ftp.el (transparent remote file access for Emacs) parses the +;; user's netrc file + + +;;; Portability ================================================== +;; +;; getenv, scsh file primitives, regexp code, format +;; define-record, ecm-utilities + + +;;; Desirable things ============================================= +;; +;; * Remove restrictions (as stated in 'Overview') and behave like +;; /usr/bin/ftp behaves +;; * perhaps: adding case-insensitivity (for host names) +;; * perhaps: better record-disclosers for netrc-entry- and netrc-records + + +; return the user's mail address, either specified by the environment +; variable REPLYTO or "user@hostname". +(define (user-mail-address) + (or (getenv "REPLYTO") + (string-append (user-login-name) "@" (system-fqdn)))) + + +; looks up the desired machine in a netrc-record +; if the machine is found in the entries-section +; following three values are returned: login, password and account +; if the machine is not found in the entries-section +; the behavior depends on lookup-default? which defaults to #t: +; if lookup-default? is #t +; following three values are returned: default-login default-password #f +; otherwise #f #f #f is returned. +(define (netrc:lookup netrc-record machine . lookup-default?) + (let-optionals lookup-default? + ((lookup-default? #t)) + (let ((record (find-record netrc-record machine))) + (if record + (values (netrc-entry:login record) + (netrc-entry:password record) + (netrc-entry:account record)) + (if lookup-default? + (values (netrc:default-login netrc-record) + (netrc:default-password netrc-record) + #f) + (values #f #f #f)))))) + +; does the same as netrc:lookup, but returns only the password (or #f) +(define (netrc:lookup-password netrc-record machine . lookup-default?) + (let-optionals lookup-default? + ((lookup-default? #t)) + (let ((record (find-record netrc-record machine))) + (if record + (netrc-entry:password record) + (and lookup-default? + (netrc:default-password netrc-record)))))) + +; does the same as netrc:lookup, but returns only the login (or #f) +(define (netrc:lookup-login netrc-record machine . lookup-default?) + (let-optionals lookup-default? + ((lookup-default? #t)) + (let ((record (find-record netrc-record machine))) + (if record + (netrc-entry:login record) + (and lookup-default? + (netrc:default-login netrc-record)))))) + +; does the work for netrc:parse +; file-name has to be resolved +(define (netrc:try-parse file-name default-password default-login) + (netrc:check-permissions file-name) + (let ((fd (open-input-file file-name)) + (netrc-record (make-netrc '() default-password default-login file-name))) + (for-each-line (parse-line netrc-record) fd))) + +; parses the netrc-file +; expected arguments: filename default-password default-login +; filename: filename of the .netrc-file (defaults to ~/.netrc) +; default-password: default password for any not specified machine +; defaults to (user-mail-address) +; default password in netrc-file overwrites this setting +; default-login: default login name for any not specified machine +; defaults to "anonymous" +; default login in netrc-file overwrites this setting +; * (default-login is expected after default-password as users usually want +; to change the default-password (to something else than their mail-address) +; rather than the login-name)(define (netrc:parse . args) +; * if the given file does not exist or it has the wrong permissions, +; than a default netrc-record is returned +; * if you don't want expected errors to be captured, use netrc:try-parse; +; note that you have to resolve the file-name on your own +(define-condition-type 'netrc-refuse '(warning)) +(define netrc-refuse? (condition-predicate 'netrc-refuse)) + +(define (netrc:parse . args) + (let-optionals + args ((file-name "~/.netrc") + (default-password #f) ; both ... + (default-login #f)) ; ... are set if netrc-file does + ; not provide default-values + (let* ((file-name (resolve-file-name file-name)) + (local-default-login (lambda () "anonymous")) + (local-default-password (lambda () (user-mail-address))) + (local-default-netrc-record + (lambda () + (make-netrc '() + (or default-login (local-default-login)) + (or default-password (local-default-password)) + #f)))) +; i know, this double-handler sucks; has anyone a better idea? + (call-with-current-continuation + (lambda (exit) + (with-handler + (lambda (error more) + (if (netrc-refuse? error) + (format (current-error-port) + "netrc: Warning: ~a~%" + (car (condition-stuff error))) + (format (current-error-port) + "netrc: Warning: Unexpected error encountered: ~s~%" + error)) + (exit (local-default-netrc-record))) + (lambda () + (with-errno-handler* + (lambda (errno packet) + (if (= errno errno/noent) + (format (current-error-port) + "netrc: Warning: no such file or directory: ~a~%" + file-name) + (format (current-error-port) + "netrc: Warning: Error accessing file ~s~%" + file-name)) + (exit (local-default-netrc-record))) + (lambda () + (let ((netrc-record + (netrc:try-parse file-name default-password default-login))) + ; If we get a netrc-record, we return it after + ; checking default login and default password settings. + ; Otherwise, we return the default record with + ; file-name stored. + ; This is sub-optimal, as we may throw away badly + ; structured .netrc-files silently. We need an error + ; checking mechanism. + (if (netrc? netrc-record) + (begin + (if (eq? (netrc:default-login netrc-record) #f) + (set-netrc:default-login (local-default-login))) + (if (eq? (netrc:default-password netrc-record) #f) + (set-netrc:default-password (local-default-password))) + netrc-record) + (let ((default-netrc-record (local-default-netrc-record))) + (set-netrc:file-name default-netrc-record file-name) + default-netrc-record)))))))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; nothing exported below +;; except +;; netrc:default-password +;; netrc:default-login + +(define-record netrc-entry + machine + login + password + account) + +(define-record netrc + entries ; list of netrc-entrys + default-login ; default-values (either library-default or netrc-file-default) + default-password + file-name) ; debug-purpose + + +(define-record-discloser type/netrc-entry + (lambda (netrc-entry) + (list 'netrc-entry))) ; perhaps something else later on + +(define-record-discloser type/netrc + (lambda (netrc) + (list 'netrc))) ; perhaps something else later on + +; finds a record in the entries-list of a netrc-record +; matching the given machine +; returns the netrc-entry-record if found, otherwise #f +(define (find-record netrc-record machine) + (find-first (lambda (rec) + (and (equal? (netrc-entry:machine rec) machine) + rec)) + (netrc:entries netrc-record))) + + +;; raise error if any permissions are set for group or others. +(define (netrc:check-permissions file-name) + (let ((perms (- (file-mode file-name) 32768))) + (if (positive? (bitwise-and #b000111111 perms)) + (signal 'netrc-refuse + (format #f + "Not parsing ~s (netrc file); dangerous permissions." + file-name))))) + +; tries to match target on line and returns the first group, +; or #f if there is no match +(define (try-match target line) + (let ((match (string-match target line))) + (and match + (match:substring match 1)))) + +; parses the default line of the netrc-file +(define (parse-default netrc-record line) + (let ((login (try-match "login[ \t]+([^ \t]+)" line)) + (password (try-match "password[ \t]+([^ \t]+)" line))) + (if login + (set-netrc:default-login netrc-record login)) + (if password + (set-netrc:default-password netrc-record password)) + netrc-record)) + +; parses a line of the netrc-file +(define (parse-line netrc-record) + (lambda (line) + (cond ((string-match "default" line) + (parse-default netrc-record line)) + (else + (let ((machine (try-match "machine[ \t]+([^ \t]+)" line)) + (login (try-match "login[ \t]+([^ \t]+)" line)) + (password (try-match "password[ \t]+([^ \t]+)" line)) + (account (try-match "account[ \t]+([^ \t]+)" line))) + (if (or machine login password account) + (add netrc-record machine login password account) + netrc-record)))))) ; return record on empty / wrong lines +; (This is a workaround. we should give a warning on malicious .netrc +; files. As we do not have an error checking system installed yet, we +; skip these lines silently.) + +; adds machine login password account stored in a netrc-entry-record +; to the entries-list of a netrc-record +(define (add netrc-record machine login password account) + (set-netrc:entries netrc-record + (cons (make-netrc-entry machine login password account) + (netrc:entries netrc-record))) + netrc-record) + +;; for testing +(define (netrc:dump netrc-record) + (format #t "~%--- Dumping ~s contents ---" (netrc:file-name netrc-record)) + (for-each (lambda (rec) + (format #t "~% machine ~a login ~a password ~a account ~a" + (netrc-entry:machine rec) + (netrc-entry:login rec) + (netrc-entry:password rec) + (netrc-entry:account rec))) + (netrc:entries netrc-record)) + (format #t "~% default login: ~s" (netrc:default-login netrc-record)) + (format #t "~% default password: ~s" (netrc:default-password netrc-record)) + (format #t "~%--- End of ~s contents ---~%" (netrc:file-name netrc-record))) + + +; runs proc for each line of fd (line is argument to proc) +; returns either nothing, if the fd had no line +; or the value returned by proc called on the last line +(define (for-each-line proc fd) + (let ((line (read-line fd))) + (if (not (eof-object? line)) + (let loop ((last-result (proc line))) + (let ((line (read-line fd))) + (if (not (eof-object? line)) + (loop (proc line)) + last-result)))))) + +; finds first element in l for which pred doesn't return #f +; returns either #f (no such element found) +; or the result of the last call to pred +(define (find-first pred l) + (if (null? l) #f + (or (pred (car l)) + (find-first pred (cdr l))))) + +;; EOF diff --git a/scheme/lib/nettime-obsolete.scm b/scheme/lib/nettime-obsolete.scm new file mode 100644 index 0000000..01b9a92 --- /dev/null +++ b/scheme/lib/nettime-obsolete.scm @@ -0,0 +1,6 @@ +; maps obsolete nettime-procedure names to new nettime procedure names +; by Andreas Bernauer (2002) + +(define net:time net-time) +(define net:daytime net-daytime) + diff --git a/scheme/lib/nettime.scm b/scheme/lib/nettime.scm new file mode 100644 index 0000000..f928098 --- /dev/null +++ b/scheme/lib/nettime.scm @@ -0,0 +1,76 @@ +;;; nettime.scm -- obtain the time on remote machines +;; +;; $Id: nettime.scm,v 1.1 2002/06/08 15:05:24 sperber Exp $ +;; +;; Please send suggestions and bug reports to + + + +;;; Overview ======================================================== +;; +;; Most Unix hosts provide a Daytime service which sends the current +;; date and time as a human-readable character string. The daytime +;; service is typically served on port 13 as both TCP and UDP. +;; +;; The Time protocol provides a site-independent, machine readable +;; date and time. A "time" consists of the number of seconds since +;; midnight on 1st January 1900. The Time service is typically served +;; on port 37 as TCP and UDP. The idea is that you can confirm your +;; system's idea of the time by polling several independent sites on +;; the network. + + +;;; Related work ====================================================== +;; +;; * Time.pm is a Perl module by Graham Barr +;; * rfc868 describes the Time protocol +;; * rfc867 describes the Daytime protocol in all its glory +;; * for a genuinely useful protocol look at the Network Time Protocol +;; defined in rfc1305, which allows for the synchronization of clocks +;; on networked computers. + + + +;; args host protocol, where host may be an IP number or a fqdn. we +;; subtract 70 years' worth of seconds at the end, since the time +;; protocol returns the number of seconds since 1900, whereas Unix +;; time is since 1970. +(define (net-time host tcp/udp) + (let* ((hst-info (host-info host)) + (srvc-info (service-info "time" "tcp")) + (sock (socket-connect protocol-family/internet + tcp/udp + (host-info:name hst-info) + (service-info:port srvc-info))) + (result (read-integer (socket:inport sock)))) + (close-socket sock) + (- result 2208988800))) + + +(define (net-daytime host tcp/udp) + (let* ((hst-info (host-info host)) + (srvc-info (service-info "daytime" "tcp")) + (sock (socket-connect protocol-family/internet + tcp/udp + (host-info:name hst-info) + (service-info:port srvc-info))) + (result (read-string 20 (socket:inport sock)))) + (close-socket sock) + result)) + + +;; read 4 bytes from fd and build an integer from them +(define (read-integer fd) + (let loop ((accum 0) + (remaining 4)) + (if (zero? remaining) + accum + (loop (+ (arithmetic-shift accum 8) (read-byte fd)) + (- remaining 1))))) + +;; what about EOF?? +(define (read-byte fd) + (char->ascii (read-char fd))) + + +;; EOF diff --git a/scheme/lib/parse-forms.scm b/scheme/lib/parse-forms.scm new file mode 100644 index 0000000..46f99c8 --- /dev/null +++ b/scheme/lib/parse-forms.scm @@ -0,0 +1,67 @@ +;;; Code to parse information submitted from HTML forms. -*- Scheme -*- +;;; Copyright (c) 1995 by Olin Shivers. + +;;; See http://www.w3.org/hypertext/WWW/MarkUp/html-spec/html-spec_toc.html + +;;; Imports and non-R4RS'isms +;;; string-index (string srfi) +;;; let-optionals (let-opt package) +;;; receive (Multiple-value return) +;;; unescape-uri +;;; map-string (strings package) +;;; ? (cond) + +;;; About HTML forms +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; The form's field data are turned into a single string, of the form +;;; The form's field data are turned into a single string, of the form +;;; name=val&name=val +;;; where the and parts are URI encoded to hide their +;;; &, =, and + chars, among other things. After URI encoding, the +;;; space chars are converted to + chars, just for fun. It is important +;;; to encode the spaces this way, because the perfectly general %xx escape +;;; mechanism might be insufficiently confusing. This variant encoding is +;;; called "form-url encoding." +;;; +;;; If the form's method is POST, +;;; Browser sends the form's field data in the entity block, e.g., +;;; "button=on&ans=yes". The request's Content-type: is application/ +;;; x-www-form-urlencoded, and the request's Content-length: is the +;;; number of bytes in the form data. +;;; +;;; If the form's method is GET, +;;; Browser sends the form's field data in the URL's part. +;;; (So the server will pass to the CGI script as $QUERY_STRING, +;;; and perhaps also on in argv[]). +;;; +;;; In either case, the data is "form-url encoded" (as described above). + +;;; Form-query parsing +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Parse "foo=x&bar=y" into (("foo" . "x") ("bar" . "y")) +;;; Substrings are plus-decoded and then URI-decoded. This implementation is +;;; slightly sleazy as it will successfully parse a string like "a&b=c&d=f" +;;; into (("a&b" . "c") ("d" . "f")) without a complaint. + +(define (parse-html-form-query q) + (let ((qlen (string-length q))) + (let recur ((i 0)) + (cond + ((>= i qlen) '()) + ((string-index q #\= i) => + (lambda (j) + (let ((k (or (string-index q #\& j) qlen))) + (cons (cons (unescape-uri+ q i j) + (unescape-uri+ q (+ j 1) k)) + (recur (+ k 1)))))) + (else '()))))) ; BOGUS STRING -- Issue a warning. + + +;;; Map plus characters to spaces, then do URI decoding. +(define (unescape-uri+ s . maybe-start/end) + (let-optionals maybe-start/end ((start 0) + (end (string-length s))) + (unescape-uri (string-map (lambda (c) (if (char=? c #\+) #\space c)) + (if (and (zero? start) + (= end (string-length s))) + s ; Gratuitous optimisation. + (substring s start end)))))) diff --git a/scheme/lib/pop3-obsolete.scm b/scheme/lib/pop3-obsolete.scm new file mode 100644 index 0000000..b866f72 --- /dev/null +++ b/scheme/lib/pop3-obsolete.scm @@ -0,0 +1,12 @@ +; maps obsolete pop3-procedure names to new pop3 procedure names +; by Andreas Bernauer (2002) + +(define pop3:connect pop3-connect) +(define pop3:login pop3-login) +(define pop3:stat pop3-stat) +(define pop3:get pop3-get) +(define pop3:headers pop3-headers) +(define pop3:last pop3-last) +(define pop3:delete pop3-delete) +(define pop3:reset pop3-reset) +(define pop3:quit pop3-quit) diff --git a/scheme/lib/pop3.scm b/scheme/lib/pop3.scm new file mode 100644 index 0000000..1dfe068 --- /dev/null +++ b/scheme/lib/pop3.scm @@ -0,0 +1,351 @@ +;;; 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 $ +;; +;; Please send suggestions and bug reports to + + +;;; Overview ============================================================== +;; +;; The POP3 protocol allows access to email on a maildrop server. It +;; is often used in configurations where users connect from a client +;; machine which doesn't have a permanent network connection or isn't +;; always turned on, situations which make local SMTP delivery +;; impossible. It is the most common form of email access provided by +;; Internet Service Providers. +;; +;; Two types of authentication are commonly used. The first, most +;; basic type involves sending a user's password in clear over the +;; network, and should be avoided. Unfortunately many POP3 clients +;; only implement this basic authentication. The digest authentication +;; system involves the server sending the client a "challenge" token; +;; the client encodes this token with the pass phrase and sends the +;; coded information to the server. This method avoids sending +;; sensitive information over the network. +;; +;; Once connected, a client may request information about the number +;; and size of the messages waiting on the server, download selected +;; messages (either their headers or the entire content), and delete +;; selected messages. + + +;;; Entry points ======================================================= +;; +;; (pop3-connect [host logfile]) -> connection +;; Connect to the maildrop server named HOST. Optionally log the +;; conversation with the server to LOGFILE, which will be appended +;; to if it exists, and created otherwise. The environment variable +;; MAILHOST, if set, will override the value of HOST. +;; +;; (pop3-login connection [login password]) -> status +;; Log in to the mailhost. If a login and password are not +;; provided, they are first searched for in the user's ~/.netrc +;; file. USER/PASS authentication will be tried first, and if this +;; fails, APOP authentication will be tried. +;; +;; (pop3-login/APOP connection login password) -> status +;; Log in to the mailhost using APOP authentication. +;; +;; (pop3-stat connection) -> integer x integer +;; Return the number of messages and the number of bytes waiting in +;; the maildrop. +;; +;; (pop3-get connection msgid) -> status +;; Download message number MSGID from the mailhost. MSGID must be +;; positive and less than the number of messages returned by the +;; pop3-stat call. The message contents are sent to +;; (current-output-port). +;; +;; (pop3-headers connection msgid) -> status +;; Download the headers of message number MSGID. The data is sent +;; to (current-output-port). +;; +;; (pop3-last connection) -> integer +;; Return the highest accessed message-id number for the current +;; session. This isn't in the RFC, but seems to be supported by +;; several servers. +;; +;; (pop3-delete connection msgid) -> status +;; Mark message number MSGID for deletion. The message will not be +;; deleted until the client logs out. +;; +;; (pop3-reset connection) -> status +;; Any messages which have been marked for deletion are unmarked. +;; +;; (pop3-quit connection) -> status +;; Close the connection with the mailhost. + + + +;;; Portability ====================================================== +;; +;; define-record +;; socket, regexp +;; signals/handlers + + +;;; Related work ===================================================== +;; +;; * Emacs is distributed with a C program called movemail which can +;; be compiled with support for the POP protocol. There is also an +;; Emacs Lisp library called pop3.el by Richard Pieri which includes +;; APOP support. +;; +;; * Shriram Krishnamurth has written a POP3 library for MzScheme (as +;; well as support for the NNTP protocol, for SMTP, ...). +;; +;; * Siod (a small-footprint Scheme implementation by George Carette) +;; includes support for the POP3 protocol. +;; +;; * rfc1939 describes the POP3 protocol. + + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Communication is initiated by the client. The server responds to +;; each request with a status indicator and an explanatory message. +;; The client starts off by opening a connection to a well known port +;; on the server machine (typically TCP 110, or 109 on some broken +;; systems). Messages sent to the server are of the form +;; +;; CMD [ arg ] +;; +;; Replies from the server are of the form +;; +;; status [ Informative message ] +;; +;; where status is either "+OK" or "-ERR". If the server is sending +;; data (the contents of a message for example), it marks the end of +;; the data by a line consisting only of a decimal point (thus the +;; bytes to look out for are .. Any lines in the data +;; starting with a . have an additional . added to the beginning, to +;; avoid the client thinking that the line marks the end of the +;; message. The client should therefore replace double decimal points +;; at the beginning of a line by a single decimal point. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;: [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)) + + ;; 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) + (call-error "must provide a login" pop3-login args))) + (password (or (safe-second args) + (netrc:lookup-password netrc (pop3-connection:host-name connection) #f) + (call-error "must provide a password" pop3-login args)))) + (with-handler + (lambda (result punt) + (if (-ERR? result) + (if (pop3-connection:challenge connection) + (pop3-login/APOP connection login password) + (error "login failed")))) + (lambda () + (pop3-send-command connection (format #f "USER ~a" login)) + (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))))) + + +;; Login to the server using APOP authentication (no cleartext +;; passwords are sent over the network). The server appends a token to +;; its welcome message, which is built from the server's fully +;; qualified domain name and a unique serial number. The client +;; concatenates this token and the pass phrase and applies the MD5 +;; digest algorithm (a one-way hash) to produce a digest. The user +;; name and the digest are sent to the server to authenticate the +;; user. The following example comes from the RFC: +;; +;; S: +OK POP3 server ready <1896.697170952@dbc.mtview.ca.us> +;; C: APOP mrose c4c9334bac560ecc979e58001b3e22fb +;; S: +OK maildrop has 1 message (369 octets) +;; +;; In this example, the shared secret is the string `tan- +;; staaf'. Hence, the MD5 algorithm is applied to the string +;; +;; <1896.697170952@dbc.mtview.ca.us>tanstaaf +;; +;; which produces a digest value of +;; +;; c4c9334bac560ecc979e58001b3e22fb +;; +;;: connection x string x string -> status +(define (pop3-login/APOP connection login password) + (let* ((key (string-append (pop3-connection:challenge connection) + password)) + (digest (md5-digest key)) + (status (pop3-send-command connection + (format #f "APOP ~a ~a" login digest)))) + (set-pop3-connection:login connection login) + (set-pop3-connection:password connection password) + (set-pop3-connection:state connection 'connected) + status)) + + +;; return number of messages and number of bytes waiting at the maildrop +;;: connection -> integer x integer +(define (pop3-stat connection) + (pop3-check-transaction-state connection 'pop3-stat) + (let* ((response (pop3-send-command connection "STAT")) + (match (regexp-search (rx (posix-string "([0-9]+) ([0-9]+)")) response))) + (values (string->number (match:substring match 1)) + (string->number (match:substring match 2))))) + +;; dump the message number MSGID to (current-output-port) +;;: connection x integer -> status +(define (pop3-get connection msgid) + (pop3-check-transaction-state connection 'pop3-get) + (let ((status (pop3-send-command connection (format #f "RETR ~a" msgid)))) + (pop3-dump (socket:inport (pop3-connection:command-socket connection))) + status)) + +;;: connection x integer -> status +(define (pop3-headers connection msgid) + (pop3-check-transaction-state connection 'pop3-headers) + (let ((status (pop3-send-command connection (format #f "TOP ~a 0" msgid)))) + (pop3-dump (socket:inport (pop3-connection:command-socket connection))) + status)) + +;; Return highest accessed message-id number for the session. This +;; ain't in the RFC, but seems to be supported by several servers. +;;: connection -> integer +(define (pop3-last connection) + (pop3-check-transaction-state connection 'pop3-last) + (let ((response (pop3-send-command connection "LAST"))) + (string->number (car ((infix-splitter) response))))) + +;; mark the message number MSGID for deletion. Note that the messages +;; are not truly deleted until the QUIT command is sent, and messages +;; can be undeleted using the RSET command. +;;: connection x integer -> status +(define (pop3-delete connection msgid) + (pop3-check-transaction-state connection 'pop3-delete) + (pop3-send-command connection (format #f "DELE ~a" msgid))) + + +;; any messages which have been marked for deletion are unmarked +;;: connection -> status +(define (pop3-reset connection) + (pop3-check-transaction-state connection 'pop3-reset) + (pop3-send-command connection "RSET")) + +;;: connection -> status +(define (pop3-quit connection) + (pop3-check-transaction-state connection 'pop3-quit) + (let ((status (pop3-send-command connection "QUIT"))) + (close-socket (pop3-connection:command-socket connection)) + status)) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Nothing exported below. + +(define-record pop3-connection + host-name + command-socket + logfd + login + password + challenge + state) + +;; cf /usr/local/src/scheme48-0.49/scheme/rts/condition.scm +(define-condition-type '-ERR '(error)) +(define -ERR? (condition-predicate '-ERR)) + + +(define (pop3-check-transaction-state connection caller) + (if (not (eq? (pop3-connection:state connection) 'connected)) + (call-error "not in transaction state" caller))) + +(define (pop3-read-response connection) + (let* ((sock (pop3-connection:command-socket connection)) + (IN (socket:inport sock)) + (line (read-line IN))) + (pop3-log connection (format #f "-> ~a" line)) + line)) + +;; this could perhaps be improved +(define (pop3-handle-response response command) + (let ((match (regexp-search (rx (posix-string "^\\+OK(.*)")) response))) + (if match + (match:substring match 1) + (let ((match2 (regexp-search (rx (posix-string "^-ERR(.*)")) response))) + (if match2 + (signal '-ERR (match:substring match2 1) command) + (signal '-ERR response command)))))) + + +(define (pop3-log connection line) + (let ((LOG (pop3-connection:logfd connection))) + (and LOG + (write-string line LOG) + (write-string "\n" LOG) + (force-output LOG)))) + +(define (pop3-send-command connection command) + (let* ((sock (pop3-connection:command-socket connection)) + (OUT (socket:outport sock))) + (write-string command OUT) + (write-crlf OUT) + (pop3-log connection (format #f "<- ~a" command)) + (pop3-handle-response (pop3-read-response connection) command))) + + +;; who will write this in Scheme? +(define (md5-digest str) + (car (run/strings (md5sum) (<< ,str)))) +; the name of the program differs among the distributions +; e.g. in FreeBSD it is called md5 + +(define (pop3-dump fd) + (let loop ((line (read-line fd))) + (cond ((and (not (eof-object? line)) + (not (equal? line ".\r"))) + (and (eq? 0 (string-index line #\.)) ; fix byte-stuffed lines + (eq? 1 (string-index line #\. 1)) + (set! line (substring line 1 (string-length line)))) + (write-string line) + (newline) + (loop (read-line fd)))))) + +;; EOF diff --git a/scheme/lib/rate-limit.scm b/scheme/lib/rate-limit.scm new file mode 100644 index 0000000..5a461c6 --- /dev/null +++ b/scheme/lib/rate-limit.scm @@ -0,0 +1,58 @@ +;;; Rate limiting -*- Scheme -*- +;;; Copyright (c) 2002 by Mike Sperber. + +(define-record-type rate-limiter :rate-limiter + (really-make-rate-limiter simultaneous-requests + access-lock + block-lock + current-requests) + rate-limiter? + (simultaneous-requests rate-limiter-simultaneous-requests) + (access-lock rate-limiter-access-lock) + (block-lock rate-limiter-block-lock) + (current-requests rate-limiter-current-requests-unsafe + set-rate-limiter-current-requests!)) + +(define (make-rate-limiter simultaneous-requests) + (really-make-rate-limiter simultaneous-requests + (make-lock) + (make-lock) + 0)) + +(define (rate-limit-block rate-limiter) + (obtain-lock (rate-limiter-block-lock rate-limiter))) + +(define (rate-limit-open rate-limiter) + (obtain-lock (rate-limiter-access-lock rate-limiter)) + (let ((current-requests + (+ 1 (rate-limiter-current-requests-unsafe rate-limiter)))) + (set-rate-limiter-current-requests! rate-limiter + current-requests) + (if (>= current-requests + (rate-limiter-simultaneous-requests rate-limiter)) + (maybe-obtain-lock (rate-limiter-block-lock rate-limiter)) + (release-lock (rate-limiter-block-lock rate-limiter)))) + (release-lock (rate-limiter-access-lock rate-limiter))) + +(define (rate-limit-close rate-limiter) + (obtain-lock (rate-limiter-access-lock rate-limiter)) + (let ((current-requests + (- (rate-limiter-current-requests-unsafe rate-limiter) 1))) + (if (negative? current-requests) + (error "rate-limiter: too many close operations" + rate-limiter)) + (set-rate-limiter-current-requests! rate-limiter + current-requests) + (if (= current-requests + (- (rate-limiter-simultaneous-requests rate-limiter) + 1)) + ;; we just came back into range + (release-lock (rate-limiter-block-lock rate-limiter)))) + (release-lock (rate-limiter-access-lock rate-limiter))) + +(define (rate-limiter-current-requests rate-limiter) + (obtain-lock (rate-limiter-access-lock rate-limiter)) + (let ((current-requests + (rate-limiter-current-requests-unsafe rate-limiter))) + (release-lock (rate-limiter-access-lock rate-limiter)) + current-requests)) diff --git a/scheme/lib/rfc822.scm b/scheme/lib/rfc822.scm new file mode 100644 index 0000000..10d0868 --- /dev/null +++ b/scheme/lib/rfc822.scm @@ -0,0 +1,219 @@ +;;; RFC 822 field-parsing code -*- Scheme -*- +;;; Copyright (c) 1995 by Olin Shivers. +;;; +;;; +;;; Imports and non-R4RS'isms +;;; string conversions +;;; read-crlf-line +;;; let-optionals, :optional +;;; receive values (MV return) +;;; "\r\n" in string for cr/lf +;;; ascii->char (defining the tab char) +;;; index +;;; string-join (reassembling body lines) +;;; error +;;; ? (COND) + +;;; RFC 822 is the "Standard for the format of ARPA Internet text messages" +;;; -- the document that essentially tells how the fields in email headers +;;; (e.g., the Subject: and To: fields) are formatted. This code is for +;;; parsing these headers. Here are two pointers to the document: +;;; Emacs/ange /ftp@ftp.internic.net:/rfc/rfc822.txt +;;; URL ftp://ftp.internic.net/rfc/rfc822.txt +;;; RFC 822 parsing is useful in other contexts as well -- the HTTP protocol +;;; uses it, and it tends to pop up here and there. +;;; +;;; RFC 822 header syntax has two levels: the general syntax for headers, +;;; and the syntax for specific headers. For example, once you have figured +;;; out which chunk of text is the To: line, there are more rules telling +;;; how to split the To: line up into a list of addresses. Another example: +;;; lines with dates, e.g., the Date: header, have a specific syntax for +;;; the time and date. +;;; +;;; This code currently *only* provides routines for parsing the gross +;;; structure -- splitting the message header into its distinct fields. +;;; It would be nice to provide the finer-detail parsers, too. You do it. +;;; -Olin + +;;; A note on line-terminators: +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Line-terminating sequences are always a drag, because there's no agreement +;;; on them -- the Net protocols and DOS use cr/lf; Unix uses lf; the Mac +;;; uses cr. One one hand, you'd like to use the code for all of the above, +;;; on the other, you'd also like to use the code for strict applications +;;; that need definitely not to recognise bare cr's or lf's as terminators. +;;; +;;; RFC 822 requires a cr/lf (carriage-return/line-feed) pair to terminate +;;; lines of text. On the other hand, careful perusal of the text shows up +;;; some ambiguities (there are maybe three or four of these, and I'm too +;;; lazy to write them all down). Furthermore, it is an unfortunate fact +;;; that many Unix apps separate lines of RFC 822 text with simple linefeeds +;;; (e.g., messages kept in /usr/spool/mail). As a result, this code takes a +;;; broad-minded view of line-terminators: lines can be terminated by either +;;; cr/lf or just lf, and either terminating sequence is trimmed. +;;; +;;; If you need stricter parsing, you can call the lower-level procedure +;;; %READ-RFC-822-FIELD and %READ-RFC822-HEADERS procs. They take the +;;; read-line procedure as an extra parameter. This means that you can +;;; pass in a procedure that recognises only cr/lf's, or only cr's (for a +;;; Mac app, perhaps), and you can determine whether or not the terminators +;;; get trimmed. However, your read-line procedure must indicate the +;;; header-terminating empty line by returning *either* the empty string or +;;; the two-char string cr/lf (or the EOF object). + +;;; (read-rfc822-field [port]) +;;; (%read-rfc822-field read-line port) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Read one field from the port, and return two values [NAME BODY]: +;;; - NAME Symbol such as 'subject or 'to. The field name is converted +;;; to a symbol using the Scheme implementation's preferred +;;; case. If the implementation reads symbols in a case-sensitive +;;; fashion (e.g., scsh), lowercase is used. This means you can +;;; compare these symbols to quoted constants using EQ?. When +;;; printing these field names out, it looks best if you capitalise +;;; them with (CAPITALIZE-STRING (SYMBOL->STRING FIELD-NAME)). +;;; - BODY List of strings which are the field's body, e.g. +;;; ("shivers@lcs.mit.edu"). Each list element is one line +;;; from the field's body, so if the field spreads out +;;; over three lines, then the body is a list of three +;;; strings. The terminating cr/lf's are trimmed from each +;;; string. A leading space or a leading horizontal tab +;;; is also trimmed, but one and only one. +;;; When there are no more fields -- EOF or a blank line has terminated the +;;; header section -- then the procedure returns [#f #f]. +;;; +;;; The %READ-RFC822-FIELD variant allows you to specify your own +;;; read-line procedure. The one used by READ-RFC822-FIELD terminates +;;; lines with either cr/lf or just lf, and it trims the terminator +;;; from the line. Your read-line procedure should trim the terminator +;;; of a line so an empty line is returned just as an empty string. + +(define htab (ascii->char 9)) + +;;; Convert to a symbol using the Scheme implementation's preferred case, +;;; so we can compare these things against quoted constants. +(define string->symbol-pref + (if (char=? #\a (string-ref (symbol->string 'a) 0)) ; Is it #\a or #\A? + (lambda (s) (string->symbol (string-map char-downcase s))) + (lambda (s) (string->symbol (string-map char-upcase s))))) + +(define (read-rfc822-field . maybe-port) + (let-optionals maybe-port ((port (current-input-port))) + (%read-rfc822-field read-crlf-line port))) + +(define (%read-rfc822-field read-line port) + (let ((line1 (read-line port))) + (if (or (eof-object? line1) + (zero? (string-length line1)) + (string=? line1 "\r\n")) ; In case read-line doesn't trim. + + (values #f #f) ; Blank line or EOF terminates header text. + + (cond + ((string-index line1 #\:) => ; Find the colon and + (lambda (colon) ; split out field name. + (let ((name (string->symbol-pref (substring line1 0 colon)))) + ;; Read in continuation lines. + (let lp ((lines (list (substring line1 + (+ colon 1) + (string-length line1))))) + (let ((c (peek-char port))) ; Could return EOF. +;;; RFC822: continuous lines has to start with a space or a htab + (if (or (eqv? c #\space) (eqv? c htab)) + (lp (cons (read-line port) lines)) + (values name (reverse lines)))))))) + (else (error "Illegal RFC 822 field syntax." line1)))))) ; No : + + +;;; (read-rfc822-headers [port]) +;;; (%read-rfc822-headers read-line port) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Read in and parse up a section of text that looks like the header portion +;;; of an RFC 822 message. Return an alist mapping a field name (a symbol +;;; such as 'date or 'subject) to a list of field bodies -- one for +;;; each occurence of the field in the header. So if there are five +;;; "Received-by:" fields in the header, the alist maps 'received-by +;;; to a five element list. Each body is in turn represented by a list +;;; of strings -- one for each line of the field. So a field spread across +;;; three lines would produce a three element body. +;;; +;;; The %READ-RFC822-HEADERS variant allows you to specify your own read-line +;;; procedure. See notes above for reasons why. + +(define (read-rfc822-headers . maybe-port) + (let-optionals maybe-port ((port (current-input-port))) + (%read-rfc822-headers read-crlf-line port))) + +(define (%read-rfc822-headers read-line port) + (let lp ((alist '())) + (receive (field val) (%read-rfc822-field read-line port) + (cond (field (cond ((assq field alist) => + (lambda (entry) + (set-cdr! entry (cons val (cdr entry))) + (lp alist))) + (else (lp (cons (list field val) alist))))) + + ;; We are done. Reverse the order of each entry and return. + (else (for-each (lambda (entry) + (set-cdr! entry (reverse (cdr entry)))) + alist) + alist))))) + +;;; (rejoin-header-lines alist [separator]) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Takes a field alist such as is returned by READ-RFC822-HEADERS and +;;; returns an equivalent alist. Each body (string list) in the input alist +;;; is joined into a single list in the output alist. SEPARATOR is the +;;; string used to join these elements together; it defaults to a single +;;; space " ", but can usefully be "\n" or "\r\n". +;;; +;;; To rejoin a single body list, use scsh's STRING-JOIN procedure. + +(define (rejoin-header-lines alist . maybe-separator) + (let-optionals maybe-separator ((sep " ")) + (map (lambda (entry) + (cons (car entry) + (map (lambda (body) (string-join body sep)) + (cdr entry)))) + alist))) + + +;;; Given a set of RFC822 headers like this: +;;; From: shivers +;;; To: ziggy, +;;; newts +;;; To: gjs, tk +;;; +;;; We have the following definitions: +;;; (get-header-all hdrs 'to) -> ((" ziggy," " newts") (" gjs, tk")) +;;; - All entries, or #f +;;; (get-header-lines hdrs 'to) -> (" ziggy," " newts") +;;; - All lines of the first entry, or #f. +;;; (get-header hdrs 'to) -> "ziggy,\n newts" +;;; - First entry, with the lines joined together by newlines. + +(define (get-header-all headers name) + (let ((entry (assq name headers))) + (and entry (cdr entry)))) + +(define (get-header-lines headers name) + (let ((entry (assq name headers))) + (and entry + (pair? entry) + (cadr entry)))) + +(define (get-header headers name . maybe-sep) + (let ((entry (assq name headers))) + (and entry + (pair? entry) + (string-join (cadr entry) + (:optional maybe-sep "\n"))))) + + + +;;; Other desireable functionality +;;; - Unfolding long lines. +;;; - Lexing structured fields. +;;; - Unlexing structured fields into canonical form. +;;; - Parsing and unparsing dates. +;;; - Parsing and unparsing addresses. diff --git a/scheme/lib/smtp.scm b/scheme/lib/smtp.scm new file mode 100644 index 0000000..fe13a72 --- /dev/null +++ b/scheme/lib/smtp.scm @@ -0,0 +1,606 @@ +;;; SMTP client code -*- Scheme -*- +;;; Copyright (c) 1995 by Brian D. Carlstrom and Olin Shivers. +;;; , +;;; +;;; See rfc821: /ftp@ftp.internic.net:/rfc/rfc821.txt + +;;; External dependencies and non-R4RS'isms +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; system-name user-login-name (for high-level SENDMAIL proc) +;;; receive values (MV return) +;;; write-string read-string/partial (scsh I/O procs) +;;; force-output +;;; scsh's socket module +;;; :optional +;;; error +;;; read-crlf-line write-crlf +;;; \n \r in strings (Not R5RS) + +;;; SMTP protocol procedures tend to return two values: +;;; - CODE The integer SMTP reply code returned by server for the transaction. +;;; - TEXT A list of strings -- the text messages tagged by the code. +;;; The text strings have the initial code numerals and the terminating +;;; cr/lf's stripped. Codes in the range [1,399] are sucess codes; codes +;;; in the range [400,599] are error codes; codes >= 600 are not part +;;; of the official SMTP spec. This module uses codes >= 600 to indicate +;;; extra-protocol errors. There are two of these: +;;; - 600 Server reply could not be parsed. +;;; The server sent back some sort of incomprehensible garbage reply. +;;; - 621 Premature EOF while reading server reply. +;;; The server shut down in the middle of a reply. +;;; A list of the official protocol return codes is appended at the end of +;;; this file. + +;;; These little cover functions are trivial packagings of the protocol. +;;; You could write your own to handle, e.g., mailing a message to a list +;;; of addresses. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + +;;; This is broken -- the (SYSTEM-NAME) proc returns a local name, not +;;; a useful Internet host name. How do we do that? +;;; [Andreas:] I've inserted a way to do this. It works fine on my +;;; system. Does it work on your, too? + +;;; (sendmail to-list body [host]) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Mail message to recipients in list TO-LIST. Message handed off to server +;;; running on HOST; default is the local host. Returns two values: code and +;;; text-list. However, if only problem with message is that some recipients +;;; were rejected, sendmail sends to the rest of the recipients, and the +;;; partial-success return is [700 loser-alist] where loser-alist +;;; is a list whose elements are of the form (loser-recipient code . text) -- +;;; that is, for each recipient refused by the server, you get the error +;;; data sent back for that guy. The success check is (< code 400). +;;; +;;; BODY is a string or an input port. + +(define (sendmail to-list body . maybe-host) + (call-with-current-continuation + (lambda (bailout) + (let ((local (host-info:name (host-info (system-name)))) + (socket (smtp/open (:optional maybe-host "localhost")))) + (receive (code text) (smtp-transactions socket ; Do prologue. + (smtp/helo socket local) + (smtp/mail socket (string-append (user-login-name) + "@" local))) + (if (>= code 400) (values code text) ; error + + ;; Send over recipients and collect the losers. + (let ((losers (filter-map + (lambda (to) + (receive (code text) (smtp/rcpt socket to) + (and (>= code 400) ; Error + (cond ((>= code 600) + (smtp/quit socket) + (bailout code text)) + (else `(,to ,code ,@text)))))) + to-list))) + + ;; Send the message body and wrap things up. + (receive (code text) (smtp-transactions socket + (smtp/data socket body) + (smtp/quit socket)) + (if (and (< code 400) (null? losers)) + (values code text) + (values 700 losers)))))))))) + +;;; Trivial utility -- like map, but filter out #f's. + +(define (filter-map f lis) + (let lp ((ans '()) (lis lis)) + (if (pair? lis) + (lp (cond ((f (car lis)) => (lambda (val) (cons val ans))) + (else ans)) + (cdr lis)) + (reverse ans)))) + +(define (%sendmail from local-host to dest-host message) + (let ((socket (smtp/open dest-host))) + (smtp-transactions socket + (smtp/helo socket local-host) + (smtp/mail socket from) + (smtp/rcpt socket to) + (smtp/data socket message) + (smtp/quit socket)))) + + +;;; EXPN, VRFY, MAIL-HELP +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; These three are simple queries of the server. + +(define (smtp-query socket query arg) + (receive (code text) + (smtp-transactions socket + (smtp/helo socket (system-name)) + (query socket arg)) + (if (not (or (= code 421) (= code 221))) + (smtp/quit socket)) + (values code text))) + +(define (expn name host) + (smtp-query (smtp/open host) smtp/expn name)) + +(define (vrfy name host) + (smtp-query (smtp/open host) smtp/vrfy name)) + +(define (mail-help host . details) + (smtp-query (smtp/open host) smtp/help (apply string-append (cons " " details)))) + + +;;; (smtp-transactions socket ?transaction1 ...) +;;; (smtp-transactions/no-close socket ?transaction1 ...) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; These macros make it easy to do simple sequences of SMTP commands. +;;; +;;; Evaluate a series of expressions ?transaction1, ?transaction2, ... +;;; - Each expression should perform an SMTP transaction, +;;; and return two values: +;;; + CODE (the integer reply code) +;;; + TEXT (list of strings that came with the reply). +;;; +;;; - If the transaction's reply code is 221 or 421 (meaning the socket has +;;; been closed), then the transaction sequence is aborted, and the +;;; SMTP-TRANSACTIONS form returns the CODE and TEXT values for the current +;;; transaction. +;;; +;;; - If the reply code is an error code (in the four- or five-hundred range), +;;; the transaction sequence is aborted, and the fatal transaction's CODE +;;; and TEXT values are returned. SMTP-TRANSACTIONS will additionally +;;; close the socket for you; SMTP-TRANSACTIONS/NO-CLOSE will not. +;;; +;;; - If the transaction is the last in the transaction sequence, +;;; its CODE and TEXT values are returned. +;;; +;;; - Otherwise, we throw away the current CODE and TEXT values, and +;;; proceed to the next transaction. +;;; +;;; Since SMTP-TRANSACTIONS closes the socket whenever it aborts a sequence, +;;; an SMTP-TRANSACTIONS form terminated with an (smtp/quit socket) transaction +;;; will always close the socket. +;;; +;;; If the socket should be kept open in the case of an abort, use +;;; SMTP-TRANSACTIONS/NO-CLOSE. +;;; +;;; We abort sequences if a transaction results in a 400-class error code. +;;; So, a sequence mailing a message to five people, with 5 RCPT's, would +;;; abort if the mailing address for one of these people was wrong, rather +;;; than proceeding to mail the other four. This may not be what you want; +;;; if so, you'll have to roll your own. + +(define-syntax smtp-transactions + (syntax-rules () + ((smtp-transactions socket ?T1 ?T2 ...) + (let ((s socket)) + (receive (code text) (smtp-transactions/no-close s ?T1 ?T2 ...) + (if (<= 400 code) (smtp/quit s)) + (values code text)))))) + +(define-syntax smtp-transactions/no-close + (syntax-rules () + ((smtp-transactions/no-close socket ?T1 ?T2 ...) + ;; %smtp-transactions/no-close replicates the socket argument, + ;; so we have to force it to be a variable. + (let ((s socket)) + (%smtp-transactions/no-close s ?T1 ?T2 ...))))) + +;;; SOCKET must be a variable, hence replicable. +(define-syntax %smtp-transactions/no-close + (syntax-rules () + ((%smtp-transactions/no-close socket ?T1 ?T2 ?T3 ...) + (receive (code text) ?T1 + (if (or (= code 221) + (= code 421) ; Redundant, I know. + (<= 400 code)) + (values code text) + (%smtp-transactions/no-close socket ?T2 ?T3 ...)))) + + ((%smtp-transactions/no-close socket ?T1) + ?T1))) + +;;; I can't make this nested definition work. I'm not enough of a macro stud. +;(define-syntax smtp-transactions/no-close +; (syntax-rules () +; ((smtp-transactions/no-close socket ?T1 ...) +; (letrec-syntax ((%smtp-transactions/no-close +; (syntax-rules () +; +; ((%smtp-transactions/no-close socket ?T1 ?T2 ...) +; (receive (code text) ?T1 +; (if (or (= code 221) +; (= code 421) ; Redundant, I know. +; (<= 400 code)) +; (values code text) +; (%smtp-transactions/no-close socket ?T2 ...)))) +; +; ((%smtp-transactions/no-close socket ?T1) +; ?T1)))) +; +; ;; %smtp-transactions/no-close replicates the socket argument, +; ;; so we have to force it to be a variable. +; (let ((s socket)) +; (%smtp-transactions/no-close s ?T1 ...)))))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; The basics of the protocol + +(define (nullary-smtp-command command) + (lambda (socket) + (let ((port (socket:outport socket))) + (write-string command port) + (write-crlf port)) + (handle-smtp-reply socket))) + + +(define (unary-smtp-command command) + (lambda (socket data) + (let ((port (socket:outport socket))) + (write-string command port) + (display #\space port) + (write-string data port) + (write-crlf port)) + (handle-smtp-reply socket))) + + +(define (smtp/open host . maybe-port) + (let ((sock (socket-connect protocol-family/internet socket-type/stream host + (:optional maybe-port "smtp")))) + (receive (code text) (handle-smtp-reply sock) + (if (< code 400) sock + (error "SMTP socket-open server-reply error" sock code text))))) + +;; HELLO +(define smtp/helo (unary-smtp-command "HELO")) + +;; MAIL FROM: +(define smtp/mail (unary-smtp-command "MAIL FROM:")) + +;; RECIPIENT TO: +(define smtp/rcpt (unary-smtp-command "RCPT TO:")) + +;; DATA +(define smtp/data + (let ((send-DATA-msg (nullary-smtp-command "DATA"))) + (lambda (socket message) ; MESSAGE is a string or an input port. + (receive (code text) (send-DATA-msg socket) + (if (>= code 400) (values code text) ; Error. + + ;; We got a positive acknowledgement for the DATA msg, + ;; now send the message body. + (let ((p (socket:outport socket))) + (cond ((string? message) + (receive (data last-char) (smtp-stuff message #f) + (write-string data p))) + + ((input-port? message) + (let lp ((last-char #f)) + (cond ((read-string/partial 1024 message) => + (lambda (chunk) + (receive (data last-char) + (smtp-stuff chunk last-char) + (write-string data p) + (lp last-char))))))) + + (else (error "Message must be string or input-port."))) + + (write-string "\r\n.\r\n" p) + (force-output p) + (handle-smtp-reply socket))))))) + +;; SEND FROM: +(define smtp/send (unary-smtp-command "SEND FROM:")) + +;; SEND OR MAIL +(define smtp/soml (unary-smtp-command "SOML FROM:")) + +;; SEND AND MAIL +(define smtp/saml (unary-smtp-command "SOML SAML:")) + +;; RESET +(define smtp/rset (nullary-smtp-command "RSET")) + +;; VERIFY +(define smtp/vrfy (unary-smtp-command "VRFY")) + +;; EXPAND +(define smtp/expn (unary-smtp-command "EXPN")) + +;; HELP

+(define smtp/help + (let ((send-help (unary-smtp-command "HELP"))) + (lambda (socket . details) + (send-help socket (apply string-append details))))) + +;; NOOP +(define smtp/noop (nullary-smtp-command "NOOP")) + +;; QUIT +(define smtp/quit + (let ((quit (nullary-smtp-command "QUIT"))) + (lambda (socket) + (receive (code text) (quit socket) ; Quit & close socket gracefully. + (case code + ((221 421)) + (else (close-socket socket))) ; But close in any event. + (values code text))))) + +;; TURN +(define smtp/turn (nullary-smtp-command "TURN")) + +;;; Read and handle the reply. Return an integer (the reply code), +;;; and a list of the text lines that came tagged by the reply code. +;;; The text lines have the reply-code prefix (first 4 chars) and the +;;; terminating cr/lf's stripped. +;;; +;;; In bdc's analog of this proc, he would read another reply if the code was +;;; in the one-hundred range (1xx). These codes aren't even used in smtp, +;;; according to the RFC. So why? + +(define (handle-smtp-reply socket) + (receive (code text) (read-smtp-reply (socket:inport socket)) + (case code + ((221 421) (close-socket socket))) ; All done. + (values code text))) + +;;; Read a reply from the SMTP server. Returns two values: +;;; - CODE Integer. The reply code. +;;; - TEXT String list. A list of the text lines comprising the reply. +;;; Each line of text is stripped of the initial reply-code +;;; numerals (e.g., the first four chars of the reply), and +;;; the trailing cr/lf. We are in fact generous about what +;;; we take to be a line -- the protocol requires cr/lf +;;; terminators, but we'll accept just lf. This appears to +;;; true to the spirit of the "be strict in what you send, +;;; and generous in what you accept" Internet protocol philosphy. + +(define (read-smtp-reply port) + (let lp ((replies '())) + (let ((ln (read-crlf-line port))) + (if (eof-object? ln) + (values 621 (cons "Premature EOF during smtp reply." + (reverse replies))) + (receive (code line more?) (parse-smtp-reply ln) + (let ((replies (cons line replies))) + (if more? (lp replies) + (values code (reverse replies))))))))) + +;;; Parse a line of SMTP reply. Return three values: +;;; CODE integer - the reply code that prefixes the string. +;;; REST string - the rest of the line. +;;; MORE? boolean - is there more reply to read (i.e., was the numeric +;;; reply code terminated by a "-" character?) + +(define (parse-smtp-reply line) + (if (and (string? line) ; This is all checking + (> (string-length line) 3) ; to see if the line + (char-numeric? (string-ref line 0)) ; is properly formatted. + (char-numeric? (string-ref line 1)) + (char-numeric? (string-ref line 2)) + (let ((c (string-ref line 3))) + (or (char=? c #\space) (char=? c #\-)))) + + (values (string->number (substring line 0 3)) ; It is. + (substring line 4 (string-length line)) + (char=? (string-ref line 3) #\-)) + + (values 600 ; It isn't. + (string-append "Improperly-formatted smtp reply: " line) + #f))) + + +;;; The message body of a piece of email is terminated by the sequence +;;; +;;; If the message body contains this magic sequence, it has to be escaped. +;;; We do this by mapping the sequence to ; +;;; the SMTP receiver undoes this mapping. + +;;; S is a string to stuff, PCHAR was the character read just before S +;;; (which matters if it is a line-feed). If S is the first chunk of the entire +;;; msg, then PCHAR can be #f. Return two values: the stuffed string, and the +;;; last char in S (or PCHAR if S is empty). The last-char value returned can +;;; be used as the PCHAR arg for the following call to SMTP-STUFF. + +(define (smtp-stuff s pchar) + (let* ((slen (string-length s)) + (hits ; Count up all the seqs in the string. + (let lp ((count 0) + (nl? (eqv? pchar #\newline)) ; Was last char a newline? + (i 0)) + (if (< i slen) + (let ((c (string-ref s i))) + (lp (if (and nl? (char=? c #\.)) (+ count 1) count) + (eq? c #\newline) + (+ i 1))) + count)))) + + (values (if (zero? hits) s + ;; Make a new string, and do the dot-stuffing copy. + (let ((ns (make-string (+ hits slen)))) + (let lp ((nl? (eqv? pchar #\newline)) + (i 0) ; S index. + (j 0)) ; NS index. + (if (< i slen) + (let ((c (string-ref s i))) + (string-set! ns j c) + (cond ((and nl? (char=? c #\.)) + (string-set! ns (+ j 1) #\.) + (lp #f (+ i 1) (+ j 2))) + (else (lp (char=? c #\newline) (+ i 1) (+ j 1))))))) + ns)) + + (if (zero? slen) pchar (string-ref s (- slen 1)))))) ; LAST-CHAR + +;;; Reply codes +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; This material taken from the RFC. +;;; +;;; 1yz Positive Preliminary reply +;;; +;;; The command has been accepted, but the requested action +;;; is being held in abeyance, pending confirmation of the +;;; information in this reply. The sender-SMTP should send +;;; another command specifying whether to continue or abort +;;; the action. +;;; +;;; [Note: SMTP does not have any commands that allow this +;;; type of reply, and so does not have the continue or +;;; abort commands.] +;;; +;;; 2yz Positive Completion reply +;;; +;;; The requested action has been successfully completed. A +;;; new request may be initiated. +;;; +;;; 3yz Positive Intermediate reply +;;; +;;; The command has been accepted, but the requested action +;;; is being held in abeyance, pending receipt of further +;;; information. The sender-SMTP should send another command +;;; specifying this information. This reply is used in +;;; command sequence groups. +;;; +;;; 4yz Transient Negative Completion reply +;;; +;;; The command was not accepted and the requested action did +;;; not occur. However, the error condition is temporary and +;;; the action may be requested again. The sender should +;;; return to the beginning of the command sequence (if any). +;;; It is difficult to assign a meaning to "transient" when +;;; two different sites (receiver- and sender- SMTPs) must +;;; agree on the interpretation. Each reply in this category +;;; might have a different time value, but the sender-SMTP is +;;; encouraged to try again. A rule of thumb to determine if +;;; a reply fits into the 4yz or the 5yz category (see below) +;;; is that replies are 4yz if they can be repeated without +;;; any change in command form or in properties of the sender +;;; or receiver. (E.g., the command is repeated identically +;;; and the receiver does not put up a new implementation.) +;;; +;;; 5yz Permanent Negative Completion reply +;;; +;;; The command was not accepted and the requested action did +;;; not occur. The sender-SMTP is discouraged from repeating +;;; the exact request (in the same sequence). Even some +;;; "permanent" error conditions can be corrected, so the +;;; human user may want to direct the sender-SMTP to +;;; reinitiate the command sequence by direct action at some +;;; point in the future (e.g., after the spelling has been +;;; changed, or the user has altered the account status). +;;; +;;;The second digit encodes responses in specific categories: +;;; +;;; x0z Syntax -- These replies refer to syntax errors, +;;; syntactically correct commands that don't fit any +;;; functional category, and unimplemented or superfluous +;;; commands. +;;; +;;; x1z Information -- These are replies to requests for +;;; information, such as status or help. +;;; +;;; x2z Connections -- These are replies referring to the +;;; transmission channel. +;;; +;;; x3z Unspecified as yet. +;;; +;;; x4z Unspecified as yet. +;;; +;;; x5z Mail system -- These replies indicate the status of +;;; the receiver mail system vis-a-vis the requested +;;; transfer or other mail system action. + +;;; Complete list (grouped by function) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; 500 Syntax error, command unrecognized +;;; [This may include errors such as command line too long] +;;; 501 Syntax error in parameters or arguments +;;; 502 Command not implemented +;;; 503 Bad sequence of commands +;;; 504 Command parameter not implemented +;;; +;;; 211 System status, or system help reply +;;; 214 Help message +;;; [Information on how to use the receiver or the meaning of a +;;; particular non-standard command; this reply is useful only +;;; to the human user] +;;; +;;; 220 Service ready +;;; 221 Service closing transmission channel +;;; 421 Service not available, +;;; closing transmission channel +;;; [This may be a reply to any command if the service knows it +;;; must shut down] +;;; +;;; 250 Requested mail action okay, completed +;;; 251 User not local; will forward to +;;; 450 Requested mail action not taken: mailbox unavailable +;;; [E.g., mailbox busy] +;;; 550 Requested action not taken: mailbox unavailable +;;; [E.g., mailbox not found, no access] +;;; 451 Requested action aborted: error in processing +;;; 551 User not local; please try +;;; 452 Requested action not taken: insufficient system storage +;;; 552 Requested mail action aborted: exceeded storage allocation +;;; 553 Requested action not taken: mailbox name not allowed +;;; [E.g., mailbox syntax incorrect] +;;; 354 Start mail input; end with . +;;; 554 Transaction failed +;;; + +;;; State diagram +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; CONNECTION ESTABLISHMENT +;;; S: 220 +;;; F: 421 +;;; HELO +;;; S: 250 +;;; E: 500, 501, 504, 421 +;;; MAIL +;;; S: 250 +;;; F: 552, 451, 452 +;;; E: 500, 501, 421 +;;; RCPT +;;; S: 250, 251 +;;; F: 550, 551, 552, 553, 450, 451, 452 +;;; E: 500, 501, 503, 421 +;;; DATA +;;; I: 354 -> data -> S: 250 +;;; F: 552, 554, 451, 452 +;;; F: 451, 554 +;;; E: 500, 501, 503, 421 +;;; RSET +;;; S: 250 +;;; E: 500, 501, 504, 421 +;;; SEND +;;; S: 250 +;;; F: 552, 451, 452 +;;; E: 500, 501, 502, 421 +;;; SOML +;;; S: 250 +;;; F: 552, 451, 452 +;;; E: 500, 501, 502, 421 +;;; SAML +;;; S: 250 +;;; F: 552, 451, 452 +;;; E: 500, 501, 502, 421 +;;; VRFY +;;; S: 250, 251 +;;; F: 550, 551, 553 +;;; E: 500, 501, 502, 504, 421 +;;; EXPN +;;; S: 250 +;;; F: 550 +;;; E: 500, 501, 502, 504, 421 +;;; HELP +;;; S: 211, 214 +;;; E: 500, 501, 502, 504, 421 +;;; NOOP +;;; S: 250 +;;; E: 500, 421 +;;; QUIT +;;; S: 221 +;;; E: 500 +;;; TURN +;;; S: 250 +;;; F: 502 +;;; E: 500, 503 diff --git a/scheme/lib/sunet-utilities.scm b/scheme/lib/sunet-utilities.scm new file mode 100644 index 0000000..734a222 --- /dev/null +++ b/scheme/lib/sunet-utilities.scm @@ -0,0 +1,16 @@ +; some useful utilities + +(define (host-name-or-ip addr) + (with-fatal-error-handler + (lambda (condition more) + (call-with-values + (lambda () (socket-address->internet-address addr)) + (lambda (ip port) + (format-internet-host-address ip)))) + (host-info:name (host-info addr)))) + +(define (on-interrupt interrupt thunk) + (let lp ((event (most-recent-sigevent))) + (let ((next (next-sigevent event interrupt))) + (thunk) + (lp next)))) diff --git a/scheme/lib/uri.scm b/scheme/lib/uri.scm new file mode 100644 index 0000000..65c673c --- /dev/null +++ b/scheme/lib/uri.scm @@ -0,0 +1,301 @@ +;;; -*- Scheme -*- +;;; Copyright (c) 1995 by Olin Shivers. + +;;; URI syntax -- [scheme] : path [? search ] [# fragmentid] + +;;; Imports and non-R4RS'isms +;;; let-optionals +;;; receive values (MV return) +;;; ascii->char char->ascii +;;; index rindex +;;; char-set-index char-set-rindex +;;; string-reduce +;;; char-set package +;;; bitwise logical funs and arithmetic-shift +;;; join-strings (scsh field-reader code.) + + +;;; References: +;;; - ftp://ftp.internic.net/rfc/rfc1630.txt +;;; Original RFC +;;; - http://www.w3.org/hypertext/WWW/Addressing/URL/URI_Overview.html +;;; General Web page of URI pointers. + +;;; I wrote a URI parser that slavishly obeyed Tim Berners-Lee's +;;; spec (rfc 1630). This was a waste of time, as most URL's do not +;;; obey his spec, which is incomplete and inconsistent with the URL spec +;;; in any event. This parser is much simpler. It parses a URI into four +;;; fields: +;;; [ ] : [ ? ] [ # fragid ] +;;; The returned fields are *not* unescaped, as the rules for parsing the +;;; component in particular need unescaped text, and are dependent +;;; on . The URL parser is responsible for doing this. +;;; If the , or portions are not specified, +;;; they are #f. Otherwise, , , and are strings; +;;; is a non-empty string list. + +;;; The parsing technique is inwards from both ends. +;;; - First we search forwards for the first reserved char (= ; / # ? : space) +;;; If it's a colon, then that's the part, otw no part. +;;; Remove it. +;;; - Then we search backwards from the end for the last reserved char. +;;; If it's a sharp, then that's the part -- remove it. +;;; - Then we search backwards from the end for the last reserved char. +;;; If it's a question-mark, then that's the part -- remove it. +;;; - What's left is the path. Split at slashes. "" -> ("") +;;; +;;; This scheme is tolerant of the various ways people build broken +;;; URI's out there on the Net , p.e. \#= is a reserved character, but +;;; used unescaped in the search-part. It was given to me by Dan +;;; Connolly of the W3C and slightly modified. + +;;; Returns four values: scheme, path, search, frag-id. Each value is +;;; either #f or a string except of the path, which is a nonempty list +;;; of string (as mentioned above). + + +(define uri-reserved (string->char-set ";/#?: =")) + +(define (parse-uri s) + (let* ((slen (string-length s)) + ;; Search forwards for colon (or intervening reserved char). + (rs1 (string-index s uri-reserved)) ; 1st reserved char + (colon (and rs1 (char=? (string-ref s rs1) #\:) rs1)) + (path-start (if colon (+ colon 1) 0)) + + ;; Search backwards for # (or intervening reserved char). + (rs-last (string-index-right s uri-reserved)) + (sharp (and rs-last (char=? (string-ref s rs-last) #\#) rs-last)) + + ;; Search backwards for ? (or intervening reserved char). + ;; (NB: #\= may be after #\? and before #\#) + (rs-penult (string-index-right + s + (char-set-delete uri-reserved #\=) + (or sharp slen))) + (ques (and rs-penult (char=? (string-ref s rs-penult) #\?) rs-penult)) + + (path-end (or ques sharp slen))) + (values (and colon (substring s 0 colon)) + (split-uri-path s path-start path-end) + (and ques (substring s (+ ques 1) (or sharp slen))) + (and sharp (substring s (+ sharp 1) slen))))) + +;;; Caution: +;;; Don't use this proc until *after* you've parsed the URL -- unescaping +;;; might introduce reserved chars (like slashes and colons) that could +;;; blow your parse. + +(define (unescape-uri s . maybe-start/end) + (let-optionals maybe-start/end ((start 0) + (end (string-length s))) + (let* ((esc-seq? (lambda (i) (and (< (+ i 2) end) + (char=? (string-ref s i) #\%) + (hex-digit? (string-ref s (+ i 1))) + (hex-digit? (string-ref s (+ i 2)))))) + (hits (let lp ((i start) (hits 0)) ; count # of esc seqs. + (if (< i end) + (if (esc-seq? i) + (lp (+ i 3) (+ hits 1)) + (lp (+ i 1) hits)) + hits)))) + + (if (and (zero? hits) (zero? start) (= end (string-length s))) s + + (let* ((nlen (- (- end start) (* hits 2))) ; the new + ; length of the + ; unescaped + ; string + (ns (make-string nlen))) ; stores the result + + (let lp ((i start) (j 0)) ; sweap over the string + (if (< j nlen) + (lp (cond + ((esc-seq? i) ; unescape + ; escape-sequence + (string-set! ns j + (let ((d1 (string-ref s (+ i 1))) + (d2 (string-ref s (+ i 2)))) + (ascii->char (+ (* 16 (hexchar->int d1)) + (hexchar->int d2))))) + (+ i 3)) + (else (string-set! ns j (string-ref s i)) + (+ i 1))) + (+ j 1)))) + ns))))) + +(define hex-digit? + (let ((hex-digits (string->char-set "0123456789abcdefABCDEF"))) + (lambda (c) (char-set-contains? hex-digits c)))) + +; make use of the fact that numbers and characters are in order in the ascii table +(define (hexchar->int c) + (- (char->ascii c) + (if (char-numeric? c) + (char->ascii #\0) + (- (if (char-upper-case? c) + (char->ascii #\A) + (char->ascii #\a)) + 10)))) + +(define int->hexchar + (let ((table '#(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 + #\A #\B #\C #\D #\E #\F))) + (lambda (i) (vector-ref table i)))) + + +;;; Caution: +;;; All reserved chars (e.g., slash, sharp, colon) get escaped: "=;/#?: " +;;; So don't apply this proc to chunks of text with syntactically meaningful +;;; reserved chars (e.g., paths with URI slashes or colons) -- they'll be +;;; escaped, and lose their special meaning. E.g. it would be a mistake +;;; to apply ESCAPE-URI to "//lcs.mit.edu:8001/foo/bar.html" because the +;;; slashes and colons would be escaped. + +(define uri-escaped-chars + (char-set-complement (char-set-union char-set:letter+digit + (string->char-set "$-_@.&!*\"'(),+")))) + +;;; Takes a set of chars to escape. This is because we sometimes need to +;;; escape larger sets of chars for different parts of a URI. + +(define (escape-uri s . maybe-escaped-chars) + (let-optionals maybe-escaped-chars ((escaped-chars uri-escaped-chars)) + (let ((nlen (string-fold + (lambda (c i) + (+ i + (if (char-set-contains? escaped-chars c) + 3 1))) + 0 + s))) ; new length of escaped string + (if (= nlen (string-length s)) s + (let ((ns (make-string nlen))) + (string-fold + (lambda (c i) ; replace each occurance of an + ; character to escape with %ff where ff + ; is the ascii-code in hexadecimal + ; notation + (+ i (cond + ((char-set-contains? escaped-chars c) + (string-set! ns i #\%) + (let* ((d (char->ascii c)) + (dhi (bitwise-and (arithmetic-shift d -4) #xF)) + (dlo (bitwise-and d #xF))) + (string-set! ns (+ i 1) + (int->hexchar dhi)) + (string-set! ns (+ i 2) + (int->hexchar dlo))) + 3) + (else (string-set! ns i c) + 1)))) + 0 + s) + ns))))) + + +;;; Four args: context URI's : values, and +;;; main URI's : values. +;;; If the path cannot be resolved, return #f #f (this occurs if +;;; begins with n sequential slashes, and doesn't +;;; have that many sequential slashes anywhere). All paths are +;;; represented as non-empty lists. + +(define (resolve-uri cscheme cp scheme p) + (if scheme (values scheme p) ; If URI has own , it is absolute. + + (if (and (pair? p) (string=? (car p) "")) ; Path P begins with a slash. + + (receive (numsl p) ; Count and strip off initial + (do ((i 1 (+ i 1)) ; slashes (i.e., initial ""'s) + (q (cdr p) (cdr q))) + ((or (null? q) (not (string=? (car q) ""))) + (values i q))) + + ;; Skip through CP until we find that many sequential /'s. + (let lp ((cp-tail cp) + (rhead '()) ; CP prefix, reversed. + (j 0)) ; J counts sequential / + + (cond + ((and (pair? cp-tail) (string=? (car cp-tail) "")) ; More ""'s + (lp (cdr cp-tail) + (cons (car cp-tail) rhead) + (+ j 0))) + + ((= j numsl) ; Win + (values cscheme (simplify-uri-path (rev-append rhead p)))) + + ((pair? cp-tail) ; Keep looking. + (lp (cdr cp-tail) + (cons (car cp-tail) rhead) + 1)) + + (else (values #f #f))))) ; Lose. + + + ;; P doesn't begin with a slash. + (values cscheme (simplify-uri-path + (rev-append (cdr (reverse cp)) ; Drop non-dir part + p)))))) ; and append P. + + +(define (rev-append a b) ; (append (reverse a) b) + (let rev-app ((a a) (b b)) ; Should be defined in a list-proc + (if (pair? a) ; package, not here. + (rev-app (cdr a) (cons (car a) b)) + b))) + +;;; Cribbed from scsh's fname.scm + +(define (split-uri-path uri start end) ; Split at /'s (infix grammar). + (let split ((i start)) ; "" -> ("") + (cond + ((>= i end) '("")) + ((string-index uri #\/ i) => + (lambda (slash) + (cons (substring uri i slash) + (split (+ slash 1))))) + (else (list (substring uri i end)))))) + + +;;; The elements of PLIST must be escaped in case they contain slashes. +;;; This procedure doesn't escape them for you; you must do that yourself: +;;; (uri-path-list->path (map escape-uri pathlist)) + +(define (uri-path-list->path plist) + (string-join plist "/")) ; Insert slashes between elts of PLIST. + + +;;; Remove . and /.. elements from path. The result is a +;;; (maybe empty) list representing a path that does not contain "." +;;; and ".." elements neither at the beginning nor somewhere else. I +;;; tried to follow RFC2396 here. The procedure returns #f if the path +;;; tries to back up past root (like "//.." or "/foo/../.."). "//" may +;;; occur somewhere in the path but not being backed up. Usually, +;;; relative paths are intended to be used with a base +;;; url. Accordingly to RFC2396 (as I hope) relative paths are +;;; considered not to start with "/". They are appended to a base +;;; URL-path and then simplified. So before you start to simplify a +;;; URL try to find out if it is a relative path (i.e. it does not +;;; start with a "/"). + +(define (simplify-uri-path p) + (if (null? p) #f ; P must be non-null + (let lp ((path-list (cdr p)) + (stack (list (car p)))) + (if (null? path-list) ; we're done + (reverse stack) + (cond + ((string=? (car path-list) "..") ; back up + ; neither the empty path nor root + (if (not (or (null? stack) (string=? (car stack) ""))) + (lp (cdr path-list) (cdr stack)) + #f)) + ((string=? (car path-list) ".") ; leave this + (lp (cdr path-list) stack)) + ((string=? (car path-list) "") ; back to root + (lp (cdr path-list) '(""))) + (else ; usual segment + (lp (cdr path-list) (cons (car path-list) stack)))))))) + + \ No newline at end of file diff --git a/scheme/lib/url.scm b/scheme/lib/url.scm new file mode 100644 index 0000000..80a27d7 --- /dev/null +++ b/scheme/lib/url.scm @@ -0,0 +1,152 @@ +;;; URL parsing and unparsing -*- Scheme -*- +;;; Copyright (c) 1995 by Olin Shivers. + +;;; I'm only implementing http URL's right now. + +;;; References: +;;; - ftp://ftp.internic.net/rfc/rfc1738.txt +;;; Original RFC +;;; - http://www.w3.org/hypertext/WWW/Addressing/URL/Overview.html +;;; General Web page of URI pointers. + + +;;; Unresolved issues: +;;; - The userhost parser shouldn't substitute default values -- +;;; that should happen in a separate step. + +;;; Imports and non-R4RS'isms +;;; define-record Record structures +;;; receive values MV return +;;; URI support +;;; string-index + +;;; The steps in hacking a URL are: +;;; - Take the UID, parse it, and resolve it with the context UID, if any. +;;; - Consult the UID's . Pick the appropriate URL parser and parse. + + +;;; Userhost strings: //:@:/ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; A USERHOST record describes path-prefixes of the form +;;; //:@:/ +;;; These are frequently used as the initial prefix of URL's describing +;;; Internet resources. + +(define-record userhost ; Each slot is a decoded string or #f. + user + password + host + port) + +;;; Parse a URI path (a list representing a path, not a string!) into +;;; a userhost record. Default values are taken from the userhost +;;; record DEFAULT except for the host. Returns a userhost record if +;;; it wins. CADDR drops the userhost portion of the path. In fact, +;;; fatal-syntax-error is called, if the path doesn't start with '//'. + +(define (parse-userhost path default) + (if (and (pair? path) ; The thing better begin + (string=? (car path) "") ; with // (i.e., have two + (pair? (cdr path)) ; initial "" elements). + (string=? (cadr path) "")) + + (let* ((uhs (caddr path)) ; Userhost string. + (uhs-len (string-length uhs)) + ; Usr:passwd at-sign, + (at (string-index uhs #\@)) ; if any. + + (colon1 (and at (string-index uhs #\:))) ; Usr:passwd colon, + (colon1 (and colon1 (< colon1 at) colon1)) ; if any. + + (colon2 (string-index uhs #\: (or at 0)))) ; Host:port colon, + ; if any. + (make-userhost (if at + (unescape-uri uhs 0 (or colon1 at)) + (userhost:user default)) + (if colon1 + (unescape-uri uhs (+ colon1 1) at) + (userhost:password default)) + (unescape-uri uhs (if at (+ at 1) 0) + (or colon2 uhs-len)) + (if colon2 + (unescape-uri uhs (+ colon2 1) uhs-len) + (userhost:port default)))) + + (fatal-syntax-error "URL must begin with //..." path))) + +;;; Unparser + +(define userhost-escaped-chars + (char-set-union uri-escaped-chars ; @ and : are also special + (string->char-set "@:"))) ; in UH strings. + +(define (userhost->string uh) + (let* ((us (userhost:user uh)) + (pw (userhost:password uh)) + (ho (userhost:host uh)) + (po (userhost:port uh)) + + ;; Encode before assembly in case pieces contain colons or at-signs. + (e (lambda (s) (escape-uri s userhost-escaped-chars))) + + (user/passwd (if us `(,(e us) . ,(if pw `(":" ,(e pw) "@") '("@"))) + '())) + (host/port (if ho `(,(e ho) . ,(if po `(":" ,(e po)) '())) + '()))) + + (apply string-append (append user/passwd host/port)))) + + +;;; HTTP URL parsing +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; The PATH slot of this record is the URL's path split at slashes, +;;; e.g., "foo/bar//baz/" => ("foo" "bar" "" "baz" "") +;;; These elements are in raw, unescaped format. To convert back to +;;; a string, use (uri-path-list->path (map escape-uri pathlist)). + +(define-record http-url + userhost ; Initial //anonymous@clark.lcs.mit.edu:80/ + path ; Rest of path, split at slashes & decoded. + search + frag-id) + +;;; The URI parser (parse-uri in uri.scm) maps a string to four parts: +;;; : ? # , , and +;;; are strings; is a non-empty string list -- the +;;; URI's path split at slashes. Optional parts of the URI, when +;;; missing, are specified as #f. If is "http", then the +;;; other three parts can be passed to PARSE-HTTP-URL, which parses +;;; them into a HTTP-URL record. All strings come back from the URI +;;; parser encoded. SEARCH and FRAG-ID are left that way; this parser +;;; decodes the path elements. +;;; +;;; Returns a HTTP-URL record, if possible. Otherwise +;;; FATAL-SYNTAX-ERROR is called. + +(define (parse-http-url path search frag-id) + (let ((uh (parse-userhost path default-http-userhost))) + (if (or (userhost:user uh) (userhost:password uh)) + (fatal-syntax-error + "HTTP URL's may not specify a user or password field" path)) + + (make-http-url uh (map unescape-uri (cdddr path)) search frag-id))) + + +;;; Default http port is 80. +(define default-http-userhost (make-userhost #f #f #f "80")) + + +;;; Unparse. + +(define (http-url->string url) + (string-append "http://" + (userhost->string (http-url:userhost url)) + "/" + (uri-path-list->path (map escape-uri (http-url:path url))) + (cond ((http-url:search url) => + (lambda (s) (string-append "?" s))) + (else "")) + (cond ((http-url:frag-id url) => + (lambda (fi) (string-append "#" fi))) + (else ""))))