yppdb.ss
(module yppdb mzscheme
  (require (lib "unitsig.ss")
           (lib "servlet-sig.ss" "web-server")
           (lib "url.ss" "net")
           (lib "servlet.ss" "web-server")
           (lib "class.ss")
           (lib "list.ss"))
  (require "yppdb-util.ss"
           (prefix sql-oo: (planet "sql-oo.ss" ("jaymccarthy" "sql-oo.plt" 1)))
           (prefix sql-oo:paper: "sql-oo-paper.ss"))
  (provide interface-version timeout generate-start)
  
  (define interface-version 'v1)
  (define timeout (* 60 60 24 5))
  (define db:moc% (sql-oo:apply-units sql-oo:sql-oo%
                                      sql-oo:paper:paper@))
  
  ; Per-session params
  (define FILTERS `())
  (define BASE-URL "/servlet/not-yppdb.ss")
  (define db:moc #f)
  
  ; Main template
  (define (template . body)
    `(html (head (title "Your Personal Paper Database")
                 (style ([type "text/css"])
                        "div#banner { text-align: center; }
                         div#header { text-align: center; }
                         div#header ul li {
                         	padding-left: 10px;
                         	padding-right: 10px;
                         	display: inline;
                         }
                         div#search {
                         	text-align: center;
                         	float: right;
                         	width: 20%;
                         }
                         div#filter {
                         	float: right;
                         	clear: right;
                         	width: 24%;
                         }
                         div#body {
                         	float: left;
                         	width: 74%;
                         }
                         div#body a {
                         	text-decoration: none;
                         } 
                         div#body a:hover {
                         	text-decoration: underline;
                         }
                         div#footer {
                         	float: right;
                          	clear: right;
                         	width: 100%;
                         }
                         a {
                         	color: blue;
                         }
                         a.k-url:visited {
                         	color: blue;
                         }
                         span.unread {
                         	font-style: italic;
                         }"))
           (body 
            (div ([id "banner"])
                 (h2 "Your Personal Paper Database"))
            (div ([id "header"])
                 (div ([id "search"])
                      (form ([method "POST"]
                             [action ,(lambda (request)
                                        (let ([the-bindings (request-bindings request)])
                                          (with-binding the-bindings (field-name value)
                                                        (list-papers (sql-oo:paper:papers/search db:moc field-name value)))))])
                            (select ([name "field-name"])
                                    ,@(map
                                       (lambda (f)
                                         `(option ([value ,(car f)]) ,(cadr f)))
                                       `( ("author" "Author")
                                          ("title" "Title")
                                          ("year" "Year")
                                          ("notes" "Notes") )))
                            nbsp
                            (input ([type "text"] [name "value"] [size "10"] [value ""]))
                            (br)
                            (input ([type "submit"] [value "Search"]))))
                 
                 (ul
                  (li (a ([class "k-url"]
                          [href ,BASE-URL]) "Home"))
                  (li (a ([class "k-url"]
                          [href ,(lambda (request)
                                   (list-papers/filters))])
                         "List"))
                  (li (a ([class "k-url"]
                          [href ,(lambda (request)
                                   (edit-paper #f))])
                         "Add"))
                  (li (a ([class "k-url"]
                          [href ,(string-append "javascript:location.href='"
                                                BASE-URL 
                                                "?bookmarklet=addPaper"
                                                "&title='+encodeURIComponent(document.title)+'"
                                                "&url='+encodeURIComponent(location.href)+'"
                                                "'"
                                                )])
                         "Post to YPPDB") " (Bookmarklet)")))
            (div ([id "filter"])
                 (ul
                  (li (a ([class "k-url"]
                          [href ,(lambda (request)
                                   (fluid-let ([FILTERS `()])
                                     (list-papers/filters)))])
                         "Clear All Filters")))
                 (ul                                 
                  ,@(map
                     (lambda (category)
                       (if (member category FILTERS)
                           `(li (strong (a ([class "k-url"]
                                            [href ,(lambda (request)
                                                     (fluid-let ([FILTERS (filter (lambda (c) (not (eq? category c))) FILTERS)])
                                                       (list-papers/filters)))])
                                           ,(symbol->string category))))
                           `(li (a ([class "k-url"]
                                    [href ,(lambda (request)
                                             (fluid-let ([FILTERS (append FILTERS (list category))])
                                               (list-papers/filters)))])
                                   ,(symbol->string category)))))
                     (sql-oo:paper:category-list db:moc))))
            (div ([id "body"])
                 ,@body)
            (div ([id "footer"])
                 (p ([align "right"])
                    "Powered by " (a ([href "http://www.plt-scheme.org/"])
                                     (img ([width "53"] [height "19"] [src "/Defaults/documentation/plt-logo.gif"]))) 
                    (br)
                    (font ([size "2"]) "For more information on PLT Software, please follow the icon link."))))))
  
  ; Sub-pages
  (define (list-papers paper-list)
    (send/suspend/callback
     (template
      `(ul
        ,@(map
           (lambda (paper)
             (let ([paper-line (string-append (send paper title) " (" (send paper year) ") - " (send paper author))])
               `(li (a ([href ,(send paper url)])
                       (span ([class ,(if (send paper read) "read" "unread")]) ,paper-line))
                    nbsp
                    (a ([class "k-url"]
                        [href ,(lambda (request)
                                 (edit-paper paper))]) "#"))))
           paper-list)))))
  (define (list-papers/filters)
    (list-papers (sql-oo:paper:papers/categories db:moc FILTERS)))
  
  ; If the-paper is #f then we are creating a new paper entry
  (define (edit-paper/apply the-paper return-to-edit? request)
    (let ([the-bindings (request-bindings request)])
      (with-bindings/defaults the-bindings 
                              (read) ((title "") (author "") (year "") (url "") (categories "()") (notes "")) ()
                              (let ([paper (if the-paper 
                                               the-paper 
                                               (send db:moc object url "object_paper"))])                       
                                (send* paper 
                                  (title! title) (author! author) (year! year) 
                                  (url! url) (categories! categories) (read! read)
                                  (notes! notes))
                                (if return-to-edit?
                                    (edit-paper paper)
                                    (list-papers/filters))))))
  (define (edit-paper the-paper)
    (let ([title (if the-paper (send the-paper title) "")]
          [author (if the-paper (send the-paper author) "")]
          [year (if the-paper (send the-paper year) "")]
          [categories (if the-paper (send the-paper categories) "")]
          [url (if the-paper (send the-paper url) "")]
          [read (if the-paper (send the-paper read) #f)]
          [notes (if the-paper (send the-paper notes) "")])
      (send/suspend/callback
       (template
        `(form ([method "POST"]
                [action ,(lambda (request)
                           (edit-paper/apply the-paper #f request))])
               (table
                (tr (td "Title:") (td (input ([type "text"] [size "83"] [name "title"] [value ,title]))))
                (tr (td "Author:") (td (input ([type "text"] [size "83"] [name "author"] [value ,author]))))
                (tr (td "Year:") (td (input ([type "text"] [name "year"] [value ,year]))))
                (tr (td "Categories:") (td (input ([type "text"] [size "83"] [name "categories"]
                                                                 [value ,categories]))))
                (tr (td "URL:") (td (input ([type "text"] [size "83"] [name "url"] [value ,url]))))
                (tr (td "Read?") (td (input ([type "checkbox"] [name "read"] 
                                                               ,@(if read 
                                                                     `([checked "true"])
                                                                     `())))))
                (tr (td ([valign "top"]) "Notes:") (td (textarea ([rows "24"] [cols "80"] [name "notes"]) ,notes)))
                (tr (td ([colspan "2"] [align "right"]) 
                        (input ([type "submit"] [value ,(if the-paper
                                                            "Save" 
                                                            "Add")]))))))))))
  
  ; Module-based servlets need to provide a start function
  ; Rather than hard code a DB, we have the user pass it in
  ; Furthermore, we only want to have one db open for the whole serverlet (rather than once per session)
  ; Note: A fluid-let can't be used on the outside because db:moc would be set!'d back to #f when the lambda was returned
  (define (generate-start path-to-db)
    (let ([the-db:moc (new db:moc% (db-path path-to-db))])
      (lambda (initial-request)
        ; Set some params
        (report-errors-to-browser send/back)
        (let ([url-compost (base-url initial-request)]
              [bindings (request-bindings initial-request)])
          (fluid-let ([db:moc the-db:moc]
                      ; We care about what our URL is for generating urls
                      [BASE-URL (string-append "http://"
                                               (bytes->string/utf-8 (cdr (assoc 'host (request-headers initial-request))))
                                               (car url-compost))])
            ; Provide support for the add bookmarklet
            (if (and (exists-binding? 'bookmarklet bindings)
                     (equal? (extract-binding/single 'bookmarklet bindings) "addPaper"))
                (edit-paper/apply #f #t initial-request)
                (list-papers/filters))))))))