Add the SOCKSv{4,5} support to be able to pass through the Tor network

bin/args.ml

@@ -336,3 +336,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

@@ -6,6 +6,12 @@ let choose = function
   | false ->
       let open Fiber in
       fun identity ->
+        let human_readable_identity =
+          Password.identity_of_seed
+            (Password.compile Dict.En.words)
+            ~seed:identity
+          |> Result.get_ok
+        in
         let rec asking () =
           Fiber.getline Unix.stdin >>| Stdlib.Option.map String.lowercase_ascii
           >>= function
@@ -15,7 +21,7 @@ let choose = function
               Fmt.pr "Invalid response, accept from %s [Y/n]: %!" identity;
               asking ()
         in
-        Fmt.pr "Accept from %s [Y/n]: %!" identity;
+        Fmt.pr "Accept from %s [Y/n]: %!" human_readable_identity;
         asking ()
 
 let ask_password () =
@@ -30,12 +36,13 @@ let ask_password () =
   Fmt.pr "Your password: %!";
   asking ()
 
-let source_with_reporter quiet ~config ~identity ~ciphers ~shared_keys sockaddr
-    : (Stdbob.bigstring Stream.source, _) result Fiber.t =
+let source_with_reporter quiet ~config ~identity ~ciphers ~shared_keys
+    ~happy_eyeballs ?through addr :
+    (Stdbob.bigstring Stream.source, _) result Fiber.t =
   with_reporter ~config quiet incoming_data @@ fun (reporter, finalise) ->
   Transfer.receive
     ~reporter:(Fiber.return <.> reporter)
-    ~finalise ~identity ~ciphers ~shared_keys sockaddr
+    ~finalise ~identity ~ciphers ~shared_keys ~happy_eyeballs ?through addr
 
 let make_window bits = De.make_window ~bits
 
@@ -223,21 +230,25 @@ 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 (_, he) addr secure_port reproduce password yes
+let run_client quiet g (_, he) 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 ->
-  Bob_happy_eyeballs.connect he addr >>? fun (sockaddr, socket) ->
+  (match through with
+  | Some server -> Bob_socks.connect ~happy_eyeballs:he ~server addr
+  | None -> Bob_happy_eyeballs.connect he 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
   >>? fun (identity, ciphers, shared_keys) ->
   let config = Progress.Config.v ~ppf:Fmt.stdout () in
-  let sockaddr = Transfer.sockaddr_with_secure_port sockaddr secure_port in
-  source_with_reporter quiet ~config ~identity ~ciphers ~shared_keys sockaddr
+  let addr = Transfer.addr_with_secure_port addr secure_port in
+  source_with_reporter quiet ~config ~identity ~ciphers ~shared_keys
+    ~happy_eyeballs:he ?through addr
   >>| Transfer.open_error
   >>? fun source -> extract_with_reporter quiet ~config ~g source destination
 
@@ -249,10 +260,12 @@ 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_and_he addr secure_port reproduce password yes dst =
+let run quiet g () dns_and_he through addr secure_port reproduce password yes
+    dst =
   match
     Fiber.run
-      (run_client quiet g dns_and_he addr secure_port reproduce password yes dst)
+      (run_client quiet g dns_and_he through addr secure_port reproduce password
+         yes dst)
   with
   | Ok () -> `Ok 0
   | Error err ->
@@ -270,8 +283,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/relay.ml

@@ -1,4 +1,4 @@
-let run timeout inet_addr port secure_port backlog =
+let run g timeout inet_addr port secure_port backlog =
   let sockaddr01 = Unix.ADDR_INET (inet_addr, port) in
   let sockaddr02 = Unix.ADDR_INET (inet_addr, secure_port) in
   let socket01 =
@@ -27,19 +27,19 @@ let run timeout inet_addr port secure_port backlog =
   Fiber.run
     Fiber.(
       fork_and_join
-        (fun () -> Bob_clear.relay ~timeout socket01 secured ~stop)
+        (fun () -> Bob_clear.relay ~g ~timeout socket01 secured ~stop)
         (fun () -> Bob_unix.secure_room ~timeout socket02 secured ~stop)
       >>= fun ((), ()) -> Fiber.return ());
   Unix.close socket01;
   Unix.close socket02;
   `Ok 0
 
-let run _quiet daemonize timeout inet_addr port secure_port backlog () =
+let run _quiet g daemonize timeout inet_addr port secure_port backlog () =
   match daemonize with
   | Some path ->
       Daemon.daemonize ~path (fun () ->
-          run timeout inet_addr port secure_port backlog)
-  | None -> run timeout inet_addr port secure_port backlog
+          run g timeout inet_addr port secure_port backlog)
+  | None -> run g timeout inet_addr port secure_port backlog
 
 open Cmdliner
 open Args
@@ -103,8 +103,8 @@ let cmd =
     (Cmd.info "relay" ~doc ~man)
     Term.(
       ret
-        (const run $ term_setup_logs $ daemonize $ timeout $ inet_addr $ port
-       $ secure_port $ backlog $ term_setup_pid))
+        (const run $ term_setup_logs $ term_setup_random $ daemonize $ timeout
+       $ inet_addr $ port $ secure_port $ backlog $ term_setup_pid))
 
 type configuration = {
   quiet : bool;

bin/send.ml

@@ -51,9 +51,10 @@ let emit_one_with_reporter quiet ?level ~config path =
   | Ok stream -> Fiber.return (Stream stream)
 
 let transfer_with_reporter quiet ~config ~identity ~ciphers ~shared_keys
-    sockaddr = function
+    ~happy_eyeballs ?through addr = function
   | Stream stream ->
-      Transfer.transfer ~identity ~ciphers ~shared_keys sockaddr stream
+      Transfer.transfer ~identity ~ciphers ~shared_keys ~happy_eyeballs ?through
+        addr stream
   | File path ->
       let total = (Unix.stat (Bob_fpath.to_string path)).Unix.st_size in
       with_reporter ~config quiet (make_tranfer_bar ~total)
@@ -64,7 +65,7 @@ let transfer_with_reporter quiet ~config ~identity ~ciphers ~shared_keys
       >>| Result.get_ok
       >>= Transfer.transfer
             ~reporter:(Fiber.return <.> reporter)
-            ~identity ~ciphers ~shared_keys sockaddr
+            ~identity ~ciphers ~shared_keys ~happy_eyeballs ?through addr
       >>| fun res ->
       finalise ();
       res
@@ -92,8 +93,8 @@ let better_to_compress_for mime_type =
   | "video" :: _ | "audio" :: _ | "image" :: _ -> false
   | _ -> true
 
-let run_server quiet g (_, he) mime_type compression addr secure_port reproduce
-    password path =
+let run_server quiet g (_, he) through mime_type compression addr secure_port
+    reproduce password path =
   let compression =
     match (mime_type, compression) with
     | None, None -> true
@@ -103,26 +104,39 @@ let run_server quiet g (_, he) 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 he addr >>? fun (sockaddr, socket) ->
+  (match through with
+  | Some server -> Bob_socks.connect ~happy_eyeballs:he ~server addr
+  | None -> Bob_happy_eyeballs.connect he addr)
+  >>? fun (_sockaddr, socket) ->
   generate_pack_file quiet ~g ~config compression path >>= fun pack ->
-  Bob_clear.server socket ~reproduce ~g secret
+  let identity =
+    if quiet then Fun.const (Fiber.return ())
+    else fun seed ->
+      let identity =
+        Password.identity_of_seed (Password.compile Dict.En.words) ~seed
+        |> Result.get_ok
+      in
+      Progress.interject_with (fun () -> Fmt.pr "Identity: %s\n%!" identity);
+      Fiber.return ()
+  in
+  Bob_clear.server socket ~reproduce ~g ~identity secret
   >>? fun (identity, ciphers, shared_keys) ->
-  let sockaddr = Transfer.sockaddr_with_secure_port sockaddr secure_port in
+  let addr = Transfer.addr_with_secure_port addr secure_port in
   transfer_with_reporter quiet ~config ~identity ~ciphers:(flip ciphers)
-    ~shared_keys:(flip shared_keys) sockaddr pack
+    ~shared_keys:(flip shared_keys) ~happy_eyeballs:he ?through addr pack
   >>| Transfer.open_error
 
 let pp_error ppf = function
   | #Transfer.error as err -> Transfer.pp_error ppf err
   | #Bob_clear.error as err -> Bob_clear.pp_error ppf err
   | `Msg err -> Fmt.pf ppf "%s" err
 
-let run () dns_and_he mime_type compression addr secure_port reproduce
+let run () dns_and_he through mime_type compression addr secure_port reproduce
     (quiet, g, password) path =
   match
     Fiber.run
-      (run_server quiet g dns_and_he mime_type compression addr secure_port
-         reproduce password path)
+      (run_server quiet g dns_and_he through mime_type compression addr
+         secure_port reproduce password path)
   with
   | Ok () -> `Ok 0
   | Error err ->
@@ -179,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))

bin/transfer.ml

@@ -4,10 +4,10 @@ let src = Logs.Src.create "bob.transfer"
 
 module Log = (val Logs.src_log src : Logs.LOG)
 
-let sockaddr_with_secure_port sockaddr secure_port =
-  match sockaddr with
-  | Unix.ADDR_INET (inet_addr, _) -> Unix.ADDR_INET (inet_addr, secure_port)
-  | Unix.ADDR_UNIX _ -> invalid_arg "Invalid sockaddr"
+let addr_with_secure_port addr secure_port =
+  match addr with
+  | `Inet (inet_addr, _) -> `Inet (inet_addr, secure_port)
+  | `Domain (host, _) -> `Domain (host, secure_port)
 
 let max_packet =
   2 + Bob_unix.Crypto.max_packet + 16 (* header + data + tag_size *)
@@ -44,13 +44,16 @@ end)
 
 type error =
   [ Bob_unix.error
-  | `Connect of Unix.error
+  | `Connect of [ `Closed | `Msg of string | `Unix of Unix.error ]
   | `Blocking_connect of Connect.error
   | `Crypto of [ Crypto.write_error | Crypto.error ] ]
 
 let pp_error ppf = function
   | `Blocking_connect err -> Connect.pp_error ppf err
-  | `Connect errno -> Fmt.pf ppf "connect(): %s" (Unix.error_message errno)
+  | `Connect `Closed -> Fmt.pf ppf "connect(): Connection reset by peer"
+  | `Connect (`Msg msg) -> Fmt.pf ppf "connect(): %s" msg
+  | `Connect (`Unix errno) ->
+      Fmt.pf ppf "connect(): %s" (Unix.error_message errno)
   | `Crypto (#Crypto.write_error as err) -> Crypto.pp_write_error ppf err
   | `Crypto (#Crypto.error as err) -> Crypto.pp_error ppf err
   | #Bob_unix.error as err -> Bob_unix.pp_error ppf err
@@ -94,17 +97,13 @@ let crypto_of_flow ~reporter ~ciphers ~shared_keys socket =
   Stream.Sink { init; push; full; stop }
 
 let transfer ?chunk:_ ?(reporter = Fiber.ignore) ~identity ~ciphers ~shared_keys
-    sockaddr stream =
-  let { Unix.p_proto; _ } =
-    try Unix.getprotobyname "tcp"
-    with _ ->
-      (* fail on Windows *) { p_name = "tcp"; p_aliases = [||]; p_proto = 0 }
-  in
-  let domain = Unix.domain_of_sockaddr sockaddr in
-  let socket = Unix.socket ~cloexec:true domain Unix.SOCK_STREAM p_proto in
+    ~happy_eyeballs ?through addr stream =
   let open Fiber in
-  Fiber.connect socket sockaddr >>| reword_error (fun err -> `Connect err)
-  >>? fun () ->
+  (match through with
+  | Some server -> Bob_socks.connect ~happy_eyeballs ~server addr
+  | None -> Bob_happy_eyeballs.connect happy_eyeballs addr)
+  >>| reword_error (fun err -> `Connect err)
+  >>? fun (_sockaddr, socket) ->
   Bob_unix.init_peer socket ~identity >>= function
   | Error (#Bob_unix.error as err) ->
       Fiber.close socket >>= fun () -> Fiber.return (Error (err :> error))
@@ -139,17 +138,13 @@ let crypto_of_flow ~reporter ~finalise ~ciphers ~shared_keys socket =
   Stream.Source { init; pull; stop }
 
 let receive ?(reporter = Fiber.ignore) ?(finalise = ignore) ~identity ~ciphers
-    ~shared_keys sockaddr =
-  let { Unix.p_proto; _ } =
-    try Unix.getprotobyname "tcp"
-    with _ ->
-      (* fail on Windows *) { p_name = "tcp"; p_aliases = [||]; p_proto = 0 }
-  in
-  let domain = Unix.domain_of_sockaddr sockaddr in
-  let socket = Unix.socket ~cloexec:true domain Unix.SOCK_STREAM p_proto in
+    ~shared_keys ~happy_eyeballs ?through addr =
   let open Fiber in
-  Fiber.connect socket sockaddr >>| reword_error (fun err -> `Connect err)
-  >>? fun () ->
+  (match through with
+  | Some server -> Bob_socks.connect ~happy_eyeballs ~server addr
+  | None -> Bob_happy_eyeballs.connect happy_eyeballs addr)
+  >>| reword_error (fun err -> `Connect err)
+  >>? fun (_sockaddr, socket) ->
   Bob_unix.init_peer socket ~identity >>= function
   | Error (#Bob_unix.error as err) ->
       Fiber.close socket >>= fun () -> Fiber.return (Error (err :> error))

bin/transfer.mli

@@ -1,7 +1,7 @@
 type error =
   [ Bob_unix.error
   | `Blocking_connect of Connect.error
-  | `Connect of Unix.error
+  | `Connect of [ `Closed | `Msg of string | `Unix of Unix.error ]
   | `Crypto of
     [ `Closed
     | `Corrupted
@@ -10,7 +10,7 @@ type error =
 
 val pp_error : error Fmt.t
 val open_error : ('a, error) result -> ('a, [> error ]) result
-val sockaddr_with_secure_port : Unix.sockaddr -> int -> Unix.sockaddr
+val addr_with_secure_port : Bob_socks.addr -> int -> Bob_socks.addr
 val max_packet : int
 
 val transfer :
@@ -19,7 +19,9 @@ val transfer :
   identity:string ->
   ciphers:Spoke.cipher * Spoke.cipher ->
   shared_keys:string * string ->
-  Unix.sockaddr ->
+  happy_eyeballs:Bob_happy_eyeballs.t ->
+  ?through:Bob_socks.server ->
+  Bob_socks.addr ->
   Stdbob.bigstring Stream.stream ->
   (unit, error) result Fiber.t
 
@@ -29,5 +31,7 @@ val receive :
   identity:string ->
   ciphers:Spoke.cipher * Spoke.cipher ->
   shared_keys:string * string ->
-  Unix.sockaddr ->
+  happy_eyeballs:Bob_happy_eyeballs.t ->
+  ?through:Bob_socks.server ->
+  Bob_socks.addr ->
   (Stdbob.bigstring Stream.source, error) result Fiber.t