futur.blue
objective categorical abstract machine language personal data server
Put blob refs when importing a repo
+14
-3
pegasus/lib/repository.ml
+14
-3
pegasus/lib/repository.ml
···
620
620
in
621
621
(* collect record data for insert *)
622
622
let since = Tid.now () in
623
+
let blob_refs : (string * Cid.t) list ref = ref [] in
623
624
let record_data =
624
-
List.filter_map
625
+
List.map
625
626
(fun (path, cid) ->
626
627
match Block_map.get cid all_blocks with
627
628
| Some data ->
628
-
Some (path, cid, data, since)
629
+
let record = Lex.of_cbor data in
630
+
let record_refs =
631
+
Util.find_blob_refs record
632
+
|> List.map (fun (br : Mist.Blob_ref.t) -> (path, br.ref))
633
+
in
634
+
blob_refs := record_refs @ !blob_refs ;
635
+
(path, cid, data, since)
629
636
| None ->
630
637
failwith ("missing record block: " ^ Cid.to_string cid) )
631
638
leaves
···
639
646
let$! () =
640
647
[%rapper execute {sql| DELETE FROM records |sql}] () conn
641
648
in
642
-
let$! () = User_store.Bulk.put_records record_data conn in
649
+
let$!* _ =
650
+
Lwt.all
651
+
[ User_store.Bulk.put_records record_data conn
652
+
; User_store.Bulk.put_blob_refs !blob_refs conn ]
653
+
in
643
654
Lwt.return_ok () ) )
644
655
in
645
656
(* clear cached block_map so it's rebuilt on next access *)
+35
pegasus/lib/user_store.ml
+35
pegasus/lib/user_store.ml
···
635
635
Lwt.return_error e )
636
636
in
637
637
process_chunks chunks
638
+
639
+
let put_blob_refs (refs : (string * Cid.t) list) conn =
640
+
if List.is_empty refs then Lwt.return_ok ()
641
+
else
642
+
let module C = (val conn : Caqti_lwt.CONNECTION) in
643
+
let chunks = chunk_list 200 refs in
644
+
let rec process_chunks = function
645
+
| [] ->
646
+
Lwt.return_ok ()
647
+
| chunk :: rest -> (
648
+
let values =
649
+
List.map
650
+
(fun (path, cid) ->
651
+
Printf.sprintf "('%s', '%s')" (escape_sql_string path)
652
+
(escape_sql_string (Cid.to_string cid)) )
653
+
chunk
654
+
|> String.concat ", "
655
+
in
656
+
let sql =
657
+
Printf.sprintf
658
+
"INSERT INTO blobs_records (record_path, blob_cid) VALUES %s \
659
+
ON CONFLICT DO NOTHING"
660
+
values
661
+
in
662
+
let query =
663
+
Caqti_request.Infix.( ->. ) Caqti_type.unit Caqti_type.unit sql
664
+
in
665
+
let%lwt result = C.exec query () in
666
+
match result with
667
+
| Ok () ->
668
+
process_chunks rest
669
+
| Error e ->
670
+
Lwt.return_error e )
671
+
in
672
+
process_chunks chunks
638
673
end
+20
-1
pegasus/lib/util.ml
+20
-1
pegasus/lib/util.ml
···
33
33
let ( let$! ) m f =
34
34
match%lwt m with Ok x -> f x | Error e -> raise (Caqti_error.Exn e)
35
35
36
+
(* let$! but for an array of results *)
37
+
let ( let$!* ) m f =
38
+
let%lwt results =
39
+
match%lwt m with
40
+
| xs ->
41
+
Lwt.return @@ List.rev
42
+
@@ List.fold_left
43
+
(fun acc x ->
44
+
match x with
45
+
| Ok x ->
46
+
x :: acc
47
+
| Error e ->
48
+
raise (Caqti_error.Exn e) )
49
+
[] xs
50
+
in
51
+
f results
52
+
36
53
(* unwraps an Lwt result, raising an exception if there's an error *)
37
54
let ( >$! ) m f =
38
55
match%lwt m with
···
468
485
let props_json = Template.props_to_json props |> Yojson.Basic.to_string in
469
486
let page_data = Printf.sprintf "window.__PAGE__ = {props: %s};" props_json in
470
487
let app = Template.make ~props () in
471
-
let page = Frontend.Layout.make ?title ~favicon:Env.favicon_url ~children:app () in
488
+
let page =
489
+
Frontend.Layout.make ?title ~favicon:Env.favicon_url ~children:app ()
490
+
in
472
491
Dream.stream ?status
473
492
~headers:[("Content-Type", "text/html")]
474
493
(fun stream ->