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