fix timestamps (but stays on Irmin 0.10.1)

canopy_store.ml

@@ -45,99 +45,64 @@ module Store (C: CONSOLE) (CTX: Irmin_mirage.CONTEXT) (INFL: Git.Inflate.S) = st
          let msg = Printf.sprintf "Fail pull %s" (Printexc.to_string e) in
          Lwt.return (C.log console msg))
 
-  let created_commit_id commit keys =
-    repo () >>= fun repo ->
+  let commit_date repo commit_id =
+    Store.Repo.task_of_commit_id repo commit_id >|= fun task ->
+    Irmin.Task.date task |> Int64.to_float |> Ptime.of_float_s
+
+  let commits repo key =
     Store.master task repo >>= fun t  ->
     Store.history (t "Reading history") >>= fun history ->
-    let rec aux last_commit visited to_visit =
-      match to_visit with
-      | [] -> Lwt.return last_commit
-      | commit::to_visit ->
-   Store.of_commit_id (Irmin.Task.none) commit repo >>= fun store ->
-   Store.read (store ()) keys >>= fun readed_file ->
-   let visited = commit::visited in
-   match readed_file with
-   | Some _ ->
-      let to_visit =
-        ( match Store.History.pred history commit with
-    | [] -> to_visit
-    | pred::pred2::[] ->
-       let to_visit = if ((List.mem pred visited) = false) then pred::to_visit else to_visit in
-       let to_visit = if ((List.mem pred2 visited) = false) then pred2::to_visit else to_visit in
-       to_visit
-    | pred::[] ->
-       let to_visit = if ((List.mem pred visited) = false) then pred::to_visit else to_visit in
-       to_visit
-    | q -> print_endline "weird"; List.append (List.rev q) to_visit)
-      in aux commit visited to_visit
-   | None -> Lwt.return last_commit in
-    aux commit [] [commit]
+    Topological.fold
+      (fun id acc ->
+         Store.of_commit_id (Irmin.Task.none) id repo >>= fun store ->
+         acc >>= fun acc ->
+         Store.read (store ()) key >>= function
+         | None -> Lwt.return acc
+         | Some x -> commit_date repo id >|= function
+           | None -> acc
+           | Some d -> (d, x) :: acc)
+      history (Lwt.return [])
 
-  let last_updated_commit_id commit key =
-    repo () >>= fun repo ->
-    new_task () >>= fun t  ->
-    Store.read_exn (t "Reading file") key >>= fun current_file ->
-    let aux commit_id acc =
-      acc >>= fun (acc, matched) ->
-      Store.of_commit_id (Irmin.Task.none) commit_id repo >>= fun store ->
-      Store.read (store ()) key >>= fun readed_file ->
-      match readed_file with
-      | Some readed_file ->
-        let matching = current_file = readed_file in
-        let res =
-          if current_file = readed_file
-          then if matched then acc else commit_id
-          else commit_id in
-        Lwt.return (res, matching)
-      | None -> Lwt.return (commit_id, true) in
-    Store.history (t "Reading history") >>= fun history ->
-    Topological.fold aux history (Lwt.return (commit, false))
-    >>= fun (c, _) -> Lwt.return c
+  let find_last_ts c = function
+    | [] -> c
+    | ((_, newest)::_) as xs ->
+      List.fold_left (fun ts (n, data) -> if newest = data then n else ts) c xs
+
+  let date_updated_created head repo key =
+    commits repo key >|= fun commits ->
+    match List.sort (fun (t1, _) (t2, _) -> compare t1 t2) commits with
+    | ((f, _)::_) as xs -> (f, find_last_ts f (List.rev xs))
+    | [] -> (head, head)
 
-  let date_updated_created key =
+  let last_commit_date () =
     new_task () >>= fun t  ->
     repo () >>= fun repo ->
     Store.head_exn (t "Finding head") >>= fun head ->
-    last_updated_commit_id head key >>= fun updated_commit_id ->
-    created_commit_id head key >>= fun created_commit_id ->
-    Store.Repo.task_of_commit_id repo updated_commit_id >>= fun task ->
-    let date = Irmin.Task.date task |> Int64.to_float in
-    let updated_date = Ptime.of_float_s date in
-    Store.Repo.task_of_commit_id repo created_commit_id >>= fun task ->
-    let date = Irmin.Task.date task |> Int64.to_float in
-    let created_date = Ptime.of_float_s date in
-    match updated_date, created_date with
-    | Some a, Some b -> Lwt.return (a, b)
-    | _ -> raise (Invalid_argument "date_updated_last")
+    commit_date repo head >>= function
+      | None -> assert false
+      | Some x -> Lwt.return x
 
   let fill_cache article_map =
     let open Canopy_content in
-    let key_to_path key = List.fold_left (fun a b -> a ^ "/" ^ b) "" key in
+    last_commit_date () >>= fun head_date ->
+    repo () >>= fun repo ->
     let fold_fn key value acc =
       value >>= fun content ->
-      date_updated_created key >>= fun (updated, created) ->
-      let uri = List.fold_left (fun s a -> s ^ "/" ^ a) "" key in
+      date_updated_created head_date repo key >>= fun (created, updated) ->
+      Printf.printf "article %s created %s updated %s\n%!" (String.concat "/" key) (Ptime.to_rfc3339 created) (Ptime.to_rfc3339 updated) ;
+      let uri = String.concat "/" key in
       match of_string ~uri ~content ~created ~updated with
-      | Ok article -> (
-          article_map := KeyMap.add key article !article_map;
-          Lwt.return acc)
+      | Ok article ->
+        article_map := KeyMap.add key article !article_map;
+        Lwt.return acc
       | Error error ->
-        let error_msg = Printf.sprintf "Error while parsing %s: %s" (key_to_path key) error in
+        let error_msg = Printf.sprintf "Error while parsing %s: %s" uri error in
         Lwt.return (error_msg::acc)
       | Unknown ->
-        let error_msg = Printf.sprintf "%s : Unknown content type" (key_to_path key) in
+        let error_msg = Printf.sprintf "%s : Unknown content type" uri in
         Lwt.return (error_msg::acc)
     in
     new_task () >>= fun t ->
     fold (t "Folding through values") fold_fn []
 
-  let last_commit_date () =
-    new_task () >>= fun t  ->
-    repo () >>= fun repo ->
-    Store.head_exn (t "Finding head") >>= fun head ->
-    Store.Repo.task_of_commit_id repo head >>= fun task ->
-    let date = Irmin.Task.date task |> Int64.to_float in
-    Ptime.of_float_s date |> function
-      | Some o -> Lwt.return o
-      | None -> raise (Invalid_argument "date_updated_last")
 end