Commit | Line | Data |
---|---|---|
3af4536f FT |
1 | ; Dolda Connect - Modular multiuser Direct Connect-style client |
2 | ; Copyright (C) 2007 Fredrik Tolf <fredrik@dolda2000.com> | |
3 | ; | |
4 | ; This program is free software; you can redistribute it and/or modify | |
5 | ; it under the terms of the GNU General Public License as published by | |
6 | ; the Free Software Foundation; either version 2 of the License, or | |
7 | ; (at your option) any later version. | |
8 | ; | |
9 | ; This program is distributed in the hope that it will be useful, | |
10 | ; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
11 | ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
12 | ; GNU General Public License for more details. | |
13 | ; | |
14 | ; You should have received a copy of the GNU General Public License | |
15 | ; along with this program; if not, write to the Free Software | |
16 | ; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA | |
17 | ||
d3372da9 | 18 | (define-module (dolcon ui)) |
19 | ||
9cbeb60c | 20 | (export dc-connect dc-disconnect dc-connected dc-select dc-getresp dc-extract dc-intresp dc-qcmd dc-loginasync dc-lexsexpr dc-checkproto) |
d3372da9 | 21 | |
22 | (load-extension "libdolcon-guile" "init_guiledc") | |
23 | ||
24 | (define-public dc-login | |
25 | (lambda (useauthless . username) | |
26 | (let ((done #f) (errsym #f)) | |
27 | (dc-loginasync | |
28 | (lambda (err reason) | |
29 | (set! errsym err) | |
30 | (set! done #t)) | |
31 | useauthless (if (pair? username) (car username) #f)) | |
32 | (while (not done) (dc-select)) | |
33 | errsym))) | |
34 | ||
35 | (define-public dc-must-connect | |
9cbeb60c | 36 | (lambda (host . version) |
37 | (let* ((fd (dc-connect host)) | |
38 | (ores (do ((resp (dc-getresp) (dc-getresp))) | |
39 | ((and resp | |
40 | (equal? (cdr (assoc 'cmd (dc-extract resp))) ".connect")) | |
41 | resp) | |
42 | (dc-select))) | |
43 | (resp (dc-extract ores))) | |
44 | (if (not (= (cdr (assoc 'code resp)) 201)) | |
d3372da9 | 45 | (throw 'bad-return (cdr (assoc 'code resp)) (cadr (assoc 'resp resp))) |
9cbeb60c | 46 | (if (dc-checkproto ores (if (pair? version) (car version) dc-latest)) |
47 | fd | |
48 | (throw 'bad-protocol ores)) | |
d3372da9 | 49 | ) |
50 | ) | |
51 | ) | |
52 | ) | |
53 | ||
54 | (define-public dc-c&l | |
55 | (lambda (verbose host useauthless) | |
56 | (let ((fd -1) (print (lambda (obj) (if verbose (display obj (if (port? verbose) verbose (current-error-port))))))) | |
57 | (print "connecting...\n") | |
58 | (set! fd (dc-must-connect host)) | |
59 | (print "authenticating...\n") | |
60 | (let ((ret (dc-login useauthless))) | |
61 | (if (not (eq? ret 'success)) | |
62 | (throw 'login-failure ret))) | |
63 | (print "authentication success\n") | |
64 | fd) | |
65 | ) | |
66 | ) | |
67 | ||
68 | (define-public dc-ecmd | |
69 | (lambda args | |
70 | (let ((tag (dc-qcmd args))) | |
01e40b61 FT |
71 | (do ((resp (dc-getresp tag) (dc-getresp tag))) |
72 | (resp resp) | |
73 | (dc-select)) | |
d3372da9 | 74 | ) |
75 | ) | |
76 | ) | |
77 | ||
78 | (define-public dc-ecmd-assert | |
79 | (lambda (code . args) | |
80 | (let* ((resp (apply dc-ecmd args)) (eresp (dc-extract resp))) | |
81 | (if (not (if (list? code) | |
82 | (memq (cdr (assoc 'code eresp)) code) | |
83 | (= (cdr (assoc 'code eresp)) code))) | |
84 | (throw 'bad-return (cdr (assoc 'code eresp)) (cadr (assoc 'resp eresp))) | |
85 | ) | |
86 | resp | |
87 | ) | |
88 | ) | |
89 | ) | |
90 | ||
91 | (define-public dc-intall | |
92 | (lambda (resp) | |
93 | (let ((retlist '())) | |
94 | (do ((ires (dc-intresp resp) (dc-intresp resp))) ((not ires) retlist) | |
95 | (set! retlist (append retlist (list ires))))))) |