Initial implementation for tags

Author: abbysmal

canopy_main.ml

@@ -62,6 +62,13 @@ module Main  (C: CONSOLE) (RES: Resolver_lwt.S) (CON: Conduit_mirage.S) (S:Cohtt
 	 Store.fill_cache articles_hashtable >>= 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
+
       | key ->
         begin
           match KeyHashtbl.find_opt articles_hashtable key with
@@ -76,8 +83,9 @@ module Main  (C: CONSOLE) (RES: Resolver_lwt.S) (CON: Conduit_mirage.S) (S:Cohtt
             | Some article ->
               let content = Canopy_templates.template_article article in
               respond_html ~status:`OK ~title:article.title ~content
-        end in
+        end
 
+    in
     let callback _ request _ =
       let uri = Cohttp.Request.uri request in
       dispatcher (Uri.path uri)

canopy_templates.ml

@@ -14,6 +14,14 @@ end
 
 module StringHtml = Html5.Make_printer(StringPrinter)
 
+let (++) = List.append
+
+let template_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 paths = List.map (function
 			 | x::_ -> x
@@ -33,13 +41,13 @@ let template_main ~config ~content ~title ~keys =
     html
       (head
 	 (Html5.M.title (pcdata title))
-	 (List.append [
+	 ([
 	   meta ~a:[a_charset "UTF-8"] ();
 	   link ~rel:[`Stylesheet] ~href:"/static/bower/bootstrap/dist/css/bootstrap.min.css" ();
 	   link ~rel:[`Stylesheet] ~href:"/static/css/style.css" ();
 	   script ~a:[a_src "/static/bower/jquery/dist/jquery.min.js"] (pcdata "");
 	   script ~a:[a_src "/static/bower/bootstrap/dist/js/bootstrap.min.js"] (pcdata "")
-	 ] mathjax)
+	 ] ++ mathjax)
       )
       (body
 	 [
@@ -54,7 +62,7 @@ let template_main ~config ~content ~title ~keys =
 				      span ~a:[a_class ["icon-bar"]][];
 				      span ~a:[a_class ["icon-bar"]][]
 				    ];
-			     a ~a:[a_class ["navbar-brand"]; a_href config.index_page][pcdata config.blog_name]
+			     a ~a:[a_class ["navbar-brand"]; a_href ("/" ^ config.index_page)][pcdata config.blog_name]
 			   ];
 		       div ~a:[a_class ["collapse navbar-collapse collapse"]] [
 			     ul ~a:[a_class ["nav navbar-nav navbar-right"]] links
@@ -73,12 +81,15 @@ let template_main ~config ~content ~title ~keys =
 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]
        ]]
 
@@ -87,12 +98,12 @@ let template_listing_entry article =
   let abstract = match article.abstract with
     | None -> []
     | Some abstract -> [p ~a:[a_class ["list-group-item-text abstract"]] [pcdata abstract]] in
-  let content = List.append [
-		    h4 ~a:[a_class ["list-group-item-heading"]] [pcdata article.title];
-		    span ~a:[a_class ["author"]] [pcdata author];
-		    br ();
-		  ] abstract in
-  a ~a:[a_href article.uri; a_class ["list-group-item"]] content
+  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

canopy_types.ml

@@ -5,8 +5,18 @@ type article = {
   abstract : string option;
   uri : string;
   date: string;
+  tags: string list;
 }
 
+let map_opt fn default = function
+  | None -> default
+  | Some v -> fn v
+
+let assoc_opt k l =
+  match List.assoc k l with
+  | v -> Some v
+  | exception Not_found -> None
+
 let meta_assoc str =
   Re_str.split (Re_str.regexp "\n") str |>
   List.map (fun meta ->
@@ -18,6 +28,7 @@ let meta_assoc str =
 
 let article_of_string uri str date =
   try
+    let split_tags = Re_str.split (Re_str.regexp ",") in
     let r_meta = Re_str.regexp "---" in
     let s_str = Re_str.bounded_split r_meta str 2 in
     match s_str with
@@ -31,12 +42,9 @@ let article_of_string uri str date =
       let assoc = meta_assoc meta in
       let author = List.assoc "author" assoc in
       let title = List.assoc "title" assoc in
-      let abstract =
-        try
-          Some (List.assoc "abstract" assoc)
-        with
-        | Not_found -> None in
-      Some {title; content; author; uri; abstract; date}
+      let tags = assoc_opt "tags" assoc |> map_opt split_tags [] in
+      let abstract = assoc_opt "abstract" assoc in
+      Some {title; content; author; uri; abstract; date; tags}
     | _ -> None
   with
   | _ -> None

less/style.less

@@ -67,6 +67,12 @@ article {
     margin-top: 30px;
 }
 
+a.tag {
+    margin-right: 3px;
+    font-size: 0.7em;
+    color: #777;
+}
+
 footer {
     margin-top: 20px;
     font-size: 0.7em;