684 lines
30 KiB
Scheme
684 lines
30 KiB
Scheme
#cs
|
|
(module handin-server mzscheme
|
|
(require (lib "thread.ss")
|
|
(lib "port.ss")
|
|
(lib "mzssl.ss" "openssl")
|
|
(lib "file.ss")
|
|
(lib "date.ss")
|
|
(lib "list.ss")
|
|
(lib "string.ss")
|
|
"md5.ss"
|
|
"lock.ss"
|
|
"web-status-server.ss"
|
|
"run-status.ss")
|
|
|
|
(define log-port (open-output-file "log.ss" 'append))
|
|
|
|
(define current-session (make-parameter 0))
|
|
|
|
(define (write+flush port . xs)
|
|
(for-each (lambda (x) (write x port) (newline port)) xs)
|
|
(flush-output port))
|
|
|
|
(define-struct alist (name l))
|
|
(define (a-set! alist key val)
|
|
(let ([l (alist-l alist)])
|
|
(cond [(assq key l) => (lambda (p) (set-cdr! p val))]
|
|
[else (set-alist-l! alist (cons (cons key val) l))])))
|
|
(define (a-ref alist key . default)
|
|
(cond [(assq key (alist-l alist)) => cdr]
|
|
[(pair? default) (car default)]
|
|
[else (error (alist-name alist) "no value for `~s'" key)]))
|
|
|
|
(provide LOG)
|
|
(define (LOG str . args)
|
|
;; Assemble log into into a single string, to make
|
|
;; interleaved log lines unlikely:
|
|
(let ([line
|
|
(format "(~a ~s ~s)\n"
|
|
(current-session)
|
|
(parameterize ([date-display-format 'iso-8601])
|
|
(date->string (seconds->date (current-seconds)) #t))
|
|
(apply format str args))])
|
|
(display line log-port)
|
|
(flush-output log-port)))
|
|
|
|
(define server-dir (current-directory))
|
|
(define config-file (build-path server-dir "config.ss"))
|
|
(unless (file-exists? config-file)
|
|
(error 'handin-server
|
|
"must be started from a properly configured directory"))
|
|
|
|
(define (get-config which default)
|
|
(get-preference which (lambda () default) #f config-file))
|
|
|
|
(define PORT-NUMBER (get-config 'port-number 7979))
|
|
(define HTTPS-PORT-NUMBER (get-config 'https-port-number (add1 PORT-NUMBER)))
|
|
(define SESSION-TIMEOUT (get-config 'session-timeout 300))
|
|
(define SESSION-MEMORY-LIMIT (get-config 'session-memory-limit 40000000))
|
|
(define DEFAULT-FILE-NAME (get-config 'default-file-name "handin.scm"))
|
|
(define MAX-UPLOAD (get-config 'max-upload 500000))
|
|
(define MAX-UPLOAD-KEEP (get-config 'max-upload-keep 9))
|
|
(define USER-REGEXP (get-config 'user-regexp #rx"^[a-z][a-z0-9]+$"))
|
|
(define USER-DESC (get-config 'user-desc "alphanumeric string"))
|
|
(define USERNAME-CASE-SENSITIVE? (get-config 'username-case-sensitive? #f))
|
|
(define ALLOW-NEW-USERS? (get-config 'allow-new-users #f))
|
|
(define ALLOW-CHANGE-INFO? (get-config 'allow-change-info #f))
|
|
(define MASTER-PASSWD (get-config 'master-password #f))
|
|
(define EXTRA-FIELDS
|
|
(get-config 'extra-fields
|
|
'(("Full Name" #f #f)
|
|
("ID#" #f #f)
|
|
("Email" #rx"^[^@<>\"`',]+@[a-zA-Z0-9_.-]+[.][a-zA-Z]+$"
|
|
"a valid email address"))))
|
|
|
|
(define orig-custodian (current-custodian))
|
|
|
|
;; On startup, check that the users file is not locked:
|
|
(put-preferences null null
|
|
(lambda (f)
|
|
(delete-file f)
|
|
(put-preferences null null
|
|
(lambda (f)
|
|
(error 'handin-server
|
|
"unable to clean up lock file: ~s" f))
|
|
"users.ss"))
|
|
"users.ss")
|
|
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(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 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
|
|
;; means that there was a failed submission and the next one will
|
|
;; re-create ATTEMPT.
|
|
(let* ([dirlist (map path->string (directory-list))]
|
|
[dir (quicksort
|
|
(filter (lambda (d)
|
|
(and (directory-exists? d)
|
|
(regexp-match SUCCESS-RE d)))
|
|
dirlist)
|
|
string<?)]
|
|
[dir (and (pair? dir) (car dir))])
|
|
(when dir
|
|
(unless (member dir SUCCESS-GOOD)
|
|
(LOG "*** USING AN UNEXPECTED SUBMISSION DIRECTORY: ~a"
|
|
(build-path (current-directory) dir)))
|
|
;; We have a submission directory -- copy all newer things (extra
|
|
;; things that exist in the main submission directory but not in
|
|
;; SUCCESS, or things that are newer in the main submission
|
|
;; directory are kept (but subdirs in SUCCESS will are copied as
|
|
;; is))
|
|
(for-each
|
|
(lambda (f)
|
|
(define dir/f (build-path dir f))
|
|
(cond [(not (or (file-exists? f) (directory-exists? f)))
|
|
;; f is in dir but not in the working directory
|
|
(copy-directory/files dir/f f)]
|
|
[(or (<= (file-or-directory-modify-seconds f)
|
|
(file-or-directory-modify-seconds dir/f))
|
|
(and (file-exists? f) (file-exists? dir/f)
|
|
(not (= (file-size f) (file-size dir/f)))))
|
|
;; f is newer in dir than in the working directory
|
|
(delete-directory/files f)
|
|
(copy-directory/files dir/f f)]))
|
|
(directory-list dir)))))
|
|
|
|
(define cleanup-sema (make-semaphore 1))
|
|
(define (cleanup-submission dir)
|
|
;; This is called at a lock cleanup, so it is important that it does not
|
|
;; throw an exception, or the whole server will be locked down. It is
|
|
;; invoked just before the lock is released, so fine to assume that we have
|
|
;; exclusive access to the directory contents.
|
|
(with-handlers ([void
|
|
(lambda (e)
|
|
(LOG "*** ERROR DURING (cleanup-submission ~s) : ~a"
|
|
dir (if (exn? e) (exn-message e) e)))])
|
|
(when (directory-exists? dir) ; submissions can fail before mkdir
|
|
(parameterize ([current-directory dir])
|
|
(call-with-semaphore cleanup-sema cleanup-submission-body)))))
|
|
|
|
(define (cleanup-all-submissions)
|
|
(LOG "Cleaning up all submission directories")
|
|
(for-each (lambda (top)
|
|
(when (directory-exists? top)
|
|
(parameterize ([current-directory top])
|
|
(for-each (lambda (pset)
|
|
(when (directory-exists? pset) ; filter non-dirs
|
|
(parameterize ([current-directory pset])
|
|
(for-each (lambda (sub)
|
|
(when (directory-exists? sub)
|
|
(cleanup-submission sub)))
|
|
(directory-list)))))
|
|
(directory-list)))))
|
|
'("active" "inactive")))
|
|
|
|
;; On startup, we scan all submissions, then repeat at random intervals (only
|
|
;; if clients connected in that time), and check often for changes in the
|
|
;; active/inactive directories and run a cleanup if there was a change
|
|
(define connection-num 0)
|
|
(thread (lambda ()
|
|
(define last-active/inactive #f)
|
|
(define last-connection-num #f)
|
|
(let loop ()
|
|
(let loop ([n (+ 20 (random 20))]) ; 10-20 minute delay
|
|
(when (>= n 0)
|
|
(let ([new (map (lambda (x)
|
|
(if (directory-exists? x)
|
|
(directory-list x)
|
|
null))
|
|
'("active" "inactive"))])
|
|
(if (equal? new last-active/inactive)
|
|
(begin (sleep 30) (loop (sub1 n)))
|
|
(begin (set! last-active/inactive new)
|
|
(set! last-connection-num #f))))))
|
|
(unless (equal? last-connection-num connection-num)
|
|
(cleanup-all-submissions)
|
|
(set! last-connection-num connection-num))
|
|
(loop))))
|
|
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define (save-submission s part)
|
|
(with-output-to-file part
|
|
(lambda () (display s))))
|
|
|
|
(define (accept-specific-submission data r r-safe w)
|
|
;; Note: users are always sorted
|
|
(define users (a-ref data 'usernames))
|
|
(define assignments (a-ref data 'assignments))
|
|
(define assignment (a-ref data 'assignment))
|
|
(define dirname
|
|
(apply string-append (car users)
|
|
(map (lambda (u) (string-append "+" u)) (cdr users))))
|
|
(define len #f)
|
|
(unless (member assignment assignments)
|
|
(error 'handin "not an active assignment: ~a" assignment))
|
|
(LOG "assignment for ~a: ~a" users assignment)
|
|
(write+flush w 'ok)
|
|
(set! len (read r-safe))
|
|
(unless (and (number? len) (integer? len) (positive? len))
|
|
(error 'handin "bad length: ~s" len))
|
|
(unless (len . < . MAX-UPLOAD)
|
|
(error 'handin
|
|
"max handin file size is ~s bytes, file to handin is too big (~s bytes)"
|
|
MAX-UPLOAD len))
|
|
(parameterize ([current-directory (build-path "active" assignment)])
|
|
(wait-for-lock dirname
|
|
(let ([dir (build-path (current-directory) dirname)])
|
|
(lambda () (cleanup-submission dir))))
|
|
(when (and (pair? users) (pair? (cdr users)))
|
|
;; two or more users -- lock each one
|
|
(for-each wait-for-lock users))
|
|
(write+flush w 'go)
|
|
(unless (regexp-match #rx"[$]" r-safe)
|
|
(error 'handin "did not find start-of-content marker"))
|
|
(let ([s (read-bytes len r)])
|
|
(unless (and (bytes? s) (= (bytes-length s) len))
|
|
(error 'handin "error uploading (got ~e, expected ~s bytes)"
|
|
(if (bytes? s) (bytes-length s) s) len))
|
|
;; we have a submission, need to create a directory if needed, make
|
|
;; sure that no users submitted work with someone else
|
|
(unless (directory-exists? dirname)
|
|
(for-each
|
|
(lambda (dir)
|
|
(for-each
|
|
(lambda (d)
|
|
(when (member d users)
|
|
(error 'handin
|
|
"bad submission: ~a has an existing submission (~a)"
|
|
d dir)))
|
|
(regexp-split #rx" *[+] *" (path->string dir))))
|
|
(directory-list))
|
|
(make-directory dirname))
|
|
(parameterize ([current-directory dirname]
|
|
[current-messenger
|
|
(case-lambda
|
|
[(msg) (write+flush w 'message msg)]
|
|
[(msg styles)
|
|
(if (eq? 'final styles)
|
|
(write+flush w 'message-final msg)
|
|
(begin (write+flush w 'message-box msg styles)
|
|
(read (make-limited-input-port r 50))))])])
|
|
;; Clear out old ATTEMPT, if any, and make a new one:
|
|
(when (directory-exists? ATTEMPT-DIR)
|
|
(delete-directory/files ATTEMPT-DIR))
|
|
(make-directory ATTEMPT-DIR)
|
|
(save-submission s (build-path ATTEMPT-DIR "handin"))
|
|
(timeout-control 'reset)
|
|
(LOG "checking ~a for ~a" assignment users)
|
|
(let* ([checker* (path->complete-path (build-path 'up "checker.ss"))]
|
|
[checker* (and (file-exists? checker*)
|
|
(parameterize ([current-directory server-dir])
|
|
(dynamic-require checker* 'checker)))])
|
|
(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 'handin-configuration
|
|
"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 d)))
|
|
(map path->string (directory-list)))
|
|
(parameterize ([current-directory ".."])
|
|
(when (directory-exists? dirname)
|
|
(delete-directory/files dirname)))))
|
|
(raise e))])
|
|
(parameterize ([current-directory ATTEMPT-DIR])
|
|
(pre users s)))))
|
|
(let ([part (if checker
|
|
(parameterize ([current-directory ATTEMPT-DIR])
|
|
(checker users s))
|
|
DEFAULT-FILE-NAME)])
|
|
(write+flush w 'confirm)
|
|
(let ([v (read (make-limited-input-port r 50))])
|
|
(if (eq? v 'check)
|
|
(begin
|
|
(LOG "saving ~a for ~a" assignment users)
|
|
(parameterize ([current-directory ATTEMPT-DIR])
|
|
(rename-file-or-directory "handin" part))
|
|
;; Shift successful-attempt directories so that there's
|
|
;; no SUCCESS-0:
|
|
(make-success-dir-available 0)
|
|
(rename-file-or-directory ATTEMPT-DIR (success-dir 0))
|
|
(when post
|
|
(parameterize ([current-directory (success-dir 0)])
|
|
(post users s))))
|
|
(error 'handin "upload not confirmed: ~s" v)))))))))
|
|
|
|
(define (retrieve-specific-submission data w)
|
|
;; Note: users are always sorted
|
|
(define users (a-ref data 'usernames))
|
|
(define assignments (a-ref data 'assignments))
|
|
(define assignment (a-ref data 'assignment))
|
|
(define dirname
|
|
(apply string-append (car users)
|
|
(map (lambda (u) (string-append "+" u)) (cdr users))))
|
|
(define submission-dir (build-path "active" assignment dirname))
|
|
(unless (member assignment assignments)
|
|
(error 'handin "not an active assignment: ~a" assignment))
|
|
(unless (directory-exists? submission-dir)
|
|
(error 'handin "no ~a submission directory for ~a" assignment users))
|
|
(LOG "retrieving assignment for ~a: ~a" users assignment)
|
|
(parameterize ([current-directory (build-path "active" assignment dirname)])
|
|
(define file
|
|
;; find the newest wxme file
|
|
(let loop ([files (directory-list)] [file #f] [time #f])
|
|
(if (null? files)
|
|
file
|
|
(let ([f (car files)])
|
|
(if (and (file-exists? f)
|
|
(equal? #"WXME" (with-input-from-file f
|
|
(lambda () (read-bytes 4))))
|
|
(or (not file)
|
|
(> (file-or-directory-modify-seconds f) time)))
|
|
(loop (cdr files) f (file-or-directory-modify-seconds f))
|
|
(loop (cdr files) file time))))))
|
|
(if file
|
|
(let ([len (file-size file)])
|
|
(write+flush w len)
|
|
(display "$" w)
|
|
(display (with-input-from-file file (lambda () (read-bytes len))) w)
|
|
(flush-output w))
|
|
(error 'handin "no ~a submission file found for ~a" assignment users))))
|
|
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define (put-user-data username data)
|
|
;; Although we don't have to worry about trashing the
|
|
;; prefs file, we do have to worry about a thread
|
|
;; getting killed while it locks the pref file.
|
|
;; Avoid the problem by using orig-custodian.
|
|
(call-in-nested-thread
|
|
(lambda ()
|
|
(put-preferences
|
|
(list (string->symbol username)) (list data)
|
|
(lambda (f)
|
|
(error 'handin "user database busy; please try again, and alert the adminstrator if problems persist"))
|
|
"users.ss"))
|
|
orig-custodian))
|
|
|
|
(define (get-user-data username)
|
|
(get-preference (string->symbol username) (lambda () #f) #f "users.ss"))
|
|
(define (check-field value field-re field-name field-desc)
|
|
(unless (cond [(or (string? field-re) (regexp? field-re))
|
|
(regexp-match field-re value)]
|
|
[(list? field-re) (member value field-re)]
|
|
[(not field-re) #t]
|
|
[else (error 'handin "bad spec: field-regexp is ~e"
|
|
field-re)])
|
|
(error 'handin "bad ~a: \"~a\"~a" field-name value
|
|
(if field-desc (format "; need ~a" field-desc) ""))))
|
|
|
|
(define (add-new-user data)
|
|
(define username (a-ref data 'username/s))
|
|
(define passwd (a-ref data 'password))
|
|
(define extra-fields (a-ref data 'extra-fields))
|
|
(unless ALLOW-NEW-USERS?
|
|
(error 'handin "new users not allowed: ~a" username))
|
|
(check-field username USER-REGEXP "username" USER-DESC)
|
|
;; Since we're going to use the username in paths, and + to split names:
|
|
(when (regexp-match #rx"[+/\\:|\"<>]" username)
|
|
(error 'handin "username must not contain one of the following: + / \\ : | \" < >"))
|
|
(when (regexp-match
|
|
#rx"^((nul)|(con)|(prn)|(aux)|(clock[$])|(com[1-9])|(lpt[1-9]))[.]?"
|
|
(string-foldcase username))
|
|
(error 'handin "username must not be a Windows special file name"))
|
|
(when (regexp-match #rx"^[ .]|[ .]$" username)
|
|
(error 'handin "username must not begin or end with a space or period"))
|
|
(when (regexp-match #rx"^solution" username)
|
|
(error 'handin "the username prefix \"solution\" is reserved"))
|
|
(when (string=? "checker.ss" username)
|
|
(error 'handin "the username \"checker.ss\" is reserved"))
|
|
(when (get-user-data username)
|
|
(error 'handin "username already exists: `~a'" username))
|
|
(for-each
|
|
(lambda (str info) (check-field str (cadr info) (car info) (caddr info)))
|
|
extra-fields EXTRA-FIELDS)
|
|
(wait-for-lock "+newuser+")
|
|
(LOG "create user: ~a" username)
|
|
(put-user-data username (cons passwd extra-fields)))
|
|
|
|
(define (change-user-info data)
|
|
(define usernames (a-ref data 'usernames))
|
|
(define user-datas (a-ref data 'user-datas))
|
|
(define passwd (a-ref data 'new-password))
|
|
(define extra-fields (a-ref data 'extra-fields))
|
|
(unless (= 1 (length usernames))
|
|
(error 'handin "cannot change a password for multiple users: ~a"
|
|
usernames))
|
|
;; the new data is the same as the old one for every empty string
|
|
(let ([new-data (map (lambda (old new) (if (equal? "" new) old new))
|
|
(car user-datas) (cons passwd extra-fields))])
|
|
(unless (or ALLOW-CHANGE-INFO? (equal? (cdr new-data) (cdar user-datas)))
|
|
(error 'handin "changing information not allowed: ~a" (car usernames)))
|
|
(when (equal? new-data (car user-datas))
|
|
(error 'handin "no fields changed: ~a" (car usernames)))
|
|
(for-each
|
|
(lambda (str info) (check-field str (cadr info) (car info) (caddr info)))
|
|
(cdr new-data) EXTRA-FIELDS)
|
|
(LOG "change info for ~a ~s -> ~s" (car usernames) new-data (car user-datas))
|
|
(put-user-data (car usernames) new-data)))
|
|
|
|
(define (get-user-info data)
|
|
(define usernames (a-ref data 'usernames))
|
|
(unless (= 1 (length usernames))
|
|
(error 'handin "cannot get user-info for multiple users: ~a" usernames))
|
|
(cdar (a-ref data 'user-datas)))
|
|
|
|
(define crypt
|
|
(let ([c #f] [sema (make-semaphore 1)])
|
|
;; use only when needed so it doesn't blow up on non-unix platforms
|
|
(lambda (passwd salt)
|
|
(unless c (set! c (dynamic-require '(lib "crypt.ss" "ffi") 'crypt)))
|
|
;; crypt is not reentrant
|
|
(call-with-semaphore sema
|
|
(lambda () (bytes->string/utf-8 (c passwd salt)))))))
|
|
(define (has-password? raw md5 passwords)
|
|
(define (good? passwd)
|
|
(cond [(string? passwd) (equal? md5 passwd)]
|
|
[(and (list? passwd) (= 2 (length passwd))
|
|
(eq? 'unix (car passwd)) (string? (cadr passwd))
|
|
;; find the salt part
|
|
(regexp-match #rx"^([$][^$]+[$][^$]+[$]|..)" (cadr passwd)))
|
|
=> (lambda (m)
|
|
(equal? (crypt raw (car m)) (cadr passwd)))]
|
|
[else (LOG "ERROR: bad password in user database: ~s" passwd)
|
|
;; do not show the bad password...
|
|
(error 'handin "bad password in user database")]))
|
|
(or (member md5 passwords) ; very cheap search first
|
|
(ormap good? passwords)))
|
|
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define (handle-connection r r-safe w)
|
|
(define msg #f)
|
|
(define active-assignments (assignment-list))
|
|
(define data
|
|
(make-alist 'protocol-data `((assignments . ,active-assignments))))
|
|
(define (perror fmt . args) (apply error 'handin-protocol fmt args))
|
|
(let loop ()
|
|
(set! msg (read r-safe))
|
|
(case msg
|
|
;; ----------------------------------------
|
|
;; getting information from the client
|
|
[(set)
|
|
(let* ([key (read r-safe)] [val (read r-safe)])
|
|
(unless (symbol? key) (perror "bad key value: ~e" key))
|
|
(unless (if (eq? 'extra-fields key)
|
|
(and (list? val)
|
|
(- (length val) (length EXTRA-FIELDS))
|
|
(andmap string? val))
|
|
(string? val))
|
|
(perror "bad value for set: ~e" val))
|
|
(when (a-ref data key #f) (perror "multiple values for ~e" key))
|
|
(case key
|
|
[(username/s)
|
|
(unless USERNAME-CASE-SENSITIVE?
|
|
(set! val (string-foldcase val)))
|
|
(let ([usernames
|
|
;; Username lists must always be sorted, and never empty
|
|
;; (regexp-split will not return an empty list)
|
|
(quicksort (regexp-split #rx" *[+] *" val) string<?)])
|
|
(a-set! data 'usernames usernames)
|
|
(a-set! data 'user-datas (map get-user-data usernames)))]
|
|
[(password new-password)
|
|
;; empty passwords are left empty for change-user-info to re-use
|
|
;; an existing password value
|
|
(when (eq? key 'password) (a-set! data 'raw-password val))
|
|
(unless (equal? "" val) (set! val (md5 val)))]
|
|
[(usernames user-datas raw-password assignments)
|
|
;; forbid setting these directly
|
|
(perror "bad key for `set': ~e" key)])
|
|
(a-set! data key val))
|
|
(loop)]
|
|
;; ----------------------------------------
|
|
;; sending information to the client
|
|
[(get-active-assignments)
|
|
(write+flush w active-assignments)
|
|
(loop)]
|
|
[(get-extra-fields)
|
|
(write+flush w EXTRA-FIELDS)
|
|
(loop)]
|
|
;; ----------------------------------------
|
|
;; action handlers
|
|
;; (don't loop back except get-user-info which needs authorization)
|
|
[(create-user) (add-new-user data)]
|
|
[(bye) #t] ; <- general disconnection
|
|
;; other messages require a login: valid users and a good password
|
|
[else
|
|
(when (eof-object? msg)
|
|
(let ([username/s (a-ref data 'username/s #f)])
|
|
(apply error 'handin
|
|
(if username/s `("hangup (~a)" ,username/s) `("hangup")))))
|
|
(let ([usernames (a-ref data 'usernames #f)]
|
|
[user-datas (a-ref data 'user-datas #f)])
|
|
(when (or (memq #f user-datas)
|
|
(not (has-password?
|
|
(a-ref data 'raw-password)
|
|
(a-ref data 'password)
|
|
(cons MASTER-PASSWD (map car user-datas)))))
|
|
(LOG "failed login: ~a" (a-ref data 'username/s))
|
|
(error 'handin "bad username or password for ~a"
|
|
(a-ref data 'username/s)))
|
|
(LOG "login: ~a" usernames))
|
|
(case msg
|
|
[(change-user-info) (change-user-info data)]
|
|
[(save-submission) (accept-specific-submission data r r-safe w)]
|
|
[(get-submission) (retrieve-specific-submission data w)]
|
|
[(get-user-info) (write+flush w (get-user-info data)) (loop)]
|
|
[else (perror "bad message `~a'" msg)])]))
|
|
(write+flush w 'ok)) ; final confirmation for *all* actions
|
|
|
|
(define (assignment-list)
|
|
(quicksort (map path->string (directory-list "active")) string<?))
|
|
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define no-limit-warning? #f) ; will be set to #t if no memory limits
|
|
|
|
(define current-timeout-control (make-parameter #f))
|
|
(provide timeout-control)
|
|
(define (timeout-control msg)
|
|
(LOG "timeout-control: ~s" msg)
|
|
((current-timeout-control) msg))
|
|
|
|
(define (with-watcher w proc)
|
|
(let ([session-cust (make-custodian)]
|
|
[session-channel (make-channel)]
|
|
[timeout #f]
|
|
[status-box (box #f)])
|
|
(define (timeout-control msg)
|
|
(if (rational? msg)
|
|
(set! timeout (+ (current-inexact-milliseconds) (* 1000 msg)))
|
|
(case msg
|
|
[(reset) (timeout-control SESSION-TIMEOUT)]
|
|
[(disable) (set! timeout #f)]
|
|
[else (error 'timeout-control "bad argument: ~s" msg)])))
|
|
(current-timeout-control timeout-control)
|
|
(timeout-control 'reset)
|
|
(unless no-limit-warning?
|
|
(with-handlers ([exn:fail:unsupported?
|
|
(lambda (x)
|
|
(set! no-limit-warning? #t)
|
|
(LOG "WARNING: per-session memory limit not supported by MrEd"))])
|
|
(custodian-limit-memory session-cust SESSION-MEMORY-LIMIT session-cust)))
|
|
(let* ([watcher
|
|
(parameterize ([current-custodian orig-custodian])
|
|
(thread
|
|
(lambda ()
|
|
(let ([session-thread (channel-get session-channel)])
|
|
(let loop ([timed-out? #f])
|
|
(cond
|
|
[(sync/timeout 3 session-thread)
|
|
(LOG "session killed ~awhile ~s"
|
|
(if timed-out? "(timeout) " "")
|
|
(unbox status-box))
|
|
(write+flush
|
|
w (format "handin terminated due to ~a (program doesn't terminate?)~a"
|
|
(if timed-out? "time limit" "excessive memory use")
|
|
(if (unbox status-box)
|
|
(format " while ~a" (unbox status-box))
|
|
"")))
|
|
(close-output-port w)
|
|
(channel-put session-channel 'done)]
|
|
[(let ([t timeout]) ; grab value to avoid races
|
|
(and t ((current-inexact-milliseconds) . > . t)))
|
|
;; Shutdown here to get the handin-terminated error
|
|
;; message, instead of relying on
|
|
;; SESSION-TIMEOUT at the run-server level
|
|
(custodian-shutdown-all session-cust)
|
|
(loop #t)]
|
|
[else
|
|
(collect-garbage)
|
|
(LOG "running ~a ~a"
|
|
(current-memory-use session-cust)
|
|
(if no-limit-warning?
|
|
"(total)"
|
|
(list (current-memory-use orig-custodian)
|
|
(current-memory-use))))
|
|
(loop #f)]))))))])
|
|
;; Run proc in a thread under session-cust:
|
|
(let ([session-thread
|
|
(parameterize ([current-custodian session-cust]
|
|
[current-run-status-box status-box])
|
|
(thread
|
|
(lambda ()
|
|
(proc (lambda ()
|
|
;; Proc has succeeded...
|
|
(parameterize ([current-custodian orig-custodian])
|
|
(kill-thread watcher))))
|
|
(channel-put session-channel 'done-normal))))])
|
|
(channel-put session-channel session-thread)
|
|
;; Wait until the proc is done or killed (and kill is reported):
|
|
(channel-get session-channel)))))
|
|
|
|
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(LOG "server started ------------------------------")
|
|
|
|
(define stop-status (serve-status HTTPS-PORT-NUMBER get-config))
|
|
|
|
(define session-count 0)
|
|
|
|
(parameterize ([error-display-handler
|
|
(lambda (msg exn)
|
|
(LOG msg))])
|
|
(run-server
|
|
PORT-NUMBER
|
|
(lambda (r w)
|
|
(set! connection-num (add1 connection-num))
|
|
(when ((current-memory-use) . > . SESSION-MEMORY-LIMIT)
|
|
(collect-garbage))
|
|
(parameterize ([current-session (begin
|
|
(set! session-count (add1 session-count))
|
|
session-count)])
|
|
(let-values ([(here there) (ssl-addresses r)])
|
|
(LOG "connect from ~a" there))
|
|
(with-watcher
|
|
w
|
|
(lambda (kill-watcher)
|
|
(let ([r-safe (make-limited-input-port r 2048)])
|
|
(write+flush w 'handin)
|
|
;; Check protocol:
|
|
(with-handlers ([exn:fail?
|
|
(lambda (exn)
|
|
(let ([msg (if (exn? exn)
|
|
(exn-message exn)
|
|
(format "~e" exn))])
|
|
(kill-watcher)
|
|
(LOG "ERROR: ~a" msg)
|
|
(write+flush w msg)
|
|
;; see note on close-output-port below
|
|
(close-output-port w)))])
|
|
(let ([protocol (read r-safe)])
|
|
(if (eq? protocol 'ver1)
|
|
(write+flush w 'ver1)
|
|
(error 'handin "unknown protocol: ~s" protocol)))
|
|
(handle-connection r r-safe w)
|
|
(LOG "normal exit")
|
|
(kill-watcher)
|
|
;; This close-output-port should not be necessary, and it's
|
|
;; here due to a deficiency in the SLL 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)
|
|
(printf "~a\n" (if (exn? exn) (exn-message exn) exn)))
|
|
(lambda (port-k cnt reuse?)
|
|
(let ([l (ssl-listen port-k cnt #t)])
|
|
(ssl-load-certificate-chain! l "server-cert.pem")
|
|
(ssl-load-private-key! l "private-key.pem")
|
|
l))
|
|
ssl-close
|
|
ssl-accept
|
|
ssl-accept/enable-break)))
|