lib/resolvers.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
137
138
139
140
141
142
143
144
145
146
147
148

(* -*- mode: tuareg; -*- *)

module Store = Git_unix.Store
open Lwt_result.Syntax
open Config

let full_path path = Filename.concat config.git_project_root path

let store repo =
  let path = full_path repo |> Fpath.v in
  Store.v ~dotgit:path path

let repo_description repo =
  let description_path = Filename.concat (full_path repo) "description" in
  In_channel.with_open_text description_path In_channel.input_all

let short_hash hash = String.sub hash 0 8

module Commit = struct
  type user = Git.User.t

  type t = {
    hash : string;
    parents : string list;
    author : user;
    message : string option;
  }

  let to_t c =
    let open Store.Value in
    {
      hash = Commit.digest c |> Store.Hash.to_hex;
      parents = Commit.parents c |> List.map Store.Hash.to_hex;
      author = Commit.author c;
      message = Commit.message c;
    }

  let of_id repo id =
    let* store = store repo in
    let hash = Store.Hash.of_hex id in
    Lwt_result.bind (Store.read store hash) @@ function
    | Git.Value.Commit commit -> Lwt_result.return (to_t commit)
    | _ -> Lwt_result.fail @@ `Msg ("no commit matches id " ^ id)

  let head repo =
    let* store = store repo in
    let* hash = Store.Ref.resolve store Git.Reference.head in
    let id = hash |> Store.Hash.to_hex in
    of_id repo id

  let recent repo n =
    let* head_commit = head repo in
    let rec walk acc hash count =
      if count = 0 then Lwt_result.return (List.rev acc)
      else
        let* commit = of_id repo hash in
        match commit.parents with
        | parent_hash :: _ -> walk (commit :: acc) parent_hash (count - 1)
        | [] -> Lwt_result.return (List.rev (commit :: acc))
    in
    walk [] head_commit.hash n
end

module Branch = struct
  type t = { name : string; hash : string }

  let to_t (reference, hash) = { name = reference; hash }

  let all repo =
    let* store = store repo in
    let open Lwt.Syntax in
    let* refs = Store.Ref.list store in
    let branches =
      List.map
        (fun (reference, hash) ->
          {
            name = Git.Reference.to_string reference;
            hash = Store.Hash.to_hex hash;
          })
        refs
    in
    Lwt_result.return branches

  let of_id repo id =
    let* branches = all repo in
    let branch =
      branches
      |> List.find_opt (fun branch -> Filename.basename branch.name = id)
    in
    match branch with
    | Some branch -> Lwt_result.return branch
    | None -> Lwt_result.fail @@ `Msg ("no branch matches id " ^ id)
end

module Entry = struct
  type t = { hash : string; name : string; perm : int }

  let to_t (entry : Store.Value.Tree.entry) =
    let perm =
      match entry.perm with
      | `Commit -> 0o160000
      | `Dir -> 0o040000
      | `Everybody -> 0o100664
      | `Exec -> 0o100755
      | `Link -> 0o120000
      | `Normal -> 0o100644
    in
    let hash = Store.Hash.to_hex entry.node in
    { hash; name = entry.name; perm }
end

module Tree = struct
  type t = { hash : string; entries : Entry.t list }

  let to_t tree =
    let hash = Store.Value.Tree.hash tree |> Int.to_string in
    let entries = Store.Value.Tree.to_list tree |> List.map Entry.to_t in
    { hash; entries }

  let of_id repo id =
    let* store = store repo in
    let hash = Store.Hash.of_hex id in
    Lwt_result.bind (Store.read store hash) @@ function
    | Git.Value.Tree tree -> Lwt_result.return (to_t tree)
    | _ -> Lwt_result.fail @@ `Msg ("no tree matches id " ^ id)

  let head repo =
    let* store = store repo in
    let* commit_hash = Store.Ref.resolve store Git.Reference.head in
    Lwt_result.bind (Store.read store commit_hash) @@ function
    | Git.Value.Commit commit ->
        let tree_id = Store.Value.Commit.tree commit |> Store.Hash.to_hex in
        of_id repo tree_id
    | _ -> Lwt_result.fail @@ `Msg "HEAD reference does not point to a commit"
end

module Blob = struct
  type t = { content : string }

  let to_t blob = { content = Store.Value.Blob.to_string blob }

  let of_id repo id =
    let* store = store repo in
    let hash = Store.Hash.of_hex id in
    Lwt_result.bind (Store.read store hash) @@ function
    | Git.Value.Blob blob -> Lwt_result.return (to_t blob)
    | _ -> Lwt_result.fail @@ `Msg ("no blob matches id " ^ id)
end