| 1 | (define-module (dolcon ui)) |
| 2 | |
| 3 | (export dc-connect dc-disconnect dc-connected dc-select dc-getresp dc-extract dc-intresp dc-qcmd dc-loginasync dc-lexsexpr dc-checkproto) |
| 4 | |
| 5 | (load-extension "libdolcon-guile" "init_guiledc") |
| 6 | |
| 7 | (define-public dc-login |
| 8 | (lambda (useauthless . username) |
| 9 | (let ((done #f) (errsym #f)) |
| 10 | (dc-loginasync |
| 11 | (lambda (err reason) |
| 12 | (set! errsym err) |
| 13 | (set! done #t)) |
| 14 | useauthless (if (pair? username) (car username) #f)) |
| 15 | (while (not done) (dc-select)) |
| 16 | errsym))) |
| 17 | |
| 18 | (define-public dc-must-connect |
| 19 | (lambda (host . version) |
| 20 | (let* ((fd (dc-connect host)) |
| 21 | (ores (do ((resp (dc-getresp) (dc-getresp))) |
| 22 | ((and resp |
| 23 | (equal? (cdr (assoc 'cmd (dc-extract resp))) ".connect")) |
| 24 | resp) |
| 25 | (dc-select))) |
| 26 | (resp (dc-extract ores))) |
| 27 | (if (not (= (cdr (assoc 'code resp)) 201)) |
| 28 | (throw 'bad-return (cdr (assoc 'code resp)) (cadr (assoc 'resp resp))) |
| 29 | (if (dc-checkproto ores (if (pair? version) (car version) dc-latest)) |
| 30 | fd |
| 31 | (throw 'bad-protocol ores)) |
| 32 | ) |
| 33 | ) |
| 34 | ) |
| 35 | ) |
| 36 | |
| 37 | (define-public dc-c&l |
| 38 | (lambda (verbose host useauthless) |
| 39 | (let ((fd -1) (print (lambda (obj) (if verbose (display obj (if (port? verbose) verbose (current-error-port))))))) |
| 40 | (print "connecting...\n") |
| 41 | (set! fd (dc-must-connect host)) |
| 42 | (print "authenticating...\n") |
| 43 | (let ((ret (dc-login useauthless))) |
| 44 | (if (not (eq? ret 'success)) |
| 45 | (throw 'login-failure ret))) |
| 46 | (print "authentication success\n") |
| 47 | fd) |
| 48 | ) |
| 49 | ) |
| 50 | |
| 51 | (define-public dc-ecmd |
| 52 | (lambda args |
| 53 | (let ((tag (dc-qcmd args))) |
| 54 | (if (>= tag 0) |
| 55 | (do ((resp (dc-getresp tag) (dc-getresp tag))) |
| 56 | (resp resp) |
| 57 | (dc-select))) |
| 58 | ) |
| 59 | ) |
| 60 | ) |
| 61 | |
| 62 | (define-public dc-ecmd-assert |
| 63 | (lambda (code . args) |
| 64 | (let* ((resp (apply dc-ecmd args)) (eresp (dc-extract resp))) |
| 65 | (if (not (if (list? code) |
| 66 | (memq (cdr (assoc 'code eresp)) code) |
| 67 | (= (cdr (assoc 'code eresp)) code))) |
| 68 | (throw 'bad-return (cdr (assoc 'code eresp)) (cadr (assoc 'resp eresp))) |
| 69 | ) |
| 70 | resp |
| 71 | ) |
| 72 | ) |
| 73 | ) |
| 74 | |
| 75 | (define-public dc-intall |
| 76 | (lambda (resp) |
| 77 | (let ((retlist '())) |
| 78 | (do ((ires (dc-intresp resp) (dc-intresp resp))) ((not ires) retlist) |
| 79 | (set! retlist (append retlist (list ires))))))) |