seppo/chkr/cgi.ml

(*
 *    _  _   ____                         _  
 *  _| || |_/ ___|  ___ _ __  _ __   ___ | | 
 * |_  ..  _\___ \ / _ \ '_ \| '_ \ / _ \| | 
 * |_      _|___) |  __/ |_) | |_) | (_) |_| 
 *   |_||_| |____/ \___| .__/| .__/ \___/(_) 
 *                     |_|   |_|             
 *
 * Personal Social Web.
 *
 * cgi.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/>.
 *)

open Seppo_lib

let ( let* ) = Result.bind

let webfinger _uuid qs =
  match qs |> List.assoc_opt "resource" with
  | Some [resource] ->
    (match resource
           |> Rfc7565.of_string
           |> Result.get_ok
           |> Shell.webfinger with
    | Error e ->
      Logr.debug (fun m -> m "%s.%s %s" "cgi" "webfinger" e);
      Ok (`Bad_request, [Http.H.ct_plain], e |> Cgi.Response.body)
    | Ok q ->
      match
        q.links |> As2_vocab.Types.Webfinger.self_link,
        q.links |> As2_vocab.Types.Webfinger.profile_page,
        qs |> List.assoc_opt "redirect" with
      | Some j,_,Some [{|self|}] ->
        let r = Uri.make
            ~path:"actor"
            ~query:["id",[j |> Uri.to_string]]
            ()  in
        r
        |> Uri.to_string
        |> Http.s302
      | _,Some h,Some [{|http://webfinger.net/rel/profile-page|}] ->
        h
        |> Uri.to_string
        |> Http.s302
      | _,_,_ ->
        Ok (`OK, [Http.H.ct_json], fun oc ->
            q
            |> As2_vocab.Encode.Webfinger.query_result ~base:Uri.empty
            |> Ezjsonm.value_to_channel oc ))
  | _ -> Http.s400

let actor _uuid qs (r : Cgi.Request.t)  =
  match qs |> List.assoc_opt "id" with
  | Some [id] ->
    let key =
      (* https://datatracker.ietf.org/doc/html/draft-cavage-http-signatures-12#appendix-C *)
      let pem = {|-----BEGIN RSA PRIVATE KEY-----
MIICXgIBAAKBgQDCFENGw33yGihy92pDjZQhl0C36rPJj+CvfSC8+q28hxA161QF
NUd13wuCTUcq0Qd2qsBe/2hFyc2DCJJg0h1L78+6Z4UMR7EOcpfdUE9Hf3m/hs+F
UR45uBJeDK1HSFHD8bHKD6kv8FPGfJTotc+2xjJwoYi+1hqp1fIekaxsyQIDAQAB
AoGBAJR8ZkCUvx5kzv+utdl7T5MnordT1TvoXXJGXK7ZZ+UuvMNUCdN2QPc4sBiA
QWvLw1cSKt5DsKZ8UETpYPy8pPYnnDEz2dDYiaew9+xEpubyeW2oH4Zx71wqBtOK
kqwrXa/pzdpiucRRjk6vE6YY7EBBs/g7uanVpGibOVAEsqH1AkEA7DkjVH28WDUg
f1nqvfn2Kj6CT7nIcE3jGJsZZ7zlZmBmHFDONMLUrXR/Zm3pR5m0tCmBqa5RK95u
412jt1dPIwJBANJT3v8pnkth48bQo/fKel6uEYyboRtA5/uHuHkZ6FQF7OUkGogc
mSJluOdc5t6hI1VsLn0QZEjQZMEOWr+wKSMCQQCC4kXJEsHAve77oP6HtG/IiEn7
kpyUXRNvFsDE0czpJJBvL/aRFUJxuRK91jhjC68sA7NsKMGg5OXb5I5Jj36xAkEA
gIT7aFOYBFwGgQAQkWNKLvySgKbAZRTeLBacpHMuQdl1DfdntvAyqpAZ0lY0RKmW
G6aFKaqQfOXKCyWoUiVknQJAXrlgySFci/2ueKlIE1QqIiLSZ8V8OlpFLRnb1pzI
7U1yQXnTAEFYM560yJlzUpOb1V4cScGd365tiSMvxLOvTA==
-----END RSA PRIVATE KEY-----|} in
      let base = r |> Cgi.Request.base in
      let base = Uri.make ~path:(r.script_name ^ "/") () |> Http.reso ~base in
      let path = "actor.jsa" in
      let id'  = Uri.make ~path () |> Http.reso ~base in
      let key_id = id' |> Ap.Person.my_key_id in
      let pk = pem
               |> Cstruct.of_string
               |> Ap.PubKeyPem.private_of_pem_data
               |> Result.get_ok in
      Some (Http.Signature.mkey key_id pk (Ptime_clock.now ()))
    in
    (match id |> Uri.of_string |> Shell.actor ~key with
     | Error e ->
       Logr.debug (fun m -> m "%s.%s %s" "cgi" "actor" e);
       Ok (`Bad_request, [Http.H.ct_plain], e |> Cgi.Response.body)
     | Ok q ->
       Ok (`OK, [Http.H.ct_jlda], fun oc ->
           let lang = As2_vocab.Constants.ActivityStreams.und in
           q
           |> As2_vocab.Encode.person ~lang ~base:Uri.empty
           |> Ezjsonm.value_to_channel oc ))
  | _ -> Http.s400

(* a callback endpoint for signing pem *)
let actor_jsa uuid r =
  let path = "actor.jsa" in
  let base = r |> Cgi.Request.base in
  let base = Uri.make ~path:(r.script_name ^ "/") () |> Http.reso ~base in
  let lang = Some "und"
  (* https://datatracker.ietf.org/doc/html/draft-cavage-http-signatures-12#appendix-C *)
  and id   = Uri.make ~path () |> Http.reso ~base in
  assert (id |> Uri.to_string |> St.is_suffix ~affix:"/apchk.cgi/actor.jsa");
  let name = Some "ApChk.cgi" in
  let preferred_username = name
  and pem = {|-----BEGIN PUBLIC KEY-----
MIGfMA0GCSqGSIb3DQEBAQUAA4GNADCBiQKBgQDCFENGw33yGihy92pDjZQhl0C3
6rPJj+CvfSC8+q28hxA161QFNUd13wuCTUcq0Qd2qsBe/2hFyc2DCJJg0h1L78+6
Z4UMR7EOcpfdUE9Hf3m/hs+FUR45uBJeDK1HSFHD8bHKD6kv8FPGfJTotc+2xjJw
oYi+1hqp1fIekaxsyQIDAQAB
-----END PUBLIC KEY-----|}
  and signatureAlgorithm = Some "https://www.w3.org/2001/04/xmldsig-more#rsa-sha256"
  in
  {Ap.Person.empty with
   id;
   name;
   preferred_username;
   generator  = Some {href=St.seppo_u; name; name_map=[]; rel=None};
   public_key =
     {
       id    = id |> Ap.Person.my_key_id;
       owner = Some id;
       pem;
       signatureAlgorithm;
     };
  }
  |> As2_vocab.Encode.person ~base ~lang
  |> Ezjsonm.value_to_string ~minify:false
  |> Http.clob_send uuid Http.Mime.app_jlda

let handle uuid _ic (req : Cgi.Request.t) : Cgi.Response.t =
  let dispatch (r : Cgi.Request.t) =
    let send_res ct p = match ("static" ^ p) |> Res.read with
      | None   -> Http.s500
      | Some b -> Http.clob_send uuid ct b in
    match r.path_info, r.request_method |> Cohttp.Code.method_of_string with
    | ("/doap.rdf" as p,          `GET) -> p |> send_res Http.Mime.text_xml
    | ("/LICENSE" as p,           `GET) -> p |> send_res Http.Mime.text_plain
    | ("/doap2html.xsl" as p,     `GET) -> p |> send_res Http.Mime.text_xsl
    | "",                         `GET  -> Http.s302 (req.script_name ^ "/xml")
    | "/",                        `GET  -> Http.s302 req.script_name
    | "/actor",                   `GET  -> r |> actor uuid (r.query_string |> Uri.query_of_encoded)
    | "/actor.jsa",               `GET  -> r |> actor_jsa uuid
    | "/version",                 `GET  ->
      Printf.sprintf
        "https://Seppo.Social/v/%s+%s" Version.dune_project_version Version.git_sha
      |> Http.s302
    | "/webfinger",               `GET  -> r.query_string |> Uri.query_of_encoded |> webfinger uuid
    | "/css",                     `GET  -> "/apchk.css" |> send_res Http.Mime.text_css
    | "/xml",                     `GET  -> "/apchk.xml" |> send_res Http.Mime.text_xml
    | "/xsl",                     `GET  -> "/apchk.xsl" |> send_res Http.Mime.text_xsl
    | _,                          `GET  -> Http.s404
    | _                                 -> Http.s405
  and merge = function
    | Ok v    -> v
    | Error v -> v
  in
  Logr.info (fun m -> m "%s -> %s %a" req.remote_addr req.request_method Uri.pp (req |> Cgi.Request.path_and_query));
  req
  |> dispatch
  |> merge