seppo/lib/ban.ml

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

(** Brute force mitigation HTTP 429,
 * https://www.rfc-editor.org/rfc/rfc6585#section-4 *)

let fn  = "app/var/run/ipban.cdb"
let cdb = Mapcdb.Cdb fn

let prepare_cdb (db : Mapcdb.cdb) : Mapcdb.cdb =
  (* don't log in case banned *)
  let Cdb db' = db in
  let _ = db' |> File.restore_static in
  db

let chunk_s = 600.

(* if expiry sooner than 2 chunks in the future: None *)
let check (db : Mapcdb.cdb) (tnow : Ptime.t) (k : string) : Ptime.t option =
  (* Logr.debug (fun m -> m "%s.%s %s" "Ban" "check" k); *)
  Option.bind
    (Mapcdb.find_string_opt k db)
    (fun t ->
       let noban v = Logr.debug (fun m -> m "%s.%s %s not banned (%s)" "Ban" "check" k v);
         None in
       (* Logr.debug (fun m -> m "%s.%s check %s" "Ban" "check" t); *)
       match t |> Ptime.of_rfc3339 with
       | Ok (t, _, _) ->
         let dt = 2. *. chunk_s |> Ptime.Span.of_float_s |> Option.get in
         let than = Ptime.sub_span t dt |> Option.get in
         if Ptime.is_earlier tnow ~than
         then (
           Logr.info (fun m -> m "%s.%s %s banned until %a" "Ban" "check" k Ptime.pp than);
           Some than)
         else noban "expired"
       | _ -> noban "time fail" (* is this too generous? *)
    )

let check_req (db : Mapcdb.cdb) (tnow : Ptime.t) (req : Cgi.Request.t) =
  match check db tnow req.remote_addr with
  | None   -> Ok req
  | Some t -> Http.s429_t t

(* add another chunk to the expiry in the ban db *)
let escalate db tnow addr : unit =
  let base = match Mapcdb.find_string_opt addr db with
    | None -> tnow
    | Some v ->
      match v |> Ptime.of_rfc3339 with
      | Ok (t, _, _) -> max tnow t
      | Error _      -> tnow
  in
  let expiry = chunk_s
               |> Ptime.Span.of_float_s |> Option.get
               |> Ptime.add_span base |> Option.get
               |> Ptime.to_rfc3339 in
  Logr.info (fun m -> m "%s.%s addr: %s expiry: %s" "Ban" "escalate" addr expiry);
  let _ = Mapcdb.update_string addr expiry db in
  Logr.warn (fun m -> m "%s.%s TODO use a predicate to remove expired entries." "Ban" "escalate")

let escalate_req db tnow (r : Cgi.Request.t)=
  Ok (escalate db tnow r.remote_addr)

(*
 *
 * # Brute force protect authentication.
 *
 * ## Requirements
 *
 * 1) persistence on disc,
 * 2) fast lookup if a given address (ip4 or ip6 string) is blacklisted and not
 * expired,
 * 3) add penalty and refresh expiry,
 * 4) housekeeping (unaccessed expiry)
 *
 * ## Caveats
 *
 * 1) mitigate DOS (be savy with CPU, files, space)
 * 2) fast negative answer (not banned)
 * 3) slow penalty, do the housekeeping here
 * 4) slow ban lift/expiry, too
 *
 * ## Possible storage
 *
 * - separate files named after address, timestamp expiry (evtl. with offset),
 * content severity
 * or
 * - one binary file mmapped as a Bigarray
 * or
 * - one fixed-line-length text file mmapped as a Bigstring
 * or
 * - one Csexp file
 *)