lib/storage.ml

   1 (*
   2  *    _  _   ____                         _
   3  *  _| || |_/ ___|  ___ _ __  _ __   ___ | |
   4  * |_  ..  _\___ \ / _ \ '_ \| '_ \ / _ \| |
   5  * |_      _|___) |  __/ |_) | |_) | (_) |_|
   6  *   |_||_| |____/ \___| .__/| .__/ \___/(_)
   7  *                     |_|   |_|
   8  *
   9  * Personal Social Web.
  10  *
  11  * Copyright (C) The #Seppo contributors. All rights reserved.
  12  *
  13  * This program is free software: you can redistribute it and/or modify
  14  * it under the terms of the GNU General Public License as published by
  15  * the Free Software Foundation, either version 3 of the License, or
  16  * (at your option) any later version.
  17  *
  18  * This program is distributed in the hope that it will be useful,
  19  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  20  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  21  * GNU General Public License for more details.
  22  *
  23  * You should have received a copy of the GNU General Public License
  24  * along with this program.  If not, see <http://www.gnu.org/licenses/>.
  25  *)
  26
  27 let ( let* ) = Result.bind
  28 let ( >>= ) = Result.bind
  29
  30 let pre        = "app/var/db/"
  31 let fn         = pre ^ "o/p.s"
  32 let fn_id_cdb  = Mapcdb.Cdb (pre ^ "o/id.cdb")
  33 let fn_url_cdb = Mapcdb.Cdb (pre ^ "o/url.cdb")
  34 let fn_t_cdb   = Mapcdb.Cdb (pre ^ "o/t.cdb")
  35
  36 (** An id consists of a page name and number and an index within *)
  37 module Id = struct
  38   let uri_to_b id =
  39     id |> Uri.to_string |> Bytes.of_string
  40
  41   (** defined by a name and a number. *)
  42   type page = string * int
  43
  44   (** An ID consists of a page and an index within *)
  45   type t = page * int
  46
  47   let to_page_i id : (t,string) result=
  48     if id |> Uri.scheme |> Option.is_none
  49     && id |> Uri.host |> Option.is_none
  50     && id |> Uri.path |> St.is_prefix ~affix:"o/"
  51     then
  52       let jig = "%-%/" |> Make.Jig.make in
  53       match id |> Uri.path |> Make.Jig.cut jig,
  54             id |> Uri.fragment with
  55       | Some [b;j] , Some i ->
  56         (try
  57            Ok ((b,j |> int_of_string)
  58               , i |> int_of_string)
  59          with Failure e -> Error e)
  60       | _   -> Error "no index given"
  61     else
  62       Error "must be like o/p-23/#42"
  63 end
  64
  65 (* a tuple of two (file) positions *)
  66 module TwoPad10 = struct
  67   let length = 28
  68   type t = int * int
  69
  70   let to_string (a,b : t) =
  71     (* write a canonical s-expression in one go *)
  72     let r = Printf.sprintf "(10:0x%08x10:0x%08x)" a b in
  73     assert (length == (r |> String.length));
  74     r
  75
  76   let decode (sx : Csexp.t) : (t,'a) result =
  77     let h2i = int_of_string in
  78     match sx with
  79     | Csexp.(List [Atom p0; Atom p1]) -> Ok (h2i p0, h2i p1)
  80     | _                               -> Error "couldn't decode"
  81
  82   let decode_many l : t list =
  83     let h2i = int_of_string in
  84     l |> List.fold_left (fun init e ->
  85         match e with
  86         | Csexp.(List [Atom p0; Atom p1]) -> (h2i p0, h2i p1) :: init
  87         | _                               -> init) []
  88     |> List.rev
  89
  90   let fold_decode a (_ : (Csexp.t,'a) result) =
  91     a
  92
  93   let from_channel ic =
  94     match Csexp.input_many ic with
  95     | Error _ -> []
  96     | Ok l -> decode_many l
  97
  98   let from_file = File.in_channel from_channel
  99
 100   let from_page_i ?(prefix = pre) (((fn,j),i) : Id.t) : (t,string) result =
 101     let jig = prefix ^ "%/%.s" |> Make.Jig.make in
 102     let l : t list = [fn;j |> string_of_int]
 103                      |> Make.Jig.paste jig
 104                      |> Option.get
 105                      |> from_file in
 106     try Ok (i |> List.nth l)
 107     with _ -> Error "not found"
 108
 109   let from_id ?(prefix = pre) id : (t,string) result =
 110     id
 111     |> Id.to_page_i
 112     >>= from_page_i ~prefix
 113
 114   let strut (p0,p1 : t) =
 115     assert (p0 >= 0);
 116     assert (p1 - p0 - 6 >= 0);
 117     let l0,l1 = match p1 - p0 - 6 with
 118       |             0 as n -> 0,n - 0
 119       |            10 as n -> 1,n - 1
 120       |           101 as n -> 1,n - 2
 121       |         1_002 as n -> 1,n - 3
 122       |        10_003 as n -> 1,n - 4
 123       |       100_004 as n -> 1,n - 5
 124       |     1_000_005 as n -> 1,n - 6
 125       |    10_000_006 as n -> 1,n - 7
 126       |   100_000_007 as n -> 1,n - 8
 127       | 1_000_000_008 as n -> 1,n - 9
 128       | n ->
 129         let n'   = n |> float_of_int in
 130         let dec' = n' |> log10 |> floor in
 131         let dec  = n' -. dec' |> log10 |> int_of_float in
 132         0,n - dec
 133     in
 134     let fil = 'x' in
 135     let r = Csexp.(List [Atom (String.make l0 fil); Atom (String.make l1 fil)]) in
 136     Logr.debug (fun m -> m "%s.%s %d" "Storage" "strut" (p1-p0));
 137     assert ((p1-p0) == (r |> Csexp.to_string |> String.length));
 138     r
 139 end
 140
 141 (* hydrate entry (from main storage) *)
 142 let fold_of_twopad10 ?(fn = fn) a p =
 143   (* read entry from main storage *)
 144   let of_twopad10 (p0,p1 : TwoPad10.t) : (Csexp.t,'a) result =
 145     let ipt ic =
 146       seek_in ic p0;
 147       assert (pos_in ic = p0);
 148       let r = Csexp.input ic in
 149       assert (pos_in ic = p1);
 150       r
 151     in
 152     fn |> File.in_channel ipt
 153   in
 154   let ( >>= ) = Result.bind in
 155   (p
 156    |> TwoPad10.decode
 157    >>= of_twopad10
 158    >>= Rfc4287.Entry.decode)
 159   :: a
 160
 161 module Page = struct
 162   type t = Id.page
 163
 164   let jig = pre ^ "%/%.s" |> Make.Jig.make
 165
 166   let of_fn fn : t option =
 167     match fn |> Make.Jig.cut jig with
 168     | Some [a;b] ->
 169       assert (a |> St.is_prefix ~affix:"o/");
 170       Some (a,b |> int_of_string)
 171     | _          -> None
 172
 173   let to_fn (a,b : t) =
 174     assert (a |> St.is_prefix ~affix:"o/");
 175     [a;b |> string_of_int]
 176     |> Make.Jig.paste jig
 177     |> Option.get
 178
 179   let to_posn (p : t) : TwoPad10.t list =
 180     p
 181     |> to_fn
 182     |> TwoPad10.from_file
 183
 184   let find_max ?(prefix = pre) (dir,_ : t) : t option =
 185     assert (dir |> St.is_prefix ~affix:"o/");
 186     assert (not (dir |> St.is_suffix ~affix:"/"));
 187     let mx = File.fold_dir (fun c fn ->
 188         (try Scanf.sscanf fn "%d.s" (fun i -> i)
 189          with _ -> -1)
 190         |> max c,true)
 191         (-1) (prefix ^ dir) in
 192     if mx < 0
 193     then None
 194     else Some (dir,mx)
 195
 196   let jig2 = "%-%/" |> Make.Jig.make
 197
 198   let of_id = Id.to_page_i
 199
 200   let modify_idx fu (a,x : t) : t =
 201     (a,x |> fu)
 202
 203   let pred = modify_idx Int.pred
 204   let succ = modify_idx Int.succ
 205
 206   let to_int = function
 207     | Some (_,x : t) -> x
 208     | _ -> -1
 209
 210   (* the next id and page *)
 211   let next_id ~items_per_page (dir,_ as pa : t) : (Uri.t * t) =
 212     (* Logr.debug (fun m -> m "%s.%s %s" "Storage" "next_id" dir); *)
 213     assert (dir |> St.is_prefix ~affix:"o/");
 214     assert (not (dir |> St.is_suffix ~affix:"/"));
 215     let bytes_per_item = TwoPad10.length in
 216     (* get the previously highest index number and name *)
 217     let _ = pa |> to_fn |> Filename.dirname |> File.mkdir_p File.pDir in
 218     let pg,i =
 219       match pa |> find_max with
 220       | None ->
 221         (* Logr.debug (fun m -> m "%s.%s first %s" "Storage" "next_id" dir); *)
 222         0,0
 223       | Some (di,pg) ->
 224         assert (di |> String.equal dir);
 225         let pa = (dir,pg) in
 226         let i = (try (pa |> to_fn |> Unix.stat).st_size
 227                  with _ -> 0) / bytes_per_item in
 228         if i < items_per_page
 229         then pg,i
 230         else pg+1,0
 231     in
 232     assert (pg >= 0);
 233     assert (i >= 0);
 234     assert (i < items_per_page);
 235     let j = "%-%/#%" |> Make.Jig.make in
 236     let v = [dir;pg |> string_of_int;i |> string_of_int] in
 237     let id = v |> Make.Jig.paste j |> Option.get |> Uri.of_string in
 238     Logr.debug (fun m -> m "%s.%s %a" "Storage" "next_id" Uri.pp id);
 239     assert (id |> Uri.to_string |> St.is_prefix ~affix:"o/");
 240     id,(dir,pg)
 241
 242   let apnd (_,b as pa) pos =
 243     assert (b >= 0);
 244     assert (TwoPad10.length == (pos |> Bytes.length));
 245     pa
 246     |> to_fn
 247     |> File.out_channel_append (fun oc -> output_bytes oc pos)
 248
 249   let append (pa : t) (pos : TwoPad10.t) =
 250     let by = pos
 251              |> TwoPad10.to_string
 252              |> Bytes.of_string in
 253     by |> apnd pa;
 254     by
 255
 256   let _remake fn ix =
 257     (* add csexp entry to .s and return (id,position) tuple *)
 258     let add_1_csx oc sx =
 259       let ol = pos_out oc in
 260       sx |> Csexp.to_channel oc;
 261       let ne = pos_out oc in
 262       let id = match sx |> Rfc4287.Entry.decode with
 263         | Error _ -> None
 264         | Ok r    -> Some r.id in
 265       (id,(ol,ne)) in
 266     (* if Some id call fkt with id->(ol,ne) *)
 267     let add_1_p fkt = function
 268       | (None,_v)    -> Logr.warn (fun m -> m "add a strut?")
 269       | (Some id,v)  -> fkt (Id.uri_to_b id, v |> TwoPad10.to_string |> Bytes.of_string) in
 270     (* - read all csexps from the source *)
 271     let ic = open_in_gen [ Open_binary; Open_rdonly ] 0 fn in
 272     let* sxs = Csexp.input_many ic in
 273     close_in ic;
 274     (* copy fn content as csexps to tmp file fn' *)
 275     let fn' = fn ^ "~" in
 276     let oc = open_out_gen [ Open_binary; Open_wronly ] File.pFile fn' in
 277     let cp_csx oc sxs sx = (add_1_csx oc sx) :: sxs in
 278     let pos = List.fold_left (cp_csx oc) [] sxs in
 279     close_out oc;
 280     (* recreate cdb *)
 281     let none _ = false in
 282     let add_all fkt = List.iter (add_1_p fkt) pos in
 283     let _ = Mapcdb.add_many none add_all ix in
 284     (* swap tmp for real *)
 285     Unix.rename fn' fn;
 286     Ok fn
 287
 288   open Rfc4287
 289
 290   (* all but o/p/, unnumbered (dummy -3) *)
 291   let other_feeds (e : Entry.t) : t list =
 292     let day (Rfc3339.T iso) = ("o/d/" ^ String.sub iso 0 10,-3) in
 293     let open Category in
 294     let tag init (_,(Term (Single t)),_) = ("o/t/" ^ t,-3) :: init in
 295     day e.published
 296     :: (e.categories |> List.fold_left tag [])
 297
 298   (* all but o/p/, numbered *)
 299   let next_other_pages ~items_per_page (e : Entry.t) : t list  =
 300     let page init item =
 301       let _,pg = next_id ~items_per_page item in
 302       pg :: init
 303     in
 304     e
 305     |> other_feeds
 306     |> List.fold_left page []
 307
 308   let find (pos : TwoPad10.t) (base : string) : t option =
 309     let compare (inner0,inner1) (outer0,outer1) =
 310       (* Logr.debug (fun m -> m "%s.%s (%i,%i) (%i,%i)" "Main.Note.Delete" "dirty.compare" in0 in1 out0 out1); *)
 311       assert (inner0 <= inner1);
 312       assert (outer0 <= outer1);
 313       if inner1 < outer0
 314       then (-1)
 315       else if inner0 > outer1
 316       then 1
 317       else 0
 318     in
 319     let union posn =
 320       match posn with
 321       | [] -> (0,0)
 322       | (a0,a1) :: _ ->
 323         let b0,b1 = posn |> St.last in
 324         (* Logr.debug (fun m -> m "%s.%s (%i,%i) (%i,%i)" "Main.Note.Delete" "dirty.range" p00 p01 p10 p11); *)
 325         assert (a0 <= a1);
 326         assert (b0 <= b1);
 327         assert (a0 <= b1);
 328         (a0,b1)
 329     in
 330     let includes (outer0,outer1) (inner0,inner1) =
 331       (* Logr.debug (fun m -> m "%s.%s (%i,%i) (%i,%i)" "Main.Note.Delete" "dirty.spans" in0 in1 out0 out1); *)
 332       (*     assert (r = (0 == compare (in0,in1) (out0,out1))); *)
 333       inner0 >= outer0 && inner1 <= outer1
 334     in
 335     let rec bsearch (pos : TwoPad10.t) (p,i0 : t) (p1,i1 : t) =
 336       Logr.debug (fun m -> m "%s.%s (%s,%i) (%s,%i)" "Main.Note.Delete" "dirty.find.bsearch" p i0 p1 i1);
 337       assert (p |> String.equal p1);
 338       assert (i0 <= i1);
 339       let m = p , (i0 + i1) / 2 in
 340       match m
 341             |> to_posn
 342             |> union
 343             |> compare pos with
 344       |  0 -> Logr.debug (fun m -> m "%s.%s found: (%s,%i)" "Main.Note.Delete" "dirty.find.bsearch" p ((i0+i1)/2));
 345         Some m
 346       | -1 -> bsearch pos (p,i0) m
 347       |  1 -> bsearch pos m (p1,i1)
 348       | _  -> failwith __LOC__
 349     in
 350     Option.bind
 351       (find_max (base,-11))
 352       (fun mx ->
 353          let mx' = mx
 354                    |> to_posn
 355                    |> union in
 356          (* at first examine the most recent page *)
 357          if includes mx' pos
 358          then Some mx
 359          else let _,mx'1 = mx' in
 360            (* then binary search all *)
 361            let all = (0,mx'1) in
 362            if includes pos all
 363            then (let p,_ = mx in
 364                  bsearch pos (p,0) mx)
 365            else None)
 366 end
 367
 368 open Rfc4287
 369
 370 (* all logical feed urls, xml+json, (including the main feed) outbox etc. *)
 371 let feed_urls (e : Entry.t) =
 372   let db = Uri.make ~path:"o/d/" () in
 373   let day (Rfc3339.T iso) =
 374     let p = String.sub iso 0 10 in
 375     Uri.make ~path:(p ^ "/") () |> Http.reso ~base:db in
 376
 377   let tb = tagu in
 378   let open Category in
 379   let tag (_,(Term (Single p)),_) =
 380     Uri.make ~path:(p ^ "/") () |> Http.reso ~base:tb in
 381
 382   let obox = Uri.make ~path:(Ap.apub ^ "outbox/") () in
 383   defa
 384   :: obox
 385   :: (e.published |> day)
 386   :: (e.categories |> List.map tag)
 387
 388 let climb a : string =
 389   a
 390   |> String.split_on_char '/'
 391   |> List.map (fun _ -> "../")
 392   |> String.concat ""
 393
 394 let make_feed_syml (unn,b : Page.t) fn' =
 395   Logr.debug (fun m -> m "%s.%s %s/%d %s" "Storage" "make_feed_syml" unn b fn');
 396   let ld = unn ^ "/" in
 397   let ln = ld ^ (Filename.basename fn') in
 398   let fn = (unn |> climb) ^ fn' in
 399   Logr.debug (fun m -> m "ln -s %s %s" fn ln);
 400   let open Unix in
 401   ((* should we take measures to only ever unlink symlinks? *)
 402     try unlink ln
 403     with Unix_error(ENOENT, "unlink", _) -> ());
 404   (try mkdir ld File.pDir
 405    with Unix_error(EEXIST, "mkdir", _) -> ());
 406   symlink ~to_dir:false fn ln;
 407   (fn, ln)
 408
 409 (* return a list of Page.t the entry is part of *)
 410 let save
 411     ?(items_per_page = 50)
 412     ?(fn = fn)
 413     ?(fn_id_cdb = fn_id_cdb)
 414     ?(_fn_url_cdb = fn_url_cdb)
 415     ?(_fn_t_cdb = fn_t_cdb)
 416     (e : Rfc4287.Entry.t) =
 417   let rel_edit_for_id id : Rfc4287.Link.t =
 418     Logr.debug (fun m -> m "%s.%s id %a" "Storage" "save.rel_edit_for_id" Uri.pp id);
 419     let path = Cfg.seppo_cgi ^ "/edit" in
 420     let f = id |> Uri.fragment |> Option.value ~default:"" in
 421     assert (f != "");
 422     let query = [("id",[id |> Uri.to_string])] in
 423     {href    = Uri.make ~path ~query ();
 424      rel     = Some Link.edit;
 425      rfc7565 = None;
 426      title   = None} in
 427   let id,(a,b as ix) = Page.next_id ~items_per_page ("o/p",-3) in
 428   Logr.debug (fun m -> m "%s.%s  id: %a  fn_x: %s%d" "Storage" "save" Uri.pp id a b);
 429   assert (Rfc4287.defa |> Uri.to_string |> String.equal (a ^"/"));
 430   assert (id |> Uri.to_string |> St.is_prefix ~affix:"o/p-");
 431   assert (a |> String.equal "o/p");
 432   assert (b >= 0);
 433   let e = {e with id;
 434                   links = (id |> rel_edit_for_id) :: e.links} in
 435   (* append entry to global storage .s and record store position *)
 436   let p0 = try (Unix.stat fn).st_size with _ -> 0 in
 437   let mode = [ Open_append; Open_binary; Open_creat; Open_wronly ] in
 438   fn |> File.out_channel_append ~mode (fun oc ->
 439       e
 440       |> Rfc4287.Entry.encode
 441       |> Csexp.to_channel oc);
 442   let p1 = (Unix.stat fn).st_size in
 443   let pos = (p0,p1) |> Page.append ix in
 444   let _ = Mapcdb.add (Id.uri_to_b e.id) pos fn_id_cdb in
 445   Logr.warn (fun m -> m "@TODO append url->id to urls.cdb");
 446   e,ix,pos
 447
 448 let from_channel (p0,_ : TwoPad10.t) sc =
 449   seek_in sc p0;
 450   sc |> Csexp.input >>= Entry.decode
 451
 452 let overwrite fn (p0,p1 as pos : TwoPad10.t) =
 453   fn
 454   |> File.out_channel_patch
 455     (fun oc ->
 456        seek_out oc p0;
 457        assert (p0 == pos_out oc);
 458        pos |> TwoPad10.strut |> Csexp.to_channel oc;
 459        assert (p1 == pos_out oc) )
 460
 461 (* overwrite in primary storage *)
 462 let delete
 463     ?(fn = fn)
 464     id : (Rfc4287.Entry.t, string) result =
 465   Logr.debug (fun m -> m "%s.%s %a" "Storage" "delete" Uri.pp_hum id);
 466   let* pos = id |> TwoPad10.from_id in
 467   let* r = fn |> File.in_channel (from_channel pos) in
 468   overwrite fn pos;
 469   Ok r
 470
 471 let select ?(fn = fn) id : (Rfc4287.Entry.t, string) result =
 472   Logr.warn (fun m -> m "%s.%s %a" "Storage" "select" Uri.pp_hum id);
 473   let* pos = TwoPad10.from_id id in
 474   fn |> File.in_channel (from_channel pos)