d3372da9 |
1 | (define-module (dolcon ui)) |
2 | |
9cbeb60c |
3 | (export dc-connect dc-disconnect dc-connected dc-select dc-getresp dc-extract dc-intresp dc-qcmd dc-loginasync dc-lexsexpr dc-checkproto) |
d3372da9 |
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 |
9cbeb60c |
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)) |
d3372da9 |
28 | (throw 'bad-return (cdr (assoc 'code resp)) (cadr (assoc 'resp resp))) |
9cbeb60c |
29 | (if (dc-checkproto ores (if (pair? version) (car version) dc-latest)) |
30 | fd |
31 | (throw 'bad-protocol ores)) |
d3372da9 |
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))) |
ee63cbcb |
54 | (if (>= tag 0) |
55 | (do ((resp (dc-getresp tag) (dc-getresp tag))) |
56 | (resp resp) |
57 | (dc-select))) |
d3372da9 |
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))))))) |