seppo/lib/cfg.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/>.
 *)

let seppo_cgi = "seppo.cgi"

let random_pwd () =
  (* 12*8 bits of entropy packed into 16 legible characters *)
  Random0.random_buffer 12
  |> Cstruct.to_string
  |> Base64.encode_string ~alphabet:Base64.uri_safe_alphabet

module Base = struct
  let fn = "app/etc/baseurl.s"

  let to_file fn u : (string,string) result =
    fn |> File.out_channel_replace (fun oc ->
        assert (u |> Uri.path |> St.is_prefix ~affix:"/");
        assert (u |> Uri.path |> St.is_suffix ~affix:"/");
        assert (not (u |> Uri.path |> St.is_suffix ~affix:"//"));
        Csexp.Atom (u
                    |> Uri.to_string)
        |> Csexp.to_channel oc;
        Ok fn)

  let from_file =
    File.in_channel (fun ic ->
        match ic |> Csexp.input with
        | Error _ as e -> e
        | Ok Csexp.Atom b ->
          let b = b |> Uri.of_string in
          assert (match b |> Uri.scheme with
              | Some "http"
              | Some "https" -> true
              | _ -> false);
          assert (b |> Uri.host |> Option.is_some);
          assert (b |> Uri.to_string |> St.is_suffix ~affix:"/");
          assert (not (b |> Uri.path |> St.is_suffix ~affix:"//"));
          assert (b |> Uri.fragment |> Option.is_none);
          assert (b |> Uri.query |> List.length = 0);
          Ok b
        | _ -> Error __LOC__ )
end

module ServerSession = struct
  let timeout tnow =
    30 * 60
    |> Ptime.Span.of_int_s
    |> Ptime.add_span tnow
    |> Option.value ~default:Ptime.min

  let fn = "app/var/run/session.s"
  let l32 = 32

  type t = Ptime.t * Cstruct.t

  let from_file fn =
    (* Logr.debug (fun m -> m "CookieSecret.from_file: %s" fn); *)
    let ( let* ) = Result.bind in
    try
      fn |> File.in_channel (fun ic ->
          let* t,l = match Csexp.input ic with
            | Error _ as e -> e
            | Ok Csexp.(List [Atom t; Atom s]) ->
              (match t |> Ptime.of_rfc3339 with
               | Ok (t,_,_) -> Ok (t,s |> Cstruct.of_string)
               | Error _    -> Error "expected rfc3339"
              )
            | _ -> Error "expected cookie secret" in
          assert (l32 = (l |> Cstruct.length));
          Ok (t,l))
    with _ -> Error "not found"

  let create ?(fn = fn) ?(sec = Random0.random_buffer l32) tnow =
    assert (sec |> Cstruct.length = l32);
    Logr.debug (fun m -> m "%s.%s" "Cfg.CookieSecret" "create_session");
    let te = tnow |> timeout in
    let r = te,sec in
    fn |> File.out_channel_replace (fun oc ->
        Csexp.(List [
            Atom (te |> Ptime.to_rfc3339);
            Atom (sec |> Cstruct.to_string);
          ])
        |> Csexp.to_channel oc);
    Some r

  let delete_session ?(fn = fn) () =
    Unix.unlink fn

  let valid_secret tnow ((to_,sec) : t) =
    if Ptime.is_later to_ ~than:tnow
    then Some sec
    else None
end

module Profile = struct
  type t = {
    title    : string; (* similar atom:subtitle *)
    bio      : string; (* similar atom:description *)
    language : Rfc4287.rfc4646;
    timezone : Timedesc.Time_zone.t;
    posts_per_page : int;
  }

  let validate p : (t, 'a) result =
    Ok p

  let encode p =
    let Rfc4287.Rfc4646 language = p.language in
    let tz  : string = p.timezone |> Timedesc.Time_zone.name in
    let ppp : string = p.posts_per_page |> string_of_int in
    Csexp.(List [
        List [ Atom "title";     Atom p.title ] ;
        List [ Atom "bio";       Atom p.bio ] ;
        List [ Atom "language";  Atom language ] ;
        List [ Atom "timezone";  Atom tz ] ;
        List [ Atom "posts-per-page"; Atom ppp ] ;
      ])

  let decode = function
    | Ok Csexp.(List [
        List [ Atom "title";     Atom title ] ;
        List [ Atom "bio";       Atom bio ] ;
        List [ Atom "language";  Atom language ] ;
        List [ Atom "timezone";  Atom timezone ] ;
        List [ Atom "posts-per-page"; Atom posts_per_page ] ;
      ]) ->
      {
        title;
        bio;
        language = Rfc4287.Rfc4646 language;
        timezone = Timedesc.Time_zone.(timezone |> make |> Option.value ~default:Rfc3339.fallback);
        posts_per_page = posts_per_page |> int_of_string;
      }
      |> validate
    | Ok _ -> Error "profile field expectation failure"
    | Error _ as e -> e

  let from_file fn =
    try fn |> File.in_channel Csexp.input
        |> decode
    with
    | e ->
      Logr.err (fun m -> m "%s %a" __LOC__ St.pp_exc e);
      Error "failed to load profile from file"

  let to_file fn (p : t) =
    Logr.debug (fun m -> m "to_file '%s' ('%s')" fn p.title);
    fn |> File.out_channel_replace (fun oc ->
        p
        |> encode
        |> Csexp.to_channel oc;
        Ok fn )

  let fn = "app/etc/profile.s"

  let load
      ?(tz = Rfc3339.fallback)
      fn : t =
    let defa posts_per_page timezone : t =
      let language = Rfc4287.Rfc4646 "en"
      and title = "Yet Another #Seppo! 🌻"
      and bio = {|#Seppo — Personal Social Web. For you!

Hooray! You successfully put the file seppo.cgi from https://Seppo.Social/en/support/#installation on your webspace, visited it and are now enjoying networking in the fediverse!

#Seppo is an https://W3.org/TR/ActivityPub fediverse server software of unsurpassed sustainability and respects the https://permacomputing.net/Principles/. It has a minimal resource and carbon footprint and is built to work for decades without maintenance. Shared webspace is sufficient, no privileged access ('root') required. The seppo.cgi is active only in the moments you are sending and receiving posts. Your casual visitors won't ever use it. They get static files from your webspace. By renting that, your provider cares for security and you may sleep untroubled!

CGIs entered the stage 1997 and drove the dotcom boom. Later on they got a bad name, mostly because they don't scale well to big numbers and can't serve millions of users at a time. Many younger developers are unaware of them. However, you are not a million users, you are just one! A CGI can very well serve one, it even has favourable security properties in this case. And remember, your visitors won't use the CGI.|}
      in {title;bio;language;timezone;posts_per_page}
    in
    match from_file fn with
    | Ok p -> p
    | Error e ->
      Logr.warn (fun m -> m "%s.%s: %s" "Cfg.Profile" "load" e);
      defa
        50
        tz
end

module Urlcleaner = struct

  let fn = "app/etc/url-cleaner.s"

  type t = {
    rex : string;
    rep : string;
  }

  let is_valid v : (t, 'a) result = Ok v

  let of_file _fn =
    Error "not implemented yet"

  let apply' _c _s =
    Error "not implemented yet"

  let apply _l _s =
    Error "not implemented yet"
end