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