seppo/lib/iweb.ml

(*
 *    _  _   ____                         _  
 *  _| || |_/ ___|  ___ _ __  _ __   ___ | | 
 * |_  ..  _\___ \ / _ \ '_ \| '_ \ / _ \| | 
 * |_      _|___) |  __/ |_) | |_) | (_) |_| 
 *   |_||_| |____/ \___| .__/| .__/ \___/(_) 
 *                     |_|   |_|             
 *
 * Personal Social Web.
 *
 * iweb.ml
 *
 * Copyright (C) The #Seppo contributors. All rights reserved.
 *
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program.  If not, see <http://www.gnu.org/licenses/>.
 *)

let ( >>= )  = Result.bind
let ( let* ) = Result.bind
let chain a b =
  let f a = Ok (a, b) in
  Result.bind a f
let seppo = Uri.make ~userinfo:"seppo" ~host:"seppo.social" ()

let to_channel ~xsl oc l =
  assert (xsl |> St.ends_with ~suffix:".xsl");
  let xsl = Some ("../themes/current/" ^ xsl)
  and readme = Some {|
The html you see here is for compatibility with https://sebsauvage.net/wiki/doku.php?id=php:shaarli

The main reason is backward compatibility for e.g. http://mro.name/ShaarliOS and
https://github.com/dimtion/Shaarlier
|} in
  Xml.to_chan ~xsl ~readme l oc

module MyCookie = struct
  let timeout tnow =
    30 * 60
    |> Ptime.Span.of_int_s
    |> Ptime.add_span tnow
    |> Option.get

  (* payload *)
  let encode (Auth.Uid uid, t) =
    Logr.debug (fun m -> m "%s.%s" "Iweb.MyCookie" "encode");
    let t = t |> Ptime.to_rfc3339 in
    Csexp.(List [ Atom uid; Atom t ] |> to_string)

  (* payload *)
  let decode c =
    let open Csexp in
    match c |> parse_string with
    | Ok List [ Atom uid; Atom t ] -> (
        match t |> Ptime.of_rfc3339 with
        | Error _ -> Error "expected rfc3339"
        | Ok (t,  _, _) -> Ok (Auth.Uid uid, t))
    | _ -> Error "expected cookie csexp"

  let name = "#session"

  let make (req : Cgi.Request.t) v =
    Cookie.to_string
      ~domain:req.host
      ~http_only:true
      ~path:req.script_name
      ~same_site:`Strict
      ~secure:false
      (name, v)

  let new_session
      ?(nonce12 = Cookie.random_nonce ())
      ?(tnow = Ptime_clock.now ())
      sec32
      req
      uid =
    assert (Cfg.CookieSecret.l32 = (sec32 |> Cstruct.length));
    assert (Cookie.l12 = (nonce12 |> Cstruct.length));
    (uid, tnow |> timeout)
    |> encode
    |> Cstruct.of_string
    |> Cookie.encrypt sec32 nonce12
    |> make req
    |> Http.H.set_cookie
end

(**
 * input type'textarea' => textarea
 * input type'submit'   => button
*)
let xhtmlform tit name (ips : Http.Form.input list) err (frm : Http.Form.t) : _ Xmlm.frag =
  let sep n = `Data ("\n" ^ String.make (2*n) ' ') in
  let att (n,v) = (("", n), v) in
  let ns_h = "http://www.w3.org/1999/xhtml" in
  let fofi _err init ((n,t,atts) : Http.Form.input) =
    let atts = atts |> List.fold_left (fun init a -> att a :: init) [] in
    let atts = match List.assoc_opt n frm with
      | None   -> atts
      | Some s -> att ("value", s |> String.concat "") :: atts in
    let txt v l = `Data (l |> List.assoc_opt v |> Option.value ~default:"") in
    (*
    init
    @ (err |> List.fold_left (fun init (f,e) ->
        if String.equal f n
        then `El (((ns_h,"div"), [att ("class","err"); att ("data-name",n)]), [`Data e]) :: init
        else init) [])
    @ *)
    sep 2 ::
    (match t with
     (* type is abused to mark textarea. Here we put it right again. *)
     | "textarea" ->  let atts' = atts |> List.remove_assoc ("","value") in
       `El (((ns_h,"textarea"), (("","name"),n) :: atts'), [txt ("","value") atts] )
     | "submit"   -> `El (((ns_h,"button"), (("","name"),n) :: (("","type"),t) :: atts), [txt ("","value") atts])
     | _          -> `El (((ns_h,"input"),  (("","name"),n) :: (("","type"),t) :: atts), []))
    :: init
  in
  `El (((ns_h,"html"),
        ((Xmlm.ns_xml,"base"),"../")
        :: ((Xmlm.ns_xmlns,"xmlns"), ns_h)
        :: []),
       sep 0
       :: `El (((ns_h,"head"),[]),
               sep 1  :: `El (((ns_h,"link"), [(("","rel"),"icon"); (("","type"),"image/jpg"); (("","href"),"../me-avatar.jpg")] ),[])
               :: sep 1 :: `El (((ns_h,"meta"), [(("","name"),"generator"); (("","content"),St.seppo_s)] ),[])
               :: sep 1 :: `El (((ns_h,"title"), []),[`Data tit])
               :: [])
       :: sep 0
       :: `El (((ns_h,"body"),[]),
               sep 1
               :: `El (((ns_h,"form"),
                        [(("","method"),"post");
                         (("","name"),name);
                         (("","id"),name)] ),
                       sep 2
                       :: `El (((ns_h,"ul"),[(("","id"),name ^ "_validation"); (("","class"),"validation")]),
                               (* at first display all errors with key "" *)
                               (err |> List.fold_left (fun init (f,e) -> match (f,e) with
                                    | "",e -> sep 2 :: `El (((ns_h,"li"),[]), [ `Data e ]) :: init
                                    | _    -> init) []) )
                       :: (ips |> List.rev |> List.fold_left (fofi err) []) )
               :: sep 0 :: [])
       :: sep 0 :: [])

module Ping = struct
  let get ~base _uuid (r : Cgi.Request.t) =
    let base : Uri.t = base ()
    and run_delay = 60 in
    match r.query_string |> Uri.query_of_encoded with
    | []
    | ["",[]]
    | [("nudge",_)] ->
      Main.Queue.ping_and_forget ~base ~run_delay
    | [("loop",_)] -> (
        match Ap.PubKeyPem.(private_of_pem pk_pem) with
        | Ok pk ->
          Main.Queue.(loop ~base ~run_delay (process_new_and_due ~pk ~base))
        | Error e ->
          Logr.warn (fun m -> m "%s.%s %s" "Iweb.Ping" "get" e);
          Lwt.return Http.s500 )
    | _ -> Lwt.return Http.s400
end

(* combine name and value *)
let n ((n,_,_) : Http.Form.input) (v : string) : Http.Form.field = (n,[v])

module Login = struct
  let path = "/login"
  module F = Http.Form

  let i_tok : F.input = ("token",              "hidden",   [])
  let i_uid : F.input = ("login",              "text",     [("required","required")])
  let i_pwd : F.input = ("password",           "password", [("required","required")])
  let i_lol : F.input = ("longlastingsession", "checkbox", [])
  let i_ret : F.input = ("returnurl",          "hidden",   [])
  let i_but : F.input = ("Login",              "submit",   [])

  let get _uuid (tok, (r : Cgi.Request.t)) =
    Logr.debug (fun m -> m "%s.%s" "Iweb.Login" "get");
    let ur = r |> Cgi.Request.path_and_query |> Uri.of_string in
    Ok (`OK, [Http.H.ct_xml], (fun oc ->
        [
          n i_tok tok;
          n i_ret ("returnurl" |> Uri.get_query_param ur |> Option.value ~default:"");
          n i_but "Login";
        ]
        |> xhtmlform "👋 Login" "loginform" [i_tok;i_uid;i_pwd;i_lol;i_ret;i_but] []
        |> to_channel ~xsl:"loginform.xsl" oc))

  (* check uid+pwd, Always take at least 2 seconds, if ok set session cookie and
     redirect to returnurl, call ban_f otherwise. *)
  let post _uuid tnow (ban_f : Ptime.t -> string -> unit) (_tok, (frm, (req : Cgi.Request.t))) =
    let sleep = 2 in
    Logr.debug (fun m -> m "Iweb.Login.post, sleep %d seconds..." sleep);
    Unix.sleep sleep;
    let flt r = function
      | (("login", [_]) as v)
      | (("password", [_]) as v)
      | (("returnurl", [_]) as v)
      | (("token", [_]) as v) -> r |> List.cons v
      | (f, _) -> Logr.info (fun m -> m "unconsumed form field: '%s'" f); r
    and cmp (a, _) (b, _) = String.compare a b in
    match frm |> List.fold_left flt [] |> List.sort cmp with
    | [ ("login", [uid]);
        ("password", [pwd]);
        ("returnurl", [retu]);
        ("token", [_] (* token has to be already checked by the caller. *)); ] ->
      Ok (Auth.Uid uid, pwd)
      >>= Auth.chk_file Auth.fn
      >>= (fun uid ->
          Cfg.CookieSecret.(make "" >>= from_file)
          >>= chain (Ok uid))
      >>= (fun (uid, sec32) ->
          assert (32 = (sec32 |> Cstruct.length));
          MyCookie.new_session ~tnow sec32 req uid |> Result.ok)
      |> (function
          | Ok cv ->
            Http.s302 ~header:[ cv ] retu
          | Error "invalid username or password" ->
            ban_f tnow req.remote_addr;
            Http.s403
          | Error e ->
            Logr.err (fun m -> m "%s %s.%s: %s" E.e1021 "Login" "post" e);
            Http.s500)
    | _ ->
      Http.s401
end

module Logout = struct
  let path = "/logout"

  (* GET requests should be idempotent, have no side effects.
     TODO: We could use a form button for this and POST: https://stackoverflow.com/a/33880971/349514*)
  let get _uuid ((_ : Auth.uid option), req) =
    Http.s302 ~header:[ ("Set-Cookie", MyCookie.make req "") ] ".."
end

let check_token f_ok exp ((v : Http.Form.t), vv) =
  Logr.debug (fun m -> m "Iweb.check_token");
  match Uri.get_query_param (Uri.make ~query:v ()) "token" with
  | Some tok ->
    if String.equal exp tok
    then (f_ok ();
          Ok (tok, (v,vv)))
    else Http.s403
  | None ->
    Logr.warn (fun m -> m "check_token: no token in form: %s" (Uri.encoded_of_query v));
    Http.s400

(** get uid from session if still running *)
let ases tnow (r : Cgi.Request.t) =
  (* Logr.debug (fun m -> m "%s.%s" "Iweb" "ases"); *)
  let uid = function
    (* check if the session cookie carries a date in the future *)
    | ("#session" as n, pay) :: [] ->
      assert (n = MyCookie.name);
      let sec = Cfg.CookieSecret.(make "" >>= from_file) |> Result.get_ok in
      Option.bind
        (Cookie.decrypt sec pay)
        (fun c ->
           Logr.debug (fun m -> m "%s.%s cookie value '%s'" "Iweb" "ases" c);
           match c |> MyCookie.decode with
             Ok (uid, tend) ->
             if tend > tnow
             then Some uid
             else None
           | _ -> None)
    | _ ->
      Logr.debug (fun m -> m "%s.%s %s cookie not found." "Iweb" "ases" MyCookie.name);
      None
  in
  Ok (r.http_cookie |> Cookie.of_string |> uid, r)

let rz = Webfinger.Server.rule
         :: Webfinger.rule
         :: Ap.Person.rule
         :: Ap.PersonX.rule
         :: Ap.PubKeyPem.pk_rule
         :: Ap.PubKeyPem.rule
         :: Cfg.Profile.ava
         :: Cfg.Profile.ban
         :: []

module Passwd = struct
  let path = "/passwd"
  module F = Http.Form

  let i_tok : F.input = ("token", "hidden", [])
  let i_uid : F.input = ("setlogin", "text", [
      ("required","required");
      ("maxlength","50");
      ("minlength","1");
      ("pattern", {|^[a-zA-Z0-9_.-]+$|});
      ("placeholder","Your local name as 'alice' in @alice@example.com");
    ])
  let i_pwd : F.input = ("setpassword", "password", [
      ("required","required");
      ("maxlength","200");
      ("minlength","12");
      ("pattern", {|^\S([^\n\t]*\S)?$|});
      ("placeholder","good passwords: xkcd.com/936");
    ])
  let i_pw2 : F.input = ("confirmpassword", "password", [
      ("required","required");
      ("placeholder","the same once more");
    ])
  let i_but : F.input = ("Save", "submit", [])

  let get _uuid (token, (Auth.Uid uid, _req)) =
    let _need_uid = Auth.(is_setup fn) in
    Ok (`OK, [Http.H.ct_xml], (fun oc ->
        [
          n i_tok token;
          n i_uid uid;
          n i_but "Save config";
        ]
        |> xhtmlform "🌻 Change Password" "changepasswordform" [i_tok;i_uid;i_pwd;i_pw2;i_but] []
        |> to_channel ~xsl:"changepasswordform.xsl" oc))

  let post _uuid _ (_tok, (frm, (Auth.Uid _, (req : Cgi.Request.t)))) =
    let _boo = File.exists Auth.fn in
    Logr.debug (fun m -> m "Iweb.Passwd.post form name='%s'" "changepasswordform");
    assert (Http.Mime.app_form_url = req.content_type);
    let run() =
      (* funnel additional err messages into the form *)
      let err msg (name,_,_) pred = if pred
        then Ok ()
        else Error (name,msg) in
      let* uid = F.string i_uid frm in
      let* pwd = F.string i_pwd frm in
      let* pw2 = F.string i_pw2 frm in
      let* _ = String.equal pwd pw2 |> err "not identical to password" i_pw2 in
      Ok (Auth.Uid uid,pwd)
    in
    match run() with
    | Ok (uid,pwd) ->
      let* _ = Auth.((uid, pwd) |> to_file fn) in
      let* _ = req |> Cgi.Request.base |> Cfg.Base.(to_file fn) |> Result.map_error (Http.err500 "failed to save baseurl") in
      let* _ = Webfinger.Server.(Make.make rz rule.target) |> Result.map_error (Http.err500 "failed to update webfinger") in
      let* _ = Ap.PersonX.(Make.make rz rule.target) |> Result.map_error (Http.err500 "failed to update profile") in
      let* sec = Cfg.CookieSecret.(make "" >>= from_file) |> Result.map_error (Http.err500 "failed to read cookie secret") in
      let header = [ MyCookie.new_session sec req (uid) ] in
      if File.exists Storage.fn
      then
        (Logr.debug (fun m -> m "already exists: %s" Storage.fn);
         Http.s302 ~header "../")
      else (
        Logr.debug (fun m -> m "add the first post from welcome.en.txt");
        let Auth.Uid uid = uid in
        let* base     = Cfg.Base.(fn |> from_file) |> Result.map_error (Http.err500 "failed to load baseurl") in
        let* profile  = Cfg.Profile.(fn |> from_file) |> Result.map_error (fun e ->
            Logr.err (fun m -> m "%s.%s failed to load profile: %s" "Iweb.Profile" "post" e);
            Http.s500') in
        let author    = Uri.make ~userinfo:uid ~host:(Uri.host base |> Option.value ~default:"example.com") ()
        and lang      = Rfc4287.Rfc4646 "en"
        and msg       = Res.read "/welcome.en.txt" |> Option.value ~default:"Ouch, missing welcome."
        and published = Rfc3339.T ( Ptime_clock.now() |> Ptime.to_rfc3339 )
        and uri       = Uri.with_userinfo seppo None
        in match
          msg
          |> Rfc4287.Entry.from_text_plain ~published ~author ~lang ~uri "Hello, #Seppo!"
          >>= Main.sift_urls
          >>= Main.sift_tags Tag.cdb
          >>= Main.sift_handles
          >>= Main.Note.publish ~base ~profile ~author:author
        with
        | Ok _    -> Http.s302 "../"
        | Error _ -> Http.s500 )
    | Error ee ->
      Logr.err (fun m -> m "%s %s.%s" E.e1022 "Iweb.Passwd" "post");
      Ok (`Unprocessable_entity, [Http.H.ct_xml], (fun oc ->
          frm
          |> xhtmlform "🌻 Change Password" "changepasswordform" [i_tok;i_uid;i_pwd;i_pw2;i_but] [ee]
          |> to_channel ~xsl:"changepasswordform.xsl" oc))
end

(** if no uid then redirect to login/passwd page *)
let uid_redir x : ((Auth.uid * Cgi.Request.t), Cgi.Response.t) result =
  match x with
  | (Some uid, r) -> Ok (uid, r)
  | (None, (r : Cgi.Request.t)) ->
    let r302 p =
      let path = r.script_name ^ p in
      let query = [("returnurl",[r |> Cgi.Request.abs])] in
      Uri.make ~path ~query () |> Uri.to_string |> Http.s302
    in
    if Auth.(is_setup fn)
    then r302 Login.path
    else if Passwd.path = r.path_info
    then (
      Logr.info (fun m -> m "passwd are not set, so go on with an empty uid. %s" r.path_info);
      Ok (Auth.dummy, r))
    else r302 Passwd.path

module Actor = struct
  let path = "/activitypub/actor.xml"

  let get ~base uuid (token, (Auth.Uid _uid, (r : Cgi.Request.t))) =
    match Ap.PubKeyPem.(private_of_pem pk_pem) with
    | Error e ->
      Logr.warn (fun m -> m "%s.%s %s" "Iweb.Actor" "get" e);
      Lwt.return Http.s500
    | Ok pk ->
      let query = r.query_string |> Uri.query_of_encoded in
      let u = Uri.make ~query () in
      Logr.debug (fun m -> m "%s.%s %a %a" "Iweb.Actor" "get" Uuidm.pp uuid Uri.pp_hum u);
      match Uri.get_query_param u "id" with
      | None   -> (* static, public profile of myself *)
        Http.s302 ("../../" ^ Ap.prox) |> Lwt.return
      | Some u -> (* dynamic, uncached remote actor profile converted to rdf *)
        let date = Ptime_clock.now () in
        let base = base () in
        let key_id = Uri.make ~path:Ap.proj () |> Http.reso ~base |> Ap.Person.key_id in
        let key : Http.t_sign_k option = Some (key_id,Ap.PubKeyPem.sign pk,date) in
        let%lwt act = u
                      |> Uri.of_string
                      |> Ap.Actor.http_get ~key in
        match act with
        | Error s ->
          Logr.warn (fun m -> m "%s.%s %a %s" "Actor" "get" Uuidm.pp uuid s);
          Http.s502 |> Lwt.return
        | Ok p ->
          let toc ?(indent = None) oc doc =
            (* similar St.to_chan *)
            let o = Xmlm.make_output ~decl:false (`Channel oc) ~nl:true ~indent in
            let id x = x in
            Xmlm.output_doc_tree id o (None, doc)
          in
          Ok (`OK, [Http.H.ct_xml], (fun oc ->
              Xml.pi oc "xml" ["version","1.0"];
              Xml.pi oc "xml-stylesheet" ["type","text/xsl"; "href","../../themes/current/" ^ "actor.xsl"];
              p
              |> Ap.Person.flatten
              |> Ap.Person.Rdf.encode
                ~token:(Some token)
                ~notify:(Ap.Followers.notify p.id)
                ~subscribed:(Ap.Following.subscribed p.id)
                ~blocked:(Ap.Following.blocked p.id)
                ~base
                ~context:None
              |> toc oc))
          |> Lwt.return

  let post
      ~(base : unit -> Uri.t)
      ?(que = Job.qn)
      ?(subscribed = Ap.Following.cdb)
      uuid tnow (_tok, ((frm : Http.Form.t), (Auth.Uid _uid, (req : Cgi.Request.t)))) =
    let dst_inbox = frm |> List.assoc "inbox" |> String.concat "|" |> Uri.of_string in
    let todo_id = frm |> List.assoc "id" |> String.concat "|" |> Uri.of_string in
    Logr.debug (fun m -> m "%s.%s %a data %a" "Iweb.Actor" "post" Uuidm.pp uuid Uri.pp_hum dst_inbox);
    let base = base () in
    let me = Uri.make ~path:Ap.proj () |> Http.reso ~base in
    let form_toggle_foldr k_of_old f_switch form init (k_old,v_old) =
      match k_old |> k_of_old with
      | None   -> init
      | Some k ->
        let v = match form |> List.assoc_opt k with
          | None
          | Some ["no"] -> "no"
          | _           -> "on" in
        let v_old = match v_old with
          | ["no"] -> "no"
          | _      -> "on" in
        match f_switch (k, v_old, v) with
        | None -> init
        | Some x -> x :: init in
    let _ = frm |> List.fold_left
              (form_toggle_foldr
                 (St.after ~prefix:"~")
                 (function
                   | "block",_,_ -> Some ()
                   | "notify",_,_ -> Some ()
                   | "subscribed","no","on" ->
                     Logr.debug (fun m -> m "%s.%s send subscribed %a to %a" "Iweb.Actor" "post" Uri.pp todo_id Uri.pp dst_inbox);
                     let fo = todo_id |> Ap.Following.follow ~me ~inbox:dst_inbox in
                     let cs = fo
                              |> As2_vocab.Encode.follow ~base
                              |> Main.job_encode_notify fo.id (dst_inbox, fo.object_)  in
                     let _ = cs
                             |> Csexp.to_string
                             |> Bytes.of_string
                             |> Job.enqueue ~due:tnow que 0 in
                     let ke = fo.object_ |> Uri.to_string in
                     let v = Ap.Followers.State.((Pending,tnow,dst_inbox,None,None,None) |> encode) |> Csexp.to_string in
                     let _ = Mapcdb.update_string ke v subscribed in
                     let _ = Ap.Following.Json.(Make.make [rule] target) in
                     let _ = Ap.Following.Atom.(Make.make [rule] target) in
                     Some ()
                   | "subscribed","on","no" ->
                     Logr.debug (fun m -> m "%s.%s send unsubscribe %a to %a" "Iweb.Actor" "post" Uri.pp todo_id Uri.pp dst_inbox);
                     let ufo = todo_id |> Ap.Following.follow ~me ~inbox:dst_inbox |> Ap.Following.undo ~me  in
                     let j = ufo |> As2_vocab.Encode.(undo ~context:None (follow ~context:None ~base) ~base) in
                     let _ = j |> Main.job_encode_notify ufo.id (dst_inbox, ufo.obj.object_)
                             |> Csexp.to_string
                             |> Bytes.of_string
                             |> Job.enqueue ~due:tnow que 0 in
                     let ke = ufo.obj.object_ |> Uri.to_string in
                     let _ = Mapcdb.remove_string ke subscribed in
                     let _ = Ap.Following.Json.(Make.make [rule] target) in
                     let _ = Ap.Following.Atom.(Make.make [rule] target) in
                     Some ()
                   | k,v',v ->
                     Logr.warn (fun m -> m "%s.%s unhandled %s: '%s' -> '%s'" "Iweb.Actor" "post" k v' v);
                     None )
                 frm)
              [] in
    let loc = req |> Cgi.Request.abs |> Uri.of_string in
    let loc = Uri.add_query_param' loc ("id", (todo_id |> Uri.to_string)) in
    Logr.debug (fun m -> m "%s.%s %a 302 back to %a" "Iweb.Actor" "post" Uuidm.pp uuid Uri.pp loc);
    let%lwt _ = Main.Queue.ping_and_forget ~base ~run_delay:60 in
    Lwt.return (Http.s302 (loc |> Uri.to_string))

  module Icon = struct
    (* forward to the avatar image of the id with explicit cache duration set by .htaccess/webserver config *)
    let get ~base uuid (r : Cgi.Request.t) =
      Logr.debug (fun m -> m "%s.%s" "Iweb.Actor.Icon" "get");
      let query = r.query_string |> Uri.query_of_encoded in
      match query with
      | ["id",[u]] ->
        (match Ap.PubKeyPem.(private_of_pem pk_pem) with
         | Error e ->
           Logr.warn (fun m -> m "%s.%s %s" "Iweb.Actor.Icon" "get" e);
           Lwt.return Http.s500
         | Ok pk ->
           let date = Ptime_clock.now () in
           let base = base () in
           let key_id = Uri.make ~path:Ap.proj () |> Http.reso ~base |> Ap.Person.key_id in
           let key : Http.t_sign_k option = Some (key_id,Ap.PubKeyPem.sign pk,date) in
           let%lwt act =
             u
             |> Uri.of_string
             |> Ap.Actor.http_get ~key in
           (match act with
            | Error s ->
              Logr.warn (fun m -> m "%s.%s %a %s" "Iweb.Avatar" "get" Uuidm.pp uuid s);
              Http.s502
            | Ok p ->
              p.icon
              |> Option.value ~default:Uri.empty
              |> Uri.to_string
              |> Http.s302)
           |> Lwt.return)
      | _ -> Http.s404
             |> Lwt.return
  end
end

module Health = struct
  let path = "/actor"
  let get ~base _uuid (Auth.Uid uid, (_r : Cgi.Request.t)) =
    let base = base () in
    let to_rdf ?(tz = 0) me (pem_url,x509) (cur,err,new_,run,tmp,wait) (ci_cur,ci_new) lock : _ Xmlm.frag =
      let _ = tz in
      let open Xml in
      let Webfinger.Client.(Localpart lopa,Domainpart dopa) = me in
      let sep n = `Data ("\n" ^ String.make (2*n) ' ') in
      let txt ?(datatype = None) (ns,tn) (s : string) =
        `El (((ns, tn), match datatype with
          | Some ty -> [((ns_rdf, "datatype"), ty)]
          | None    -> []), [`Data s]) in
      let intg (ns,tn) (v : int) =
        `El (((ns, tn),
              [((ns_rdf, "datatype"), ns_xsd ^ "integer")]),
             [`Data (v |> Int.to_string)]) in
      let dati ?(tz_offset_s = 0) (ns,tn) (v : Ptime.t option) =
        `El (((ns, tn),
              [((ns_rdf, "datatype"), ns_xsd ^ "dateTime")]),
             [`Data (match v with
                  | None   -> "-"
                  | Some v -> v |> Ptime.to_rfc3339 ~tz_offset_s)]) in
      `El (((ns_rdf, "RDF"),
            [
              ((Xmlm.ns_xmlns, "rdf"), ns_rdf);
              ((Xmlm.ns_xmlns, "seppo"), ns_seppo);
              ((Xmlm.ns_xmlns, "b"), ns_backoffice);
            ]),
           [sep 0;
            `El (((ns_rdf, "Description"),
                  [((ns_rdf,"about"),"")]), [
                   sep 1; txt  (ns_backoffice, "domainpart") dopa;
                   sep 1; txt  (ns_backoffice, "localpart")  lopa;
                   sep 1; txt  (ns_backoffice, "rfc7033")    (me |> Webfinger.Client.to_string);
                   sep 1; txt  (ns_backoffice, "x509_pem_url") (pem_url |> Uri.to_string);
                   sep 1; txt  (ns_backoffice, "x509_fingerprint") (x509 |> X509.Public_key.fingerprint |> Cstruct.to_hex_string);
                   sep 1; txt  (ns_backoffice, "x509_id") (x509 |> X509.Public_key.id |> Cstruct.to_hex_string);
                   sep 1; dati (ns_backoffice, "q_lock")          lock;
                   sep 1; intg (ns_backoffice, "spool_job_cur")   cur;
                   sep 1; intg (ns_backoffice, "spool_job_err")   err;
                   sep 1; intg (ns_backoffice, "spool_job_new")   new_;
                   sep 1; intg (ns_backoffice, "spool_job_run")   run;
                   sep 1; intg (ns_backoffice, "spool_job_tmp")   tmp;
                   sep 1; intg (ns_backoffice, "spool_job_wait")  wait;
                   sep 1; intg (ns_backoffice, "cache_inbox_new") ci_new;
                   sep 1; intg (ns_backoffice, "cache_inbox_cur") ci_cur;
                 ] )]) in
    let pat = Str.regexp {|.+\.\(s\|json\)$|} in
    let count dn =
      let pred f = Str.string_match pat f 0 in
      dn |> File.count_dir ~pred in
    let spool_job = (
      "app/var/spool/job/cur/" |> count,
      "app/var/spool/job/err/" |> count,
      "app/var/spool/job/new/" |> count,
      "app/var/spool/job/run/" |> count,
      "app/var/spool/job/tmp/" |> count,
      "app/var/spool/job/wait/"|> count
    )
    and cache_inbox = (
      "app/var/cache/inbox/cur/" |> count,
      "app/var/cache/inbox/new/" |> count
    )
    and qt = try
        (Main.Queue.run_fn
         |> Unix.stat).st_mtime
        |> Ptime.of_float_s
      with | _ -> None
    and x509 = Ap.PubKeyPem.target
               |> File.to_string
               |> Ap.PubKeyPem.of_pem
               |> Result.get_ok
    and me = Webfinger.Client.(Localpart uid,Domainpart (Uri.host base |> Option.value ~default:"")) in
    let x = to_rdf me (Ap.PubKeyPem.target |> Uri.of_string |> Http.reso ~base,x509) spool_job cache_inbox qt in
    let xsl = "backoffice.xsl" in

    let xsl = Some ("../../themes/current/" ^ xsl) in
    Ok (`OK, [Http.H.ct_xml], Xml.to_chan ~xsl x)
end

module Http_ = struct
  let path = "/http"
  let get ~base uuid now (Auth.Uid _, (r : Cgi.Request.t)) =
    let query = r.query_string |> Uri.query_of_encoded in
    let u = Uri.make ~query () in
    Logr.debug (fun m -> m "%s.%s %a %a" "Iweb.Http_" "get" Uuidm.pp uuid Uri.pp_hum u);
    match Uri.get_query_param u "get" with
    | None   -> Http.s400 |> Lwt.return
    | Some u ->
      let base  = base () in
      let me    = Uri.make ~path:Ap.proj () |> Http.reso ~base in
      let keyid = me |> Ap.Person.key_id in
      let (let*%) = Http.(let*%) in
      let*% pk = Ap.PubKeyPem.(private_of_pem pk_pem) |> Result.map_error (fun s ->
          Logr.err (fun m -> m "%s %s.%s %s" E.e1009 "Iweb.Http_" "get" s);
          Http.s500') in
      Logr.debug (fun m -> m "%s.%s got keyid %a" "Iweb.Http_" "get" Uri.pp_hum keyid);
      let key : Http.t_sign_k option = Some (keyid,Ap.PubKeyPem.sign pk,now) in

      let headers = [ Http.H.acc_app_jlda ] |> Cohttp.Header.of_list in
      let%lwt p = u
                  |> Uri.of_string
                  |> Http.get ~key ~headers in
      match p with
      | Error e ->
        Logr.warn (fun m -> m "%s.%s %s" "Iweb.Http_" "get" e);
        Http.s422 |> Lwt.return
      | Ok (r,b) ->
        match r.status with
        | #Cohttp.Code.success_status ->
          let%lwt b = b |> Cohttp_lwt.Body.to_string in
          let ct = ("Content-Type", Cohttp.Header.get r.headers "content-type"
                                    |> Option.value ~default:Http.Mime.text_plain) in
          Ok (`OK, [ct], fun oc -> b |> output_string oc)
          |> Lwt.return
        | s ->
          let s = s |> Cohttp.Code.string_of_status in
          Logr.warn (fun m -> m "%s.%s %s" "Iweb.Http_" "get" s);
          Http.s400 |> Lwt.return
end

module Note = struct
  let path = "/note"

  (*
   curl -L https://example.com/seppo.cgi/note?id=https://digitalcourage.social/users/mro/statuses/111601127682690078
  *)
  let get uuid (token, (Auth.Uid _uid, (r : Cgi.Request.t))) : Cgi.Response.t' =
    let que = Ap.Note.ibc_dir in
    let query = r.query_string |> Uri.query_of_encoded in
    let u = Uri.make ~query () in
    Logr.debug (fun m -> m "%s.%s %a data %a" "Iweb.Note" "get" Uuidm.pp uuid Uri.pp_hum u);
    let _ = token in
    match Option.bind
            ("h" |> Uri.get_query_param u)
            (fun h ->
               Logr.debug (fun m -> m "%s.%s %s" "Iweb.Note" "get" h);
               try
                 let h = Scanf.sscanf h "%[a-zA-Z0-9_-]" (fun a -> a) in
                 Ok (`OK, [Http.H.ct_jlda], fun oc ->
                     Printf.sprintf "%s%snote-%s.json" que "new/" h
                     |> File.to_string
                     |> output_string oc)
                 |> Option.some
               with _ -> None) with
    | Some v -> v
    | None   ->
      match Option.bind
              ("id" |> Uri.get_query_param u)
              (fun id ->
                 let h = id
                         |> Uri.of_string
                         |> Ap.Note.uhash in
                 let u = Uri.remove_query_param u "id" in
                 Uri.add_query_param u ("h",[h])
                 |> Uri.to_string
                 |> Http.s302
                 |> Option.some ) with
      | None   -> Http.s404
      | Some v -> v
end

module Profile = struct
  let path = "/profile"
  module F = Http.Form

  let i_tok : F.input = ("token",          "hidden",   [])
  let i_tit : F.input = ("title",          "text",     [ ("required","required"); ("minlength","1"); ("maxlength","100"); ("placeholder","A one-liner describing this #Seppo!"); ])
  let i_bio : F.input = ("bio",            "textarea", [                          ("maxlength","2000"); ("rows","10"); ("placeholder","more text describing this #Seppo!"); ])
  let i_tzo : F.input = ("timezone",       "text",     [ ("required","required"); ("minlength","3"); ("maxlength","100"); ("placeholder","Europe/Amsterdam or what timezone do you usually write from"); ])
  let i_lng : F.input = ("language",       "text",     [ ("required","required"); ("minlength","2"); ("maxlength","2"); ("pattern", {|^[a-z]+$|}); ("placeholder","nl or what language do you usually write in"); ])
  let i_ppp : F.input = ("posts_per_page", "number",   [ ("required","required"); ("min","10"); ("max","1000"); ("placeholder","50 or how many posts should go on one page"); ])
  let i_but : F.input = ("save",           "submit",   [])

  let get _uuid (token, (_uid, _req)) : Cgi.Response.t' =
    let p = Cfg.Profile.(load fn) in
    let rz =  Cfg.Profile.ava
              :: Cfg.Profile.ban
              :: [] in
    let _ = rz |> List.fold_left (fun _ (r : Make.t) -> Make.make rz r.target) (Ok "") in
    Ok (`OK, [Http.H.ct_xml], (fun oc ->
        let Rfc4287.Rfc4646 lng = p.language in
        [
          n i_tok token;
          n i_tit p.title;
          n i_bio p.bio;
          n i_lng lng;
          n i_tzo (Timedesc.Time_zone.name p.timezone);
          n i_ppp (string_of_int p.posts_per_page);
          n i_but "Save";
        ]
        |> xhtmlform "🎭 Profile" "configform" [i_tok;i_tit;i_bio;i_lng;i_tzo;i_ppp;i_but] []
        |> to_channel ~xsl:"configform.xsl" oc))

  let post _uuid _tnow (_tok, (frm, (Auth.Uid uid, (_req : Cgi.Request.t)))) =
    let run () =
      Logr.debug (fun m -> m "%s.%s save" "Iweb.Profile" "post");
      let* title   = F.string i_tit frm in
      let* bio     = frm |> F.string i_bio in
      let* language= F.string i_lng frm in
      let language = Rfc4287.Rfc4646 language in
      let* timezone= F.string i_tzo frm in
      let timezone = Timedesc.Time_zone.(make timezone
                                         |> Option.value ~default:Rfc3339.fallback) in
      let* ppp = F.string i_ppp frm in
      let posts_per_page = ppp
                           |> int_of_string_opt
                           |> Option.value ~default:50 in
      let p : Cfg.Profile.t = {title;bio;language;timezone;posts_per_page} in
      let eee e = ("",e) in
      let* _ = Result.map_error eee Cfg.Profile.(p |> to_file fn) in
      let* _ = Result.map_error eee Ap.Person.(Make.make rz rule.target) in
      let* _ = Result.map_error eee Ap.PersonX.(Make.make rz rule.target) in
      let* ba = Result.map_error eee Cfg.Base.(from_file fn) in
      Ok (p,ba) in
    match run() with
    | Ok (profile,base) ->
      if File.exists Storage.fn
      then
        (Logr.debug (fun m -> m "already exists: %s" Storage.fn);
         Http.s302 "../")
      else (
        Logr.debug (fun m -> m "add the first post from welcome.en.txt");
        let author    = Uri.make ~userinfo:uid ~host:(Uri.host base |> Option.value ~default:"example.com") ()
        and lang      = Rfc4287.Rfc4646 "en"
        and msg       = Res.read "/welcome.en.txt" |> Option.value ~default:"Ouch, missing welcome."
        and published = Ptime_clock.now() |> Rfc3339.of_ptime
        and uri       = Uri.with_userinfo seppo None
        in match
          msg
          |> Rfc4287.Entry.from_text_plain ~published ~author ~lang ~uri "Hello, #Seppo!"
          >>= Main.sift_urls
          >>= Main.sift_tags Tag.cdb
          >>= Main.sift_handles
          >>= Main.Note.publish ~base ~profile ~author:author
        with
        | Ok _    -> Http.s302 "../"
        | Error _ -> Http.s500 )
    | Error ("",e) ->
      Logr.err (fun m -> m "%s %s.%s %s" E.e1024 "Iweb.Profile" "post" e);
      Http.s500
    | Error (_f,e) ->
      Logr.err (fun m -> m "%s %s.%s %s" E.e1025 "Iweb.Profile" "post" e);
      Ok (`Unprocessable_entity, [Http.H.ct_xml], (fun oc ->
          frm
          |> xhtmlform "🎭 Profile" "configform" [i_tok;i_tit;i_bio;i_lng;i_tzo;i_ppp;i_but] []
          |> to_channel ~xsl:"configform.xsl" oc))
end

module Post = struct
  let path = "/post"
  module F = Http.Form

  let epoch_shaarli = ((2011,9,13),((15,45,42),2*60*60))
                      |> Ptime.of_date_time
                      |> Option.value ~default:Ptime.min

  let s2d ?(tz_offset_s = 0) s =
    Scanf.sscanf
      s
      "%4i%2i%2i_%2i%2i%2i"
      (fun y m d ho mi se -> ((y,m,d),((ho,mi,se),tz_offset_s)) |> Ptime.of_date_time)

  let d2s ?(tz_offset_s = 0) d =
    let ((y,m,d),((ho,mi,se),_)) = Ptime.to_date_time ~tz_offset_s d in
    Printf.sprintf "%04i%02i%02i_%02i%02i%02i" y m d ho mi se

  type cmd = Cancel | Delete | Save

  type t = {
    scrape : bool;
    source : string option;
    dat    : Ptime.t option;
    url    : Uri.t option;
    tit    : string option;
    dsc    : string option;
    tag    : string list;
    pri    : bool;
    sav    : cmd option;
    can    : string option;
    tok    : string;
    ret    : Uri.t option;
    img    : Uri.t option;
  }

  let empty = {
    scrape = false;
    source = None;
    dat    = None;
    url    = None;
    tit    = None;
    dsc    = None;
    tag    = [];
    pri    = false;
    sav    = None;
    can    = None;
    tok    = "";
    ret    = None;
    img    = None;
  }

  let to_rfc4287
      ?(now = Ptime_clock.now ())
      ?(lang = Rfc4287.Rfc4646 "nl")
      ?(author = Uri.empty)
      ?(tz = Rfc3339.fallback)
      r =
    let dat = r.dat |> Option.value ~default:now |> Rfc3339.of_ptime ~tz in
    let lks = match r.url with
      | None   -> []
      | Some l ->
        assert (l |> Uri.host|> Option.is_some);
        [ Rfc4287.Link.make l ] in
    let os = Option.value ~default:"" in
    Ok ({
        id         = Uri.empty;
        (* assumes an antry has one language for title, tags, content. *)
        in_reply_to = [];
        lang;
        author;
        title      = r.tit |> os;
        published  = dat;
        updated    = dat;
        links      = lks;
        categories = r.tag |> List.fold_left ( fun i s ->
            let l = Rfc4287.Category.Label (Rfc4287.Single s) in
            let t = Rfc4287.Category.Term (Rfc4287.Single s) in
            (l,t,Uri.empty) :: i) [];
        content    = r.dsc |> os;
      } : Rfc4287.Entry.t)

  let of_rfc4287
      tpl (e : Rfc4287.Entry.t) : t =
    let tit = Some e.title in
    let date t0 t =
      let Rfc3339.T t = t in
      match Ptime.of_rfc3339 t with
      | Error _       -> t0
      | Ok (t,_tz,_c) -> Some t
    in
    let dat = date tpl.dat e.published in
    let url = List.fold_left (fun init (u : Rfc4287.Link.t) ->
        match init with
        | Some _ as v -> v (* found the link, just pass it *)
        | None ->
          match u.rel with
          | None -> Some u.href
          | _    -> None) None e.links in
    let dsc = Some e.content in
    (* TODO: ensure no tags get lost *)
    {tpl with dat;url;tit;dsc}

  let sift_bookmarklet_get ?(tz = "Europe/Amsterdam") i (k,v) =
    let _ = tz in
    let v = v |> String.concat " " in
    let os v = let v = v |> String.trim in if v = "" then None else Some v
    and ou v = if "" = v then None else Some (v |> Uri.of_string) in
    match k,v with
    | "post",        v -> (
        let u = v |> Uri.of_string in
        match u |> Uri.scheme with
        | None   -> {i with tit = Some v}
        | Some _ -> {i with url = Some u})
    | "source",      v -> {i with source = os v}
    | "scrape",      v -> {i with scrape = v != "no"}
    | "title",       v -> {i with tit    = os v}
    | "tags",        v -> {i with tag    = v |> String.split_on_char ' '}
    | "image",       v -> {i with img    = ou v}
    | "description", v -> {i with dsc    = os v}
    | _ -> i

  let sift_post ?(tz = "Europe/Amsterdam") i (k,v) =
    let _ = tz in
    let v = v |> String.concat " " in
    let os v = let v = v |> String.trim in if v = "" then None else Some v
    and ou v = if "" = v then None else Some (v |> Uri.of_string) in
    let oau v = let u = ou v in
      Option.bind u
        (fun u' -> Option.bind (u' |> Uri.scheme)
            (fun _ -> u) )
    in
    match k,v with
    | "lf_linkdate"   , v -> {i with dat = v |> s2d }
    | "token"         , v -> {i with tok = v}
    | "returnurl"     , v -> {i with ret = ou v}
    | "lf_image"      , v -> {i with img = oau v}
    | "lf_url"        , v -> {i with url = oau v}
    | "lf_title"      , v -> {i with tit = os v}
    | "lf_description", v -> {i with dsc = os v}
    | "cancel_edit"   , ("Cancel") -> {i with sav = Some Cancel}
    | "delete_edit"   , ("Delete") -> {i with sav = Some Delete}
    | "save_edit"     , ("Save")   -> {i with sav = Some Save}
    | k               , v -> Logr.warn (fun m -> m "%s.%s %s: %s" "Iweb.Post" "sift_post" k v);
      i

  let i_dat : F.input = ("lf_linkdate",    "hidden",   [])
  let i_url : F.input = ("lf_url",         "url",      [])
  let i_tit : F.input = ("lf_title",       "text",     [("required","required"); ("minlength","1")])
  let i_dsc : F.input = ("lf_description", "textarea", [])
  let i_tag : F.input = ("lf_tags",        "text",     [("data-multiple","data-multiple")])
  let i_pri : F.input = ("lf_private",     "checkbox", [])
  let i_sav : F.input = ("save_edit",      "submit",   [])
  let i_can : F.input = ("cancel_edit",    "submit",   [])
  let i_tok : F.input = ("token",          "hidden",   [])
  let i_ret : F.input = ("returnurl",      "hidden",   [])
  let i_img : F.input = ("lf_image",       "hidden",   [])

  (* only parameter is 'post'
   * https://code.mro.name/github/Shaarli-Vanilla/src/master/index.php#L427
   * https://code.mro.name/github/Shaarli-Vanilla/src/029f75f180f79cd581786baf1b37e810da1adfc3/index.php#L1548
  *)
  let get ~base uuid (_token, (_uid, (req : Cgi.Request.t))) =
    Logr.debug (fun m -> m "%s.%s %a %s" "Iweb.Post" "get" Uuidm.pp uuid req.query_string);
    let r = req.query_string |> Uri.query_of_encoded in
    let emp = {empty with dat = Some (Ptime_clock.now())} in
    let emp =
      match List.assoc_opt "id" r with
      | Some [id] ->
        let base = base () in
        let id = id
                 (* revert substitution by posts.xsl  *)
                 |> String.map (function | '$' -> '#'
                                         | c   -> c)
                 |> Uri.of_string
                 |> Http.abs_to_rel ~base in
        assert (id |> Uri.to_string |> St.starts_with ~prefix:"o/");
        (match id |> Storage.select with
         | Error e ->
           Logr.warn (fun m -> m "%s.%s %s" "Iweb.Post" "get" e);
           emp
         | Ok e ->
           of_rfc4287 emp e )
      | _ -> emp in
    let r = r |> List.fold_left sift_bookmarklet_get emp
    in
    (* - look up url in storage
     * - if not present:
     *   - if title not present
     *     then
     *       try to get from url
     *       use title, description, keywords
     * - show 'linkform'
    *)
    let os v = v |> Option.value ~default:"" in
    let od v = v |> Option.value ~default:epoch_shaarli |> d2s in
    let ou v = v |> Option.value ~default:Uri.empty |> Uri.to_string in
    let ol v = v |> String.concat " " in
    let ob v = if v then "on" else "no" in
    Ok (`OK, [Http.H.ct_xml], (fun oc ->
        [
          n i_dat (r.dat |> od);
          n i_url (r.url |> ou);
          n i_tit (r.tit |> os);
          n i_dsc (r.dsc |> os);
          n i_tag (r.tag |> ol);
          n i_pri (r.pri |> ob);
          n i_sav "save_edit";
          n i_can "cancel_edit";
          n i_tok _token;
          n i_ret (r.img |> ou);
          n i_img (r.img |> ou);
        ]
        |> xhtmlform "Add" "linkform" [i_dat;i_url;i_tit;i_dsc;i_tag;i_pri;i_sav;i_can;i_tok;i_ret;i_img;] []
        |> to_channel ~xsl:"linkform.xsl" oc))

  (* https://code.mro.name/github/Shaarli-Vanilla/src/master/index.php#L1479 *)
  let post ~base uuid _ (_tok, (frm, (Auth.Uid uid, (req : Cgi.Request.t)))) =
    Logr.debug (fun m -> m "%s.%s %a %s" "Iweb.Post" "post" Uuidm.pp uuid req.query_string);
    let base = base () in
    let f () =
      let s = frm |> Uri.with_query Uri.empty in
      Logr.debug (fun m -> m "%s.%s %a %a" "Iweb.Post" "post" Uuidm.pp uuid Uri.pp s);
      let eee e =
        Logr.warn (fun m -> m "%s.%s %a error loading Cfg.Profile: %s" "Iweb.Post" "post" Uuidm.pp uuid e);
        Http.s422' in
      let now      = Ptime_clock.now () in
      let* profile = Result.map_error eee Cfg.Profile.(from_file fn) in
      let lang     = profile.language in
      let author   = Uri.make ~userinfo:uid ~host:(Uri.host base |> Option.value ~default:"example.com") () in
      let* _pk = Ap.PubKeyPem.(private_of_pem pk_pem) |> Result.map_error (fun ( s) ->
          Logr.err (fun m -> m "%s %s.%s invalid private key: %s" E.e1026 "Ap" "post" s);
          Http.s500') in
      let r = frm |> List.fold_left sift_post empty in
      match r.sav with
      | Some Cancel ->
        Logr.debug (fun m -> m "%s.%s %s" "Iweb.Post" "post" "Cancel");
        Http.s302 "../"
      | Some Delete ->
        Logr.debug (fun m -> m "%s.%s %s" "Iweb.Post" "post" "Delete");
        (match req.query_string |> Uri.query_of_encoded |> List.assoc_opt "id" with
         | Some [id] ->
           let id = id
                    (* revert substitution by posts.xsl  *)
                    |> String.map (function | '$' -> '#'
                                            | c   -> c)
                    |> Uri.of_string
                    |> Http.abs_to_rel ~base in
           (match id
                  |> Main.Note.Delete.delete
              >>= Main.Note.Delete.notify_subscribers ~due:now ~base
            with
            | Ok r ->
              Logr.info (fun m -> m "TODO %s.%s Delete refresh affected files. %a" "Iweb.Post" "post" Uri.pp r.id);
              Http.s302 "../"
            | Error e ->
              Logr.warn (fun m -> m "%s.%s Delete %s" "Iweb.Post" "post" e);
              Http.s500)
         | None
         | _ -> Http.s500)
      | Some Save ->
        (match
           r
           |> to_rfc4287 ~tz:profile.timezone ~now ~lang ~author
           >>= Main.sift_urls
           >>= Main.sift_tags Tag.cdb
           >>= Main.sift_handles
           >>= Main.Note.publish ~base ~author ~profile
           >>= Main.Note.Create.notify_subscribers ~due:now ~base
         with
         | Ok (_n : Rfc4287.Entry.t) -> Http.s302 "../"
         | Error (_ : string)        -> Http.s500)
      | None ->
        Logr.err (fun m -> m "%s.%s %s" "Iweb.Post" "post" "None");
        Http.s500
    in
    let r = f () in
    let%lwt _ = Main.Queue.ping_and_forget ~base ~run_delay:60 in
    Lwt.return r
end

module Tools = struct
  let get _uuid _ = Http.s501
end

module Session = struct
  let get _uuid (uid, _req) =
    match uid with
    | None -> (* no ban penalty but 404 nevertheless. *)
      Http.s404
    | Some (Auth.Uid v) ->
      Ok (`OK, [Http.H.ct_xml], (fun oc -> output_string oc v))
end

(* send a potential new to-be-notified to their home server to subscribe back.
   Requires the other side to implement webfinger RFC7033 and provide
   rel=http://ostatus.org/schema/1.0/subscribe. *)
module Notifyme = struct
  let get ~base uuid _tnow (r : Cgi.Request.t) =
    assert ("http://ostatus.org/schema/1.0/subscribe" = As2_vocab.Constants.Webfinger.ostatus_rel);
    match r.query_string |> Uri.query_of_encoded with
    | ["resource",[acct]; "rel",["http://ostatus.org/schema/1.0/subscribe"]] ->
      (Logr.debug (fun m -> m "%s.%s %a %s" "Iweb.Notifyme" "get" Uuidm.pp uuid acct);
       match Webfinger.(acct
                        |> of_string
                        |> well_known_uri) with
       | Error _ -> Http.s400
                    |> Lwt.return
       | Ok wk ->
         Logr.debug (fun m -> m "%s.%s %a webfinger: %a" "Iweb.Notifyme" "get" Uuidm.pp uuid Uri.pp wk);
         let%lwt wf = wk |> Webfinger.Client.http_get in
         match wf with
         | Error _ -> Http.s500
                      |> Lwt.return
         | Ok wf ->
           match wf.links |> As2_vocab.Types.Webfinger.ostatus_subscribe with
           | None -> Http.s502
                     |> Lwt.return
           | Some tpl ->
             Logr.debug (fun m -> m "%s.%s %a got template %s" "Iweb.Notifyme" "get" Uuidm.pp uuid tpl);
             let rx = Str.regexp_string "{uri}" in
             let uri = Http.reso ~base:(base()) (Uri.make ~path:Ap.proj ())
                       |> Uri.to_string in
             tpl
             |> Str.replace_first rx uri
             |> Http.s302
             |> Lwt.return )
    | _ -> Http.s400
           |> Lwt.return
end