package opam-repository

  1. Overview
  2. Docs

Source file opamVCS.ml

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
(**************************************************************************)
(*                                                                        *)
(*    Copyright 2012-2015 OCamlPro                                        *)
(*    Copyright 2012 INRIA                                                *)
(*                                                                        *)
(*  All rights reserved. This file is distributed under the terms of the  *)
(*  GNU Lesser General Public License version 2.1, with the special       *)
(*  exception on linking described in the file LICENSE.                   *)
(*                                                                        *)
(**************************************************************************)

open OpamTypes
open OpamStd.Op
open OpamProcess.Job.Op

module type VCS = sig
  val name: OpamUrl.backend
  val exists: dirname -> bool
  val init: dirname -> url -> unit OpamProcess.job
  val fetch: ?cache_dir:dirname -> dirname -> url -> unit OpamProcess.job
  val reset_tree: dirname -> url -> unit OpamProcess.job
  val patch_applied: dirname -> url -> unit OpamProcess.job
  val diff: dirname -> url -> filename option OpamProcess.job
  val is_up_to_date: dirname -> url -> bool OpamProcess.job
  val revision: dirname -> string option OpamProcess.job
  val versioned_files: dirname -> string list OpamProcess.job
  val vc_dir: dirname -> dirname
  val current_branch: dirname -> string option OpamProcess.job
  val is_dirty: dirname -> bool OpamProcess.job
end


module Make (VCS: VCS) = struct

  let name = VCS.name

  let fetch_repo_update repo_name ?cache_dir repo_root repo_url =
    if VCS.exists repo_root then
      OpamProcess.Job.catch (fun e -> Done (OpamRepositoryBackend.Update_err e))
      @@ fun () ->
      OpamRepositoryBackend.job_text repo_name "sync"
        (VCS.fetch ?cache_dir repo_root repo_url)
      @@+ fun () ->
      OpamRepositoryBackend.job_text repo_name "diff"
        (VCS.diff repo_root repo_url)
      @@| function
      | None -> OpamRepositoryBackend.Update_empty
      | Some patch -> OpamRepositoryBackend.Update_patch patch
    else
      OpamProcess.Job.catch (fun e ->
          OpamFilename.rmdir repo_root;
          Done (OpamRepositoryBackend.Update_err e))
      @@ fun () ->
      OpamRepositoryBackend.job_text repo_name "init"
        (VCS.init repo_root repo_url)
      @@+ fun () ->
      OpamRepositoryBackend.job_text repo_name "sync"
        (VCS.fetch ?cache_dir repo_root repo_url)
      @@+ fun () ->
      let tmpdir = OpamFilename.Dir.(of_string (to_string repo_root ^".new")) in
      OpamFilename.copy_dir ~src:repo_root ~dst:tmpdir;
      OpamProcess.Job.catch (fun e -> OpamFilename.rmdir tmpdir; raise e)
      @@ fun () ->
      VCS.reset_tree tmpdir repo_url @@| fun () ->
      OpamRepositoryBackend.Update_full tmpdir

  let repo_update_complete dirname url =
    VCS.patch_applied dirname url @@+ fun () ->
    Done ()

  let pull_url ?cache_dir dirname checksum url =
    if checksum <> None then invalid_arg "VC pull_url doesn't allow checksums";
    OpamProcess.Job.catch
      (fun e ->
         OpamConsole.error "Could not synchronize %s from %S:\n%s"
           (OpamFilename.Dir.to_string dirname)
           (OpamUrl.to_string url)
           (match e with Failure fw -> fw | _ -> Printexc.to_string e);
         Done (Not_available (None, OpamUrl.to_string url)))
    @@ fun () ->
    if VCS.exists dirname then
      VCS.fetch ?cache_dir dirname url @@+ fun () ->
      VCS.is_up_to_date dirname url @@+ function
      | true -> Done (Up_to_date None)
      | false ->
        VCS.reset_tree dirname url @@+ fun () ->
        Done (Result None)
    else
      (OpamFilename.mkdir dirname;
       VCS.init dirname url @@+ fun () ->
       VCS.fetch ?cache_dir dirname url @@+ fun () ->
       VCS.reset_tree dirname url @@+ fun () ->
       Done (Result None))

  let revision repo_root =
    VCS.revision repo_root @@+ fun r ->
    Done (OpamStd.Option.map OpamPackage.Version.of_string r)

  let sync_dirty repo_root repo_url =
    match OpamUrl.local_dir repo_url with
    | None -> pull_url repo_root None repo_url
    | Some dir ->
      VCS.versioned_files dir
      @@+ fun files ->
      let files =
        List.map OpamFilename.(remove_prefix dir)
          (OpamFilename.rec_files (VCS.vc_dir dir))
        @ files
      in
      let stdout_file =
        let f = OpamSystem.temp_file "rsync-files" in
        let fd = open_out f in
        List.iter (fun s -> output_string fd s; output_char fd '\n') files;
        close_out fd;
        f
      in
      (* Remove non-versionned files from destination *)
      (* fixme: doesn't clean directories *)
      let fset = OpamStd.String.Set.of_list files in
      List.iter (fun f ->
          let basename = OpamFilename.remove_prefix repo_root f in
          if not (OpamFilename.(starts_with (VCS.vc_dir repo_root) f) ||
                  OpamStd.String.Set.mem basename fset)
          then OpamFilename.remove f)
        (OpamFilename.rec_files repo_root);
      OpamLocal.rsync_dirs ~args:["--files-from"; stdout_file]
        ~exclude_vcdirs:false
        repo_url repo_root
      @@+ fun result ->
      OpamSystem.remove stdout_file;
      Done (match result with
          | Up_to_date _ -> Up_to_date None
          | Result _ -> Result None
          | Not_available _ as na -> na)

end