;;; Time-stamp: <06/06/11 20:24:26 noel>
;;; Copyright (C) by Noel Welsh.

;;; This library is free software; you can redistribute it
;;; and/or modify it under the terms of the GNU Lesser
;;; General Public License as published by the Free Software
;;; Foundation; either version 2.1 of the License, or (at
;;; your option) any later version.

;;; This library is distributed in the hope that it will be
;;; useful, but WITHOUT ANY WARRANTY; without even the
;;; implied warranty of MERCHANTABILITY or FITNESS FOR A
;;; PARTICULAR PURPOSE.  See the GNU Lesser General Public
;;; License for more details.

;;; You should have received a copy of the GNU Lesser
;;; General Public License along with this library; if not,
;;; write to the Free Software Foundation, Inc., 59 Temple
;;; Place, Suite 330, Boston, MA 02111-1307 USA

;;; Author: Noel Welsh <>
;; Commentary:
(module idcheck-util mzscheme

  (require (lib "")
           (lib "" "web-server")
           (lib "" "xml")
           (file "")
           (file ""))

  (provide idcheck-cookie-domain
           (struct status (major-version minor-version code reason))
  ;; idcheck-cookie-domain : (parameter string)
  ;; This is the "domain" attribute set on IDCheck cookies. It must be
  ;; a partial domain name, starting with a full stop. For example:
  ;;     ""
  ;; The parameter must be set to a common suffix of the domain name
  ;; of the local web server and the IDCheck server. For example:
  ;;     IDCheck server:    ""
  ;;     Web server:        ""
  ;;     Parameter setting: ""
  ;; This parameter must be set before the library is used.
  (define idcheck-cookie-domain (make-parameter #f))
  ;; get-idcheck-cookie-domain : -> string
  ;; Retrieves the current value of the idcheck-cookie-domain parameter,
  ;; and checks to make sure the parameter has been set.
  (define (get-idcheck-cookie-domain)
    (let ([cookie-domain (idcheck-cookie-domain)])
      (if cookie-domain
The idcheck-cookie-domain parameter has not been set.
Initialize the parameter with a call to parameterize as follows:

     (parameterize ([idcheck-cookie-domain ""])
       ; Insert code here...

  ;; preregistration-key? : string -> string
  (define (preregistration-key? key)
    (if (regexp-match #rx"R[0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9]" key)

  ;; registered-key? : string -> string
  (define (registered-key? key)
    (if (regexp-match #rx"[0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9]" key)

  ;; headers-cookies : headers -> string
  (define (headers-cookies headers)
    (let ([cookies (assoc-value/default 'cookie headers #"")])
      (if (bytes? cookies)
          (bytes->string/utf-8 cookies)

  ;; headers-keys : headers -> (values (U string #f) (U string #f))
  (define (headers-keys headers)
    (let* ((cookies (headers-cookies headers))
            (get-cookie/single "idcheck.request" cookies))
           (reg-key (get-cookie/single "idcheck" cookies)))
      (values prereg-key reg-key)))

  ;; headers-registered-key : headers -> (U string #f)
  (define (headers-registered-key headers)
    (let-values (((prereg-key reg-key) (headers-keys headers)))

  ;; headers-preregistered-key : headers -> (U string #f)
  (define (headers-preregistered-key headers)
    (let-values (((prereg-key reg-key) (headers-keys headers)))

  ;; unregistered? : headers -> (U #t #f)
  ;; True if the user has not registered with IDCheck
  (define (unregistered? headers)
    (let-values (((prereg reg) (headers-keys headers)))
      (and (or (not prereg) (preregistration-key? prereg))
           (not reg))))

  ;; unvalidated? : headers -> (U #t #f)
  ;; True if the user has registered with IDCheck, but has
  ;; not been validated
  (define (unvalidated? headers)
    (let-values (((prereg reg) (headers-keys headers)))
      (and prereg (registered-key? prereg) (not reg))))

  ;; validated? : headers -> (U #t #f)
  ;; True if the user has been validated with IDCheck
  (define (validated? headers)
    (let-values (((prereg reg) (headers-keys headers)))
      (and (not prereg) reg)))

  ;; Copied from http-client

  ;; Regexp to extract information from an HTTP status line
  ;; Stolen from Neil Van Dyke's HTTPer package
  (define status-regexp
    (regexp "^HTTP/([0-9]+)\\.([0-9]+) +([1-5][0-9][0-9]) +(.*)"))

  ;; successful? : status -> (U #t #f)
  (define (successful? status)
    (let ((code (status-code status)))
      (and (>= code 200) (<= code 299))))

  ;; struct status: Number Number Number String
  (define-struct status
    (major-version minor-version code reason) (make-inspector))

  ;; parse-status : string -> status
  (define (parse-status string)
    (match (regexp-match status-regexp string)
           [(list whole major minor status reason)
             (string->number major)
             (string->number minor)
             (string->number status)
           [_ (raise-exn:idcheck
               (format "Invalid status line: ~a" string))]))

  ;; my-redirect-to : string (alist-of symbol string) -> response
  ;; redirect-to in the servlets library doesn't accept
  ;; headers, so we duplicate here
  (define (my-redirect-to url headers)
     "Moved temporarily"
     `((location . ,url)
       `(html (head
               (meta ((http-equiv "refresh") (url ,url)))
               (title "Redirect to " ,url))
               (p "Redirecting to " (a ([href ,url]) ,url))))))))

  ;; Name of the cookie used to communicate with the IDCheck
  ;; server
  (define idcheck-cookie-name "idcheck.request")

  ;; Name of the cookie visible only to us, used to store
  ;; the IDCheck key
  (define private-cookie-name "idcheck")

  ;; set-idcheck-cookie : string -> cookie
  (define (set-idcheck-cookie value)
       (set-cookie idcheck-cookie-name value)
      (+ (current-seconds) 480))
  ;; clear-idcheck-cookie : () -> cookie
  (define (clear-idcheck-cookie)
       (set-cookie idcheck-cookie-name "null")

  ;; set-private-cookie : string -> cookie
  (define (set-private-cookie value)
     (set-cookie private-cookie-name value)

  ;; clear-private-cookie : () -> cookie
  (define (clear-private-cookie)
      (set-cookie private-cookie-name "null")