wip

bin/talk.ml

@@ -1,9 +1,5 @@
 open Stdbob
 
-type value = Value : 'a Bob_protocol.Protocol.packet * 'a -> value
-
-let error_msgf fmt = Fmt.kstr (fun msg -> Error (`Msg msg)) fmt
-
 (* XXX(dinosaure): copy-pasta with [transfer.ml], TODO! *)
 module Crypto = Bob_unix.Crypto.Make (struct
   include Bob_unix.Fiber
@@ -31,8 +27,9 @@ module Crypto = Bob_unix.Crypto.Make (struct
   and go fd bstr off len =
     Fiber.write fd bstr ~off ~len >>= function
     | Error _ as err -> Fiber.return err
-    | Ok len' when len' = len -> Fiber.return (Ok ())
-    | Ok len' -> go fd bstr (off + len') (len - len')
+    | Ok len' ->
+        if len' - len <= 0 then Fiber.return (Ok ())
+        else go fd bstr (off + len') (len - len')
 end)
 
 module Clear = struct
@@ -56,100 +53,105 @@ module Bob_clear = struct
   include Bob_unix.Make (Clear)
 end
 
-let rec talk secure_flow value =
+let rec run_protocol secure_flow value =
   let open Fiber in
   match value with
-  | Bob_protocol.State.Return value -> Fiber.return (Ok value)
-  | Bob_protocol.State.Error err -> Fiber.return (Error err)
-  | Bob_protocol.State.Write { buffer; off; len; continue } ->
+  | Bob_protocol.Protocol.Return value -> Fiber.return (Ok value)
+  | Bob_protocol.Protocol.Error err -> Fiber.return (Error err)
+  | Bob_protocol.Protocol.Write { buffer; off; len; continue } ->
+      Logs.debug (fun m ->
+          m "~> @[<hov>%a@]"
+            (Hxd_string.pp Hxd.default)
+            (String.sub buffer off len));
       let { Cstruct.buffer; off; len } = Cstruct.of_string buffer ~off ~len in
       Crypto.send secure_flow buffer ~off ~len
       >>| Result.map_error (fun err -> `Read err)
-      >>? fun len -> talk secure_flow (continue len)
-  | Bob_protocol.State.Read { buffer; off; len = _; continue } -> (
+      >>? fun len -> run_protocol secure_flow (continue len)
+  | Bob_protocol.Protocol.Read { buffer; off; len = _; continue } -> (
       Crypto.recv secure_flow >>| Result.map_error (fun err -> `Write err)
       >>? function
-      | `End -> talk secure_flow (continue `End)
+      | `End -> run_protocol secure_flow (continue `End)
       | `Data bstr ->
           let len = Bigarray.Array1.dim bstr in
           bigstring_blit_to_bytes bstr ~src_off:0 buffer ~dst_off:off ~len;
-          talk secure_flow (continue (`Len len)))
-
-let send stdin state secure_flow =
-  let open Fiber in
-  getline stdin >>= function
-  | None ->
-      talk secure_flow
-        (Bob_protocol.Protocol.encode state Bob_protocol.Protocol.quit ())
-      >>? fun () -> Fiber.return (Ok `Quit)
-  | Some cmd -> (
-      let v =
-        match cmd with
-        | "ping" -> Ok (Value (Bob_protocol.Protocol.ping, ()))
-        | "pong" -> Ok (Value (Bob_protocol.Protocol.pong, ()))
-        | cmd -> error_msgf "Invalid command: %S" cmd
-      in
-      match v with
-      | Ok (Value (packet, value)) ->
-          talk secure_flow (Bob_protocol.Protocol.encode state packet value)
-          >>? fun () -> Fiber.return (Ok `Sent)
-      | Error _ as err -> Fiber.return err)
-
-let recv state secure_flow =
-  let open Fiber in
-  talk secure_flow
-    (Bob_protocol.Protocol.decode state Bob_protocol.Protocol.any)
-  >>? fun (Any (packet, value)) ->
-  Fiber.return (Ok (`Received (Value (packet, value))))
-
-let rec pp_value ppf (Value (packet, value)) =
-  match packet with
-  | Bob_protocol.Protocol.Any ->
-      let (Any (packet, value)) = value in
-      pp_value ppf (Value (packet, value))
-  | Ping | Pong | Quit -> Bob_protocol.Protocol.pp ppf packet
-
-let rec repl stdin state secure_flow =
-  let open Fiber in
-  pick
-    (fun () -> send stdin state secure_flow)
-    (fun () -> recv state secure_flow)
-  >>? function
-  | `Quit -> Fiber.return (Ok ())
-  | `Sent ->
-      Fmt.pr "# %!";
-      repl stdin state secure_flow
-  | `Received value ->
-      Fmt.pr "\n~> %a\n%!# %!" pp_value value;
-      repl stdin state secure_flow
+          Logs.debug (fun m ->
+              m "<~ @[<hov>%a@]"
+                (Hxd_string.pp Hxd.default)
+                (Bytes.sub_string buffer off len));
+          run_protocol secure_flow (continue (`Len len)))
 
 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 run g he addr secure_port password reproduce =
+let on_error on_error k =
+  let open Fiber in
+  k () >>= function
+  | Error err -> on_error err >>= fun () -> Fiber.return (Error err)
+  | Ok _ as value -> Fiber.return value
+
+type error =
+  [ `Msg of string
+  | `Handshake of Bob_clear.error
+  | `Write of Crypto.error
+  | `Read of Crypto.write_error
+  | `Connect of Clear.error
+  | Bob_protocol.Protocol.error
+  | Bob_protocol.Machine.error
+  | Bob_unix.error ]
+
+let run person g he addr secure_port password reproduce =
   let open Fiber in
   Bob_happy_eyeballs.connect he addr >>? fun (sockaddr, socket) ->
-  Bob_clear.client socket ~reproduce
-    ~choose:(Fun.const (Fiber.return `Accept))
-    ~g password
+  (match person with
+  | `Bob ->
+      let secret, _ = Spoke.generate ~g ~password ~algorithm:Spoke.Pbkdf2 16 in
+      Bob_clear.server socket ~reproduce ~g secret
+  | `Alice ->
+      Bob_clear.client socket ~reproduce
+        ~choose:(Fun.const (Fiber.return `Accept))
+        ~g password)
   >>| Result.map_error (fun err -> `Handshake err)
-  >>? fun (_identity, ciphers, shared_keys) ->
+  >>? fun (identity, ciphers, shared_keys) ->
+  Fmt.pr ">>> Found a peer: %S\n%!" identity;
   let sockaddr = sockaddr_with_secure_port sockaddr secure_port in
   let domain = Unix.domain_of_sockaddr sockaddr in
-  Fiber.connect socket sockaddr >>| reword_error (fun err -> `Connect err)
-  >>? fun () ->
   let { Unix.p_proto; _ } =
     try Unix.getprotobyname "tcp"
     with _ ->
       (* fail on Windows *) { p_name = "tcp"; p_aliases = [||]; p_proto = 0 }
   in
   let socket = Unix.socket ~cloexec:true domain Unix.SOCK_STREAM p_proto in
+  Fiber.connect socket sockaddr >>| reword_error (fun err -> `Connect err)
+  >>? fun () ->
+  on_error (fun _err -> Fiber.close socket) @@ fun () ->
+  Bob_unix.init_peer socket ~identity
+  >>| Result.map_error (fun err -> (err :> error))
+  >>? fun () ->
+  let ciphers, shared_keys =
+    match person with
+    | `Bob -> (ciphers, shared_keys)
+    | `Alice -> (flip ciphers, flip shared_keys)
+  in
   let secure_flow = Bob_unix.Crypto.make ~ciphers ~shared_keys socket in
   let state = Bob_protocol.Protocol.state () in
-  repl Unix.stdin state secure_flow >>= fun res ->
-  Fiber.close socket >>= fun () -> Fiber.return res
+  let monad =
+    match person with
+    | `Bob ->
+        let metadata = Bob_protocol.Metadata.v1 ~size:1L `File in
+        Bob_protocol.Machine.bob ~metadata state
+    | `Alice -> Bob_protocol.Machine.alice state
+  in
+  run_protocol secure_flow monad
+  >>| Result.map_error (fun err -> (err :> error))
+  >>? function
+  | `Ready_to_send -> Fiber.close socket >>= fun () -> Fiber.return (Ok ())
+  | `Ready_to_resume _resume ->
+      Fiber.close socket >>= fun () -> Fiber.return (Ok ())
+  | `Ready_to_recv _metadata ->
+      Fiber.close socket >>= fun () -> Fiber.return (Ok ())
+  | `Quit -> Fiber.return (Error (`Read `Closed))
 
 let pp_error ppf = function
   | `Msg err -> Fmt.pf ppf "%s" err
@@ -159,9 +161,11 @@ let pp_error ppf = function
   | `Write err -> Crypto.pp_error ppf err
   | `Read err -> Crypto.pp_write_error ppf err
   | `Connect err -> Clear.pp_error ppf err
+  | #Bob_unix.error as err -> Bob_unix.pp_error ppf err
+  | #Bob_protocol.Machine.error as err -> Bob_protocol.Machine.pp_error ppf err
 
-let run _quiet g () (_, he) addr secure_port password reproduce =
-  match Fiber.run (run g he addr secure_port password reproduce) with
+let run _quiet g () (_, he) addr secure_port password person reproduce =
+  match Fiber.run (run person g he addr secure_port password reproduce) with
   | Ok () -> `Ok 0
   | Error err ->
       Fmt.epr "%s: %a.\n%!" Sys.argv.(0) pp_error err;
@@ -174,15 +178,21 @@ let password =
   let doc = "The password to share." in
   Arg.(required & pos 0 (some string) None & info [] ~doc ~docv:"<password>")
 
+let person =
+  let flags = [ (`Alice, Arg.info [ "alice" ]); (`Bob, Arg.info [ "bob" ]) ] in
+  Arg.(value & vflag `Alice flags)
+
 let term =
   Term.(
     ret
       (const run $ term_setup_logs $ term_setup_random $ term_setup_temp
-     $ term_setup_dns $ relay $ secure_port $ password $ reproduce))
+     $ term_setup_dns $ relay $ secure_port $ password $ person $ reproduce))
 
-let _cmd =
+let cmd =
   let doc =
     "A simple program to talk with another person via a secured canal."
   in
   let man = [ `S Manpage.s_description; `P "" ] in
   Cmd.v (Cmd.info "talk" ~doc ~man) term
+
+let () = exit @@ Cmd.eval' cmd

lib/crypto.ml

@@ -125,7 +125,7 @@ let make ~ciphers:(cipher0, cipher1) ~shared_keys:(k0, k1) fd =
     Cstruct.create (2 + max_packet + Cipher_block.tag_size)
   in
   let send_record =
-    let (Symmetric { impl = (module Cipher_block); _ }) = recv in
+    let (Symmetric { impl = (module Cipher_block); _ }) = send in
     Cstruct.create (2 + max_packet + Cipher_block.tag_size)
   in
   {
@@ -239,6 +239,7 @@ module Make (Flow : FLOW) = struct
         Flow.read flow.fd >>= function
         | Error err -> Flow.return (Error (`Rd err))
         | Ok `Eof ->
+            Log.err (fun m -> m "End of transmission with our peer.");
             if await = `Await_hdr then Flow.return (Ok `End)
             else Flow.return (Error `Corrupted)
         | Ok (`Data cs) ->

lib/dune

@@ -21,8 +21,6 @@
  (name bob)
  (public_name bob)
  (modules crypto state handshake bob)
- (libraries bob.std bob.qe mirage-crypto hxd.core hxd.string logs spoke.core))
- (modules crypto state protocol bob)
  (libraries
   bob.std
   bob.qe
@@ -48,6 +46,12 @@
   (names bob))
  (libraries bob.std bob.fpath ke bheap logs unix))
 
+(library
+ (name json)
+ (public_name bob.json)
+ (modules json)
+ (libraries jsonm fmt))
+
 (library
  (name stream)
  (public_name bob.stream)

lib/extract.ml

@@ -0,0 +1,32 @@
+let kind tmp ~offset =
+  let open Fiber in
+  let open Stream in
+  Stream.run ~from:(Source.file ~offset tmp)
+    ~via:(Pack.inflate_entry ~reporter:Fiber.ignore)
+    ~into:Sink.to_string >>= fun (root, source) ->
+  Fiber.Option.iter Source.dispose source >>= fun () ->
+  Fiber.return (Git.tree_of_string root) >>? fun elements ->
+  match List.partition (function `Normal _ -> true | _ -> false) elements with
+  | [ `Normal name ], [] -> Fiber.return (OK (`File name))
+  | files, [] ->
+    let names = List.map (function `Normal name -> name | _ -> assert false) files in
+    Fiber.return (Ok (`Files names))
+  | [], [ _directory ] -> Fiber.return (Ok `Directory)
+  | _ -> Fiber.return (Error `Invalid_first_entry)
+
+let extract ?g ?metadata from destination =
+  let open Fiber in
+  let open Stream in
+  let tmp = Temp.random_temporary_path ?g "pack-%s.pack" in
+  let via = Flow.(save_into tmp << Pack.analyse ignore) in
+  Stream.run ~from ~via ~into:Sink.first >>= function
+  | Some (`End _, _, _, _), _ | None, _ -> Fiber.return (Error `Empty_pack_file)
+  | Some (`Elt (offset, _status, `Base (`B, _weight)), decoder, src, off), leftover ->
+    begin kind tmp ~offset >>? fun kind -> match kind, Stdlib.Option.map Metadata.kind_of_document metadata with
+    | `File name, (Some `File | None) -> assert false
+    | `Files names, (Some `Files | None) -> assert false
+    | `Directory, (Some `Directory | None) -> assert false
+      collect_and_verify_with_reporter quiet ~config entry tmp decoder ~src ~off leftover
+      >>= Pack.unpack tmp
+      >>? fun (name, total, hash, pack) ->
+    | _ -> Fiber.return (Error `Unexpected_kind_of_document) end

lib/fiber.ml

@@ -195,6 +195,8 @@ let pwr = Hashtbl.create 0x100
 
 let write fd bstr ~off ~len : (int, [ `Closed | `Unix of Unix.error ]) result t
     =
+  if off < 0 || len < 0 || off > Bigarray.Array1.dim bstr - len then
+    invalid_arg "Invalid write";
   match Hashtbl.find_opt pwr fd with
   | Some (`Write (_, ivar)) -> Ivar.read ivar
   | _ ->

lib/handshake.ml

@@ -1,4 +1,4 @@
-let src = Logs.Src.create "bob.protocol"
+let src = Logs.Src.create "bob.handshake"
 
 module Log = (val Logs.src_log src : Logs.LOG)