Integrate the socks implementation into our binary

bin/args.ml

@@ -323,3 +323,12 @@ let destination =
     Arg.conv (parser, pp)
   in
   Arg.(value & opt (some name) None & info [ "o"; "output" ] ~doc ~docv:"<dst>")
+
+let through =
+  let doc =
+    "The user can communicate with the relay $(b,through) a SOCKSv{4a,5} \
+     server (usually, a Tor server). The format of the argument is: \
+     [socks{4,4a,5}://(username:password@)?hostname(:port)?]"
+  in
+  let server = Arg.conv Bob_socks.(parser, pp) in
+  Arg.(value & opt (some server) None & info [ "through" ] ~doc ~docv:"<socks>")

bin/bob.ml

@@ -1,13 +1,15 @@
 let () = Printexc.record_backtrace true
 
-let run quiet g temp dns compression addr secure_port yes dst = function
+let run quiet g temp dns compression through addr secure_port yes dst = function
   | Some path when Sys.file_exists path ->
       let password = Args.setup_password quiet g None in
-      Send.run temp dns None compression addr secure_port false password
+      Send.run temp dns through None compression addr secure_port false password
         (Bob_fpath.v path)
   | Some password ->
-      Recv.run quiet g temp dns addr secure_port false (Some password) yes dst
-  | None -> Recv.run quiet g temp dns addr secure_port false None yes dst
+      Recv.run quiet g temp dns through addr secure_port false (Some password)
+        yes dst
+  | None ->
+      Recv.run quiet g temp dns through addr secure_port false None yes dst
 
 open Cmdliner
 open Args
@@ -20,8 +22,8 @@ let term =
   Term.(
     ret
       (const run $ term_setup_logs $ term_setup_random $ term_setup_temp
-     $ term_setup_dns $ compression $ relay $ secure_port $ yes $ destination
-     $ path_or_password))
+     $ term_setup_dns $ compression $ through $ relay $ secure_port $ yes
+     $ destination $ path_or_password))
 
 let cmd =
   let doc = "An universal & secure peer-to-peer file-transfer program." in

bin/dune

@@ -52,7 +52,8 @@
   bob.pack
   bob.tls
   bob.dns
-  bob.happy-eyeballs))
+  bob.happy-eyeballs
+  bob.socks))
 
 ; (rule
 ;  (target cat.com)

bin/recv.ml

@@ -229,14 +229,18 @@ let extract_with_reporter quiet ~config ?g
                 name Bob_fpath.pp destination);
           unpack_with_reporter quiet ~config ~total pack destination hash)
 
-let run_client quiet g dns addr secure_port reproduce password yes destination =
+let run_client quiet g dns through addr secure_port reproduce password yes
+    destination =
   let open Fiber in
   (match password with
   | Some password -> Fiber.return password
   | None -> ask_password ())
   >>= fun password ->
   let happy_eyeballs = Bob_happy_eyeballs.create ~dns () in
-  Bob_happy_eyeballs.connect happy_eyeballs addr >>? fun (sockaddr, socket) ->
+  (match through with
+  | Some server -> Bob_socks.connect ~happy_eyeballs ~server addr
+  | None -> Bob_happy_eyeballs.connect happy_eyeballs addr)
+  >>? fun (sockaddr, socket) ->
   Logs.debug (fun m -> m "The client is connected to the relay.");
   let choose = choose yes in
   Bob_clear.client socket ~reproduce ~choose ~g password
@@ -255,10 +259,11 @@ let pp_error ppf = function
   | `No_root -> Fmt.pf ppf "The given PACK file has no root"
   | `Msg err -> Fmt.pf ppf "%s" err
 
-let run quiet g () dns addr secure_port reproduce password yes dst =
+let run quiet g () dns through addr secure_port reproduce password yes dst =
   match
     Fiber.run
-      (run_client quiet g dns addr secure_port reproduce password yes dst)
+      (run_client quiet g dns through addr secure_port reproduce password yes
+         dst)
   with
   | Ok () -> `Ok 0
   | Error err ->
@@ -276,8 +281,8 @@ let term =
   Term.(
     ret
       (const run $ term_setup_logs $ term_setup_random $ term_setup_temp
-     $ term_setup_dns $ relay $ secure_port $ reproduce $ password $ yes
-     $ destination))
+     $ term_setup_dns $ through $ relay $ secure_port $ reproduce $ password
+     $ yes $ destination))
 
 let cmd =
   let doc = "Receive a file from a peer who share the given password." in

bin/send.ml

@@ -92,8 +92,8 @@ let better_to_compress_for mime_type =
   | "video" :: _ | "audio" :: _ | "image" :: _ -> false
   | _ -> true
 
-let run_server quiet g dns mime_type compression addr secure_port reproduce
-    password path =
+let run_server quiet g dns through mime_type compression addr secure_port
+    reproduce password path =
   let compression =
     match (mime_type, compression) with
     | None, None -> true
@@ -104,7 +104,10 @@ let run_server quiet g dns mime_type compression addr secure_port reproduce
   let config = Progress.Config.v ~ppf:Fmt.stdout () in
   let secret, _ = Spoke.generate ~g ~password ~algorithm:Spoke.Pbkdf2 16 in
   let open Fiber in
-  Bob_happy_eyeballs.connect happy_eyeballs addr >>? fun (sockaddr, socket) ->
+  (match through with
+  | Some server -> Bob_socks.connect ~happy_eyeballs ~server addr
+  | None -> Bob_happy_eyeballs.connect happy_eyeballs addr)
+  >>? fun (sockaddr, socket) ->
   generate_pack_file quiet ~g ~config compression path >>= fun pack ->
   let identity =
     if quiet then Fun.const (Fiber.return ())
@@ -128,12 +131,12 @@ let pp_error ppf = function
   | #Bob_clear.error as err -> Bob_clear.pp_error ppf err
   | `Msg err -> Fmt.pf ppf "%s" err
 
-let run () dns mime_type compression addr secure_port reproduce
+let run () dns through mime_type compression addr secure_port reproduce
     (quiet, g, password) path =
   match
     Fiber.run
-      (run_server quiet g dns mime_type compression addr secure_port reproduce
-         password path)
+      (run_server quiet g dns through mime_type compression addr secure_port
+         reproduce password path)
   with
   | Ok () -> `Ok 0
   | Error err ->
@@ -190,7 +193,7 @@ let cmd =
     (Cmd.info "send" ~doc ~man)
     Term.(
       ret
-        (const run $ term_setup_temp $ term_setup_dns $ mime_type $ compression
-       $ relay $ secure_port $ reproduce
+        (const run $ term_setup_temp $ term_setup_dns $ through $ mime_type
+       $ compression $ relay $ secure_port $ reproduce
         $ term_setup_password password
         $ path))

bob.opam

@@ -38,4 +38,9 @@ depends: [
   "ke"                {>= "0.6"}
   "alcotest"          {with-test}
   "spoke"             {>= "0.0.2"}
+  "socks"
+]
+
+pin-depends: [
+  [ "socks.dev" "git+https://github.com/dinosaure/ocaml-socks.git#31399dab6812cb3fbf28b9eea5c5e4a3939abe4b" ]
 ]

com.opam

@@ -45,6 +45,7 @@ depends: [
   "ke"                { >= "0.6" }
   "alcotest"          { with-test }
   "spoke"             { >= "0.0.2" }
+  "socks"
 ]
 
 pin-depends: [
@@ -53,6 +54,7 @@ pin-depends: [
   [ "mirage-crypto-ec.dev" "git+https://github.com/dinosaure/mirage-crypto.git#989c4aff6915b239f2afa0c88d948257a960f43a" ]
   [ "mirage-crypto-rng.dev" "git+https://github.com/dinosaure/mirage-crypto.git#989c4aff6915b239f2afa0c88d948257a960f43a" ]
   [ "mtime.dev" "git+https://github.com/dinosaure/mtime.git#d5d70f38c40da90e3e173eb60346df55b64a4a0a"]
+  [ "socks.dev" "git+https://github.com/dinosaure/ocaml-socks.git#31399dab6812cb3fbf28b9eea5c5e4a3939abe4b" ]
 ]
 
 x-mirage-opam-lock-location: "com.opam.locked"