: SYSTEM = struct

  let wrap_deferred_system cmd f =
    wrap_deferred f ~on_exn:(fun e -> `System (cmd, `Exn e))
  let fail_sys r = fail (`System r)

  module Shell = struct

    let discriminate_process_status s ret =
      begin match ret with
      | Lwt_unix.WEXITED 0 -> return ()
      | Lwt_unix.WEXITED n -> fail (`Shell (s, `Exited n))
      | Lwt_unix.WSIGNALED n -> fail (`Shell (s, `Signaled n))
      | Lwt_unix.WSTOPPED n -> fail (`Shell (s, `Stopped n))
    end

    let status_to_string = function
    | `Exited i -> sprintf "Exited with %d" i
    | `Exn e -> sprintf "Exception %s" (exn e)
    | `Signaled i -> sprintf "Signaled (%d)" i
    | `Stopped i -> sprintf "Stopped (%d)" i

    let do_or_fail s =
      wrap_deferred  Lwt_io.(fun () -> Lwt_unix.system s)
        ~on_exn:(fun e -> `Shell (s, `Exn e))
      >>= fun ret ->
      discriminate_process_status s ret


    let execute s =
      wrap_deferred ~on_exn:(fun e -> `Shell (s, `Exn e))
        Lwt.(fun () ->
          let inprocess = Lwt_process.(open_process_full (shell s)) in
          Lwt_list.map_p Lwt_io.read
            [inprocess#stdout; inprocess#stderr; ]
          >>= fun output ->
          inprocess#status >>= fun status ->
          return (status, output))
      >>= fun (ret, output) ->
      let code =
        match ret with
        | Lwt_unix.WEXITED n ->   (`Exited n)
        | Lwt_unix.WSIGNALED n -> (`Signaled n)
        | Lwt_unix.WSTOPPED n ->  (`Stopped n)
      in
      begin match output with
      | [out; err] -> return (out, err, code)
      | _ -> assert false
      end

  end


  let sleep f =
    wrap_deferred_system (`Sleep f) (fun () -> Lwt_unix.sleep f)

  let with_timeout time ~f =
    Lwt.catch
      begin fun () ->
        Lwt_unix.with_timeout time f
      end
      begin function
      | Lwt_unix.Timeout -> fail (`Timeout time)
      | e -> fail_sys (`With_timeout time, `Exn e)
      end


  let mkdir_or_fail ?(perm=0o700) dirname =
    let fail_here e =
      fail_sys (`Make_directory dirname, e) in
    Lwt.catch
      Lwt.(fun () -> Lwt_unix.mkdir dirname perm >>= fun () -> return (`Ok ()))
      begin function
      | Unix.Unix_error (Unix.EACCES, cmd, arg)  ->
        fail_here (`Wrong_access_rights perm)
      | Unix.Unix_error (Unix.EEXIST, cmd, arg)  ->
        fail_here (`Already_exists)
      | Unix.Unix_error (Unix.EISDIR, cmd, arg)  ->
        (* Bypass MacOSX bug https://github.com/janestreet/core/issues/7 *)
        fail_here (`Already_exists)
      | e -> fail_here (`Exn e)
      end

  let mkdir_even_if_exists ?(perm=0o700) dirname =
    let fail_here e =
      fail_sys (`Make_directory dirname, e) in
    Lwt.catch
      Lwt.(fun () -> Lwt_unix.mkdir dirname perm >>= fun () -> return (`Ok ()))
      begin function
      | Unix.Unix_error (Unix.EACCES, cmd, arg)  ->
        fail_here (`Wrong_access_rights perm)
      | Unix.Unix_error (Unix.EISDIR, cmd, arg)  ->
        (* Bypass MacOSX bug https://github.com/janestreet/core/issues/7 *)
        return ()
      | Unix.Unix_error (Unix.EEXIST, cmd, arg)  -> return ()
      | e -> fail_here (`Exn e)
      end

  let make_new_directory ?perm dirname =
    mkdir_or_fail ?perm dirname

  let ensure_directory_path ?perm dirname =
    (* Code inspired by Core.Std.Unix *)
    let init, dirs =
      match Filename.parts dirname with
      | [] -> ksprintf failwith "Sys.mkdir_p: BUG! Filename.parts %s -> []" dirname
      | init :: dirs -> (init, dirs)
    in
    mkdir_even_if_exists ?perm init
    >>= fun () ->
    List.fold_left dirs ~init:(return init) ~f:(fun m part ->
        m >>= fun previous ->
        let dir = Filename.concat previous part in
        mkdir_even_if_exists ?perm dir
        >>= fun () ->
        return dir)
    >>= fun _ ->
    return ()

  type file_info =
    [ `Absent
    | `Regular_file of int
    | `Symlink of string
    | `Block_device
    | `Character_device
    | `Directory
    | `Fifo
    | `Socket]

(*
  WARNING: this is a work-around for issue [329] with Lwt_unix.readlink.
  When it is fixed, we should go back to Lwt_unix.

  [329]: http://ocsigen.org/trac/ticket/329
*)
  let lwt_unix_readlink l =
    let open Lwt in
    Lwt_preemptive.detach Unix.readlink l

  let file_info ?(follow_symlink=false) path =
    let stat_fun =
      if follow_symlink then Lwt_unix.stat else Lwt_unix.lstat in
    (* eprintf "(l)stat %s? \n%!" path; *)
    Lwt.catch
      Lwt.(fun () -> stat_fun path >>= fun s -> return (`Ok (`Unix_stats s)))
      begin function
      | Unix.Unix_error (Unix.ENOENT, cmd, arg)  -> return `Absent
      | e -> fail_sys (`File_info path, `Exn e)
      end
    >>= fun m ->
    let open Lwt_unix in
    begin match m with
    | `Absent -> return `Absent
    | `Unix_stats stats ->
      begin match stats.st_kind with
      | S_DIR -> return (`Directory)
      | S_REG -> return (`Regular_file (stats.st_size))
      | S_LNK ->
        (* eprintf "readlink %s? \n%!" path; *)
        begin
          catch_deferred (fun () -> lwt_unix_readlink path)
          >>< begin function
          | `Ok s -> return s
          | `Error e -> fail (`System (`File_info path, `Exn e))
          end
        end
        >>= fun destination ->
        (* eprintf "readlink %s worked \n%!" path; *)
        return (`Symlink destination)
      | S_CHR -> return (`Character_device)
      | S_BLK -> return (`Block_device)
      | S_FIFO -> return (`Fifo)
      | S_SOCK -> return (`Socket)
      end
    end

  let list_directory path =
    let f_stream = Lwt_unix.files_of_directory path in
    let next s =
      wrap_deferred ~on_exn:(fun e -> `System (`List_directory path, `Exn e))
        Lwt.(fun () ->
            catch (fun () -> Lwt_stream.next s >>= fun n -> return (Some n))
              (function Lwt_stream.Empty -> return None | e -> fail e)) in
    `Stream (fun () -> (next f_stream))

  let remove path =
    let rec remove_aux path =
      file_info path
      >>= begin function
      | `Absent -> return ()
      | `Block_device
      | `Character_device
      | `Symlink _
      | `Fifo
      | `Socket
      | `Regular_file _-> wrap_deferred_system (`Remove path) (fun () -> Lwt_unix.unlink path)
      | `Directory ->
        let `Stream next_dir = list_directory path in
        let rec loop () =
          next_dir ()
          >>= begin function
          | Some ".."
          | Some "." -> loop ()
          | Some name ->
            remove_aux (Filename.concat path name)
            >>= fun () ->
            loop ()
          | None -> return ()
          end
        in
        loop ()
        >>= fun () ->
        wrap_deferred_system (`Remove path) (fun () -> Lwt_unix.rmdir path)
      end
    in
    remove_aux path
    >>< begin function
    | `Ok () -> return ()
    | `Error (`System_exn e) -> fail (`System (`Remove path, `Exn e))
    | `Error (`System e) -> fail (`System e)
    end

  let make_symlink ~target ~link_path =
    wrap_deferred (fun () -> Lwt_unix.symlink target link_path)
      ~on_exn:(fun e ->
          begin match e with
          | Unix.Unix_error (Unix.EEXIST, cmd, arg)  ->
            (`System (`Make_symlink (target, link_path), `File_exists link_path))
          | e ->  (`System (`Make_symlink (target, link_path), `Exn e))
          end)

  type file_destination = [
    | `Into of string
    | `Onto of string
  ]
  let path_of_destination ~src ~dst =
    match dst with
    | `Into p -> Filename.(concat p (basename src))
    | `Onto p -> p

  let copy
      ?(ignore_strange=false) ?(symlinks=`Fail) ?(buffer_size=64_000)
      ?(if_exists=`Fail)
      ~src dst =
    let rec copy_aux ~src ~dst =
      file_info src
      >>= begin function
      | `Absent -> fail (`File_not_found src)
      | `Block_device
      | `Character_device
      | `Fifo
      | `Socket as k ->
        if ignore_strange then return () else fail (`Wrong_file_kind (src, k))
      | `Symlink content ->
        begin match symlinks with
        | `Fail -> fail (`Wrong_file_kind (src, `Symlink content))
        | `Follow -> copy_aux ~src:content ~dst
        | `Redo ->
          let link_path = path_of_destination ~src ~dst in
          begin match if_exists with
          | `Fail -> (* make_symlink already fails on existing files *)
            return ()
          | `Overwrite
          | `Update -> remove link_path (* remove does not fail on missing files *)
          end
          >>= fun () ->
          make_symlink ~target:content ~link_path
        end
      | `Regular_file _->
        let output_path = path_of_destination ~src ~dst in
        let open_spec =
          match if_exists with
          | `Fail -> `Create_file output_path
          | `Overwrite | `Update -> `Overwrite_file output_path
        in
        IO.with_out_channel ~buffer_size open_spec ~f:(fun outchan ->
            IO.with_in_channel ~buffer_size (`File src) ~f:(fun inchan ->
                let rec loop () =
                  IO.read ~count:buffer_size inchan
                  >>= begin function
                  | "" -> return ()
                  | buf ->
                    IO.write outchan buf >>= fun () ->
                    loop ()
                  end
                in
                loop ()))
      | `Directory ->
        let new_dir = path_of_destination ~src ~dst in
        file_info new_dir
        >>= begin function
        | `Absent ->
          make_new_directory new_dir
        | smth_else ->
          begin match if_exists with
          | `Fail -> fail (`File_exists new_dir)
          | `Overwrite ->
            remove new_dir
            >>= fun () ->
            make_new_directory new_dir
          | `Update ->
            if smth_else = `Directory
            then return ()
            else fail (`Not_a_directory new_dir)
          end
        end
        >>= fun () ->
        let `Stream next_dir = list_directory src in
        let rec loop () =
          next_dir ()
          >>= begin function
          | Some ".."
          | Some "." -> loop ()
          | Some name ->
            copy_aux
              ~src:(Filename.concat src name)
              ~dst:(`Into new_dir)
            >>= fun () ->
            loop ()
          | None -> return ()
          end
        in
        loop ()
      end
    in
    (copy_aux ~src ~dst
     >>< begin function
     | `Ok () -> return ()
     | `Error err ->
       begin match err with
       | `IO (`Exn e) -> fail (`System (`Copy src, `Exn e))
       | `IO (`File_exists _)
       | `IO (`Wrong_path _)
       | `File_exists _
       | `File_not_found _
       | `Not_a_directory _
       | `Wrong_file_kind _ as e -> fail (`System (`Copy src, e))
       | `System e -> fail (`System e)
       end
     end)

  let move_in_same_device ?(if_exists=`Fail) ~src dst =
    let real_dest = path_of_destination ~src ~dst in
    begin match if_exists with
    | `Fail ->
      file_info real_dest
      >>= begin function
      | `Absent -> return ()
      | _ -> fail (`System (`Move src, `File_exists real_dest))
      end
    | _ -> (* Unix.rename does overwriting *) return ()
    end
    >>= fun () ->
    Lwt.catch
      Lwt.(fun () -> Lwt_unix.rename src real_dest >>= fun () -> return (`Ok `Moved))
      begin function
      | Unix.Unix_error (Unix.EXDEV, cmd, arg)  -> return `Must_copy
      | Unix.Unix_error (Unix.ENOTEMPTY, cmd, arg)  -> return `Must_copy
      | e -> fail (`System (`Move src, `Exn e))
      end

  let move ?ignore_strange ?symlinks ?buffer_size ?if_exists ~src dst =
    move_in_same_device ?if_exists ~src dst
    >>= begin function
    | `Moved -> return ()
    | `Must_copy ->
      copy ~src ?buffer_size ?ignore_strange ?symlinks ?if_exists dst
      >>= fun () ->
      remove src
    end


  type file_tree = [
    | `Node of string * file_tree list
    | `Leaf of string * file_info
  ]

  let file_tree ?(follow_symlinks=false) path =
    let directory p l = return (`Node (p, l)) in
    let file p l = return (`Leaf (p, l)) in
    let rec find_aux ?name_to_report path =
      let name =
        match name_to_report with
        | Some s -> s
        | None -> Filename.basename path in
      file_info path
      >>= begin function
      | `Absent -> fail (`File_not_found path)
      | `Block_device
      | `Character_device
      | `Fifo
      | `Regular_file _
      | `Socket as k -> file name k
      | `Symlink content as k ->
        begin match follow_symlinks with
        | true ->
          let continue =
            if Filename.is_relative content
            then (Filename.concat path content)
            else content in
          find_aux ~name_to_report:(Filename.basename path) continue
        | false ->
          file name k
        end
      | `Directory ->
        let `Stream next_dir = list_directory path in
        let rec loop acc =
          next_dir ()
          >>= begin function
          | Some ".."
          | Some "." -> loop acc
          | Some name -> loop (name :: acc)
          | None -> return acc
          end
        in
        loop []
        >>= fun sub_list ->
        List.fold_left
          ~init:(return []) (List.sort ~cmp:String.compare sub_list)
          ~f:(fun prev dir ->
              prev >>= fun l ->
              find_aux (Filename.concat path dir)
              >>= fun newone ->
              return (newone :: l))
        >>| List.rev
        >>= fun sub_tree ->
        directory name sub_tree
      end
    in
    (find_aux path
     >>< function
     | `Ok o -> return o
     | `Error e ->
       begin match e with
       | `Io_exn e -> fail (`System (`File_tree path, `Exn e))
       | `File_not_found _ as e -> fail (`System (`File_tree path, e))
       | `System e -> fail (`System e)
       end)

  let file_info_to_string = function
  | `Absent -> "Absent"
  | `Regular_file i -> sprintf "Regular file (size %d B)" i
  | `Symlink s -> sprintf "Sym-link to %S" s
  | `Block_device -> "Block device"
  | `Character_device -> "Character device"
  | `Directory -> "Directory"
  | `Fifo -> "FIFO"
  | `Socket -> "Socket"


  let error_to_string = function
  | `System (where, what) ->
    sprintf "System error while %s: %s"
      begin match where with
      | `File_info s -> sprintf "getting info on %S" s
      | `Make_directory s -> sprintf "making directory %S" s
         (* | `IO of [ `File_exists of string | `Wrong_path of string ] *)
      | `File_tree s -> sprintf "getting file tree from %S" s
      | `Move s -> sprintf "moving %S" s
      | `Copy s -> sprintf "copying %S" s
      | `Make_symlink (s1, s2) -> sprintf "Making symlink from target %S to %s" s1 s2
      | `Remove s -> sprintf "removing %S" s
      | `List_directory s -> sprintf "listing directory %S" s
      end
      begin match what with
      | `Already_exists -> "Already exists"
      | `IO _ as e -> sprintf "I/O Error %S" (IO.error_to_string e)
      | `File_not_found s -> sprintf "File not found (%S)" s
      | `Not_a_directory s -> sprintf "Not a directory (%S)" s
      | `File_exists s -> sprintf "File exists (%S)" s
      | `Wrong_path s -> sprintf "Wrong path (%S)" s
      | `Wrong_file_kind (s, k) ->
        sprintf "Wrong kind of file (%S: %s)" s (file_info_to_string k)
      | `Exn e -> sprintf "Exception %s" (exn e)
      | `Wrong_access_rights o -> sprintf "wrong access rights: 0o%o" o
      end
  | `Shell (cmd, err) ->
    sprintf "Shell command %S failed: %s" cmd
      (Shell.status_to_string err)

end