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

open Astring

(* rather leverage fileutils? *)

let rec find_path_tail predicate ?(prfx = "") ?(sep = "/") lst =
  match lst with
  | [] -> Error "not found"
  | hd :: tl ->
    let prfx = sep ^ hd ^ prfx in
    match predicate prfx with
    | Error _ as e -> e
    | Ok true -> Ok prfx
    | Ok false -> find_path_tail predicate ~prfx ~sep tl

let mtime_0 ?(default = 0.) fn =
  (* Logr.debug (fun m -> m "mtime_0 %s" fn); *)
  try (Unix.stat fn).st_mtime
  with
  | _ -> default

let pDir = 0o755
(** typical permissions (directories) *)

let pFile = 0o644
(** typical permissions (files) *)

let pFileRO = 0o444

let rec mkdir_p perm n =
  (* TODO should we block anything starting with / or . ? *)
  match Sys.file_exists n with
  | true -> Ok n
  | false -> (
      match n |> Filename.dirname |> mkdir_p perm with
      | Ok _ -> (
          Unix.(try
                  mkdir n perm;
                  Ok n
                with Unix_error (n, a, b) ->
                  Error ((n |> error_message) ^ ": " ^ a ^ " " ^ b)))
      | e -> e)

let _chdir f d =
  Logr.debug (fun m -> m "%s.%s %s" "File" "chdir" d);
  let cwd = Unix.getcwd () in
  let _ = mkdir_p pDir d in
  Unix.chdir d;
  let r = f () in
  Unix.chdir cwd;
  r

(** similar to List.fold_left but for dirctory contents. Low level.
 *  f init fn:     fn is the filename local to the directory
 *  init:          aggregate
 *  dn:            directory name
*)
let fold_dir f init dn =
  try let dh = dn |> Unix.opendir in
    let rec next init =
      try
        match dh
              |> Unix.readdir
              |> f init with
        | init,false -> init
        | init,true  -> init |> next
      with End_of_file -> init
    in
    let ret = next init in
    dh |> Unix.closedir;
    ret
  with Unix.(Unix_error(ENOENT, "opendir", _)) -> init

let count_dir ?(max = Int.max_int) ?(pred = (fun f -> not (f = "." || f = ".."))) dn =
  fold_dir (fun count fn ->
      let count = count + if pred fn
                  then 1
                  else 0 in
      (count,count < max))
    0 dn

let any pred d : string option =
  (* use File.fold_dir? *)
  let wa = Unix.opendir d in
  let rec loop () =
    try
      let fn = wa |> Unix.readdir in
      if pred fn
      then Some fn
      else loop ()
    with End_of_file -> None
  in
  let r = loop () in
  Unix.closedir wa;
  r

let exists = Sys.file_exists

(* evtl. https://rosettacode.org/wiki/Read_entire_file#OCaml *)
let to_bytes (fn : string) : bytes =
  try
    let len = (Unix.stat fn).st_size in
    let ic = open_in_gen [ Open_binary; Open_rdonly ] 0 fn in
    let buf = Bytes.create len in
    really_input ic buf 0 len;
    close_in ic;
    buf
  with _ -> Bytes.empty

let to_string fn = fn
                   |> to_bytes
                   |> Bytes.to_string

let cat fn = try
    fn |> to_string |> Result.ok
  with
  | Sys_error e -> Error e
  | Invalid_argument e -> Error e
(* | End_of_file -> Error ("error reading file " ^ fn) *)

(** open, read, close a file.
 *
 * rdr       the receiving function
 * fn        filename
*)
let in_channel rdr fn =
  let ic = open_in_gen [ Open_rdonly; Open_binary ] 0 fn in
  let ret = rdr ic in
  close_in ic;
  ret

(** generic write - don't use directly.*)
let out_channel' ~tmp ~mode ~perm wrtr fn =
  Logr.debug (fun m -> m "%s.%s %s cwd: %s" "File" "out_channel" fn (Unix.getcwd ()));
  let fn' = match tmp with
    | None     -> fn
    | Some "~" -> fn ^ "~"
    | Some s   -> s in
  let oc = open_out_gen mode perm fn' in
  let ret = wrtr oc in
  oc |> close_out;
  if tmp |> Option.is_some
  then Unix.rename fn' fn;
  ret

(** atomic write.
    @TODO aquire on exclusive lock? *)
let out_channel_append ?(mode = [ Open_append; Open_binary; Open_creat; Open_wronly; ]) ?(perm = pFile) wrtr fn =
  assert (mode |> List.exists (function Open_append -> true | _ -> false));
  assert (mode |> List.exists (function Open_trunc -> true | _ -> false) |> not);
  assert (mode |> List.exists (function Open_wronly -> true | _ -> false));
  out_channel' ~tmp:None ~mode ~perm wrtr fn

(** atomic write.

    I'm not convinced that https://notes.eatonphil.com/2024-09-29-build-a-serverless-acid-database-with-this-one-neat-trick.html#a-filesystem-blob-store
    would be enough: O_CREAT | O_EXCL. *)
let out_channel_replace ?(tmp = "~") ?(mode = [ Open_binary; Open_creat; Open_trunc; Open_wronly; ]) ?(perm = pFile) wrtr fn =
  assert (mode |> List.exists (function Open_append -> true | _ -> false) |> not);
  assert (mode |> List.exists (function Open_trunc  -> true | _ -> false));
  assert (mode |> List.exists (function Open_wronly -> true | _ -> false));
  out_channel' ~tmp:(Some tmp) ~mode ~perm wrtr fn

let out_channel_create ?(tmp = "~") ?(mode = [ Open_binary; Open_creat; Open_excl; Open_wronly; ]) ?(perm = pFile) wrtr fn =
  assert (mode |> List.exists (function Open_append -> true | _ -> false) |> not);
  assert (mode |> List.exists (function Open_excl   -> true | _ -> false));
  assert (mode |> List.exists (function Open_trunc  -> true | _ -> false) |> not);
  assert (mode |> List.exists (function Open_wronly -> true | _ -> false));
  out_channel' ~tmp:(Some tmp) ~mode ~perm wrtr fn

(** non-atomic write inside a file *)
let out_channel_patch ?(mode = [ Open_binary; Open_wronly; ]) ?(perm = pFile) wrtr fn =
  assert (mode |> List.exists (function Open_append -> true | _ -> false) |> not);
  assert (mode |> List.exists (function Open_trunc  -> true | _ -> false) |> not);
  assert (mode |> List.exists (function Open_wronly -> true | _ -> false));
  out_channel' ~tmp:None ~mode ~perm wrtr fn

let touch fn =
  fn
  |> open_out_gen [ Open_append; Open_binary; Open_creat; Open_wronly; ] pFileRO
  |> close_out

let copy_channel ?(buf = 16 * 0x400 |> Bytes.create) oc ic =
  (* primitive take copy inspired by
     https://sylvain.le-gall.net/ocaml-fileutils.html *)
  let len = buf |> Bytes.length in
  let r = ref 0 in
  while r := input ic buf 0 len;
    !r <> 0
  do
    output oc buf 0 !r
  done

let restore_static ?(perm = pFile) fn =
  if fn |> exists
  then None
  else
    let _ = fn |> Filename.dirname |> mkdir_p pDir in
    fn |> out_channel_replace ~perm (fun oc ->
        match Res.read ("static/" ^ fn) with
        | None ->
          Logr.err (fun m -> m "%s missing %s" E.e1028 fn);
          None
        | Some str as r ->
          str |> output_string oc;
          Logr.info (fun m -> m "unpacked %s" fn);
          r )

let fold_lines f init ic =
  let rec next_line init' =
    try
      ic
      |> input_line
      |> f init'
      |> next_line
    with
    | End_of_file -> init'
  in
  next_line init

let fold_bind_lines f init ic =
  let ( let* ) = Result.bind in
  let rec next_line init' =
    try
      let* init' = ic |> input_line |> f init' in
      next_line init'
    with
    | End_of_file -> Ok init'
  in
  next_line init

module Path = struct
  let sep = String.of_char '/'

  let hd (ch : char) (str : string) : string option =
    assert (ch = '/');
    Option.bind
      (String.cut ~sep str)
      (fun (s,_) -> Some s)

  let tl (ch : char) (str : string) : string option =
    assert (ch = '/');
    Option.bind
      (String.cut ~sep str)
      (fun (_,s) -> Some s)
end