Need not check for negative tag in dc-ecmd anymore.
[doldaconnect.git] / lib / guile / dolcon / ui.scm
CommitLineData
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)))))))