Artifacts: Web
This page captures useful code snippets that are too small to be a package.
There is also an GitHub organisation for larger examples https://github.com/racket-artifacts
Please contribute your own!
#lang racket
;; Code from Why I Like PLT Scheme by Jacob Matthews
;; http://www.kuro5hin.org/story/2004/3/17/93442/8657
;; archived as https://web.archive.org/web/20050205000754/http://www.kuro5hin.org/story/2004/3/17/93442/8657
;; minor changes to port to Racket 7.1
(module+ test
(require rackunit))
; scan : string[hostname] (listof int) -> listof (list int string)
; gives the number and well-known service name of each port in the given
; list that is open on the given host
(define (scan host ports)
(map
(lambda (p) (list p (port->name p)))
(open-ports host ports)))
(define (range low high)
(cond
[(> low high) null]
[else (cons low (range (+ low 1) high))]))
(require racket/contract)
(provide/contract
(scan (string? (listof natural-number/c)
. -> .
(listof (list/c natural-number/c string?)))))
;(require (lib "list.ss")) ; for filter
; open-ports : string[hostname] (listof int) -> (listof int)
; returns the sublist of numbers that represent open ports on the
; given host, performing all checks concurrently
(define (open-ports host ports)
(filter (lambda (x) (not (eq? 'closed x)))
(threaded-map
(lambda (port) (if (can-connect? host port) port 'closed))
ports)))
; can-connect? : string[hostname] number -> bool
; determines if the host is listening on the given port
(define (can-connect? host port)
(with-handlers ([exn:fail:network? (lambda (e) #f)])
(let-values ([(ip op) (tcp-connect host port)])
(close-input-port ip) (close-output-port op) #t)))
; threaded-map : (X -> Y) * (listof X) -> (listof Y)
; maps the given function over the given list with each computation
; done in parallel
(define (threaded-map f l)
(let ((cs (map (lambda (x) (make-channel)) l)))
(for-each (lambda (x c) (thread (lambda () (channel-put c (f x))))) l cs)
(map channel-get cs)))
(require net/url) ; for get-pure-port and string->url
(define NAMES
(let ([ip (if (file-exists? "/etc/services")
(open-input-file "/etc/services")
(get-pure-port (string->url "http://www.iana.org/assignments/port-numbers")))]
[nametable (make-hash)])
(while m (regexp-match #px"([^ \n]+)[\\W]+([0-9]+)/tcp[ \t]+([^\r\n])" ip)
(hash-set! nametable (string->number (bytes->string/utf-8 (list-ref m 2))) (list-ref m 1)))
nametable))
(define (port->name p) (hash-ref! NAMES p (lambda () "unknown")))
(define-syntax (while stx)
(syntax-case stx ()
[(_ var test body)
(identifier? #'var)
#'(let loop ((var test))
(when var body (loop test)))]))
(module+ test
;; Any code in this `test` submodule runs when this file is run using DrRacket
;; or with `raco test`. The code here does not run when this file is
;; required by another module.
(scan "www.lnwh.nhs.uk" (range 1 100))
)
(module+ main
;; (Optional) main submodule. Put code here if you need it to be executed when
;; this file is run using DrRacket or the `racket` executable. The code here
;; does not run when this file is required by another module. Documentation:
;; http://docs.racket-lang.org/guide/Module_Syntax.html#%28part._main-and-test%29
)
;; Get a URL's entity, being sure to close the port.
(require net/url)
(call/input-url (string->url "http://www.google.com")
get-pure-port
port->string)
;; Get a URL's headers and entity, being sure to close the port.
(require net/url)
(define-values (headers entity)
(call/input-url (string->url "http://www.google.com")
get-impure-port
(lambda (in)
(values (purify-port in)
(port->string in)))))#lang web-server
(require web-server/servlet-env)
(define (secure-start request)
(response/xexpr "Hello SSL-encrypted world"))
;redirect to https:
(define (insecure-start request)
(display "in redirect\n")
(redirect-to
(url->string
(struct-copy url (request-uri request)
[scheme "https"]
[host "www.mydomain.com"]
[port 8001]))))
;;secure servlet on port 8001, with server-authentication via x.509
(define secure-servlet
(thread
(λ ()
(serve/servlet secure-start
#:stateless? #t
#:launch-browser? #f
#:connection-close? #t
#:quit? #f
#:listen-ip #f
#:port 8001
#:ssl? #t
#:ssl-cert (build-path "my-domain-cert.crt")
#:ssl-key (build-path "my-private-key.key")
#:servlet-path "/"))))
;; inesecure servlet on port 8000
(define insecure-servlet
(thread
(λ ()
(serve/servlet
insecure-start
#:stateless? #t
#:launch-browser? #f
#:connection-close? #t
#:quit? #f
#:listen-ip #f
#:port 8000
#:servlet-path "/"
))))
(thread-wait insecure-servlet)
(thread-wait secure-servlet)Discussion: an HTTP request contains name/value bindings passed as byte-strings.
Maybe.
Sad, Tragic and Unfortunate Outcome space:
1) Bindings your Racket code expects could be missing.
2) optional bindings might be present or absent
3) The underlying values might not be interpretable as the value types you expect (just when you expect an integer, the binding-value is "frobnitzzz")
4) The actual values passed might be outside the domain (i.e. allowable values) the Racket code works on
We want to catch these problems using the contract system before we create a server error. We use functional composition to create make-idl, which will take four arguments:
Recall that in composition, the first function to execute is the rightmost argument, with its return value(s) being passed to the function-argument on its left
So reading (make-idl....) from right to left:
binding-name: the name of the binding we expect in the HTTP request
optionality-fn: one of two functions. either required-arg, or optional-arg. required-arg will throw an error if the binding is missing or malformed. optional-arg allows missing bindings to pass
transform-fn will transform the byte-string to some primitive type (number, boolean, etc.) or throw an error trying and
contract-fn, which is the actual domain-enforcing racket-contract we want to assert before we send the argument to the server
(make-idl...) returns a single function which operates on the HTTP request-bindings, and either returns a value which honors the description we memorialized in the four arguments, or throws an error
Usage and the missing helper functions will be discussed in Part II.
(require (prefix-in HTTP: web-server/http/request-structs))
(define/contract (make-idl contract-fn
transform-fn
optionality-fn
binding-name)
(-> contract? (-> any/c any/c) (-> any/c any/c) bytes? (-> (listof HTTP:binding?) any/c))
(compose (λ (x) (if (not (contract-fn x))
(raise (exn:fail (format "IDL layer error: binding contract error\n" ) (current-continuation-marks)))
x))
(λ (x) (if (not (transform-fn x))
(raise (exn:fail (format "IDL layer error: binding transformation error\n" ) (current-continuation-marks)))
(transform-fn x)))
optionality-fn
(λ (bindings) (HTTP:bindings-assq binding-name bindings))))
#:stuffer (stuffer-chain
serialize-stuffer
(stuffer-compose base64-stuffer
(HMAC-SHA1-stuffer #"mysupersecretkey")));usage (generate-authenticator-key 32) -> returns 256-bit key
(define/contract (generate-authenticator-key key-len)
(-> exact-positive-integer? bytes?)
(list->bytes (build-list key-len (λ _ (random 255)))))This would be useful for creating the "Unforgeable Authenticator Cookie", discussed in section 4.1 of the MIT Cookie Eater's recommendations (see: "Do's And Don'ts of Client Authentication on the Web", Fu et al)
Note: Uses generate-authenticator-key from the preceding Artifact.
(require web-server/stuffers/hmac-sha1)
;use 128-bit key
(define *private-key* (generate-authenticator-key 16))
(define *signed-message* (let* ((plaintext #"We are Spinal Tap!")
(MAC (HMAC-SHA1 plaintext *private-key*)))
(bytes-append MAC plaintext)))
;;now we lose custody of *signed-message* by sending it to the client...
;;and now we get *signed-message* back and attempt to authenticate it
(let ((received-MAC (subbytes *signed-message* 0 20))
(received-plaintext (subbytes *signed-message* 20)))
(if (bytes=? received-MAC
(HMAC-SHA1 received-plaintext
*private-key*))
"Message is authentic and not forged"
"Message has been forged"))
This is a quick hack for parsing libpcap files (the standard format used by packet-capturing programs, e.g. wireshark) into packets. (John Clements)
(define (file->packets file)
(define pcap-bytes (file->bytes file))
(define global-header (subbytes pcap-bytes 0 (* 6 4)))
(define packets
(let loop ([offset 24])
(cond [(< offset (bytes-length pcap-bytes))
(define pcaprec-header (subbytes pcap-bytes
offset
(+ offset 16)))
(define captured-len (integer-bytes->integer pcaprec-header
#f #f
8 12))
(define packet-len (integer-bytes->integer pcaprec-header
#f #f
12 16))
(when (not (= captured-len packet-len))
(fprintf (current-error-port)
"warning: captured only ~v bytes of packet with ~v bytes\n"
captured-len packet-len))
(printf "packet len: ~v\n" captured-len)
(cons
(list pcaprec-header
(subbytes pcap-bytes (+ offset 16)
(+ offset 16 captured-len)))
(loop (+ offset 16 captured-len)))]
[else empty]))))