diff --git a/canopy_article.ml b/canopy_article.ml index 0f8a99f..2983e74 100644 --- a/canopy_article.ml +++ b/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 diff --git a/canopy_content.ml b/canopy_content.ml index 45cf386..e40efc4 100644 --- a/canopy_content.ml +++ b/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 -> diff --git a/canopy_dispatch.ml b/canopy_dispatch.ml index a260ae8..a60865a 100644 --- a/canopy_dispatch.ml +++ b/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 diff --git a/canopy_main.ml b/canopy_main.ml index a15d73b..b397550 100644 --- a/canopy_main.ml +++ b/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 = diff --git a/canopy_store.ml b/canopy_store.ml index a9ee0c1..6d68a88 100644 --- a/canopy_store.ml +++ b/canopy_store.ml @@ -2,6 +2,7 @@ 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 @@ -9,6 +10,7 @@ module Store (CTX: Irmin_mirage.CONTEXT) (INFL: Git.Inflate.S) = struct 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 -> diff --git a/canopy_templates.ml b/canopy_templates.ml index 65812cd..ce0aebd 100644 --- a/canopy_templates.ml +++ b/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 diff --git a/config.ml b/config.ml index 63596b8..00abf77 100644 --- a/config.ml +++ b/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" ]