90 lines
2.7 KiB
Scheme
90 lines
2.7 KiB
Scheme
|
|
(module client mzscheme
|
|
(require (lib "mzssl.ss" "openssl"))
|
|
|
|
(provide handin-connect
|
|
submit-assignment
|
|
submit-addition
|
|
submit-password-change)
|
|
|
|
(define-struct handin (r w))
|
|
|
|
(define (write+flush port . xs)
|
|
(for-each (lambda (x) (write x port) (newline port)) xs)
|
|
(flush-output port))
|
|
|
|
(define (handin-connect server port pem)
|
|
(let ([ctx (ssl-make-client-context)])
|
|
(ssl-set-verify! ctx #t)
|
|
(ssl-load-verify-root-certificates! ctx pem)
|
|
(let-values ([(r w) (ssl-connect server port ctx)])
|
|
;; Sanity check: server sends "handin", first:
|
|
(let ([s (read-bytes 6 r)])
|
|
(unless (equal? #"handin" s)
|
|
(error 'handin-connect "bad handshake from server: ~e" s)))
|
|
;; Tell server protocol = 'original:
|
|
(write+flush w 'original)
|
|
;; One more sanity check: server recognizes protocol:
|
|
(let ([s (read r)])
|
|
(unless (eq? s 'original)
|
|
(error 'handin-connect "bad protocol from server: ~e" s)))
|
|
;; Return connection and list of active assignments:
|
|
(values (make-handin r w)
|
|
(let ([v (read r)])
|
|
(unless (and (list? v)
|
|
(andmap string? v))
|
|
(error 'handin-connect "failed to get active-assignment list from server"))
|
|
v)))))
|
|
|
|
(define (submit-assignment h username passwd assignment content on-commit)
|
|
(let ([r (handin-r h)]
|
|
[w (handin-w h)])
|
|
(write+flush w username passwd assignment)
|
|
(let ([v (read r)])
|
|
(unless (eq? v 'ok)
|
|
(error 'handin-connect "login error: ~a" v)))
|
|
(write+flush w (bytes-length content))
|
|
(let ([v (read r)])
|
|
(unless (eq? v 'go)
|
|
(error 'handin-connect "upload error: ~a" v)))
|
|
(fprintf w "$")
|
|
(display content w)
|
|
(flush-output w)
|
|
(let ([v (read r)])
|
|
(unless (eq? v 'confirm)
|
|
(error 'handin-connect "submit error: ~a" v)))
|
|
(on-commit)
|
|
(write+flush w 'check)
|
|
(let ([result-msg
|
|
(let ([v (read r)])
|
|
(cond
|
|
[(eq? v 'done) #f]
|
|
[(and (pair? v) (eq? (car v) 'result))
|
|
(cadr v)]
|
|
[else
|
|
(error 'handin-connect "commit probably unsucccesful: ~e" v)]))])
|
|
(close-input-port r)
|
|
(close-output-port w)
|
|
result-msg)))
|
|
|
|
|
|
(define (submit-addition h username full-name id email passwd)
|
|
(let ([r (handin-r h)]
|
|
[w (handin-w h)])
|
|
(write+flush w username 'create full-name id email passwd)
|
|
(let ([v (read r)])
|
|
(unless (eq? v 'ok)
|
|
(error 'handin-connect "update error: ~a" v)))
|
|
(close-input-port r)
|
|
(close-output-port w)))
|
|
|
|
(define (submit-password-change h username old-passwd new-passwd)
|
|
(let ([r (handin-r h)]
|
|
[w (handin-w h)])
|
|
(write+flush w username old-passwd 'change new-passwd)
|
|
(let ([v (read r)])
|
|
(unless (eq? v 'ok)
|
|
(error 'handin-connect "update error: ~a" v)))
|
|
(close-input-port r)
|
|
(close-output-port w))))
|