builder-web/db/representation.ml

142 lines
4.4 KiB
OCaml

module Asn = struct
let decode_strict codec cs =
match Asn.decode codec cs with
| Ok (a, cs) ->
if Cstruct.length cs = 0
then Ok a
else Error "trailing bytes"
| Error (`Parse msg) -> Error ("parse error: " ^ msg)
let projections_of asn =
let c = Asn.codec Asn.der asn in
(decode_strict c, Asn.encode c)
let console =
Asn.S.(sequence_of
(sequence2
(required ~label:"delta" int)
(required ~label:"data" utf8_string)))
let console_of_cs, console_to_cs = projections_of console
end
type untyped_id = int64
let untyped_id = Caqti_type.int64
type 'a id = untyped_id
let id (_ : 'a) : 'a id Caqti_type.t = untyped_id
let any_id : 'a id Caqti_type.t = untyped_id
type file = {
filepath : Fpath.t;
localpath : Fpath.t;
sha256 : Cstruct.t;
size : int;
}
let uuid =
let encode uuid = Ok (Uuidm.to_bytes uuid) in
let decode s =
Uuidm.of_bytes s
|> Option.to_result ~none:"failed to decode uuid"
in
Caqti_type.custom ~encode ~decode Caqti_type.string
let ptime =
let encode t = Ok (Ptime.Span.to_d_ps (Ptime.to_span t)) in
let decode (d, ps) = Ok (Ptime.v (d, ps))
in
let rep = Caqti_type.(tup2 int int64) in
Caqti_type.custom ~encode ~decode rep
let fpath =
let encode t = Ok (Fpath.to_string t) in
let decode s = Fpath.of_string s
|> Result.map_error (fun (`Msg s) -> s) in
Caqti_type.custom ~encode ~decode Caqti_type.string
let cstruct =
let encode t = Ok (Cstruct.to_string t) in
let decode s = Ok (Cstruct.of_string s) in
Caqti_type.custom ~encode ~decode Caqti_type.octets
let file =
let encode { filepath; localpath; sha256; size } =
Ok (filepath, localpath, sha256, size) in
let decode (filepath, localpath, sha256, size) =
Ok { filepath; localpath; sha256; size } in
Caqti_type.custom ~encode ~decode Caqti_type.(tup4 fpath fpath cstruct int)
let file_opt =
let rep = Caqti_type.(tup4 (option fpath) (option fpath) (option cstruct) (option int)) in
let encode = function
| Some { filepath; localpath; sha256; size } ->
Ok (Some filepath, Some localpath, Some sha256, Some size)
| None ->
Ok (None, None, None, None)
in
let decode = function
| (Some filepath, Some localpath, Some sha256, Some size) ->
Ok (Some { filepath; localpath; sha256; size })
| (None, None, None, None) ->
Ok None
| _ ->
(* This should not happen if the database is well-formed *)
Error "Some but not all fields NULL"
in
Caqti_type.custom ~encode ~decode rep
let execution_result =
let encode = function
| Builder.Exited v -> Ok (v, None)
| Builder.Signalled v -> Ok (v lsl 8, None)
| Builder.Stopped v -> Ok (v lsl 16, None)
| Builder.Msg msg -> Ok (65536, Some msg)
in
let decode (code, msg) =
if code <= 0xFF then
Ok (Builder.Exited code)
else if code <= 0xFFFF then
Ok (Builder.Signalled (code lsr 8))
else if code <= 0xFFFFFF then
Ok (Builder.Stopped (code lsr 16))
else if code = 65536 then
match msg with
| None -> Error "bad encoding"
| Some m -> Ok (Builder.Msg m)
else
Error "bad encoding (unknown number)"
in
let rep = Caqti_type.(tup2 int (option string)) in
Caqti_type.custom ~encode ~decode rep
let console =
let encode console = Ok (Asn.console_to_cs console) in
let decode data = Asn.console_of_cs data in
Caqti_type.custom ~encode ~decode cstruct
let user_info =
let rep = Caqti_type.(tup4 string cstruct cstruct (tup4 int int int bool)) in
let encode { Builder_web_auth.username;
password_hash = `Scrypt (password_hash, password_salt, {
Builder_web_auth.scrypt_n; scrypt_r; scrypt_p
});
restricted; }
=
Ok (username, password_hash, password_salt, (scrypt_n, scrypt_r, scrypt_p, restricted))
in
let decode (username, password_hash, password_salt, (scrypt_n, scrypt_r, scrypt_p, restricted)) =
Ok { Builder_web_auth.username;
password_hash =
`Scrypt (password_hash, password_salt,
{ Builder_web_auth.scrypt_n;
scrypt_r; scrypt_p });
restricted; } in
Caqti_type.custom ~encode ~decode rep
(* this doesn't really belong in this module, but we need access to the type of [id] *)
let last_insert_rowid =
Caqti_request.find
Caqti_type.unit
any_id
"SELECT last_insert_rowid()"