seppo/bin/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
open Astring

let ( let* ) = Result.bind
let ( >>= )  = Result.bind
let ( >>| ) a b = match a with
  | Error _ as e -> Lwt.return e
  | Ok a -> b a

let post_limit_b = 2 * 1024

(* Handle incoming HTTP requests.
 *
 * Has the
 * - brue force mitigation ban,
 * - initial setup,
 * - asset restore,
 * - URL router (dispatch),
 * - session enforcement
 * - /ping loop
 * and delegates to the logic in Iweb (UI webinterface) or Is2s (ActivityPub Server to Server endpoint)
 *
 * Still does a Lwt_main.run that preferably owuld be outside
*)
let handle uuid tnow ic (req : Cgi.Request.t) : Cgi.Response.t =
  let t0 = Sys.time() in
  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);
  assert (not (req.path_info |> St.is_prefix ~affix:("/" ^ Cfg.seppo_cgi)));
  (** redirect to password reset if non exists *)
  let redir_if_passwd_nonex (r : Cgi.Request.t) =
    let loc = Iweb.Passwd.path in
    if Auth.fn |> File.exists
    || r.path_info |> String.equal loc
    then Ok r
    else
      (* start a 'recovery' session *)
      let* _,sec = Cfg.ServerSession.create tnow
                   |> Option.to_result ~none:Http.s500' in
      let header = [ Iweb.ClientCookie.new_session ~tnow sec req Auth.dummy ] in
      Cfg.seppo_cgi ^ loc |> Http.s302 ~header
  and restore_assets lst r =
    let _ = Assets.Const.restore_if_nonex File.pFile lst in
    Ok r
  and
    (** URL router and HTTP middleware. *)
    dispatch (r : Cgi.Request.t) =
    (* Logr.debug (fun m -> m "%s.%s path_info '%s'" "Cgi" "handle.dispatch" r.path_info); *)

    let (* send_file ct p = p
                         |> File.to_string
                         |> Http.clob_send uuid ct
           and *) (** Send an asset from inside the binary *)
      send_res ct p = match p |> Res.read with
      | None   -> Http.s500
      | Some b -> Http.clob_send uuid ct b
    and send_res' ct (Auth.Uid _,(r : Cgi.Request.t)) =
      match match r.path_info with
        | "/people" as p -> p ^ ".xml" |> Res.read
        | _ -> None with
      | None   -> Http.s404
      | Some s -> Http.clob_send uuid ct s
    and ases      = Iweb.ases tnow
    and auth      = Iweb.uid_redir
    and ban       = Ban.escalate Ban.cdb
    and base ()   = (* lazy, may not exist yet *) Cfg.Base.(from_file fn) |> Result.get_ok
    and csrf_ck v = Iweb.Token.(check fn v)
    and csrf_mk v = Ok Iweb.Token.(create ~uuid fn, v)
    and form (r : Cgi.Request.t) ic v =
      match r.content_length with
      | None   -> Http.s411
      | Some n -> if n < 0 || n > post_limit_b
        then Http.s413
        else try
            Ok (ic |> Html.Form.of_channel n, v)
          with _ -> Http.s400
    and rt        = Lwt.return
    and tz        = Timedesc.Time_zone.(local () |> Option.value ~default:utc)
    and s302
        ?(qs="")
        ?(header = [])
        p =
      r.script_name ^ p ^ qs
      |> Http.s302 ~header in
    let re = 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 |> rt
      | ("/LICENSE" as p,              `GET)
        (*
      | ("/var/lock/challenge" as p,   `GET) -> let f = "app" ^ p in f |> send_file Http.Mime.text_plain |> rt
    *)
      | ("/version" as p,              `GET) -> p |> send_res Http.Mime.text_plain |> rt
      | "/activitypub/actor.xml",      `GET  -> r |> ases >>= auth >>=               csrf_mk >>| Iweb.Actor.get ~base uuid
      | "/activitypub/actor.xml",      `POST -> r |> ases >>= auth >>= form r ic >>= csrf_ck >>| Iweb.Actor.post ~base uuid tnow
      | "/activitypub/actor.xml/icon", `GET  -> r |>                                             Iweb.Actor.Icon.get ~base uuid
      | "/activitypub/announce",       `GET  -> r |> ases >>= auth >>=               csrf_mk >>= Iweb.Announce.get ~base uuid tnow |> rt
      | "/activitypub/dislike",        `GET  -> r |> ases >>= auth >>=               csrf_mk >>= Iweb.Like.get ~undo:true ~base uuid tnow |> rt
      | "/activitypub/inbox.jsa",      `POST -> r |>                                             Is2s.Inbox.post ~base uuid tnow ic
      | "/activitypub/like",           `GET  -> r |> ases >>= auth >>=               csrf_mk >>= Iweb.Like.get ~base uuid tnow |> rt
      | "/backoffice/",                `GET  -> r |> ases >>= auth                           >>= Iweb.Health.get ~base uuid |> rt
      | "/http",                       `GET  -> r |> ases >>= auth                           >>| Iweb.Http_.get ~base uuid tnow
      | "/login",                      `GET  -> r |>                                 csrf_mk >>= Iweb.Login.get uuid |> rt
      | "/login",                      `POST -> r |>                   form r ic >>= csrf_ck >>= Iweb.Login.post uuid tnow ban |> rt
      | "/logout",                     `GET  -> r |> ases                                    >>= Iweb.Logout.get uuid |> rt
      (*
      | "/note",                       `GET  -> r |> ases >>= auth >>=               csrf_mk >>= Iweb.Note.get uuid |> rt
      *)
      | "/notifyme",                   `GET  -> r |> Result.ok                               >>| Iweb.Notifyme.get ~base uuid tnow
      | "/passwd",                     `GET  -> r |> ases >>= auth >>=               csrf_mk >>= Iweb.Passwd.get uuid |> rt
      | "/passwd",                     `POST -> r |> ases >>= auth >>= form r ic >>= csrf_ck >>= Iweb.Passwd.post uuid tnow |> rt
      | "/people",                     `GET  -> r |> ases >>= auth                           >>= send_res' Http.Mime.text_xml |> rt
      | "/ping",                       `GET  -> r |>                                             Iweb.Ping.get ~base uuid
      | "/edit",                       `GET
      | "/post",                       `GET  -> r |> ases >>= auth >>=               csrf_mk >>= Iweb.Post.get ~base uuid |> rt
      | "/edit",                       `POST
      | "/post",                       `POST -> r |> ases >>= auth >>= form r ic >>= csrf_ck >>| Iweb.Post.post ~base uuid tnow
      | "/profile",                    `GET  -> r |> ases >>= auth >>=               csrf_mk >>= Iweb.Profile.get uuid |> rt
      | "/profile",                    `POST -> r |> ases >>= auth >>= form r ic >>= csrf_ck >>= Iweb.Profile.post uuid tnow |> rt
      | "/search",                     `GET  -> r |> ases >>= auth >>=                           Iweb.Search.get ~base uuid |> rt
      | "/session",                    `GET  -> r |> ases                                    >>= Iweb.Session.get uuid |> rt
      | "/timeline/",                  `GET  -> "p/" |> Http.s302 |> rt
      | "/tools",                      `GET  -> Http.s501 |> rt
      | "/tools",                      `POST -> Http.s501 |> rt
      | "/webfinger",                  `GET  -> r |>                                             Iweb.Webfing.get uuid
      | "/",                           `GET  -> ".." |> Http.s302 |> rt
      | "",                            `GET when "" = r.query_string -> Http.s302 "." |> rt
      | "",                            `GET  -> (let ur = r |> Cgi.Request.path_and_query in
                                                 (* shaarli compatibility *)
                                                 match "do" |> Uri.get_query_param ur with
                                                 | Some "login"     -> s302 Iweb.Login.path
                                                 | Some "logout"    -> s302 Iweb.Logout.path
                                                 | Some "configure" -> s302 Iweb.Profile.path
                                                 | _                  ->
                                                   (* accessing random urls leads to a ban, eventually *)
                                                   ban tnow r.remote_addr;
                                                   Http.s404
                                                ) |> rt
      | _,                             `GET when r |> Iweb.Timeline.can_handle                 -> r |> ases >>= auth >>=     Iweb.Timeline.get ~tz ~base uuid tnow |> rt
      | _,                             `GET when r |> Iweb.Webfing.can_handle ~prefix:"/@"     -> r |> Iweb.Webfing.do_handle ~prefix:"/@"     |> rt
      | _,                             `GET when r |> Iweb.Webfing.can_handle ~prefix:"/acct:" -> r |> Iweb.Webfing.do_handle ~prefix:"/acct:" |> rt
      | _,                             `HEAD -> Http.s405 |> rt
      | _ ->
        (* accessing random urls leads to a ban, eventually *)
        ban tnow r.remote_addr;
        Http.s404 |> rt in
    re |> Lwt_main.run
  and
    (** Unite Ok and Error and write response. *)
    merge (x : (Cgi.Response.t, Cgi.Response.t) result) : Cgi.Response.t =
    let (status,_,_) as x = match x with
      | Ok x    -> x
      | Error x -> x in
    Logr.info (fun m -> m "%s.%s %a dt=%.3fs HTTP %s %s %s -> localhost%a"
                  "Cgi" "handle"
                  Uuidm.pp uuid
                  (Sys.time() -. t0)
                  (status |> Cohttp.Code.string_of_status)
                  req.request_method
                  req.remote_addr
                  Uri.pp (req |> Cgi.Request.path_and_query));
    x in
  Ok req
  >>= Ban.(check_req (prepare_cdb cdb) tnow)
  >>= Iweb.redir_if_cgi_bin
  >>= Assets.Const.(restore_assets all)
  >>= redir_if_passwd_nonex
  >>= dispatch
  |> merge