Source file `sihl_storage.ml`

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
include Sihl.Contract.Storage

let log_src = Logs.Src.create ("sihl.service." ^ Sihl.Contract.Storage.name)

module Logs = (val Logs.src_log log_src : Logs.LOG)

module Make (Repo : Repo.Sig) : Sihl.Contract.Storage.Sig = struct
  let find_opt ~id = Repo.get_file ~id

  let find ~id =
    let open Lwt.Syntax in
    let* file = Repo.get_file ~id in
    match file with
    | None ->
      raise (Sihl.Contract.Storage.Exception ("File not found with id " ^ id))
    | Some file -> Lwt.return file
  ;;

  let delete ~id =
    let open Lwt.Syntax in
    let* file = find ~id in
    let blob_id = file.Sihl.Contract.Storage.blob in
    let* () = Repo.delete_file ~id:file.file.id in
    Repo.delete_blob ~id:blob_id
  ;;

  let upload_base64 file ~base64 =
    let open Lwt.Syntax in
    let blob_id = Uuidm.v `V4 |> Uuidm.to_string in
    let* blob =
      match Base64.decode base64 with
      | Error (`Msg msg) ->
        Logs.err (fun m ->
            m "Could not upload base64 content of file %a" pp_file file);
        raise (Sihl.Contract.Storage.Exception msg)
      | Ok blob -> Lwt.return blob
    in
    let* () = Repo.insert_blob ~id:blob_id ~blob in
    let stored_file = Sihl.Contract.Storage.{ file; blob = blob_id } in
    let* () = Repo.insert_file ~file:stored_file in
    Lwt.return stored_file
  ;;

  let update_base64 file ~base64 =
    let open Lwt.Syntax in
    let blob_id = file.Sihl.Contract.Storage.blob in
    let* blob =
      match Base64.decode base64 with
      | Error (`Msg msg) ->
        Logs.err (fun m ->
            m "Could not upload base64 content of file %a" pp_stored file);
        raise (Sihl.Contract.Storage.Exception msg)
      | Ok blob -> Lwt.return blob
    in
    let* () = Repo.update_blob ~id:blob_id ~blob in
    let* () = Repo.update_file ~file in
    Lwt.return file
  ;;

  let download_data_base64_opt file =
    let open Lwt.Syntax in
    let blob_id = file.Sihl.Contract.Storage.blob in
    let* blob = Repo.get_blob ~id:blob_id in
    match Option.map Base64.encode blob with
    | Some (Error (`Msg msg)) ->
      Logs.err (fun m ->
          m "Could not get base64 content of file %a" pp_stored file);
      raise (Sihl.Contract.Storage.Exception msg)
    | Some (Ok blob) -> Lwt.return @@ Some blob
    | None -> Lwt.return None
  ;;

  let download_data_base64 file =
    let open Lwt.Syntax in
    let blob_id = file.Sihl.Contract.Storage.blob in
    let* blob = Repo.get_blob ~id:blob_id in
    match Option.map Base64.encode blob with
    | Some (Error (`Msg msg)) ->
      Logs.err (fun m ->
          m "Could not get base64 content of file %a" pp_stored file);
      raise (Sihl.Contract.Storage.Exception msg)
    | Some (Ok blob) -> Lwt.return blob
    | None ->
      raise
        (Sihl.Contract.Storage.Exception
           (Format.asprintf "File data not found for file %a" pp_stored file))
  ;;

  let start () = Lwt.return ()
  let stop () = Lwt.return ()
  let lifecycle = Sihl.Container.create_lifecycle "storage" ~start ~stop

  let register () =
    Repo.register_migration ();
    Repo.register_cleaner ();
    Sihl.Container.Service.create lifecycle
  ;;
end

module MariaDb : Sihl.Contract.Storage.Sig =
  Make (Repo.MakeMariaDb (Sihl.Database.Migration.MariaDb))