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 4b1da442913d4a5f8998ce2ef1f16b4a7310758d..3270eaabd32f5bf52c9a02c833c8bfab19d9e87a 100644 (file)
--- 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 3a98df09c304cc02a107489abf5ea95806559730..b8d05157a40f0ff009651062b726fd86ba3d1599 100644 (file)
--- 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))))))
 \f
 (define-class (<g-mount-operation> (constructor ()))
-    (<gio>))
+    (<gio>)
+  (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 <g-mount-operation>))
   (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)))
 \f
 (define-class (<gfile> (constructor (uri)))
     (<gobject>)
@@ -1082,7 +1175,7 @@ USA.
 (define-method initialize-instance ((gfile <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