Skip to content
This repository

This page captures useful code snippets that are too small to be a Planet package.

Specifying a HMAC-SHA1 stuffer for the stateless web-server
#:stuffer (stuffer-chain
            serialize-stuffer
            (stuffer-compose base64-stuffer
                             (HMAC-SHA1-stuffer #"mysupersecretkey")))
Split a string into lines
(regexp-split "\n+" str)
Fetch the contents of a URL
;; 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)))))
generate a n-byte key for use in MAC authentication (like HMAC-SHA1)
;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)))))
How to generate a Message Authentication Code (MAC) and authenticate a signed message.

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

Redirecting an HTTP-scheme URL to an HTTPS-scheme URL using two servlets (courtesy of Jay McCarthy)
#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)

Parsing libpcap files

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

Directly calling the OpenSSL executable from Racket

This example generates a 1024-bit RSA key in PEM format

Idea courtesy of Neil Van Dyke. Control flow suggested by Neil Van Dyke, Robby Findler and Eli Barzilay.

(parameterize ([current-input-port (open-input-string "")])
  (with-output-to-string (λ _(system* (build-path "c:" "openssl-win32" "bin" "openssl.exe")
                                      "genrsa" 
                                      "1024"))))

More OpenSSL: generating an HMAC-SHA1 digest

;;returns the string "(stdin)= 5df23ffdf57d5d925f150c885d64bee2eaf55a43\n"

(parameterize ([current-input-port (open-input-string "We are Spinal Tap!")])
  (with-output-to-string (λ _ (system* (build-path "c:" "openssl-win32" "bin" "openssl.exe")
                                      "dgst" 
                                      "-sha1"
                                      "-hex"
                                      "-hmac"
                                      #"mysecretkey"))))

OpenSSL on Amazon Linux

When installing Racket on the Amazon Linux AMI, choose the Fedora build. For example use the racket-5.2.1-bin-x86_64-linux-f14.sh installer for Racket 5.2.1 with the 64-bit Amazon Linux AMI.

You may find that openssl module calls give a runtime error. This includes procedures like ssl-connect, and procedures that use it indirectly such as get-pure-port with an https scheme in the URI.

To fix, install the openssl-devel package:

$ sudo yum install openssl-devel

On Error Resume Next using Pattern Matching Macros

Allows us to sequentially execute error-throwing statements without causing control flow to branch

(define-syntax-rule (on-error-resume-next f ...)
   (let ((out #f))
     (with-handlers ([exn:fail? (lambda (exn) (printf "~A\n" (exn-message exn)) (out))])
       (let/cc k (set! out k) f) ...)))


#| usage
(define (my-error val) (error (format "my-error ~A\n" val)))

(on-error-resume-next (my-error 1) (my-error 2) (my-error 3))
;RETURNS
my-error 1

my-error 2

my-error 3

#|

How to generate a rotating key-value, which changes at some arbitrary interval.

Here the daily-key is a simple random number, available at module level. You can plug in a better Artifact from above to create a more useful n-bit key.

The (sync...) function blocks until (alarm-evt...) is ready at next-alarm milliseconds (here arbitrarily set for 3 am). Then daily-key is mutated, and a new (sync...) call blocks until tomorrow at the same time.

secure-key-generation uses the on-errror-resume-next Artifact from above.

(provide daily-key
         start-key-generation
         secure-key-generation)

(define daily-key null)
(define key-thread null)

(define (start-key-generation)
  (unless (thread? key-thread) ;protect against reinitializing key-thread
    (set! daily-key (random 255))
    (set! key-thread (thread (λ _ 
                               (letrec ((next-alarm (λ _ (let* ((milliseconds-per-day (* 24 3600 1000))
                                                                (now (current-date))
                                                                (hour (date-hour now))
                                                                (3am-ms (* 1000 (find-seconds 0 0 3 
                                                                                              (date-day now)
                                                                                              (date-month now)
                                                                                              (date-year now)
                                                                                              #t))))
                                                           (if (hour . < . 3) 
                                                               3am-ms
                                                               (+ 3am-ms milliseconds-per-day)))))
                                        (rfc (λ _ (begin (sync (alarm-evt (next-alarm))) 
                                                         (set! daily-key (random 255))
                                                         (rfc)))))
                                 (rfc)))))))

(define (secure-key-generation)
  (on-error-resume-next
   (kill-thread key-thread)
   (set! key-thread null)
   (set! daily-key null)))

AJAX: How to build a response to an HTTPXmlRequest

Note: the correct MIME-type is important to get the browser to understand what you're sending over in the body of the response.

Client-side convention with respect to setting up client AJAX continuation seems to be to at least check the message-field equal to "OK", so be aware of this.

In addition to this code, You still need to send the reponse back to the client via one of Jay McCarthy's primitives such as send/suspend/dispatch (if stateless), or send/back (if stateful).

#|
USAGE: 
(define res (make-xml-response `(xml "victory!")))
(call-with-output-string (response-output res))
-> "<xml>victory!</xml>"

|#
#lang racket
(require  xml
          web-server/servlet-env
          web-server/http/response-structs
          web-server/http/request-structs)

;; or just use #lang web-server and (require xml), if that's easier for you

(define (make-xml-response  #:code [code 200]
                            #:message [message #"OK"]
                            #:seconds [seconds (current-seconds)]
                            #:mime-type [mime-type #"text/xml charset=utf-8"]
                            #:headers [headers (list (make-header #"Cache-Control" #"no-cache"))]
                            content)
  (response/full code message seconds mime-type headers (list (string->bytes/utf-8 (xexpr->string content)))))

How to Build a Context-Free Grammar with Racket's unique Recursive Contract System

Here's a context-free grammar of a binary tree written using the contract system. A parent node is the first symbol of a list. A child node is a cons'd s-expression in the same list

Its like getting a free goal-seeker for Christmas! [while Racket's recursive contract system can't find substitutions, it can provide answers to existential queries!]

(define tree/c (flat-rec-contract tree
                                  (or/c symbol?
                                        (listof symbol?)
                                        (cons/c symbol? (listof tree)))))

#|
usage 

EXAMPLES: WELL-FORMED TREES

       S1 

(tree/c 'S1) ;-> #t

        S1
        |
       S2

(tree/c '(S1 S2)) ;-> #t

       S1
   ____|____
   |   |   |    
   S2  S3  S4  
     __|__
    |     |
   S3-1  S3-2
  __|__
 |     |
 S3-1-1  S3-1-2   

(tree/c '(S1 S2 (S3 (S3-1 S3-1-1 S3-1-2) S3-2) S4)) ;->#t

COUNTEREXAMPLES: MALFORMED TREES

(tree/c '((a b))) ;#->f

(tree/c '((a b) (c d))) ;#->f


|#

How to transform a Tree (see above) into an x-expression

This converts the beautiful tree notation possible in Racket into the ugly, verbose representation necessary to send hierarchical structures to other computational environments with no respect for beauty, symmetry nor notational elegance.

(require xml)

(define tree/c
  (flat-rec-contract
   tree
   (or/c symbol?
        (listof symbol?)
        (cons/c symbol? (listof tree)))))

(define atom?
  (lambda (x)
    (and (not (pair? x)) (not (null? x)))))

(define/contract (tree->xexpr tree)
  (tree/c . -> . xexpr/c)
  (letrec ((parent-proc (λ (subtree)
                          (cond
                            [(atom? (car subtree)) `(div ((id ,(symbol->string (car subtree)))) ,@(child-proc (cdr subtree)))])))
           (child-proc (λ (subtree)
                          (cond 
                            [(null? subtree) '("")]
                            [(symbol? (car subtree)) (cons `(div ((id ,(symbol->string (car subtree)))) "")  (child-proc (cdr subtree)))]
                            [(cons? (car subtree)) (cons (parent-proc (car subtree)) (child-proc (cdr subtree)))]))))
      (parent-proc tree)))

#|
USAGE
(display (xexpr->string 
          (tree->xexpr '(S1 S2 (S3 (S3-1 S3-1-1 S3-1-2) S3-2) S4))))

RETURNS 

<div id="S1">
     <div id="S2"></div>
     <div id="S3">
        <div id="S3-1">
             <div id="S3-1-1"></div>
             <div id="S3-1-2"></div>
        </div>
        <div id="S3-2"> </div>
     </div>
     <div id="S4"></div>
</div>

|#


Web Server: Creating an Interface Definition Language (IDL) between an HTTP-request and Racket code, Part I

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

Cookies and the Web Server

Two quick notes:

1) You can pass base64 encoded values to the browser as cookie-values as long as you strip both out the embedded and trailing carriage-return-line-feed sequences.

BAD:

(define (start request)
  (response/xexpr `(html (head (meta ((name "viewport")(content "initial-scale=1.0, user-scalable=no")))
                               (meta ((http-equiv "content-type")(content "text/html; charset=UTF-8"))))
                                       (body (div "Cookies!")))
                  #:headers  (list (make-header #"Set-Cookie" #"Racketboy=XetM5o+My2BQYizra/y+NC7UJ0MxMjM0\r\nNTY2OQ==\r\n; Secure;"))))

GOOD:

...code...
#:headers  (list (make-header #"Set-Cookie" #"Racketboy=XetM5o+My2BQYizra/y+NC7UJ0MxMjM0NTY2OQ==; Secure;"))
...code...

2) The Secure flag in the cookie only instructs the browser not to send the cookie over a non-secure connection. The server will happily pass a Secure-flag cookie over a non-secure connection.

To prevent the a Secure-flag cookie from being sent over a non secure connection, set the #:ssl keyword argument to #t in serve/servlet.

AJAX and the Web Server

I wanted to present an absolute minimal implementation of Jay's Web Server that demonstrates how to set up AJAX functionality.

It doesn't do very much, but you can use as an AJAX test bed. I used this particular code to test whether setting browser cookies via AJAX works.

#lang web-server

(require  web-server/servlet-env
          xml
          web-server/http/xexpr)

(define my-xml-response
  (response/xexpr `(xml "victory!")
                  #:mime-type #"text/xml charset=utf-8"
                  #:headers (list (make-header #"Set-Cookie" #"name=mikey"))))

(define (start request)
  (letrec ((response-generator (λ (make-url)
                                 (response/xexpr `(html (head 
                                                         (script ((type "text/javascript")) ,(format StartXMLHttpRequest (make-url receive-ajax-signal)))
                                                         (script ((type "text/javascript")) ,processChange)
                                                         )
                                                        (body (div ((onclick "alert('things are working');"))  "Hello jay")
                                                                     (div ((onclick "StartXMLHttpRequest('some data');"))  "click for AJAX-type Request")
                                                                     (a ((href ,(make-url receive-signal)))"click for browser-window-type Request"))))))
           (receive-ajax-signal   (λ (request)
                                    my-xml-response))
           (receive-signal (λ (request)
                              (send/suspend/dispatch response-generator))))
    (send/suspend/dispatch response-generator)))


(define StartXMLHttpRequest (string-append "function StartXMLHttpRequest(post_data){ "
                                           "obj = new XMLHttpRequest(); "
                                           "obj.onreadystatechange = processChange;"
                                           "obj.open('POST','~A',false); "
                                           "obj.setRequestHeader('Content-Type','application/x-www-form-urlencoded'); "
                                           "obj.send(post_data); "
                                           "processChange();"
                                            "} "))


(define processChange "function processChange(){alert('in processChange!');}")


(serve/servlet start
               #:stateless? #t        
               #:launch-browser? #t
               #:connection-close? #t
               #:quit? #f 
               #:listen-ip #f 
               #:port 8000
               #:servlet-path "/")

Generating a GUID using the Win32 API

Demonstrates use of the Foreign Function Interface (FFI) to create a Globally Unique ID

#lang racket

#|
creates a GUID using the Win32API via the foreign function interface

usage:
(new-GUID) ; ->"3849203981-8836-19662-12178292003955076235"

;returns a max(43) length string, which we can store in database
and set a UNIQUE constraint to make sure same order isn't entered twice.
|#

(require  ffi/unsafe)

(provide new-GUID)

(define ole32 (ffi-lib "ole32.dll"))

(ffi-lib? ole32)

(define-cstruct _GUID ([Data1 _uint32]    ;32 bytes, max 10 char when converted to string
                       [Data2 _uint16]    ;16 bytes, max 5 char when converted to string
                       [Data3 _uint16]    ;16 bytes, max 5 chars when converted to string 
                       [Data4 _uint64]))   ;simulates 8x8 char array for 64 bytes total, max 20 chars when converted to string       

(define generate-GUID  (get-ffi-obj "CoCreateGuid" ole32 (_fun  _GUID-pointer -> _uint32)))

(define (new-GUID)
  (let* ((x (make-GUID 0 0 0 0)) ;note make-GUID returns a pointer to a _GUID structure
        (res (generate-GUID x)))
    (if (= res 0)
        (string-append 
         (number->string (GUID-Data1 x)) "-"
         (number->string (GUID-Data2 x)) "-"
         (number->string (GUID-Data3 x)) "-"
         (number->string (GUID-Data4 x)))
        (error "Unable to generate GUID"))))


Sending a file to the Windows Print Spool using the Win32 API

Uses the on-error-resume-next macro from above in the postlude. Also uses an anaphoric lambda (aλ) macro which I haven't posted yet. Can just substitute a letrec form if the a-lambda is confusing.

#lang racket\base

(require ffi/unsafe
         racket/function
         racket/path)

(define kernel (ffi-lib "kernel32.dll"))
(define winspool (ffi-lib "winspool.drv"))

(define-cstruct _DOC_INFO_1  ([pDocName _string/utf-16 ]
                              [pOutputFile _string/utf-16] 
                              [pDatatype _string/utf-16]))

;just return h, if its zero, then assume an error has occured
(define open-printer (get-ffi-obj "OpenPrinterW" winspool (_fun   _string/utf-16 (h : (_ptr o _uint32)) _pointer -> (r : _uint32) -> h)));(values h r))))
(define get-last-error (get-ffi-obj "GetLastError" kernel (_fun -> _uint32)))
(define start-doc-printer (get-ffi-obj "StartDocPrinterW" winspool (_fun _uint32 _uint32 _DOC_INFO_1-pointer -> _uint32)))
(define start-page-printer (get-ffi-obj "StartPagePrinter" winspool (_fun _uint32 -> _uint32)))
(define write-printer (get-ffi-obj "WritePrinter" winspool (_fun _uint32 _pointer  _uint32 (read : (_ptr o _uint32)) -> (r : _uint32) -> (values read r))))
(define end-page-printer (get-ffi-obj "EndPagePrinter" winspool (_fun _uint32 -> _uint32)))
(define end-doc-printer (get-ffi-obj "EndDocPrinter" winspool (_fun _uint32 -> _uint32)))
(define close-printer (get-ffi-obj "ClosePrinter" winspool (_fun _uint32 -> _uint32)))


;usage (spool-file (build-path  "C:\\temp.doc") "printername")
(define (spool-file pth szprinter)
  (let ((hprn 0))
    (dynamic-wind
     (λ _ void)
     (λ _ (define buf-size #x4000)
       (set! hprn (ON-FAIL  (open-printer szprinter #f) (format "spool-file; unable to open printer ~A" szprinter)))
       (let ((di (make-DOC_INFO_1  (string-append "Box-lunch:" (path->string (file-name-from-path pth))) #f "RAW")))
         (ON-FAIL  (start-doc-printer hprn 1 di) "spool-file: failed to start document")
         (ON-FAIL  (start-page-printer hprn) "spool-file: failed to start page")
         (let ([buffer (make-bytes buf-size (char->integer #\_))])
           (with-input-from-file pth
             (λ _ 
               ((aλ (bytes-read)
                    (unless (eof-object? bytes-read)
                      (let-values ([(written retval) (write-printer hprn buffer  bytes-read)])
                        (ON-FAIL retval "spool-file: failed to write to printer"))
                      (self (read-bytes! buffer))))
                (read-bytes! buffer)))
             #:mode 'binary))
         ))
     (λ _ (on-error-resume-next (end-page-printer hprn)
                                (end-doc-printer hprn)
                                (close-printer hprn))))))



;raises an error if id isn't a positive integer. Zero is typically returned for a win32 error
(define/contract (ON-FAIL id msg)
    (-> any/c string? exact-positive-integer?)
    (unless (exact-positive-integer? id)
        (raise (exn:fail msg (current-continuation-marks))))
    id)

Something went wrong with that request. Please try again.