suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Removing dependency on servlet-helpers

Browse Source 
svn: r6404
This commit is contained in:
Jay McCarthy 2007-05-30 15:27:18 +00:00
parent ce4c6fac38
commit b5fcacf8e4
6 changed files with 48 additions and 47 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
collects/web-server/dispatchers/dispatch-files.ss
View File

@ -7,13 +7,11 @@
(lib "plt-match.ss")
(lib "contract.ss")
(lib "uri-codec.ss" "net"))
(require (lib "pretty.ss"))
(require "dispatch.ss"
"../private/configuration.ss"
"../private/util.ss"
"../private/mime-types.ss"
"../private/request.ss"
"../private/servlet-helpers.ss"
"../request-structs.ss"
"../private/response.ss"
"../response-structs.ss")
(provide/contract

3
collects/web-server/dispatchers/dispatch-log.ss
View File

@ -6,8 +6,7 @@
(lib "plt-match.ss")
(lib "contract.ss"))
(require "dispatch.ss"
"../request-structs.ss"
"../private/servlet-helpers.ss")
"../request-structs.ss")
(provide/contract
[interface-version dispatcher-interface-version?])
(provide ; XXX contract kw

3
collects/web-server/dispatchers/dispatch-passwords.ss
View File

@ -4,7 +4,8 @@
(require "dispatch.ss"
"../private/util.ss"
"../private/configuration.ss"
"../private/servlet-helpers.ss"
"../request-structs.ss"
"../private/basic-auth.ss"
"../private/connection-manager.ss"
"../private/response.ss")
(provide/contract

35
collects/web-server/private/basic-auth.ss Normal file
View File

@ -0,0 +1,35 @@
(module basic-auth mzscheme
(require (lib "contract.ss")
(lib "plt-match.ss")
(lib "base64.ss" "net"))
(require "../request-structs.ss")
; Authentication
; extract-user-pass : (listof (cons sym bytes)) -> (or/c #f (cons str str))
;; Notes (GregP)
;; 1. This is Basic Authentication (RFC 1945 SECTION 11.1)
;; e.g. an authorization header will look like this:
;; Authorization: Basic QWxhZGRpbjpvcGVuIHNlc2FtZQ==
;; 2. Headers should be read as bytes and then translated to unicode as appropriate.
;; 3. The Authorization header should have bytes (i.e. (cdr pass-pair) is bytes
(define (extract-user-pass headers)
(match (headers-assq* #"Authorization" headers)
[#f #f]
[(struct header (_ basic-credentials))
(cond
[(and (basic? basic-credentials)
(regexp-match #rx"([^:]*):(.*)"
(base64-decode (subbytes basic-credentials 6 (bytes-length basic-credentials)))))
=> (lambda (user-pass)
(cons (cadr user-pass) (caddr user-pass)))]
[else #f])]))
;; basic?: bytes -> (or/c (listof bytes) #f)
;; does the second part of the authorization header start with #"Basic "
(define basic?
(let ([rx (byte-regexp #"^Basic .*")])
(lambda (a) (regexp-match rx a))))
(provide/contract
; XXX contract maybe
[extract-user-pass ((listof header?) . -> . (or/c false/c (cons/c bytes? bytes?)))]))

35
collects/web-server/private/servlet-helpers.ss
View File

@ -2,13 +2,14 @@
(require (lib "contract.ss")
(lib "kw.ss")
(lib "plt-match.ss")
(lib "base64.ss" "net")
(lib "uri-codec.ss" "net"))
(require "util.ss"
"bindings.ss"
"basic-auth.ss"
"../request-structs.ss"
"../response-structs.ss")
(provide (all-from "bindings.ss")
(all-from "basic-auth.ss")
(all-from "../response-structs.ss")
(all-from "../request-structs.ss"))
@ -58,43 +59,11 @@
(pre ,(exn->string exn)))))))])
(thunk)))
; Authentication
(define AUTHENTICATION-REGEXP (regexp "([^:]*):(.*)"))
(define (match-authentication x) (regexp-match AUTHENTICATION-REGEXP x))
;:(define match-authentication (type: (str -> (or/c false (list str str str)))))
; extract-user-pass : (listof (cons sym bytes)) -> (or/c #f (cons str str))
;; Notes (GregP)
;; 1. This is Basic Authentication (RFC 1945 SECTION 11.1)
;; e.g. an authorization header will look like this:
;; Authorization: Basic QWxhZGRpbjpvcGVuIHNlc2FtZQ==
;; 2. Headers should be read as bytes and then translated to unicode as appropriate.
;; 3. The Authorization header should have bytes (i.e. (cdr pass-pair) is bytes
(define (extract-user-pass headers)
(match (headers-assq* #"Authorization" headers)
[#f #f]
[(struct header (_ basic-credentials))
(cond
[(and (basic? basic-credentials)
(match-authentication
(base64-decode (subbytes basic-credentials 6 (bytes-length basic-credentials)))))
=> (lambda (user-pass)
(cons (cadr user-pass) (caddr user-pass)))]
[else #f])]))
;; basic?: bytes -> (or/c (listof bytes) #f)
;; does the second part of the authorization header start with #"Basic "
(define basic?
(let ([rx (byte-regexp #"^Basic .*")])
(lambda (a) (regexp-match rx a))))
(provide ; all-from
with-errors-to-browser
redirect-to
(rename uri-decode translate-escapes))
(provide/contract
; XXX contract maybe
[extract-user-pass ((listof header?) . -> . (or/c false/c (cons/c bytes? bytes?)))]
[permanently redirection-status?]
[temporarily redirection-status?]
[see-other redirection-status?]

15
collects/web-server/servlet.ss
View File

@ -8,6 +8,11 @@
"private/servlet-helpers.ss"
"private/web-cells.ss"
"servlet-structs.ss")
(require "private/servlet-url.ss")
(provide (all-from "private/web-cells.ss")
(all-from "private/servlet-helpers.ss")
(all-from "private/servlet-url.ss")
(all-from "servlet-structs.ss"))
;; ************************************************************
;; HELPERS
@ -39,13 +44,7 @@
[send/forward ((response-generator?) (expiration-handler?) . opt-> . request?)]
[send/suspend/dispatch ((embed/url? . -> . servlet-response?) . -> . any/c)]
[send/suspend/callback (xexpr/callback? . -> . any/c)])
(require "private/servlet-url.ss")
(provide (all-from "private/web-cells.ss")
(all-from "private/servlet-helpers.ss")
(all-from "private/servlet-url.ss")
(all-from "servlet-structs.ss"))
;; ************************************************************
;; EXPORTS
@ -141,4 +140,4 @@
; redirect/get : -> request
(define redirect/get (make-redirect/get send/suspend))
(define redirect/get/forget (make-redirect/get send/forward)))
(define redirect/get/forget (make-redirect/get send/forward)))