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)))))))