├── .gitignore ├── .travis.yml ├── Dockerfile ├── LICENSE.md ├── README.md ├── _tags ├── assets ├── assets_generated.tar.gz ├── js │ └── main.js └── less │ ├── partials │ ├── atoms.less │ ├── constants.less │ ├── layout.less │ ├── navbar.less │ ├── reset.less │ └── typography.less │ └── style.less ├── canopy_article.ml ├── canopy_config.ml ├── canopy_content.ml ├── canopy_dispatch.ml ├── canopy_main.ml ├── canopy_store.ml ├── canopy_syndic.ml ├── canopy_templates.ml ├── canopy_utils.ml ├── config.ml ├── package.json ├── populate.sh └── tls └── .gitignore /.gitignore: -------------------------------------------------------------------------------- 1 | _build/ 2 | disk/ 3 | _opam/ 4 | 5 | key_gen.ml 6 | main.ml 7 | static1.ml 8 | static1.mli 9 | 10 | Makefile 11 | log 12 | 13 | canopy.x[el] 14 | canopy.x[el].in 15 | canopy_libvirt.xml 16 | main.native 17 | canopy 18 | canopy.xen 19 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | sudo: required 2 | 3 | services: 4 | - docker 5 | 6 | language: c 7 | 8 | before_install: 9 | - docker pull ocurrent/opam:debian-10-ocaml-4.08 10 | 11 | script: docker build -t canopy . 12 | -------------------------------------------------------------------------------- /Dockerfile: -------------------------------------------------------------------------------- 1 | FROM ocaml/opam:debian-10-ocaml-4.12 2 | MAINTAINER canopy 3 | ENV OPAMYES 1 4 | RUN sudo apt-get update 5 | RUN sudo apt-get install -yy curl software-properties-common 6 | RUN curl -sL https://deb.nodesource.com/setup_12.x | sudo bash - 7 | RUN sudo apt-get install -yy nodejs 8 | RUN sudo npm install -g less browserify 9 | RUN cd /home/opam/opam-repository && git pull origin master && opam update 10 | ADD package.json README.md config.ml /src/ 11 | WORKDIR /src 12 | ADD tls /src/tls 13 | RUN sudo chown -R opam:opam /src; sudo chmod -R 700 /src 14 | ENV TMP /tmp 15 | RUN opam install -y depext 16 | RUN opam depext -u mirage 17 | RUN opam install -y -j2 mirage 18 | COPY . /src 19 | ADD assets /src/assets 20 | RUN sudo chown -R opam:opam /src; sudo chmod -R 700 /src 21 | RUN opam config exec -- mirage configure 22 | RUN opam config exec -- make depend 23 | RUN opam config exec -- make 24 | RUN sudo mkdir /tmp/assets ; sudo chown opam:opam /tmp/assets ; ./populate.sh /tmp/assets 25 | EXPOSE 8080 26 | ENTRYPOINT ["opam", "config", "exec", "--", "./canopy"] 27 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | ISC License 2 | 3 | Copyright (c) ''2016,2017'', ''Enguerrand Decorne'' 4 | 5 | Permission to use, copy, modify, and/or distribute this software for any 6 | purpose with or without fee is hereby granted, provided that the above 7 | copyright notice and this permission notice appear in all copies. 8 | 9 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH 10 | REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY 11 | AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, 12 | INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM 13 | LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE 14 | OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR 15 | PERFORMANCE OF THIS SOFTWARE. -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Canopy - A git-blogging unikernel 🌿 [![Build Status](https://travis-ci.org/Engil/Canopy.svg?branch=master)](https://travis-ci.org/Engil/Canopy) 2 | 3 | Canopy is an attempt at writting a blog-engine based on Git using [MirageOS][mirage]. 4 | 5 | The goal is to provide a simple blog platform that only requires you to provide a Git remote URL and respecting some architecture rules within the said repository. 6 | 7 | Canopy is written in OCaml using MirageOS and [Irmin][irmin]. It is running on both Unix and Xen. 8 | 9 | [decompress]: 10 | [mirage]: 11 | [irmin]: 12 | 13 | ### HTTPS/TLS support 14 | 15 | Canopy has TLS support, you have to first create your TLS private key and get a 16 | signed certificate (using [certify](https://github.com/yomimono/ocaml-certify) 17 | and/or [let's encrypt](https://letsencrypt.org/) - sorry, no let's encrypt 18 | client in OCaml yet). 19 | 20 | Put your unencrypted private key into `tls/server.key`, and your full 21 | certificate chain (starting with the server certificate, then the intermediate 22 | CAs, no need to include the root CA) into `tls/server.pem` before running 23 | `mirage configure` (which will embed them as OCaml code into the binary). 24 | 25 | You can configure Canopy with `--tls=` to run it as HTTPS 26 | service. Canopy will then respond to HTTP requests with a [moved 27 | permanently](https://tools.ietf.org/html/rfc2616#section-10.3.2) redirection to 28 | the HTTPS URL. Also, the HTTPS service includes a [strict transport 29 | security](https://en.wikipedia.org/wiki/HTTP_Strict_Transport_Security) HTTP 30 | header (containing `max-age=31536000`). 31 | 32 | ### Compiling and running Canopy 33 | 34 | You will need at least `OCaml 4.07.1`, `opam 2.0` and `mirage 3.7.5` before starting. To setup a mirage environment, please refer to [the mirage website](https://mirage.io/). 35 | 36 | Checkout Canopy repository, then go inside: 37 | 38 | ```sh 39 | # Configure the mirage application, compile assets 40 | mirage configure -t unix 41 | # Get dependencies 42 | make depend 43 | # Compile Canopy 44 | make 45 | # Run it 46 | ./canopy 47 | ``` 48 | 49 | Note: if you run Canopy with a grsec kernel you might have to relax 50 | memory-mapping restrictions (i.e.: `paxctl -cm canopy`) and load the `tun` 51 | module. 52 | 53 | A server will be launched using the specified URL as the git remote, `Index` as the default page rendered on the blog (it must exist within the repository) and `8080` is the listening port. 54 | You can see more options by running `./canopy --help`. 55 | 56 | To prepare your own data repository, you have to use `npm`, `less-css` and `browserify` if you want to compile and retrieve everything related to the blog-styling. The `mirage configure` step takes care of fetching and recompiling all assets. If none of the mentioned programs were to be found, the configure step will use the tarball found in the `assets` directory, containing already compiled assets. 57 | 58 | ``` 59 | # OR start with git clone git://github.com/Engil/__blog.git ;) 60 | mkdir canopy-data 61 | cd canopy-data 62 | git init . 63 | # Populate data using npm, browserify, etc. 64 | if [ -x `which npm` ] ; then 65 | ./populate.sh /tmp/data 66 | else 67 | # OR use pregenerated tarball 68 | cd /tmp/data && tar xf assets/assets_generated.tar.gz 69 | cd /tmp/data && mv disk/static . 70 | fi; 71 | 72 | git add static 73 | 74 | # Generate a UUID for the Atom feed 75 | uuidtrip -r > .config/uuid 76 | # Add blog name (defaults to "Canopy") 77 | echo "My blog" > .config/blog_name 78 | git add .config 79 | 80 | git commit -m initial 81 | 82 | # configure git remote and push 83 | git remote add origin git@github.com/me/__blog.git 84 | git push origin master 85 | ``` 86 | 87 | You can run Canopy with your own data repository: 88 | 89 | ``` 90 | ./canopy -r git://github.com/me/__blog.git 91 | ``` 92 | 93 | You can use git branches for drafting changes: `./canopy -r git://github.com/me/__blog.git#dev`. 94 | 95 | ### Compiling and running on Xen 96 | 97 | If you want to build for xen, there's a couple of packages that need to be 98 | installed from specific branches. 99 | 100 | ```sh 101 | opam pin add dolog 'https://github.com/UnixJunkie/dolog.git#no_unix' 102 | opam pin add bin_prot 'https://github.com/hannesm/bin_prot.git#113.33.00+xen' 103 | ``` 104 | 105 | You can either build with support for DHCP or static ip, just specifying it as 106 | command line arguments, for instance: 107 | 108 | ```sh 109 | mirage configure --xen --dhcp false --net direct --ip 10.0.0.2 --netmask 255.255.255.0 --gateways 10.0.0.1 110 | make 111 | ``` 112 | 113 | Make sure to have `br0` set up for this. For example, I did: 114 | 115 | ```sh 116 | # provide ip forwarding 117 | echo 'net.ipv4.ip_forward=1' >> /etc/sysctl.conf 118 | sysctl -p /etc/sysctl.conf 119 | iptables -t nat -A POSTROUTING -o wlan0 -j MASQUERADE 120 | # create a new bridge 121 | brctl addbr br0 122 | ip addr dev br0 add 10.0.0.1/24 123 | ip link set br0 up 124 | ``` 125 | 126 | Finally you can run your unikernel! 127 | 128 | ```sh 129 | xl create -c canopy.xl 130 | ``` 131 | 132 | ### Git push hooks 133 | 134 | To keep your Canopy content updated, you need to tell your instance that new content is available on the git remote, then it will just pull the changes and will serve the new content. 135 | 136 | To do that, Canopy use a simple URL path that you can set into Canopy_config.ml (`hook_push_path`). 137 | 138 | Using Github, setting up this hook is pretty simple: just add a push webhook targeting your URL + your hook path. 139 | For example, by default this hook path is `push`, so the resulting URL is `http://yourdomain/push`. 140 | 141 | If you are not using Github, you can just find a way (`post-commit-hooks`, for example) to run a HTTP request to this URL. 142 | 143 | ### How Canopy works 144 | 145 | Canopy will require you to provide a Git remote uri. Once started, it will clone in-memory the repository content and serve the content in a more or less organized way. 146 | 147 | Each file at the root of the repository is considered a standalone page, more like the usual « About » or « Contact » pages. They will have their own entries in the navigation menu. 148 | 149 | Each directories will contains more pages, but that will be classified under a category decided by the name of the said directory. 150 | For example, a `posts/hello-word.md` file will be a new blog post under the `Posts` category. 151 | You can use it to emulate some sort of tag, like for example having an `OCaml` directory regrouping all you writing in everyone's favorite language. :-) 152 | 153 | Static assets (not processed) can be added into "static" subdir, configuration values below ".config". 154 | 155 | The file syntax of articles is just plain markdown, everything should be supported out-the-box (depending on the [`ocaml-omd`](https://github.com/ocaml/omd) markdown implementation), with a little bit of extra informations absolutely needed at the top of each files. 156 | 157 | ``` 158 | --- 159 | title: A blog entry 160 | author: Me 161 | author_url: http://www.an_optional_link_that_wraps_the_author.com 162 | abstract: A simple line telling what this article is all about, will be displayed in listing pages. (optional) 163 | --- 164 | article content 165 | ``` 166 | 167 | If you don't respect this syntax, then the article won't show up in the resulting website. 168 | 169 | You can also put some MathJax inside articles, Mathjax is activated if you pass the --mathjax parameter at startup. 170 | -------------------------------------------------------------------------------- /_tags: -------------------------------------------------------------------------------- 1 | true: package(checkseum.c digestif.c) 2 | -------------------------------------------------------------------------------- /assets/assets_generated.tar.gz: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/abbysmal/Canopy/7ad8691be9dffa60ba4fe9e1f2a786c12909780b/assets/assets_generated.tar.gz -------------------------------------------------------------------------------- /assets/js/main.js: -------------------------------------------------------------------------------- 1 | var $; 2 | $ = require('jquery') 3 | global.jQuery = require("jquery") 4 | _ = require('bootstrap') 5 | var hljs = require('highlight.js') 6 | hljs.initHighlightingOnLoad(); 7 | -------------------------------------------------------------------------------- /assets/less/partials/atoms.less: -------------------------------------------------------------------------------- 1 | // ======================= 2 | // APP DEFINED ELEMENTS 3 | // ======================= 4 | 5 | // Q: WHEN TO USE THIS FILE? 6 | // A: Defining a new small component or widget. 7 | 8 | .post, 9 | .listing { 10 | width: 90%; 11 | max-width: 800px; 12 | font-family: @HelveticaNeue; 13 | font-size: 1.2em; 14 | } 15 | 16 | a.list-group-item { 17 | border: 0; 18 | } 19 | 20 | .extract { 21 | margin-top: 10px; 22 | font-size: 0.9em; 23 | } 24 | 25 | .tag { 26 | margin-right: 4px; 27 | } 28 | -------------------------------------------------------------------------------- /assets/less/partials/constants.less: -------------------------------------------------------------------------------- 1 | // ====================== 2 | // VARS & CONSTANTS 3 | // ====================== 4 | 5 | // TODO: color audit and condense is needed 6 | 7 | @White: #fff; 8 | @DefaultColor: #aaa; 9 | @BarColor: @White; 10 | @TextColor: #333; 11 | @DarkGreyColor: #555; 12 | @GreyColor: #ccc; 13 | @MainColor: #eee; 14 | @SecondaryColor: #00b0e3; 15 | @AuthorColor: #555; 16 | @DateColor: #666; 17 | @TagColor: #666; 18 | @FooterText: #777; 19 | @NavToggleIconColor: #222; 20 | -------------------------------------------------------------------------------- /assets/less/partials/layout.less: -------------------------------------------------------------------------------- 1 | // ================= 2 | // GRID & LAYOUT 3 | // ================= 4 | 5 | main { 6 | margin-top: 60px; 7 | } 8 | 9 | .flex-container { 10 | display: flex; 11 | width: 100%; 12 | justify-content: center; 13 | } 14 | 15 | article { 16 | margin-top: 30px; 17 | } 18 | 19 | footer { 20 | margin-top: 20px; 21 | } 22 | 23 | pre { 24 | padding: 0px; 25 | } -------------------------------------------------------------------------------- /assets/less/partials/navbar.less: -------------------------------------------------------------------------------- 1 | // =================== 2 | // NAVBAR STYLES 3 | // =================== 4 | 5 | // TODO: A lot of these rules have deeply nested props 6 | // example: .navbar-variant .navbar-nav > li > a > &:hover 7 | // Important to cut bloat from generated CSS, slow queries, etc. 8 | 9 | 10 | .navbar { 11 | background-color: #FFF; 12 | background-image: linear-gradient(to right, 13 | wheat, 14 | wheat 10%, 15 | skyblue 10%, 16 | skyblue 20%, 17 | lightcoral 20%, 18 | lightcoral 30%, 19 | wheat 30%, 20 | wheat 40%, 21 | skyblue 40%, 22 | skyblue 50%, 23 | lightcoral 50%, 24 | lightcoral 60%, 25 | wheat 60%, 26 | wheat 70%, 27 | skyblue 70%, 28 | skyblue 80%, 29 | lightcoral 80%, 30 | lightcoral 90%, 31 | wheat 90%, 32 | wheat 100%); 33 | background-size: 100% 5px; 34 | background-position: 50% 100%; 35 | background-repeat: no-repeat; 36 | border: 0px; 37 | } 38 | 39 | .navbar-toggle .icon-bar { 40 | background-color: @NavToggleIconColor; 41 | } 42 | 43 | .navbar-default .navbar-brand { 44 | color: #555; 45 | &:hover, 46 | &:focus { 47 | color: #555; 48 | } 49 | } 50 | 51 | .navbar-default .navbar-nav { 52 | > li > a { 53 | color: #555; 54 | 55 | &:hover, 56 | &:focus { 57 | color: #555; 58 | } 59 | } 60 | } -------------------------------------------------------------------------------- /assets/less/partials/reset.less: -------------------------------------------------------------------------------- 1 | // ==================== 2 | // RESETS 3 | // ==================== 4 | // Because the web is hard. 5 | 6 | *, html { 7 | zoom: 1; 8 | } 9 | 10 | body { 11 | background: @White; 12 | } 13 | -------------------------------------------------------------------------------- /assets/less/partials/typography.less: -------------------------------------------------------------------------------- 1 | // =================== 2 | // FONT & HEADINGS 3 | // =================== 4 | 5 | // @import url(https://fonts.googleapis.com/css?family=Josefin+Sans:600); 6 | @HelveticaNeue: "Helvetica Neue", Helvetica, Arial, sans-serif; 7 | 8 | h2 { 9 | margin-bottom: 3px; 10 | color: @DarkGreyColor; 11 | } 12 | 13 | main { 14 | font-size: 0.95em; 15 | } 16 | 17 | .post-title { 18 | font-size: 1.2em; 19 | } 20 | 21 | .author { 22 | font-size: 0.8em; 23 | color: @AuthorColor; 24 | } 25 | 26 | .date { 27 | font-size: 0.7em; 28 | color: @DateColor; 29 | } 30 | 31 | time { 32 | font-size: 0.7em; 33 | color: @DateColor; 34 | } 35 | 36 | footer { 37 | font-size: 0.7em; 38 | color: @FooterText; 39 | font-family: @HelveticaNeue; 40 | } 41 | 42 | 43 | .tags { 44 | color: @TagColor; 45 | font-size: 0.8em; 46 | } -------------------------------------------------------------------------------- /assets/less/style.less: -------------------------------------------------------------------------------- 1 | // ====================== 2 | // MAIN APP STYLES 3 | // ====================== 4 | 5 | // Q: WHEN CAN I EDIT THIS FILE? 6 | // A: This file should only be edited to add 7 | // new partial files. It should contain 8 | // NO raw styles dropped in. NONE whatsoever. 9 | // Partial imports are organized from most basic 10 | // to most specific to preserve natural CSS cascade. 11 | 12 | @import url(partials/reset.less); 13 | @import url(partials/constants.less); 14 | @import url(partials/layout.less); 15 | @import url(partials/typography.less); 16 | @import url(partials/atoms.less); 17 | @import url(partials/navbar.less); -------------------------------------------------------------------------------- /canopy_article.ml: -------------------------------------------------------------------------------- 1 | open Canopy_utils 2 | open Tyxml.Html 3 | 4 | type t = { 5 | title : string; 6 | content : string; 7 | author : string; 8 | author_uri : string option; 9 | abstract : string option; 10 | uri : string; 11 | created: Ptime.t; 12 | updated: Ptime.t; 13 | tags: string list; 14 | uuid: string; 15 | } 16 | 17 | let of_string base_uuid meta uri created updated content = 18 | try 19 | let split_tags = Re.Str.split (Re.Str.regexp ",") in 20 | let content = Omd.to_html (Omd.of_string content) in 21 | let author = List.assoc "author" meta in 22 | let title = List.assoc "title" meta in 23 | let tags = assoc_opt "tags" meta |> map_opt split_tags [] |> List.map String.trim in 24 | let abstract = match assoc_opt "abstract" meta with 25 | | None -> None 26 | | Some x -> Some (Omd.to_html (Omd.of_string x)) 27 | in 28 | let author_uri = assoc_opt "author_url" meta in 29 | let uuid = 30 | let open Uuidm in 31 | let stamp = Ptime.to_rfc3339 created in 32 | let entry_id = to_string (v5 (create (`V5 (ns_dns, stamp))) base_uuid) in 33 | Printf.sprintf "urn:uuid:%s" entry_id 34 | in 35 | Some {title; content; author; author_uri; uri; abstract; created; updated; tags; uuid} 36 | with 37 | | _ -> None 38 | 39 | let to_tyxml article = 40 | let author = "Written by " ^ article.author in 41 | let created = ptime_to_pretty_date article.created in 42 | let updated = ptime_to_pretty_date article.updated in 43 | let updated = String.concat " " 44 | [ "Published:" ; created ; "(last updated:" ; updated ^ ")" ] 45 | in 46 | let tags = Canopy_templates.taglist article.tags in 47 | let author_span_or_a = match article.author_uri with 48 | | None -> span ~a:[a_class ["author"]] [pcdata author] 49 | | Some a_uri -> a ~a:[a_class ["author"]; a_href a_uri] [pcdata author] 50 | in 51 | [div ~a:[a_class ["post"]] [ 52 | h2 [pcdata article.title]; 53 | author_span_or_a; 54 | br (); 55 | tags; 56 | span ~a:[a_class ["date"]] [pcdata updated]; 57 | br (); 58 | Tyxml.Html.article [Unsafe.data article.content] 59 | ]] 60 | 61 | let to_tyxml_listing_entry article = 62 | let author = "Written by " ^ article.author in 63 | let abstract = match article.abstract with 64 | | None -> [] 65 | | Some abstract -> [p ~a:[a_class ["list-group-item-text abstract"]] [Unsafe.data abstract]] in 66 | let created = ptime_to_pretty_date article.created in 67 | let content = [ 68 | h2 ~a:[a_class ["list-group-item-heading"]] [pcdata article.title]; 69 | span ~a:[a_class ["author"]] [pcdata author]; 70 | pcdata " "; 71 | time [pcdata created]; 72 | br (); 73 | ] in 74 | a ~a:[a_href ("/" ^ article.uri); a_class ["list-group-item"]] (content ++ abstract) 75 | 76 | let to_tyxml_tags tags = 77 | let format_tag tag = 78 | let taglink = Printf.sprintf "/tags/%s" in 79 | a ~a:[taglink tag |> a_href; a_class ["list-group-item"]] [pcdata tag] in 80 | let html = match tags with 81 | | [] -> div [] 82 | | tags -> 83 | let tags = List.map format_tag tags in 84 | p ~a:[a_class ["tags"]] tags 85 | in 86 | [div ~a:[a_class ["post"]] [ 87 | h2 [pcdata "Tags"]; 88 | div ~a:[a_class ["list-group listing"]] [html]]] 89 | 90 | let to_atom cache ({ title; author; abstract; uri; created; updated; tags; content; uuid}) = 91 | let text x : Syndic.Atom.text_construct = Syndic.Atom.Text x in 92 | let summary = match abstract with 93 | | Some x -> Some (text x) 94 | | None -> None 95 | in 96 | let root = Canopy_config.root cache 97 | in 98 | let categories = 99 | List.map 100 | (fun x -> Syndic.Atom.category ~scheme:(Uri.of_string (root ^ "/tags/" ^ x)) x) 101 | tags 102 | in 103 | Syndic.Atom.entry 104 | ~id:(Uri.of_string uuid) 105 | ~content:(Syndic.Atom.Html (None, content)) 106 | ~authors:(Syndic.Atom.author author, []) 107 | ~title:(text title) 108 | ~published:created 109 | ~updated 110 | ?summary 111 | ~categories 112 | ~links:[Syndic.Atom.link ~rel:Syndic.Atom.Alternate (Uri.of_string uri)] 113 | () 114 | -------------------------------------------------------------------------------- /canopy_config.ml: -------------------------------------------------------------------------------- 1 | open Canopy_utils 2 | 3 | let decompose_git_url url = 4 | match String.rindex url '#' with 5 | | exception Not_found -> (url, None) 6 | | i -> 7 | let remote_url = String.sub url 0 i in 8 | let branch = String.sub url (i + 1) (String.length url - i - 1) in 9 | (remote_url, Some branch) 10 | 11 | let remote_uri () = fst (decompose_git_url (Key_gen.remote ())) 12 | let remote_branch () = snd (decompose_git_url (Key_gen.remote ())) 13 | let port () = Key_gen.port () 14 | let tls_port () = Key_gen.tls_port () 15 | let push_hook_path () = Key_gen.push_hook () 16 | 17 | let entry name = [ ".config" ; name ] 18 | 19 | let index_page cache = 20 | match KeyMap.find_opt cache @@ entry "index_page" with 21 | | Some (`Config p) -> p 22 | | _ -> "Index" 23 | 24 | let blog_name cache = 25 | match KeyMap.find_opt cache @@ entry "blog_name" with 26 | | Some (`Config n) -> n 27 | | _ -> "Canopy" 28 | 29 | let root cache = 30 | match KeyMap.find_opt cache @@ entry "root" with 31 | | Some (`Config r) -> r 32 | | _ -> "http://localhost" 33 | -------------------------------------------------------------------------------- /canopy_content.ml: -------------------------------------------------------------------------------- 1 | open Canopy_utils 2 | 3 | type content_t = 4 | | Markdown of Canopy_article.t 5 | 6 | type error_t = 7 | Unknown 8 | | Error of string 9 | | Ok of content_t 10 | 11 | let meta_assoc str = 12 | Re.Str.split (Re.Str.regexp "\n") str |> 13 | List.map (fun meta -> 14 | let reg = Re.Str.regexp "\\(.*\\): \\(.*\\)" in 15 | let _ = Re.Str.string_match reg meta 0 in 16 | let key = Re.Str.matched_group 1 meta in 17 | let value = Re.Str.matched_group 2 meta in 18 | key, value) 19 | 20 | let of_string ~base_uuid ~uri ~created ~updated ~content = 21 | let splitted_content = Re.Str.bounded_split (Re.Str.regexp "---") content 2 in 22 | match splitted_content with 23 | | [raw_meta;raw_content] -> 24 | begin 25 | match meta_assoc raw_meta with 26 | | meta -> 27 | begin 28 | match assoc_opt "content" meta with 29 | | Some "markdown" 30 | | None -> 31 | Canopy_article.of_string base_uuid meta uri created updated raw_content 32 | |> map_opt (fun article -> Ok (Markdown article)) (Error "Error while parsing article") 33 | | Some _ -> Unknown 34 | end 35 | | exception _ -> Unknown 36 | end 37 | | _ -> Error "No header found" 38 | 39 | let to_tyxml = function 40 | | Markdown m -> 41 | let open Canopy_article in 42 | m.title, to_tyxml m 43 | 44 | let to_tyxml_listing_entry = function 45 | | Markdown m -> Canopy_article.to_tyxml_listing_entry m 46 | 47 | let to_atom cache = function 48 | | Markdown m -> Canopy_article.to_atom cache m 49 | 50 | let find_tag tagname = function 51 | | Markdown m -> 52 | List.exists ((=) tagname) m.Canopy_article.tags 53 | 54 | let date = function 55 | | Markdown m -> 56 | m.Canopy_article.created 57 | 58 | let compare a b = Ptime.compare (date b) (date a) 59 | 60 | let updated = function 61 | | Markdown m -> 62 | m.Canopy_article.updated 63 | 64 | let tags content_map = 65 | let module S = Set.Make(String) in 66 | let s = KeyMap.fold_articles ( 67 | fun _k v s -> match v with 68 | | Markdown m -> 69 | let s' = S.of_list m.Canopy_article.tags in 70 | S.union s s') 71 | content_map S.empty 72 | in S.elements s 73 | -------------------------------------------------------------------------------- /canopy_dispatch.ml: -------------------------------------------------------------------------------- 1 | open Lwt.Infix 2 | 3 | type store_ops = { 4 | subkeys : string list -> string list list Lwt.t ; 5 | value : string list -> string option Lwt.t ; 6 | update : unit -> unit Lwt.t ; 7 | last_commit : unit -> Ptime.t Lwt.t ; 8 | } 9 | 10 | module Make (S: Cohttp_lwt.S.Server) = struct 11 | 12 | let src = Logs.Src.create "canopy-dispatch" ~doc:"Canopy dispatch logger" 13 | module Log = (val Logs.src_log src : Logs.LOG) 14 | 15 | let moved_permanently uri = 16 | let headers = Cohttp.Header.init_with "location" (Uri.to_string uri) in 17 | S.respond ~headers ~status:`Moved_permanently ~body:`Empty () 18 | 19 | let rec dispatcher headers store atom cache uri etag = 20 | let open Canopy_utils in 21 | let respond_not_found () = 22 | S.respond_string ~headers ~status:`Not_found ~body:"Not found" () 23 | in 24 | let respond_if_modified ~headers ~body ~updated = 25 | match etag with 26 | | Some tg when Ptime.to_rfc3339 updated = tg -> 27 | S.respond ~headers ~status:`Not_modified ~body:`Empty () 28 | | _ -> 29 | S.respond_string ~headers ~status:`OK ~body () 30 | in 31 | let respond_html ~headers ~content ~title ~updated = 32 | store.subkeys [] >>= fun keys -> 33 | let body = Canopy_templates.main ~cache:(!cache) ~content ~title ~keys in 34 | let headers = html_headers headers updated in 35 | respond_if_modified ~headers ~body ~updated 36 | and respond_update () = S.respond_string ~headers ~status:`OK ~body:"" () 37 | in 38 | match Re.Str.split (Re.Str.regexp "/") (Uri.pct_decode uri) with 39 | | [] -> 40 | let index_page = Canopy_config.index_page !cache in 41 | dispatcher headers store atom cache index_page etag 42 | | "atom" :: [] -> 43 | atom () >>= fun body -> 44 | store.last_commit () >>= fun updated -> 45 | let headers = atom_headers headers updated in 46 | respond_if_modified ~headers ~body ~updated 47 | | uri::[] when uri = Canopy_config.push_hook_path () -> 48 | store.update () >>= fun () -> 49 | respond_update () 50 | | "tags"::[] -> ( 51 | let tags = Canopy_content.tags !cache in 52 | let content = Canopy_article.to_tyxml_tags tags in 53 | store.last_commit () >>= fun updated -> 54 | let title = Canopy_config.blog_name !cache in 55 | respond_html ~headers ~title ~content ~updated 56 | ) 57 | | "tags"::tagname::_ -> ( 58 | let aux _ v l = 59 | if Canopy_content.find_tag tagname v then (v::l) else l 60 | in 61 | let sorted = KeyMap.fold_articles aux !cache [] |> List.sort Canopy_content.compare in 62 | match sorted with 63 | | [] -> respond_not_found () 64 | | _ -> 65 | let updated = List.hd (List.rev (List.sort Ptime.compare (List.map Canopy_content.updated sorted))) in 66 | let content = sorted 67 | |> List.map Canopy_content.to_tyxml_listing_entry 68 | |> Canopy_templates.listing 69 | in 70 | let title = Canopy_config.blog_name !cache in 71 | respond_html ~headers ~title ~content ~updated 72 | ) 73 | | key -> 74 | begin 75 | match KeyMap.find_opt !cache key with 76 | | None 77 | | Some (`Config _ ) -> ( 78 | store.subkeys key >>= function 79 | | [] -> respond_not_found () 80 | | keys -> 81 | let articles = List.map (KeyMap.find_article_opt !cache) keys |> list_reduce_opt in 82 | match articles with 83 | | [] -> respond_not_found () 84 | | _ -> ( 85 | let sorted = List.sort Canopy_content.compare articles in 86 | let updated = List.hd (List.rev (List.sort Ptime.compare (List.map Canopy_content.updated articles))) in 87 | let content = sorted 88 | |> List.map Canopy_content.to_tyxml_listing_entry 89 | |> Canopy_templates.listing 90 | in 91 | let title = Canopy_config.blog_name !cache in 92 | respond_html ~headers ~title ~content ~updated 93 | )) 94 | | Some (`Article article) -> 95 | let title, content = Canopy_content.to_tyxml article in 96 | let updated = Canopy_content.updated article in 97 | respond_html ~headers ~title ~content ~updated 98 | | Some (`Raw (body, updated)) -> 99 | let headers = static_headers headers uri updated in 100 | respond_if_modified ~headers ~body ~updated 101 | | Some (`Redirect uri) -> 102 | moved_permanently uri 103 | end 104 | 105 | (* maybe this should be provided elsewhere *) 106 | let log request response = 107 | let open Cohttp in 108 | let sget k = match Header.get request.Request.headers k with 109 | | None -> "-" 110 | | Some x -> x 111 | in 112 | Log.info (fun f -> 113 | f "\"%s %s %s\" %d \"%s\" \"%s\"" 114 | (Code.string_of_method request.Request.meth) 115 | request.Request.resource 116 | (Code.string_of_version request.Request.version) 117 | (Code.code_of_status response.Response.status) 118 | (sget "Referer") 119 | (sget "User-Agent")) 120 | 121 | let create dispatch = 122 | let conn_closed (_, conn_id) = 123 | let cid = Cohttp.Connection.to_string conn_id in 124 | Log.debug (fun f -> f "conn %s closed" cid) 125 | in 126 | let callback = match dispatch with 127 | | `Redirect fn -> 128 | (fun _ request _ -> 129 | let redirect = fn (Cohttp.Request.uri request) in 130 | moved_permanently redirect >|= fun (res, body) -> 131 | log request res ; 132 | (res, body)) 133 | | `Dispatch (headers, store, atom, content) -> 134 | (fun _ request _ -> 135 | let uri = Cohttp.Request.uri request in 136 | let etag = Cohttp.Header.get Cohttp.Request.(request.headers) "if-none-match" in 137 | dispatcher headers store atom content (Uri.path uri) etag >|= fun (res, body) -> 138 | log request res ; 139 | (res, body)) 140 | in 141 | S.make ~callback ~conn_closed () 142 | end 143 | -------------------------------------------------------------------------------- /canopy_main.ml: -------------------------------------------------------------------------------- 1 | open Lwt.Infix 2 | 3 | module Main (S: Mirage_stack.V4) (_: sig end) (_: Resolver_lwt.S) (_: Conduit_mirage.S) (CLOCK: Mirage_clock.PCLOCK) (KEYS: Mirage_kv.RO) = struct 4 | 5 | module TCP = S.TCPV4 6 | module TLS = Tls_mirage.Make (TCP) 7 | module X509 = Tls_mirage.X509 (KEYS) (CLOCK) 8 | 9 | module HTTP = Cohttp_mirage.Server(TCP) 10 | module HTTPS = Cohttp_mirage.Server(TLS) 11 | 12 | module D = Canopy_dispatch.Make(HTTP) 13 | module DS = Canopy_dispatch.Make(HTTPS) 14 | 15 | let src = Logs.Src.create "canopy-main" ~doc:"Canopy main logger" 16 | module Log = (val Logs.src_log src : Logs.LOG) 17 | 18 | let with_tls cfg tcp f = 19 | let peer, port = TCP.dst tcp in 20 | TLS.server_of_flow cfg tcp >>= function 21 | | Error e -> 22 | Log.warn (fun f -> f "%s:%d TLS failed %a" (Ipaddr.V4.to_string peer) port TLS.pp_write_error e); 23 | TCP.close tcp 24 | | Ok tls -> 25 | Log.info (fun f -> f "%s:%d TLS ok" (Ipaddr.V4.to_string peer) port); 26 | f tls >>= fun () -> TLS.close tls 27 | 28 | let with_tcp tcp f = 29 | let peer, port = TCP.dst tcp in 30 | Log.info (fun f -> f "%s:%d TCP established" (Ipaddr.V4.to_string peer) port); 31 | f tcp >>= fun () -> TCP.close tcp 32 | 33 | let tls_init kv = 34 | X509.certificate kv `Default >|= fun cert -> 35 | Tls.Config.server ~certificates:(`Single cert) () 36 | 37 | module Store = Canopy_store 38 | 39 | let start stack ctx resolver conduit _clock keys = 40 | let ctx = Git_cohttp_mirage.with_conduit (Cohttp_mirage.Client.ctx resolver conduit) ctx in 41 | Store.pull ~ctx >>= fun () -> 42 | Store.base_uuid () >>= fun uuid -> 43 | Store.fill_cache uuid >>= fun new_cache -> 44 | let cache = ref (new_cache) in 45 | let update_atom, atom = 46 | Canopy_syndic.atom uuid Store.last_commit_date cache 47 | in 48 | let store_ops = { 49 | Canopy_dispatch.subkeys = Store.get_subkeys ; 50 | value = Store.get_key ; 51 | update = 52 | (fun () -> 53 | Store.pull ~ctx >>= fun () -> 54 | Store.fill_cache uuid >>= fun new_cache -> 55 | cache := new_cache ; 56 | update_atom ()); 57 | last_commit = Store.last_commit_date ; 58 | } in 59 | update_atom () >>= fun () -> 60 | let disp hdr = `Dispatch (hdr, store_ops, atom, cache) in 61 | (match Canopy_config.tls_port () with 62 | | Some tls_port -> 63 | let redir uri = 64 | let https = Uri.with_scheme uri (Some "https") in 65 | let port = match tls_port, Uri.port uri with 66 | | 443, None -> None 67 | | _ -> Some tls_port 68 | in 69 | Uri.with_port https port 70 | in 71 | let http_callback = HTTP.listen (D.create (`Redirect redir)) in 72 | let http flow = with_tcp flow http_callback 73 | and port = Canopy_config.port () 74 | in 75 | S.listen_tcpv4 stack ~port http ; 76 | Log.info (fun f -> f "HTTP server listening on port %d, \ 77 | redirecting to https service on port %d" 78 | port tls_port) ; 79 | tls_init keys >|= fun tls_conf -> 80 | let hdr = Cohttp.Header.init_with 81 | "Strict-Transport-Security" "max-age=31536000" (* in seconds, roughly a year *) 82 | in 83 | let callback = HTTPS.listen (DS.create (disp hdr)) in 84 | let https flow = with_tls tls_conf flow callback in 85 | S.listen_tcpv4 stack ~port:tls_port https ; 86 | Log.info (fun f -> f "HTTPS server listening on port %d" tls_port) 87 | | None -> 88 | let hdr = Cohttp.Header.init () in 89 | let http_callback = HTTP.listen (D.create (disp hdr)) in 90 | let http flow = with_tcp flow http_callback 91 | and port = Canopy_config.port () 92 | in 93 | S.listen_tcpv4 stack ~port http ; 94 | Log.info (fun f -> f "HTTP server listening on port %d" port) ; 95 | Lwt.return_unit 96 | ) >>= fun () -> 97 | S.listen stack 98 | end 99 | -------------------------------------------------------------------------------- /canopy_store.ml: -------------------------------------------------------------------------------- 1 | open Lwt.Infix 2 | open Canopy_config 3 | open Canopy_utils 4 | 5 | module Store = Irmin_mirage_git.Mem.KV(Irmin.Contents.String) 6 | module Sync = Irmin.Sync(Store) 7 | module Topological = Graph.Topological.Make(Store.History) 8 | 9 | let src = Logs.Src.create "canopy-store" ~doc:"Canopy store logger" 10 | module Log = (val Logs.src_log src : Logs.LOG) 11 | 12 | let store_config = Irmin_mem.config () 13 | let repo _ = Store.Repo.v store_config 14 | 15 | let store () = 16 | match remote_branch () with 17 | | None -> repo () >>= Store.master 18 | | Some branch -> repo () >>= fun r -> Store.of_branch r branch 19 | 20 | let walk t root = 21 | let todo = ref [] in 22 | let all = ref [] in 23 | let rec aux () = match !todo with 24 | | [] -> Lwt.return_unit 25 | | k::rest -> 26 | todo := rest; 27 | Store.list t k >>= fun childs -> 28 | Lwt_list.iter_p (fun (s, _c) -> 29 | let k = k @ [s] in 30 | Store.kind t k >>= function 31 | | None -> Lwt.return_unit 32 | | Some `Node -> todo := k :: !todo; Lwt.return_unit 33 | | Some `Contents -> 34 | Store.get t k >|= fun v -> 35 | all := (k, v) :: !all 36 | ) childs >>= 37 | aux 38 | in 39 | todo := [root]; 40 | aux () >|= fun () -> 41 | !all 42 | 43 | let key_type = function 44 | | x::_ when x = "static" -> `Static 45 | | x::_ when x = ".config" -> `Config 46 | | _ -> `Article 47 | 48 | let get_subkeys key = 49 | store () >>= fun t -> 50 | walk t key >|= fun keys -> 51 | List.fold_left (fun acc (k, _) -> 52 | if key_type k = `Article then k :: acc else acc 53 | ) [] keys 54 | 55 | let get_key key = 56 | store () >>= fun t -> 57 | Store.find t key 58 | 59 | let fold t fn acc = 60 | let mut = Lwt_mutex.create () in 61 | walk t [] >>= fun all -> 62 | Lwt_list.fold_left_s (fun acc (k, v) -> 63 | Lwt_mutex.with_lock mut (fun () -> acc >|= fn k v) 64 | ) (Lwt.return acc) all 65 | >>= fun x -> x 66 | 67 | let base_uuid () = 68 | get_key [".config" ; "uuid"] >|= function 69 | | None -> invalid_arg ".config/uuid is required in the remote git repository" 70 | | Some n -> String.trim n 71 | 72 | let pull ~ctx = 73 | let upstream = Store.remote ~ctx (remote_uri ()) in 74 | store () >>= fun t -> 75 | Log.info (fun f -> f "pulling repository") ; 76 | Lwt.catch 77 | (fun () -> 78 | Sync.pull_exn t upstream `Set >|= fun _ -> 79 | Log.info (fun f -> f "repository pulled")) 80 | (fun e -> 81 | Log.warn (fun f -> f "failed pull %a" Fmt.exn e); 82 | Lwt.return ()) 83 | 84 | let created_updated_ids commit key = 85 | store () >>= fun t -> 86 | Store.history t >>= fun history -> 87 | let aux commit_id acc = 88 | Store.of_commit commit_id >>= fun store -> 89 | acc >>= fun (created, updated, last) -> 90 | Store.find store key >|= fun data -> 91 | match data, last with 92 | | None , None -> (created, updated, last) 93 | | None , Some _ -> (created, updated, last) 94 | | Some x, Some y when x = y -> (created, updated, last) 95 | | Some _, None -> (commit_id, commit_id, data) 96 | | Some _, Some _ -> (created, commit_id, data) 97 | in 98 | Topological.fold aux history (Lwt.return (commit, commit, None)) 99 | 100 | let date_updated_created key = 101 | store () >>= fun t -> 102 | Store.Head.get t >>= fun head -> 103 | created_updated_ids head key >>= fun (created_commit_id, updated_commit_id, _) -> 104 | let to_ptime info = 105 | Irmin.Info.date info |> Int64.to_float |> Ptime.of_float_s 106 | in 107 | Store.Commit.info updated_commit_id |> fun updated -> 108 | Store.Commit.info created_commit_id |> fun created -> 109 | match to_ptime updated, to_ptime created with 110 | | Some a, Some b -> Lwt.return (a, b) 111 | | _ -> raise (Invalid_argument "date_updated_last") 112 | 113 | let check_redirect content = 114 | match Astring.String.cut ~sep:"redirect:" content with 115 | | None -> None 116 | | Some (_, path) -> Some (Uri.of_string (String.trim path)) 117 | 118 | let fill_cache base_uuid = 119 | let module C = Canopy_content in 120 | let fn key content cache = 121 | date_updated_created key >|= fun (updated, created) -> 122 | match key_type key with 123 | | `Static -> KeyMap.add key (`Raw (content, updated)) cache 124 | | `Config -> KeyMap.add key (`Config (String.trim content)) cache 125 | | `Article -> 126 | let uri = String.concat "/" key in 127 | match C.of_string ~base_uuid ~uri ~content ~created ~updated with 128 | | C.Ok article -> KeyMap.add key (`Article article) cache 129 | | C.Unknown -> 130 | Log.warn (fun f -> f "%s : Unknown content type" uri) ; 131 | cache 132 | | C.Error error -> 133 | match check_redirect content with 134 | | None -> 135 | Log.warn (fun f -> f "Error while parsing %s: %s" uri error) ; 136 | cache 137 | | Some uri -> KeyMap.add key (`Redirect uri) cache 138 | in 139 | store () >>= fun t -> 140 | fold t fn KeyMap.empty 141 | 142 | let last_commit_date () = 143 | store () >>= fun t -> 144 | Store.Head.get t >>= fun head -> 145 | Store.Commit.info head |> fun info -> 146 | let date = Irmin.Info.date info |> Int64.to_float in 147 | Ptime.of_float_s date |> function 148 | | Some o -> Lwt.return o 149 | | None -> raise (Invalid_argument "date_updated_last") 150 | -------------------------------------------------------------------------------- /canopy_syndic.ml: -------------------------------------------------------------------------------- 1 | 2 | open Lwt.Infix 3 | open Canopy_utils 4 | open Canopy_config 5 | 6 | let atom uuid last_commit_date content_cache = 7 | let cache = ref None in 8 | let update_atom () = 9 | let l = KeyMap.fold_articles (fun _ x acc -> x :: acc) !content_cache [] 10 | |> List.sort Canopy_content.compare 11 | |> resize 10 in 12 | let entries = List.map (Canopy_content.to_atom !content_cache) l in 13 | let ns_prefix _ = Some "" in 14 | last_commit_date () >|= fun updated -> 15 | Syndic.Atom.feed 16 | ~id:(Uri.of_string ("urn:uuid:" ^ uuid)) 17 | ~title:(Syndic.Atom.Text (blog_name !content_cache): Syndic.Atom.text_construct) 18 | ~updated 19 | ~links:[Syndic.Atom.link ~rel:Syndic.Atom.Self (Uri.of_string (root !content_cache ^ "/atom"))] 20 | entries 21 | |> fun feed -> Syndic.Atom.to_xml feed 22 | |> fun x -> Syndic.XML.to_string ~ns_prefix x 23 | |> fun body -> cache := Some body; body 24 | in 25 | (fun () -> ignore (update_atom ()); Lwt.return ()), 26 | (fun () -> match !cache with 27 | | Some body -> Lwt.return body 28 | | None -> update_atom ()) 29 | -------------------------------------------------------------------------------- /canopy_templates.ml: -------------------------------------------------------------------------------- 1 | open Canopy_config 2 | open Canopy_utils 3 | open Tyxml.Html 4 | 5 | let empty = 6 | div [] 7 | 8 | let taglist tags = 9 | let format_tag tag = 10 | let taglink = Printf.sprintf "/tags/%s" in 11 | a ~a:[taglink tag |> a_href; a_class ["tag"]] [pcdata tag] in 12 | match tags with 13 | | [] -> empty 14 | | tags -> 15 | let tags = List.map format_tag tags in 16 | div ~a:[a_class ["tags"]] ([pcdata "Classified under: "] ++ tags) 17 | 18 | let links keys = 19 | let paths = List.map (function 20 | | x::_ -> x 21 | | _ -> assert false 22 | ) keys |> List.sort_uniq (Pervasives.compare) in 23 | let format_link link = 24 | li [ a ~a:[a_href ("/" ^ link)] [span [pcdata link]]] in 25 | List.map format_link paths 26 | 27 | let main ~cache ~content ~title ~keys = 28 | let links = links keys in 29 | let page = 30 | html 31 | (head 32 | (Tyxml.Html.title (pcdata title)) 33 | ([ 34 | meta ~a:[a_charset "UTF-8"] (); 35 | link ~rel:[`Stylesheet] ~href:"/static/css/bootstrap.min.css" (); 36 | link ~rel:[`Stylesheet] ~href:"/static/css/style.css" (); 37 | link ~rel:[`Stylesheet] ~href:"/static/css/highlight.css" (); 38 | script ~a:[a_src "/static/js/canopy.js"] (pcdata ""); 39 | link ~rel:[`Alternate] ~href:"/atom" ~a:[a_title title; a_mime_type "application/atom+xml"] (); 40 | meta ~a:[a_name "viewport"; a_content "width=device-width, initial-scale=1, viewport-fit=cover"] (); 41 | ]) 42 | ) 43 | (body 44 | [ 45 | nav ~a:[a_class ["navbar navbar-default navbar-fixed-top"]] [ 46 | div ~a:[a_class ["container"]] [ 47 | div ~a:[a_class ["navbar-header"]] [ 48 | button ~a:[a_class ["navbar-toggle collapsed"]; 49 | a_user_data "toggle" "collapse"; 50 | a_user_data "target" ".navbar-collapse" 51 | ] [ 52 | span ~a:[a_class ["icon-bar"]][]; 53 | span ~a:[a_class ["icon-bar"]][]; 54 | span ~a:[a_class ["icon-bar"]][] 55 | ]; 56 | a ~a:[a_class ["navbar-brand"]; a_href ("/" ^ index_page cache)][pcdata (blog_name cache)] 57 | ]; 58 | div ~a:[a_class ["collapse navbar-collapse collapse"]] [ 59 | ul ~a:[a_class ["nav navbar-nav navbar-right"]] links 60 | ] 61 | ] 62 | ]; 63 | main [ 64 | div ~a:[a_class ["flex-container"]] content 65 | ] 66 | ] 67 | ) 68 | in 69 | let buf = Buffer.create 500 in 70 | let fmt = Format.formatter_of_buffer buf in 71 | pp () fmt page ; 72 | Buffer.contents buf 73 | 74 | let listing entries = 75 | [div ~a:[a_class ["flex-container"]] [ 76 | div ~a:[a_class ["list-group listing"]] entries 77 | ] 78 | ] 79 | 80 | let error msg = 81 | [div ~a:[a_class ["alert alert-danger"]] [pcdata msg]] 82 | -------------------------------------------------------------------------------- /canopy_utils.ml: -------------------------------------------------------------------------------- 1 | let assoc_opt k l = 2 | match List.assoc k l with 3 | | v -> Some v 4 | | exception Not_found -> None 5 | 6 | let map_opt fn default = function 7 | | None -> default 8 | | Some v -> fn v 9 | 10 | let list_reduce_opt l = 11 | let rec aux acc = function 12 | | [] -> acc 13 | | (Some x)::xs -> aux (x::acc) xs 14 | | None::xs -> aux acc xs 15 | in 16 | aux [] l 17 | 18 | let default_opt default = function 19 | | None -> default 20 | | Some v -> v 21 | 22 | let resize len l = 23 | List.fold_left 24 | (fun (len, acc) x -> 25 | if len > 0 26 | then (len - 1, x :: acc) 27 | else (0, acc)) 28 | (len, []) l 29 | |> fun (_, l) -> List.rev l 30 | 31 | let (++) = List.append 32 | 33 | let ptime_to_pretty_date t = 34 | Ptime.to_date t |> fun (y, m, d) -> 35 | Printf.sprintf "%04d-%02d-%02d" y m d 36 | 37 | module KeyMap = struct 38 | module KeyOrd = struct 39 | type t = string list 40 | let compare a b = 41 | match compare (List.length a) (List.length b) with 42 | | 0 -> ( 43 | try List.find ((<>) 0) (List.map2 String.compare a b) 44 | with Not_found -> 0 45 | ) 46 | | x -> x 47 | end 48 | 49 | module M = Map.Make(KeyOrd) 50 | include M 51 | 52 | let fold_articles f = 53 | M.fold (fun k v acc -> match v with 54 | | `Article a -> f k a acc 55 | | _ -> acc) 56 | 57 | let find_opt m k = 58 | try Some (M.find k m) with 59 | | Not_found -> None 60 | 61 | let find_article_opt m k = 62 | match find_opt m k with 63 | | Some (`Article a) -> Some a 64 | | _ -> None 65 | end 66 | 67 | let add_etag_header time headers = 68 | Cohttp.Header.add headers "Etag" (Ptime.to_rfc3339 time) 69 | 70 | let html_headers headers time = 71 | Cohttp.Header.add headers "Content-Type" "text/html; charset=UTF-8" 72 | |> add_etag_header time 73 | 74 | let atom_headers headers time = 75 | Cohttp.Header.add headers "Content-Type" "application/atom+xml; charset=UTF-8" 76 | |> add_etag_header time 77 | 78 | let static_headers headers uri time = 79 | Cohttp.Header.add headers "Content-Type" (Magic_mime.lookup uri) 80 | |> add_etag_header time 81 | -------------------------------------------------------------------------------- /config.ml: -------------------------------------------------------------------------------- 1 | open Mirage 2 | 3 | 4 | (* boilerplate from https://github.com/mirage/ocaml-git.git unikernel/config.ml 5 | (commit #2220ba7fe749d228a52e52f25f3761575269a98a) *) 6 | type mimic = Mimic 7 | 8 | let mimic = typ Mimic 9 | 10 | let mimic_count = 11 | let v = ref (-1) in 12 | fun () -> incr v ; !v 13 | 14 | let mimic_conf () = 15 | let packages = [ package "mimic" ] in 16 | impl @@ object 17 | inherit base_configurable 18 | method ty = mimic @-> mimic @-> mimic 19 | method module_name = "Mimic.Merge" 20 | method! packages = Key.pure packages 21 | method name = Fmt.str "merge_ctx%02d" (mimic_count ()) 22 | method! connect _ _modname = 23 | function 24 | | [ a; b ] -> Fmt.str "Lwt.return (Mimic.merge %s %s)" a b 25 | | [ x ] -> Fmt.str "%s.ctx" x 26 | | _ -> Fmt.str "Lwt.return Mimic.empty" 27 | end 28 | 29 | let merge ctx0 ctx1 = mimic_conf () $ ctx0 $ ctx1 30 | 31 | let mimic_tcp_conf = 32 | let packages = [ package "git-mirage" ~sublibs:[ "tcp" ] ] in 33 | impl @@ object 34 | inherit base_configurable 35 | method ty = stackv4 @-> mimic 36 | method module_name = "Git_mirage_tcp.Make" 37 | method! packages = Key.pure packages 38 | method name = "tcp_ctx" 39 | method! connect _ modname = function 40 | | [ stack ] -> 41 | Fmt.str {ocaml|Lwt.return (%s.with_stack %s %s.ctx)|ocaml} 42 | modname stack modname 43 | | _ -> assert false 44 | end 45 | 46 | let mimic_tcp_impl stackv4 = mimic_tcp_conf $ stackv4 47 | 48 | let mimic_ssh_conf ~kind ~seed ~auth = 49 | let seed = Key.abstract seed in 50 | let auth = Key.abstract auth in 51 | let packages = [ package "git-mirage" ~sublibs:[ "ssh" ] ] in 52 | impl @@ object 53 | inherit base_configurable 54 | method ty = stackv4 @-> mimic @-> mclock @-> mimic 55 | method! keys = [ seed; auth; ] 56 | method module_name = "Git_mirage_ssh.Make" 57 | method! packages = Key.pure packages 58 | method name = match kind with 59 | | `Rsa -> "ssh_rsa_ctx" 60 | | `Ed25519 -> "ssh_ed25519_ctx" 61 | method! connect _ modname = 62 | function 63 | | [ _; tcp_ctx; _ ] -> 64 | let with_key = 65 | match kind with 66 | | `Rsa -> "with_rsa_key" 67 | | `Ed25519 -> "with_ed25519_key" 68 | in 69 | Fmt.str 70 | {ocaml|let ssh_ctx00 = Mimic.merge %s %s.ctx in 71 | let ssh_ctx01 = Option.fold ~none:ssh_ctx00 ~some:(fun v -> %s.%s v ssh_ctx00) %a in 72 | let ssh_ctx02 = Option.fold ~none:ssh_ctx01 ~some:(fun v -> %s.with_authenticator v ssh_ctx01) %a in 73 | Lwt.return ssh_ctx02|ocaml} 74 | tcp_ctx modname 75 | modname with_key Key.serialize_call seed 76 | modname Key.serialize_call auth 77 | | _ -> assert false 78 | end 79 | 80 | let mimic_ssh_impl ~kind ~seed ~auth stackv4 mimic_git mclock = 81 | mimic_ssh_conf ~kind ~seed ~auth 82 | $ stackv4 83 | $ mimic_git 84 | $ mclock 85 | 86 | (* TODO(dinosaure): user-defined nameserver and port. *) 87 | 88 | let mimic_dns_conf = 89 | let packages = [ package "git-mirage" ~sublibs:[ "dns" ] ] in 90 | impl @@ object 91 | inherit base_configurable 92 | method ty = random @-> mclock @-> time @-> stackv4 @-> mimic @-> mimic 93 | method module_name = "Git_mirage_dns.Make" 94 | method! packages = Key.pure packages 95 | method name = "dns_ctx" 96 | method! connect _ modname = 97 | function 98 | | [ _; _; _; stack; tcp_ctx ] -> 99 | Fmt.str 100 | {ocaml|let dns_ctx00 = Mimic.merge %s %s.ctx in 101 | let dns_ctx01 = %s.with_dns %s dns_ctx00 in 102 | Lwt.return dns_ctx01|ocaml} 103 | tcp_ctx modname 104 | modname stack 105 | | _ -> assert false 106 | end 107 | 108 | let mimic_dns_impl random mclock time stackv4 mimic_tcp = 109 | mimic_dns_conf $ random $ mclock $ time $ stackv4 $ mimic_tcp 110 | 111 | (* --- end of copied code --- *) 112 | 113 | (* Command-line options *) 114 | 115 | let push_hook_k = 116 | let doc = Key.Arg.info ~doc:"GitHub push hook." ["hook"] in 117 | Key.(create "push_hook" Arg.(opt string "push" doc)) 118 | 119 | let remote_k = 120 | let doc = Key.Arg.info ~doc:"Remote repository to fetch content.\ 121 | \ Use suffix #foo to specify a branch 'foo':\ 122 | \ https://github.com/user/blog.git#content" 123 | ["r"; "remote"] in 124 | Key.(create "remote" Arg.(opt string "https://github.com/Engil/__blog.git" doc)) 125 | 126 | let port_k = 127 | let doc = Key.Arg.info ~doc:"Socket port." ["p"; "port"] in 128 | Key.(create "port" Arg.(opt int 8080 doc)) 129 | 130 | let tls_port_k = 131 | let doc = Key.Arg.info ~doc:"Enable TLS (using keys in `tls/`) on given port." ["tls"] in 132 | Key.(create "tls_port" Arg.(opt (some int) None doc)) 133 | 134 | let ssh_seed = 135 | let doc = Key.Arg.info ~doc:"Seed for ssh private key." ["ssh-seed"] in 136 | Key.(create "ssh_seed" Arg.(opt (some string) None doc)) 137 | 138 | let ssh_authenticator = 139 | let doc = Key.Arg.info ~doc:"SSH host key authenticator." ["ssh-authenticator"] in 140 | Key.(create "ssh_authenticator" Arg.(opt (some string) None doc)) 141 | 142 | (* Dependencies *) 143 | 144 | let packages = [ 145 | package "omd" ; 146 | package ~min:"4.0.0" "tyxml"; 147 | package "ptime"; 148 | package ~min:"0.5" "decompress"; 149 | package ~min:"2.0.0" "irmin"; 150 | package ~min:"2.0.0" "irmin-mirage"; 151 | package ~min:"2.0.0" "irmin-mirage-git"; 152 | package ~min:"3.3.1" "git-mirage"; 153 | package "git-cohttp-mirage"; 154 | package "cohttp-mirage"; 155 | package "mirage-flow"; 156 | package "tls-mirage"; 157 | package "re"; 158 | package ~min:"0.21.0" "cohttp"; 159 | package ~min:"1.5" "syndic"; 160 | package "magic-mime"; 161 | package "uuidm"; 162 | package "logs"; 163 | ] 164 | 165 | 166 | (* Network stack *) 167 | let stack = generic_stackv4 default_network 168 | 169 | let mimic_impl ~kind ~seed ~authenticator stackv4 random mclock time = 170 | let mtcp = mimic_tcp_impl stackv4 in 171 | let mdns = mimic_dns_impl random mclock time stackv4 mtcp in 172 | let mssh = mimic_ssh_impl ~kind ~seed ~auth:authenticator stackv4 mtcp mclock in 173 | merge mssh mdns 174 | 175 | let mimic_impl = 176 | mimic_impl ~kind:`Rsa ~seed:ssh_seed ~authenticator:ssh_authenticator stack 177 | default_random default_monotonic_clock default_time 178 | 179 | let () = 180 | let keys = Key.([ 181 | abstract push_hook_k; 182 | abstract remote_k; 183 | abstract port_k; 184 | abstract tls_port_k; 185 | ]) 186 | in 187 | register "canopy" [ 188 | foreign 189 | ~keys 190 | ~packages 191 | "Canopy_main.Main" 192 | (stackv4 @-> mimic @-> resolver @-> conduit @-> pclock @-> kv_ro @-> job) 193 | $ stack 194 | $ mimic_impl 195 | $ resolver_dns stack 196 | $ conduit_direct ~tls:true stack 197 | $ default_posix_clock 198 | $ crunch "tls" 199 | ] 200 | -------------------------------------------------------------------------------- /package.json: -------------------------------------------------------------------------------- 1 | { 2 | "name": "canopy", 3 | "version": "0.0.1", 4 | "description": "A git-blogging unikernel", 5 | "main": "canopy.js", 6 | "directories": { 7 | "test": "tests" 8 | }, 9 | "dependencies": { 10 | "bootstrap": "^3.3.6", 11 | "highlight.js": "^9.3.0", 12 | "jquery": "^2.2.3", 13 | "less": "^2.6.1" 14 | }, 15 | "devDependencies": {}, 16 | "scripts": { 17 | "test": "echo \"Error: no test specified\" && exit 1" 18 | }, 19 | "repository": { 20 | "type": "git", 21 | "url": "git+https://github.com/Engil/Canopy.git" 22 | }, 23 | "keywords": [ 24 | "ocaml", 25 | "mirage", 26 | "canopy", 27 | "blog", 28 | "static" 29 | ], 30 | "author": "Enguerrand Decorne", 31 | "license": "MIT", 32 | "bugs": { 33 | "url": "https://github.com/Engil/Canopy/issues" 34 | }, 35 | "homepage": "https://github.com/Engil/Canopy#readme" 36 | } 37 | -------------------------------------------------------------------------------- /populate.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | TARGET=$1 4 | 5 | if [ -x `which npm` ]; then 6 | if [ -d $1 ]; then 7 | mkdir -p $1/static/css $1/static/js 8 | npm install 9 | browserify assets/js/main.js -o $1/static/js/canopy.js 10 | lessc assets/less/style.less $1/static/css/style.css --source-map-map-inline --strict-imports 11 | cp node_modules/bootstrap/dist/css/bootstrap.min.css $1/static/css/bootstrap.min.css 12 | cp node_modules/highlight.js/styles/grayscale.css $1/static/css/highlight.css 13 | echo "now go to $1 and git add static && git commit -m . && git push" 14 | else 15 | echo "please run as 'populate.sh data_repository'" 16 | fi 17 | else 18 | echo "npm not found, please unpack assets/assets_generated.tar.gz to your data repository" 19 | fi 20 | -------------------------------------------------------------------------------- /tls/.gitignore: -------------------------------------------------------------------------------- 1 | * 2 | --------------------------------------------------------------------------------