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       (do ((resp (dc-getresp tag) (dc-getresp tag)))
  51           (resp resp)
  52         (dc-select))
  53       )
  54     )
  55   )
  56
  57 (define-public dc-ecmd-assert
  58   (lambda (code . args)
  59     (let* ((resp (apply dc-ecmd args)) (eresp (dc-extract resp)))
  60       (if (not (if (list? code)
  61                    (memq (cdr (assoc 'code eresp)) code)
  62                    (= (cdr (assoc 'code eresp)) code)))
  63           (throw 'bad-return (cdr (assoc 'code eresp)) (cadr (assoc 'resp eresp)))
  64           )
  65       resp
  66       )
  67     )
  68   )
  69
  70 (define-public dc-intall
  71   (lambda (resp)
  72     (let ((retlist '()))
  73       (do ((ires (dc-intresp resp) (dc-intresp resp))) ((not ires) retlist)
  74         (set! retlist (append retlist (list ires)))))))