chkr/cgi.ml

   1 (*
   2  *    _  _   ____                         _
   3  *  _| || |_/ ___|  ___ _ __  _ __   ___ | |
   4  * |_  ..  _\___ \ / _ \ '_ \| '_ \ / _ \| |
   5  * |_      _|___) |  __/ |_) | |_) | (_) |_|
   6  *   |_||_| |____/ \___| .__/| .__/ \___/(_)
   7  *                     |_|   |_|
   8  *
   9  * Personal Social Web.
  10  *
  11  * cgi.ml
  12  *
  13  * Copyright (C) The #Seppo contributors. All rights reserved.
  14  *
  15  * This program is free software: you can redistribute it and/or modify
  16  * it under the terms of the GNU General Public License as published by
  17  * the Free Software Foundation, either version 3 of the License, or
  18  * (at your option) any later version.
  19  *
  20  * This program is distributed in the hope that it will be useful,
  21  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  22  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  23  * GNU General Public License for more details.
  24  *
  25  * You should have received a copy of the GNU General Public License
  26  * along with this program.  If not, see <http://www.gnu.org/licenses/>.
  27  *)
  28
  29 open Seppo_lib
  30
  31 let ( let* ) = Result.bind
  32
  33 let webfinger qs =
  34   match qs |> List.assoc_opt "resource" with
  35   | Some [resource] ->
  36     (match resource
  37            |> Rfc7565.of_string
  38            |> Result.get_ok
  39            |> Shell.webfinger with
  40     | Error e ->
  41       Logr.debug (fun m -> m "%s.%s %s" "cgi" "webfinger" e);
  42       Ok (`Bad_request, [Http.H.ct_plain], e |> Cgi.Response.body)
  43     | Ok q ->
  44       match
  45         q.links |> As2_vocab.Types.Webfinger.self_link,
  46         q.links |> As2_vocab.Types.Webfinger.profile_page,
  47         qs |> List.assoc_opt "redirect-rel" with
  48       | Some j,_,Some [{|self|}] ->
  49         let r = Uri.make
  50             ~path:"actor"
  51             ~query:["id",[j |> Uri.to_string]]
  52             ()  in
  53         r
  54         |> Uri.to_string
  55         |> Http.s302
  56       | _,Some h,Some [{|http://webfinger.net/rel/profile-page|}] ->
  57         h
  58         |> Uri.to_string
  59         |> Http.s302
  60       | _,_,_ ->
  61         Ok (`OK, [Http.H.ct_json], fun oc ->
  62             q
  63             |> As2_vocab.Encode.Webfinger.query_result ~base:Uri.empty
  64             |> Ezjsonm.value_to_channel oc ))
  65   | _ -> Http.s400
  66
  67 let actor _uuid qs (r : Cgi.Request.t)  =
  68   match qs |> List.assoc_opt "id" with
  69   | Some [id] ->
  70     let key =
  71       (* https://datatracker.ietf.org/doc/html/draft-cavage-http-signatures-12#appendix-C *)
  72       let pem = {|-----BEGIN RSA PRIVATE KEY-----
  73 MIICXgIBAAKBgQDCFENGw33yGihy92pDjZQhl0C36rPJj+CvfSC8+q28hxA161QF
  74 NUd13wuCTUcq0Qd2qsBe/2hFyc2DCJJg0h1L78+6Z4UMR7EOcpfdUE9Hf3m/hs+F
  75 UR45uBJeDK1HSFHD8bHKD6kv8FPGfJTotc+2xjJwoYi+1hqp1fIekaxsyQIDAQAB
  76 AoGBAJR8ZkCUvx5kzv+utdl7T5MnordT1TvoXXJGXK7ZZ+UuvMNUCdN2QPc4sBiA
  77 QWvLw1cSKt5DsKZ8UETpYPy8pPYnnDEz2dDYiaew9+xEpubyeW2oH4Zx71wqBtOK
  78 kqwrXa/pzdpiucRRjk6vE6YY7EBBs/g7uanVpGibOVAEsqH1AkEA7DkjVH28WDUg
  79 f1nqvfn2Kj6CT7nIcE3jGJsZZ7zlZmBmHFDONMLUrXR/Zm3pR5m0tCmBqa5RK95u
  80 412jt1dPIwJBANJT3v8pnkth48bQo/fKel6uEYyboRtA5/uHuHkZ6FQF7OUkGogc
  81 mSJluOdc5t6hI1VsLn0QZEjQZMEOWr+wKSMCQQCC4kXJEsHAve77oP6HtG/IiEn7
  82 kpyUXRNvFsDE0czpJJBvL/aRFUJxuRK91jhjC68sA7NsKMGg5OXb5I5Jj36xAkEA
  83 gIT7aFOYBFwGgQAQkWNKLvySgKbAZRTeLBacpHMuQdl1DfdntvAyqpAZ0lY0RKmW
  84 G6aFKaqQfOXKCyWoUiVknQJAXrlgySFci/2ueKlIE1QqIiLSZ8V8OlpFLRnb1pzI
  85 7U1yQXnTAEFYM560yJlzUpOb1V4cScGd365tiSMvxLOvTA==
  86 -----END RSA PRIVATE KEY-----|} in
  87       let base = r |> Cgi.Request.base in
  88       let base = Uri.make ~path:(r.script_name ^ "/") () |> Http.reso ~base in
  89       let path = "actor.jsa" in
  90       let id'  = Uri.make ~path () |> Http.reso ~base in
  91       let key_id = id' |> Ap.Person.my_key_id in
  92       let pk = pem
  93                |> Cstruct.of_string
  94                |> Ap.PubKeyPem.private_of_pem_data
  95                |> Result.get_ok in
  96       Some (Http.Signature.mkey key_id pk (Ptime_clock.now ()))
  97     in
  98     (match id |> Uri.of_string |> Shell.actor ~key with
  99      | Error e ->
 100        Logr.debug (fun m -> m "%s.%s %s" "cgi" "actor" e);
 101        Ok (`Bad_request, [Http.H.ct_plain], e |> Cgi.Response.body)
 102      | Ok q ->
 103        Ok (`OK, [Http.H.ct_jlda], fun oc ->
 104            let lang = As2_vocab.Constants.ActivityStreams.und in
 105            q
 106            |> As2_vocab.Encode.person ~lang ~base:Uri.empty
 107            |> Ezjsonm.value_to_channel oc ))
 108   | _ -> Http.s400
 109
 110 (* a callback endpoint for signing pem *)
 111 let actor_jsa uuid r =
 112   let path = "actor.jsa" in
 113   let base = r |> Cgi.Request.base in
 114   let base = Uri.make ~path:(r.script_name ^ "/") () |> Http.reso ~base in
 115   let lang = Some "und"
 116   (* https://datatracker.ietf.org/doc/html/draft-cavage-http-signatures-12#appendix-C *)
 117   and id   = Uri.make ~path () |> Http.reso ~base in
 118   assert (id |> Uri.to_string |> St.is_suffix ~affix:"/apchk.cgi/actor.jsa");
 119   let name = Some "ApChk.cgi" in
 120   let preferred_username = name
 121   and pem = {|-----BEGIN PUBLIC KEY-----
 122 MIGfMA0GCSqGSIb3DQEBAQUAA4GNADCBiQKBgQDCFENGw33yGihy92pDjZQhl0C3
 123 6rPJj+CvfSC8+q28hxA161QFNUd13wuCTUcq0Qd2qsBe/2hFyc2DCJJg0h1L78+6
 124 Z4UMR7EOcpfdUE9Hf3m/hs+FUR45uBJeDK1HSFHD8bHKD6kv8FPGfJTotc+2xjJw
 125 oYi+1hqp1fIekaxsyQIDAQAB
 126 -----END PUBLIC KEY-----|}
 127   and signatureAlgorithm = Some "https://www.w3.org/2001/04/xmldsig-more#rsa-sha256"
 128   in
 129   {Ap.Person.empty with
 130    id;
 131    name;
 132    preferred_username;
 133    generator  = Some {href=St.seppo_u; name; name_map=[]; rel=None};
 134    public_key =
 135      {
 136        id    = id |> Ap.Person.my_key_id;
 137        owner = Some id;
 138        pem;
 139        signatureAlgorithm;
 140      };
 141   }
 142   |> As2_vocab.Encode.person ~base ~lang
 143   |> Ezjsonm.value_to_string ~minify:false
 144   |> Http.clob_send uuid Http.Mime.app_jlda
 145
 146 let handle uuid _ic (req : Cgi.Request.t) : Cgi.Response.t =
 147   let dispatch (r : Cgi.Request.t) =
 148     let send_res ct p = match ("static" ^ p) |> Res.read with
 149       | None   -> Http.s500
 150       | Some b -> Http.clob_send uuid ct b in
 151     match r.path_info, r.request_method |> Cohttp.Code.method_of_string with
 152     | ("/doap.rdf" as p,          `GET) -> p |> send_res Http.Mime.text_xml
 153     | ("/LICENSE" as p,           `GET) -> p |> send_res Http.Mime.text_plain
 154     | ("/doap2html.xsl" as p,     `GET) -> p |> send_res Http.Mime.text_xsl
 155     | "",                         `GET  -> Http.s302 (req.script_name ^ "/xml")
 156     | "/",                        `GET  -> Http.s302 req.script_name
 157     | "/actor",                   `GET  -> r |> actor uuid (r.query_string |> Uri.query_of_encoded)
 158     | "/actor.jsa",               `GET  -> r |> actor_jsa uuid
 159     | "/version",                 `GET  ->
 160       Printf.sprintf
 161         "https://Seppo.mro.name/v/%s+%s" Version.dune_project_version Version.git_sha
 162       |> Http.s302
 163     | "/webfinger",               `GET  -> r.query_string |> Uri.query_of_encoded |> webfinger
 164     | "/css",                     `GET  -> "/apchk.css" |> send_res Http.Mime.text_css
 165     | "/xml",                     `GET  -> "/apchk.xml" |> send_res Http.Mime.text_xml
 166     | "/xsl",                     `GET  -> "/apchk.xsl" |> send_res Http.Mime.text_xsl
 167     | _,                          `GET  -> Http.s404
 168     | _                                 -> Http.s405
 169   and merge = function
 170     | Ok v    -> v
 171     | Error v -> v
 172   in
 173   Logr.info (fun m -> m "%s -> %s %a" req.remote_addr req.request_method Uri.pp (req |> Cgi.Request.path_and_query));
 174   req
 175   |> dispatch
 176   |> merge