Skip to content

Commit 40f33e1

Browse files
jchavarridavesnx
jchavarri
and
davesnx
authored
Support assets in mel.module (#134)
Co-authored-by: David Sancho <[email protected]>
1 parent f9b10a8 commit 40f33e1

File tree

13 files changed

+819
-12
lines changed

13 files changed

+819
-12
lines changed

‎dune-project

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -36,6 +36,7 @@
3636
(lwt (>= 5.6.0))
3737
(lwt_ppx (>= 2.1.0))
3838
(uri (>= 4.2.0))
39+
integers
3940

4041
; Test dependencies
4142
(alcotest :with-test)

‎packages/melange.ppx/base32/LICENSES/ISC.txt

Lines changed: 15 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,15 @@
1+
ISC License:
2+
3+
Copyright (c) 2004-2010 by Internet Systems Consortium, Inc. ("ISC")
4+
Copyright (c) 1995-2003 by Internet Software Consortium
5+
6+
Permission to use, copy, modify, and/or distribute this software for any purpose
7+
with or without fee is hereby granted, provided that the above copyright notice
8+
and this permission notice appear in all copies.
9+
10+
THE SOFTWARE IS PROVIDED "AS IS" AND ISC DISCLAIMS ALL WARRANTIES WITH REGARD
11+
TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS.
12+
IN NO EVENT SHALL ISC BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL
13+
DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
14+
WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING
15+
OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.

‎packages/melange.ppx/base32/README.md

Lines changed: 11 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,11 @@
1+
This library was vendored for server-reason-react from https://codeberg.org/pukkamustard/ocaml-base32/src/commit/c08f37455b7ea67d8106c110af0efd501f1374ae.
2+
3+
# Base32 for OCaml
4+
5+
This implements Base32 encoded as specified by [RFC 4648](https://tools.ietf.org/html/rfc4648) for OCaml.
6+
7+
ocaml-base32 is an adaptation of [ocaml-base64](https://github.com/mirage/ocaml-base64)
8+
9+
## License
10+
11+
[ISC](./LICENSES/ISC.txt)

‎packages/melange.ppx/base32/lib/base32.ml

Lines changed: 231 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,231 @@
1+
(*
2+
* Copyright (c) 2006-2009 Citrix Systems Inc.
3+
* Copyright (c) 2010 Thomas Gazagnaire <[email protected]>
4+
* Copyright (c) 2014-2016 Anil Madhavapeddy <[email protected]>
5+
* Copyright (c) 2016 David Kaloper Meršinjak
6+
* Copyright (c) 2018 Romain Calascibetta <[email protected]>
7+
* Copyright (c) 2021 pukkamustard <[email protected]>
8+
*
9+
* Permission to use, copy, modify, and distribute this software for any
10+
* purpose with or without fee is hereby granted, provided that the above
11+
* copyright notice and this permission notice appear in all copies.
12+
*
13+
* THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
14+
* WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
15+
* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
16+
* ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
17+
* WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
18+
* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
19+
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
20+
*
21+
*)
22+
23+
type alphabet = { emap : int array; dmap : int array }
24+
type sub = string * int * int
25+
26+
let ( // ) x y =
27+
if y < 1 then raise Division_by_zero;
28+
if x > 0 then 1 + ((x - 1) / y) else 0
29+
[@@inline]
30+
31+
let unsafe_get_uint8 input off = String.unsafe_get input off |> Char.code
32+
let unsafe_set_uint8 input off v = v |> Char.chr |> Bytes.unsafe_set input off
33+
let none = -1
34+
35+
(* We mostly want to have an optional array for [dmap] (e.g. [int option
36+
array]). So we consider the [none] value as [-1]. *)
37+
38+
let make_alphabet alphabet =
39+
if String.length alphabet <> 32 then
40+
invalid_arg "Length of alphabet must be 32";
41+
if String.contains alphabet '=' then
42+
invalid_arg "Alphabet can not contain padding character";
43+
let emap =
44+
Array.init (String.length alphabet) (fun i -> Char.code alphabet.[i])
45+
in
46+
let dmap = Array.make 256 none in
47+
String.iteri (fun idx chr -> dmap.(Char.code chr) <- idx) alphabet;
48+
{ emap; dmap }
49+
50+
let length_alphabet { emap; _ } = Array.length emap
51+
let alphabet { emap; _ } = emap
52+
let default_alphabet = make_alphabet "ABCDEFGHIJKLMNOPQRSTUVWXYZ234567"
53+
let padding = int_of_char '='
54+
let error_msgf fmt = Format.ksprintf (fun err -> Error (`Msg err)) fmt
55+
56+
let encode_sub pad { emap; _ } ?(off = 0) ?len input =
57+
let len =
58+
match len with Some len -> len | None -> String.length input - off
59+
in
60+
61+
if len < 0 || off < 0 || off > String.length input - len then
62+
error_msgf "Invalid bounds"
63+
else
64+
let n = len in
65+
let n' = n // 5 * 8 in
66+
let res = Bytes.make n' (Char.chr 0) in
67+
68+
let emap i = Array.unsafe_get emap i in
69+
70+
(* the bit magic - takes 5 bytes and reads 5-bits at a time *)
71+
let emit b1 b2 b3 b4 b5 i =
72+
unsafe_set_uint8 res i (emap ((0b11111000 land b1) lsr 3));
73+
unsafe_set_uint8 res (i + 1)
74+
(emap (((0b00000111 land b1) lsl 2) lor ((0b11000000 land b2) lsr 6)));
75+
unsafe_set_uint8 res (i + 2) (emap ((0b00111110 land b2) lsr 1));
76+
unsafe_set_uint8 res (i + 3)
77+
(emap (((0b00000001 land b2) lsl 4) lor ((0b11110000 land b3) lsr 4)));
78+
unsafe_set_uint8 res (i + 4)
79+
(emap (((0b00001111 land b3) lsl 1) lor ((0b10000000 land b4) lsr 7)));
80+
unsafe_set_uint8 res (i + 5) (emap ((0b01111100 land b4) lsr 2));
81+
unsafe_set_uint8 res (i + 6)
82+
(emap (((0b00000011 land b4) lsl 3) lor ((0b11100000 land b5) lsr 5)));
83+
unsafe_set_uint8 res (i + 7) (emap (0b00011111 land b5))
84+
in
85+
86+
let rec enc j i =
87+
if i = len then ()
88+
else if i = n - 1 then emit (unsafe_get_uint8 input (off + i)) 0 0 0 0 j
89+
else if i = n - 2 then
90+
emit
91+
(unsafe_get_uint8 input (off + i))
92+
(unsafe_get_uint8 input (off + i + 1))
93+
0 0 0 j
94+
else if i = n - 3 then
95+
emit
96+
(unsafe_get_uint8 input (off + i))
97+
(unsafe_get_uint8 input (off + i + 1))
98+
(unsafe_get_uint8 input (off + i + 2))
99+
0 0 j
100+
else if i = n - 4 then
101+
emit
102+
(unsafe_get_uint8 input (off + i))
103+
(unsafe_get_uint8 input (off + i + 1))
104+
(unsafe_get_uint8 input (off + i + 2))
105+
(unsafe_get_uint8 input (off + i + 3))
106+
0 j
107+
else (
108+
emit
109+
(unsafe_get_uint8 input (off + i))
110+
(unsafe_get_uint8 input (off + i + 1))
111+
(unsafe_get_uint8 input (off + i + 2))
112+
(unsafe_get_uint8 input (off + i + 3))
113+
(unsafe_get_uint8 input (off + i + 4))
114+
j;
115+
enc (j + 8) (i + 5))
116+
in
117+
118+
let rec unsafe_fix = function
119+
| 0 -> ()
120+
| i ->
121+
unsafe_set_uint8 res (n' - i) padding;
122+
unsafe_fix (i - 1)
123+
in
124+
125+
enc 0 0;
126+
127+
(* amount of padding required *)
128+
let pad_to_write =
129+
match n mod 5 with 0 -> 0 | 1 -> 6 | 2 -> 4 | 3 -> 3 | 4 -> 1 | _ -> 0
130+
in
131+
132+
if pad then (
133+
unsafe_fix pad_to_write;
134+
Ok (Bytes.unsafe_to_string res, 0, n'))
135+
else Ok (Bytes.unsafe_to_string res, 0, n' - pad_to_write)
136+
137+
let encode ?(pad = true) ?(alphabet = default_alphabet) ?off ?len input =
138+
match encode_sub pad alphabet ?off ?len input with
139+
| Ok (res, off, len) -> Ok (String.sub res off len)
140+
| Error _ as err -> err
141+
142+
let encode_string ?pad ?alphabet input =
143+
match encode ?pad ?alphabet input with
144+
| Ok res -> res
145+
| Error _ -> assert false
146+
147+
let encode_sub ?(pad = true) ?(alphabet = default_alphabet) ?off ?len input =
148+
encode_sub pad alphabet ?off ?len input
149+
150+
let encode_exn ?pad ?alphabet ?off ?len input =
151+
match encode ?pad ?alphabet ?off ?len input with
152+
| Ok v -> v
153+
| Error (`Msg err) -> invalid_arg err
154+
155+
let decode_sub { dmap; _ } ?(off = 0) ?len input =
156+
let len =
157+
match len with Some len -> len | None -> String.length input - off
158+
in
159+
160+
if len < 0 || off < 0 || off > String.length input - len then
161+
error_msgf "Invalid bounds"
162+
else
163+
let n = len // 8 * 8 in
164+
let n' = n // 8 * 5 in
165+
let res = Bytes.create n' in
166+
167+
let get_uint8 t i =
168+
if i < len then Char.code (String.unsafe_get t (off + i)) else padding
169+
in
170+
171+
let set_uint8 t off v =
172+
(* Format.printf "set_uint8 %d\n" (v land 0xff); *)
173+
if off < 0 || off >= Bytes.length t then ()
174+
else unsafe_set_uint8 t off (v land 0xff)
175+
in
176+
177+
let emit b0 b1 b2 b3 b4 b5 b6 b7 j =
178+
set_uint8 res j ((b0 lsl 3) lor (b1 lsr 2));
179+
set_uint8 res (j + 1) ((b1 lsl 6) lor (b2 lsl 1) lor (b3 lsr 4));
180+
set_uint8 res (j + 2) ((b3 lsl 4) lor (b4 lsr 1));
181+
set_uint8 res (j + 3) ((b4 lsl 7) lor (b5 lsl 2) lor (b6 lsr 3));
182+
set_uint8 res (j + 4) ((b6 lsl 5) lor b7)
183+
in
184+
185+
let dmap i = Array.unsafe_get dmap i in
186+
187+
let get_uint8_with_padding t i padding =
188+
let x = get_uint8 t i in
189+
if x = 61 then (0, padding)
190+
else
191+
let v = dmap x in
192+
if v >= 0 then (v, 0) else raise Not_found
193+
in
194+
195+
let rec dec j i =
196+
if i = n then 0
197+
else
198+
let b0, pad0 = get_uint8_with_padding input i 5 in
199+
let b1, pad1 = get_uint8_with_padding input (i + 1) 5 in
200+
let b2, pad2 = get_uint8_with_padding input (i + 2) 4 in
201+
let b3, pad3 = get_uint8_with_padding input (i + 3) 4 in
202+
let b4, pad4 = get_uint8_with_padding input (i + 4) 3 in
203+
let b5, pad5 = get_uint8_with_padding input (i + 5) 2 in
204+
let b6, pad6 = get_uint8_with_padding input (i + 6) 2 in
205+
let b7, pad7 = get_uint8_with_padding input (i + 7) 1 in
206+
let pad =
207+
List.fold_left max 0
208+
[ pad0; pad1; pad2; pad3; pad4; pad5; pad6; pad7 ]
209+
in
210+
211+
(* Format.printf "emit %d %d %d %d %d %d %d %d\n" b0 b1 b2 b3 b4 b5 b6 b7; *)
212+
emit b0 b1 b2 b3 b4 b5 b6 b7 j;
213+
if pad == 0 then dec (j + 5) (i + 8) else pad
214+
in
215+
216+
match dec 0 0 with
217+
| pad -> Ok (Bytes.unsafe_to_string res, 0, n' - pad)
218+
| exception Not_found -> error_msgf "Malformed input"
219+
220+
let decode ?(alphabet = default_alphabet) ?off ?len input =
221+
match decode_sub alphabet ?off ?len input with
222+
| Ok (res, off, len) -> Ok (String.sub res off len)
223+
| Error _ as err -> err
224+
225+
let decode_sub ?(alphabet = default_alphabet) ?off ?len input =
226+
decode_sub alphabet ?off ?len input
227+
228+
let decode_exn ?alphabet ?off ?len input =
229+
match decode ?alphabet ?off ?len input with
230+
| Ok res -> res
231+
| Error (`Msg err) -> invalid_arg err

‎packages/melange.ppx/base32/lib/base32.mli

Lines changed: 114 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,114 @@
1+
(*
2+
* Copyright (c) 2006-2009 Citrix Systems Inc.
3+
* Copyright (c) 2010 Thomas Gazagnaire <[email protected]>
4+
* Copyright (c) 2014-2016 Anil Madhavapeddy <[email protected]>
5+
* Copyright (c) 2016 David Kaloper Meršinjak
6+
* Copyright (c) 2018 Romain Calascibetta <[email protected]>
7+
* Copyright (c) 2021 pukkamustard <[email protected]>
8+
*
9+
* Permission to use, copy, modify, and distribute this software for any
10+
* purpose with or without fee is hereby granted, provided that the above
11+
* copyright notice and this permission notice appear in all copies.
12+
*
13+
* THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
14+
* WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
15+
* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
16+
* ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
17+
* WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
18+
* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
19+
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
20+
*
21+
*)
22+
23+
(** Base32 RFC4648 implementation.
24+
25+
Base32 is a group of similar binary-to-text encoding schemes that represent
26+
binary data in an ASCII string format by translating it into a radix-32
27+
representation. It is specified in RFC 4648.
28+
29+
{e Release %%VERSION%% - %%PKG_HOMEPAGE%%} *)
30+
31+
type alphabet
32+
(** Type of alphabet. *)
33+
34+
type sub = string * int * int
35+
(** Type of sub-string: [str, off, len]. *)
36+
37+
val default_alphabet : alphabet
38+
(** A 32-character alphabet specifying the regular Base32 alphabet. *)
39+
40+
val make_alphabet : string -> alphabet
41+
(** Make a new alphabet. *)
42+
43+
val length_alphabet : alphabet -> int
44+
(** Returns length of the alphabet, should be 64. *)
45+
46+
val alphabet : alphabet -> int array
47+
(** Returns the alphabet. *)
48+
49+
val decode_exn : ?alphabet:alphabet -> ?off:int -> ?len:int -> string -> string
50+
(** [decode_exn ?off ?len s] decodes [len] bytes (defaults to
51+
[String.length s - off]) of the string [s] starting from [off] (defaults to
52+
[0]) that is encoded in Base32 format. Will leave trailing NULLs on the
53+
string, padding it out to a multiple of 3 characters. [alphabet] defaults to
54+
{!default_alphabet}. [pad = true] specifies to check if [s] is padded or
55+
not, otherwise, it raises an exception.
56+
57+
Decoder can fail when character of [s] is not a part of [alphabet] or is not
58+
[padding] character. If input is not padded correctly, decoder does the
59+
best-effort but it does not ensure [decode_exn (encode ~pad:false x) = x].
60+
61+
@raise if Invalid_argument [s] is not a valid Base32 string. *)
62+
63+
val decode_sub :
64+
?alphabet:alphabet ->
65+
?off:int ->
66+
?len:int ->
67+
string ->
68+
(sub, [> `Msg of string ]) result
69+
(** Same as {!decode_exn} but it returns a result type instead to raise an
70+
exception. Then, it returns a {!sub} string. Decoded input [(str, off, len)]
71+
will starting to [off] and will have [len] bytes - by this way, we ensure to
72+
allocate only one time result. *)
73+
74+
val decode :
75+
?alphabet:alphabet ->
76+
?off:int ->
77+
?len:int ->
78+
string ->
79+
(string, [> `Msg of string ]) result
80+
(** Same as {!decode_exn}, but returns an explicit error message {!result} if it
81+
fails. *)
82+
83+
val encode :
84+
?pad:bool ->
85+
?alphabet:alphabet ->
86+
?off:int ->
87+
?len:int ->
88+
string ->
89+
(string, [> `Msg of string ]) result
90+
(** [encode s] encodes the string [s] into base32. If [pad] is false, no
91+
trailing padding is added. [pad] defaults to [true], and [alphabet] to
92+
{!default_alphabet}.
93+
94+
[encode] fails when [off] and [len] do not designate a valid range of [s]. *)
95+
96+
val encode_string : ?pad:bool -> ?alphabet:alphabet -> string -> string
97+
(** [encode_string s] encodes the string [s] into base32. If [pad] is false, no
98+
trailing padding is added. [pad] defaults to [true], and [alphabet] to
99+
{!default_alphabet}. *)
100+
101+
val encode_sub :
102+
?pad:bool ->
103+
?alphabet:alphabet ->
104+
?off:int ->
105+
?len:int ->
106+
string ->
107+
(sub, [> `Msg of string ]) result
108+
(** Same as {!encode} but return a {!sub}-string instead a plain result. By this
109+
way, we ensure to allocate only one time result. *)
110+
111+
val encode_exn :
112+
?pad:bool -> ?alphabet:alphabet -> ?off:int -> ?len:int -> string -> string
113+
(** Same as {!encode} but raises an invalid argument exception if we retrieve an
114+
error. *)

‎packages/melange.ppx/base32/lib/dune

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,3 @@
1+
(library
2+
(name base32)
3+
(public_name server-reason-react.base32))

‎packages/melange.ppx/dune

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -3,7 +3,7 @@
33
(public_name server-reason-react.melange_ppx)
44
(ppx_runtime_libraries server-reason-react.runtime)
55
(flags :standard -w -9)
6-
(libraries ppxlib ppxlib.astlib str quickjs)
6+
(libraries base32 ppxlib ppxlib.astlib str quickjs xxhash)
77
(preprocess
88
(pps ppxlib.metaquot))
99
(kind ppx_rewriter))

0 commit comments

Comments
 (0)