From: Matt Birkholz Date: Wed, 17 Aug 2011 21:55:11 +0000 (-0700) Subject: Support GFile mounts that need a username and password. X-Git-Tag: mit-scheme-pucked-9.2.12~636 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=176dc44138449af3051dba6ec547f08edb48220d;p=mit-scheme.git Support GFile mounts that need a username and password. --- diff --git a/src/gtk/Includes/gio/gmountoperation.cdecl b/src/gtk/Includes/gio/gmountoperation.cdecl index 4b1da4429..3270eaabd 100644 --- a/src/gtk/Includes/gio/gmountoperation.cdecl +++ b/src/gtk/Includes/gio/gmountoperation.cdecl @@ -3,4 +3,63 @@ glib-2.0/gio/gmountoperation.h |# (extern (* GMountOperation) - g_mount_operation_new) \ No newline at end of file + g_mount_operation_new) + +(extern (* (const char)) + g_mount_operation_get_username + (op (* GMountOperation))) + +(extern void + g_mount_operation_set_username + (op (* GMountOperation)) + (username (* (const char)))) + +(extern (* (const char)) + g_mount_operation_get_password + (op (* GMountOperation))) + +(extern void + g_mount_operation_set_password + (op (* GMountOperation)) + (password (* (const char)))) + +(extern gboolean + g_mount_operation_get_anonymous + (op (* GMountOperation))) + +(extern void + g_mount_operation_set_anonymous + (op (* GMountOperation)) + (gboolean anonymous)) + +(extern (* (const char)) + g_mount_operation_get_domain + (op (* GMountOperation))) + +(extern void + g_mount_operation_set_domain + (op (* GMountOperation)) + (domain (* (const char)))) + +(extern GPasswordSave + g_mount_operation_get_password_save + (op (* GMountOperation))) + +(extern void + g_mount_operation_set_password_save + (op (* GMountOperation)) + (save GPasswordSave)) + +(extern int + g_mount_operation_get_choice + (op (* GMountOperation))) + +(extern void + g_mount_operation_set_choice + (op (* GMountOperation)) + (choice int)) + +(extern void + g_mount_operation_reply + (op (* GMountOperation)) + (result GMountOperationResult)) \ No newline at end of file diff --git a/src/gtk/gio.scm b/src/gtk/gio.scm index 3a98df09c..b8d05157a 100644 --- a/src/gtk/gio.scm +++ b/src/gtk/gio.scm @@ -26,7 +26,7 @@ USA. (define (open-input-gfile uri) (let* ((uri* (->uri* uri 'open-input-gfile)) - (gfile (make-gfile (uri->string uri*))) + (gfile (make-gfile uri*)) (gstream (gfile-read gfile)) (port (make-generic-i/o-port (make-g-stream-source gstream) #f))) ;;(port/set-coding port 'ISO-8859-1) @@ -78,7 +78,7 @@ USA. (define (open-output-gfile uri) (let* ((uri* (->uri* uri 'open-output-gfile)) - (gfile (make-gfile (uri->string uri*))) + (gfile (make-gfile uri*)) (gstream (gfile-replace gfile #f #t 'private)) (port (make-generic-i/o-port #f (make-g-stream-sink gstream)))) ;;(port/set-coding port 'ISO-8859-1) @@ -109,7 +109,7 @@ USA. (define (gdirectory-read uri) (let* ((uri* (->uri* uri 'gdirectory-read)) - (gfile (make-gfile (uri->string uri*))) + (gfile (make-gfile uri*)) (names (map! (lambda (ginfo) (let ((name (gfile-info-get-attribute-value @@ -397,7 +397,7 @@ USA. (set-gio-cleanup-info-pending-op! gio-info 'ERROR) (error "Error during close:" gio value)) (else - (error "Unexpected value from:" queue gio))))))) + (error "Unexpected:" value gio))))))) (define (make-input-close-finish-callback queue gerror*) (C-callback @@ -587,9 +587,9 @@ USA. (retry)) ((string? value) (set-gio-cleanup-info-pending-op! gio-info 'ERROR) - (error (string-append (gfile-uri gfile) ":") value)) + (error (string-append (uri->string (gfile-uri gfile))":") value)) (else - (error "Unexpected value from:" queue gstream))))))) + (error "Unexpected:" value gstream))))))) (define (make-open-finish-callback alien queue gerror*) (C-callback @@ -968,7 +968,11 @@ USA. (%queue! queue #t)))))) (define-class ( (constructor ())) - ()) + () + (message define standard initial-value #f) + (username define standard initial-value #f) + (domain define standard initial-value #f) + (ask-password-flags define standard initial-value #f)) (define-method initialize-instance ((gmountop )) (call-next-method gmountop) @@ -983,9 +987,10 @@ USA. (cleanup-gio gio-info))) (define (gfile-mount gfile) - (let* ((mount-op (make-g-mount-operation)) - (gio-info (gio-cleanup-info mount-op)) - (queue (gio-queue mount-op)) + (let* ((gmountop (make-g-mount-operation)) + (alien (gobject-alien gmountop)) + (gio-info (gio-cleanup-info gmountop)) + (queue (gio-queue gmountop)) (gerror* (gio-cleanup-info-gerror-pointer gio-info)) (callback-id (without-interrupts ;don't leak callback IDs @@ -994,25 +999,85 @@ USA. (set-gio-cleanup-info-pending-op! gio-info 'MOUNT) (set-gio-cleanup-info-callback-id! gio-info id) id))))) - (attach-mount-signal-handlers mount-op gfile) - (C-call "g_file_mount_enclosing_volume" - (gobject-alien gfile) - (C-enum "G_MOUNT_MOUNT_NONE") - (gobject-alien mount-op) - (gobject-alien (gio-cleanup-info-gcancellable gio-info)) - (C-callback "async_ready") - callback-id) - (let ((value (thread-queue/dequeue! queue))) - (if (string? value) - (begin - (set-gio-cleanup-info-pending-op! gio-info 'ERROR) - (error "Error during mount:" gfile value)) - (begin - (set-gio-cleanup-info-pending-op! gio-info #f) - (gobject-unref! mount-op) - (without-interrupts - (lambda () - (cleanup-gio gio-info)))))))) + (let ((userinfo (uri-authority-userinfo (uri-authority (gfile-uri gfile))))) + (if userinfo + (if (string=? userinfo "anonymous") + (begin + (C-call "g_mount_operation_set_anonymous" alien 1) + (set-g-mount-operation-username! gmountop "anonymous")) + (begin + (C-call "g_mount_operation_set_username" alien userinfo) + (set-g-mount-operation-username! gmountop userinfo))))) + (attach-mount-signal-handlers gmountop gfile) + (let retry () + (C-call "g_file_mount_enclosing_volume" + (gobject-alien gfile) + (C-enum "G_MOUNT_MOUNT_NONE") + alien + (gobject-alien (gio-cleanup-info-gcancellable gio-info)) + (C-callback "async_ready") + callback-id) + (let ((value (thread-queue/dequeue! queue))) + (cond ((and (equal? value "Password dialog cancelled") + (g-mount-operation-ask-password-flags gmountop)) + (set-gio-cleanup-info-pending-op! gio-info #f) + (prompt-for-mount-auth gmountop) + (retry)) + ((string? value) + (set-gio-cleanup-info-pending-op! gio-info 'ERROR) + (error (string-append (uri->string (gfile-uri gfile))":") value)) + ((eq? value #t) + (set-gio-cleanup-info-pending-op! gio-info #f) + (gobject-unref! gmountop) + (without-interrupts + (lambda () + (cleanup-gio gio-info))) + unspecific) + (else + (error "Unexpected value:" value gmountop))))))) + +(define (prompt-for-mount-auth gmountop) + (%trace-auth ";prompt-for-mount-auth "gmountop"\n") + (let ((message (g-mount-operation-message gmountop)) + (domain (g-mount-operation-domain gmountop)) + (username (g-mount-operation-username gmountop)) + (flags (g-mount-operation-ask-password-flags gmountop)) + (alien (gobject-alien gmountop)) + (port (interaction-i/o-port))) + (if message (display message port)) + (if (and (memq 'ANONYMOUS-SUPPORTED flags) + (prompt-for-confirmation "Login anonymously" port)) + (begin + (C-call "g_mount_operation_set_anonymous" alien 1) + (set-g-mount-operation-username! alien "anonymous"))) + (if (memq 'NEED-DOMAIN flags) + (let ((d (prompt-for-string* "Domain" domain port))) + (C-call "g_mount_operation_set_domain" alien d) + (set-g-mount-operation-domain! gmountop d))) + (if (memq 'NEED-USERNAME flags) + (let ((u (prompt-for-string* "Username" username port))) + (C-call "g_mount_operation_set_username" alien u) + (set-g-mount-operation-username! gmountop u))) + (if (memq 'NEED-PASSWORD flags) + (call-with-pass-phrase + "Password" + (lambda (phrase) + (C-call "g_mount_operation_set_password" alien phrase)))) + (if (memq 'SAVING-SUPPORTED flags) + (if (prompt-for-confirmation "Save password permanently" port) + (C-call "g_mount_operation_set_password_save" alien + (C-enum "G_PASSWORD_SAVE_PERMANENTLY")) + (if (prompt-for-confirmation "Save password for this session" port) + (C-call "g_mount_operation_set_password_save" alien + (C-enum "G_PASSWORD_SAVE_FOR_SESSION")) + (C-call "g_mount_operation_set_password_save" alien + (C-enum "G_PASSWORD_SAVE_NEVER"))))))) + +(define (prompt-for-string* prompt default port) + (let ((s (prompt-for-string prompt port))) + (if (not (string-find-next-char-in-set s char-set:not-whitespace)) + default + s))) (define (make-mount-finish-callback queue gerror*) (C-callback @@ -1038,26 +1103,53 @@ USA. 'show-processes)) (define (make-mount-password-callback gfile) - (named-lambda (mount-password-callback gmount-op message user domain flags) - (%trace ";mount-password-callback "(gfile-uri gfile) - " "gmount-op - " "(c-peek-cstring message) - " "(c-peek-cstring user) - " "(c-peek-cstring domain) - " "(c-flags "GAskPasswordFlags" flags)"\n") - )) - -(define (c-flags ignore flags) - (declare (ignore ignore)) - (string "0x" (number->string flags 16))) + (named-lambda (mount-password-callback gmountop message user domain flags) + (%trace-auth ";mount-password-callback "(gfile-uri gfile) + " "gmountop + " "(c-peek-cstring message) + " "(c-peek-cstring user) + " "(c-peek-cstring domain) + " "(->ask-password-flags flags)"\n") + (let ((old (g-mount-operation-ask-password-flags gmountop)) + (new (->ask-password-flags flags))) + (set-g-mount-operation-message! gmountop (c-peek-cstring message)) + (set-g-mount-operation-username! gmountop (c-peek-cstring user)) + (set-g-mount-operation-domain! gmountop (c-peek-cstring domain)) + (set-g-mount-operation-ask-password-flags! gmountop new) + (cond ((not old) + ;; Punt, %queuing "Password dialog cancelled". + (C-call "g_mount_operation_reply" (gobject-alien gmountop) + (C-enum "G_MOUNT_OPERATION_UNHANDLED"))) + ((equal? old new) + ;; Assume gmountop is now setup after "...dialog cancelled". + (C-call "g_mount_operation_reply" (gobject-alien gmountop) + (C-enum "G_MOUNT_OPERATION_HANDLED"))))))) + +(define (->ask-password-flags flags) + (define-integrable (cons-flags mask symbol rest) + (if (not (zero? (bitwise-and mask flags))) + (cons symbol rest) + rest)) + (cons-flags + (C-enum "G_ASK_PASSWORD_NEED_PASSWORD") 'NEED-PASSWORD + (cons-flags + (C-enum "G_ASK_PASSWORD_NEED_USERNAME") 'NEED-USERNAME + (cons-flags + (C-enum "G_ASK_PASSWORD_NEED_DOMAIN") 'NEED-DOMAIN + (cons-flags + (C-enum "G_ASK_PASSWORD_SAVING_SUPPORTED") 'SAVING-SUPPORTED + (cons-flags + (C-enum "G_ASK_PASSWORD_ANONYMOUS_SUPPORTED") 'ANONYMOUS-SUPPORTED + '())))))) (define (make-mount-question-callback gfile) - (named-lambda (mount-question-callback gmount-op message choices) - (%trace ";make-mount-question-callback "(gfile-uri gfile) - " "gmount-op - " "(c-peek-cstring message) - " "(peek-gstrv! choices)"\n") - )) + (named-lambda (mount-question-callback gmountop message choices) + (%trace-auth ";make-mount-question-callback" + " "(gfile-uri gfile) + " "gmountop + " "(c-peek-cstring message) + " "(peek-gstrv! chooices)"\n") + (warn "Unimplemented" 'mount-question-callback))) (define (peek-gstrv! alien) (let loop () @@ -1067,13 +1159,14 @@ USA. (cons str (loop)))))) (define (make-mount-processes-callback gfile) - (named-lambda (mount-processes-callback gmount-op message processes choices) - (%trace ";make-mount-processes-callback "gfile - " "gmount-op - " "(c-peek-cstring message) - " "processes - " "(peek-gstrv! choices)"\n") - )) + (named-lambda (mount-processes-callback gmountop message processes choices) + (%trace-auth ";make-mount-processes-callback" + " "gfile + " "gmountop + " "(c-peek-cstring message) + " "processes + " "(peek-gstrv! choices)"\n") + (warn "Unimplemented" 'mount-processes-callback))) (define-class ( (constructor (uri))) () @@ -1082,7 +1175,7 @@ USA. (define-method initialize-instance ((gfile )) (call-next-method gfile) (let ((alien (gobject-alien gfile)) - (uri (gfile-uri gfile))) + (uri (uri->string (gfile-uri gfile)))) (set-alien/ctype! alien '|GFile|) (guarantee-utf8-string uri) (C-call "g_file_new_for_uri" alien uri) @@ -1144,6 +1237,12 @@ USA. (define %trace? #f) +(define %trace-auth? #t) + (define-syntax %trace + (syntax-rules () + ((_ . ARGS) (if %trace? ((lambda () (outf-error . ARGS))))))) + +(define-syntax %trace-auth (syntax-rules () ((_ . ARGS) (if %trace? ((lambda () (outf-error . ARGS))))))) \ No newline at end of file