diff --git a/handin-server/main.rkt b/handin-server/main.rkt index ff17b0f..7e72096 100644 --- a/handin-server/main.rkt +++ b/handin-server/main.rkt @@ -1,10 +1,13 @@ #lang racket/base (require mzlib/thread + racket/match + racket/place racket/port openssl racket/file racket/format + "private/constants.rkt" "private/logger.rkt" "private/config.rkt" "private/lock.rkt" @@ -12,6 +15,7 @@ "private/run-status.rkt" "private/reloadable.rkt" "private/hooker.rkt" + "private/place.rkt" (prefix-in web: "web-status-server.rkt") ;; this sets some global parameter values, and this needs ;; to be done in the main thread, rather than later in a @@ -23,27 +27,10 @@ ;; they're being required dynamically), and further handlers ;; will fail with "queue-callback: eventspace is shutdown", ;; requiring it here makes it avoids killing the eventspace - racket/gui/base) + #;racket/gui/base) (install-logger-port) -;; errors to the user: no need for a "foo: " prefix -(define (error* fmt . args) - (error (apply format fmt args))) - -(define (write+flush port . xs) - (for ([x (in-list xs)]) (write x port) (newline port)) - (flush-output port)) - -(define-struct alist (name [l #:mutable])) -(define (a-set! alist key val) - (let ([l (alist-l alist)]) - (cond [(assq key l) => (lambda (p) (set-box! (cdr p) val))] - [else (set-alist-l! alist (cons (cons key (box val)) l))]))) -(define (a-ref alist key . default) - (cond [(assq key (alist-l alist)) => (lambda (x) (unbox (cdr x)))] - [(pair? default) (car default)] - [else (error (alist-name alist) "no value for `~s'" key)])) (define orig-custodian (current-custodian)) @@ -60,20 +47,6 @@ ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(define ATTEMPT-DIR "ATTEMPT") -(define (success-dir n) (format "SUCCESS-~a" n)) - -(define (make-success-dir-available n) - (let ([name (success-dir n)]) - (when (directory-exists? name) - (if (< n (get-conf 'max-upload-keep)) - (begin (make-success-dir-available (add1 n)) - (rename-file-or-directory name (success-dir (add1 n)))) - (delete-directory/files name))))) - -(define ATTEMPT-RE (regexp (format "^~a$" ATTEMPT-DIR))) -(define SUCCESS-RE (regexp (format "^~a$" (success-dir "[0-9]+")))) -(define SUCCESS-GOOD (map success-dir '(0 1))) (define (cleanup-submission-body) ;; Find the newest SUCCESS dir -- ignore ATTEMPT, since if it exist it @@ -164,18 +137,13 @@ (map (lambda (u) (string-append "+" u)) (cdr users)))) (provide get-user-assignment-directory) -(define user-assignment-directory (make-parameter #f)) -(define (get-user-assignment-directory) (user-assignment-directory)) (provide get-assignment-name) -(define assignment-name (make-parameter #f)) -(define (get-assignment-name) (assignment-name)) (provide get-submit-on-error?) -(define current-submission-data (make-parameter #f)) -(define (get-submit-on-error?) - (equal? (a-ref (current-submission-data) 'submit-on-error "no") "yes")) + + (define (accept-specific-submission data r r-safe w) ;; Note: users are always sorted (define users (a-ref data 'usernames)) @@ -231,44 +199,37 @@ ;; Clear out old ATTEMPT, if any, and make a new one: (when (directory-exists? ATTEMPT-DIR) (delete-directory/files ATTEMPT-DIR)) + + (log-line "creating attempt-dir ~s" ATTEMPT-DIR) (make-directory ATTEMPT-DIR) (save-submission s (build-path ATTEMPT-DIR "handin")) (timeout-control 'reset) (log-line "checking ~a for ~a" assignment users) (let* ([checker* (path->complete-path (build-path 'up "checker.rkt"))] - [checker* (and (file-exists? checker*) - (parameterize ([current-directory server-dir]) - (auto-reload-value - `(file ,(path->string checker*)) - 'checker)))]) - (parameterize ([user-assignment-directory (path->complete-path (build-path 'same))] - [assignment-name assignment]) - (define-values (pre checker post) - (cond [(not checker*) (values #f #f #f)] - [(procedure? checker*) (values #f checker* #f)] - [(and (list? checker*) (= 3 (length checker*))) - (apply values checker*)] - [else (error* "bad checker value: ~e" checker*)])) - (when pre - (let ([dir (current-directory)]) - (with-handlers - ([void (lambda (e) - (parameterize ([current-directory dir]) - (unless (ormap (lambda (d) - (and (directory-exists? d) - (regexp-match - SUCCESS-RE - (path->string d)))) - (directory-list)) - (parameterize ([current-directory ".."]) - (when (directory-exists? dirname) - (delete-directory/files dirname))))) - (raise e))]) - (parameterize ([current-directory ATTEMPT-DIR]) - (pre users s))))) + [checker-place + (and (file-exists? checker*) + (start-place checker* server-dir assignment ATTEMPT-DIR dirname))]) + (log-line "place started: ~s" checker-place) + (define-values (pre checker post) + (cond [(not checker-place) (values #f #f #f)] + [else (match (place-channel-get checker-place) + [(cons 'exn e) + (error* "place startup failed: ~s" e)] + [(list pre checker post) + (define (f sym) + (and sym + (lambda args + (place-channel-put checker-place (cons sym args)) + (define r + (place-channel-get checker-place)) + (if (and (pair? r) (eq? 'exn (car r))) + (error (string-append "remote checker raised exception:\n" + (cdr r))) + r)))) + (values (f pre) (f checker) (f post))] + [m (error* "bad checker value: ~s" m)])])) (let ([part (if checker - (parameterize ([current-directory ATTEMPT-DIR]) - (checker users s)) + (checker users s) (get-conf 'default-file-name))]) (write+flush w 'confirm) (let ([v (read (make-limited-input-port r 50))]) @@ -286,9 +247,8 @@ (hook 'submission-committed `([usernames ,users] [assignment ,assignment])) (when post - (parameterize ([current-directory (success-dir 0)]) - (post users s)))) - (error* "upload not confirmed: ~s" v)))))))))) + (post users s (success-dir 0)))) + (error* "upload not confirmed: ~s" v))))))))) (define (retrieve-specific-submission data w) ;; Note: users are always sorted @@ -722,35 +682,36 @@ r w))) (define default-context-length (error-print-context-length)) -(parameterize ([error-display-handler (lambda (msg exn) (log-line msg))] - [error-print-context-length 0] - [current-directory server-dir]) - (define port (get-conf 'port-number)) - (define (start-notify) - (log-line "*** handin server started on port ~a" port) - (hook 'server-start `([port ,port]))) - (run-server - port - (lambda (r w) - (error-print-context-length default-context-length) - (handle-*-request r w) - ;; This close-output-port should not be necessary, and it's here - ;; due to a deficiency in the SSL binding. The problem is that a - ;; custodian shutdown of w is harsher for SSL output than a normal - ;; close. A normal close flushes an internal buffer that's not - ;; supposed to exist, while the shutdown gives up immediately. - (close-output-port w)) - #f ; `with-watcher' handles our timeouts - (lambda (exn) - (log-line "ERROR: ~a" (if (exn? exn) (exn-message exn) exn))) - (lambda (port-k cnt reuse?) - (let ([l (ssl-listen port-k 128 #t)]) - (ssl-load-certificate-chain! l "server-cert.pem") - (ssl-load-private-key! l "private-key.pem") - (start-notify) - l)) - (lambda (l) - (log-line "shutting down") - (web-controller 'shutdown) - (ssl-close l)) - ssl-accept ssl-accept/enable-break)) +(module+ main + (parameterize ([error-display-handler (lambda (msg exn) (log-line msg))] + [error-print-context-length 0] + [current-directory server-dir]) + (define port (get-conf 'port-number)) + (define (start-notify) + (log-line "*** handin server started on port ~a" port) + (hook 'server-start `([port ,port]))) + (run-server + port + (lambda (r w) + (error-print-context-length default-context-length) + (handle-*-request r w) + ;; This close-output-port should not be necessary, and it's here + ;; due to a deficiency in the SSL binding. The problem is that a + ;; custodian shutdown of w is harsher for SSL output than a normal + ;; close. A normal close flushes an internal buffer that's not + ;; supposed to exist, while the shutdown gives up immediately. + (close-output-port w)) + #f ; `with-watcher' handles our timeouts + (lambda (exn) + (log-line "ERROR: ~a" (if (exn? exn) (exn-message exn) exn))) + (lambda (port-k cnt reuse?) + (let ([l (ssl-listen port-k 128 #t)]) + (ssl-load-certificate-chain! l "server-cert.pem") + (ssl-load-private-key! l "private-key.pem") + (start-notify) + l)) + (lambda (l) + (log-line "shutting down") + (web-controller 'shutdown) + (ssl-close l)) + ssl-accept ssl-accept/enable-break))) diff --git a/handin-server/private/config.rkt b/handin-server/private/config.rkt index bdcc875..17a0231 100644 --- a/handin-server/private/config.rkt +++ b/handin-server/private/config.rkt @@ -1,131 +1,141 @@ #lang racket/base (require racket/file) +(provide get-conf assignment<->dir) -;; This module should be invoked when we're in the server directory -(provide server-dir) -(define server-dir - (let ([dir (or (getenv "PLT_HANDINSERVER_DIR") (current-directory))]) - (if (directory-exists? dir) - dir - (error 'config "handin server directory does not exist: ~e" dir)))) - -(define config-file (path->complete-path "config.rktd" server-dir)) - -(define poll-freq 2000.0) ; poll at most once every two seconds +(module pure racket/base + (provide (all-defined-out)) + (require racket/file) + (define config-file #f) + (define server-dir #f) + (define (set-server-dir v) + (set! server-dir v) + (set! config-file (path->complete-path "config.rktd" server-dir))) + + (define poll-freq 2000.0) ; poll at most once every two seconds -(define last-poll #f) -(define last-filetime #f) -(define raw-config #f) -(define config-cache #f) + (define last-poll #f) + (define last-filetime #f) + (define raw-config #f) + (define config-cache #f) -(provide get-conf) -(define (get-conf key) - (unless (and raw-config - (< (- (current-inexact-milliseconds) last-poll) poll-freq)) - (set! last-poll (current-inexact-milliseconds)) - (let ([filetime (file-or-directory-modify-seconds config-file)]) - (unless (and filetime (equal? filetime last-filetime)) - (set! last-filetime filetime) - (with-handlers + (provide get-conf) + (define (get-conf key) + (unless (and raw-config + (< (- (current-inexact-milliseconds) last-poll) poll-freq)) + (set! last-poll (current-inexact-milliseconds)) + (let ([filetime (file-or-directory-modify-seconds config-file)]) + (unless (and filetime (equal? filetime last-filetime)) + (set! last-filetime filetime) + (with-handlers ([void (lambda (e) (raise-user-error 'get-conf "could not read conf (~a): ~a" config-file (exn-message e)))]) - (when raw-config - ;; can't use log-line from logger, since it makes a cycle, - ;; but make sure it's written in one shot; in any case, don't - ;; write anything if this is the first read, since the logger - ;; is not initialized yet (and if there's an error at this - ;; stage, the server will exit) - (eprintf (format "reloading configuration from ~a\n" config-file))) - (let ([c (with-input-from-file config-file read)]) - (if (and (list? c) - (andmap (lambda (x) - (and (pair? x) (symbol? (car x)))) - c)) - (set! raw-config c) - (raise-user-error - 'get-conf "malformed configuration file content")))) - (set! config-cache (make-hasheq))))) - (hash-ref config-cache key - (lambda () - (define-values [default translate] (config-default+translate key)) - (define v - (case translate - ;; #f => computed value => return untranslated default w/out lookup - [(#f) default] - ;; #t => user key => return raw value or error - [(#t) (cond [(assq key raw-config) => cadr] - [else (raise-user-error - 'get-conf "no value for key: ~e" key)])] - [else (translate (cond [(assq key raw-config) => cadr] - [else default]))])) - (hash-set! config-cache key v) - v))) + (when raw-config + ;; can't use log-line from logger, since it makes a cycle, + ;; but make sure it's written in one shot; in any case, don't + ;; write anything if this is the first read, since the logger + ;; is not initialized yet (and if there's an error at this + ;; stage, the server will exit) + (eprintf (format "reloading configuration from ~a\n" config-file))) + (let ([c (with-input-from-file config-file read)]) + (if (and (list? c) + (andmap (lambda (x) + (and (pair? x) (symbol? (car x)))) + c)) + (set! raw-config c) + (raise-user-error + 'get-conf "malformed configuration file content")))) + (set! config-cache (make-hasheq))))) + (hash-ref config-cache key + (lambda () + (define-values [default translate] (config-default+translate key)) + (define v + (case translate + ;; #f => computed value => return untranslated default w/out lookup + [(#f) default] + ;; #t => user key => return raw value or error + [(#t) (cond [(assq key raw-config) => cadr] + [else (raise-user-error + 'get-conf "no value for key: ~e" key)])] + [else (translate (cond [(assq key raw-config) => cadr] + [else default]))])) + (hash-set! config-cache key v) + v))) -(define (id x) x) -(define (rx s) (if (regexp? s) s (regexp s))) -(define (path p) (path->complete-path p server-dir)) -(define (path/false p) (and p (path p))) -(define (path-list l) (map path l)) -(define (maybe-strs l) (and l (pair? l) (map string->bytes/utf-8 l))) + (define (id x) x) + (define (rx s) (if (regexp? s) s (regexp s))) + (define (path p) (path->complete-path p server-dir)) + (define (path/false p) (and p (path p))) + (define (path-list l) (map path l)) + (define (maybe-strs l) (and l (pair? l) (map string->bytes/utf-8 l))) -(define (config-default+translate which) - ;; translate = #f => a computed value (so no lookup or translation) - ;; = #t => an unknown key (raw return value) - (case which - [(active-dirs) (values '() path-list )] - [(inactive-dirs) (values '() path-list )] - [(port-number) (values 7979 id )] - [(use-https) (values #t id )] - [(hook-file) (values #f path/false )] - [(session-timeout) (values 300 id )] - [(session-memory-limit) (values 40000000 id )] - [(default-file-name) (values "handin.rkt" id )] - [(max-upload) (values 500000 id )] - [(max-upload-keep) (values 9 id )] - [(user-regexp) (values #rx"^[a-z][a-z0-9]+$" rx )] - [(user-desc) (values "alphanumeric string" id )] - [(username-case-sensitive) (values #f id )] - [(allow-new-users) (values #f id )] - [(allow-change-info) (values #f id )] - [(allow-web-upload) (values #f maybe-strs )] - [(master-password) (values #f id )] - [(log-output) (values #t id )] - [(log-file) (values "log" path/false )] - [(web-log-file) (values #f path/false )] - [(extra-fields) - (values '(("Full Name" #f #f) - ("ID#" #f #f) - ("Email" #rx"^[^@<>\"`',]+@[a-zA-Z0-9_.-]+[.][a-zA-Z]+$" - "a valid email address")) - id)] - ;; computed from the above (mark by translate = #f) - [(all-dirs) - (values (append (get-conf 'active-dirs) (get-conf 'inactive-dirs)) #f)] - [(names-dirs) ; see below - (values (paths->map (get-conf 'all-dirs)) #f)] - [(user-fields) - (values (filter (lambda (f) (not (eq? '- (cadr f)))) - (get-conf 'extra-fields)) - #f)] - [else (values #f #t)])) + (define (config-default+translate which) + ;; translate = #f => a computed value (so no lookup or translation) + ;; = #t => an unknown key (raw return value) + (case which + [(active-dirs) (values '() path-list )] + [(inactive-dirs) (values '() path-list )] + [(port-number) (values 7979 id )] + [(use-https) (values #t id )] + [(hook-file) (values #f path/false )] + [(session-timeout) (values 300 id )] + [(session-memory-limit) (values 40000000 id )] + [(default-file-name) (values "handin.rkt" id )] + [(max-upload) (values 500000 id )] + [(max-upload-keep) (values 9 id )] + [(user-regexp) (values #rx"^[a-z][a-z0-9]+$" rx )] + [(user-desc) (values "alphanumeric string" id )] + [(username-case-sensitive) (values #f id )] + [(allow-new-users) (values #f id )] + [(allow-change-info) (values #f id )] + [(allow-web-upload) (values #f maybe-strs )] + [(master-password) (values #f id )] + [(log-output) (values #t id )] + [(log-file) (values "log" path/false )] + [(web-log-file) (values #f path/false )] + [(extra-fields) + (values '(("Full Name" #f #f) + ("ID#" #f #f) + ("Email" #rx"^[^@<>\"`',]+@[a-zA-Z0-9_.-]+[.][a-zA-Z]+$" + "a valid email address")) + id)] + ;; computed from the above (mark by translate = #f) + [(all-dirs) + (values (append (get-conf 'active-dirs) (get-conf 'inactive-dirs)) #f)] + [(names-dirs) ; see below + (values (paths->map (get-conf 'all-dirs)) #f)] + [(user-fields) + (values (filter (lambda (f) (not (eq? '- (cadr f)))) + (get-conf 'extra-fields)) + #f)] + [else (values #f #t)])) -;; This is used below to map names to submission directory paths and back -;; returns a (list-of (either (list name path) (list path name))) -(define (paths->map dirs) - (define (path->name dir) - (unless (directory-exists? dir) - (if (file-exists? dir) - (error 'get-conf "directory entry points at a file: ~e" dir) - (make-directory* dir))) - (let-values ([(_1 name _2) (split-path dir)]) - (path-element->string name))) - (let ([names (map path->name dirs)]) - (append (map list names dirs) (map list dirs names)))) + ;; This is used below to map names to submission directory paths and back + ;; returns a (list-of (either (list name path) (list path name))) + (define (paths->map dirs) + (define (path->name dir) + (unless (directory-exists? dir) + (if (file-exists? dir) + (error 'get-conf "directory entry points at a file: ~e" dir) + (make-directory* dir))) + (let-values ([(_1 name _2) (split-path dir)]) + (path-element->string name))) + (let ([names (map path->name dirs)]) + (append (map list names dirs) (map list dirs names)))) -;; Translates an assignment name to a directory path or back -(provide assignment<->dir) -(define (assignment<->dir a/d) - (cond [(assoc a/d (get-conf 'names-dirs)) => cadr] - [else (error 'assignment<->dir "internal error: ~e" a/d)])) + ;; Translates an assignment name to a directory path or back + (provide assignment<->dir) + (define (assignment<->dir a/d) + (cond [(assoc a/d (get-conf 'names-dirs)) => cadr] + [else (error 'assignment<->dir "internal error: ~e" a/d)]))) + + +;; This module should be invoked when we're in the server directory +(provide server-dir) +(require (submod "." pure)) +(set-server-dir + (let ([dir (or (getenv "PLT_HANDINSERVER_DIR") (current-directory))]) + (if (directory-exists? dir) + dir + (error 'config "handin server directory does not exist: ~e" dir)))) diff --git a/handin-server/private/constants.rkt b/handin-server/private/constants.rkt new file mode 100644 index 0000000..79d40f3 --- /dev/null +++ b/handin-server/private/constants.rkt @@ -0,0 +1,50 @@ +#lang racket/base + +(require "config.rkt" + racket/file) + +(provide (all-defined-out)) +(define ATTEMPT-DIR "ATTEMPT") +(define (success-dir n) (format "SUCCESS-~a" n)) + +(define (make-success-dir-available n) + (let ([name (success-dir n)]) + (when (directory-exists? name) + (if (< n (get-conf 'max-upload-keep)) + (begin (make-success-dir-available (add1 n)) + (rename-file-or-directory name (success-dir (add1 n)))) + (delete-directory/files name))))) + +(define ATTEMPT-RE (regexp (format "^~a$" ATTEMPT-DIR))) +(define SUCCESS-RE (regexp (format "^~a$" (success-dir "[0-9]+")))) +(define SUCCESS-GOOD (map success-dir '(0 1))) + + +(define user-assignment-directory (make-parameter #f)) +(define (get-user-assignment-directory) (user-assignment-directory)) + +(define assignment-name (make-parameter #f)) +(define (get-assignment-name) (assignment-name)) + +(define current-submission-data (make-parameter #f)) +(define (get-submit-on-error?) + (equal? (a-ref (current-submission-data) 'submit-on-error "no") "yes")) + + +;; errors to the user: no need for a "foo: " prefix +(define (error* fmt . args) + (error (apply format fmt args))) + +(define (write+flush port . xs) + (for ([x (in-list xs)]) (write x port) (newline port)) + (flush-output port)) + +(define-struct alist (name [l #:mutable])) +(define (a-set! alist key val) + (let ([l (alist-l alist)]) + (cond [(assq key l) => (lambda (p) (set-box! (cdr p) val))] + [else (set-alist-l! alist (cons (cons key (box val)) l))]))) +(define (a-ref alist key . default) + (cond [(assq key (alist-l alist)) => (lambda (x) (unbox (cdr x)))] + [(pair? default) (car default)] + [else (error (alist-name alist) "no value for `~s'" key)])) diff --git a/handin-server/private/place.rkt b/handin-server/private/place.rkt new file mode 100644 index 0000000..1889ee0 --- /dev/null +++ b/handin-server/private/place.rkt @@ -0,0 +1,85 @@ +#lang racket/base + +(require racket/place + racket/match + racket/file + racket/format + racket/place + racket/port + "logger.rkt" + "reloadable.rkt" + (submod "config.rkt" pure) + "constants.rkt") + +(define (checker-place-loop ch checker-path server-dir assignment ATTEMPT-DIR dirname) + (define (run-checker-place pre checker post) + (match (place-channel-get ch) + [(list 'pre users s) + (when pre + (let ([dir (current-directory)]) + (with-handlers + ([void (lambda (e) + (parameterize ([current-directory dir]) + (unless (ormap (lambda (d) + (and (directory-exists? d) + (regexp-match + SUCCESS-RE + (path->string d)))) + (directory-list)) + (parameterize ([current-directory ".."]) + (when (directory-exists? dirname) + (delete-directory/files dirname))))) + (raise e))]) + (parameterize ([current-directory ATTEMPT-DIR]) + (pre users s)))))] + [(list 'checker users s) + (define result + (parameterize ([current-directory ATTEMPT-DIR]) + (checker users s))) + (if (string? result) + (place-channel-put ch result) + (place-channel-put ch "handin"))] + [(list 'post users s dir) + (parameterize ([current-directory dir]) + (and post (post users s dir)))] + ['stop 'stop])) + + + (define checker* + (parameterize ([current-directory server-dir]) + (auto-reload-value + `(file ,(path->string checker-path)) + 'checker))) + (parameterize ([user-assignment-directory (path->complete-path (build-path 'same))] + [assignment-name assignment] + [current-directory dirname]) + (define-values (pre checker post) + (cond [(not checker*) (values #f #f #f)] + [(procedure? checker*) (values #f checker* #f)] + [(and (list? checker*) (= 3 (length checker*))) + (apply values checker*)] + [else (place-channel-put (~e checker*)) + (error* "bad checker value: ~e" checker*)])) + (place-channel-put ch (list (and pre 'pre) + (and checker 'checker) + (and post 'post))) + (let loop () + (define v (with-handlers ([void (lambda (e) + (log-line "error was raised: ~s" e) + (place-channel-put ch (cons 'exn (exn-message e))) + 'stop)]) + (run-checker-place pre checker post))) + + (unless (eq? v 'stop) (loop))))) + + +(provide start-place) +(define (start-place checker* server-dir assignment ATTEMPT-DIR dirname) + (define d (current-directory)) + (place/context p + (parameterize ([current-directory d]) + (with-handlers ([void (lambda (e) + (log-line "error was raised: ~s" e) + (place-channel-put p (cons 'exn (exn-message e))) + 'stop)]) + (checker-place-loop p checker* server-dir assignment ATTEMPT-DIR dirname)))))