Updated findfile.
[doldaconnect.git] / lib / guile / dolcon / ui.scm
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)
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 args
20     (let* ((fd (apply dc-connect args)) (resp (dc-extract (do ((resp (dc-getresp) (dc-getresp)))
21                                 ((and resp
22                                       (equal? (cdr (assoc 'cmd (dc-extract resp))) ".connect"))
23                                  resp)
24                               (dc-select)))))
25       (if (= (cdr (assoc 'code resp)) 200)
26           fd
27           (throw 'bad-return (cdr (assoc 'code resp)) (cadr (assoc 'resp resp)))
28           )
29       )
30     )
31   )
32
33 (define-public dc-c&l
34   (lambda (verbose host useauthless)
35     (let ((fd -1) (print (lambda (obj) (if verbose (display obj (if (port? verbose) verbose (current-error-port)))))))
36       (print "connecting...\n")
37       (set! fd (dc-must-connect host))
38       (print "authenticating...\n")
39       (let ((ret (dc-login useauthless)))
40         (if (not (eq? ret 'success))
41             (throw 'login-failure ret)))
42       (print "authentication success\n")
43       fd)
44     )
45   )
46
47 (define-public dc-ecmd
48   (lambda args
49     (let ((tag (dc-qcmd args)))
50       (if (>= tag 0)
51           (do ((resp (dc-getresp tag) (dc-getresp tag)))
52               (resp resp)
53             (dc-select)))
54       )
55     )
56   )
57
58 (define-public dc-ecmd-assert
59   (lambda (code . args)
60     (let* ((resp (apply dc-ecmd args)) (eresp (dc-extract resp)))
61       (if (not (if (list? code)
62                    (memq (cdr (assoc 'code eresp)) code)
63                    (= (cdr (assoc 'code eresp)) code)))
64           (throw 'bad-return (cdr (assoc 'code eresp)) (cadr (assoc 'resp eresp)))
65           )
66       resp
67       )
68     )
69   )
70
71 (define-public dc-intall
72   (lambda (resp)
73     (let ((retlist '()))
74       (do ((ires (dc-intresp resp) (dc-intresp resp))) ((not ires) retlist)
75         (set! retlist (append retlist (list ires)))))))