123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238 |
- (*
- * _ _ ____ _
- * _| || |_/ ___| ___ _ __ _ __ ___ | |
- * |_ .. _\___ \ / _ \ '_ \| '_ \ / _ \| |
- * |_ _|___) | __/ |_) | |_) | (_) |_|
- * |_||_| |____/ \___| .__/| .__/ \___/(_)
- * |_| |_|
- *
- * 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/>.
- *)
- (* 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
- let pFile = 0o644
- 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
- 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) *)
- 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
- let in_channel fn rdr =
- in_channel' rdr fn
- let out_channel' ?(tmp = Some "~") ?(mode = [ Open_append; Open_binary; Open_creat; Open_wronly ]) ?(perm = pFile) 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
- let out_channel ?(tmp = Some "~") ?(mode = [ Open_append; Open_binary; Open_creat; Open_wronly ]) ?(perm = pFile) fn wrtr =
- out_channel' ~tmp ~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 cp' ?(buf = 16 * 0x400 |> Bytes.create) src oc =
- let ic = open_in_gen [ Open_rdonly; Open_binary ] 0 src in
- ic |> copy_channel ~buf oc;
- close_in ic
- let restore_static ?(perm = pFile) fn =
- if fn |> exists
- then None
- else
- let _ = fn |> Filename.dirname |> mkdir_p pDir in
- fn |> out_channel' ~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 hd_tl (ch : char) (str : string) : (string * string) option =
- Option.bind
- (String.index_opt str ch)
- (fun len ->
- let hd = String.sub str 0 len
- and tl = let pp1 = len + 1 in
- String.sub str pp1 ((String.length str) - pp1)
- in Some (hd, tl))
- let hd (ch : char) (str : string) : string option =
- Option.bind
- (hd_tl ch str)
- (fun (s,_) -> Some s)
- let tl (ch : char) (str : string) : string option =
- Option.bind
- (hd_tl ch str)
- (fun (_,s) -> Some s)
- end
|