diff --git a/scheme/ftpd/ftpd.scm b/scheme/ftpd/ftpd.scm index a6e489d..07c4fcd 100644 --- a/scheme/ftpd/ftpd.scm +++ b/scheme/ftpd/ftpd.scm @@ -893,9 +893,9 @@ (string->number (match:substring match match-index))) '(1 2 3 4 5 6)))) - (if (any? (lambda (component) - (> component 255)) - components) + (if (any (lambda (component) + (> component 255)) + components) (begin (log (syslog-level debug) "rejecting PORT-command because of invalid arguments (port-component > 255) (501)") @@ -1012,7 +1012,7 @@ (let ((args (split-arguments arg))) (call-with-values (lambda () - (partition-list + (partition (lambda (arg) (and (not (string=? "" arg)) (char=? #\- (string-ref arg 0)))) diff --git a/scheme/httpd/access-control.scm b/scheme/httpd/access-control.scm index 860db47..014d80b 100644 --- a/scheme/httpd/access-control.scm +++ b/scheme/httpd/access-control.scm @@ -12,16 +12,16 @@ (define (access-denier . hosts) (lambda (info) - (and (any? (lambda (host) - (host-matches? info host)) - hosts) + (and (any (lambda (host) + (host-matches? info host)) + hosts) 'deny))) (define (access-allower . hosts) (lambda (info) - (and (any? (lambda (host) + (and (any (lambda (host) (host-matches? info host)) - hosts) + hosts) 'allow))) (define (access-controller . controls) @@ -49,23 +49,23 @@ (cond ((list? host) (let ((len (length host))) - (any? (lambda (address) - (equal? (take len (address->list address)) host)) - (host-info:addresses info)))) + (any (lambda (address) + (equal? (take len (address->list address)) host)) + (host-info:addresses info)))) (else ; (string? host) - (any? (lambda (name) - (string-match host (string-map char-downcase name))) - (cons (host-info:name info) - (host-info:aliases info)))))) + (any (lambda (name) + (string-match host (string-map char-downcase name))) + (cons (host-info:name info) + (host-info:aliases info)))))) (define normalize-host (let ((split (infix-splitter (make-regexp "\\."))) (number (make-regexp "[0-9]+"))) (lambda (host) (let ((components (split host))) - (if (every? (lambda (component) - (regexp-exec number component)) - components) + (if (every (lambda (component) + (regexp-exec number component)) + components) (map string->number components) host))))) diff --git a/scheme/httpd/info-gateway.scm b/scheme/httpd/info-gateway.scm index f28c9ab..ccf2785 100644 --- a/scheme/httpd/info-gateway.scm +++ b/scheme/httpd/info-gateway.scm @@ -179,7 +179,7 @@ (define (search-field regexp) (cond - ((any (lambda (field) + ((find (lambda (field) (string-match regexp (car field))) fields) => cadr) diff --git a/scheme/httpd/logging.scm b/scheme/httpd/logging.scm index 003edd4..62421f1 100644 --- a/scheme/httpd/logging.scm +++ b/scheme/httpd/logging.scm @@ -9,12 +9,29 @@ ;;; the distribution. (define do-nothing-proc (lambda a #f)) -(define-record logging - (http-log-port #f) ;port to perform CLF-logging - (http-log-proc do-nothing-proc) ;proc to run for CLF-logging (req status-code) - (http-syslog? #f) ;do syslogging? - (http-syslog-proc do-nothing-proc) ;proc to run for syslog (level fmt . args) - (dns-lookup? #f)) ;perform dns-lookups? + +(define-record-type logging :logging + (really-make-logging log-port log-proc + syslog? syslog-proc + dns-lookup?) + logging? + ;; port to perform CLF-logging + (log-port logging-log-port set-logging-log-port!) + ;; proc to run for CLF-logging (req status-code) + (log-proc logging-log-proc set-logging-log-proc!) + ;; do syslogging? + (syslog? logging-syslog? set-logging-syslog?!) + ;; proc to run for syslog (level fmt . args) + (syslog-proc logging-syslog-proc set-logging-syslog-proc!) + ;; perform dns lookups? + (dns-lookup? logging-dns-lookup? set-logging-dns-lookup?!)) + +(define (make-logging) + (really-make-logging #f + do-nothing-proc + #f + do-nothing-proc + #f)) (define logging (make-preserved-thread-fluid #f)) @@ -25,17 +42,17 @@ (lambda (value) (setter (thread-fluid logging) value))) -(define logging-http-log-proc (make-fluid-selector logging:http-log-proc)) -(define logging-http-syslog-proc (make-fluid-selector logging:http-syslog-proc)) -(define logging-http-syslog? (make-fluid-selector logging:http-syslog?)) -(define logging-http-log-port (make-fluid-selector logging:http-log-port)) -(define logging-dns-lookup? (make-fluid-selector logging:dns-lookup?)) +(define logging-http-log-proc (make-fluid-selector logging-log-proc)) +(define logging-http-syslog-proc (make-fluid-selector logging-syslog-proc)) +(define logging-http-syslog? (make-fluid-selector logging-syslog?)) +(define logging-http-log-port (make-fluid-selector logging-log-port)) +(define logging-dns-lookup? (make-fluid-selector logging-dns-lookup?)) -(define set-logging-http-log-proc (make-fluid-setter set-logging:http-log-proc)) -(define set-logging-http-syslog-proc (make-fluid-setter set-logging:http-syslog-proc)) -(define set-logging-http-syslog? (make-fluid-setter set-logging:http-syslog?)) -(define set-logging-http-log-port (make-fluid-setter set-logging:http-log-port)) -(define set-logging-dns-lookup? (make-fluid-setter set-logging:dns-lookup?)) +(define set-logging-http-log-proc (make-fluid-setter set-logging-log-proc!)) +(define set-logging-http-syslog-proc (make-fluid-setter set-logging-syslog-proc!)) +(define set-logging-http-syslog? (make-fluid-setter set-logging-syslog?!)) +(define set-logging-http-log-port (make-fluid-setter set-logging-log-port!)) +(define set-logging-dns-lookup? (make-fluid-setter set-logging-dns-lookup?!)) (define http-syslog (lambda a diff --git a/scheme/httpd/response.scm b/scheme/httpd/response.scm index 6172673..7ad6c1f 100644 --- a/scheme/httpd/response.scm +++ b/scheme/httpd/response.scm @@ -5,7 +5,7 @@ ;;; For copyright information, see the file COPYING which comes with ;;; the distribution. -(define-record-type :http-response +(define-record-type http-response :http-response (make-response code message seconds mime extras body) response? (code response-code) @@ -15,21 +15,20 @@ (extras response-extras) (body response-body)) -(define-record-type :http-writer-body +(define-record-type http-writer-body :http-writer-body (make-writer-body proc) writer-body? (proc writer-body-proc)) -(define-record-type :http-reader-writer-body +(define-record-type http-reader-writer-body :http-reader-writer-body (make-reader-writer-body proc) reader-writer-body? (proc reader-writer-body-proc)) -(define-record-type :http-redirect-body +(define-record-type http-redirect-body :http-redirect-body (make-redirect-body location) redirect-body? (location redirect-body-location)) - (define (display-http-body body iport oport options) (cond diff --git a/scheme/packages.scm b/scheme/packages.scm index b5b3cad..9d5758d 100644 --- a/scheme/packages.scm +++ b/scheme/packages.scm @@ -366,7 +366,7 @@ rooted-file-or-directory-handler)) (define-interface httpd-seval-handlers-interface - (export httpd-seval-handler)) + (export seval-handler)) (define-interface httpd-info-gateway-interface (export info-handler @@ -404,17 +404,15 @@ (define-structure parse-html-forms parse-html-forms-interface (open scheme-with-scsh - scsh-utilities let-opt - srfi-13 + (subset srfi-13 (string-index string-map)) receiving uri) (files (lib parse-forms))) (define-structure htmlout htmlout-interface (open scheme-with-scsh - scsh-utilities - srfi-13 + (subset srfi-13 (string-fold)) formats ascii receiving) @@ -436,9 +434,8 @@ (define-structure rfc822 rfc822-interface (open scheme-with-scsh receiving ; MV return (RECEIVE and VALUES) - scsh-utilities ; index - srfi-13 - srfi-1 ; fold + (subset srfi-13 (string-map string-index string-join)) + (subset srfi-1 (fold)) let-opt ; let-optionals crlf-io ; read-crlf-line ascii ; ascii->char @@ -448,22 +445,19 @@ (define-structure uri uri-interface (open scheme-with-scsh - srfi-13 + (subset srfi-13 (string-index string-index-right string-fold string-join)) let-opt receiving ascii - srfi-14 bitwise field-reader-package) (files (lib uri))) (define-structure url url-interface (open scheme-with-scsh - scsh-utilities define-record-types receiving - srfi-13 - srfi-14 + (subset srfi-13 (string-index)) uri httpd-error) (files (lib url))) @@ -477,7 +471,7 @@ conditions signals error-package - srfi-13 + (subset srfi-13 (string-join)) let-opt sunet-utilities crlf-io) @@ -526,7 +520,7 @@ handle conditions signals - srfi-13 + (subset srfi-13 (string-index)) let-opt crlf-io) (files (lib pop3))) @@ -600,7 +594,8 @@ (define-structure ls ls-interface (open scheme-with-scsh handle - big-scheme bitwise + (subset srfi-1 (filter)) + bitwise fluids crlf-io) (files (lib ls))) @@ -615,7 +610,7 @@ format-net sigevents let-opt - srfi-13 + (subset srfi-13 (string-join)) dns let-opt ; :optional locks @@ -637,14 +632,14 @@ fluids thread-fluids locks (subset srfi-13 (string-map string-trim-both string-index)) - (subset big-util (any? partition-list)) + (subset srfi-1 (any partition)) crlf-io ls dns sunet-version sunet-utilities - receiving ; RECEIVE - format-net) ; pretty print of internet-addresses + receiving + format-net) (files (ftpd ftpd))) ;; Web server @@ -652,18 +647,16 @@ (define-structure httpd-core httpd-core-interface (open scheme-with-scsh thread-fluids ; fork-thread - receiving ; receive + receiving crlf-io ; write-crlf, read-crlf-line rfc822 ; read-rfc822-headers - srfi-14 ; char-set-complement, char-set:whitespace handle ; ignore-errors conditions ; condition-stuff uri url - formats ; format - format-net ; format-internet-host-address + format-net rate-limit ; rate-limiting stuff - srfi-13 ; STRING-INDEX + (subset srfi-13 (string-index)) dns ; dns-lookup-ip sunet-utilities ; socket-address->string locks ; make-lock et al. @@ -679,7 +672,7 @@ httpd-responses sunet-version - srfi-1) ; find + ) (files (httpd core))) (define-structures ((httpd-make-options httpd-make-options-interface) @@ -690,11 +683,11 @@ (define-structure httpd-access-control httpd-access-control-interface (open scheme-with-scsh - big-scheme + (subset srfi-1 (any every)) httpd-responses httpd-requests httpd-error - srfi-13 ; STRING-MAP + (subset srfi-13 (string-map)) ) (files (httpd access-control))) @@ -706,19 +699,19 @@ (open scheme-with-scsh httpd-read-options i/o ; make-null-output-port - locks ; make-lock obtain-lock release-lock - receiving ; receive + locks + receiving uri ; uri-path-list->path url ; http-url-path httpd-requests ; request record - formats ; format + formats format-net ; format-internet-host-address - srfi-13 ; string-join, string-trim + (subset srfi-13 (string-join string-trim)) rfc822 ; get-header sunet-utilities ; on-interrupt threads ; spawn dns ; dns-lookup-ip - defrec-package ; define-record + define-record-types thread-fluids ; make-preserved-fluid et al. handle-fatal-error ) @@ -733,7 +726,7 @@ (open scheme (subset scsh (format-date write-string time date)) syslog - srfi-9 + define-record-types defenum-package formats httpd-requests @@ -745,8 +738,8 @@ (open scheme-with-scsh rfc822 httpd-requests ; REQUEST record type, v0.9-request - srfi-1 ; FOLD-RIGHT - srfi-13 ; STRING-TRIM + (subset srfi-1 (fold-right)) + (subset srfi-13 (string-trim)) httpd-responses ) (files (httpd handlers))) @@ -762,7 +755,7 @@ url htmlout crlf-io - srfi-13 ; STRING-JOIN + (subset srfi-13 (string-join)) sunet-utilities ; dotdot-check, copy-inport->outport conditions handle-fatal-error @@ -777,9 +770,9 @@ httpd-logging ; http-log uri ; UNESCAPE-URI htmlout ; Formatted HTML output - error-package ; ERROR - pp ; Pretty-printer - srfi-13 ; STRING-SKIP + error-package ; ERROR #### + pp + (subset srfi-13 (string-skip)) rfc822 toothless-eval ; EVAL-SAFELY handle ; IGNORE-ERROR @@ -790,8 +783,8 @@ (define-structure httpd-info-gateway httpd-info-gateway-interface (open scheme-with-scsh - big-scheme - srfi-13 + (subset srfi-1 (find)) + (subset srfi-13 (string-map string-skip string-index)) conditions signals handle htmlout httpd-requests @@ -815,12 +808,13 @@ handle-fatal-error let-opt sunet-utilities - srfi-13) + (subset srfi-13 (string-join)) + ) (files (httpd rman-gateway))) (define-structure httpd-cgi-handlers httpd-cgi-handlers-interface (open scheme-with-scsh - srfi-13 + (subset srfi-13 (string-prefix? string-index string-trim substring/shared)) rfc822 crlf-io ; WRITE-CRLF uri @@ -832,9 +826,8 @@ httpd-error ; HTTP-ERROR httpd-file-directory-handlers ; dot-dot-check, copy-inport->outport sunet-version - scsh-utilities ; INDEX - formats ; format - format-net ; FORMAT-INTERNET-HOST-ADDRESS + formats + format-net sunet-utilities ; host-name-or-empty let-opt ; let-optionals handle-fatal-error