<commit_before>(*
 * Copyright (C) 2016 <NAME> <<EMAIL>>
 *
 * Permission to use, copy, modify, and distribute this software for any
 * purpose with or without fee is hereby granted, provided that the above
 * copyright notice and this permission notice appear in all copies.
 *
 * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
 * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
 * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
 * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
 * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
 * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
 * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
 *
 *)
open Lwt
open Dns

let src =
  let src = Logs.Src.create "dns" ~doc:"Resolve DNS queries on the host" in
  Logs.Src.set_level src (Some Logs.Info);
  src

module Log = (val Logs.src_log src : Logs.LOG)

(* A queue of responses per source port. Returning results out of order
   seems to confuse the Linux resolver, even though the requests and responses
   have transaction ids *)

type response_sender = unit -> unit Lwt.t

type queue = {
  senders: response_sender Lwt.t Queue.t;
}

let per_source_port : (int, queue) Hashtbl.t = Hashtbl.create 7

let enter_queue src_port =
  let t, u = Lwt.task () in
  if Hashtbl.mem per_source_port src_port then begin
    let q = Hashtbl.find per_source_port src_port in
    Queue.push t q.senders;
  end else begin
    let senders = Queue.create () in
    let q = { senders } in
    Hashtbl.replace per_source_port src_port q;
    Queue.push t q.senders;
    let rec process () =
      if Queue.is_empty q.senders then begin
        Hashtbl.remove per_source_port src_port;
        Lwt.return ()
      end else begin
        let t = Queue.pop q.senders in
        t >>= fun response_sender ->
        response_sender ()
        >>= fun () ->
        process ()
      end in
    let _thread = process () in
    ()
  end;
  u

let input s ~src ~dst ~src_port buf =
  let wakener = enter_queue src_port in

  (* Re-read /etc/resolv.conf on every request. This ensures that
     changes to DNS on sleep/resume or switching networks are reflected
     immediately. The file is very small, and parsing it shouldn't be
     too slow. *)
  Dns_resolver_unix.create () (* re-read /etc/resolv.conf *)
  >>= fun resolver ->

  (* HACK: grab the DNS response in [process] but which isn't conveniently
     returned by processor *)
  let response = ref None in

  let src_str = Ipaddr.V4.to_string src in
  let dst_str = Ipaddr.V4.to_string dst in

  let process ~src ~dst packet =
    let open Packet in
    Log.info (fun f -> f "DNS %s:%d -> %s %s" src_str src_port dst_str (Dns.Packet.to_string packet));
    match packet.questions with
    | [] ->
      return None; (* no questions in packet *)
    | [q] ->
      Lwt.catch
        (fun () ->
          Dns_resolver_unix.resolve resolver q.q_class q.q_type q.q_name
          >>= fun result ->
          let result = { result with Dns.Packet.id = packet.Dns.Packet.id } in
          response := Some result;
          (return (Some (Dns.Query.answer_of_response result)))
        ) (function
          | Dns.Protocol.Dns_resolve_error exns ->
            Log.err (fun f -> f "DNS resolution failed for %s: %s" (Dns.Packet.question_to_string q) (String.concat "; " (List.map Printexc.to_string exns)));
            return None
          | e ->
            Log.err (fun f -> f "DNS resolution failed for %s: %s" (Dns.Packet.question_to_string q) (Printexc.to_string e));
            return None
          )
    | _::_::_ -> return None in

  let processor = ((Dns_server.processor_of_process process) :> (module Dns_server.PROCESSOR)) in
  let open Dns_server in
  let len = Cstruct.len buf in
  let buf = Dns.Buf.of_cstruct buf in
  let src' = Ipaddr.V4 src, src_port in
  let dst' = Ipaddr.V4 dst, 53 in
  let obuf = Dns.Buf.create 4096 in
  process_query buf len obuf src' dst' processor
  >>= function
  | None ->
    Lwt.wakeup_later wakener (fun () -> Lwt.return_unit);
    Lwt.return_unit
  | Some buf ->
    let buf = Cstruct.of_bigarray buf in
    (* Take a copy of the response buffer to put in the response queue *)
    let copy = Cstruct.create (Cstruct.len buf) in
    Cstruct.blit buf 0 copy 0 (Cstruct.len buf);
    Lwt.wakeup_later wakener
      (fun () ->
        Tcpip_stack.UDPV4.write ~source_port:53 ~dest_ip:src ~dest_port:src_port (Tcpip_stack.udpv4 s) copy
        >>= fun () ->
        Log.info (fun f -> f "DNS %s:%d <- %s %s" src_str src_port dst_str (match !response with Some x -> Dns.Packet.to_string x | None -> "None"));
        Lwt.return ()
      );
    Lwt.return ()<commit_msg>com.docker.slirp: simplify use of the DNS API<commit_after>(*
 * Copyright (C) 2016 <NAME> <<EMAIL>>
 *
 * Permission to use, copy, modify, and distribute this software for any
 * purpose with or without fee is hereby granted, provided that the above
 * copyright notice and this permission notice appear in all copies.
 *
 * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
 * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
 * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
 * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
 * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
 * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
 * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
 *
 *)
open Lwt
open Dns

let src =
  let src = Logs.Src.create "dns" ~doc:"Resolve DNS queries on the host" in
  Logs.Src.set_level src (Some Logs.Info);
  src

module Log = (val Logs.src_log src : Logs.LOG)

module OptionThread = struct
  let (>>=) m f = m >>= function
    | None -> Lwt.return_none
    | Some x -> f x
end

(* A queue of responses per source port. Returning results out of order
   seems to confuse the Linux resolver, even though the requests and responses
   have transaction ids *)

type response_sender = unit -> unit Lwt.t

type queue = {
  senders: response_sender Lwt.t Queue.t;
}

let per_source_port : (int, queue) Hashtbl.t = Hashtbl.create 7

let enter_queue src_port =
  let t, u = Lwt.task () in
  if Hashtbl.mem per_source_port src_port then begin
    let q = Hashtbl.find per_source_port src_port in
    Queue.push t q.senders;
  end else begin
    let senders = Queue.create () in
    let q = { senders } in
    Hashtbl.replace per_source_port src_port q;
    Queue.push t q.senders;
    let rec process () =
      if Queue.is_empty q.senders then begin
        Hashtbl.remove per_source_port src_port;
        Lwt.return ()
      end else begin
        let t = Queue.pop q.senders in
        t >>= fun response_sender ->
        response_sender ()
        >>= fun () ->
        process ()
      end in
    let _thread = process () in
    ()
  end;
  u

let input s ~src ~dst ~src_port buf =
  let wakener = enter_queue src_port in

  (* Re-read /etc/resolv.conf on every request. This ensures that
     changes to DNS on sleep/resume or switching networks are reflected
     immediately. The file is very small, and parsing it shouldn't be
     too slow. *)
  Dns_resolver_unix.create () (* re-read /etc/resolv.conf *)
  >>= fun resolver ->

  let src_str = Ipaddr.V4.to_string src in
  let dst_str = Ipaddr.V4.to_string dst in

  let len = Cstruct.len buf in
  let buf = Dns.Buf.of_cstruct buf in
  let obuf = Dns.Buf.create 4096 in

  let result =
    let open OptionThread in
    ( match Dns.Protocol.Server.parse (Dns.Buf.sub buf 0 len) with
    | None ->
      Log.err (fun f -> f "Failed to parse DNS packet");
      Lwt.return_none
    | Some request ->
      Log.info (fun f -> f "DNS %s:%d -> %s %s" src_str src_port dst_str (Dns.Packet.to_string request));
      begin match request.Dns.Packet.questions with
      | [] -> Lwt.return_none (* no questions in packet *)
      | [q] ->
        Lwt.catch
          (fun () ->
            let open Lwt.Infix in
            Dns_resolver_unix.resolve resolver q.Dns.Packet.q_class q.Dns.Packet.q_type q.Dns.Packet.q_name
            >>= fun response ->
            Lwt.return (Some (request, { response with Dns.Packet.id = request.Dns.Packet.id }))
          ) (function
            | Dns.Protocol.Dns_resolve_error exns ->
              Log.err (fun f -> f "DNS resolution failed for %s: %s" (Dns.Packet.question_to_string q) (String.concat "; " (List.map Printexc.to_string exns)));
              Lwt.return_none
            | e ->
              Log.err (fun f -> f "DNS resolution failed for %s: %s" (Dns.Packet.question_to_string q) (Printexc.to_string e));
              Lwt.return_none
            )
      | _::_::_ ->
        Log.err (fun f -> f "More than 1 query in DNS request: %s" (Dns.Packet.to_string request));
        Lwt.return_none
      end
    ) >>= fun (request, response) ->
    let query = Dns.Protocol.Server.query_of_context request in
    let answer = Dns.Query.answer_of_response response in
    let response = Dns.Query.response_of_answer query answer in
    match Dns.Protocol.Server.marshal obuf request response with
    | None -> Lwt.return_none
    | Some buf -> Lwt.return (Some (response, buf)) in

  result
  >>= function
  | None ->
    Lwt.wakeup_later wakener (fun () -> Lwt.return_unit);
    Lwt.return_unit
  | Some (response, buf) ->
    let buf = Cstruct.of_bigarray buf in
    (* Take a copy of the response buffer to put in the response queue *)
    let copy = Cstruct.create (Cstruct.len buf) in
    Cstruct.blit buf 0 copy 0 (Cstruct.len buf);
    Lwt.wakeup_later wakener
      (fun () ->
        Tcpip_stack.UDPV4.write ~source_port:53 ~dest_ip:src ~dest_port:src_port (Tcpip_stack.udpv4 s) copy
        >>= fun () ->
        Log.info (fun f -> f "DNS %s:%d <- %s %s" src_str src_port dst_str (Dns.Packet.to_string response));
        Lwt.return ()
      );
    Lwt.return ()
{'fraction_non_alphanumeric': 0.097198684079354, 'fraction_numerical': 0.003987638321204267, 'mean_word_length': 2.6559766763848396, 'pattern_counts': {'":': 0, '<': 11, '<?xml version=': 0, '>': 93, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 0, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '663088', 'n_tokens_mistral': 3323, 'n_tokens_neox': 3233, 'n_words': 1138}