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

8
scheme/ftpd/ftpd.scm
View File

@ -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))))

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

@ -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)))))

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

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

49
scheme/httpd/logging.scm
View File

@ -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

9
scheme/httpd/response.scm
View File

@ -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,22 +15,21 @@
(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
((writer-body? body)

87
scheme/packages.scm
View File

@ -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