diff --git a/Makefile b/Makefile index 532382923..0217e3701 100644 --- a/Makefile +++ b/Makefile @@ -26,7 +26,7 @@ IPADDR ?= static FLAGS ?= -.PHONY: all configure build run clean +.PHONY: all configure build run clean news all: @echo "To build this website, look in the Makefile and set" @@ -39,7 +39,10 @@ configure: depend: cd src && make depend -build: +news: + cd news && make run + +build: news cd src && make build run: @@ -47,4 +50,5 @@ run: clean: cd src && make clean + cd feeds && make clean $(RM) log src/mir-www src/*.img src/make-fat*.sh diff --git a/files/css/site.css b/files/css/site.css index 3311b9bbd..ffa15f26e 100644 --- a/files/css/site.css +++ b/files/css/site.css @@ -7,7 +7,7 @@ h4,h5,h6 { color: #222222; font-size: 1.4rem; font-weight: 600; } .front_updates h4 { font-style: italic; font-size: 1.2rem; } .front_updates ul { font-size: 1.0rem; } .front_updates a i { font-style: normal; color: #332222; } -.front_updates .front_date { color: #777799; } +.front_date { color: #777799; } .panel { padding-top: 0.5rem; diff --git a/news/.merlin b/news/.merlin new file mode 100644 index 000000000..14ec7b7e5 --- /dev/null +++ b/news/.merlin @@ -0,0 +1,8 @@ +PKG cow +PKG cow.syntax +PKG cowabloga +PKG lwt +PKG cohttp +PKG cohttp.lwt +PKG xmlm +PKG syndic diff --git a/news/Makefile b/news/Makefile new file mode 100644 index 000000000..9441ff6d5 --- /dev/null +++ b/news/Makefile @@ -0,0 +1,21 @@ +LIBS = -pkgs lwt.syntax,cow.syntax,cowabloga,lwt,cohttp,cohttp.lwt,xmlm,syndic +PKGS = cow cowabloga lwt cohttp xmlm syndic +SYNTAX = -tags "syntax(camlp4o)" +OPAM = opam + +.PHONY: all depend run build clean + +all: build + +depend: + $(OPAM) install $(PKGS) --verbose + +run: build + @echo "updating news pages" + @./news.native + +build: depend + ocamlbuild -use-ocamlfind $(LIBS) $(SYNTAX) news.native + +clean: + ocamlbuild -clean diff --git a/news/feeds.ml b/news/feeds.ml new file mode 100644 index 000000000..25cd1a6a2 --- /dev/null +++ b/news/feeds.ml @@ -0,0 +1,7 @@ +let feeds = [ + ("Anil Madhavapeddy", "http://anil.recoil.org/feeds/atom.xml"); + ("Mindy Preston", "http://www.somerandomidiot.com/atom.xml"); + ("Amir Chaudhry", "http://feeds.feedburner.com/amirmc"); + ("My Little Garden of Code", "https://philtomson.github.io/atom.xml"); + ("Thomas Leonard", "http://roscidus.com/blog/atom.xml"); +] diff --git a/news/news.ml b/news/news.ml new file mode 100644 index 000000000..e73d4cf78 --- /dev/null +++ b/news/news.ml @@ -0,0 +1,160 @@ +open Lwt +open Cohttp +open Cow +open Cowabloga +open Syndic_atom + + +(*** Syndic and RSS feeds ***) + +let string_of_text (t:text_construct) : string = match t with + | Text(s) -> s + | Html(_,s) -> s + | Xhtml(_,xs) -> List.fold_left (fun acc x -> acc ^ Syndic_xml.to_string x) "" xs + +(* given a feed as a string, try parsing it as Atom, then as RSS2 *) +let feed_of_string (u : string) (s : string) : Syndic_atom.feed option = + try + Some (Syndic_atom.parse (Xmlm.make_input (`String(0, s)))) + with _ -> try + let rss = Syndic_rss2.parse (Xmlm.make_input (`String(0, s))) in + let atom = Syndic_rss2.to_atom rss in + Some atom + with _ -> + Printf.fprintf stderr "Error parsing feed: %s\n" u; + None + +(* compare Syndic entries by date *) +let by_date (e1 : entry) (e2 : entry) : int = + Syndic_date.compare e2.updated e1.updated + + +(*** HTML formatting ***) +type news_item = { + title: string; + author:string; + date:int * string * int; + uri:string +} + +(* extract data required to display a news item *) +let mk_news_item ((n: string), (e : entry)) : news_item = + let date = e.updated in + let title = string_of_text e.title in + let uri = match e.links with + [] -> "" + | link :: _ -> Uri.to_string link.href + in + let open Syndic_date in + let day = day date in + let year = year date in + let month = month date |> string_of_month in + {title; author=n; date=(day, month, year); uri} + + +(* format a news item for news page *) +let news_page_item ((n: string), (e : entry)) = + let {title; author; date=(day, month, year); uri} = mk_news_item (n,e) in + let date = Printf.sprintf "%d %s %d" day month year in + <:html< +
+

$str:title$

+

$str:author$ ($str:date$)

+
+
&>> + +(* format a news item for home page *) +let home_page_item ((n: string), (e : entry)) = + let {title; date=(day, month, year); uri} = mk_news_item (n,e) in + let date = Printf.sprintf "%d %s %d" day month year in + <:html< +
  • + $str:title$ + ($str:date$)
    • &>> + + +(* format a feed an HTML list item *) +let syndication_item (name, uri) = + <:html< +
  • $str:name$
    • +>> + +(* format the news page as a list of entries and a list of feeds *) +let news_page feeds (es : (string * entry) list) = + <:html< +
    +
    +

    News

    +
    +
    +
    +
    +

    + Here, we aggregate various blogs from the Mirage community. + If you would like to be added, please + get in touch. +

    +
    + $list:List.map news_page_item es$ +
    + +
    + >> + +(* format the latest news as a list *) +let latest_news es = + let ns = List.map (fun (n, e) -> home_page_item (n, e)) es in + <:html< &>> + + +(*** Feeds retrieval and processing ***) + +(* return a list of named, Syndic entries, in chronological order *) +let named_entries feeds : (string * entry) list Lwt.t = + let http_get (uri : string) : string Lwt.t = + Cohttp_lwt_unix.Client.get (Uri.of_string uri) >>= fun (_, body) -> + Cohttp_lwt_body.to_string body + in + let rec join = function [] -> [] | xs::xss -> xs @ join xss + in + Lwt_list.map_p (fun (n, u) -> + http_get u >>= fun s -> return + (match feed_of_string u s with + Some(f) -> List.map (fun e -> (n, e)) f.entries + | None -> []) + ) feeds >>= fun ess -> + let es = join ess in + Lwt.return @@ List.sort (fun (_,e1) (_,e2) -> by_date e1 e2) es + +(* write HTML news page *) +let write_news_page feeds (es : (string * entry) list) : unit Lwt.t = + let html_page = news_page feeds es in + let fname = "../tmpl/news.html" in + Lwt_io.with_file + Lwt_io.output fname (fun ch -> Lwt_io.fprint ch (Html.to_string html_page)) + +(* write a list of latest news for homepage *) +let write_latest_news es = + let take n xs = + let rec take_aux n xs acc = + match (n, xs) with + (n, _) when n <= 0 -> acc + | (_, []) -> acc + | (n, x::xs) -> take_aux (n-1) xs (x::acc) + in List.rev (take_aux n xs []) + in + let latest_news = latest_news (take 10 es) in + let fname = "../tmpl/latest_news.html" in + Lwt_io.with_file + Lwt_io.output fname (fun ch -> Lwt_io.fprint ch (Html.to_string latest_news)) + +let write_news feeds es = + (write_news_page feeds es) <&> (write_latest_news es) +let _ = + let feeds = List.sort (fun (n1,_) (n2,_) -> compare n1 n2) Feeds.feeds in + Lwt_main.run (named_entries feeds >>= (write_news feeds)) diff --git a/src/dispatch.ml b/src/dispatch.ml index 4218bd2ea..f2f7c5b89 100644 --- a/src/dispatch.ml +++ b/src/dispatch.ml @@ -48,7 +48,7 @@ module Main `Blog (blog_feed, Data.Blog.entries); `Wiki (wiki_feed, Data.Wiki.entries); ] in - + lwt blog_dispatch = Blog.dispatch blog_feed Data.Blog.entries in lwt wiki_dispatch = Wiki.dispatch wiki_feed Data.Wiki.entries in lwt releases_dispatch = Pages.Releases.dispatch read_tmpl in @@ -65,14 +65,14 @@ module Main return (`Html (Pages.Index.t ~feeds:updates_feeds read_tmpl)) | ["about"] - | ["community"] -> - return (`Html (Pages.About.t read_tmpl)) + | ["community"] -> return (`Html (Pages.About.t read_tmpl)) + | ["news"] -> return (`Html (Pages.News.t read_tmpl)) | "releases" :: tl -> return (`Page (releases_dispatch tl)) | "blog" :: tl -> return (`Page (blog_dispatch tl)) | "links" :: tl -> return (links_dispatch tl) | "updates" :: tl -> return (`Page (updates_dispatch tl)) - + | "docs" :: tl | "wiki" :: tl -> return (`Page (wiki_dispatch tl)) diff --git a/src/pages.ml b/src/pages.ml index 69d55c43d..067b92feb 100644 --- a/src/pages.ml +++ b/src/pages.ml @@ -37,7 +37,7 @@ module Global = struct
  • Background
  • Contact
  • Team
    • -
  • Blogroll
    • +
  • News
  • Links
    • @@ -71,6 +71,7 @@ module Index = struct lwt l2 = read_file read_fn "/intro-3.md" in lwt footer = read_file read_fn "/intro-f.html" in lwt recent = Cowabloga.Feed.to_html ~limit:12 feeds in + lwt latest_news = read_file read_fn "/latest_news.html" in let content = <:html<
    @@ -83,6 +84,9 @@ module Index = struct

    Recent Updates (all)

    $recent$ +

    + Latest News (all)

    + $latest_news$
    @@ -166,7 +170,6 @@ module About = struct lwt r = read_file read_fn "/about-community.md" in lwt b = read_file read_fn "/about-b.md" in lwt f = read_file read_fn "/about-funding.md" in - lwt br = read_file read_fn "/about-blogroll.md" in let content = <:html<
    @@ -184,14 +187,24 @@ module About = struct
    $l$
    $r$
    -
    - -
    -
    $br$
    >> in return (Global.page ~title:"Community" ~headers:[] ~content) end + +module News = struct + let t read_fn = + lwt bs = read_file read_fn "news.html" in + let content = <:html< +
    +
    $bs$
    +
    + >> in + return (Global.page ~title:"News" ~headers:[] ~content) +end + + + module Releases = struct let content_type_xhtml = Cowabloga.Headers.html