bf57b06748ee0778b52d93f127c0ff40b03ef258
[doldaconnect.git] / lib / guile / dolcon / ui.scm
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
18 (define-module (dolcon ui))
19
20 (export dc-connect dc-disconnect dc-connected dc-select dc-getresp dc-extract dc-intresp dc-qcmd dc-loginasync dc-lexsexpr dc-checkproto)
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
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))
45           (throw 'bad-return (cdr (assoc 'code resp)) (cadr (assoc 'resp resp)))
46           (if (dc-checkproto ores (if (pair? version) (car version) dc-latest))
47               fd
48               (throw 'bad-protocol ores))
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)))
71       (if (>= tag 0)
72           (do ((resp (dc-getresp tag) (dc-getresp tag)))
73               (resp resp)
74             (dc-select)))
75       )
76     )
77   )
78
79 (define-public dc-ecmd-assert
80   (lambda (code . args)
81     (let* ((resp (apply dc-ecmd args)) (eresp (dc-extract resp)))
82       (if (not (if (list? code)
83                    (memq (cdr (assoc 'code eresp)) code)
84                    (= (cdr (assoc 'code eresp)) code)))
85           (throw 'bad-return (cdr (assoc 'code eresp)) (cadr (assoc 'resp eresp)))
86           )
87       resp
88       )
89     )
90   )
91
92 (define-public dc-intall
93   (lambda (resp)
94     (let ((retlist '()))
95       (do ((ires (dc-intresp resp) (dc-intresp resp))) ((not ires) retlist)
96         (set! retlist (append retlist (list ires)))))))