initial, compiles

app/canopy_app.ml

@@ -0,0 +1,27 @@
+let jump () repository =
+  Canopy.convert repository
+
+let setup_log style_renderer level =
+  Fmt_tty.setup_std_outputs ?style_renderer ();
+  Logs.set_level level;
+  Logs.set_reporter (Logs_fmt.reporter ~dst:Format.std_formatter ())
+
+open Cmdliner
+
+let setup_log =
+  Term.(const setup_log
+        $ Fmt_cli.style_renderer ()
+        $ Logs_cli.level ())
+
+let repository =
+  let doc = "Path to repository" in
+  Arg.(required & pos 0 (some dir) None & info [] ~doc ~docv:"PATH")
+
+let cmd =
+  let term =
+    Term.(term_result (const jump $ setup_log $ repository))
+  and info = Cmd.info "canopy" ~version:"%%VERSION_NUM%%"
+  in
+  Cmd.v info term
+
+let () = exit (Cmd.eval cmd)

app/dune

@@ -0,0 +1,4 @@
+(executable
+ (name canopy_app)
+ (public_name canopy)
+ (libraries canopy lwt.unix cmdliner logs.fmt logs.cli fmt fmt.cli fmt.tty))

dune-project

@@ -0,0 +1 @@
+(lang dune 1.0)

src/canopy.ml

@@ -0,0 +1,14 @@
+(* input is a git repository with canopy layout on the main branch:
+   - articles (markdown with some header)
+   - configuration
+   - static data
+
+   output is a branch (pages) that will be served by unipi
+   - atom feed
+   - html files of articles
+   - generated index page(s)
+   - static files
+*)
+
+let convert _repo =
+  assert false

src/canopy.mli

@@ -0,0 +1,2 @@
+
+val convert : string -> (unit, [ `Msg of string ]) result

src/canopy_article.ml

@@ -0,0 +1,124 @@
+[@@@warning "-3"]
+
+open Canopy_utils
+open Tyxml.Html
+
+type t = {
+  title : string option;
+  content : string;
+  author : string option;
+  author_uri : string option;
+  abstract : string option;
+  uri : string;
+  created: Ptime.t;
+  updated: Ptime.t;
+  tags: string list;
+  uuid: string;
+}
+
+let of_string base_uuid meta uri created updated content =
+  try
+    let split_tags = Re.Str.split (Re.Str.regexp ",") in
+    let content = Omd.to_html (Omd.of_string content) in
+    let author = assoc_opt "author" meta in
+    let title = assoc_opt "title" meta in
+    let tags = assoc_opt "tags" meta |> map_opt split_tags [] |> List.map String.trim in
+    let abstract = match assoc_opt "abstract" meta with
+        | None -> None
+        | Some x -> Some (Omd.to_html (Omd.of_string x))
+    in
+    let author_uri = assoc_opt "author_url" meta in
+    let uuid =
+      let open Uuidm in
+      let stamp = Ptime.to_rfc3339 created in
+      let entry_id = to_string (v5 (create (`V5 (ns_dns, stamp))) base_uuid) in
+      Printf.sprintf "urn:uuid:%s" entry_id
+    in
+    Some {title; content; author; author_uri; uri; abstract; created; updated; tags; uuid}
+  with
+  | _ -> None
+
+let to_tyxml article =
+  let title = match article.title with
+    | None -> []
+    | Some t -> [ h2 [ pcdata t ] ]
+  in
+  let author = match article.author with
+    | None -> []
+    | Some auth ->
+      let a_class = [a_class ["author"]]
+      and data = [pcdata ("Written by " ^ auth)]
+      in
+      match article.author_uri with
+      | None -> [ span ~a:a_class data ; br () ]
+      | Some a_uri -> [ a ~a:(a_class@[a_href a_uri]) data ; br () ]
+  in
+  let created = ptime_to_pretty_date article.created in
+  let updated = ptime_to_pretty_date article.updated in
+  let updated = String.concat " "
+      [ "Published:" ; created ; "(last updated:" ; updated ^ ")" ]
+  in
+  let tags = Canopy_templates.taglist article.tags in
+  [div ~a:[a_class ["post"]] (
+      title @ author @
+      tags @ [
+      span ~a:[a_class ["date"]] [pcdata updated] ;
+      Tyxml.Html.article [Unsafe.data article.content]
+    ])]
+
+let to_tyxml_listing_entry article =
+  let title = match article.title with
+    | None -> []
+    | Some t -> [ h2 ~a:[a_class ["list-group-item-heading"]] [pcdata t] ]
+  in
+  let author = match article.author with
+    | None -> []
+    | Some auth ->
+      [ span ~a:[a_class ["author"]] [pcdata ("Written by " ^ auth)] ; br () ]
+  in
+  let abstract = match article.abstract with
+    | None -> []
+    | Some abstract -> [p ~a:[a_class ["list-group-item-text abstract"]] [Unsafe.data abstract]] in
+  let content = title @ author in
+  a ~a:[a_href ("/" ^ article.uri); a_class ["list-group-item"]] (content ++ abstract)
+
+let to_tyxml_tags tags =
+  let format_tag tag =
+    let taglink = Printf.sprintf "/tags/%s" in
+    a ~a:[taglink tag |> a_href; a_class ["list-group-item"]] [pcdata tag] in
+  let html = match tags with
+    | [] -> div []
+    | tags ->
+      let tags = List.map format_tag tags in
+      p ~a:[a_class ["tags"]] tags
+  in
+  [div ~a:[a_class ["post"]] [
+      h2 [pcdata "Tags"];
+      div ~a:[a_class ["list-group listing"]] [html]]]
+
+let to_atom cache ({ title; author; abstract; uri; created; updated; tags; content; uuid; _}) =
+  let text x : Syndic.Atom.text_construct = Syndic.Atom.Text x in
+  let summary = match abstract with
+    | Some x -> Some (text x)
+    | None -> None
+  in
+  let root = Canopy_config.root cache
+  in
+  let categories =
+    List.map
+      (fun x -> Syndic.Atom.category ~scheme:(Uri.of_string (root ^ "/tags/" ^ x)) x)
+      tags
+  in
+  let author = match author with None -> "canopy" | Some a -> a in
+  let title = match title with None -> "no title" | Some t -> t in
+  Syndic.Atom.entry
+    ~id:(Uri.of_string uuid)
+    ~content:(Syndic.Atom.Html (None, content))
+    ~authors:(Syndic.Atom.author author, [])
+    ~title:(text title)
+    ~published:created
+    ~updated
+    ?summary
+    ~categories
+    ~links:[Syndic.Atom.link ~rel:Syndic.Atom.Alternate (Uri.of_string uri)]
+    ()

src/canopy_config.ml

@@ -0,0 +1,31 @@
+open Canopy_utils
+
+let decompose_git_url url =
+  match String.rindex url '#' with
+  | exception Not_found -> (url, None)
+  | i ->
+    let remote_url = String.sub url 0 i in
+    let branch = String.sub url (i + 1) (String.length url - i - 1) in
+    (remote_url, Some branch)
+
+let remote = "foo#bar"
+
+let remote_uri () = fst (decompose_git_url remote)
+let remote_branch () = snd (decompose_git_url remote)
+
+let entry name = [ ".config" ; name ]
+
+let index_page cache =
+  match KeyMap.find_opt cache @@ entry "index_page" with
+  | Some (`Config p) -> p
+  | _ -> "Index"
+
+let blog_name cache =
+  match KeyMap.find_opt cache @@ entry "blog_name" with
+  | Some (`Config n) -> n
+  | _ -> "Canopy"
+
+let root cache =
+  match KeyMap.find_opt cache @@ entry "root" with
+  | Some (`Config r) -> r
+  | _ -> "http://localhost"

src/canopy_content.ml

@@ -0,0 +1,72 @@
+open Canopy_utils
+
+type content_t =
+  | Markdown of Canopy_article.t
+
+type error_t =
+    Unknown
+  | Error of string
+  | Ok of content_t
+
+let meta_assoc str =
+  Re.Str.split (Re.Str.regexp "\n") str |>
+  List.map (fun meta ->
+      let reg = Re.Str.regexp "\\(.*\\): \\(.*\\)" in
+      let _ = Re.Str.string_match reg meta 0 in
+      let key = Re.Str.matched_group 1 meta in
+      let value = Re.Str.matched_group 2 meta in
+      key, value)
+
+let of_string ~base_uuid ~uri ~created ~updated ~content =
+  let splitted_content = Re.Str.bounded_split (Re.Str.regexp "---") content 2 in
+  match splitted_content with
+  | [raw_meta;raw_content] ->
+    begin
+      match meta_assoc raw_meta with
+      | meta ->
+        begin
+          match assoc_opt "content" meta with
+          | Some "markdown"
+          | None ->
+            Canopy_article.of_string base_uuid meta uri created updated raw_content
+            |> map_opt (fun article -> Ok (Markdown article)) (Error "Error while parsing article")
+          | Some _ -> Unknown
+        end
+      | exception _ -> Unknown
+    end
+  | _ -> Error "No header found"
+
+let to_tyxml = function
+  | Markdown m ->
+    let open Canopy_article in
+    m.title, to_tyxml m
+
+let to_tyxml_listing_entry = function
+  | Markdown m -> Canopy_article.to_tyxml_listing_entry m
+
+let to_atom cache = function
+  | Markdown m -> Canopy_article.to_atom cache m
+
+let find_tag tagname = function
+  | Markdown m ->
+    List.exists ((=) tagname) m.Canopy_article.tags
+
+let date = function
+  | Markdown m ->
+    m.Canopy_article.created
+
+let compare a b = Ptime.compare (date b) (date a)
+
+let updated = function
+  | Markdown m ->
+    m.Canopy_article.updated
+
+let tags content_map =
+  let module S = Set.Make(String) in
+  let s = KeyMap.fold_articles (
+      fun _k v s -> match v with
+        | Markdown m ->
+          let s' = S.of_list m.Canopy_article.tags in
+          S.union s s')
+      content_map S.empty
+  in S.elements s

src/canopy_store.ml

@@ -0,0 +1,149 @@
+open Lwt.Infix
+open Canopy_config
+open Canopy_utils
+
+module Store = Irmin_mirage_git.Mem.KV.Make(Irmin.Contents.String)
+module Sync = Irmin.Sync.Make(Store)
+module Topological = Graph.Topological.Make(Store.History)
+
+let src = Logs.Src.create "canopy-store" ~doc:"Canopy store logger"
+module Log = (val Logs.src_log src : Logs.LOG)
+
+let store_config = Irmin_mem.config ()
+let repo _ = Store.Repo.v store_config
+
+let store () =
+  match remote_branch () with
+  | None        -> repo () >>= Store.main
+  | Some branch -> repo () >>= fun r -> Store.of_branch r branch
+
+let walk t root =
+  let todo = ref [] in
+  let all = ref [] in
+  let rec aux () = match !todo with
+    | []      -> Lwt.return_unit
+    | k::rest ->
+      todo := rest;
+      Store.list t k >>= fun childs ->
+      Lwt_list.iter_p (fun (s, _c) ->
+          let k = k @ [s] in
+          Store.kind t k >>= function
+          | None           -> Lwt.return_unit
+          | Some `Node     -> todo := k :: !todo; Lwt.return_unit
+          | Some `Contents ->
+            Store.get t k >|= fun v ->
+            all := (k, v) :: !all
+        ) childs >>=
+      aux
+  in
+  todo := [root];
+  aux () >|= fun () ->
+  !all
+
+let key_type = function
+  | x::_ when x = "static" -> `Static
+  | x::_ when x = ".config" -> `Config
+  | _ -> `Article
+
+let get_subkeys key =
+  store () >>= fun t ->
+  walk t key >|= fun keys ->
+  List.fold_left (fun acc (k, _) ->
+      if key_type k = `Article then k :: acc else acc
+    ) [] keys
+
+let get_key key =
+  store () >>= fun t ->
+  Store.find t key
+
+let fold t fn acc =
+  let mut = Lwt_mutex.create () in
+  walk t [] >>= fun all ->
+  Lwt_list.fold_left_s (fun acc (k, v) ->
+      Lwt_mutex.with_lock mut (fun () -> acc >|= fn k v)
+    ) (Lwt.return acc) all
+  >>= fun x -> x
+
+let base_uuid () =
+  get_key [".config" ; "uuid"] >|= function
+  | None -> invalid_arg ".config/uuid is required in the remote git repository"
+  | Some n -> String.trim n
+
+let pull ~ctx =
+  let upstream = Store.remote ~ctx (remote_uri ()) in
+  store () >>= fun t ->
+  Log.info (fun f -> f "pulling repository") ;
+  Lwt.catch
+    (fun () ->
+       Sync.pull_exn t upstream `Set >|= fun _ ->
+       Log.info (fun f -> f "repository pulled"))
+    (fun e ->
+       Log.warn (fun f -> f "failed pull %a" Fmt.exn e);
+       Lwt.return ())
+
+let created_updated_ids commit key =
+  store () >>= fun t ->
+  Store.history t >>= fun history ->
+  let aux commit_id acc =
+    Store.of_commit commit_id >>= fun store ->
+    acc >>= fun (created, updated, last) ->
+    Store.find store key >|= fun data ->
+    match data, last with
+    | None  , None -> (created, updated, last)
+    | None  , Some _ -> (created, updated, last)
+    | Some x, Some y when x = y -> (created, updated, last)
+    | Some _, None -> (commit_id, commit_id, data)
+    | Some _, Some _ -> (created, commit_id, data)
+  in
+  Topological.fold aux history (Lwt.return (commit, commit, None))
+
+let date_updated_created key =
+  store () >>= fun t  ->
+  Store.Head.get t >>= fun head ->
+  created_updated_ids head key >>= fun (created_commit_id, updated_commit_id, _) ->
+  let to_ptime info =
+    Store.Info.date info |> Int64.to_float |> Ptime.of_float_s
+  in
+  Store.Commit.info updated_commit_id |> fun updated ->
+  Store.Commit.info created_commit_id |> fun created ->
+  match to_ptime updated, to_ptime created with
+  | Some a, Some b -> Lwt.return (a, b)
+  | _ -> raise (Invalid_argument "date_updated_last")
+
+let check_redirect content =
+  match Astring.String.cut ~sep:"redirect:" content with
+  | None -> None
+  | Some (_, path) -> Some (Uri.of_string (String.trim path))
+
+let fill_cache base_uuid =
+  let module C = Canopy_content in
+  let fn key content cache =
+    date_updated_created key >|= fun (updated, created) ->
+    match key_type key with
+    | `Static -> KeyMap.add key (`Raw (content, updated)) cache
+    | `Config -> KeyMap.add key (`Config (String.trim content)) cache
+    | `Article ->
+      let uri = String.concat "/" key in
+      match C.of_string ~base_uuid ~uri ~content ~created ~updated with
+      | C.Ok article -> KeyMap.add key (`Article article) cache
+      | C.Unknown ->
+        Log.warn (fun f -> f "%s : Unknown content type" uri) ;
+        cache
+      | C.Error error ->
+        match check_redirect content with
+        | None ->
+          Log.warn (fun f -> f "Error while parsing %s: %s" uri error) ;
+          cache
+        | Some uri -> KeyMap.add key (`Redirect uri) cache
+  in
+  store () >>= fun t ->
+  fold t fn KeyMap.empty
+
+let last_commit_date () =
+  store () >>= fun t  ->
+  Store.Head.get t >>= fun head ->
+  Store.Commit.info head |> fun info ->
+  let date = Store.Info.date info |> Int64.to_float in
+  Ptime.of_float_s date |> function
+  | Some o -> Lwt.return o
+  | None -> raise (Invalid_argument "date_updated_last")

src/canopy_syndic.ml

@@ -0,0 +1,25 @@
+open Canopy_utils
+open Canopy_config
+
+let atom uuid updated content_cache =
+  let cache = ref None in
+  let update_atom () =
+    let l = KeyMap.fold_articles (fun _ x acc -> x :: acc) !content_cache []
+            |> List.sort Canopy_content.compare
+            |> resize 10 in
+    let entries = List.map (Canopy_content.to_atom !content_cache) l in
+    let ns_prefix _ = Some "" in
+    Syndic.Atom.feed
+      ~id:(Uri.of_string ("urn:uuid:" ^ uuid))
+      ~title:(Syndic.Atom.Text (blog_name !content_cache): Syndic.Atom.text_construct)
+      ~updated
+      ~links:[Syndic.Atom.link ~rel:Syndic.Atom.Self (Uri.of_string (root !content_cache ^ "/atom"))]
+      entries
+    |> fun feed -> Syndic.Atom.to_xml feed
+    |> fun x -> Syndic.XML.to_string ~ns_prefix x
+    |> fun body -> cache := Some body; body
+  in
+  (fun () -> ignore (update_atom ())),
+  (fun () -> match !cache with
+     | Some body -> body
+     | None -> update_atom ())

src/canopy_templates.ml

@@ -0,0 +1,76 @@
+[@@@warning "-3"]
+
+open Canopy_config
+open Canopy_utils
+open Tyxml.Html
+
+let taglist tags =
+  let format_tag tag =
+    let taglink = Printf.sprintf "/tags/%s" in
+    a ~a:[taglink tag |> a_href; a_class ["tag"]] [pcdata tag] in
+  match tags with
+  | [] -> []
+  | tags ->
+     let tags = List.map format_tag tags in
+     [ div ~a:[a_class ["tags"]] ([pcdata "Classified under: "] ++ tags) ]
+
+let links keys =
+  let format_link link =
+    li [ a ~a:[a_href ("/" ^ link)] [span [pcdata link]]] in
+  List.map format_link keys
+
+let main ~cache ~content ?footer ~title ~keys () =
+  let idx = index_page cache in
+  let links = links keys in
+  let footer = match footer with
+    | None -> []
+    | Some f ->
+      let html = Omd.to_html (Omd.of_string f) in
+      [ div ~a:[a_class ["footer"]] [Unsafe.data html] ]
+  in
+  let page =
+    html
+      (head
+         (Tyxml.Html.title (pcdata title))
+         ([
+           meta ~a:[a_charset "UTF-8"] ();
+           (* link ~rel:[`Stylesheet] ~href:"/static/css/bootstrap.min.css" (); *)
+           link ~rel:[`Stylesheet] ~href:"/static/css/style.css" ();
+           (* link ~rel:[`Stylesheet] ~href:"/static/css/highlight.css" (); *)
+           (* script ~a:[a_src "/static/js/highlight.pack.js"] (pcdata ""); *)
+           (* script (pcdata "hljs.initHighlightingOnLoad();"); *)
+           link ~rel:[`Alternate] ~href:"/atom" ~a:[a_title title; a_mime_type "application/atom+xml"] ();
+           meta ~a:[a_name "viewport"; a_content "width=device-width, initial-scale=1, viewport-fit=cover"] ();
+         ])
+      )
+      (body
+         ([
+           nav ~a:[a_class ["navbar navbar-default navbar-fixed-top"]] [
+             div ~a:[a_class ["container"]] [
+               div ~a:[a_class ["navbar-header"]] [
+                 a ~a:[a_class ["navbar-brand"]; a_href ("/" ^ idx)][pcdata (blog_name cache)]
+               ];
+               div ~a:[a_class ["collapse navbar-collapse collapse"]] [
+                 ul ~a:[a_class ["nav navbar-nav navbar-right"]] links
+               ]
+             ]
+           ];
+           main [
+             div ~a:[a_class ["flex-container"]] content
+           ]
+         ] @ footer)
+      )
+  in
+  let buf = Buffer.create 500 in
+  let fmt = Format.formatter_of_buffer buf in
+  pp () fmt page ;
+  Buffer.contents buf
+
+let listing entries =
+  [div ~a:[a_class ["flex-container"]] [
+	 div ~a:[a_class ["list-group listing"]] entries
+       ]
+  ]
+
+let error msg =
+  [div ~a:[a_class ["alert alert-danger"]] [pcdata msg]]

src/canopy_utils.ml

@@ -0,0 +1,65 @@
+let assoc_opt k l =
+  match List.assoc k l with
+  | v -> Some v
+  | exception Not_found -> None
+
+let map_opt fn default = function
+  | None -> default
+  | Some v -> fn v
+
+let list_reduce_opt l =
+  let rec aux acc = function
+    | [] -> acc
+    | (Some x)::xs -> aux (x::acc) xs
+    | None::xs -> aux acc xs
+  in
+  aux [] l
+
+let default_opt default = function
+  | None -> default
+  | Some v -> v
+
+let resize len l =
+  List.fold_left
+    (fun (len, acc) x ->
+      if len > 0
+      then (len - 1, x :: acc)
+      else (0, acc))
+    (len, []) l
+  |> fun (_, l) -> List.rev l
+
+let (++) = List.append
+
+let ptime_to_pretty_date t =
+  Ptime.to_date t |> fun (y, m, d) ->
+    Printf.sprintf "%04d-%02d-%02d" y m d
+
+module KeyMap = struct
+  module KeyOrd = struct
+    type t = string list
+    let compare a b =
+      match compare (List.length a) (List.length b) with
+      | 0 -> (
+          try List.find ((<>) 0) (List.map2 String.compare a b)
+          with Not_found -> 0
+        )
+      | x -> x
+  end
+
+  module M = Map.Make(KeyOrd)
+  include M
+
+  let fold_articles f =
+    M.fold (fun k v acc -> match v with
+        | `Article a -> f k a acc
+        | _ -> acc)
+
+  let find_opt m k =
+    try Some (M.find k m) with
+    | Not_found -> None
+
+  let find_article_opt m k =
+    match find_opt m k with
+    | Some (`Article a) -> Some a
+    | _ -> None
+end

src/dune

@@ -0,0 +1,4 @@
+(library
+ (name canopy)
+ (public_name canopy)
+ (libraries ptime tyxml syndic omd uuidm lwt irmin-mirage-git))