PLaneT Package Repository : Home > neil > web-server-xexp.plt

Home > neil > web-server-xexp.plt > package version 1.0
web-server-xexp.rkt
#lang racket/base
;; Copyright Neil Van Dyke.  See file "info.rkt".

(require (for-syntax racket/base
                     syntax/parse
                     web-server/http/cookie
                     "planet-neil-html-template.rkt"
                     "web-server-xexp-misc.rkt")
         (for-template web-server/http/cookie
                       "web-server-xexp-misc.rkt")
         (planet neil/mcfly)
         web-server/http/cookie
         web-server/http/request-structs
         web-server/http/response-structs
         syntax/parse
         "planet-neil-html-template.rkt"
         ;; TODO: Use submodules to get rid of file "web-server-xexp-misc.rkt"?
         "web-server-xexp-misc.rkt")

(doc (section "Introduction")

     (para "This package makes using "
           (hyperlink "http://www.neilvandyke.org/racket-xexp/"
                      "SXML/xexp")
           " with the Racket Web Server easier.  Currently, this means providing a "
           (racket response/html-template)
           " procedure that can be used like "
           (racket html-template)
           " from the "
           (hyperlink "http://www.neilvandyke.org/racket-html-template/"
                      (tt "html-template"))
           " package, but producing a Racket Web Server "
           (racket response)
           " value.")

     (para "As a quick example, here's the next hot dotcom:")
     
     (RACKETBLOCK
      
      (UNSYNTAX (code "#lang web-server/insta"))
      
      (require (planet neil/web-server-xexp))
      
      (define (start req)
        (response/html-template
         (html (header (title "advice-pin-oogly-book-r.com"))
               (body (h1 "Today's Advice")
                     (p "Don't run with "
                        (% (random-list-element '("scissors"
                                                  "toilet plungers"
                                                  "cheese graters"
                                                  "trays of lasagna"
                                                  "cats"
                                                  "wolves"
                                                  "the bulls")))
                        ".")
                     (p "Like us on Facebook for a chance to win $"
                        (% (+ 100 (random 901)))
                        ".")))))
      
      (define (random-list-element lst)
        (list-ref lst (random (length lst))))))

(doc (section "Interface"))

(define-for-syntax %html-utf-8-mime-type-bytes #"text/html; charset=utf-8")

;; (define-for-syntax %html-preamble-bytes #"<!DOCTYPE html>\n")

(define-for-syntax toplevel-stx #'toplevel)

(define-for-syntax (%do-reverse-lvs reverse-lvs stx)
  (if (null? reverse-lvs)
      stx
      (quasisyntax/loc stx
        (let-values (#,@(reverse reverse-lvs)) #,stx))))

(define-for-syntax (%web-server-xexp:irep->content-length-info irep)
  ;; TODO: !!! Implement this once #:ordering implemented.
  (values #f #t))

;; TODO: Rework response/html-template for html-template:2:0 features.
(doc (defform/subs (response/html-template maybe-code
                                           maybe-message
                                           maybe-seconds
                                           maybe-mime-type
                                           maybe-headers
                                           maybe-cookies
                                           maybe-preamble
                                           content ...)
         ((maybe-code      code:blank (code:line #:code      number?))
          (maybe-message   code:blank (code:line #:message   bytes?))
          (maybe-seconds   code:blank (code:line #:seconds   number?))
          (maybe-mime-type code:blank (code:line #:mime-type (or/c #f bytes?)))
          (maybe-headers   code:blank (code:line #:headers   (listof header?)))
          (maybe-cookies   code:blank (code:line #:cookies   (listof cookie?)))
          (maybe-preamble  code:blank (code:line #:preamble  (or/c bytes? string?))))
       (para "Like "
             (racket html-template)
             " from the "
             (hyperlink "http://www.neilvandyke.org/racket-html-template/"
                        (tt "html-template"))
             " package, but producing a Racket Web Server "
             (racket response)
             " value.")))
(provide response/html-template)
(define-syntax (response/html-template stx)
  (syntax-parse stx
    ((_ (~or (~optional (~seq #:code      CODE))      #:name "#:code option"
             (~optional (~seq #:message   MESSAGE))   #:name "#:message option"
             (~optional (~seq #:seconds   SECONDS))   #:name "#:seconds option"
             (~optional (~seq #:mime-type MIME-TYPE)) #:name "#:mime-type option"
             (~optional (~seq #:headers   HEADERS))   #:name "#:headers option"
             (~optional (~seq #:cookies   COOKIES))   #:name "#:cookies option"
             (~optional (~seq #:preamble  PREAMBLE))  #:name "#:preamble option"
             (~optional (~seq #:ordering  ORDERING:ordering-sc)
                        #:name "#:ordering option"))
        ...
        BODY:xexp-sc ...)
     (let ((code-var-stx (syntax/loc stx code)))
       (with-syntax
           ((CODE      (or (attribute CODE)      #'200))
            (MESSAGE   (or (attribute MESSAGE)   #'#f))
            (SECONDS   (or (attribute SECONDS)   #'(current-seconds)))
            (MIME-TYPE (or (attribute MIME-TYPE) #'#"text/html; charset=utf-8"))
            (PREAMBLE  (or (attribute PREAMBLE)  #'#""))
            (ORDERING  (or (attribute ORDERING)  #'guess)))
         (let*-values
             (((reverse-lvs)
               '())
              ;; Handle #:code and #:message.
              ((message-stx)
               (syntax MESSAGE))
              ((message-e)
               (syntax-e message-stx))
              ((reverse-lvs code-stx message-stx)
               (if message-e
                   ;; MESSAGE is not #f, so this is simple.
                   (values reverse-lvs (syntax CODE) message-stx)
                   ;; MESSAGE is #f, so is CODE a literal?
                   (let* ((code-stx (syntax CODE))
                          (code-e   (syntax-e code-stx)))
                     (if (integer? code-e)
                         ;; CODE is a literal, so get the message statically.
                         (values reverse-lvs
                                 code-stx
                                 (hash-ref %web-server-xexp:http-code-to-message-bytes-hash
                                           code-e
                                           #"Unknown Status Code"))
                         ;; CODE is not a literal, so add CODE to the let, and get message dynamically.
                         (let ((code-var-stx (syntax/loc code-stx
                                               code)))
                           (values (cons (quasisyntax/loc code-stx
                                           ((#,code-var-stx) CODE))
                                         reverse-lvs)
                                   code-var-stx
                                   (quasisyntax/loc code-stx
                                     (hash-ref %web-server-xexp:http-code-to-message-bytes-hash
                                               #,code-var-stx
                                               #"Unknown Status Code"))))))))
              ;; Handle #:headers and #:cookies.
              ((cookie-header-stx)
               (cond ((attribute COOKIES)
                      => (lambda (cookies-stx)
                           (quasisyntax/loc cookies-stx
                             (map cookie->header #,cookies-stx))))
                     (else #f)))
              ((headers-stx)
               (if (attribute HEADERS)
                   (if (attribute COOKIES)
                       (quasisyntax/loc stx
                         (append HEADERS #,cookie-header-stx))
                       (syntax HEADERS))
                   (if cookie-header-stx
                       cookie-header-stx
                       #''())))
              ;; Parse BODY to irep.
              ((irep)
               (parse-html-template 'response/html-template (syntax (BODY ...))))
              ;; Handle #:preamble by prepending it to irep.
              ((preamble-stx)
               (syntax PREAMBLE))
              ((irep)
               (cons `(verbatim ,preamble-stx ,preamble-stx)
                     irep))
              ;; Compress irep.
              ((irep)
               (compress-html-template-irep irep))
              ;;
              ((static-content-length dynamic-writes?)
               (%web-server-xexp:irep->content-length-info irep))
              ((headers-stx)
               (if (and static-content-length (not dynamic-writes?))
                   (quasisyntax/loc stx
                     (cons (make-header #"Content-Length"
                                        #,(datum->syntax toplevel-stx
                                                      (string->bytes/utf-8
                                                       (number->string
                                                        static-content-length))
                                                      stx))
                           #,headers-stx))
                   headers-stx))
              ;;
              )
           (quasisyntax/loc stx
             (response #,code-stx
                       #,message-stx
                       SECONDS
                       MIME-TYPE
                       #,headers-stx
                       (lambda (out)
                         #,(expand-html-template #:error-name  'response/html-template
                                                 #:stx         stx
                                                 #:ordering    (syntax ORDERING.value)
                                                 #:reverse-lvs '()
                                                 #:irep        irep
                                                 #:port-stx    (syntax out)))))))))))
                                
                         
;;               ;; Non-static irep, so expand based on #:ordering.
;;               (let* ((ordering-stx (syntax ORDERING))
;;                      (ordering-e   (syntax-e ordering-stx))
;;                      (ordering-e   (if (eq? 'guess ordering-e)
;;                                        ;; TODO: !!! Use heuristic
;;                                        'evaluation
;;                                        ordering-e)))
;;                 (case ordering-e
;;                   ((any)
;;                    (%do-reverse-let-clauses
;;                     reverse-let-clauses
;;                     (quasisyntax/loc stx
;;                       (response/full #,code-stx
;;                                      #,message-stx
;;                                      SECONDS
;;                                      MIME-TYPE
;;                                      #,headers-stx
;;                                      (list #,@(html-template-irep->bytes-list-stx-list
;;                                                'response/html-template
;;                                                stx
;;                                                irep))))))
;;                   ((evaluation)
;;                    (let loop ((raws                stx-list)
;;                               (dynamic-count       0)
;;                               (reverse-let-clauses reverse-let-clauses)
;;                               (reverse-finals      '()))
;;                      (if (null? raws)
;;                          (%do-reverse-let-clauses
;;                           reverse-let-clauses
;;                           (quasisyntax/loc stx
;;                            
;;                             (response/full #,code-stx
;;                                            #,message-stx
;;                                            SECONDS
;;                                            MIME-TYPE
;;                                            #,headers-stx
;;                                            (list #,@(reverse reverse-finals)))))
;;                          (let* ((raw-stx (car raws))
;;                                 (raw-e   (syntax-e raw-stx)))
;;                            (if (bytes? raw-e)
;;                                (loop (cdr raws)
;;                                      dynamic-count
;;                                      reverse-let-clauses
;;                                      (cons raw-stx reverse-finals))
;;                                (let ((var-stx (quasisyntax/loc raw-stx
;;                                                 #,(string->symbol (format "dynamic-~A" dynamic-count)))))
;;                                  (loop (cdr raws)
;;                                        (+ 1 dynamic-count)
;;                                        (cons (quasisyntax/loc raw-stx
;;                                                (#,var-stx #,raw-stx))
;;                                              reverse-let-clauses)
;;                                        (cons var-stx reverse-finals))))))))
;;                   ((writes-and-evaluation)
;;                    (error 'response/html-template
;;                           "internal error: not yet implemented: #:ordering writes-and-evaluation"))
;;                   (else
;;                    (error 'response/html-template
;;                           "internal error: invalid ordering-e ~S" ordering-e)))))))))))
;;
;; 
;;

(doc (section "Known Issues")

     (itemlist

      (item "Rework "
            (racket response/html-template)
            " to use new features in package version "
            (tt "html-template:2")
            ".")

      (item "Add "
            (racket #:ordering)
            " argument to "
            (racket response/html-template)
            ", probably implemented using more general support in package "
            (tt "html-template")
            ".  Once that's finalized, implement the "
            (tt "Content-length")
            " computation placeholder code.")

      (item "Document more.")
      
      (item "Maybe expose "
            (tt "html-writing")
            " package procedures as well, to reduce version mismatches.")))

(doc history

     (#:planet 1:0 #:date "2013-01-07"
               (itemlist
                (item "Early initial release, since needed by RackOut."))))