handin server/client fixup
svn: r601
This commit is contained in:
Matthew Flatt
parent
1ba0546d2f
commit
697043dbc1
|
|
@ -15,11 +15,12 @@
|
|||
(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-string 6 r)])
|
||||
(unless (equal? "handin" s)
|
||||
(let ([s (read-bytes 6 r)])
|
||||
(unless (equal? #"handin" s)
|
||||
(error 'handin-connect "bad handshake from server: ~e" s)))
|
||||
;; Tell server protocol = 'original:
|
||||
(fprintf w "original\n")
|
||||
(flush-output w)
|
||||
;; One more sanity check: server recognizes protocol:
|
||||
(let ([s (read r)])
|
||||
(unless (eq? s 'original)
|
||||
|
|
@ -36,20 +37,24 @@
|
|||
(let ([r (handin-r h)]
|
||||
[w (handin-w h)])
|
||||
(fprintf w "~s ~s ~s\n" username passwd assignment)
|
||||
(flush-output w)
|
||||
(let ([v (read r)])
|
||||
(unless (eq? v 'ok)
|
||||
(error 'handin-connect "login error: ~a" v)))
|
||||
(fprintf w "~s\n" (string-length content))
|
||||
(fprintf w "~s\n" (bytes-length content))
|
||||
(flush-output w)
|
||||
(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)
|
||||
(fprintf w "check\n")
|
||||
(flush-output w)
|
||||
(let ([v (read r)])
|
||||
(unless (eq? v 'done)
|
||||
(error 'handin-connect "commit probably unsucccesful: ~e" v)))
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
;; Also replace the "icon.png" and "server-cert.pem" files.
|
||||
(define name "Course Handin")
|
||||
(define collection "handin-client")
|
||||
;; (define server:port "localhost:7979")
|
||||
;(define server:port "localhost:7979")
|
||||
;; --> server:port should be defined here, if it is not defined, not tool
|
||||
;; will appear. To try things, you can set the PLT_HANDIN_SERVER_PORT
|
||||
;; environment variable when this is undefined.
|
||||
|
|
@ -15,7 +15,7 @@
|
|||
;(define web-menu-name "Course Homepage")
|
||||
;(define web-address "http://www.university.edu/course/")
|
||||
|
||||
#;(define tool-icons (list (list "icon.png" collection)))
|
||||
#;(define tools '(("tool.ss")))
|
||||
#;(define tool-names (list name))
|
||||
(define tool-icons (list (list "icon.png" collection)))
|
||||
(define tools '(("tool.ss")))
|
||||
(define tool-names (list name))
|
||||
(define requires '(("mred") ("openssl"))))
|
||||
|
|
|
|||
|
|
@ -1,23 +1,20 @@
|
|||
-----BEGIN CERTIFICATE-----
|
||||
MIIDwDCCAymgAwIBAgIBADANBgkqhkiG9w0BAQQFADCBojELMAkGA1UEBhMCVVMx
|
||||
DTALBgNVBAgTBFV0YWgxFzAVBgNVBAcTDlNhbHQgTGFrZSBDaXR5MRkwFwYDVQQK
|
||||
ExBQTFQgU2NoZW1lLCBJbmMuMQ0wCwYDVQQLEwREZW1vMRswGQYDVQQDExJ3d3cu
|
||||
cGx0LXNjaGVtZS5vcmcxJDAiBgkqhkiG9w0BCQEWFXNjaGVtZUBwbHQtc2NoZW1l
|
||||
Lm9yZzAeFw0wMzA3MjIxNTA0MTdaFw0wNDA3MjExNTA0MTdaMIGiMQswCQYDVQQG
|
||||
EwJVUzENMAsGA1UECBMEVXRhaDEXMBUGA1UEBxMOU2FsdCBMYWtlIENpdHkxGTAX
|
||||
BgNVBAoTEFBMVCBTY2hlbWUsIEluYy4xDTALBgNVBAsTBERlbW8xGzAZBgNVBAMT
|
||||
End3dy5wbHQtc2NoZW1lLm9yZzEkMCIGCSqGSIb3DQEJARYVc2NoZW1lQHBsdC1z
|
||||
Y2hlbWUub3JnMIGfMA0GCSqGSIb3DQEBAQUAA4GNADCBiQKBgQC4/XjGBcwJU/jD
|
||||
4cZRe8LcjrJaWh9F8Nh0j97nGv2JgeLYCJp6oClWBvWLfAs/YBDIMogsN48jjA6n
|
||||
QExslJ6Dk+oriK92EPLlIuiqrHcTif9lHu2H0BarIme4COTVVPmfETXTrDBNxp/D
|
||||
93kzGvXsbxdnO2lSsU3u6hZoj1ZEGwIDAQABo4IBAjCB/zAdBgNVHQ4EFgQU0X7d
|
||||
ycn57T16KLOXUwMM35kdhKEwgc8GA1UdIwSBxzCBxIAU0X7dycn57T16KLOXUwMM
|
||||
35kdhKGhgaikgaUwgaIxCzAJBgNVBAYTAlVTMQ0wCwYDVQQIEwRVdGFoMRcwFQYD
|
||||
VQQHEw5TYWx0IExha2UgQ2l0eTEZMBcGA1UEChMQUExUIFNjaGVtZSwgSW5jLjEN
|
||||
MAsGA1UECxMERGVtbzEbMBkGA1UEAxMSd3d3LnBsdC1zY2hlbWUub3JnMSQwIgYJ
|
||||
KoZIhvcNAQkBFhVzY2hlbWVAcGx0LXNjaGVtZS5vcmeCAQAwDAYDVR0TBAUwAwEB
|
||||
/zANBgkqhkiG9w0BAQQFAAOBgQAJEtqvFtCPszpdUg273+hMC0NMSIINToTqv8+T
|
||||
Knl3yfTJtzdcvFBuTRaYVzPz4YyREx8Y46e5dKSk5Qr2dNogn00yOn6nzzumbkqN
|
||||
hu9gFV5/J9fJtvaQV/hF4ynhpD0M5TSCILdMJIc1Ls70xEtVFHPT51iZev3zDUuN
|
||||
4Xintg==
|
||||
MIIDQjCCAqugAwIBAgIBADANBgkqhkiG9w0BAQQFADB6MQswCQYDVQQGEwJVUzEN
|
||||
MAsGA1UECBMEVXRhaDEMMAoGA1UEBxMDU0xDMRgwFgYDVQQKEw9QTFQgU2NoZW1l
|
||||
IEluYy4xDDAKBgNVBAMTA1BMVDEmMCQGCSqGSIb3DQEJARYXcGx0QHBsc2NoZW1l
|
||||
LXNjaGVtZS5vcmcwHhcNMDUwODE2MTk0ODAzWhcNMTUwODE0MTk0ODAzWjB6MQsw
|
||||
CQYDVQQGEwJVUzENMAsGA1UECBMEVXRhaDEMMAoGA1UEBxMDU0xDMRgwFgYDVQQK
|
||||
Ew9QTFQgU2NoZW1lIEluYy4xDDAKBgNVBAMTA1BMVDEmMCQGCSqGSIb3DQEJARYX
|
||||
cGx0QHBsc2NoZW1lLXNjaGVtZS5vcmcwgZ8wDQYJKoZIhvcNAQEBBQADgY0AMIGJ
|
||||
AoGBAMdLMny/wvHYNxyQZAjI8wwyRzRQalJLgbelm2FU3Iwo2rm+QIw/GEhjXAZP
|
||||
cNT7jQINFX9tWDrcONJJQw6fkGBsawcLdEiojEgRYem8cdq7yLSHR84+qqFDUb3v
|
||||
QvP9oHpsObUqxKCTaeAH8B0818IQfPd/oAHaGHMBB0/csp5vAgMBAAGjgdcwgdQw
|
||||
HQYDVR0OBBYEFMuCBFBMnAfhGRTn5gEODVz0+LVpMIGkBgNVHSMEgZwwgZmAFMuC
|
||||
BFBMnAfhGRTn5gEODVz0+LVpoX6kfDB6MQswCQYDVQQGEwJVUzENMAsGA1UECBME
|
||||
VXRhaDEMMAoGA1UEBxMDU0xDMRgwFgYDVQQKEw9QTFQgU2NoZW1lIEluYy4xDDAK
|
||||
BgNVBAMTA1BMVDEmMCQGCSqGSIb3DQEJARYXcGx0QHBsc2NoZW1lLXNjaGVtZS5v
|
||||
cmeCAQAwDAYDVR0TBAUwAwEB/zANBgkqhkiG9w0BAQQFAAOBgQAhywbndr1xp2Gy
|
||||
jrTiDToZzQCnmhoqJpxb2e71zM3jpQLfdOAF86W196HoIRlwBaKQKzS1rL3ezjqu
|
||||
JALq992K/Bi68LWaA7dekB2EiagNfvtR9vIjBD7Q4Qtp0yjpRV9uLTEfYRff6ecm
|
||||
rSywn1Wmca+PBdVY79TbaeEsgCxt6Q==
|
||||
-----END CERTIFICATE-----
|
||||
|
|
|
|||
|
|
@ -466,7 +466,7 @@
|
|||
(send ed write-to-file stream))
|
||||
editors)
|
||||
(write-editor-global-footer stream)
|
||||
(send base get-string)))
|
||||
(send base get-bytes)))
|
||||
|
||||
(add-test-suite-extension
|
||||
"Handin"
|
||||
|
|
|
|||
|
|
@ -23,7 +23,8 @@
|
|||
(parameterize ([date-display-format 'iso-8601])
|
||||
(date->string (seconds->date (current-seconds)) #t))
|
||||
(apply format str args))])
|
||||
(display line log-port)))
|
||||
(display line log-port)
|
||||
(flush-output log-port)))
|
||||
|
||||
(define (get-config which default)
|
||||
(get-preference which
|
||||
|
|
@ -65,20 +66,21 @@
|
|||
(define backup-dir-re (regexp (format "^~a[0-9]+$" backup-prefix)))
|
||||
(define (backup n) (format "~a~a" backup-prefix n))
|
||||
(define (files+backups)
|
||||
(let* ([files (directory-list)]
|
||||
(let* ([files (map path->string (directory-list))]
|
||||
[backups (filter (lambda (f)
|
||||
(and (directory-exists? f)
|
||||
(regexp-match backup-dir-re f)))
|
||||
files)])
|
||||
(and (directory-exists? f)
|
||||
(regexp-match backup-dir-re f)))
|
||||
files)])
|
||||
(values (remove* backups files) backups)))
|
||||
(define (do-backups)
|
||||
(let-values ([(files backups) (files+backups)])
|
||||
(define (make-backup-available n)
|
||||
(when (member (backup n) backups)
|
||||
(if (< n MAX-UPLOAD-KEEP)
|
||||
(begin (make-backup-available (add1 n))
|
||||
(rename-file-or-directory (backup n) (backup (add1 n))))
|
||||
(delete-directory/files (backup n)))))
|
||||
(begin
|
||||
(make-backup-available (add1 n))
|
||||
(rename-file-or-directory (backup n) (backup (add1 n))))
|
||||
(delete-directory/files (backup n)))))
|
||||
(unless (null? files)
|
||||
(LOG "backing up ~a" files)
|
||||
(make-backup-available 0)
|
||||
|
|
@ -117,14 +119,15 @@
|
|||
"max handin file size is ~s bytes, file to handin is too big (~s bytes)"
|
||||
MAX-UPLOAD len))
|
||||
(fprintf w "go\n")
|
||||
(flush-output w)
|
||||
(unless (regexp-match #rx"[$]" r-safe)
|
||||
(error 'handin
|
||||
"did not find start-of-content marker"))
|
||||
(let ([s (read-string len r)])
|
||||
(unless (and (string? s) (= (string-length s) len))
|
||||
(let ([s (read-bytes len r)])
|
||||
(unless (and (bytes? s) (= (bytes-length s) len))
|
||||
(error 'handin
|
||||
"error uploading (got ~s, expected ~s bytes)"
|
||||
(if (string? s) (string-length s) s)
|
||||
"error uploading (got ~e, expected ~s bytes)"
|
||||
(if (bytes? s) (bytes-length s) s)
|
||||
len))
|
||||
(do-backups)
|
||||
(LOG "checking ~a for ~a" assignment user)
|
||||
|
|
@ -136,12 +139,14 @@
|
|||
user s)
|
||||
DEFAULT-FILE-NAME))])
|
||||
(fprintf w "confirm\n")
|
||||
(flush-output w)
|
||||
(let ([v (read (make-limited-input-port r 50))])
|
||||
(if (eq? v 'check)
|
||||
(begin
|
||||
(LOG "saving ~a for ~a" assignment user)
|
||||
(save-submission s part)
|
||||
(fprintf w "done\n"))
|
||||
(fprintf w "done\n")
|
||||
(flush-output w))
|
||||
(error 'handin "upload not confirmed: ~s" v))))))))))
|
||||
|
||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
|
@ -234,7 +239,7 @@
|
|||
(error 'handin "bad username or password for ~a" username)]))))
|
||||
|
||||
(define assignment-list
|
||||
(quicksort (directory-list "active") string<?))
|
||||
(quicksort (map path->string (directory-list "active")) string<?))
|
||||
|
||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
|
|
@ -322,6 +327,7 @@
|
|||
(lambda (kill-watcher)
|
||||
(let ([r-safe (make-limited-input-port r 1024)])
|
||||
(fprintf w "handin\n")
|
||||
(flush-output w)
|
||||
;; Check protocol:
|
||||
(with-handlers ([exn:fail?
|
||||
(lambda (exn)
|
||||
|
|
@ -331,11 +337,14 @@
|
|||
(kill-watcher)
|
||||
(LOG "ERROR: ~a" msg)
|
||||
(fprintf w "~s\n" msg)
|
||||
(flush-output w)
|
||||
;; see note on close-output-port below
|
||||
(close-output-port w)))])
|
||||
(let ([protocol (read r-safe)])
|
||||
(if (eq? protocol 'original)
|
||||
(fprintf w "original\n")
|
||||
(begin
|
||||
(fprintf w "original\n")
|
||||
(flush-output w))
|
||||
(error 'handin "unknown protocol: ~s" protocol)))
|
||||
(accept-submission-or-update assignment-list r r-safe w)
|
||||
(LOG "normal exit")
|
||||
|
|
@ -352,8 +361,8 @@
|
|||
(printf "~a~n" (if (exn? exn)
|
||||
(exn-message exn)
|
||||
exn)))
|
||||
(lambda (port-k)
|
||||
(let ([l (ssl-listen port-k 5 #t)])
|
||||
(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))
|
||||
|
|
|
|||
|
|
@ -1,15 +1,15 @@
|
|||
-----BEGIN RSA PRIVATE KEY-----
|
||||
MIICXQIBAAKBgQC4/XjGBcwJU/jD4cZRe8LcjrJaWh9F8Nh0j97nGv2JgeLYCJp6
|
||||
oClWBvWLfAs/YBDIMogsN48jjA6nQExslJ6Dk+oriK92EPLlIuiqrHcTif9lHu2H
|
||||
0BarIme4COTVVPmfETXTrDBNxp/D93kzGvXsbxdnO2lSsU3u6hZoj1ZEGwIDAQAB
|
||||
AoGBAIAkLIXXPCf1/+sIOQz2ktufCRKnPOSA2h+cDUa/HoMi8tS82O06hoet2Gcf
|
||||
rNbgn59dyY//iGqSORBH7OiF5mqG1NBid8VQ7G84NB3/mqf/Ex7XUu9ROFJsELN3
|
||||
KDAyIEez5529FGUsCprsYE+WTAv0rZSyMYIxnPpe4/vVrzDRAkEA4hrYzzDkpJRV
|
||||
ZI3XIC3ZIOx7J1tezAahn6TZVTfPd15R0yIP6YdOElwR82MbIcuzWGd2cT7qfGcT
|
||||
hTH4zoNjyQJBANFy+yQ7LQl+fsFAXFl08Hub7EVeqPSuXReIQ9cy4f+7ZpKMueqK
|
||||
FWsDZep3ZD0+ILNuBFYTwhI/kP9oi9OkMsMCQG90DmVrU3lxCPrNFDrvfrVE/Jv0
|
||||
5TCrICZiiyL/pMvReYIaqz9RDAHu0oZn1ur8z0YHkhHWkp2J7cxdSqj5iUkCQBsz
|
||||
Qng3Eyc7fTydniCj9iMnYay0mV6FUmOe96h33C+45546ll5mJlfqbg7gCG2HpvmG
|
||||
XRvMnxR9mtgAfMA0f78CQQCGH8TQySWUkzkIoEKgdExDp/2p28j5Zv90XgcplI3H
|
||||
17MyFm0XUzCfCFIKeuSgLfk/Y2YNhyRr1Oxddd+qPj6/
|
||||
MIICXQIBAAKBgQDHSzJ8v8Lx2DcckGQIyPMMMkc0UGpSS4G3pZthVNyMKNq5vkCM
|
||||
PxhIY1wGT3DU+40CDRV/bVg63DjSSUMOn5BgbGsHC3RIqIxIEWHpvHHau8i0h0fO
|
||||
PqqhQ1G970Lz/aB6bDm1KsSgk2ngB/AdPNfCEHz3f6AB2hhzAQdP3LKebwIDAQAB
|
||||
AoGBAKJ8e+BcFJxL1bszOmwzMn5aK9XKTrVkHJHXsxSrNNoNoS9Zn5T5CFpUsD3w
|
||||
3SS5J6Fpe4KWax4qWSWSV9r/W5zgrYeXA+K8pCdPgmk9ujPUCvxNymdKS+yJncTa
|
||||
bwDMNEWKPpd4MApQbw+Dfj+GGEClMK+mBFUSPMAEwaazHkHZAkEA9ITgFslmdLhc
|
||||
8I7J/lfc3Fm4ytGFk/QC/X5lfNy5/miHjWqH/20R7neimss2GyhdzYtCVyxhzWKz
|
||||
3+q+oQ+R/QJBANCmtm91swqp5XxpZD6K5k3wninPO+od9kDBUvl6kXdR9x9Qt9eo
|
||||
vm7IG5Rpp4ADJ559alP87TTsDA6HWRU/F9sCQCAv+ZumSWFl/33/HeHoSP+MpAG2
|
||||
0QGn5ljeMZfdKnKt6eIYuuxJvEmK4BHGXEn451guU75L7lft/UWljhB/jzUCQQCR
|
||||
DAPxEfpIJHly9nUIgVi+v9HDsNuu0etZcstywQEU2LcZXuyekCDqNFPv5U7az9af
|
||||
+AGNp1tjGeD7zJ1iBr1XAkBJCu8NfQ+6FgmpozFNZTOLXOMXePZ/At6fG7Se+wd3
|
||||
NKIUNg3qG7yeoz5IoK4NqPIQL8xdb/JyfAuBneyFRiQX
|
||||
-----END RSA PRIVATE KEY-----
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user