further work on dns-web and unikernel

README.md

@@ -20,7 +20,7 @@ Future features
 - Notification system (for cyber threats / anomalities)
 - Git interface for zone editing (needs a git server)
 - Social login
-- eMail verification
+- email verification
 
 # Design
 
@@ -29,7 +29,7 @@ A unikernel using Dream and webauthn. It relies on a git remote repository for p
 The available services are HTTP/HTTPS.
 
 The data, apart from the zone files, are user accounts and shared secrets for dynamic updates. This data is kept in text files.
-Each user has a name, eMail address, authentication data, and a set of domains.
+Each user has a name, email address, authentication data, and a set of domains.
 The authentication data should be a list of webauthn tokens and optionally a passphrase.
 
 If privileged access is necessary, we can manually shutdown the service and push to the git repository directly.
@@ -38,7 +38,7 @@ If privileged access is necessary, we can manually shutdown the service and push
 
 ## Enroll a new account
 
-Basically the code from the webauthn demo. The eMail address must be unique across users.
+Basically the code from the webauthn demo. The email address must be unique across users.
 
 ## Register a second authentication mechanism
 
@@ -48,7 +48,7 @@ There should be no more than 5 authentication mechanisms.
 
 ## Pass privileges to another user for that domain
 
-Requires a logged in user with access to that domain. Specifies an eMail address of another registered user to provide them access.
+Requires a logged in user with access to that domain. Specifies an email address of another registered user to provide them access.
 
 ## Delete an account
 
@@ -83,3 +83,36 @@ Similar to let's encrypt: user requests a domain, and the system asks the user t
 ## Register ssh public key for dynamically updating an address record
 
 A ssh login with any user from a remote machine should trigger an update.
+
+## Change email address of an user account
+
+TBD
+
+# Data storage
+
+This is meant to work well with [dns-primary-git](https://github.com/roburio/dns-primary-git) unikernel:
+- zone data is kept flat at the root in one file per domain named after the domain
+- secret keys are at the root in a file with the "._keys" suffix
+
+The user data is kept in the "users/" subdirectory, one file per user named after the email address (currently allowed characters
+
+# Synchronisation, source of truth
+
+The git repository is the single source of truth. Keeping data synchronized is crucial for the operation. Both dns-primary-git and dns-web are using the same git repository for storage of data:
+- the "users" subdirectory is only read and written by dns-web
+- zone data is read and written by both dns-primary-git and dns-web
+- key data is read by dns-primary-git and read and written by dns-web
+- if a manual git push is done, both unikernels need to be notified to pull the current HEAD: dns-web via post-commit hook, dns-primary-git via DNS notify
+
+Notification from dns-web to dns-primary-git: this is trivially achieved by sending a DNS notify with a respective key. Likely needs to be done even when only "users" was updated (at the moment, should be improved to handle merges appropriately). The key can be read from the main _keys file. Any zone, even the root one, can be used for this notify.
+
+Notifications from dns-primary-git to dns-web: this cannot be achieved directly since dns-primary-git does not know of the existance of dns-web. So the git repository should have a post-commit webhook installed that requests dns-web to trigger a repo update (but not send a notify to dns-primary-git).
+
+Now, the scenario that a user changes a zone and between the GET and the POST there was some (automated change): the POST should be rejected at first (and later an appropriate merge could be done).
+
+What about the git repo was updated and the dns-primary-git receives a nsupdate? Certainly there's a merge conflict as well, which should be handled (same strategy as above).
+
+TODO:
+- For consistency and observation, the commit ID of the last pull (or push) should be exposed via a network request (dns-web: HTTP request, dns-primary-git: some DNS packet)
+- For usability, should DNS update packets sent to dns-web be forwarded to dns-primary-git? Otherwise the endpoints for the web service and the DNS update are different (and may be confused).
+- Should users be stored in a separate branch or a separate repository?

lib/dns_web.ml

@@ -5,7 +5,12 @@ module SM = Map.Make(String)
 
 let ( let* ) = Result.bind
 
+let src = Logs.Src.create "dns-web" ~doc:"dns web"
+module Log = (val Logs.src_log src : Logs.LOG)
+
 module User = struct
+  let src = Logs.Src.create "dns-web.user" ~doc:"dns web user module"
+  module Log = (val Logs.src_log src : Logs.LOG)
 
   type scrypt_password =
     { data : string ; salt : string ; n : int ; r : int ; p : int } [@@deriving yojson]
@@ -29,9 +34,10 @@ module User = struct
     Result.map_error (function `Msg m -> m)
       (Base64.decode ~pad:false ~alphabet:Base64.uri_safe_alphabet x)
 
-  let p256_to_yojson k =
-    `String
-      (b64_enc (Cstruct.to_string (Mirage_crypto_ec.P256.Dsa.pub_to_cstruct k)))
+  let p256_pub_to_b64 k =
+    b64_enc (Cstruct.to_string (Mirage_crypto_ec.P256.Dsa.pub_to_cstruct k))
+
+  let p256_to_yojson k = `String (p256_pub_to_b64 k)
 
   let p256_of_yojson = function
     | `String data ->
@@ -68,6 +74,8 @@ module User = struct
                   [@to_yojson x509_to_yojson][@of_yojson x509_of_yojson];
   } [@@deriving yojson]
 
+  let webauthn_id { key ; _ } = p256_pub_to_b64 key
+
   let version = 1
 
   let hosts_to_yojson host_set =
@@ -100,7 +108,7 @@ module User = struct
               [@to_yojson hosts_to_yojson] [@of_yojson hosts_of_yojson] ;
   } [@@deriving yojson]
 
-  let create email scrypt_password webauthn domains =
+  let valid_email email =
     let* () =
       if
         String.for_all (function
@@ -110,20 +118,36 @@ module User = struct
       then
         Ok ()
       else
-        Error (`Msg "eMail with invalid characters")
+        Error (`Msg "email contains invalid characters ([a..z][A..Z][0..9]@.+)")
     in
-    Ok { version ; email ; scrypt_password ; webauthn ; domains }
+    let* () =
+      try let _ = String.index email '@' in Ok ()
+      with Not_found -> Error (`Msg "email does not include a @ character")
+    in
+    let* () =
+      let el = String.length email in
+      if el = 0 then
+        Error (`Msg "email has no characters")
+      else if el > 60 then
+        Error (`Msg "email has too many characters (maximum allowed are 60)")
+      else
+        Ok ()
+    in
+    Ok ()
 
-  let check user =
-    match user.scrypt_password, user.webauthn with
-    | None, [] -> false
-    | _ -> true
+  let valid_auth scrypt_password webauthn =
+    match scrypt_password, webauthn with
+    | None, [] -> Error (`Msg "user lacks authentication mechanism: either a password or a webauthn")
+    | _ -> Ok ()
+
+  let create email scrypt_password webauthn domains =
+    let* () = valid_email email in
+    let* () = valid_auth scrypt_password webauthn in
+    Ok { version ; email ; scrypt_password ; webauthn ; domains }
 
   let register users user =
     if SM.mem user.email users then
       Error (`Msg "user with email address already exists")
-    else if not (check user) then
-      Error (`Msg "user lacks authentication mechanism")
     else
       Ok (SM.add user.email user users)
 
@@ -139,22 +163,24 @@ module User = struct
           if nobody_access then domain :: acc else acc)
         user.domains []
     with
-    | [] -> Ok (SM.remove user.email users)
+    | [] ->
+      Log.info (fun m -> m "user %S removed" user.email);
+      Ok (SM.remove user.email users)
     | domains ->
       Error (`Msg (Fmt.str "Domains that would be left without a user: %a"
                      Fmt.(list ~sep:(any ", ") Domain_name.pp) domains))
 
   let change_password rng users user = function
     | None ->
+      let* () = valid_auth None user.webauthn in
       let user' = { user with scrypt_password = None } in
-      if check user' then
-        Ok (SM.add user.email user' users)
-      else
-        Error (`Msg "no authentication mechanisms left")
+      Log.info (fun m -> m "user %S removed their password" user.email);
+      Ok (SM.add user.email user' users)
     | Some password ->
       let salt = rng 16 in
       let scrypt_password = scrypt_pw ~salt ~password in
       let user' = { user with scrypt_password = Some scrypt_password } in
+      Log.info (fun m -> m "user %S changed their password" user.email);
       Ok (SM.add user.email user' users)
 
   let add_webauthn users user w =
@@ -163,14 +189,15 @@ module User = struct
       List.fold_left (fun x { key ; credential_id ; _ } ->
           let* () = x in
           if Cstruct.equal (Mirage_crypto_ec.P256.Dsa.pub_to_cstruct key) key_cs then
-            Error (`Msg "key already registered")
+            Error (`Msg (Fmt.str "key %s already registered" (p256_pub_to_b64 key)))
           else if String.equal w.credential_id credential_id then
-            Error (`Msg "credential ID already registered")
+            Error (`Msg (Fmt.str "credential ID %S already registered" credential_id))
           else
             Ok ())
         (Ok ()) user.webauthn
     in
     let user' = { user with webauthn = w :: user.webauthn } in
+    Log.info (fun m -> m "user %S added webauthn %s" user.email (webauthn_id w));
     Ok (SM.add user.email user' users)
 
   let remove_webauthn users user k =
@@ -183,11 +210,10 @@ module User = struct
     if List.length webauthn = List.length user.webauthn then
       Error (`Msg "same webauthn list, nothing changed")
     else
+      let* () = valid_auth user.scrypt_password webauthn in
       let user' = { user with webauthn } in
-      if not (check user') then
-        Error (`Msg "no authentication mechanisms left")
-      else
-        Ok (SM.add user.email user' users)
+      Log.info (fun m -> m "user %S removed webauthn %s" user.email (p256_pub_to_b64 k));
+      Ok (SM.add user.email user' users)
 
   let dump users =
     SM.fold (fun key u acc ->
@@ -197,25 +223,32 @@ module User = struct
 
   let restore data =
     SM.fold (fun key data acc ->
-        let* acc = acc in
-        let* json =
-          try Ok (Yojson.Safe.from_string data)
-          with Yojson.Json_error msg ->
-            Error (`Msg (Fmt.str "invalid json for %S: %s (data: %S)"
-                           key msg data))
-        in
-        let* user =
-          Result.map_error (fun msg -> `Msg msg) (of_yojson json)
-        in
-        let* () =
-          if String.equal key user.email then
-            Ok ()
-          else
-            Error (`Msg (Fmt.str "email %S and key %S do not match"
-                           user.email key))
-        in
-        Ok (SM.add key user acc))
-      data (Ok SM.empty)
+        match
+          let* json =
+            try Ok (Yojson.Safe.from_string data)
+            with Yojson.Json_error msg ->
+              Error (`Msg (Fmt.str "invalid json for %S: %s (data: %S)"
+                             key msg data))
+          in
+          let* user =
+            Result.map_error (fun msg -> `Msg msg) (of_yojson json)
+          in
+          let* () =
+            if String.equal key user.email then
+              Ok ()
+            else
+              Error (`Msg (Fmt.str "email %S and key %S do not match"
+                             user.email key))
+          in
+          let* () = valid_email user.email in
+          let* () = valid_auth user.scrypt_password user.webauthn in
+          Ok user
+        with
+        | Ok user -> SM.add user.email user acc
+        | Error `Msg msg ->
+          Log.warn (fun m -> m "failed to restore user %S: %s" key msg);
+          acc)
+      data SM.empty
 end
 
 type t = {
@@ -223,3 +256,18 @@ type t = {
   keys : Dns.Dnskey.t Domain_name.Map.t ;
   trie : Dns_trie.t ;
 }
+
+let create
+    (user_data : string SM.t)
+    (key_data : ([`raw] Domain_name.t * Dns.Dnskey.t) list)
+    trie =
+  let users = User.restore user_data
+  and keys =
+    List.fold_left (fun acc (name, key) ->
+        if Domain_name.Map.mem name acc then
+          Log.warn (fun m -> m "key map already contains %a, overwriting"
+                       Domain_name.pp name);
+        Domain_name.Map.add name key acc)
+      Domain_name.Map.empty key_data
+  in
+  { users ; keys ; trie }

mirage/config.ml

@@ -1,5 +1,191 @@
 open Mirage
 
+(* boilerplate from https://github.com/mirage/ocaml-git.git
+   unikernel/empty-commit/config.ml
+   commit #45d90b8792ab8f3866751f462619c7dd7860e5d5 *)
+type mimic = Mimic
+
+let mimic = typ Mimic
+
+let mimic_count =
+  let v = ref (-1) in
+  fun () -> incr v ; !v
+
+let mimic_conf () =
+  let packages = [ package "mimic" ] in
+  impl @@ object
+       inherit base_configurable
+       method ty = mimic @-> mimic @-> mimic
+       method module_name = "Mimic.Merge"
+       method! packages = Key.pure packages
+       method name = Fmt.str "merge_ctx%02d" (mimic_count ())
+       method! connect _ _modname =
+         function
+         | [ a; b ] -> Fmt.str "Lwt.return (Mimic.merge %s %s)" a b
+         | [ x ] -> Fmt.str "%s.ctx" x
+         | _ -> Fmt.str "Lwt.return Mimic.empty"
+     end
+
+let merge ctx0 ctx1 = mimic_conf () $ ctx0 $ ctx1
+
+(* TODO(dinosaure): [timeout] and [timer interval]. *)
+let mimic_happy_eyeballs =
+  let packages = [ package "git-mirage" ~sublibs:[ "happy-eyeballs" ] ] in
+  impl @@ object
+       inherit base_configurable
+       method ty = random @-> time @-> mclock @-> pclock @-> stackv4v6 @-> mimic
+       method module_name = "Git_mirage_happy_eyeballs.Make"
+       method! packages = Key.pure packages
+       method name = "git_mirage_happy_eyeballs"
+       method! connect _ modname = function
+         | [ _random; _time; _mclock; _pclock; stackv4v6; ] ->
+           Fmt.str {ocaml|%s.connect %s|ocaml} modname stackv4v6
+         | _ -> assert false
+     end
+
+let mimic_tcp =
+  let packages = [ package "git-mirage" ~sublibs:[ "tcp" ] ] in
+  impl @@ object
+       inherit base_configurable
+       method ty = tcpv4v6 @-> mimic @-> mimic
+       method module_name = "Git_mirage_tcp.Make"
+       method! packages = Key.pure packages
+       method name = "git_mirage_tcp"
+       method! connect _ modname = function
+         | [ _tcpv4v6; ctx ] ->
+           Fmt.str {ocaml|%s.connect %s|ocaml}
+             modname ctx
+         | _ -> assert false
+     end
+
+let mimic_ssh ?authenticator key =
+  let packages = [ package "git-mirage" ~sublibs:[ "ssh" ] ] in
+  impl @@ object
+       inherit base_configurable
+       method ty = mclock @-> tcpv4v6 @-> mimic @-> mimic
+       method! keys = match authenticator with
+         | Some authenticator -> [ Key.abstract key; Key.abstract authenticator ]
+         | None -> [ Key.abstract key ]
+       method module_name = "Git_mirage_ssh.Make"
+       method! packages = Key.pure packages
+       method name = "git_mirage_ssh"
+       method! connect _ modname = function
+         | [ _mclock; _tcpv4v6; ctx ] ->
+           ( match authenticator with
+           | None ->
+             Fmt.str {ocaml|%s.connect %s >>= %s.with_optionnal_key ~key:%a|ocaml}
+               modname ctx modname Key.serialize_call (Key.abstract key)
+           | Some authenticator ->
+             Fmt.str {ocaml|%s.connect %s >>= %s.with_optionnal_key ?authenticator:%a ~key:%a|ocaml}
+               modname ctx modname
+               Key.serialize_call (Key.abstract authenticator)
+               Key.serialize_call (Key.abstract key) )
+         | _ -> assert false
+     end
+
+let mimic_http ?tls_key_fingerprint ?tls_cert_fingerprint headers =
+  let packages = [ package "git-mirage" ~sublibs:[ "http" ] ] in
+  impl @@ object
+       inherit base_configurable
+       method ty = time @-> pclock @-> tcpv4v6 @-> mimic @-> mimic
+       method! keys = match tls_key_fingerprint, tls_cert_fingerprint with
+         | Some tls_key_fingerprint, None ->
+           let keys = match headers with Some headers -> [ Key.abstract headers ] | None -> [] in
+           [ Key.abstract tls_key_fingerprint ] @ keys
+         | None, Some tls_cert_fingerprint ->
+           let keys = match headers with Some headers -> [ Key.abstract headers ] | None -> [] in
+           [ Key.abstract tls_cert_fingerprint ] @ keys
+         | Some tls_key_fingerprint, Some tls_cert_fingerprint ->
+           let keys = match headers with Some headers -> [ Key.abstract headers ] | None -> [] in
+           [ Key.abstract tls_key_fingerprint; Key.abstract tls_cert_fingerprint ] @ keys
+         | None, None -> ( match headers with Some headers -> [ Key.abstract headers ] | None -> [] )
+       method module_name = "Git_mirage_http.Make"
+       method! packages = Key.pure packages
+       method name = "git_mirage_http"
+       method! connect _ modname = function
+         | [ _time; _pclock; _tcpv4v6; ctx; ] ->
+           let serialize_headers ppf = function
+             | None -> ()
+             | Some headers -> Fmt.pf ppf "?headers:%a" Key.serialize_call (Key.abstract headers) in
+           ( match tls_key_fingerprint, tls_cert_fingerprint with
+           | Some tls_key_fingerprint, None ->
+             Fmt.str {ocaml|%s.connect %s >>= %s.with_optional_tls_config_and_headers ?tls_key_fingerprint:%a%a|ocaml}
+               modname ctx modname
+               Key.serialize_call (Key.abstract tls_key_fingerprint)
+               Fmt.((const string " ") ++ serialize_headers) headers
+           | None, Some tls_cert_fingerprint ->
+             Fmt.str {ocaml|%s.connect %s >>= %s.with_optional_tls_config_and_headers ?tls_cert_fingerprint:%a%a|ocaml}
+               modname ctx modname
+               Key.serialize_call (Key.abstract tls_cert_fingerprint)
+               Fmt.((const string " ") ++ serialize_headers) headers
+           | None, None ->
+             Fmt.str {ocaml|%s.connect %s >>= %s.with_optional_tls_config_and_headers%a|ocaml}
+               modname ctx modname
+               Fmt.((const string " ") ++ serialize_headers) headers
+           | Some tls_key_fingerprint, Some tls_cert_fingerprint ->
+             Fmt.str {ocaml|%s.connect %s >>= %s.with_optional_tls_config_and_headers
+                              ?tls_key_fingerprint:%a ?tls_cert_fingerprint:%a%a|ocaml}
+               modname ctx modname
+               Key.serialize_call (Key.abstract tls_key_fingerprint)
+               Key.serialize_call (Key.abstract tls_cert_fingerprint)
+               Fmt.((const string " ") ++ serialize_headers) headers )
+         | _ -> assert false
+     end
+
+let tcpv4v6_of_stackv4v6 =
+  impl @@ object
+       inherit base_configurable
+       method ty = stackv4v6 @-> tcpv4v6
+       method module_name = "Git_mirage_happy_eyeballs.TCPV4V6"
+       method! packages = Key.pure [ package "git-mirage" ~sublibs:[ "happy-eyeballs" ] ]
+       method name = "tcpv4v6"
+       method! connect _ modname = function
+         | [ stackv4v6 ] -> Fmt.str {ocaml|%s.connect %s|ocaml} modname stackv4v6
+         | _ -> assert false
+     end
+(* --- end of copied code --- *)
+
+let remote_k =
+  let doc = Key.Arg.info ~doc:"Remote git repository. Use '#' as a separator for a branch name." ["r"; "remote"] in
+  Key.(create "remote" Arg.(opt string "https://github.com/roburio/udns.git" doc))
+
+let ssh_key =
+  let doc = Key.Arg.info ~doc:"Private ssh key (rsa:<seed> or ed25519:<b64-key>)." ["ssh-key"] in
+  Key.(create "ssh-key" Arg.(opt (some string) None doc))
+
+let authenticator =
+  let doc = Key.Arg.info ~doc:"Authenticator." ["authenticator"] in
+  Key.(create "authenticator" Arg.(opt (some string) None doc))
+
+let tls_key_fingerprint =
+  let doc = Key.Arg.info ~doc:"The fingerprint of the TLS key." [ "tls-key-fingerprint" ] in
+  Key.(create "tls_key_fingerprint" Arg.(opt (some string) None doc))
+
+let tls_cert_fingerprint =
+  let doc = Key.Arg.info ~doc:"The fingerprint of the TLS certificate." [ "tls-cert-fingerprint" ] in
+  Key.(create "tls_cert_fingerprint" Arg.(opt (some string) None doc))
+
+let name =
+  let doc = Key.Arg.info ~doc:"Name of the unikernel" ["name"] in
+  Key.(create "name" Arg.(opt string "dns.robur.coop" doc))
+
+let mimic_impl random stackv4v6 mclock pclock time =
+  let tcpv4v6 = tcpv4v6_of_stackv4v6 $ stackv4v6 in
+  let mhappy_eyeballs = mimic_happy_eyeballs $ random $ time $ mclock $ pclock $ stackv4v6 in
+  let mtcp  = mimic_tcp
+    $ tcpv4v6 $ mhappy_eyeballs in
+  let mssh  = mimic_ssh ~authenticator ssh_key
+    $ mclock $ tcpv4v6 $ mhappy_eyeballs in
+  let mhttp = mimic_http ~tls_key_fingerprint ~tls_cert_fingerprint None
+    $ time $ pclock $ tcpv4v6 $ mhappy_eyeballs in
+  merge mhttp (merge mtcp mssh)
+
+let net = generic_stackv4v6 default_network
+
+let mimic_impl =
+  mimic_impl default_random net
+    default_monotonic_clock default_posix_clock default_time
+
 let main =
   let dream_pin = "git+https://github.com/roburio/dream.git#working" in
   let packages = [
@@ -9,10 +195,19 @@ let main =
     package ~pin:dream_pin "dream-httpaf" ;
     package "dns-web" ;
     package "logs" ;
+    package ~min:"2.10.0" ~max:"3.0.0" "irmin-mirage";
+    package ~min:"2.10.0" "irmin-mirage-git";
+    package ~min:"3.7.0" ~max:"3.7.1" "git-mirage";
+    package ~min:"3.7.0" "git-paf";
+    package ~min:"0.0.8" ~max:"0.0.9" ~sublibs:["mirage"] "paf";
+    package ~min:"6.2.2" ~sublibs:["zone"] "dns-server";
   ] in
-  foreign ~packages "Unikernel.Main"
-    (pclock @-> time @-> stackv4v6 @-> job)
+  foreign
+    ~keys:[ Key.abstract remote_k ; Key.abstract name ]
+    ~packages
+    "Unikernel.Main"
+    (pclock @-> time @-> stackv4v6 @-> mimic @-> job)
 
 let () =
   register "dns-web"
-    [ main $ default_posix_clock $ default_time $ generic_stackv4v6 default_network ]
+    [ main $ default_posix_clock $ default_time $ net $ mimic_impl ]

mirage/unikernel.ml

@@ -1,6 +1,138 @@
 open Lwt.Infix
 
-module Main (P : Mirage_clock.PCLOCK) (T : Mirage_time.S) (S : Tcpip.Stack.V4V6) = struct
+let decompose_git_url () =
+  match String.split_on_char '#' (Key_gen.remote ()) with
+  | [ url ] -> url, None
+  | [ url ; branch ] -> url, Some branch
+  | _ ->
+    Logs.err (fun m -> m "expected at most a single # in remote");
+    exit 64
+
+module Main (P : Mirage_clock.PCLOCK) (T : Mirage_time.S) (S : Tcpip.Stack.V4V6) (_ : sig end) = struct
+
+  module Store = struct
+    module Store = Irmin_mirage_git.Mem.KV(Irmin.Contents.String)
+    module Sync = Irmin.Sync(Store)
+
+    let users_dir = "users"
+
+    let connect ctx =
+      let config = Irmin_mem.config () in
+      let remote, branch = decompose_git_url () in
+      Store.Repo.v config >>= fun r ->
+      (match branch with
+       | None -> Store.master r
+       | Some branch -> Store.of_branch r branch) >|= fun repo ->
+      repo, Store.remote ~ctx remote
+
+    let pull repo upstream =
+      Logs.debug (fun m -> m "pulling from remote!");
+      Sync.pull ~depth:1 repo upstream `Set >|= function
+      | Ok `Empty -> Error (`Msg "pull_store: pulled empty repository")
+      | Ok (`Head _ as s) ->
+        Logs.debug (fun m -> m "pull_store: ok, pulled %a!" Sync.pp_status s);
+        Ok ()
+      | Error (`Msg e) -> Error (`Msg ("pull_store: error " ^ e))
+      | Error (`Conflict msg) -> Error (`Msg ("pull_store: conflict " ^ msg))
+
+    let load_zones store =
+      Store.list store [] >>= fun files ->
+      Lwt_list.fold_left_s (fun acc (name, kind) ->
+          match Store.Tree.destruct kind with
+          | `Node _ ->
+            Logs.info (fun m -> m "load_zones ignoring %S (expected content)"
+                          name);
+            Lwt.return acc
+          | `Contents _ ->
+            Store.get store [name] >|= fun data ->
+            (name, data) :: acc)
+        [] files >|= fun zones ->
+      Ok zones
+
+    let load_users store =
+      Store.list store [users_dir] >>= fun files ->
+      Lwt_list.fold_left_s (fun acc (name, kind) ->
+          match Store.Tree.destruct kind with
+          | `Node _ ->
+            Logs.info (fun m -> m "load_users ignoring %S (expected content)"
+                          name);
+            Lwt.return acc
+          | `Contents _ ->
+            Store.get store [users_dir ; name] >|= fun data ->
+            Dns_web.SM.add name data acc)
+        Dns_web.SM.empty files >|= fun users ->
+      Ok users
+
+    let check_bindings old_trie bindings =
+      let zones, trie, keys = Dns_zone.decode_zones_keys bindings in
+      (match old_trie with
+       | None -> ()
+       | Some old_trie ->
+         Domain_name.Set.iter (fun zone ->
+             match
+               Dns_trie.entries zone old_trie,
+               Dns_trie.entries zone trie
+             with
+             | Ok (old_soa, old_entries), Ok (soa, entries) ->
+               (* good if old_soa = soa && old_entries ++ old_soa == zone_rrs
+                  or soa is newer than old_soa *)
+               (* TODO error recovery could be to increment the SOA serial,
+                  followed by a push to git (the other errors above and below
+                  can't be fixed automatically - thus a git pull can always
+                  fail :/) *)
+               let equal =
+                 Dns.Name_rr_map.(equal
+                                    (add zone Dns.Rr_map.Soa soa entries)
+                                    (add zone Dns.Rr_map.Soa old_soa old_entries))
+               in
+               if not (Dns.Soa.newer ~old:old_soa soa) && not equal then
+                 Logs.warn (fun m -> m "SOA serial not incremented for %a"
+                               Domain_name.pp zone)
+             | Error _, Ok _ | Ok _, Error _ | Error _, Error _ -> ())
+           zones);
+      Ok (trie, keys)
+
+    (*
+    let store_zone key ip t store zone =
+      match Dns_server.text zone (Dns_server.Primary.data t) with
+      | Error (`Msg msg) ->
+        Logs.err (fun m -> m "error while converting zone %a: %s" Domain_name.pp zone msg) ;
+        Lwt.return_unit
+      | Ok data ->
+        let info () =
+          let date = Int64.of_float Ptime.Span.(to_float_s (v (P.now_d_ps ())))
+          and commit = Fmt.str "%a changed %a" Ipaddr.pp ip Domain_name.pp zone
+          and author = Fmt.str "%a via primary git" Fmt.(option ~none:(any "no key") Domain_name.pp) key
+          in
+          Irmin.Info.v ~date ~author commit
+        in
+        Store.set ~info store [Domain_name.to_string zone] data >|= function
+        | Ok () -> ()
+        | Error _ -> Logs.err (fun m -> m "error while writing to store")
+
+    let store_zones ~old key ip t store upstream =
+      (* TODO do a single commit (maybe) *)
+      let data = Dns_server.Primary.data t in
+      let zones =
+        Dns_trie.fold Dns.Rr_map.Soa data
+          (fun dname soa acc ->
+             match Dns_trie.lookup dname Dns.Rr_map.Soa old with
+             | Ok old when Dns.Soa.newer ~old soa -> dname :: acc
+             | Ok _ -> acc
+             | Error _ -> dname :: acc)
+          []
+      in
+      Lwt_list.iter_s (store_zone key ip t store) zones >>= fun () ->
+      (* TODO removal of a zone should lead to dropping this zone from git! *)
+      Logs.debug (fun m -> m "pushing to remote!");
+      Sync.push store upstream  >|= function
+      | Ok `Empty -> Logs.warn (fun m -> m "pushed empty zonefiles")
+      | Ok (`Head _ as s) -> Logs.info (fun m -> m "pushed zonefile commit %a" Sync.pp_status s)
+      | Error pe -> Logs.err (fun m -> m "push error %a" Sync.pp_push_error pe)
+*)
+
+  end
+
   module Dream = Dream__mirage.Mirage.Make (P)(T)(S)
 
   let static_base64_js _req =
@@ -19,6 +151,19 @@ module Main (P : Mirage_clock.PCLOCK) (T : Mirage_time.S) (S : Tcpip.Stack.V4V6)
     in
     Dream.logger @@ Dream.router routes
 
-  let start _ _ stack =
+  let fail_if_err = function
+    | Error (`Msg msg) ->
+      Logs.err (fun m -> m "error %s" msg);
+      Lwt.fail_with msg
+    | Ok a -> Lwt.return a
+
+  let start _ _ stack ctx =
+    Store.connect ctx >>= fun (store, upstream) ->
+    Store.pull store upstream >>= fail_if_err >>= fun () ->
+    Store.load_zones store >>= fail_if_err >>= fun bindings ->
+    Store.load_users store >>= fail_if_err >>= fun users ->
+    let _zones, trie, keys = Dns_zone.decode_zones_keys bindings in
+    let state = Dns_web.create users keys trie in
+    ignore(state);
     Dream.http ~port:80 (S.tcp stack) router
 end