From 0b5e102bd567687efbd2585483832497fb7e834c Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Mon, 4 Oct 2021 03:21:12 -0400 Subject: [PATCH 1/2] Move most of the inlined style to CSS --- handin-server/web-status-server.rkt | 46 ++++++++++++++++++----------- 1 file changed, 29 insertions(+), 17 deletions(-) diff --git a/handin-server/web-status-server.rkt b/handin-server/web-status-server.rkt index 70dc21b..b978874 100644 --- a/handin-server/web-status-server.rkt +++ b/handin-server/web-status-server.rkt @@ -1,4 +1,4 @@ -#lang racket/base +#lang at-exp racket/base (require racket/list racket/path @@ -21,9 +21,22 @@ (define (clean-str s) (regexp-replace #rx" +$" (regexp-replace #rx"^ +" s "") "")) +(define css @list{ + body { background-color: white@";" } + h1 { width: 100%@";" text-align: center@";" } + #all-handins { background-color: #ddddff@";" margin: auto@";" } + #all-handins tr { vertical-align: top@";" } + #all-handins :is(th, td) { padding: 6px@";" } + #all-handins th { text-align: left@";" background-color: #f0f0f0@";" + font-weight: bold@";" font-size: larger@";" } + #all-handins td { background-color: white@";" } + #all-handins td.grade { text-align: right@";" } + .error { color: red@";" } +}) + (define (make-page title . body) - `(html (head (title ,title)) - (body ([bgcolor "white"]) (h1 ((align "center")) ,title) ,@body))) + `(html (head (title ,title) (style "\n" ,@css "\n")) + (body (h1 ,title) ,@body))) (define get-user-data (let ([users-file (build-path server-dir "users.rktd")]) @@ -38,8 +51,8 @@ (define (make-k k tag #:mode [mode "download"]) (let ([sep (if (regexp-match? #rx"^[^#]*[?]" k) "&" "?")]) - (format "~a~atag=~a~amode=~a" - k + (format "~a~atag=~a~amode=~a" + k sep (uri-encode tag) ";" @@ -139,24 +152,23 @@ (handle-status-request user next null))) (define (all-status-page user) - (define (cell . texts) `(td ([bgcolor "white"]) ,@texts)) - (define (rcell . texts) `(td ([bgcolor "white"] [align "right"]) ,@texts)) - (define (header . texts) `(td ([bgcolor "#f0f0f0"]) (big (strong ,@texts)))) + (define (cell . texts) `(td ,@texts)) + (define (rcell . texts) `(td ([class "grade"]) ,@texts)) + (define (header . texts) `(th ,@texts)) (define ((row k active? upload-suffixes) dir) (let ([hi (assignment<->dir dir)]) - `(tr ([valign "top"]) - ,(apply header hi (if active? `((br) (small (small "[active]"))) '())) - ,(apply cell (handin-link k user hi upload-suffixes)) - ,(rcell (handin-grade user hi)) - ,(apply cell (solution-link k hi))))) + `(tr ,(apply header hi (if active? `((br) (small (small "[active]"))) '())) + ,(apply cell (handin-link k user hi upload-suffixes)) + ,(rcell (handin-grade user hi)) + ,(apply cell (solution-link k hi))))) (define upload-suffixes (get-conf 'allow-web-upload)) (let* ([next (send/suspend (lambda (k) (make-page (format "All Handins for ~a" user) - `(table ([bgcolor "#ddddff"] [cellpadding "6"] [align "center"]) - (tr () ,@(map header '(nbsp "Files" "Grade" "Solution"))) + `(table ([id "all-handins"]) + (tr ,@(map header '(nbsp "Files" "Grade" "Solution"))) ,@(append (map (row k #t upload-suffixes) (get-conf 'active-dirs)) (map (row k #f #f) (get-conf 'inactive-dirs)))))))]) (handle-status-request user next upload-suffixes))) @@ -290,8 +302,8 @@ "Handin Status Login" `(form ([action ,k] [method "post"]) (table ([align "center"]) - (tr (td ([colspan "2"] [align "center"]) - (font ([color "red"]) ,(or errmsg 'nbsp)))) + (tr (td ([colspan "2"] [align "center"] [class "error"]) + ,(or errmsg 'nbsp))) (tr (td "Username") (td (input ([type "text"] [name "user"] [size "20"] [value ""])))) From f2c592c590f49a5d5a173b4389b1c4ff12b5ead1 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Mon, 4 Oct 2021 03:42:21 -0400 Subject: [PATCH 2/2] Add `handin-make-page` to tweak the rendered server pages The default works as it did, so no changes to that --- *except* for the fact that this uses `xexpr->string` which is very fast compared to the previous. Given that the style is done through CSS, parameterizing that could go a long way, but in some cases (as is in mine), there's additional navbar content, and additional JS scripting. --- handin-server/private/config.rkt | 1 + handin-server/scribblings/server-setup.scrbl | 11 ++++- handin-server/web-status-server.rkt | 42 +++++++++++++++----- 3 files changed, 41 insertions(+), 13 deletions(-) diff --git a/handin-server/private/config.rkt b/handin-server/private/config.rkt index bdcc875..b04b614 100644 --- a/handin-server/private/config.rkt +++ b/handin-server/private/config.rkt @@ -79,6 +79,7 @@ [(port-number) (values 7979 id )] [(use-https) (values #t id )] [(hook-file) (values #f path/false )] + [(handin-make-page) (values #f path/false )] [(session-timeout) (values 300 id )] [(session-memory-limit) (values 40000000 id )] [(default-file-name) (values "handin.rkt" id )] diff --git a/handin-server/scribblings/server-setup.scrbl b/handin-server/scribblings/server-setup.scrbl index 329de8c..d1a6e68 100644 --- a/handin-server/scribblings/server-setup.scrbl +++ b/handin-server/scribblings/server-setup.scrbl @@ -217,8 +217,15 @@ This directory contains the following files and sub-directories: '("course-staff@university.edu") '() '() (map (lambda (key+val) (apply format "~a: ~s" key+val)) - alist))))]}}] - + alist))))]}} + + @item{@indexed-racket[handin-make-page] --- a path (relative to the + handin server directory or absolute) that specifies a filename that + contains a `make-page' module. It is expected to contain a module + that provides a @racket[make-page] function, which is used for pages + generated by the handin web server. The function should receive one + or more arguments: the first holding the page's title, and the rest + being xexpr values that form the body.}] The @secref{grading-utils} uses the following keys: diff --git a/handin-server/web-status-server.rkt b/handin-server/web-status-server.rkt index b978874..6d79370 100644 --- a/handin-server/web-status-server.rkt +++ b/handin-server/web-status-server.rkt @@ -9,10 +9,12 @@ web-server/servlet web-server/compat/0/coerce web-server/compat/0/http/response-structs - handin-server/private/md5 - handin-server/private/logger - handin-server/private/config - handin-server/private/hooker + xml + "private/md5.rkt" + "private/logger.rkt" + "private/config.rkt" + "private/hooker.rkt" + "private/reloadable.rkt" "run-servlet.rkt") (define (aget alist key) @@ -34,9 +36,26 @@ .error { color: red@";" } }) +(define make-page-file #f) +(define make-page-proc #f) (define (make-page title . body) - `(html (head (title ,title) (style "\n" ,@css "\n")) - (body (h1 ,title) ,@body))) + (define file (get-conf 'handin-make-page)) + (define (default-maker title . body) + (xexpr->string + `(html (head (title ,title) (style "\n" ,@css "\n")) + (body (h1 ,title) ,@body)))) + (define maker + (cond [(not file) default-maker] + [else (unless (equal? file make-page-file) + (set! make-page-file file) + (set! make-page-proc + (auto-reload-procedure `(file ,(path->string file)) + 'make-page))) + make-page-proc])) + (response/output + (λ (out) + (write-string (apply maker title body) out) + (void)))) (define get-user-data (let ([users-file (build-path server-dir "users.rktd")]) @@ -156,11 +175,12 @@ (define (rcell . texts) `(td ([class "grade"]) ,@texts)) (define (header . texts) `(th ,@texts)) (define ((row k active? upload-suffixes) dir) - (let ([hi (assignment<->dir dir)]) - `(tr ,(apply header hi (if active? `((br) (small (small "[active]"))) '())) - ,(apply cell (handin-link k user hi upload-suffixes)) - ,(rcell (handin-grade user hi)) - ,(apply cell (solution-link k hi))))) + (define hi (assignment<->dir dir)) + `(tr ,(if active? `([class "active"]) '()) + ,(apply header hi (if active? `((br) (small (small "[active]"))) '())) + ,(apply cell (handin-link k user hi upload-suffixes)) + ,(rcell (handin-grade user hi)) + ,(apply cell (solution-link k hi)))) (define upload-suffixes (get-conf 'allow-web-upload)) (let* ([next (send/suspend