Permalink
Switch branches/tags
Nothing to show
Find file
Fetching contributors…
Cannot retrieve contributors at this time
1128 lines (1044 sloc) 42.9 KB
#lang racket
(require racket/date
net/url
web-server/http
(for-syntax unstable/syntax
racket/syntax
racket/function)
(prefix-in 19: srfi/19)
(planet jaymccarthy/mongodb)
(planet jaymccarthy/mongodb/dispatch)
web-server/http/id-cookie
"model.rkt")
(define REDACT? #f)
; View
(define (footer)
`(div ([id "footer"])
"Powered by " (a ([href "http://racket-lang.org/"]) "Racket") ". "
"Written by " (a ([href "http://faculty.cs.byu.edu/~jay"]) "Jay McCarthy") ". "))
(define (template #:breadcrumb bc
. bodies)
(response/xexpr
`(html (head (title ,@(add-between (map car bc) " / "))
(script ([src "/sorttable.js"]) " ")
(link ([rel "stylesheet"] [type "text/css"] [href "/render.css"])))
(body
(div ([class "breadcrumb"])
,@(for/list ([b (in-list bc)])
(match-define (cons name url) b)
(if url
`(span (a ([href ,url]) ,name) " / ")
`(span ([class "this"]) ,name)))
,(if (current-user)
`(span ([id "logout"])
,(current-user) " | "
,@(if (next-applicant?)
(list `(a ([href ,(top-url next-app)]) "next") " | ")
empty)
(a ([href ,(top-url archive)]) "archive") " | "
(a ([href ,(top-url logout)]) "logout"))
""))
(div ([class "content"])
,@bodies
,(footer))))))
(define (tabs header . the-tabs)
(define found-selected? #f)
(define tab-seq
(build-vector (/ (length the-tabs) 2)
(lambda (i)
(define id (symbol->string (gensym)))
(define label (list-ref the-tabs (* 2 i)))
(define body (list-ref the-tabs (add1 (* 2 i))))
(define no-content?
(and (string? body)
(string=? "" body)))
(define selected?
(and (not found-selected?)
(not no-content?)))
(when selected?
(set! found-selected? #t))
(vector id selected? no-content? label body))))
`(div ([class "tabbed"])
(div ([class "tab-header"])
(div ([class "tab-uheader"]) ,header)
(ul
,@(for/list ([v (in-vector tab-seq)])
(match-define (vector id selected? no-content? label body) v)
(define direct-link
(match body
[(cons #f url) url]
[_ #f]))
`(li ([id ,(format "li~a" id)] ,@(if selected? `([class "tab-selected"]) empty))
,(cond
[no-content?
label]
[direct-link
`(a ([href ,direct-link]) ,label)]
[else
`(a ([href ,(format "javascript:~a~a;"
(for/fold ([s ""]) ([v (in-vector tab-seq)])
(match-define (vector id selected? no-content? label _) v)
(format "ToggleOff(~S);~a" id s))
(format "ToggleOn(~S)" id))])
,label)])))))
,@(for/list ([v (in-vector tab-seq)])
(match-define (vector id selected? no-content? _ body) v)
(define direct-link
(match body
[(cons #f url) url]
[_ #f]))
`(div ([id ,id]
[style ,(if selected?
"display: block"
"display: none")]
[class "tab-content"])
,(if direct-link "" body)))))
(define (data-table . rows)
(define max-cols
(apply max 0 (for/list ([row (in-list rows)]
#:when row)
(length row))))
`(table ([class "data"])
,@(for/list ([row (in-list rows)]
#:when row)
(define len (length row))
`(tr
,@(for/list ([col (in-list row)]
[i (in-naturals)])
(define label?
(even? i))
(define last?
(= i (sub1 len)))
`(td ([class ,(if label? "label" "value")]
[colspan ,(number->string (if last? (- max-cols i) 1))])
,col))))))
(define (19:time-subtract t1 t2)
(19:subtract-duration t1 (19:time-difference t1 t2)))
; Codes
(define-struct code (key str href))
(define (code-set->xexpr-forest cs)
(for/list ([c (in-list cs)])
(match-define (struct code (key str href)) c)
`(a ([class "code"]
[title ,str]
,@(if href
`([href ,(format href str)])
empty))
,key)))
(define-syntax-rule (list-cond [q code] ...)
(append (if q (list code) empty)
...))
(define (applicant-codes a)
(list-cond
[(symbol=? 'phd (applicant-degree-sought* a))
(make-code "P" "PhD applicant" #f)]
[(symbol=? 'ms (applicant-degree-sought* a))
(make-code "M" "MS applicant" #f)]
[(not (applicant-complete? a))
(make-code "I" "Incomplete Application" #f)]
[(not (string=? "BYU" (applicant-prior-school a)))
(make-code
"Y" (applicant-prior-school a)
"http://www.google.com/search?q=~a")]
[(not (regexp-match #rx"BS-CS" (applicant-degree a)))
(make-code "D" (applicant-degree a) #f)]
[(null-time<? (applicant-gre-date a)
(19:time-subtract
(19:current-time 19:time-utc)
(19:date->time-utc
(19:make-date 0 0 0 0 0 12 0 0))))
(make-code "G"
(format "Old GRE scores: ~a"
(date->xexpr (applicant-gre-date a)))
#f)]
[(not (string=? "USA" (applicant-citizenship a)))
(make-code "C" (applicant-citizenship a) #f)]
[(not (applicant-lds? a))
(make-code "L" "Not LDS" #f)]
[(not (applicant-financial-aid? a))
(make-code "F" "No financial aid" #f)]))
(define (applicant-vote->who a)
(define vote->who (make-hasheq empty))
(for ([d (applicant-decisions a)])
(define who (hash-ref d 'who))
(define vote (hash-ref d 'vote))
(hash-update! vote->who vote (curry list* who) empty))
vote->who)
(define (boolean->xexpr b)
(if b "Y" "N"))
(define (number->xexpr n)
(if (bson-null? n)
""
(number->string n)))
(define (percentage->xexpr n)
(if (bson-null? n)
""
(string-append (number->string n) "%")))
(define (date->xexpr s)
(if (bson-null? s)
""
(19:date->string (19:time-utc->date s) "~B ~Y")))
(define (percentage->xexpr-forest n)
(list (percentage->xexpr n)))
(define (number->xexpr-forest n)
(list (number->xexpr n)))
(define (date->xexpr-forest s)
(list (date->xexpr s)))
(define (toefl->xexpr s)
(if (bson-null? s)
("None")
(match s
['IELTS "IELTS"]
['IBT "IBT"]
['PBT "PBT"])))
(define (string->xexpr-forest s)
(list s))
(define (degree-sought->xexpr-forest d)
(list
(case d
[(phd) "PhD"]
[(ms) "MS"]
[(missing) "Missing"])))
;; number-field/limits->xexpr-forest : (applicant -> value) number number applicant -> xexpr-forest
(define (number-field/limits->xexpr-forest f phd ms a)
(define v (f a))
(define limit
(match (applicant-degree-sought* a)
['phd phd]
['ms ms]
['missing +inf.0]
[else
(error 'number-field/limits->xexpr-forest
"Applicant ~a has crazy degree sought: ~a"
a (applicant-degree-sought* a))]))
(define vs (number->xexpr-forest v))
(cond
[(or (bson-null? v) (v . >= . limit))
vs]
[(v . >= . (* .9 limit))
`(([class "low"]) ,@vs)]
[else
`(([class "verylow"]) ,@vs)]))
;; percentage-field/limits->xexpr-forest : (applicant -> value) number number applicant -> xexpr-forest
(define (percentage-field/limits->xexpr-forest f phd ms a)
(define v (f a))
(define limit
(match (applicant-degree-sought* a)
['phd phd]
['ms ms]
['missing +inf.0]
[else
(error 'number-field/limits->xexpr-forest
"Applicant ~a has crazy degree sought: ~a"
a (applicant-degree-sought* a))]))
(define vs (percentage->xexpr-forest v))
(cond
[(or (bson-null? v) (v . >= . limit))
vs]
[(v . >= . (* .9 limit))
`(([class "low"]) ,@vs)]
[else
`(([class "verylow"]) ,@vs)]))
(define (applicant-final-decision a)
(for/or ([d (applicant-decisions a)])
(and (string=? "COMMITTEE" (hash-ref d 'who))
(not (eq? (hash-ref d 'vote) 'Undecided))
`((strong ,(symbol->string (hash-ref d 'vote)))))))
(define possible-votes '(PhD MS Provisional Reject Borderline))
(define (vote->who->xexpr-forest vote->who)
(for/list ([v (in-list possible-votes)])
`(span ([class ,(format "dec-~a" v)]
[title ,(symbol->string v)])
,(with-handlers ([exn:fail? (lambda (x) 'nbsp)])
(number->string
(length
(hash-ref vote->who v)))))))
(define top-field-ids
'(decision last-name first-name raw-gre gre-verbal gre-verbal% gre-quant gre-quant% gre-anal gre-anal% cum-gpa codes))
(define field->field-name
#hasheq([decision . "Decisions"]
[last-name . "Last Name"]
[first-name . "First Name"]
[raw-gre . "Raw GRE"]
[gre-date . "GRE Date"]
[gre-verbal . "GRE_V"]
[gre-verbal% . "%"]
[gre-quant . "GRE_Q"]
[gre-quant% . "%"]
[gre-anal . "GRE_A"]
[gre-anal% . "%"]
[cum-gpa . "Cum. GPA"]
[major-gpa . "Major GPA"]
[research-area . "Research Area"]
[advisor . "Advisor"]
[codes . ""]))
(define gre-verbal->xexpr-forest
#;(curry number-field/limits->xexpr-forest applicant-gre-verbal-score 575 530)
(curry percentage-field/limits->xexpr-forest applicant-gre-verbal-percentile 70 60))
(define gre-quant->xexpr-forest
#;(curry number-field/limits->xexpr-forest applicant-gre-quant-score 750 700)
(curry percentage-field/limits->xexpr-forest applicant-gre-quant-percentile 80 70))
(define gre-anal->xexpr-forest
(curry number-field/limits->xexpr-forest applicant-gre-analytic-score 4.5 4.0))
(define major-gpa->xexpr-forest
(curry number-field/limits->xexpr-forest applicant-major-gpa 3.5 3.25))
(define cum-gpa->xexpr-forest
(curry number-field/limits->xexpr-forest applicant-cumulative-gpa 3.5 3.25))
(define field->applicant-field-xexpr
(make-hasheq
(list (cons 'decision
(λ (a)
(or (applicant-final-decision a)
(vote->who->xexpr-forest
(if (or (current-user-has-decided? a)
(fake-account? (current-user)))
(applicant-vote->who a)
(hasheq))))))
(cons 'last-name (compose string->xexpr-forest applicant-last-name))
(cons 'first-name (compose string->xexpr-forest applicant-first-name))
(cons 'raw-gre (compose number->xexpr-forest applicant-raw-gre))
(cons 'gre-date (compose date->xexpr-forest applicant-gre-date))
#;(cons 'gre-verbal gre-verbal->xexpr-forest)
(cons 'gre-verbal (compose number->xexpr-forest applicant-gre-verbal-score))
#;(cons 'gre-verbal% (compose number->xexpr-forest applicant-gre-verbal-percentile))
(cons 'gre-verbal% gre-verbal->xexpr-forest)
#;(cons 'gre-quant gre-quant->xexpr-forest)
(cons 'gre-quant (compose number->xexpr-forest applicant-gre-quant-score))
#;(cons 'gre-quant% (compose number->xexpr-forest applicant-gre-quant-percentile))
(cons 'gre-quant% gre-quant->xexpr-forest)
(cons 'gre-anal gre-anal->xexpr-forest)
(cons 'gre-anal% (compose number->xexpr-forest applicant-gre-analytic-percentile))
#;(cons 'cum-gpa (compose number->xexpr-forest applicant-cumulative-gpa))
(cons 'cum-gpa cum-gpa->xexpr-forest)
(cons 'codes (compose code-set->xexpr-forest applicant-codes)))))
(define (render-applicant-table applicants-seq #:editing? [editing? #f])
(define rows
(for/list ([a applicants-seq])
`(tr ([onclick ,(format "document.location = ~S" (top-url view-app a))])
,@(for/list ([id (in-list top-field-ids)])
(define f (hash-ref field->applicant-field-xexpr id))
`(td ,@(f a)))
(td nbsp
,(if editing?
`(a ([href ,(top-url edit-app a)]) "Edit")
`(a ([href ,(top-url view-app a)]) "View"))))))
(if (empty? rows)
""
`(table ([class "applicants sortable"])
(thead (tr ,@(for/list ([id (in-list top-field-ids)])
(define name (hash-ref field->field-name id 'nbsp))
`(th ,name))
(th nbsp)))
(tbody
,@rows))))
(define (applicants-tagged-for user #:tagged? [tagged? #t] #:decided? decided?)
(define ans
(mongo-dict-query
"applicants"
(if tagged?
(list (cons 'tags (list (cons '$in (vector user)))))
empty)))
(for/list ([a ans]
#:when
(let* ([non-undecided?
(for/or ([d (in-vector (applicant-decisions a))]
#:when (equal? user (hash-ref d 'who)))
(not (eq? 'Undecided (hash-ref d 'vote))))])
(eq? decided? non-undecided?)))
a))
(define (applicants/decided? user #:decided? decided?)
(applicants-tagged-for user #:tagged? #f #:decided? decided?))
(define (applicant-faculty-decision a f)
(define n (faculty-name f))
(define ds (applicant-decisions a))
(or (for/or ([d (in-vector ds)]
#:when (equal? n (hash-ref d 'who)))
(hash-ref d 'vote))
'Undecided))
(define (render-apps)
(template
#:breadcrumb (list (cons "Applicants" #f))
(tabs
""
"Your Applicants"
(render-applicant-table
(applicants-tagged-for (current-user) #:decided? #f))
"Your Applicants (decided)"
(render-applicant-table
(applicants-tagged-for (current-user) #:decided? #t))
"All Applicants"
(render-applicant-table
(applicants/decided? (current-user) #:decided? #f))
"All Applicants (decided)"
(render-applicant-table
(applicants/decided? (current-user) #:decided? #t))
"Next Undecided Applicant"
(if (next-applicant?)
(cons #f (top-url next-app))
""))))
(define (next-applicant?)
(for/or ([a (applicants-tagged-for (current-user) #:decided? #f)])
a))
(require web-server/formlets/lib)
(define (required-string def)
(to-string
(required
(text-input
#:value (if (bson-null? def)
#f (string->bytes/utf-8 def))))))
(define (optional-string def)
(cross (pure (λ (b)
(if (binding:form? b)
(bytes->string/utf-8 (binding:form-value b))
bson-null)))
(text-input #:value (if (bson-null? def)
#f
(string->bytes/utf-8 def)))))
(define (optional-boolean def)
(cross (pure (λ (x)
(and (binding:form? x)
(not (bytes=? #"off" (binding:form-value x))))))
(checkbox #""
(if (bson-null? def)
#f def))))
(define (optional-date def)
(cross (pure (λ (x)
(if (binding:form? x)
(string->time
(bytes->string/utf-8 (binding:form-value x)))
def)))
(text-input #:value (if (bson-null? def)
#"YYYY-MM"
(string->bytes/utf-8 (time->string def))))))
(define (optional-number-in-range def min max)
(cross
(pure (λ (x)
(or (and (bytes? x)
(let ([n (string->number (bytes->string/utf-8 x))])
(and (number? n)
(<= min n max)
n)))
bson-null)))
(required
(text-input #:value (if (bson-null? def)
#f
(string->bytes/utf-8 (number->string def)))))))
(define (sym-from def . opts)
(select-input opts
#:selected? (λ (x) (eq? def x))
#:display symbol->string))
(define (optional-file def-id accepted)
(define def
(if (bson-null? def-id)
bson-null
(make-mongo-dict "files" def-id)))
(cross (pure (λ (x)
(printf "Got ~v\n" x)
(if (and (binding:file? x)
(not (zero? (bytes-length (binding:file-content x)))))
(let ([uid
(mongo-dict-id
(make-file #:uploaded (19:current-time)
#:bytes (binding:file-content x)))])
(printf "New ID is ~v\n" uid)
uid)
(begin (printf "Empty\n") def-id))))
(make-input (λ (n) `(input ([type "file"] [name ,n] [accept ,accepted])
(span ([class "version"])
,(if (bson-null? def)
"No existing version"
(format "Last version uploaded on ~a"
(19:date->string
(19:time-utc->date (file-uploaded def)))))))))))
(define (applicant/default f v)
(if v
(f v)
bson-null))
(define-syntax (applicant-set! stx)
(syntax-case stx ()
[(_ a f ...)
(with-syntax ([(set-applicant-f! ...)
(map (curry format-id #'applicant? "set-applicant-~a!")
(syntax->list #'(f ...)))])
(syntax/loc stx
(begin (begin
; XXX
(printf "~v\n" `(set-applicant-f! a ,f))
(set-applicant-f! a f))
...)))]))
(define (edit-application-form k-url embed/url a)
(define toefl:t
(if a (applicant-toefl a)
bson-null))
(define (hash-ref** h k)
(if (bson-null? h)
bson-null
(hash-ref h k bson-null)))
(define toefl:kind (hash-ref** toefl:t 'kind))
(define toefl:date (hash-ref** toefl:t 'date))
(define toefl:reading
(match toefl:kind
[(? bson-null?) bson-null]
['None bson-null]
['IELTS (hash-ref** toefl:t 'read)]
['IBT (hash-ref** toefl:t 'read)]
['PBT (hash-ref** toefl:t 'reading)]))
(define toefl:listening
(hash-ref** toefl:t 'listen))
(define toefl:writing
(match toefl:kind
[(? bson-null?) bson-null]
['None bson-null]
['IELTS (hash-ref** toefl:t 'write)]
['IBT (hash-ref** toefl:t 'write)]
['PBT (hash-ref** toefl:t 'writing)]))
(define toefl:speaking/structure
(match toefl:kind
[(? bson-null?) bson-null]
['None bson-null]
['IELTS (hash-ref** toefl:t 'speak)]
['IBT (hash-ref** toefl:t 'speak)]
['PBT (hash-ref** toefl:t 'structure)]))
(define the-formlet
(formlet
(table ([class "appform"])
(tr (th "First Name")
(td ,{(required-string (applicant/default applicant-first-name a)) . => . first-name})
(th "Last Name")
(td ,{(required-string (applicant/default applicant-last-name a)) . => . last-name}))
(tr (th "Prior School")
(td ,{(optional-string (applicant/default applicant-prior-school a)) . => . prior-school})
(th "Prior Degree")
(td ,{(optional-string (applicant/default applicant-degree a)) . => . degree}))
(tr (th "Research Area")
(td ,{(optional-string (applicant/default applicant-research-area a)) . => . research-area})
(th "Advisor")
(td ,{(optional-string (applicant/default applicant-advisor a)) . => . advisor}))
(tr (th "Cumulative GPA")
(td ,{(optional-number-in-range (applicant/default applicant-cumulative-gpa a) 0 4) . => . cumulative-gpa})
#;(th "Major GPA")
#;(td ,{(optional-number-in-range (applicant/default applicant-major-gpa a) 0 4) . => . major-gpa}))
(tr (th ([colspan "3"]) "Is the student LDS?")
(td ,{(optional-boolean (applicant/default applicant-lds? a)) . => . lds?}))
(tr (th ([colspan "3"]) "Does the student need financial aid?")
(td ,{(optional-boolean (applicant/default applicant-financial-aid? a)) . => . financial-aid?}))
(tr (th ([colspan "3"]) "What degree is the applicant seeking?")
(td ,{(sym-from (applicant/default applicant-degree-sought* a) 'phd 'ms) . => . degree-sought}))
(tr (th ([colspan "2"]) "Citizenship")
(td ([colspan "2"]) ,{(optional-string (applicant/default applicant-citizenship a)) . => . citizenship}))
(tr (td ([colspan "4"]) nbsp))
(tr (th "GRE") (td nbsp)
(th "Date") (td ,{(optional-date (applicant/default applicant-gre-date a)) . => . gre-date}))
(tr (th "Verbal")
(td ,{(optional-number-in-range (applicant/default applicant-gre-verbal-score a) 0 800) . => . gre-verbal-score})
(th "Percentile")
(td ,{(optional-number-in-range (applicant/default applicant-gre-verbal-percentile a) 0 99) . => . gre-verbal-percentile}))
(tr (th "Quant")
(td ,{(optional-number-in-range (applicant/default applicant-gre-quant-score a) 0 800) . => . gre-quant-score})
(th "Percentile")
(td ,{(optional-number-in-range (applicant/default applicant-gre-quant-percentile a) 0 99) . => . gre-quant-percentile}))
(tr (th "Analytic")
(td ,{(optional-number-in-range (applicant/default applicant-gre-analytic-score a) 0 6) . => . gre-analytic-score})
(th "Percentile")
(td ,{(optional-number-in-range (applicant/default applicant-gre-analytic-percentile a) 0 99) . => . gre-analytic-percentile}))
(tr (td ([colspan "4"]) nbsp))
(tr (th "TOEFL") (td ,{(sym-from toefl:kind 'None 'IELTS 'IBT 'PBT) . => . toefl:kind})
(th "Date") (td ,{(optional-date toefl:date) . => . toefl:date}))
(tr (th "Reading") (td ,{(optional-number-in-range toefl:reading 0 100) . => . toefl:reading})
(th "Listening") (td ,{(optional-number-in-range toefl:listening 0 100) . => . toefl:listening}))
(tr (th "Writing") (td ,{(optional-number-in-range toefl:writing 0 100) . => . toefl:writing})
(th "Speaking/Structure") (td ,{(optional-number-in-range toefl:speaking/structure 0 100) . => . toefl:speaking/structure}))
(tr (td ([colspan "4"]) nbsp))
(tr (th ([colspan "2"]) "Application")
(td ([colspan "2"]) ,{(optional-file (applicant/default applicant-pdf-application a) "application/pdf") . => . pdf-application}))
(tr (th ([colspan "2"]) "Reference Letters")
(td ([colspan "2"]) ,{(optional-file (applicant/default applicant-pdf-letters a) "application/pdf") . => . pdf-letters}))
(tr (th ([colspan "2"]) "Transcript")
(td ([colspan "2"]) ,{(optional-file (applicant/default applicant-pdf-transcript a) "application/pdf") . => . pdf-transcript}))
(tr (th ([colspan "4"]) "Note: Files limited to 4MB. Larger files will silently fail."))
(tr (td ([colspan "4"]) nbsp))
(tr (td ([colspan "4"] [align "center"]) (input ([type "submit"])))))
(let ([a
(if a
a
(make-applicant #:first-name first-name
#:last-name last-name
#:degree-sought degree-sought
#:comments (vector)
#:tags (vector)
#:decisions (vector)))])
(define toefl
(match toefl:kind
[(? bson-null?) bson-null]
['None bson-null]
['IELTS
(hasheq 'kind 'IELTS
'date toefl:date
'read toefl:reading
'write toefl:writing
'listen toefl:listening
'speak toefl:speaking/structure)]
['IBT
(hasheq 'kind 'IBT
'date toefl:date
'read toefl:reading
'write toefl:writing
'listen toefl:listening
'speak toefl:speaking/structure)]
['PBT
(hasheq 'kind 'PBT
'date toefl:date
'listen toefl:listening
'structure toefl:speaking/structure
'reading toefl:reading
'writing toefl:writing)]))
(applicant-set! a
first-name last-name prior-school
degree cumulative-gpa research-area advisor
lds? financial-aid? degree-sought
citizenship gre-date
gre-verbal-percentile gre-verbal-score
gre-quant-percentile gre-quant-score
gre-analytic-percentile gre-analytic-score
toefl
pdf-application pdf-letters pdf-transcript)
a)))
(define (submit-handler req)
(formlet-process the-formlet req)
(redirect-to k-url))
`(form ([action ,(embed/url submit-handler)] [method "post"] [enctype "multipart/form-data"])
,@(formlet-display the-formlet)))
(define (render-admin)
(send/suspend/dispatch
(λ (embed/url)
(template
#:breadcrumb (list (cons "Applicants (admin)" #f))
(tabs
""
"All Applicants"
(render-applicant-table (applicants)
#:editing? #t)
"New Applicant"
`(div ([id "add"])
,(edit-application-form (top-url show-root) embed/url #f))
"Manage Faculty Accounts"
"XXX Incomplete, soweee :)")))))
(define (edit-app req a)
(define name
(format "~a ~a"
(applicant-first-name a)
(applicant-last-name a)))
(send/suspend/dispatch
(lambda (embed/url)
(template
#:breadcrumb
(list (cons "Applicants" (top-url show-root))
(cons name #f))
(edit-application-form (top-url edit-app a) embed/url a)))))
; Controller
(require scheme/runtime-path
web-server/servlet-env
web-server/servlet
web-server/http
web-server/formlets
web-server/dispatch)
(define (admin-mode?)
(string=? "ADMIN" (current-user)))
(define (fake-account? u)
(or (string=? "ADMIN" u)
(string=? "COMMITTEE" u)))
(define (show-root req)
(if (admin-mode?)
(render-admin)
(render-apps)))
(define (seq-member? e v)
(for/or ([t v]
#:when (equal? t e))
#t))
(define (sequence-partition ? s)
(for/fold ([yes empty]
[no empty])
([e s])
(if (? e)
(values (list* e yes) no)
(values yes (list* e no)))))
(define (time->xexpr t)
`(span ([class "time"])
,(19:date->string (19:time-utc->date t) "~B ~e, ~Y ~I:~M~p")))
(define (maybe-add-parens v)
(if (string=? v "")
v
(format "(~a)" v)))
(define (show-app-file req a name)
(define selector
(match name
["Application.pdf" applicant-pdf-application]
["Letters.pdf" applicant-pdf-letters]
["Transcripts.pdf" applicant-pdf-transcript]))
(define file-obj-id
(selector a))
(printf "Get uid: ~v\n" file-obj-id)
(define file
(make-mongo-dict "files" file-obj-id))
(response/full
200 #"Okay"
(19:time-second (file-uploaded file)) #"application/pdf"
empty
(list (file-bytes file))))
(define (current-user-has-decided? a)
(for/or ([(vote who) (in-hash (applicant-vote->who a))])
(and (not (symbol=? 'Undecided vote))
(ormap (curry string=? (current-user)) who))))
(define (applicant-name a)
(format "~a ~a"
(applicant-first-name a)
(applicant-last-name a)))
(define (view-app req a)
(send/suspend/dispatch
(lambda (embed/url)
(apply
template
#:breadcrumb
(list (cons "Applicants" (top-url show-root))
(cons (applicant-name a) #f))
(view-app-body a embed/url)))))
(define (view-app-body a embed/url)
(define name (applicant-name a))
(define original-tags (applicant-tags a))
(define (applicant-tagged-with? f)
(define n (faculty-name f))
(seq-member? n original-tags))
(define-values (tagged not-tagged)
(partition applicant-tagged-with?
(filter-not (compose fake-account? faculty-name)
(for/list ([f (faculty)]) f))))
(define comment-formlet
(formlet
,{(to-string (required (textarea-input))) . => . comment}
comment))
(define (tag-formlet facs)
(formlet
(#%#
,{(select-input facs #:display faculty-name)
. => .
tag}
(br)
,{comment-formlet . => . comment})
(vector tag comment)))
(define ((handle-tag formlet ! comment-type) req)
(match-define (vector new-fac comment) (formlet-process formlet req))
(define n (faculty-name new-fac))
(push-applicant-comments!
a (list (cons 'who (current-user))
(cons 'when (19:current-time))
(cons 'what comment)
(cons 'type (vector comment-type n))))
(! a n)
(redirect-to (top-url view-app a)))
(define add-tag-formlet (tag-formlet not-tagged))
(define add-tag-handler (handle-tag add-tag-formlet set-add-applicant-tags! 'add-tag))
(define remove-tag-formlet (tag-formlet tagged))
(define remove-tag-handler (handle-tag remove-tag-formlet pull-applicant-tags! 'remove-tag))
(define dec-formlet
(formlet
(#%#
,{(select-input (list* 'Undecided possible-votes)
#:selected? (curry eq? (applicant-faculty-decision a (current-user-obj)))
#:display symbol->string)
. => .
decision}
(br)
,{comment-formlet . => . comment})
(vector decision comment)))
(define (handle-dec req)
(match-define (vector decision comment) (formlet-process dec-formlet req))
(push-applicant-comments!
a (list (cons 'who (current-user))
(cons 'when (19:current-time))
(cons 'what comment)
(cons 'type (vector 'decision decision))))
(pull-applicant-decisions!
a (list (cons 'who (current-user))))
(push-applicant-decisions!
a (list (cons 'who (current-user))
(cons 'vote decision)))
(redirect-to (top-url view-app a)))
(define has-decided?
(current-user-has-decided? a))
(list
(local [(define (icon-url f)
(format "/icons/flavour-extended-png/~a.png" f))
(define (show-link applicant-file-contents name yes-icon no-icon-color)
(define exists? (not (bson-null? (applicant-file-contents a))))
(define no-icon (format "button_delete_~a" no-icon-color))
`(td
,(if exists?
`(a ([href ,(top-url show-app-file a (format "~a.pdf" name))]) (img ([src ,(icon-url yes-icon)])))
`(img ([src ,(icon-url no-icon)]))) (br)
,name))]
`(table ([class "pdfs"])
(tr
,(show-link applicant-pdf-application "Application" "apple-script" "green")
,(show-link applicant-pdf-letters "Letters" "document_blank" "blue")
,(show-link applicant-pdf-transcript "Transcripts" "curriculum_vitae" "red"))))
(data-table
(list "Name" name
"Degree Sought" `(span ,@(degree-sought->xexpr-forest (applicant-degree-sought* a))))
(list
"Citizenship" (applicant-citizenship a)
"LDS?" (boolean->xexpr (applicant-lds? a))
"Financial Aid?" (boolean->xexpr (applicant-financial-aid? a)))
(list
"Prior School" (applicant-prior-school a))
(list
"Degree" (applicant-degree a))
(list
"Research Area" (applicant-research-area* a))
(list
"Advisor" (applicant-advisor* a))
(list
"Cumulative GPA" (number->xexpr (applicant-cumulative-gpa a))
#;"Major GPA" #;`(span ,@(major-gpa->xexpr-forest a)))
(list
"GRE" (date->xexpr (applicant-gre-date a))
"Verbal" `(span ,@(gre-verbal->xexpr-forest a) nbsp
,(maybe-add-parens (number->xexpr (applicant-gre-verbal-score a))))
"Quantative" `(span ,@(gre-quant->xexpr-forest a) nbsp
,(maybe-add-parens (number->xexpr (applicant-gre-quant-score a))))
"Analytic" `(span ,@(gre-anal->xexpr-forest a) nbsp
,(maybe-add-parens (percentage->xexpr (applicant-gre-analytic-percentile a)))))
(if (bson-null? (applicant-toefl a))
#f
(local [(define toefl (applicant-toefl a))
(define kind (hash-ref toefl 'kind))]
(list*
"TOEFL" (string-append (toefl->xexpr kind) " (" (date->xexpr (hash-ref toefl 'date)) ")")
(match kind
['IELTS
(define read (hash-ref toefl 'read))
(define write (hash-ref toefl 'write))
(define listen (hash-ref toefl 'listen))
(define speak (hash-ref toefl 'speak))
; XXX null+
(define total (+ read write listen speak))
(list "Total" (number->string total)
"Reading" (number->string read)
"Listening" (number->string listen)
"Speaking" (number->string speak)
"Writing" (number->string write))]
['IBT
(define read (hash-ref toefl 'read))
(define write (hash-ref toefl 'write))
(define listen (hash-ref toefl 'listen))
(define speak (hash-ref toefl 'speak))
; XXX null+
(define total (+ read write listen speak))
(list "Total" (number->string total)
"Reading" (number->string read)
"Listening" (number->string listen)
"Speaking" (number->string speak)
"Writing" (number->string write))]
['PBT
(define listen (hash-ref toefl 'listen))
(define structure (hash-ref toefl 'structure))
(define reading (hash-ref toefl 'reading))
(define writing (hash-ref toefl 'writing))
; XXX null+
(define total (+ listen structure reading))
(list "Total" (number->string total)
"Listening" (number->string listen)
"Structure" (number->string structure)
"Reading" (number->string reading)
"Writing" (number->string writing))]))))
(local [(define tags (applicant-tags a))]
(if (zero? (vector-length tags))
#f
(list "Faculty"
`(ul ([class "horiz"])
,@(for/list ([t tags])
`(li ,t)))))))
(if embed/url
`(table
([class "edit"])
(thead
(tr (th "Add Tag")
(th "Remove Tag")
(th "Decide")))
(tbody
(tr
(td ,(if (empty? not-tagged)
""
`(form ([action ,(embed/url add-tag-handler)] [method "post"])
,@(formlet-display add-tag-formlet) (br)
(input ([type "submit"] [value "Add Tag"])))))
(td ,(if (empty? tagged)
""
`(form ([action ,(embed/url remove-tag-handler)] [method "post"])
,@(formlet-display remove-tag-formlet) (br)
(input ([type "submit"] [value "Remove Tag"])))))
(td (form ([action ,(embed/url handle-dec)] [method "post"])
,@(formlet-display dec-formlet) (br)
(input ([type "submit"] [value "Decide"])))))))
'nbsp)
`(h3 "Decisions")
(local [(define votes (applicant-vote->who a))]
(if (or has-decided?
(not REDACT?)
(fake-account? (current-user)))
(apply data-table
(for/list ([(vote who) (in-hash votes)])
(list (symbol->string vote)
`(ul ([class "horiz"])
,@(for/list ([t who])
`(li ,t))))))
"Redacted"))
`(h3 "Comments")
`(div ,@(for/list ([c (sort (vector->list (applicant-comments a))
19:time>=?
#:key (lambda (c)
(hash-ref c 'when)))])
(define who (hash-ref c 'who))
(define when (hash-ref c 'when))
(define what (hash-ref c 'what))
(define type (hash-ref c 'type))
(match type
[(vector 'add-tag tag)
`(p ([class "comment"])
(span ([class "who"]) ,who) " added the tag " (span ([class "tag"]) ,tag) "." (br)
,what ,(time->xexpr when))]
[(vector 'remove-tag tag)
`(p ([class "comment"])
(span ([class "who"]) ,who) " removed the tag " (span ([class "tag"]) ,tag) "." (br)
,what ,(time->xexpr when))]
[(vector 'decision decision)
(if (or (equal? who (current-user)) has-decided?
(not REDACT?)
(fake-account? (current-user)))
`(p ([class "comment"])
(span ([class "who"]) ,who) " made the decision " (span ([class "decision"]) ,(symbol->string decision)) "." (br)
,what ,(time->xexpr when))
`(p ([class "comment"])
"Redacted"))])))))
(define (logout req)
(redirect-to
(top-url show-root)
#:headers
(list
(cookie->header
(logout-id-cookie "name")))))
(define (next-app req)
(redirect-to
(top-url view-app (next-applicant?))))
(define (archive req)
(apply
template
#:breadcrumb
(list (cons "Applicants" (top-url show-root))
(cons "Archive" #f))
(apply append
(for/list ([a (mongo-dict-query "applicants" (hasheq))])
(list*
'(hr)
`(h1 ,(applicant-name a))
(view-app-body a #f))))))
(define-values (top-dispatch top-url top-applies?)
(dispatch-rules+applies
[("") show-root]
[("logout") logout]
[("archive") archive]
[("next") next-app]
[("edit" (mongo-dict-arg "applicants")) edit-app]
[("app" (mongo-dict-arg "applicants")) view-app]
[("pdf" (mongo-dict-arg "applicants") (string-arg)) show-app-file]))
(define-runtime-path secret-key "secret.key")
(define m8b-key (file->bytes secret-key))
(define current-user (make-parameter #f))
(define (current-user-obj)
(for/or ([e (mongo-dict-query "faculty" (list (cons 'name (current-user))))])
e))
(require (planet jaymccarthy/ldap))
(define (authenticate-netid u p)
(ldap-authenticate "ldap.byu.edu" 389 (format "uid=~a,ou=People,o=BYU.edu" u) p))
(define (login req [last-error #f])
; XXX look nice
(define login-formlet
(formlet
(table
(tr (td "NetID:")
(td ,{(to-string (required (text-input))) . => . netid}))
(tr (td "NetID Password:")
(td ,{(to-string (required (password-input))) . => . passwd})))
(values netid passwd)))
(define log-req
(send/suspend
(λ (k-url)
(template
#:breadcrumb (list (cons "Login" #f))
`(div ([id "login"])
(form ([action ,k-url] [method "post"])
,@(formlet-display login-formlet)
(input ([type "submit"] [value "Log in"])))
,@(if last-error
`((h1 ([class "error"]) ,last-error))
'()))))))
(define-values
(netid passwd)
(formlet-process login-formlet log-req))
(define who
(or (for/or ([fac (mongo-dict-query "faculty" (hasheq 'netid netid))])
fac)
(for/or ([fac (mongo-dict-query "faculty" (hasheq 'name netid))])
fac)))
(if (not who)
(login req (format "Invalid username (~S)" netid))
(let ([authenticated?
;; If there is no netid, then use the secret key
(if (and (faculty-netid who) (not (string=? passwd "")))
(authenticate-netid netid passwd)
(bytes=? m8b-key (string->bytes/utf-8 passwd)))])
(if authenticated?
(redirect-to (top-url show-root)
#:headers
(list
(cookie->header
; XXX It is a bit wrong to use the name rather than the objectid
(make-id-cookie "name" m8b-key (faculty-name who)))))
(login req (format "Invalid password for user (~S)" netid))))))
(define (call-with-custodian-shutdown thunk)
(define cust (make-custodian))
(dynamic-wind void
thunk
(λ ()
(custodian-shutdown-all cust))))
(define (login-then-top-dispatch req)
(printf "[~a] ~a\n" (current-seconds) (url->string (request-uri req)))
(call-with-custodian-shutdown
(λ ()
(call-with-model
(λ ()
(if (top-applies? req)
(let ()
(define maybe-id (request-id-cookie "name" m8b-key req))
(match maybe-id
[#f
(login req)]
[id
(parameterize ([current-user id])
(top-dispatch req))]))
(top-dispatch req)))))))
; Configuration
(define-runtime-path static-path "static")
(define-runtime-path private-key "private-key.pem")
(define-runtime-path server-cert "server-cert.pem")
(require web-server/managers/lru)
(serve/servlet login-then-top-dispatch
#:manager (make-threshold-LRU-manager #f (* 1024 1024 512))
#:port 9000
#:listen-ip #f
#:quit? #f
#:launch-browser? #f
#:servlet-regexp #rx""
#:servlet-path "/"
#:ssl-cert server-cert
#:ssl-key private-key
#:extra-files-paths (list static-path))