package activitypub_gui

  1. Overview
  2. Docs

Source file icache.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
102
103
104
105
106
107
108
109
110
111
112
113
114
115
(*********************************************************************************)
(*                OCaml-ActivityPub                                              *)
(*                                                                               *)
(*    Copyright (C) 2023-2024 INRIA All rights reserved.                         *)
(*    Author: Maxence Guesdon, INRIA Saclay                                      *)
(*                                                                               *)
(*    This program is free software; you can redistribute it and/or modify       *)
(*    it under the terms of the GNU Lesser General Public License version        *)
(*    3 as published by the Free Software Foundation.                            *)
(*                                                                               *)
(*    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, write to the Free Software                *)
(*    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA                   *)
(*    02111-1307  USA                                                            *)
(*                                                                               *)
(*    Contact: maxence.guesdon@inria.fr                                          *)
(*                                                                               *)
(*********************************************************************************)

module AP = Activitypub


let files = ref (AP.Smap.empty : int AP.Smap.t)

let mutex = Lwt_mutex.create ()

let temp_dir = ref None
let dir () =
  match !temp_dir with
  | None ->
      let%lwt d = Lwt_io.create_temp_dir ~prefix:".images" () in
      temp_dir := Some d;
      Stdlib.at_exit
        (fun () ->
           AP.Smap.iter (fun file _ -> 
              try Unix.unlink (Filename.concat d file)
              with Unix.Unix_error (e, s1, s2) -> 
               prerr_endline (Printf.sprintf "%s: %s %s" s1 s2 (Unix.error_message e))
           ) !files ;
           try Unix.rmdir d
           with Unix.Unix_error (e, s1, s2) -> 
               prerr_endline (Printf.sprintf "%s: %s %s" s1 s2 (Unix.error_message e))
        );
      Lwt.return d
  | Some d -> Lwt.return d

let sha256 str =
  let hash = Cryptokit.Hash.sha256 () in
  hash#add_string str ;
  let str = hash#result in
  hash#wipe ;
  let h = Cryptokit.Hexa.encode () in
  h#put_string str;
  h#finish;
  h#get_string

let get_file contents =
  let sha = sha256 contents in
  let%lwt dir = dir () in
  let file = Filename.concat dir sha in
  Lwt_mutex.with_lock mutex
    (fun () ->
       match AP.Smap.find_opt sha !files with
       | Some cpt ->
           files := AP.Smap.add sha (cpt+1) !files;
           Lwt.return_some file
       | None ->
           try%lwt
             let%lwt () = Lwt_io.(with_file ~mode:Output file 
                (fun oc -> write oc contents))
             in
             files := AP.Smap.add sha 1 !files ;
             Lwt.return_some file
               with
           | e ->
               Log.err (fun m -> m "file %s: %s" file (Printexc.to_string e));
               Lwt.return_none
    )

let forget file () =
  let sha = Filename.basename file in
  Lwt_mutex.with_lock mutex
    (fun () ->
       match AP.Smap.find_opt sha !files with
       | None -> Lwt.return_unit
       | Some cpt when cpt > 1 ->
           files := AP.Smap.add sha (cpt-1) !files;
           Lwt.return_unit
       | Some _ ->
           files := AP.Smap.remove sha !files ;
           Lwt_unix.unlink file
    )

let image ?classes ?name ?props ?width ?height ?keep_ratio ?pack contents =
  let i = Stk.Image.image
    ?classes ?name ?props ?width ?height ?keep_ratio ?pack ()
  in
  let%lwt () = match%lwt get_file contents with
    | None -> Lwt.return_unit
    | Some file ->
        i#load_file file ;
        let _ = i#connect Stk.Widget.Destroy
          (fun () -> Lwt.async (forget file) ; false)
        in
        Lwt.return_unit
  in
  Lwt.return i