[WIP] initial recent activity page

canopy_article.ml

@@ -52,6 +52,22 @@ let to_tyxml article =
       Tyxml.Html.article [Unsafe.data article.content]
     ]]
 
+let to_tyxml_activity diffs =
+  let format_activity (header, content) =
+    let paragraphs =
+      Printf.printf "Content: %s" content;
+      let lines = Re_str.split (Re_str.regexp "\n") content in
+      List.map (fun line -> p ~a:[a_class ["line"]] [pcdata line] ) lines
+    in
+    div ~a:[a_class ["list-group-item"]] [
+      h5 ~a:[a_class ["list-group-item-heading"]] [pcdata header];
+      div ~a:[a_class ["list-group-item-text"]] paragraphs
+    ]
+  in
+  let activity_list_html = List.map format_activity (List.rev diffs) in
+  [div ~a:[a_class ["flex-container"]]
+    [div ~a:[a_class ["list-group"; "listing"]] activity_list_html]]
+
 let to_tyxml_listing_entry article =
   let author = "Written by " ^ article.author in
   let abstract = match article.abstract with

canopy_content.ml

@@ -1,5 +1,6 @@
 open Canopy_utils
 
+
 type content_t =
   | Markdown of Canopy_article.t
 
@@ -8,6 +9,48 @@ type error_t =
   | Error of string
   | Ok of content_t
 
+
+module Canopy_diff = Simple_diff.Make(String)
+
+let string_of_diff diffs =
+  let concat symbol lines =
+    let lines = List.map (fun line -> symbol ^ " " ^ line) (Array.to_list lines) in
+    String.concat "\n" lines
+  in
+  let stringify str diff =
+    let open Canopy_diff in
+    match diff with
+    | Added lines   -> str ^ concat "+" lines
+    | Deleted lines -> str ^ concat "-" lines
+    | Equal lines   -> str
+  in
+  List.fold_left stringify "" diffs
+
+
+let of_diffs timestamp diffs =
+  let fn (key, diff) =
+    let date = match timestamp with
+      | None -> ""
+      | Some timestamp -> ptime_to_pretty_date timestamp
+    in
+    let file = String.concat "/" key in
+    match diff with
+    | `Added value ->
+      (Printf.sprintf "%s : created (%s)" file date), value
+    | `Removed value ->
+      (Printf.sprintf "%s : deleted (%s)" file date), value
+    | `Updated (old_value, new_value) ->
+      Printf.printf "Date: %s\n" date;
+      Printf.printf "File: %s\n" file;
+      Printf.printf "Old_value: \n%s\n" old_value;
+      Printf.printf "New_value: \n%s\n" new_value;
+      let new_lines = Re_str.split (Re_str.regexp "\n") new_value |> Array.of_list in
+      let old_lines = Re_str.split (Re_str.regexp "\n") old_value |> Array.of_list in
+      let content = Canopy_diff.get_diff old_lines new_lines |> string_of_diff in
+      (Printf.sprintf "%s : edited (%s)" file date), content
+  in
+  List.map fn diffs
+
 let meta_assoc str =
   Re_str.split (Re_str.regexp "\n") str |>
   List.map (fun meta ->

canopy_dispatch.ml

@@ -16,7 +16,7 @@ module Make (S: Cohttp_lwt.Server) = struct
     let headers = Cohttp.Header.init_with "location" (Uri.to_string uri) in
     S.respond ~headers ~status:`Moved_permanently ~body:`Empty ()
 
-  let rec dispatcher headers store atom cache uri etag =
+  let rec dispatcher headers store atom cache diffs uri etag =
     let open Canopy_utils in
     let respond_not_found () =
       S.respond_string ~headers ~status:`Not_found ~body:"Not found" ()
@@ -38,7 +38,7 @@ module Make (S: Cohttp_lwt.Server) = struct
     match Re_str.split (Re_str.regexp "/") (Uri.pct_decode uri) with
     | [] ->
       let index_page = Canopy_config.index_page !cache in
-      dispatcher headers store atom cache index_page etag
+      dispatcher headers store atom cache diffs index_page etag
     | "atom" :: [] ->
       atom () >>= fun body ->
       store.last_commit () >>= fun updated ->
@@ -70,6 +70,10 @@ module Make (S: Cohttp_lwt.Server) = struct
           let title = Canopy_config.blog_name !cache in
           respond_html ~headers ~title ~content ~updated
       )
+    | "recent_activity" :: [] ->
+      let content = Canopy_article.to_tyxml_activity diffs in
+      store.last_commit () >>= fun updated ->
+      respond_html ~headers ~title:"Recent activity" ~content ~updated
     | key ->
       begin
         match KeyMap.find_opt !cache key with
@@ -130,11 +134,11 @@ module Make (S: Cohttp_lwt.Server) = struct
            moved_permanently redirect >|= fun (res, body) ->
            log request res ;
            (res, body))
-      | `Dispatch (headers, store, atom, content) ->
+      | `Dispatch (headers, store, atom, content, diffs) ->
         (fun _ request _ ->
            let uri = Cohttp.Request.uri request in
            let etag = Cohttp.Header.get Cohttp.Request.(request.headers) "if-none-match" in
-           dispatcher headers store atom content (Uri.path uri) etag >|= fun (res, body) ->
+           dispatcher headers store atom content diffs (Uri.path uri) etag >|= fun (res, body) ->
            log request res ;
            (res, body))
     in

canopy_main.ml

@@ -48,6 +48,7 @@ module Main (S: STACKV4) (RES: Resolver_lwt.S) (CON: Conduit_mirage.S) (CLOCK: V
     Store.pull () >>= fun () ->
     Store.base_uuid () >>= fun uuid ->
     Store.fill_cache uuid >>= fun new_cache ->
+    Store.fill_diffs () >>= fun diffs ->
     let cache = ref (new_cache) in
     let update_atom, atom =
       Canopy_syndic.atom uuid Store.last_commit_date cache
@@ -64,7 +65,7 @@ module Main (S: STACKV4) (RES: Resolver_lwt.S) (CON: Conduit_mirage.S) (CLOCK: V
       last_commit = Store.last_commit_date ;
     } in
     update_atom () >>= fun () ->
-    let disp hdr = `Dispatch (hdr, store_ops, atom, cache) in
+    let disp hdr = `Dispatch (hdr, store_ops, atom, cache, diffs) in
     (match Canopy_config.tls_port () with
      | Some tls_port ->
        let redir uri =

canopy_store.ml

@@ -2,13 +2,15 @@ open Lwt.Infix
 open Canopy_config
 open Canopy_utils
 
+
 module Store (CTX: Irmin_mirage.CONTEXT) (INFL: Git.Inflate.S) = struct
 
   module Hash = Irmin.Hash.SHA1
   module Mirage_git_memory = Irmin_mirage.Irmin_git.Memory(CTX)(INFL)
   module Store = Mirage_git_memory(Irmin.Contents.String)(Irmin.Ref.String)(Hash)
   module Sync = Irmin.Sync(Store)
   module Topological = Graph.Topological.Make(Store.History)
+  module View = Irmin.View(Store)
 
   let src = Logs.Src.create "canopy-store" ~doc:"Canopy store logger"
   module Log = (val Logs.src_log src : Logs.LOG)
@@ -77,6 +79,41 @@ module Store (CTX: Irmin_mirage.CONTEXT) (INFL: Git.Inflate.S) = struct
     in
     Topological.fold aux history (Lwt.return (commit, commit, None))
 
+  let get_diffs repo c1 c2 =
+    let view_of_commit repo commit_id =
+      Store.of_commit_id task commit_id repo >>= fun t ->
+      View.of_path (t "view") []
+    in
+    view_of_commit repo c1 >>= fun v1 ->
+    view_of_commit repo c2 >>= fun v2 ->
+    View.diff v1 v2 >|= fun diffs ->
+    List.filter (
+      fun (key, _) ->
+      match key_type key with
+      | `Article -> true
+      | _ -> false
+    ) diffs
+
+  let fill_diffs () =
+    new_task () >>= fun t ->
+    repo () >>= fun repo ->
+    Store.history (t "Reading history") >>= fun history ->
+    let aux commit_id acc =
+      acc >>= fun acc ->
+      match acc with
+      | None, acc_list ->
+        (Some commit_id, acc_list) |> Lwt.return
+      | Some prev_commit_id, acc_list ->
+        Store.Repo.task_of_commit_id repo commit_id >>= fun task ->
+        let timestamp = Irmin.Task.date task |> Int64.to_float |> Ptime.of_float_s in
+        get_diffs repo prev_commit_id commit_id >|= fun diffs ->
+        let diffs = Canopy_content.of_diffs timestamp diffs in
+        let acc_list = List.append acc_list diffs in
+        (Some commit_id, acc_list)
+    in
+    Topological.fold aux history (Lwt.return (None, [])) >|= fun (_, diffs) ->
+    diffs
+
   let date_updated_created key =
     new_task () >>= fun t  ->
     repo () >>= fun repo ->

canopy_templates.ml

@@ -16,13 +16,16 @@ let taglist tags =
      div ~a:[a_class ["tags"]] ([pcdata "Classified under: "] ++ tags)
 
 let links keys =
+  let recent_activity_link =
+    li [a ~a:[a_href "/recent_activity"] [span [pcdata "Recent Activity"]]]
+  in
   let paths = List.map (function
 			 | x::_ -> x
 			 | _ -> assert false
 		       ) keys |> List.sort_uniq (Pervasives.compare) in
   let format_link link =
     li [ a ~a:[a_href ("/" ^ link)] [span [pcdata link]]] in
-  List.map format_link paths
+  recent_activity_link :: (List.map format_link paths)
 
 let main ~cache ~content ~title ~keys =
   let links = links keys in

config.ml

@@ -35,6 +35,7 @@ let libraries = [
     "syndic";
     "uuidm";
     "logs";
+    "simple-diff"
   ]
 
 let packages = [
@@ -54,7 +55,8 @@ let packages = [
     "syndic";
     "magic-mime";
     "uuidm";
-    "logs"
+    "logs";
+    "simple-diff"
   ]