Canopy now supports multiple kind of content

Before, the only kind of content expected on Canopy was markdown.
This commit introduce Canopy_content and hide Markdown articles behind a type that will provide interfaces to generate html from any kind of file content type.
A file content type is a simple field inside Canopy's header
---
title: Title
content: irclog
---

Author: abbysmal

canopy_article.ml

@@ -0,0 +1,51 @@
+open Canopy_utils
+open Html5.M
+
+type t = {
+  title : string;
+  content : string;
+  author : string;
+  abstract : string option;
+  uri : string;
+  date: string;
+  tags: string list;
+}
+
+let of_string meta uri date content =
+  try
+    let split_tags = Re_str.split (Re_str.regexp ",") in
+    let content = Cow.Markdown.of_string content |> Cow.Html.to_string in
+    let author = List.assoc "author" meta in
+    let title = List.assoc "title" meta in
+    let tags = assoc_opt "tags" meta |> map_opt split_tags [] in
+    let abstract = assoc_opt "abstract" meta in
+    Some {title; content; author; uri; abstract; date; tags}
+  with
+  | _ -> None
+
+let to_tyxml article =
+  let author = "Written by " ^ article.author in
+  let updated = "Last updated: " ^ article.date in
+  let tags = Canopy_templates.taglist article.tags in
+  [div ~a:[a_class ["post"]] [
+	 h2 [pcdata article.title];
+	 span ~a:[a_class ["author"]] [pcdata author];
+	 br ();
+	 span ~a:[a_class ["date"]] [pcdata updated];
+	 br ();
+	 tags;
+	 br ();
+	 Html5.M.article [Unsafe.data article.content]
+       ]]
+
+let to_tyxml_listing_entry article =
+  let author = "Written by " ^ article.author in
+  let abstract = match article.abstract with
+    | None -> []
+    | Some abstract -> [p ~a:[a_class ["list-group-item-text abstract"]] [pcdata abstract]] in
+  let content = [
+      h4 ~a:[a_class ["list-group-item-heading"]] [pcdata article.title];
+      span ~a:[a_class ["author"]] [pcdata author];
+      br ();
+    ] in
+  a ~a:[a_href article.uri; a_class ["list-group-item"]] (content ++ abstract)

canopy_content.ml

@@ -0,0 +1,53 @@
+open Canopy_utils
+
+type t =
+  | Markdown of Canopy_article.t
+  | Unknown
+  | Error of string
+
+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 ~uri ~date ~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 meta uri date raw_content
+	       |> map_opt (fun article -> 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
+  | Unknown -> "Error", Canopy_templates.error "Unknown file content"
+  | Error msg -> "Error", Canopy_templates.error msg
+
+let to_tyxml_listing_entry = function
+  | Markdown m -> Canopy_article.to_tyxml_listing_entry m
+  | Unknown -> Canopy_templates.empty
+  | Error _ -> Canopy_templates.empty
+
+let find_tag tagname = function
+  | Markdown m ->
+     let open Canopy_article in
+     List.exists ((=) tagname) m.tags
+  | Unknown
+  | Error _ -> false

canopy_main.ml

@@ -16,7 +16,7 @@ module Main  (C: CONSOLE) (RES: Resolver_lwt.S) (CON: Conduit_mirage.S) (S:Cohtt
   let start console res ctx http disk _ =
 
     let open Canopy_config in
-    let open Canopy_types in
+    let open Canopy_utils in
     let config = Canopy_config.config () in
     let module Context =
       ( struct
@@ -25,21 +25,15 @@ module Main  (C: CONSOLE) (RES: Resolver_lwt.S) (CON: Conduit_mirage.S) (S:Cohtt
     in
     let module Store = Canopy_store.Store(C)(Context)(Inflator) in
 
-    let articles_hashtable = KeyHashtbl.create 32 in
-
-    let flatten_option_list l =
-      List.fold_left
-        (fun xs x -> match x with
-           | None -> xs
-           | Some x -> x::xs) [] l in
+    let content_hashtbl = KeyHashtbl.create 32 in
 
     let respond_html ~status ~content ~title =
       Store.get_subkeys [] >>= fun keys ->
-      let body = Canopy_templates.template_main ~config ~content ~title ~keys in
+      let body = Canopy_templates.main ~config ~content ~title ~keys in
       S.respond_string ~status ~body () in
 
     Store.pull console >>= fun _ ->
-    Store.fill_cache articles_hashtable >>= fun _ ->
+    Store.fill_cache content_hashtbl >>= fun _ ->
 
     let rec dispatcher uri =
       let s_uri = Re_str.split (Re_str.regexp "/") (Uri.pct_decode uri) in
@@ -58,31 +52,35 @@ module Main  (C: CONSOLE) (RES: Resolver_lwt.S) (CON: Conduit_mirage.S) (S:Cohtt
 
       | uri::[] when uri = config.push_hook_path ->
 	 Store.pull console >>= fun _ ->
-	 KeyHashtbl.clear articles_hashtable |> Lwt.return >>= fun _ ->
-	 Store.fill_cache articles_hashtable >>= fun _ ->
+	 KeyHashtbl.clear content_hashtbl |> Lwt.return >>= fun _ ->
+	 Store.fill_cache content_hashtbl >>= fun _ ->
 	 S.respond_string ~status:`OK ~body:"" ()
 
       | "tags"::tagname::_ ->
-	 let is_in_tags = List.exists ((=) tagname) in
-	 let articles = KeyHashtbl.fold (fun _ v l -> if is_in_tags v.tags then v::l else l)
-					articles_hashtable [] in
-	 let content = Canopy_templates.template_listing articles in
-	 respond_html ~status:`OK ~title:"Listing" ~content
+	 let aux _ v l =
+	   if Canopy_content.find_tag tagname v then (v::l) else l in
+      	 let content =
+	   KeyHashtbl.fold aux content_hashtbl []
+	   |> List.map Canopy_content.to_tyxml_listing_entry
+	   |> Canopy_templates.listing in
+      	 respond_html ~status:`OK ~title:"Listing" ~content
 
       | key ->
         begin
-          match KeyHashtbl.find_opt articles_hashtable key with
+          match KeyHashtbl.find_opt content_hashtbl key with
             | None ->
               Store.get_subkeys key >>= fun keys ->
               if (List.length keys) = 0 then
                 S.respond_string ~status:`Not_found ~body:"Not found" ()
               else
-                let articles = List.map (KeyHashtbl.find_opt articles_hashtable) keys in
-                let content = flatten_option_list articles |> Canopy_templates.template_listing in
+                let articles = List.map (KeyHashtbl.find_opt content_hashtbl) keys in
+                let content =
+		  list_map_opt Canopy_content.to_tyxml_listing_entry articles
+		  |> Canopy_templates.listing in
                 respond_html ~status:`OK ~title:"Listing" ~content
             | Some article ->
-              let content = Canopy_templates.template_article article in
-              respond_html ~status:`OK ~title:article.title ~content
+              let title, content = Canopy_content.to_tyxml article in
+              respond_html ~status:`OK ~title ~content
         end
 
     in

canopy_store.ml

@@ -68,20 +68,18 @@ module Store (C: CONSOLE) (CTX: Irmin_mirage.CONTEXT) (INFL: Git.Inflate.S) = st
     CalendarLib.Printer.Calendar.sprint "%d/%m/%Y" cal |> Lwt.return
 
   let fill_cache article_hashtbl =
-    let open Canopy_types in
     let iter_fn key value =
-      value >>= fun value ->
+      value >>= fun content ->
       date_updated_last key >>= fun date ->
       let uri = List.fold_left (fun s a -> s ^ "/" ^ a) "" key in
-      match article_of_string uri value date with
-      | None -> Lwt.return_unit
-      | Some article -> KeyHashtbl.replace article_hashtbl key article |> Lwt.return
+      Canopy_content.of_string ~uri ~content ~date
+      |> KeyHashtbl.replace article_hashtbl key
+      |> Lwt.return
     in
     new_task () >>= fun t ->
     Store.iter (t "Iterating through values") iter_fn
 
   let setup_watch hashtbl =
-    let open Canopy_types in
     new_task () >>= fun t ->
     Store.watch_head (t "watch branch") (fun _ ->
       KeyHashtbl.clear hashtbl |> Lwt.return >>= fun _ ->

canopy_templates.ml

@@ -1,5 +1,5 @@
-open Canopy_types
 open Canopy_config
+open Canopy_utils
 open Html5.M
 
 module StringPrinter = struct
@@ -14,15 +14,13 @@ end
 
 module StringHtml = Html5.Make_printer(StringPrinter)
 
-let (++) = List.append
-
-let template_taglist tags =
+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
   List.map format_tag tags |> div ~a:[a_class ["tags"]]
 
-let template_links keys =
+let links keys =
   let paths = List.map (function
 			 | x::_ -> x
 			 | _ -> assert false
@@ -34,8 +32,8 @@ let template_links keys =
 let script_mathjax =
   [script ~a:[a_src "https://travis-ci.org/Engil/Canopy"] (pcdata "")]
 
-let template_main ~config ~content ~title ~keys =
-  let links = template_links keys in
+let main ~config ~content ~title ~keys =
+  let links = links keys in
   let mathjax = if config.mathjax then script_mathjax else [] in
   let page =
     html
@@ -77,37 +75,14 @@ let template_main ~config ~content ~title ~keys =
   in
   StringHtml.print page
 
-
-let template_article article =
-  let author = "Written by " ^ article.author in
-  let updated = "Last updated: " ^ article.date in
-  let tags = template_taglist article.tags in
-  [div ~a:[a_class ["post"]] [
-	 h2 [pcdata article.title];
-	 span ~a:[a_class ["author"]] [pcdata author];
-	 br ();
-	 span ~a:[a_class ["date"]] [pcdata updated];
-	 br ();
-	 tags;
-	 br ();
-	 Html5.M.article [Unsafe.data article.content]
-       ]]
-
-let template_listing_entry article =
-  let author = "Written by " ^ article.author in
-  let abstract = match article.abstract with
-    | None -> []
-    | Some abstract -> [p ~a:[a_class ["list-group-item-text abstract"]] [pcdata abstract]] in
-  let content = [
-      h4 ~a:[a_class ["list-group-item-heading"]] [pcdata article.title];
-      span ~a:[a_class ["author"]] [pcdata author];
-      br ();
-    ] in
-  a ~a:[a_href article.uri; a_class ["list-group-item"]] (content ++ abstract)
-
-let template_listing articles =
-  let entries = List.map template_listing_entry articles in
+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]]
+
+let empty =
+  div []