bin/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 open Astring
  31
  32 let ( let* ) = Result.bind
  33 let ( >>= )  = Result.bind
  34 let ( >>| ) a b = match a with
  35   | Error _ as e -> Lwt.return e
  36   | Ok a -> b a
  37
  38 let post_limit_b = 2 * 1024
  39
  40 (* Handle incoming HTTP requests.
  41  *
  42  * Has the
  43  * - brue force mitigation ban,
  44  * - initial setup,
  45  * - asset restore,
  46  * - URL router (dispatch),
  47  * - session enforcement
  48  * - /ping loop
  49  * and delegates to the logic in Iweb (UI webinterface) or Is2s (ActivityPub Server to Server endpoint)
  50  *
  51  * Still does a Lwt_main.run that preferably owuld be outside
  52 *)
  53 let handle uuid tnow ic (req : Cgi.Request.t) : Cgi.Response.t =
  54   let t0 = Sys.time() in
  55   Logr.debug (fun m -> m "%s.%s %a %s %s %s" "Cgi" "handle" Uuidm.pp uuid req.remote_addr req.request_method req.path_info);
  56   assert (not (req.path_info |> St.is_prefix ~affix:("/" ^ Cfg.seppo_cgi)));
  57   (** redirect to password reset if non exists *)
  58   let redir_if_passwd_nonex (r : Cgi.Request.t) =
  59     let loc = Iweb.Passwd.path in
  60     if Auth.fn |> File.exists
  61     || r.path_info |> String.equal loc
  62     then Ok r
  63     else
  64       (* start a 'recovery' session *)
  65       let* _,sec = Cfg.ServerSession.create tnow
  66                    |> Option.to_result ~none:Http.s500' in
  67       let header = [ Iweb.ClientCookie.new_session ~tnow sec req Auth.dummy ] in
  68       Cfg.seppo_cgi ^ loc |> Http.s302 ~header
  69   and restore_assets lst r =
  70     let _ = Assets.Const.restore_if_nonex File.pFile lst in
  71     Ok r
  72   and
  73     (** URL router and HTTP middleware. *)
  74     dispatch (r : Cgi.Request.t) =
  75     (* Logr.debug (fun m -> m "%s.%s path_info '%s'" "Cgi" "handle.dispatch" r.path_info); *)
  76
  77     let (* send_file ct p = p
  78                          |> File.to_string
  79                          |> Http.clob_send uuid ct
  80            and *) (** Send an asset from inside the binary *)
  81       send_res ct p = match p |> Res.read with
  82       | None   -> Http.s500
  83       | Some b -> Http.clob_send uuid ct b
  84     and send_res' ct (Auth.Uid _,(r : Cgi.Request.t)) =
  85       match match r.path_info with
  86         | "/people" as p -> p ^ ".xml" |> Res.read
  87         | _ -> None with
  88       | None   -> Http.s404
  89       | Some s -> Http.clob_send uuid ct s
  90     and ases      = Iweb.ases tnow
  91     and auth      = Iweb.uid_redir
  92     and ban       = Ban.escalate Ban.cdb
  93     and base ()   = (* lazy, may not exist yet *) Cfg.Base.(from_file fn) |> Result.get_ok
  94     and csrf_ck v = Iweb.Token.(check fn v)
  95     and csrf_mk v = Ok Iweb.Token.(create ~uuid fn, v)
  96     and form (r : Cgi.Request.t) ic v =
  97       match r.content_length with
  98       | None   -> Http.s411
  99       | Some n -> if n < 0 || n > post_limit_b
 100         then Http.s413
 101         else try
 102             Ok (ic |> Html.Form.of_channel n, v)
 103           with _ -> Http.s400
 104     and rt        = Lwt.return
 105     and tz        = Timedesc.Time_zone.(local () |> Option.value ~default:utc)
 106     and s302
 107         ?(qs="")
 108         ?(header = [])
 109         p =
 110       r.script_name ^ p ^ qs
 111       |> Http.s302 ~header in
 112     let re = match r.path_info, r.request_method |> Cohttp.Code.method_of_string with
 113       | ("/doap.rdf" as p,             `GET) -> p |> send_res Http.Mime.text_xml |> rt
 114       | ("/LICENSE" as p,              `GET)
 115         (*
 116       | ("/var/lock/challenge" as p,   `GET) -> let f = "app" ^ p in f |> send_file Http.Mime.text_plain |> rt
 117     *)
 118       | ("/version" as p,              `GET) -> p |> send_res Http.Mime.text_plain |> rt
 119       | "/activitypub/actor.xml",      `GET  -> r |> ases >>= auth >>=               csrf_mk >>| Iweb.Actor.get ~base uuid
 120       | "/activitypub/actor.xml",      `POST -> r |> ases >>= auth >>= form r ic >>= csrf_ck >>| Iweb.Actor.post ~base uuid tnow
 121       | "/activitypub/actor.xml/icon", `GET  -> r |>                                             Iweb.Actor.Icon.get ~base uuid
 122       | "/activitypub/announce",       `GET  -> r |> ases >>= auth >>=               csrf_mk >>= Iweb.Announce.get ~base uuid tnow |> rt
 123       | "/activitypub/dislike",        `GET  -> r |> ases >>= auth >>=               csrf_mk >>= Iweb.Like.get ~undo:true ~base uuid tnow |> rt
 124       | "/activitypub/inbox.jsa",      `POST -> r |>                                             Is2s.Inbox.post ~base uuid tnow ic
 125       | "/activitypub/like",           `GET  -> r |> ases >>= auth >>=               csrf_mk >>= Iweb.Like.get ~base uuid tnow |> rt
 126       | "/backoffice/",                `GET  -> r |> ases >>= auth                           >>= Iweb.Health.get ~base uuid |> rt
 127       | "/http",                       `GET  -> r |> ases >>= auth                           >>| Iweb.Http_.get ~base uuid tnow
 128       | "/login",                      `GET  -> r |>                                 csrf_mk >>= Iweb.Login.get uuid |> rt
 129       | "/login",                      `POST -> r |>                   form r ic >>= csrf_ck >>= Iweb.Login.post uuid tnow ban |> rt
 130       | "/logout",                     `GET  -> r |> ases                                    >>= Iweb.Logout.get uuid |> rt
 131       (*
 132       | "/note",                       `GET  -> r |> ases >>= auth >>=               csrf_mk >>= Iweb.Note.get uuid |> rt
 133       *)
 134       | "/notifyme",                   `GET  -> r |> Result.ok                               >>| Iweb.Notifyme.get ~base uuid tnow
 135       | "/passwd",                     `GET  -> r |> ases >>= auth >>=               csrf_mk >>= Iweb.Passwd.get uuid |> rt
 136       | "/passwd",                     `POST -> r |> ases >>= auth >>= form r ic >>= csrf_ck >>= Iweb.Passwd.post uuid tnow |> rt
 137       | "/people",                     `GET  -> r |> ases >>= auth                           >>= send_res' Http.Mime.text_xml |> rt
 138       | "/ping",                       `GET  -> r |>                                             Iweb.Ping.get ~base uuid
 139       | "/edit",                       `GET
 140       | "/post",                       `GET  -> r |> ases >>= auth >>=               csrf_mk >>= Iweb.Post.get ~base uuid |> rt
 141       | "/edit",                       `POST
 142       | "/post",                       `POST -> r |> ases >>= auth >>= form r ic >>= csrf_ck >>| Iweb.Post.post ~base uuid tnow
 143       | "/profile",                    `GET  -> r |> ases >>= auth >>=               csrf_mk >>= Iweb.Profile.get uuid |> rt
 144       | "/profile",                    `POST -> r |> ases >>= auth >>= form r ic >>= csrf_ck >>= Iweb.Profile.post uuid tnow |> rt
 145       | "/search",                     `GET  -> r |> ases >>= auth >>=                           Iweb.Search.get ~base uuid |> rt
 146       | "/session",                    `GET  -> r |> ases                                    >>= Iweb.Session.get uuid |> rt
 147       | "/timeline/",                  `GET  -> "p/" |> Http.s302 |> rt
 148       | "/tools",                      `GET  -> Http.s501 |> rt
 149       | "/tools",                      `POST -> Http.s501 |> rt
 150       | "/webfinger",                  `GET  -> r |>                                             Iweb.Webfing.get uuid
 151       | "/",                           `GET  -> ".." |> Http.s302 |> rt
 152       | "",                            `GET when "" = r.query_string -> Http.s302 "." |> rt
 153       | "",                            `GET  -> (let ur = r |> Cgi.Request.path_and_query in
 154                                                  (* shaarli compatibility *)
 155                                                  match "do" |> Uri.get_query_param ur with
 156                                                  | Some "login"     -> s302 Iweb.Login.path
 157                                                  | Some "logout"    -> s302 Iweb.Logout.path
 158                                                  | Some "configure" -> s302 Iweb.Profile.path
 159                                                  | _                  ->
 160                                                    (* accessing random urls leads to a ban, eventually *)
 161                                                    ban tnow r.remote_addr;
 162                                                    Http.s404
 163                                                 ) |> rt
 164       | _,                             `GET when r |> Iweb.Timeline.can_handle                 -> r |> ases >>= auth >>=     Iweb.Timeline.get ~tz ~base uuid tnow |> rt
 165       | _,                             `GET when r |> Iweb.Webfing.can_handle ~prefix:"/@"     -> r |> Iweb.Webfing.do_handle ~prefix:"/@"     |> rt
 166       | _,                             `GET when r |> Iweb.Webfing.can_handle ~prefix:"/acct:" -> r |> Iweb.Webfing.do_handle ~prefix:"/acct:" |> rt
 167       | _,                             `HEAD -> Http.s405 |> rt
 168       | _ ->
 169         (* accessing random urls leads to a ban, eventually *)
 170         ban tnow r.remote_addr;
 171         Http.s404 |> rt in
 172     re |> Lwt_main.run
 173   and
 174     (** Unite Ok and Error and write response. *)
 175     merge (x : (Cgi.Response.t, Cgi.Response.t) result) : Cgi.Response.t =
 176     let (status,_,_) as x = match x with
 177       | Ok x    -> x
 178       | Error x -> x in
 179     Logr.info (fun m -> m "%s.%s %a dt=%.3fs HTTP %s %s %s -> localhost%a"
 180                   "Cgi" "handle"
 181                   Uuidm.pp uuid
 182                   (Sys.time() -. t0)
 183                   (status |> Cohttp.Code.string_of_status)
 184                   req.request_method
 185                   req.remote_addr
 186                   Uri.pp (req |> Cgi.Request.path_and_query));
 187     x in
 188   Ok req
 189   >>= Ban.(check_req (prepare_cdb cdb) tnow)
 190   >>= Iweb.redir_if_cgi_bin
 191   >>= Assets.Const.(restore_assets all)
 192   >>= redir_if_passwd_nonex
 193   >>= dispatch
 194   |> merge