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

Streamline structure declarations 

- remove some more uses of Olin records
- remove uses of BIG-SCHEME/BIG-UTIL
- subset all uses of SRFI 1, 13, 14
This commit is contained in:
sperber 2003-01-07 12:16:33 +00:00
parent ed85e7619e
commit 186e9de56c
6 changed files with 97 additions and 88 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
scheme/ftpd/ftpd.scm
View File

@ -893,7 +893,7 @@
(string->number (string->number
(match:substring match match-index))) (match:substring match match-index)))
'(1 2 3 4 5 6)))) '(1 2 3 4 5 6))))
(if (any? (lambda (component) (if (any (lambda (component)
(> component 255)) (> component 255))
components) components)
(begin (begin
@ -1012,7 +1012,7 @@
(let ((args (split-arguments arg))) (let ((args (split-arguments arg)))
(call-with-values (call-with-values
(lambda () (lambda ()
(partition-list (partition
(lambda (arg) (lambda (arg)
(and (not (string=? "" arg)) (and (not (string=? "" arg))
(char=? #\- (string-ref arg 0)))) (char=? #\- (string-ref arg 0))))

10
scheme/httpd/access-control.scm
View File

@ -12,14 +12,14 @@
(define (access-denier . hosts) (define (access-denier . hosts)
(lambda (info) (lambda (info)
(and (any? (lambda (host) (and (any (lambda (host)
(host-matches? info host)) (host-matches? info host))
hosts) hosts)
'deny))) 'deny)))
(define (access-allower . hosts) (define (access-allower . hosts)
(lambda (info) (lambda (info)
(and (any? (lambda (host) (and (any (lambda (host)
(host-matches? info host)) (host-matches? info host))
hosts) hosts)
'allow))) 'allow)))
@ -49,11 +49,11 @@
(cond (cond
((list? host) ((list? host)
(let ((len (length host))) (let ((len (length host)))
(any? (lambda (address) (any (lambda (address)
(equal? (take len (address->list address)) host)) (equal? (take len (address->list address)) host))
(host-info:addresses info)))) (host-info:addresses info))))
(else ; (string? host) (else ; (string? host)
(any? (lambda (name) (any (lambda (name)
(string-match host (string-map char-downcase name))) (string-match host (string-map char-downcase name)))
(cons (host-info:name info) (cons (host-info:name info)
(host-info:aliases info)))))) (host-info:aliases info))))))
@ -63,7 +63,7 @@
(number (make-regexp "[0-9]+"))) (number (make-regexp "[0-9]+")))
(lambda (host) (lambda (host)
(let ((components (split host))) (let ((components (split host)))
(if (every? (lambda (component) (if (every (lambda (component)
(regexp-exec number component)) (regexp-exec number component))
components) components)
(map string->number components) (map string->number components)

2
scheme/httpd/info-gateway.scm
View File

@ -179,7 +179,7 @@
(define (search-field regexp) (define (search-field regexp)
(cond (cond
((any (lambda (field) ((find (lambda (field)
(string-match regexp (car field))) (string-match regexp (car field)))
fields) fields)
=> cadr) => cadr)

49
scheme/httpd/logging.scm
View File

@ -9,12 +9,29 @@
;;; the distribution. ;;; the distribution.
(define do-nothing-proc (lambda a #f)) (define do-nothing-proc (lambda a #f))
(define-record logging
(http-log-port #f) ;port to perform CLF-logging (define-record-type logging :logging
(http-log-proc do-nothing-proc) ;proc to run for CLF-logging (req status-code) (really-make-logging log-port log-proc
(http-syslog? #f) ;do syslogging? syslog? syslog-proc
(http-syslog-proc do-nothing-proc) ;proc to run for syslog (level fmt . args) dns-lookup?)
(dns-lookup? #f)) ;perform dns-lookups? 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)) (define logging (make-preserved-thread-fluid #f))
@ -25,17 +42,17 @@
(lambda (value) (lambda (value)
(setter (thread-fluid logging) value))) (setter (thread-fluid logging) value)))
(define logging-http-log-proc (make-fluid-selector logging:http-log-proc)) (define logging-http-log-proc (make-fluid-selector logging-log-proc))
(define logging-http-syslog-proc (make-fluid-selector logging:http-syslog-proc)) (define logging-http-syslog-proc (make-fluid-selector logging-syslog-proc))
(define logging-http-syslog? (make-fluid-selector logging:http-syslog?)) (define logging-http-syslog? (make-fluid-selector logging-syslog?))
(define logging-http-log-port (make-fluid-selector logging:http-log-port)) (define logging-http-log-port (make-fluid-selector logging-log-port))
(define logging-dns-lookup? (make-fluid-selector logging:dns-lookup?)) (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-log-proc (make-fluid-setter set-logging-log-proc!))
(define set-logging-http-syslog-proc (make-fluid-setter set-logging:http-syslog-proc)) (define set-logging-http-syslog-proc (make-fluid-setter set-logging-syslog-proc!))
(define set-logging-http-syslog? (make-fluid-setter set-logging:http-syslog?)) (define set-logging-http-syslog? (make-fluid-setter set-logging-syslog?!))
(define set-logging-http-log-port (make-fluid-setter set-logging:http-log-port)) (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 set-logging-dns-lookup? (make-fluid-setter set-logging-dns-lookup?!))
(define http-syslog (define http-syslog
(lambda a (lambda a

9
scheme/httpd/response.scm
View File

@ -5,7 +5,7 @@
;;; For copyright information, see the file COPYING which comes with ;;; For copyright information, see the file COPYING which comes with
;;; the distribution. ;;; the distribution.
(define-record-type :http-response (define-record-type http-response :http-response
(make-response code message seconds mime extras body) (make-response code message seconds mime extras body)
response? response?
(code response-code) (code response-code)
@ -15,22 +15,21 @@
(extras response-extras) (extras response-extras)
(body response-body)) (body response-body))
(define-record-type :http-writer-body (define-record-type http-writer-body :http-writer-body
(make-writer-body proc) (make-writer-body proc)
writer-body? writer-body?
(proc writer-body-proc)) (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) (make-reader-writer-body proc)
reader-writer-body? reader-writer-body?
(proc reader-writer-body-proc)) (proc reader-writer-body-proc))
(define-record-type :http-redirect-body (define-record-type http-redirect-body :http-redirect-body
(make-redirect-body location) (make-redirect-body location)
redirect-body? redirect-body?
(location redirect-body-location)) (location redirect-body-location))
(define (display-http-body body iport oport options) (define (display-http-body body iport oport options)
(cond (cond
((writer-body? body) ((writer-body? body)

87
scheme/packages.scm
View File

@ -366,7 +366,7 @@
rooted-file-or-directory-handler)) rooted-file-or-directory-handler))
(define-interface httpd-seval-handlers-interface (define-interface httpd-seval-handlers-interface
(export httpd-seval-handler)) (export seval-handler))
(define-interface httpd-info-gateway-interface (define-interface httpd-info-gateway-interface
(export info-handler (export info-handler
@ -404,17 +404,15 @@
(define-structure parse-html-forms parse-html-forms-interface (define-structure parse-html-forms parse-html-forms-interface
(open scheme-with-scsh (open scheme-with-scsh
scsh-utilities
let-opt let-opt
srfi-13 (subset srfi-13 (string-index string-map))
receiving receiving
uri) uri)
(files (lib parse-forms))) (files (lib parse-forms)))
(define-structure htmlout htmlout-interface (define-structure htmlout htmlout-interface
(open scheme-with-scsh (open scheme-with-scsh
scsh-utilities (subset srfi-13 (string-fold))
srfi-13
formats formats
ascii ascii
receiving) receiving)
@ -436,9 +434,8 @@
(define-structure rfc822 rfc822-interface (define-structure rfc822 rfc822-interface
(open scheme-with-scsh (open scheme-with-scsh
receiving ; MV return (RECEIVE and VALUES) receiving ; MV return (RECEIVE and VALUES)
scsh-utilities ; index (subset srfi-13 (string-map string-index string-join))
srfi-13 (subset srfi-1 (fold))
srfi-1 ; fold
let-opt ; let-optionals let-opt ; let-optionals
crlf-io ; read-crlf-line crlf-io ; read-crlf-line
ascii ; ascii->char ascii ; ascii->char
@ -448,22 +445,19 @@
(define-structure uri uri-interface (define-structure uri uri-interface
(open scheme-with-scsh (open scheme-with-scsh
srfi-13 (subset srfi-13 (string-index string-index-right string-fold string-join))
let-opt let-opt
receiving receiving
ascii ascii
srfi-14
bitwise bitwise
field-reader-package) field-reader-package)
(files (lib uri))) (files (lib uri)))
(define-structure url url-interface (define-structure url url-interface
(open scheme-with-scsh (open scheme-with-scsh
scsh-utilities
define-record-types define-record-types
receiving receiving
srfi-13 (subset srfi-13 (string-index))
srfi-14
uri uri
httpd-error) httpd-error)
(files (lib url))) (files (lib url)))
@ -477,7 +471,7 @@
conditions conditions
signals signals
error-package error-package
srfi-13 (subset srfi-13 (string-join))
let-opt let-opt
sunet-utilities sunet-utilities
crlf-io) crlf-io)
@ -526,7 +520,7 @@
handle handle
conditions conditions
signals signals
srfi-13 (subset srfi-13 (string-index))
let-opt let-opt
crlf-io) crlf-io)
(files (lib pop3))) (files (lib pop3)))
@ -600,7 +594,8 @@
(define-structure ls ls-interface (define-structure ls ls-interface
(open scheme-with-scsh (open scheme-with-scsh
handle handle
big-scheme bitwise (subset srfi-1 (filter))
bitwise
fluids fluids
crlf-io) crlf-io)
(files (lib ls))) (files (lib ls)))
@ -615,7 +610,7 @@
format-net format-net
sigevents sigevents
let-opt let-opt
srfi-13 (subset srfi-13 (string-join))
dns dns
let-opt ; :optional let-opt ; :optional
locks locks
@ -637,14 +632,14 @@
fluids thread-fluids fluids thread-fluids
locks locks
(subset srfi-13 (string-map string-trim-both string-index)) (subset srfi-13 (string-map string-trim-both string-index))
(subset big-util (any? partition-list)) (subset srfi-1 (any partition))
crlf-io crlf-io
ls ls
dns dns
sunet-version sunet-version
sunet-utilities sunet-utilities
receiving ; RECEIVE receiving
format-net) ; pretty print of internet-addresses format-net)
(files (ftpd ftpd))) (files (ftpd ftpd)))
;; Web server ;; Web server
@ -652,18 +647,16 @@
(define-structure httpd-core httpd-core-interface (define-structure httpd-core httpd-core-interface
(open scheme-with-scsh (open scheme-with-scsh
thread-fluids ; fork-thread thread-fluids ; fork-thread
receiving ; receive receiving
crlf-io ; write-crlf, read-crlf-line crlf-io ; write-crlf, read-crlf-line
rfc822 ; read-rfc822-headers rfc822 ; read-rfc822-headers
srfi-14 ; char-set-complement, char-set:whitespace
handle ; ignore-errors handle ; ignore-errors
conditions ; condition-stuff conditions ; condition-stuff
uri uri
url url
formats ; format format-net
format-net ; format-internet-host-address
rate-limit ; rate-limiting stuff rate-limit ; rate-limiting stuff
srfi-13 ; STRING-INDEX (subset srfi-13 (string-index))
dns ; dns-lookup-ip dns ; dns-lookup-ip
sunet-utilities ; socket-address->string sunet-utilities ; socket-address->string
locks ; make-lock et al. locks ; make-lock et al.
@ -679,7 +672,7 @@
httpd-responses httpd-responses
sunet-version sunet-version
srfi-1) ; find )
(files (httpd core))) (files (httpd core)))
(define-structures ((httpd-make-options httpd-make-options-interface) (define-structures ((httpd-make-options httpd-make-options-interface)
@ -690,11 +683,11 @@
(define-structure httpd-access-control httpd-access-control-interface (define-structure httpd-access-control httpd-access-control-interface
(open scheme-with-scsh (open scheme-with-scsh
big-scheme (subset srfi-1 (any every))
httpd-responses httpd-responses
httpd-requests httpd-requests
httpd-error httpd-error
srfi-13 ; STRING-MAP (subset srfi-13 (string-map))
) )
(files (httpd access-control))) (files (httpd access-control)))
@ -706,19 +699,19 @@
(open scheme-with-scsh (open scheme-with-scsh
httpd-read-options httpd-read-options
i/o ; make-null-output-port i/o ; make-null-output-port
locks ; make-lock obtain-lock release-lock locks
receiving ; receive receiving
uri ; uri-path-list->path uri ; uri-path-list->path
url ; http-url-path url ; http-url-path
httpd-requests ; request record httpd-requests ; request record
formats ; format formats
format-net ; format-internet-host-address format-net ; format-internet-host-address
srfi-13 ; string-join, string-trim (subset srfi-13 (string-join string-trim))
rfc822 ; get-header rfc822 ; get-header
sunet-utilities ; on-interrupt sunet-utilities ; on-interrupt
threads ; spawn threads ; spawn
dns ; dns-lookup-ip dns ; dns-lookup-ip
defrec-package ; define-record define-record-types
thread-fluids ; make-preserved-fluid et al. thread-fluids ; make-preserved-fluid et al.
handle-fatal-error handle-fatal-error
) )
@ -733,7 +726,7 @@
(open scheme (open scheme
(subset scsh (format-date write-string time date)) (subset scsh (format-date write-string time date))
syslog syslog
srfi-9 define-record-types
defenum-package defenum-package
formats formats
httpd-requests httpd-requests
@ -745,8 +738,8 @@
(open scheme-with-scsh (open scheme-with-scsh
rfc822 rfc822
httpd-requests ; REQUEST record type, v0.9-request httpd-requests ; REQUEST record type, v0.9-request
srfi-1 ; FOLD-RIGHT (subset srfi-1 (fold-right))
srfi-13 ; STRING-TRIM (subset srfi-13 (string-trim))
httpd-responses httpd-responses
) )
(files (httpd handlers))) (files (httpd handlers)))
@ -762,7 +755,7 @@
url url
htmlout htmlout
crlf-io crlf-io
srfi-13 ; STRING-JOIN (subset srfi-13 (string-join))
sunet-utilities ; dotdot-check, copy-inport->outport sunet-utilities ; dotdot-check, copy-inport->outport
conditions conditions
handle-fatal-error handle-fatal-error
@ -777,9 +770,9 @@
httpd-logging ; http-log httpd-logging ; http-log
uri ; UNESCAPE-URI uri ; UNESCAPE-URI
htmlout ; Formatted HTML output htmlout ; Formatted HTML output
error-package ; ERROR error-package ; ERROR ####
pp ; Pretty-printer pp
srfi-13 ; STRING-SKIP (subset srfi-13 (string-skip))
rfc822 rfc822
toothless-eval ; EVAL-SAFELY toothless-eval ; EVAL-SAFELY
handle ; IGNORE-ERROR handle ; IGNORE-ERROR
@ -790,8 +783,8 @@
(define-structure httpd-info-gateway httpd-info-gateway-interface (define-structure httpd-info-gateway httpd-info-gateway-interface
(open scheme-with-scsh (open scheme-with-scsh
big-scheme (subset srfi-1 (find))
srfi-13 (subset srfi-13 (string-map string-skip string-index))
conditions signals handle conditions signals handle
htmlout htmlout
httpd-requests httpd-requests
@ -815,12 +808,13 @@
handle-fatal-error handle-fatal-error
let-opt let-opt
sunet-utilities sunet-utilities
srfi-13) (subset srfi-13 (string-join))
)
(files (httpd rman-gateway))) (files (httpd rman-gateway)))
(define-structure httpd-cgi-handlers httpd-cgi-handlers-interface (define-structure httpd-cgi-handlers httpd-cgi-handlers-interface
(open scheme-with-scsh (open scheme-with-scsh
srfi-13 (subset srfi-13 (string-prefix? string-index string-trim substring/shared))
rfc822 rfc822
crlf-io ; WRITE-CRLF crlf-io ; WRITE-CRLF
uri uri
@ -832,9 +826,8 @@
httpd-error ; HTTP-ERROR httpd-error ; HTTP-ERROR
httpd-file-directory-handlers ; dot-dot-check, copy-inport->outport httpd-file-directory-handlers ; dot-dot-check, copy-inport->outport
sunet-version sunet-version
scsh-utilities ; INDEX formats
formats ; format format-net
format-net ; FORMAT-INTERNET-HOST-ADDRESS
sunet-utilities ; host-name-or-empty sunet-utilities ; host-name-or-empty
let-opt ; let-optionals let-opt ; let-optionals
handle-fatal-error handle-fatal-error