(module servlet mzscheme
(require (lib "servlet.ss" "web-server")
(lib "plt-match.ss")
(lib "list.ss")
(lib "etc.ss")
(prefix srfi:19: (lib "19.ss" "srfi")))
(require (planet "date.ss" ("jaymccarthy" "mmss.plt" 1))
(planet "list.ss" ("jaymccarthy" "mmss.plt" 1))
(planet "maybe.ss" ("jaymccarthy" "mmss.plt" 1))
(planet "javascript.ss" ("jaymccarthy" "javascript.plt" 1))
(planet "fortunedb.ss" ("jaymccarthy" "fortunedb.plt" 1))
(planet "url-param.ss" ("jaymccarthy" "url-param.plt" 1))
(planet "secure.ss" ("jaymccarthy" "url-param.plt" 1)))
(require "database.ss")
(provide interface-version timeout generate-start
instance-expiration-handler)
(define current-user (make-web-cell:local (make-nothing)))
(define current-user-key (box #f))
(bind-secure-url-parameter current-user 'user
identity identity
(lambda () (unbox current-user-key)))
(define current-fortunedb (make-parameter fortunedb:empty))
(define current-db (box database-empty))
(define db-lock (make-semaphore 1))
(define db-locks (make-hash-table 'equal))
(define db-locks-lock (make-semaphore 1))
(define current-db-path (box #f))
(define (update-entry! user new-entry)
(define user-lock
(call-with-semaphore
db-locks-lock
(lambda ()
(hash-table-get db-locks user
(lambda ()
(define new-lock (make-semaphore 1))
(hash-table-put! db-locks user new-lock)
new-lock)))))
(call-with-semaphore
user-lock
(lambda ()
(entry-write new-entry (build-path (unbox current-db-path) user))
(call-with-semaphore
db-lock
(lambda ()
(set-box! current-db
(database-insert user new-entry (unbox current-db))))))))
(define (current-entry)
(match (web-cell:local-ref current-user)
[(struct just (user))
(just-value (database-lookup user (unbox current-db)))]))
(define (update-current-entry! new-entry)
(match (web-cell:local-ref current-user)
[(struct just (user))
(update-entry! user new-entry)]))
(define interface-version 'v2-transitional)
(define timeout (* 60 15))
(define instance-expiration-handler
(make-instance-expiration-handler
(lambda (failed-request)
(redirect-to (servlet-url->url-string/no-continuation (request->servlet-url failed-request))))))
(define mode (make-web-cell:local "details"))
(bind-url-parameter mode 'mode identity identity)
(define (color/percent-complete p)
(define R (round (* (- 1 p) 255)))
(define B (round (* p 255)))
(format "#~a~x00~a~x"
(if (< R 15) "0" "")
R
(if (< B 15) "0" "")
B))
(define (template embed/url body)
`(html (head (title "The Koby/Donaldson/McCarthy Grid" trade)
(script ([src "/yui/yahoo/yahoo.js"]) "")
(script ([src "/yui/connection/connection.js"]) "")
(link ([rel "stylesheet"] [type "text/css"] [media "all"]
[href "/grid-static/style.css"])))
(body
(div ([id "banner"])
(h2 "The Koby/Donaldson/McCarthy Grid" trade))
,@(if (nothing? (web-cell:local-ref current-user))
empty
`((div ([id "header"])
(ul (li (a ([class "k-url"]
[href ,(embed/url
(lambda _
(admin)))])
"Edit"))
(li (a ([class "k-url"]
[href ,(embed/url
(lambda _
(display-current-entries)))])
"Week"))
(li (a ([class "k-url"]
[href ,(embed/url
(lambda _
(display-box)))])
"Glance"))
(li (a ([class "k-url"]
[href ,(embed/url
(lambda _
(display-password)))])
"Password"))))))
,@body
(div ([id "quote"] [style "text-align: center;"])
,(fortunedb-choose (current-fortunedb)))
(div ([id "footer"])
(h4 (a ([href "/tour"]) "Take a tour of The Grid" trade "."))
(p "The Grid" trade " is provided as a service to humanity by "
"The Grid" trade " Foundation. Contact "
(a ([href "mailto:[email protected]"]) "Jay McCarthy")
" with any questions, comments, or concerns.")
(p "Powered by " (a ([href "http://www.plt-scheme.org/"])
(img ([width "53"] [height "19"] [src "/Defaults/documentation/plt-logo.gif"] [border "0"])))
(br)
(font ([size "2"]) "For more information on PLT Software, please follow the icon link."))))))
(define display-login
(opt-lambda ([failed? #f])
(define (handle-login request)
(define binds (request-bindings request))
(define username (extract-binding/single 'username binds))
(define password (extract-binding/single 'password binds))
(redirect/get/forget)
(match (database-lookup username (unbox current-db))
[(struct nothing ())
(update-entry! username (make-entry password))
username]
[(struct just (entry))
(if (string=? (entry-password entry) password)
username
(display-login #t))]))
(send/suspend/dispatch
(lambda (embed/url)
(template
embed/url
`((div ([id "login"] [style "text-align: center;"])
(form ([action ,(embed/url handle-login)] [method "POST"])
(table ([class "key-value"] [width "50%"])
(tr (th "Username:")
(td (input ([type "text"] [size "40"] [name "username"]))))
(tr (th "Password:")
(td (input ([type "password"] [size "40"] [name "password"]))))
(tr (td ([colspan "2"] [align "center"])
,(if failed?
`(p ([style "color: red;"])
"The username you have entered has been taken, "
"or the password you have entered is wrong.")
`(p ([style "color: blue;"])
"Type in any username and password. "
"If the username has not been taken, "
"you will claim it and can start your Grid" trade ".")))))
(p ([style "text-align: center;"])
(input ([name "submit"] [type "submit"] [value "Login"])))))))))))
(define (display-password)
(define (handle-password request)
(define binds (request-bindings request))
(define new-password (extract-binding/single 'password binds))
(update-current-entry!
(entry-password-update (current-entry) new-password))
(display-password))
(redirect/get/forget)
(send/suspend/dispatch
(lambda (embed/url)
(template
embed/url
`((div ([id "password"] [style "text-align: center;"])
(form ([action ,(embed/url handle-password)] [method "POST"])
(table ([class "key-value"])
(tr (th "Password:")
(td (input ([type "text"]
[size "40"]
[name "password"]
[value ,(entry-password (current-entry))])))))
(p ([style "text-align: center;"])
(input ([name "submit"] [type "submit"] [value "Change Password"]))))))))))
(define (display-box)
(define prev-dates (compute-prev-days 7))
(define prev-epoch-days (map date->day-since-epoch prev-dates))
(define the-activities (entry-activity-order (current-entry)))
(define percent-complete/activity
(map (lambda (an-activity)
(/ (length (filter (lambda (an-ed)
(entry-activity-on? (current-entry) an-activity an-ed))
prev-epoch-days))
(length prev-epoch-days)))
the-activities))
(define percent-complete
(average percent-complete/activity))
(web-cell:local-mask mode "glance")
(redirect/get/forget)
(send/suspend/dispatch
(lambda (embed/url)
(template
embed/url
`((div ([id "glance"]
[style ,(format "background-color: ~a"
(color/percent-complete percent-complete))])
nbsp))))))
(define (handle-new-activity request)
(define new-activity (extract-binding/single 'activity (request-bindings request)))
(update-current-entry!
(entry-activity-add (current-entry) new-activity)))
(define (display-current-entries)
(define prev-dates (compute-prev-days 7))
(define prev-epoch-days (map date->day-since-epoch prev-dates))
(define next-dates (compute-next-days 4))
(define the-activities (entry-activity-order (current-entry)))
(define spaces (build-list 15 (lambda (x) `nbsp)))
(define num-cols (+ 1 (length prev-dates) (length next-dates)))
(web-cell:local-mask mode "details")
(redirect/get/forget)
(send/suspend/dispatch
(lambda (embed/url)
(template
embed/url
`((table ([id "grid"] [align "center"])
(tr (td nbsp)
,@(map (lambda (a-date)
`(th (,@(if (srfi:19:today? a-date)
`([class "current-date"])
empty))
,(srfi:19:date->string a-date "~a")
(br)
,@(if (srfi:19:today? a-date)
`(nbsp
,(srfi:19:date->string a-date "~D")
nbsp)
spaces)))
(append prev-dates next-dates)))
,@(if (empty? the-activities)
`((tr (td ([colspan ,(number->string num-cols)])
nbsp))
(tr (td ([colspan ,(number->string num-cols)]
[align "center"])
"Your Grid" trade " is currently empty. Use the button below to add activities.")))
empty)
(script
,(js
(define (make_callback activity day)
(return
(object [success
(lambda (obj)
(define newcolor
((dot obj responseText substring) 4 11))
(define activity
((dot document getElementById) (dot obj argument activity)))
(ignore ((dot activity style backgroundColor) = newcolor))
(define day ((dot document getElementById) (dot obj argument day)))
(ignore ((dot day className) = (if (== (dot day className) "field-on") "field-off" "field-on")))
(return true))]
[failure
(lambda (obj)
(return false))]
[argument
(object [activity activity]
[day day])])))))
,@(map (lambda (an-activity)
(define (percent-complete)
(/ (length (filter (lambda (an-ed)
(entry-activity-on? (current-entry) an-activity an-ed))
prev-epoch-days))
(length prev-epoch-days)))
(define activity-id (symbol->string (gensym 'activity)))
`(tr (th ([id ,activity-id]
[style ,(format "color: white; background-color: ~a;"
(color/percent-complete (percent-complete)))])
,(format "~a" an-activity))
,@(map (lambda (an-ed)
(define day-id (symbol->string (gensym 'day)))
(define (activity-flip request)
(update-current-entry!
(entry-activity-flip (current-entry) an-activity an-ed))
`(ac
,(format "~a" (color/percent-complete (percent-complete)))))
(define url (embed/url activity-flip))
`(td ([id ,day-id]
[class ,(if (entry-activity-on? (current-entry) an-activity an-ed)
"field-on"
"field-off")]
[align "center"])
(a ([class "k-url"]
[href ,url]
[onclick
,(js (begin (ignore
((dot YAHOO util Connect asyncRequest)
"GET" ,url
(make_callback ,activity-id ,day-id)))
(return false)))])
,@spaces)))
prev-epoch-days)
,@(map (lambda (a-date)
`(td ([class "future"])
,@spaces))
next-dates)))
the-activities)
(tr (td ([colspan ,(number->string num-cols)])
nbsp))
(tr (td ([colspan ,(number->string num-cols)]
[align "center"])
(form ([method "POST"]
[action ,(embed/url (lambda (r)
(handle-new-activity r)
(display-current-entries)))])
(table
(tr (td (input ([type "text"] [name "activity"] [size "40"])))
(td (input ([type "submit"] [value "Add Activity"]))))))))))))))
(define (admin)
(define the-activities (entry-activity-order (current-entry)))
(define (delete an-activity)
(lambda _
(update-current-entry!
(entry-activity-delete (current-entry) an-activity))
(admin)))
(define gen-move?
(lambda (neq)
(lambda (an-activity)
(not (eq? neq (just-value (elem-ref an-activity the-activities)))))))
(define gen-move
(lambda (amt)
(lambda (an-activity)
(lambda (request)
(define old-pos (just-value (elem-ref an-activity the-activities)))
(update-current-entry!
(entry-activity-swap (current-entry) old-pos (+ amt old-pos)))
(admin)))))
(define move-up? (gen-move? 0))
(define move-up (gen-move -1))
(define move-down? (gen-move? (sub1 (length the-activities))))
(define move-down (gen-move 1))
(define spaces (build-list 15 (lambda (x) `nbsp)))
(web-cell:local-mask mode "admin")
(redirect/get/forget)
(send/suspend/dispatch
(lambda (embed/url)
(template
embed/url
`((table ([id "grid"] [align "center"])
(tr (td nbsp)
(td nbsp)
(td nbsp)
(td nbsp))
,@(if (empty? the-activities)
`((tr (td ([colspan "4"])
nbsp))
(tr (td ([colspan "4"]
[align "center"])
"Your Grid" trade " is currently empty. Use the button below to add activities.")))
empty)
,@(map (lambda (an-activity)
`(form ([method "POST"]
[action
,(embed/url
(lambda (request)
(define new-activity (extract-binding/single 'activity (request-bindings request)))
(update-current-entry!
(entry-activity-edit (current-entry) an-activity new-activity))
(admin)))])
(tr ,(if (move-down? an-activity)
`(td (a ([href ,(embed/url (move-down an-activity))]) darr))
`(td nbsp))
,(if (move-up? an-activity)
`(td (a ([href ,(embed/url (move-up an-activity))]) uarr))
`(td nbsp))
(th (input ([input "text"]
[name "activity"]
[size "40"]
[value ,(format "~a" an-activity)])))
(td (a ([href ,(embed/url (delete an-activity))])
"delete")))))
the-activities)
(tr (td ([colspan "4"])
nbsp))
(tr (td ([colspan "4"]
[align "center"])
(form ([method "POST"]
[action ,(embed/url (lambda (r)
(handle-new-activity r)
(admin)))])
(table
(tr (td (input ([type "text"] [name "activity"] [size "40"])))
(td (input ([type "submit"] [value "Add Activity"]))))))))))))))
(define (real-start)
(match (web-cell:local-ref current-user)
[(struct nothing ())
(define the-username (display-login))
(web-cell:local-mask current-user
(make-just the-username))]
[(struct just (user))
(void)])
(match (web-cell:local-ref mode)
["admin"
(admin)]
["glance"
(display-box)]
["details"
(display-current-entries)]))
(define (generate-start user-key db-path quote-path)
(define the-fortunedb (fortunedb-load quote-path))
(set-box! current-user-key user-key)
(set-box! current-db-path db-path)
(set-box! current-db (database-load db-path))
(make-start-reconstruction-handler
(lambda ()
(parameterize ([current-fortunedb the-fortunedb])
(real-start)))
(lambda (initial-request)
(parameterize ([current-fortunedb the-fortunedb])
(real-start))))))![[logo]](/logo.png){kind=logo}