Skip to content

Commit

Permalink
issue abbysmal#30 /tags should give a list of tags
Browse files Browse the repository at this point in the history
  • Loading branch information
manu committed May 2, 2016
1 parent 162a0f4 commit 0bbd3b6
Show file tree
Hide file tree
Showing 3 changed files with 111 additions and 81 deletions.
42 changes: 28 additions & 14 deletions canopy_article.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -33,14 +33,14 @@ let to_tyxml article =
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 ();
tags;
span ~a:[a_class ["date"]] [pcdata updated];
br ();
Html5.M.article [Unsafe.data article.content]
]]
h2 [pcdata article.title];
span ~a:[a_class ["author"]] [pcdata author];
br ();
tags;
span ~a:[a_class ["date"]] [pcdata updated];
br ();
Html5.M.article [Unsafe.data article.content]
]]

let to_tyxml_listing_entry article =
let author = "Written by " ^ article.author in
Expand All @@ -49,14 +49,28 @@ let to_tyxml_listing_entry article =
| Some abstract -> [p ~a:[a_class ["list-group-item-text abstract"]] [pcdata abstract]] in
let created = ptime_to_pretty_date article.created in
let content = [
h4 ~a:[a_class ["list-group-item-heading"]] [pcdata article.title];
span ~a:[a_class ["author"]] [pcdata author];
pcdata " ";
pcdata "("; time [pcdata created]; pcdata ")";
br ();
] in
h4 ~a:[a_class ["list-group-item-heading"]] [pcdata article.title];
span ~a:[a_class ["author"]] [pcdata author];
pcdata " ";
pcdata "("; time [pcdata created]; pcdata ")";
br ();
] 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 ({ title; author; abstract; uri; created; updated; tags; content; } as article) =
let text x : Syndic.Atom.text_construct = Syndic.Atom.Text x in
let summary = match abstract with
Expand Down
46 changes: 28 additions & 18 deletions canopy_content.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -4,7 +4,7 @@ type content_t =
| Markdown of Canopy_article.t

type error_t =
Unknown
Unknown
| Error of string
| Ok of content_t

Expand All @@ -21,25 +21,25 @@ let of_string ~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 meta uri created updated raw_content
|> map_opt (fun article -> Ok (Markdown article)) (Error "Error while parsing article")
| Some _ -> Unknown
end
| exception _ -> Unknown
end
begin
match meta_assoc raw_meta with
| meta ->
begin
match assoc_opt "content" meta with
| Some "markdown"
| None ->
Canopy_article.of_string 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 open Canopy_article in
m.title, to_tyxml m

let to_tyxml_listing_entry = function
| Markdown m -> Canopy_article.to_tyxml_listing_entry m
Expand All @@ -49,14 +49,24 @@ let to_atom = function

let find_tag tagname = function
| Markdown m ->
List.exists ((=) tagname) m.Canopy_article.tags
List.exists ((=) tagname) m.Canopy_article.tags

let date = function
| Markdown m ->
m.Canopy_article.created
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 (
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
104 changes: 55 additions & 49 deletions canopy_dispatch.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -66,67 +66,73 @@ module Make (S: Cohttp_lwt.Server) (C: V1_LWT.CONSOLE) (Disk: V1_LWT.KV_RO)
| uri::[] when uri = config.Canopy_config.push_hook_path ->
store.update () >>= fun l ->
respond_update l
| "tags"::[] -> (
let tags = Canopy_content.tags !cache in
let content = Canopy_article.to_tyxml_tags tags in
store.last_commit () >>= fun updated ->

This comment has been minimized.

Sign in to view

Copy link
@voila

voila May 2, 2016

Owner

Now with updated coming from store.last_commit ()
respond_html ~headers ~title:config.Canopy_config.blog_name ~content ~updated
)
| "tags"::tagname::_ -> (
let aux _ v l =
if Canopy_content.find_tag tagname v then (v::l) else l
in
let sorted = KeyMap.fold aux !cache [] |> List.sort Canopy_content.compare in
match sorted with
| [] -> respond_not_found ()
| _ ->
let updated = List.hd (List.rev (List.sort Ptime.compare (List.map Canopy_content.updated sorted))) in
let content = sorted
|> List.map Canopy_content.to_tyxml_listing_entry
|> Canopy_templates.listing
let aux _ v l =
if Canopy_content.find_tag tagname v then (v::l) else l
in
respond_html ~headers ~title:config.Canopy_config.blog_name ~content ~updated
let sorted = KeyMap.fold aux !cache [] |> List.sort Canopy_content.compare in
match sorted with
| [] -> respond_not_found ()
| _ ->
let updated = List.hd (List.rev (List.sort Ptime.compare (List.map Canopy_content.updated sorted))) in
let content = sorted
|> List.map Canopy_content.to_tyxml_listing_entry
|> Canopy_templates.listing
in
respond_html ~headers ~title:config.Canopy_config.blog_name ~content ~updated
)
| key ->
| key ->
begin
match KeyMap.find_opt !cache key with
| None -> (
store.subkeys key >>= fun keys ->
if (List.length keys) = 0 then
respond_not_found ()
else
let articles = List.map (KeyMap.find_opt !cache) keys |> list_reduce_opt in
match articles with
| [] -> respond_not_found ()
| _ -> (
let sorted = List.sort Canopy_content.compare articles in
let updated = List.hd (List.rev (List.sort Ptime.compare (List.map Canopy_content.updated articles))) in
let content = sorted
|> List.map Canopy_content.to_tyxml_listing_entry
|> Canopy_templates.listing
in
respond_html ~headers ~title:config.Canopy_config.blog_name ~content ~updated
))
store.subkeys key >>= fun keys ->
if (List.length keys) = 0 then
respond_not_found ()
else
let articles = List.map (KeyMap.find_opt !cache) keys |> list_reduce_opt in
match articles with
| [] -> respond_not_found ()
| _ -> (
let sorted = List.sort Canopy_content.compare articles in
let updated = List.hd (List.rev (List.sort Ptime.compare (List.map Canopy_content.updated articles))) in
let content = sorted
|> List.map Canopy_content.to_tyxml_listing_entry
|> Canopy_templates.listing
in
respond_html ~headers ~title:config.Canopy_config.blog_name ~content ~updated
))
| Some article ->
let title, content = Canopy_content.to_tyxml article in
let updated = Canopy_content.updated article in
respond_html ~headers ~title ~content ~updated
end

let create console dispatch =
let conn_closed (_, conn_id) =
let cid = Cohttp.Connection.to_string conn_id in
C.log console (Printf.sprintf "conn %s closed" cid)
in
let callback = match dispatch with
| `Redirect fn ->
(fun _ request _ ->
let req = Cohttp.Request.uri request in
let uri = fn req in
C.log_s console (Printf.sprintf "redirecting to %s" (Uri.to_string uri)) >>= fun () ->
moved_permanently uri)
| `Dispatch (config, headers, disk, store, atom, content, time) ->
(fun _ request _ ->
let uri = Cohttp.Request.uri request in
let etag = Cohttp.Header.get Cohttp.Request.(request.headers) "if-none-match" in
C.log_s console (Printf.sprintf "request %s" (Uri.to_string uri)) >>= fun () ->
dispatcher config headers console disk store atom content (Uri.path uri) etag time)
in
S.make ~callback ~conn_closed ()
let create console dispatch =
let conn_closed (_, conn_id) =
let cid = Cohttp.Connection.to_string conn_id in
C.log console (Printf.sprintf "conn %s closed" cid)
in
let callback = match dispatch with
| `Redirect fn ->
(fun _ request _ ->
let req = Cohttp.Request.uri request in
let uri = fn req in
C.log_s console (Printf.sprintf "redirecting to %s" (Uri.to_string uri)) >>= fun () ->
moved_permanently uri)
| `Dispatch (config, headers, disk, store, atom, content, time) ->
(fun _ request _ ->
let uri = Cohttp.Request.uri request in
let etag = Cohttp.Header.get Cohttp.Request.(request.headers) "if-none-match" in
C.log_s console (Printf.sprintf "request %s" (Uri.to_string uri)) >>= fun () ->
dispatcher config headers console disk store atom content (Uri.path uri) etag time)
in
S.make ~callback ~conn_closed ()


end

0 comments on commit 0bbd3b6

Please sign in to comment.