<commit_before>
open Lwt

(* XXX
 * Awaiting proper entropy devices.... *)
let () = Nocrypto.Rng.reseed Cstruct.(of_string "\001\002\003\004")

module Make (TCP: V1_LWT.TCPV4) = struct

  module TCP = TCP
  type error = TCP.error

  type tracer = Sexplib.Sexp.t -> unit

  type flow = {
    role           : [ `Server | `Client ] ;
    tcp            : TCP.flow ;
    tracer         : tracer option ;
    mutable state  : [ `Active of Tls.Engine.state
                     | `Eof
                     | `Error of error ] ;
    mutable linger : Cstruct.t list ;
  }

  let error_of_alert alert =
    `Unknown (Tls.Packet.alert_type_to_string alert)

  let list_of_option = function None -> [] | Some x -> [x]

  let tracing flow f =
    match flow.tracer with
    | None      -> f ()
    | Some hook -> Tls.Tracing.active ~hook f

  let read_react flow =

    let handle tls buf =
      match
        tracing flow @@ fun () -> Tls.Engine.handle_tls tls buf
      with
      | `Ok (res, answer, appdata) ->
          flow.state <- ( match res with
            | `Ok tls      -> `Active tls
            | `Eof         -> `Eof
            | `Alert alert -> `Error (error_of_alert alert) );
          TCP.write flow.tcp answer >>
          ( match res with
            | `Ok _ -> return_unit
            | _     -> TCP.close flow.tcp ) >>
          return (`Ok appdata)
      | `Fail (alert, answer)      ->
          let reason = `Error (error_of_alert alert) in
          flow.state <- reason ;
          TCP.(write flow.tcp answer >> close flow.tcp) >> return reason
    in
    match flow.state with
    | `Eof | `Error _ as e -> return e
    | `Active tls          ->
        TCP.read flow.tcp >>= function
          | `Eof | `Error _ as e -> flow.state <- e ; return e
          | `Ok buf              -> handle tls buf

  let rec read flow =
    match flow.linger with
    | [] ->
      ( read_react flow >>= function
          | `Ok None             -> read flow
          | `Ok (Some buf)       -> return (`Ok buf)
          | `Eof | `Error _ as e -> return e )
    | bufs ->
        flow.linger <- [] ;
        return (`Ok (Tls.Utils.Cs.appends @@ List.rev bufs))

  let writev flow bufs =
    match flow.state with
    | `Eof     -> fail @@ Invalid_argument "tls: write: flow is closed"
    | `Error e -> fail @@ Invalid_argument "tls: write: flow is broken"
    | `Active tls ->
        match
          tracing flow @@ fun () -> Tls.Engine.send_application_data tls bufs
        with
        | Some (tls, answer) ->
            flow.state <- `Active tls ; TCP.write flow.tcp answer
        | None ->
            (* "Impossible" due to handhake draining. *)
            fail @@ Invalid_argument "tls: write: flow not ready to send"

  let write flow buf = writev flow [buf]

  let rekey flow =
    match flow.state with
    | `Active tls ->
       let to_send = tracing flow @@ fun () -> Tls.Engine.rekey tls in
       ( match to_send with
         | Some (tls', buf) -> flow.state <- `Active tls' ; TCP.write flow.tcp buf
         | None             -> return_unit )
    | e           -> return_unit

  let close flow =
    match flow.state with
    | `Active tls ->
      flow.state <- `Eof ;
      let (_, buf) =
        tracing flow @@ fun () -> Tls.Engine.send_close_notify tls
      in
      TCP.(write flow.tcp buf >> close flow.tcp)<commit_msg>note unfinished err semantics<commit_after>
open Lwt

(* XXX
 * Awaiting proper entropy devices.... *)
let () = Nocrypto.Rng.reseed Cstruct.(of_string "\001\002\003\004")

module Make (TCP: V1_LWT.TCPV4) = struct

  module TCP = TCP
  type error = TCP.error

  type tracer = Sexplib.Sexp.t -> unit

  type flow = {
    role           : [ `Server | `Client ] ;
    tcp            : TCP.flow ;
    tracer         : tracer option ;
    mutable state  : [ `Active of Tls.Engine.state
                     | `Eof
                     | `Error of error ] ;
    mutable linger : Cstruct.t list ;
  }

  let error_of_alert alert =
    `Unknown (Tls.Packet.alert_type_to_string alert)

  let list_of_option = function None -> [] | Some x -> [x]

  let tracing flow f =
    match flow.tracer with
    | None      -> f ()
    | Some hook -> Tls.Tracing.active ~hook f

  let read_react flow =

    let handle tls buf =
      match
        tracing flow @@ fun () -> Tls.Engine.handle_tls tls buf
      with
      | `Ok (res, answer, appdata) ->
          flow.state <- ( match res with
            | `Ok tls      -> `Active tls
            | `Eof         -> `Eof
            | `Alert alert -> `Error (error_of_alert alert) );
          TCP.write flow.tcp answer >>
          ( match res with
            | `Ok _ -> return_unit
            | _     -> TCP.close flow.tcp ) >>
          return (`Ok appdata)
      | `Fail (alert, answer)      ->
          let reason = `Error (error_of_alert alert) in
          flow.state <- reason ;
          TCP.(write flow.tcp answer >> close flow.tcp) >> return reason
    in
    match flow.state with
    | `Eof | `Error _ as e -> return e
    | `Active tls          ->
        TCP.read flow.tcp >>= function
          | `Eof | `Error _ as e -> flow.state <- e ; return e
          | `Ok buf              -> handle tls buf

  let rec read flow =
    match flow.linger with
    | [] ->
      ( read_react flow >>= function
          | `Ok None             -> read flow
          | `Ok (Some buf)       -> return (`Ok buf)
          | `Eof | `Error _ as e -> return e )
    | bufs ->
        flow.linger <- [] ;
        return (`Ok (Tls.Utils.Cs.appends @@ List.rev bufs))

  let writev flow bufs =
    match flow.state with
    | `Eof     -> fail @@ Invalid_argument "tls: write: flow is closed"
    | `Error e -> fail @@ Invalid_argument "tls: write: flow is broken"
    | `Active tls ->
        match
          tracing flow @@ fun () -> Tls.Engine.send_application_data tls bufs
        with
        | Some (tls, answer) ->
            flow.state <- `Active tls ; TCP.write flow.tcp answer
        | None ->
            (* "Impossible" due to handhake draining. *)
            fail @@ Invalid_argument "tls: write: flow not ready to send"

  let write flow buf = writev flow [buf]

  (* XXX Error semantics - what if we already error'd out? *)
  let rekey flow =
    match flow.state with
    | `Active tls ->
       let to_send = tracing flow @@ fun () -> Tls.Engine.rekey tls in
       ( match to_send with
         | Some (tls', buf) -> flow.state <- `Active tls' ; TCP.write flow.tcp buf
         | None             -> return_unit )
    | e           -> return_unit

  let close flow =
    match flow.state with
    | `Active tls ->
      flow.state <- `Eof ;
      let (_, buf) =
        tracing flow @@ fun () -> Tls.Engine.send_close_notify tls
      in
      TCP.(write flow.tcp buf >> close flow.tcp)
{'fraction_non_alphanumeric': 0.11793286219081273, 'fraction_numerical': 0.004122497055359246, 'mean_word_length': 1.6197454685692247, 'pattern_counts': {'":': 0, '<': 17, '<?xml version=': 0, '>': 101, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 2, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '4585120', 'n_tokens_mistral': 2158, 'n_tokens_neox': 2062, 'n_words': 657}