<commit_before>(*
 * Copyright (C) 2011-2015 Citrix Inc
 *
 * This program is free software; you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published
 * by the Free Software Foundation; version 2.1 only. with the special
 * exception on linking described in file LICENSE.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *)

let project_url = "http://github.com/xapi-project/nbd"

open Lwt

module Device = struct
  type id = [
    | `Nbd of Uri.t
    | `Local of string
  ]
  type t = [
    | `Nbd of Nbd_lwt_unix.Client.t
    | `Local of Block.t
  ]
  type 'a io = 'a Lwt.t
  type page_aligned_buffer = Cstruct.t
  type error = [
    | `Unknown of string
    | `Unimplemented
    | `Is_read_only
    | `Disconnected
  ]

  let connect uri = match Uri.scheme uri with
    | Some "file" ->
      let path = Uri.path uri in
      ( Block.connect path
        >>= function
        | `Error e -> return (`Error (`Unknown (Printf.sprintf "Failed to open %s" path)))
        | `Ok x -> return (`Ok (`Local x) ))
    | Some "nbd" ->
      begin match Uri.host uri with
        | Some host ->
          let port = match Uri.port uri with None -> 10809 | Some x -> x in
          Nbd_lwt_unix.connect host port
          >>= fun channel ->
          Nbd_lwt_unix.Client.negotiate channel (Uri.to_string uri)
          >>= fun (t, _, _) ->
          return (`Ok (`Nbd t))
        | None -> return (`Error (`Unknown "Cannot connect to nbd without a host"))
      end
    | _ -> return (`Error (`Unknown "unknown scheme"))

  type info = {
    read_write: bool;
    sector_size: int;
    size_sectors: int64;
  }

  let get_info = function
    | `Nbd t ->
      Nbd_lwt_unix.Client.get_info t
      >>= fun info ->
      return {
        read_write = info.Nbd_lwt_unix.Client.read_write;
        sector_size = info.Nbd_lwt_unix.Client.sector_size;
        size_sectors = info.Nbd_lwt_unix.Client.size_sectors
      }
    | `Local t ->
      Block.get_info t
      >>= fun info ->
      return {
        read_write = info.Block.read_write;
        sector_size = info.Block.sector_size;
        size_sectors = info.Block.size_sectors
      }

  let read t = match t with
    | `Nbd t -> Nbd_lwt_unix.Client.read t
    | `Local t -> Block.read t

  let write t = match t with
    | `Nbd t -> Nbd_lwt_unix.Client.write t
    | `Local t -> Block.write t

  let disconnect t = match t with
    | `Nbd t -> Nbd_lwt_unix.Client.disconnect t
    | `Local t -> Block.disconnect t
end

open Common
open Cmdliner

(* Help sections common to all commands *)

let _common_options = "COMMON OPTIONS"
let help = [
  `S _common_options;
  `P "These options are common to all commands.";
  `S "MORE HELP";
  `P "Use `$(mname) $(i,COMMAND) --help' for help on a single command."; `Noblank;
  `S "BUGS"; `P (Printf.sprintf "Check bug reports at %s" project_url);
]

(* Options common to all commands *)
let common_options_t =
  let docs = _common_options in
  let debug =
    let doc = "Give only debug output." in
    Arg.(value & flag & info ["debug"] ~docs ~doc) in
  let verb =
    let doc = "Give verbose output." in
    let verbose = true, Arg.info ["v"; "verbose"] ~docs ~doc in
    Arg.(last & vflag_all [false] [verbose]) in
  Term.(pure Common.make $ debug $ verb)

module Impl = struct
  open Lwt
  open Nbd

  let require name arg = match arg with
    | None -> failwith (Printf.sprintf "Please supply a %s argument" name)
    | Some x -> x

  let size host port export =
    let res =
      Nbd_lwt_unix.connect host port
      >>= fun client ->
      Client.negotiate client export in
    let (_,size,_) = Lwt_main.run res in
    Printf.printf "%Ld\n%!" size;
    `Ok ()

  let list common host port =
    let t =
      Nbd_lwt_unix.connect host port
      >>= fun channel ->
      Client.list channel
      >>= function
      | `Ok disks ->
        List.iter print_endline disks;
        return ()
      | `Error `Unsupported ->
        Printf.fprintf stderr "The server does not support the query function.\n%!";
        exit 1
      | `Error `Policy ->
        Printf.fprintf stderr "The server configuration does not permit listing exports.\n%!";
        exit 2 in
    `Ok (Lwt_main.run t)

  let serve common filename port =
    let filename = require "filename" filename in
    let t =
      let sock = Lwt_unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in
      let sockaddr = Lwt_unix.ADDR_INET(Unix.inet_addr_any, port) in
      Lwt_unix.bind sock sockaddr;
      Lwt_unix.listen sock 5;
      let rec loop () =
        Lwt_unix.accept sock
        >>= fun (fd, _) ->
        (* Background thread per connection *)
        let _ =
          let channel = Nbd_lwt_unix.of_fd fd in
          Server.connect channel ()
          >>= fun (name, t) ->
          Block.connect filename
          >>= function
          | `Error _ ->
            Printf.fprintf stderr "Failed to open %s\n%!" filename;
            exit 1
          | `Ok b ->
            Server.serve t (module Block) b in
        loop () in
      loop () in
    Lwt_main.run t;
    `Ok ()

let mirror common filename port secondary =
  let filename = require "filename" filename in
  let secondary = require "secondary" secondary in
  let t =
    let sock = Lwt_unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in
    let sockaddr = Lwt_unix.ADDR_INET(Unix.inet_addr_any, port) in
    Lwt_unix.bind sock sockaddr;<commit_msg>connect does not return a result anymore<commit_after>(*
 * Copyright (C) 2011-2015 Citrix Inc
 *
 * This program is free software; you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published
 * by the Free Software Foundation; version 2.1 only. with the special
 * exception on linking described in file LICENSE.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *)

let project_url = "http://github.com/xapi-project/nbd"

open Lwt

module Device = struct
  type id = [
    | `Nbd of Uri.t
    | `Local of string
  ]
  type t = [
    | `Nbd of Nbd_lwt_unix.Client.t
    | `Local of Block.t
  ]
  type 'a io = 'a Lwt.t
  type page_aligned_buffer = Cstruct.t
  type error = [
    | `Unknown of string
    | `Unimplemented
    | `Is_read_only
    | `Disconnected
  ]

  let connect uri = match Uri.scheme uri with
    | Some "file" ->
      let path = Uri.path uri in
      ( Block.connect path >|= fun x ->
        `Local x )
    | Some "nbd" ->
      begin match Uri.host uri with
        | Some host ->
          let port = match Uri.port uri with None -> 10809 | Some x -> x in
          Nbd_lwt_unix.connect host port
          >>= fun channel ->
          Nbd_lwt_unix.Client.negotiate channel (Uri.to_string uri)
          >>= fun (t, _, _) ->
          return (`Nbd t)
        | None -> fail_with "Cannot connect to nbd without a host"
      end
    | _ -> fail_with "unknown scheme"

  type info = {
    read_write: bool;
    sector_size: int;
    size_sectors: int64;
  }

  let get_info = function
    | `Nbd t ->
      Nbd_lwt_unix.Client.get_info t
      >>= fun info ->
      return {
        read_write = info.Nbd_lwt_unix.Client.read_write;
        sector_size = info.Nbd_lwt_unix.Client.sector_size;
        size_sectors = info.Nbd_lwt_unix.Client.size_sectors
      }
    | `Local t ->
      Block.get_info t
      >>= fun info ->
      return {
        read_write = info.Block.read_write;
        sector_size = info.Block.sector_size;
        size_sectors = info.Block.size_sectors
      }

  let read t = match t with
    | `Nbd t -> Nbd_lwt_unix.Client.read t
    | `Local t -> Block.read t

  let write t = match t with
    | `Nbd t -> Nbd_lwt_unix.Client.write t
    | `Local t -> Block.write t

  let disconnect t = match t with
    | `Nbd t -> Nbd_lwt_unix.Client.disconnect t
    | `Local t -> Block.disconnect t
end

open Common
open Cmdliner

(* Help sections common to all commands *)

let _common_options = "COMMON OPTIONS"
let help = [
  `S _common_options;
  `P "These options are common to all commands.";
  `S "MORE HELP";
  `P "Use `$(mname) $(i,COMMAND) --help' for help on a single command."; `Noblank;
  `S "BUGS"; `P (Printf.sprintf "Check bug reports at %s" project_url);
]

(* Options common to all commands *)
let common_options_t =
  let docs = _common_options in
  let debug =
    let doc = "Give only debug output." in
    Arg.(value & flag & info ["debug"] ~docs ~doc) in
  let verb =
    let doc = "Give verbose output." in
    let verbose = true, Arg.info ["v"; "verbose"] ~docs ~doc in
    Arg.(last & vflag_all [false] [verbose]) in
  Term.(pure Common.make $ debug $ verb)

module Impl = struct
  open Lwt
  open Nbd

  let require name arg = match arg with
    | None -> failwith (Printf.sprintf "Please supply a %s argument" name)
    | Some x -> x

  let size host port export =
    let res =
      Nbd_lwt_unix.connect host port
      >>= fun client ->
      Client.negotiate client export in
    let (_,size,_) = Lwt_main.run res in
    Printf.printf "%Ld\n%!" size;
    `Ok ()

  let list common host port =
    let t =
      Nbd_lwt_unix.connect host port
      >>= fun channel ->
      Client.list channel
      >>= function
      | `Ok disks ->
        List.iter print_endline disks;
        return ()
      | `Error `Unsupported ->
        Printf.fprintf stderr "The server does not support the query function.\n%!";
        exit 1
      | `Error `Policy ->
        Printf.fprintf stderr "The server configuration does not permit listing exports.\n%!";
        exit 2 in
    `Ok (Lwt_main.run t)

  let serve common filename port =
    let filename = require "filename" filename in
    let t =
      let sock = Lwt_unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in
      let sockaddr = Lwt_unix.ADDR_INET(Unix.inet_addr_any, port) in
      Lwt_unix.bind sock sockaddr;
      Lwt_unix.listen sock 5;
      let rec loop () =
        Lwt_unix.accept sock
        >>= fun (fd, _) ->
        (* Background thread per connection *)
        let _ =
          let channel = Nbd_lwt_unix.of_fd fd in
          Server.connect channel ()
          >>= fun (name, t) ->
          Block.connect filename
          >>= fun b ->
          Server.serve t (module Block) b in
        loop () in
      loop () in
    Lwt_main.run t;
    `Ok ()

let mirror common filename port secondary =
  let filename = require "filename" filename in
  let secondary = require "secondary" secondary in
  let t =
    let sock = Lwt_unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in
    let sockaddr = Lwt_unix.ADDR_INET(Unix.inet_addr_any, port) in
    Lwt_unix.bind sock sockaddr;
{'fraction_non_alphanumeric': 0.09949072389959986, 'fraction_numerical': 0.004092397235358312, 'mean_word_length': 2.3153451914380465, 'pattern_counts': {'":': 0, '<': 3, '<?xml version=': 0, '>': 108, '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': '1813935', 'n_tokens_mistral': 3642, 'n_tokens_neox': 3530, 'n_words': 1213}