Fix #756

Add an option to start a local web server for OAuth2 flow. - oauth2_loopback: flag to start the local web server - oauth2_loopback_port: port of the local web server [defaults to 8080]
astrada · Feb 24, 2022 · 9027602 · 9027602
1 parent 2e3c1e0
commit 9027602
Show file tree

Hide file tree

Showing 32 changed files with 281 additions and 373 deletions.
diff --git a/.ocamlformat b/.ocamlformat
@@ -1,2 +1,2 @@
-version=0.19.0
+version=0.20.1
 profile=conventional
diff --git a/bin/gdfuse.ml b/bin/gdfuse.ml
@@ -47,8 +47,8 @@ let generate_request_id () =
   Cryptokit.Random.string rng 32
   |> Utils.base64_encode
   |> ExtString.String.replace_chars (function
-       | '+' -> "-"
-       | c -> ExtString.String.of_char c)
+      | '+' -> "-"
+      | c -> ExtString.String.of_char c)
 
 let create_empty_state_store app_dir =
   let request_id = generate_request_id () in
@@ -118,16 +118,16 @@ let setup_application params =
       GaeProxy.start_server_polling ()
     with
     | GaeProxy.ServerError e ->
-        Utils.log_with_header "Removing invalid request_id=%s\n%!" request_id;
-        context
-        |> Context.request_id_lens ^= ""
-        |> Context.save_state_from_context;
-        Printf.eprintf "Cannot retrieve auth tokens: %s\n%!" e;
-        exit 1
+      Utils.log_with_header "Removing invalid request_id=%s\n%!" request_id;
+      context
+      |> Context.request_id_lens ^= ""
+      |> Context.save_state_from_context;
+      Printf.eprintf "Cannot retrieve auth tokens: %s\n%!" e;
+      exit 1
     | e ->
-        prerr_endline "Cannot retrieve auth tokens.";
-        Printexc.to_string e |> prerr_endline;
-        exit 1
+      prerr_endline "Cannot retrieve auth tokens.";
+      Printexc.to_string e |> prerr_endline;
+      exit 1
   in
 
   Utils.log_message "Starting application setup (label=%s, base_dir=%s).\n%!"
@@ -270,13 +270,13 @@ let setup_application params =
       let oauth2_config =
         match gapi_config |. GapiConfig.auth with
         | GapiConfig.OAuth2 oauth2 ->
-            oauth2
-            |> GapiConfig.refresh_access_token
-               ^= Some
-                    (fun () ->
-                      GaeProxy.refresh_access_token ();
-                      Context.get_ctx () |. Context.state_lens
-                      |. State.last_access_token)
+          oauth2
+          |> GapiConfig.refresh_access_token
+             ^= Some
+               (fun () ->
+                  GaeProxy.refresh_access_token ();
+                  Context.get_ctx () |. Context.state_lens
+                  |. State.last_access_token)
         | _ -> assert false
       in
       gapi_config |> GapiConfig.auth ^= GapiConfig.OAuth2 oauth2_config
@@ -345,6 +345,7 @@ let setup_application params =
       flush_db_thread = None;
       async_upload_thread = None;
       folder_fetching_thread = None;
+      verification_code = "";
     }
   in
   Context.set_ctx context;
@@ -385,29 +386,29 @@ let setup_application params =
 let handle_exception e label param =
   match e with
   | Drive.File_not_found ->
-      Utils.log_with_header "File not found: %s %s\n%!" label param;
-      raise (Unix.Unix_error (Unix.ENOENT, label, param))
+    Utils.log_with_header "File not found: %s %s\n%!" label param;
+    raise (Unix.Unix_error (Unix.ENOENT, label, param))
   | Drive.Permission_denied ->
-      Utils.log_with_header "Permission denied: %s %s\n%!" label param;
-      raise (Unix.Unix_error (Unix.EACCES, label, param))
+    Utils.log_with_header "Permission denied: %s %s\n%!" label param;
+    raise (Unix.Unix_error (Unix.EACCES, label, param))
   | Drive.Directory_not_empty ->
-      Utils.log_with_header "Directory not empty: %s %s\n%!" label param;
-      raise (Unix.Unix_error (Unix.ENOTEMPTY, label, param))
+    Utils.log_with_header "Directory not empty: %s %s\n%!" label param;
+    raise (Unix.Unix_error (Unix.ENOTEMPTY, label, param))
   | Drive.IO_error ->
-      Utils.log_with_header "Input/output error: %s %s\n%!" label param;
-      raise (Unix.Unix_error (Unix.EIO, label, param))
+    Utils.log_with_header "Input/output error: %s %s\n%!" label param;
+    raise (Unix.Unix_error (Unix.EIO, label, param))
   | Drive.No_attribute ->
-      raise (Unix.Unix_error (Unix.EUNKNOWNERR 61, label, param))
+    raise (Unix.Unix_error (Unix.EUNKNOWNERR 61, label, param))
   | Drive.Existing_attribute ->
-      raise (Unix.Unix_error (Unix.EEXIST, label, param))
+    raise (Unix.Unix_error (Unix.EEXIST, label, param))
   | Drive.Invalid_operation ->
-      raise (Unix.Unix_error (Unix.EINVAL, label, param))
+    raise (Unix.Unix_error (Unix.EINVAL, label, param))
   | Unix.Unix_error _ as e ->
-      Utils.log_exception e;
-      raise e
+    Utils.log_exception e;
+    raise e
   | e ->
-      Utils.log_exception e;
-      raise (Unix.Unix_error (Unix.EIO, label, param))
+    Utils.log_exception e;
+    raise (Unix.Unix_error (Unix.EIO, label, param))
 
 let init_filesystem () =
   Utils.log_with_header "init_filesystem\n%!";
@@ -626,11 +627,11 @@ let () =
     in
     List.iter
       (fun o ->
-        try
-          let _, bd = ExtString.String.split o "=" in
-          base_dir := bd
-        with ExtString.Invalid_string ->
-          failwith "Invalid mount option gdfroot")
+         try
+           let _, bd = ExtString.String.split o "=" in
+           base_dir := bd
+         with ExtString.Invalid_string ->
+           failwith "Invalid mount option gdfroot")
       base_dir_opt;
     let fuse_mount_opts =
       List.filter (fun o -> not (ExtString.String.starts_with o "gdfroot")) opts
@@ -649,9 +650,9 @@ let () =
         ( "-debug",
           Arg.Unit
             (fun () ->
-              debug := true;
-              Utils.verbose := true;
-              fuse_args := "-f" :: !fuse_args),
+               debug := true;
+               Utils.verbose := true;
+               fuse_args := "-f" :: !fuse_args),
           " enable debug mode (implies -verbose, -f). Default is false." );
         ( "-label",
           Arg.Set_string fs_label,
@@ -673,8 +674,8 @@ let () =
         ( "-s",
           Arg.Unit
             (fun _ ->
-              fuse_args := "-s" :: !fuse_args;
-              multi_threading := false),
+               fuse_args := "-s" :: !fuse_args;
+               multi_threading := false),
           " run in single-threaded mode." );
         ("-o", Arg.String parse_mount_options, " specify FUSE mount options.");
         ("-cc", Arg.Set clear_cache, " clear cache");
@@ -765,40 +766,40 @@ let () =
             Utils.log_with_header "Exiting.\n%!";
             let context = Context.get_ctx () in
             (match context.Context.buffer_eviction_thread with
-            | None -> ()
-            | Some buffer_eviction_thread ->
-                Utils.log_with_header
-                  "Stopping buffer eviction thread (TID=%d)...%!"
-                  (Thread.id buffer_eviction_thread);
-                Buffering.MemoryBuffers.stop_eviction_thread
-                  context.Context.memory_buffers;
-                Thread.join buffer_eviction_thread;
-                Utils.log_message "done\n%!");
+             | None -> ()
+             | Some buffer_eviction_thread ->
+               Utils.log_with_header
+                 "Stopping buffer eviction thread (TID=%d)...%!"
+                 (Thread.id buffer_eviction_thread);
+               Buffering.MemoryBuffers.stop_eviction_thread
+                 context.Context.memory_buffers;
+               Thread.join buffer_eviction_thread;
+               Utils.log_message "done\n%!");
             (match context.Context.flush_db_thread with
-            | None -> ()
-            | Some flush_db_thread ->
-                Utils.log_with_header "Stopping flush DB thread (TID=%d)...%!"
-                  (Thread.id flush_db_thread);
-                MemoryCache.stop_flush_db_thread ();
-                Thread.join flush_db_thread;
-                Utils.log_message "done\n%!");
+             | None -> ()
+             | Some flush_db_thread ->
+               Utils.log_with_header "Stopping flush DB thread (TID=%d)...%!"
+                 (Thread.id flush_db_thread);
+               MemoryCache.stop_flush_db_thread ();
+               Thread.join flush_db_thread;
+               Utils.log_message "done\n%!");
             (match context.Context.async_upload_thread with
-            | None -> ()
-            | Some async_upload_thread ->
-                Utils.log_with_header
-                  "Stopping async upload thread (TID=%d)\n%!"
-                  (Thread.id async_upload_thread);
-                UploadQueue.stop_async_upload_thread ();
-                Thread.join async_upload_thread);
+             | None -> ()
+             | Some async_upload_thread ->
+               Utils.log_with_header
+                 "Stopping async upload thread (TID=%d)\n%!"
+                 (Thread.id async_upload_thread);
+               UploadQueue.stop_async_upload_thread ();
+               Thread.join async_upload_thread);
             (match context.Context.folder_fetching_thread with
-            | None -> ()
-            | Some folder_fetching_thread ->
-                Utils.log_with_header
-                  "Stopping background folder fetching thread (TID=%d)...%!"
-                  (Thread.id folder_fetching_thread);
-                BackgroundFolderFetching.stop_folder_fetching_thread ();
-                Thread.join folder_fetching_thread;
-                Utils.log_message "done\n%!");
+             | None -> ()
+             | Some folder_fetching_thread ->
+               Utils.log_with_header
+                 "Stopping background folder fetching thread (TID=%d)...%!"
+                 (Thread.id folder_fetching_thread);
+               BackgroundFolderFetching.stop_folder_fetching_thread ();
+               Thread.join folder_fetching_thread;
+               Utils.log_message "done\n%!");
             Utils.log_with_header "Flushing cache...\n%!";
             Cache.flush context.Context.cache;
             Utils.log_with_header "Storing clean shutdown flag...%!";
@@ -814,7 +815,7 @@ let () =
     with
     | Failure error_message -> quit error_message
     | e ->
-        let error_message = Printexc.to_string e in
-        quit error_message
+      let error_message = Printexc.to_string e in
+      quit error_message
 
 (* END Main program *)
diff --git a/google-drive-ocamlfuse.opam b/google-drive-ocamlfuse.opam
@@ -10,7 +10,7 @@ build: [
   ["dune" "runtest" "-p" name "-j" jobs] {with-test}
 ]
 depends: [
-  "ocaml" {>= "4.02.3"}
+  "ocaml" {>= "4.04.0"}
   "base-threads" {build}
   "camlidl" {build}
   "gapi-ocaml" {>= "0.4.2"}
@@ -20,6 +20,7 @@ depends: [
   "extlib"
   "ounit" {with-test}
   "sqlite3"
+  "tiny_httpd"
 ]
 synopsis: "A FUSE filesystem over Google Drive"
 description: """

diff --git a/src/LoopbackServer.ml b/src/LoopbackServer.ml
@@ -0,0 +1,52 @@
+open GapiLens.Infix
+module S = Tiny_httpd
+
+let build_page title h3 body =
+  Printf.sprintf
+    "<!DOCTYPE html>\n\
+     <html lang=\"en\">\n\
+     <head>\n\
+     <title>%s</title>\n\
+     </head>\n\
+     <body>\n\
+     <h3>%s</h3>\n\
+     %s\n\
+     </body>\n\
+     </html>"
+    title h3 body
+
+let start port =
+  let server = S.create ~port () in
+  S.add_route_handler server
+    S.Route.(exact "oauth2callback" @/ return)
+    (fun req ->
+      let query = S.Request.query req in
+      let response =
+        try
+          let verification_code =
+            List.find (fun (key, _) -> key = "code") query |> snd
+          in
+          Context.update_ctx (Context.verification_code ^= verification_code);
+          S.Response.make_string
+            (Ok
+               (build_page "gdfuse oauth2 flow" "Success!"
+                  (Printf.sprintf
+                     "<p>Verification code: %s</p><p>You may close the \
+                      browser. Please, check the console output of the \
+                      application.</p>"
+                     verification_code)))
+        with Not_found ->
+          S.Response.make_string
+            (Ok
+               (build_page "gdfuse oauth2 flow" "Error!"
+                  (Printf.sprintf "<p>Cannot get the verification code</p>")))
+      in
+      S.stop server;
+      response);
+  Utils.log_with_header
+    "Starting OAuth2 local web server. Listening on http://%s:%d\n%!"
+    (S.addr server) (S.port server);
+  Thread.create
+    (fun () -> match S.run server with Ok () -> () | Error e -> raise e)
+    ()
+  |> ignore
diff --git a/src/LoopbackServer.mli b/src/LoopbackServer.mli
@@ -0,0 +1 @@
+val start : int -> unit
diff --git a/src/appDir.ml b/src/appDir.ml
@@ -57,9 +57,7 @@ let cache_dir =
   }
 
 let ( // ) = Filename.concat
-
 let home = Sys.getenv "HOME"
-
 let default_base_dir = home // ".gdfuse"
 
 (* XDG Base Directory *)
@@ -80,7 +78,7 @@ let get_config_path config_path xdg_base_directory base_dir fs_label =
   if config_path <> "" then (config_path, false)
   else if xdg_base_directory then (
     Utils.safe_makedir xdg_config_dir;
-    (xdg_config_path, true) )
+    (xdg_config_path, true))
   else if Sys.file_exists xdg_config_path then (xdg_config_path, true)
   else
     let base_dir = if base_dir = "" then default_base_dir else base_dir in

diff --git a/src/backgroundFolderFetching.mli b/src/backgroundFolderFetching.mli
@@ -1,3 +1,2 @@
 val start_folder_fetching_thread : CacheData.t -> (string -> unit) -> unit
-
 val stop_folder_fetching_thread : unit -> unit
diff --git a/src/bufferPool.ml b/src/bufferPool.ml
@@ -30,7 +30,6 @@ let create ~pool_size ~buffer_size =
   }
 
 let max_buffers buffer_pool = buffer_pool.max_buffers
-
 let pending_requests buffer_pool = buffer_pool.pending_requests
 
 let free_buffers buffer_pool =
@@ -50,14 +49,14 @@ let acquire_buffer mutex condition buffer_pool =
             buffer_pool.buffer_size;
         mutex = Mutex.create ();
         condition = Condition.create ();
-      } )
+      })
     else (
       buffer_pool.pending_requests <- buffer_pool.pending_requests + 1;
       while Queue.length buffer_pool.free_buffers = 0 do
         Condition.wait condition mutex
       done;
       buffer_pool.pending_requests <- buffer_pool.pending_requests - 1;
-      get_buffer () )
+      get_buffer ())
 
 let release_buffer buffer condition buffer_pool =
   Queue.add buffer buffer_pool.free_buffers;

diff --git a/src/bufferPool.mli b/src/bufferPool.mli
@@ -11,13 +11,8 @@ end
 type t
 
 val create : pool_size:int -> buffer_size:int -> t
-
 val max_buffers : t -> int
-
 val pending_requests : t -> int
-
 val free_buffers : t -> int
-
 val acquire_buffer : Mutex.t -> Condition.t -> t -> Buffer.t
-
 val release_buffer : Buffer.t -> Condition.t -> t -> unit
Original file line number	Diff line number	Diff line change
		@@ -1,3 +1,2 @@
		val start_folder_fetching_thread : CacheData.t -> (string -> unit) -> unit

		val stop_folder_fetching_thread : unit -> unit