seppo/lib/storage.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 ( let* ) = Result.bind
let ( >>= ) = Result.bind

let pre        = "app/var/db/"
let fn         = pre ^ "o/p.s"
let fn_id_cdb  = Mapcdb.Cdb (pre ^ "o/id.cdb")
let fn_url_cdb = Mapcdb.Cdb (pre ^ "o/url.cdb")
let fn_t_cdb   = Mapcdb.Cdb (pre ^ "o/t.cdb")

module Fifo = struct
  type t        = string * int

  let make size fn =
    (fn,size)

  let push byt (fn,size) =
    let sep = '\n' in
    let len = byt |> Bytes.length in
    let keep = size - len - 1 in
    let mode = [ Open_append; Open_binary; Open_creat; Open_wronly ] in
    if keep < try (Unix.stat fn).st_size with _ -> 0
    then (* make space and add *)
      let ret = len |> Bytes.create in
      let buf = keep |> Bytes.create in
      File.in_channel fn (fun ic ->
          really_input ic ret 0 len;
          let _ = input_char ic in
          really_input ic buf 0 keep );
      File.out_channel ~mode fn (fun oc ->
          output_bytes oc buf;
          output_bytes oc byt;
          output_char oc sep
        );
      Some ret
    else (* just add *)
      (File.out_channel ~tmp:None ~mode fn (fun oc ->
           output_bytes oc byt;
           output_char oc sep
         );
       None)
end

let id_to_b id =
  id |> Uri.to_string |> Bytes.of_string

(* a tuple of two (file) positions *)
module TwoPad10 = struct
  let length = 28
  type t = int * int

  let to_string (a,b : t) =
    (* write a canonical s-expression in one go *)
    let r = Printf.sprintf "(10:0x%08x10:0x%08x)" a b in
    assert (length == (r |> String.length));
    r

  let decode (sx : Csexp.t) : (t,'a) result =
    let h2i = int_of_string in
    match sx with
    | Csexp.(List [Atom p0; Atom p1]) -> Ok (h2i p0, h2i p1)
    | _                               -> Error "couldn't decode"

  let decode_many l : t list =
    let h2i = int_of_string in
    l |> List.fold_left (fun init e ->
        match e with
        | Csexp.(List [Atom p0; Atom p1]) -> (h2i p0, h2i p1) :: init
        | _                               -> init) []
    |> List.rev

  let fold_decode a (_ : (Csexp.t,'a) result) =
    a

  let from_channel ic =
    match Csexp.input_many ic with
    | Error _ -> []
    | Ok l -> decode_many l

  let from_file = File.in_channel' from_channel

  (* @todo consolidate with page *)
  let id_to_page_i id : ((string*int)*int,string) result=
    let jig = "%-%/" |> Make.Jig.make in
    match id |> Uri.path |> Make.Jig.cut jig,
          id |> Uri.fragment with
    | Some [b;j] , Some i ->
      (try
         Ok ((b,j |> int_of_string)
            , i |> int_of_string)
       with Failure e -> Error e)
    | _   -> Error "no index given"

  let from_page_i ?(prefix = pre) ((fn,j),i) : (t,string) result =
    let jig = prefix ^ "%/%.s" |> Make.Jig.make in
    let l : t list = [fn;j |> string_of_int]
                     |> Make.Jig.paste jig
                     |> Option.get
                     |> from_file in
    try Ok (i |> List.nth l)
    with _ -> Error "not found"

  let from_id ?(prefix = pre) id : (t,string) result =
    id
    |> id_to_page_i
    >>= from_page_i ~prefix

  let strut (p0,p1 : t) =
    assert (p0 >= 0);
    assert (p1 - p0 - 6 >= 0);
    let l0,l1 = match p1 - p0 - 6 with
      |             0 as n -> 0,n - 0
      |            10 as n -> 1,n - 1
      |           101 as n -> 1,n - 2
      |         1_002 as n -> 1,n - 3
      |        10_003 as n -> 1,n - 4
      |       100_004 as n -> 1,n - 5
      |     1_000_005 as n -> 1,n - 6
      |    10_000_006 as n -> 1,n - 7
      |   100_000_007 as n -> 1,n - 8
      | 1_000_000_008 as n -> 1,n - 9
      | n ->
        let n'   = n |> float_of_int in
        let dec' = n' |> log10 |> floor in
        let dec  = n' -. dec' |> log10 |> int_of_float in
        0,n - dec
    in
    let fil = 'x' in
    let r = Csexp.(List [Atom (String.make l0 fil); Atom (String.make l1 fil)]) in
    Logr.debug (fun m -> m "%s.%s %d" "Storage" "strut" (p1-p0));
    assert ((p1-p0) == (r |> Csexp.to_string |> String.length));
    r
end

(* hydrate entry (from main storage) *)
let fold_of_twopad10 ?(fn = fn) a p =
  (* read entry from main storage *)
  let of_twopad10 (p0,p1 : TwoPad10.t) : (Csexp.t,'a) result =
    let ipt ic =
      seek_in ic p0;
      assert (pos_in ic = p0);
      let r = Csexp.input ic in
      assert (pos_in ic = p1);
      r
    in
    fn |> File.in_channel' ipt
  in
  let ( >>= ) = Result.bind in
  (p
   |> TwoPad10.decode
   >>= of_twopad10
   >>= Rfc4287.Entry.decode)
  :: a

module Page = struct
  type t = string * int

  let jig = pre ^ "%/%.s" |> Make.Jig.make

  let of_fn fn : t option =
    match fn |> Make.Jig.cut jig with
    | Some [a;b] ->
      assert (a |> St.starts_with ~prefix:"o/");
      Some (a,b |> int_of_string)
    | _          -> None

  let to_fn (a,b : t) =
    assert (a |> St.starts_with ~prefix:"o/");
    [a;b |> string_of_int]
    |> Make.Jig.paste jig
    |> Option.get

  let to_posn (p : t) : TwoPad10.t list =
    p
    |> to_fn
    |> TwoPad10.from_file

  let find_max ?(prefix = pre) (dir,_ : t) : t option =
    assert (dir |> St.starts_with ~prefix:"o/");
    assert (not (dir |> St.ends_with ~suffix:"/"));
    let mx = File.fold_dir (fun c fn ->
        (try Scanf.sscanf fn "%d.s" (fun i -> i)
         with _ -> -1)
        |> max c,true)
        (-1) (prefix ^ dir) in
    if mx < 0
    then None
    else Some (dir,mx)

  let jig2 = "%-%/" |> Make.Jig.make

  let of_id id : (t * int,string) result =
    try
      match id |> Uri.path |> Make.Jig.cut jig2,
            id |> Uri.fragment with
      | Some [fn;p],Some i ->
        assert (fn |> St.starts_with ~prefix:"o/");
        assert (not (fn |> St.ends_with ~suffix:"/"));
        Ok ((fn,p |> int_of_string),i |> int_of_string)
      | _   -> Error "no index given"
    with Failure e -> Error e

  let modify_idx fu (a,x : t) : t =
    (a,x |> fu)

  let pred = modify_idx Int.pred
  let succ = modify_idx Int.succ

  let to_int = function
    | Some (_,x : t) -> x
    | _ -> -1

  (* the next id and page *)
  let next_id ~items_per_page (dir,_ as pa : t) : (Uri.t * t) =
    (* Logr.debug (fun m -> m "%s.%s %s" "Storage" "next_id" dir); *)
    assert (dir |> St.starts_with ~prefix:"o/");
    assert (not (dir |> St.ends_with ~suffix:"/"));
    let bytes_per_item = TwoPad10.length in
    (* get the previously highest index number and name *)
    let _ = pa |> to_fn |> Filename.dirname |> File.mkdir_p File.pDir in
    let pg,i =
      match pa |> find_max with
      | None ->
        (* Logr.debug (fun m -> m "%s.%s first %s" "Storage" "next_id" dir); *)
        0,0
      | Some (di,pg) ->
        assert (di |> String.equal dir);
        let pa = (dir,pg) in
        let i = (try (pa |> to_fn |> Unix.stat).st_size
                 with _ -> 0) / bytes_per_item in
        if i < items_per_page
        then pg,i
        else pg+1,0
    in
    assert (pg >= 0);
    assert (i >= 0);
    assert (i < items_per_page);
    let j = "%-%/#%" |> Make.Jig.make in
    let v = [dir;pg |> string_of_int;i |> string_of_int] in
    let id = v |> Make.Jig.paste j |> Option.get |> Uri.of_string in
    Logr.debug (fun m -> m "%s.%s %a" "Storage" "next_id" Uri.pp id);
    assert (id |> Uri.to_string |> St.starts_with ~prefix:"o/");
    id,(dir,pg)

  let apnd (_,b as pa) pos =
    assert (b >= 0);
    assert (TwoPad10.length == (pos |> Bytes.length));
    pa
    |> to_fn
    |> File.out_channel' ~tmp:None (fun oc -> output_bytes oc pos)

  let append (pa : t) (pos : TwoPad10.t) =
    let by = pos
             |> TwoPad10.to_string
             |> Bytes.of_string in
    by |> apnd pa;
    by

  let _remake fn ix =
    (* add csexp entry to .s and return (id,position) tuple *)
    let add_1_csx oc sx =
      let ol = pos_out oc in
      sx |> Csexp.to_channel oc;
      let ne = pos_out oc in
      let id = match sx |> Rfc4287.Entry.decode with
        | Error _ -> None
        | Ok r    -> Some r.id in
      (id,(ol,ne)) in
    (* if Some id call fkt with id->(ol,ne) *)
    let add_1_p fkt = function
      | (None,_v)    -> Logr.warn (fun m -> m "add a strut?")
      | (Some id,v)  -> fkt (id_to_b id, v |> TwoPad10.to_string |> Bytes.of_string) in
    (* - read all csexps from the source *)
    let ic = open_in_gen [ Open_binary; Open_rdonly ] 0 fn in
    let* sxs = Csexp.input_many ic in
    close_in ic;
    (* copy fn content as csexps to tmp file fn' *)
    let fn' = fn ^ "~" in
    let oc = open_out_gen [ Open_binary; Open_wronly ] File.pFile fn' in
    let cp_csx oc sxs sx = (add_1_csx oc sx) :: sxs in
    let pos = List.fold_left (cp_csx oc) [] sxs in
    close_out oc;
    (* recreate cdb *)
    let none _ = false in
    let add_all fkt = List.iter (add_1_p fkt) pos in
    let _ = Mapcdb.add_many none add_all ix in
    (* swap tmp for real *)
    Unix.rename fn' fn;
    Ok fn

  open Rfc4287

  (* all but o/p/, unnumbered (dummy -3) *)
  let other_feeds (e : Entry.t) : t list =
    let day (Rfc3339.T iso) = ("o/d/" ^ String.sub iso 0 10,-3) in
    let open Category in
    let tag init (_,(Term (Single t)),_) = ("o/t/" ^ t,-3) :: init in
    day e.published
    :: (e.categories |> List.fold_left tag [])

  (* all but o/p/, numbered *)
  let next_other_pages ~items_per_page (e : Entry.t) : t list  =
    let page init item =
      let _,pg = next_id ~items_per_page item in
      pg :: init
    in
    e
    |> other_feeds
    |> List.fold_left page []

  let find (pos : TwoPad10.t) (base : string) : t option =
    let compare (inner0,inner1) (outer0,outer1) =
      (* Logr.debug (fun m -> m "%s.%s (%i,%i) (%i,%i)" "Main.Note.Delete" "dirty.compare" in0 in1 out0 out1); *)
      assert (inner0 <= inner1);
      assert (outer0 <= outer1);
      if inner1 < outer0
      then (-1)
      else if inner0 > outer1
      then 1
      else 0
    in
    let union posn =
      match posn with
      | [] -> (0,0)
      | (a0,a1) :: _ ->
        let b0,b1 = posn |> St.last in
        (* Logr.debug (fun m -> m "%s.%s (%i,%i) (%i,%i)" "Main.Note.Delete" "dirty.range" p00 p01 p10 p11); *)
        assert (a0 <= a1);
        assert (b0 <= b1);
        assert (a0 <= b1);
        (a0,b1)
    in
    let includes (outer0,outer1) (inner0,inner1) =
      (* Logr.debug (fun m -> m "%s.%s (%i,%i) (%i,%i)" "Main.Note.Delete" "dirty.spans" in0 in1 out0 out1); *)
      (*     assert (r = (0 == compare (in0,in1) (out0,out1))); *)
      inner0 >= outer0 && inner1 <= outer1
    in
    let rec bsearch (pos : TwoPad10.t) (p,i0 : t) (p1,i1 : t) =
      Logr.debug (fun m -> m "%s.%s (%s,%i) (%s,%i)" "Main.Note.Delete" "dirty.find.bsearch" p i0 p1 i1);
      assert (p |> String.equal p1);
      assert (i0 <= i1);
      let m = p , (i0 + i1) / 2 in
      match m
            |> to_posn
            |> union
            |> compare pos with
      |  0 -> Logr.debug (fun m -> m "%s.%s found: (%s,%i)" "Main.Note.Delete" "dirty.find.bsearch" p ((i0+i1)/2));
        Some m
      | -1 -> bsearch pos (p,i0) m
      |  1 -> bsearch pos m (p1,i1)
      | _  -> failwith __LOC__
    in
    Option.bind
      (find_max (base,-11))
      (fun mx ->
         let mx' = mx
                   |> to_posn
                   |> union in
         (* at first examine the most recent page *)
         if includes mx' pos
         then Some mx
         else let _,mx'1 = mx' in
           (* then binary search all *)
           let all = (0,mx'1) in
           if includes pos all
           then (let p,_ = mx in
                 bsearch pos (p,0) mx)
           else None)
end

open Rfc4287

(* all logical feed urls, xml+json, (including the main feed) outbox etc. *)
let feed_urls (e : Entry.t) =
  let db = Uri.make ~path:"o/d/" () in
  let day (Rfc3339.T iso) =
    let p = String.sub iso 0 10 in
    Uri.make ~path:(p ^ "/") () |> Http.reso ~base:db in

  let tb = tagu in
  let open Category in
  let tag (_,(Term (Single p)),_) =
    Uri.make ~path:(p ^ "/") () |> Http.reso ~base:tb in

  let obox = Uri.make ~path:(Ap.apub ^ "outbox/") () in
  defa
  :: obox
  :: (e.published |> day)
  :: (e.categories |> List.map tag)

let climb a : string =
  a
  |> String.split_on_char '/'
  |> List.map (fun _ -> "../")
  |> String.concat ""

let make_feed_syml (unn,b : Page.t) fn' =
  Logr.debug (fun m -> m "%s.%s %s/%d %s" "Storage" "make_feed_syml" unn b fn');
  let ld = unn ^ "/" in
  let ln = ld ^ (Filename.basename fn') in
  let fn = (unn |> climb) ^ fn' in
  Logr.debug (fun m -> m "ln -s %s %s" fn ln);
  let open Unix in
  ((* should we take measures to only ever unlink symlinks? *)
    try unlink ln
    with Unix_error(ENOENT, "unlink", _) -> ());
  (try mkdir ld File.pDir
   with Unix_error(EEXIST, "mkdir", _) -> ());
  symlink ~to_dir:false fn ln;
  (fn, ln)

(* return a list of Page.t the entry is part of *)
let save
    ?(items_per_page = 50)
    ?(fn = fn)
    ?(fn_id_cdb = fn_id_cdb)
    ?(_fn_url_cdb = fn_url_cdb)
    ?(_fn_t_cdb = fn_t_cdb)
    (e : Rfc4287.Entry.t) =
  let rel_edit_for_id id : Rfc4287.Link.t =
    Logr.debug (fun m -> m "%s.%s id %a" "Storage" "save.rel_edit_for_id" Uri.pp id);
    let path = "seppo.cgi/edit" in
    let f = id |> Uri.fragment |> Option.value ~default:"" in
    assert (f != "");
    let query = [("id",[id |> Uri.to_string])] in
    {href    = Uri.make ~path ~query ();
     rel     = Some Link.edit;
     rfc7033 = None;
     title   = None} in
  let id,(a,b as ix) = Page.next_id ~items_per_page ("o/p",-3) in
  Logr.debug (fun m -> m "%s.%s  id: %a  fn_x: %s%d" "Storage" "save" Uri.pp id a b);
  assert (Rfc4287.defa |> Uri.to_string |> String.equal (a ^"/"));
  assert (id |> Uri.to_string |> St.starts_with ~prefix:"o/p-");
  assert (a |> String.equal "o/p");
  assert (b >= 0);
  let e = {e with id;
                  links = (id |> rel_edit_for_id) :: e.links} in
  (* append entry to global storage .s and record store position *)
  let p0 = try (Unix.stat fn).st_size with _ -> 0 in
  let mode = [ Open_append; Open_binary; Open_creat; Open_wronly ] in
  File.out_channel ~tmp:None ~mode fn (fun oc ->
      e
      |> Rfc4287.Entry.encode
      |> Csexp.to_channel oc);
  let p1 = (Unix.stat fn).st_size in
  let pos = (p0,p1) |> Page.append ix in
  let _ = Mapcdb.add (id_to_b e.id) pos fn_id_cdb in
  Logr.warn (fun m -> m "@TODO append url->id to urls.cdb");
  e,ix,pos

let from_channel (p0,_ : TwoPad10.t) sc =
  seek_in sc p0;
  sc |> Csexp.input >>= Entry.decode

let overwrite fn (p0,p1 as pos : TwoPad10.t) =
  File.out_channel
    ~tmp:None
    ~mode:[ Open_binary; Open_wronly ]
    fn
    (fun oc ->
       seek_out oc p0;
       assert (p0 == pos_out oc);
       pos |> TwoPad10.strut |> Csexp.to_channel oc;
       assert (p1 == pos_out oc) )

(* overwrite in primary storage *)
let delete
    ?(fn = fn)
    id : (Rfc4287.Entry.t, string) result =
  Logr.debug (fun m -> m "%s.%s %a" "Storage" "delete" Uri.pp_hum id);
  let* pos = id |> TwoPad10.from_id in
  let* r = fn |> File.in_channel' (from_channel pos) in
  overwrite fn pos;
  Ok r

let select ?(fn = fn) id : (Rfc4287.Entry.t, string) result =
  Logr.warn (fun m -> m "%s.%s %a" "Storage" "select" Uri.pp_hum id);
  let* pos = TwoPad10.from_id id in
  File.in_channel fn (from_channel pos)