robur/builder-web
4
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Merge pull request 'remove usage of cstruct, require mirage-crypto 1.0.0' (!1) from no-cstruct into main

Browse source 
Reviewed-on: #1
Reviewed-by: Reynir Björnsson <reynir@reynir.dk>
This commit is contained in:
Reynir Björnsson 2024-09-05 15:12:37 +00:00
commit 47b1759d0f
20 changed files with 123 additions and 136 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

12
auth/builder_web_auth.ml
View file

@ -12,9 +12,9 @@ let scrypt_params ?(scrypt_n = 16384) ?(scrypt_r = 8) ?(scrypt_p = 1) () =
{ scrypt_n; scrypt_r; scrypt_p }
type pbkdf2_sha256 =
[ `Pbkdf2_sha256 of Cstruct.t * Cstruct.t * pbkdf2_sha256_params ]
[ `Pbkdf2_sha256 of string * string * pbkdf2_sha256_params ]
type scrypt = [ `Scrypt of Cstruct.t * Cstruct.t * scrypt_params ]
type scrypt = [ `Scrypt of string * string * scrypt_params ]
type password_hash = [ pbkdf2_sha256 | scrypt ]
@ -25,10 +25,10 @@ type 'a user_info = {
}
let pbkdf2_sha256 ~params:{ pbkdf2_sha256_iter = count } ~salt ~password =
Pbkdf.pbkdf2 ~prf:`SHA256 ~count ~dk_len:32l ~salt ~password:(Cstruct.of_string password)
Pbkdf.pbkdf2 ~prf:`SHA256 ~count ~dk_len:32l ~salt ~password
let scrypt ~params:{ scrypt_n = n; scrypt_r = r; scrypt_p = p } ~salt ~password =
Scrypt_kdf.scrypt_kdf ~n ~r ~p ~dk_len:32l ~salt ~password:(Cstruct.of_string password)
Scrypt.scrypt ~n ~r ~p ~dk_len:32l ~salt ~password
let hash ?(scrypt_params=scrypt_params ())
~username ~password ~restricted () =
@ -43,10 +43,10 @@ let hash ?(scrypt_params=scrypt_params ())
let verify_password password user_info =
match user_info.password_hash with
| `Pbkdf2_sha256 (password_hash, salt, params) ->
Cstruct.equal
String.equal
(pbkdf2_sha256 ~params ~salt ~password)
password_hash
| `Scrypt (password_hash, salt, params) ->
Cstruct.equal
String.equal
(scrypt ~params ~salt ~password)
password_hash

2
auth/dune
View file

@ -1,3 +1,3 @@
(library
(name builder_web_auth)
(libraries pbkdf scrypt-kdf mirage-crypto-rng))
(libraries kdf.pbkdf kdf.scrypt mirage-crypto-rng))

51
bin/builder_db_app.ml
View file

@ -17,7 +17,7 @@ let defer_foreign_keys =
"PRAGMA defer_foreign_keys = ON"
let build_artifacts_to_orphan =
Builder_db.Rep.id `build ->* Builder_db.Rep.cstruct @@
Builder_db.Rep.id `build ->* Caqti_type.octets @@
{| SELECT a.sha256 FROM build_artifact a
WHERE a.build = ? AND
(SELECT COUNT(*) FROM build_artifact a2
@ -45,7 +45,7 @@ let migrate () dbpath =
let artifacts_dir datadir = Fpath.(datadir / "_artifacts")
let artifact_path sha256 =
let (`Hex sha256) = Hex.of_cstruct sha256 in
let sha256 = Ohex.encode sha256 in
(* NOTE: [sha256] is 64 characters when it's a hex sha256 checksum *)
(* NOTE: We add the prefix to reduce the number of files in a directory - a
workaround for inferior filesystems. We can easily revert this by changing
@ -108,7 +108,7 @@ let user_disable () dbpath username =
match user with
| None -> Error (`Msg "user not found")
| Some (_, user_info) ->
let password_hash = `Scrypt (Cstruct.empty, Cstruct.empty, Builder_web_auth.scrypt_params ()) in
let password_hash = `Scrypt ("", "", Builder_web_auth.scrypt_params ()) in
let user_info = { user_info with password_hash ; restricted = true } in
Db.exec Builder_db.User.update_user user_info
in
@ -296,12 +296,12 @@ let vacuum () datadir platform_opt jobnames predicate =
or_die 1 r
let input_ids =
Caqti_type.unit ->* Builder_db.Rep.cstruct @@
Caqti_type.unit ->* Caqti_type.octets @@
"SELECT DISTINCT input_id FROM build WHERE input_id IS NOT NULL"
let main_artifact_hash =
Builder_db.Rep.cstruct ->*
Caqti_type.t3 Builder_db.Rep.cstruct Builder_db.Rep.uuid Caqti_type.string @@
Caqti_type.octets ->*
Caqti_type.t3 Caqti_type.octets Builder_db.Rep.uuid Caqti_type.string @@
{|
SELECT a.sha256, b.uuid, j.name FROM build_artifact a, build b, job j
WHERE b.input_id = ? AND a.id = b.main_binary AND b.job = j.id
@ -319,12 +319,12 @@ let verify_input_id () dbpath =
match hashes with
| (h, uuid, jobname) :: tl ->
List.iter (fun (h', uuid', _) ->
if Cstruct.equal h h' then
if String.equal h h' then
()
else
Logs.warn (fun m -> m "job %s input id %a with two different hashes (%a, %a), build %a and %a"
jobname Cstruct.hexdump_pp input_id
Cstruct.hexdump_pp h Cstruct.hexdump_pp h'
jobname Ohex.pp input_id
Ohex.pp h Ohex.pp h'
Uuidm.pp uuid Uuidm.pp uuid'))
tl
| [] -> ())
@ -336,10 +336,9 @@ let num_build_artifacts =
Caqti_type.unit ->! Caqti_type.int @@
"SELECT count(*) FROM build_artifact"
let build_artifacts : (unit, string * Uuidm.t * Fpath.t * Cstruct.t * int64, [ `One | `Zero | `Many ]) Caqti_request.t =
let build_artifacts : (unit, string * Uuidm.t * Fpath.t * string * int64, [ `One | `Zero | `Many ]) Caqti_request.t =
Caqti_type.unit ->*
Caqti_type.(t5 string Builder_db.Rep.uuid Builder_db.Rep.fpath
Builder_db.Rep.cstruct int64)
Caqti_type.(t5 string Builder_db.Rep.uuid Builder_db.Rep.fpath octets int64)
@@
{| SELECT job.name, b.uuid, a.filepath, a.sha256, a.size
FROM build_artifact a, build b, job
@ -397,12 +396,12 @@ let verify_data_dir () datadir =
files_tracked := FpathSet.add (artifact_path sha256) !files_tracked;
let s = Int64.of_int (String.length data) in
if s <> size then Logs.err (fun m -> m "File %a has different size (in DB %Lu on disk %Lu)" Fpath.pp abs_path size s);
let sha256' = Mirage_crypto.Hash.SHA256.digest (Cstruct.of_string data) in
if not (Cstruct.equal sha256 sha256') then
let sha256' = Digestif.SHA256.(to_raw_string (digest_string data)) in
if not (String.equal sha256 sha256') then
Logs.err (fun m -> m "File %a has different hash (in DB %a on disk %a)"
Fpath.pp abs_path
Hex.pp (Hex.of_cstruct sha256)
Hex.pp (Hex.of_cstruct sha256'))) ;
Ohex.pp sha256
Ohex.pp sha256')) ;
Ok ()
else
Ok ()
@ -545,8 +544,8 @@ module Verify_cache_dir = struct
type t = {
uuid : Uuidm.t;
job_name : string;
hash_opam_switch : Cstruct.t option;
hash_debug_bin : Cstruct.t option;
hash_opam_switch : string option;
hash_debug_bin : string option;
}
let repr =
@ -560,8 +559,8 @@ module Verify_cache_dir = struct
t4
Builder_db.Rep.uuid
string
(option Builder_db.Rep.cstruct)
(option Builder_db.Rep.cstruct))
(option octets)
(option octets))
end
@ -587,7 +586,7 @@ module Verify_cache_dir = struct
let* latest_version =
Viz_aux.get_viz_version_from_dirs ~cachedir ~viz_typ
in
let `Hex viz_input_hash = Hex.of_cstruct hash in
let viz_input_hash = Ohex.encode hash in
let* viz_path =
Viz_aux.choose_versioned_viz_path
~cachedir
@ -667,7 +666,7 @@ module Verify_cache_dir = struct
match extract_hash ~viz_typ build with
| None -> ()
| Some input_hash ->
let `Hex input_hash = Hex.of_cstruct input_hash in
let input_hash = Ohex.encode input_hash in
let viz_path = Viz_aux.viz_path
~cachedir
~viz_typ
@ -741,8 +740,8 @@ end
module Asn = struct
let decode_strict codec cs =
match Asn.decode codec cs with
| Ok (a, cs) ->
if Cstruct.length cs = 0
| Ok (a, rest) ->
if String.length rest = 0
then Ok a
else Error "trailing bytes"
| Error (`Parse msg) -> Error ("parse error: " ^ msg)
@ -808,8 +807,8 @@ let extract_full () datadir dest uuid =
artifacts
in
let exec = (job, uuid, out, start, finish, result, data) in
let cs = Builder.Asn.exec_to_cs exec in
Bos.OS.File.write (Fpath.v dest) (Cstruct.to_string cs)
let data = Builder.Asn.exec_to_str exec in
Bos.OS.File.write (Fpath.v dest) data
in
or_die 1 r

2
bin/builder_web_app.ml
View file

@ -30,7 +30,7 @@ let write_raw s buf =
safe_close s >|= fun () ->
Error `Exception)
in
(* Logs.debug (fun m -> m "writing %a" Cstruct.hexdump_pp (Cstruct.of_bytes buf)) ; *)
(* Logs.debug (fun m -> m "writing %a" (Ohex.pp_hexdump ()) (Bytes.unsafe_to_string buf)) ; *)
w 0 (Bytes.length buf)
let process =

10
bin/migrations/m20210706.ml
View file

@ -57,9 +57,9 @@ let builds =
Caqti_type.unit ->*
Caqti_type.t4
Builder_db.Rep.untyped_id
Builder_db.Rep.cstruct
Builder_db.Rep.cstruct
Builder_db.Rep.cstruct @@
Caqti_type.octets
Caqti_type.octets
Caqti_type.octets @@
{| SELECT b.id, opam.sha256, env.sha256, system.sha256
FROM build b, build_artifact opam, build_artifact env, build_artifact system
WHERE opam.filepath = 'opam-switch' AND env.filepath = 'build-environment'
@ -68,7 +68,7 @@ let builds =
|}
let set_input_id =
Caqti_type.t2 Builder_db.Rep.untyped_id Builder_db.Rep.cstruct ->. Caqti_type.unit @@
Caqti_type.t2 Builder_db.Rep.untyped_id Caqti_type.octets ->. Caqti_type.unit @@
"UPDATE build SET input_id = $2 WHERE id = $1"
let migrate _datadir (module Db : Caqti_blocking.CONNECTION) =
@ -76,7 +76,7 @@ let migrate _datadir (module Db : Caqti_blocking.CONNECTION) =
Db.exec add_input_id_to_build () >>= fun () ->
Db.collect_list builds () >>= fun builds ->
Grej.list_iter_result (fun (id, opam_sha, env_sha, pkg_sha) ->
let input_id = Mirage_crypto.Hash.SHA256.digest (Cstruct.concat [ opam_sha ; env_sha ; pkg_sha ]) in
let input_id = Digestif.SHA256.(to_raw_string (digestv_string [ opam_sha ; env_sha ; pkg_sha ])) in
Db.exec set_input_id (id, input_id))
builds >>= fun () ->
Db.exec (Grej.set_version new_version) ()

7
bin/migrations/m20210707c.ml
View file

@ -16,8 +16,8 @@ let update_paths : ([`build_artifact] Builder_db.Rep.id * Fpath.t * Fpath.t, uni
Caqti_type.unit @@
"UPDATE build_artifact SET localpath = $2, filepath = $3 WHERE id = $1"
let add_artifact : ((Fpath.t * Fpath.t * Cstruct.t) * (int64 * [`build] Builder_db.Rep.id), unit, [ `Zero]) Caqti_request.t =
Caqti_type.(t2 (t3 Builder_db.Rep.fpath Builder_db.Rep.fpath Builder_db.Rep.cstruct)
let add_artifact : ((Fpath.t * Fpath.t * string) * (int64 * [`build] Builder_db.Rep.id), unit, [ `Zero]) Caqti_request.t =
Caqti_type.(t2 (t3 Builder_db.Rep.fpath Builder_db.Rep.fpath Caqti_type.octets)
(t2 Caqti_type.int64 (Builder_db.Rep.id `build))) ->.
Caqti_type.unit @@
"INSERT INTO build_artifact (filepath, localpath, sha256, size, build) VALUES (?, ?, ?, ?, ?)"
@ -48,7 +48,8 @@ let fixup datadir (module Db : Caqti_blocking.CONNECTION) =
in
assert (r = 0);
Bos.OS.File.read (Fpath.append datadir artifact_lpath) >>= fun data ->
let size = Int64.of_int (String.length data) and sha256 = Mirage_crypto.Hash.SHA256.digest (Cstruct.of_string data) in
let size = Int64.of_int (String.length data)
and sha256 = Digestif.SHA256.(to_raw_string (digest_string data)) in
Db.exec update_paths (artifact_id, new_artifact_lpath, path artifact_fpath) >>= fun () ->
Db.exec add_artifact ((artifact_fpath, artifact_lpath, sha256), (size, build_id)) >>= fun () ->
Db.find Builder_db.last_insert_rowid () >>= fun new_build_artifact_id ->

8
bin/migrations/m20210712c.ml
View file

@ -8,8 +8,8 @@ open Grej.Infix
module Asn = struct
let decode_strict codec cs =
match Asn.decode codec cs with
| Ok (a, cs) ->
if Cstruct.length cs = 0
| Ok (a, rest) ->
if String.length rest = 0
then Ok a
else Error "trailing bytes"
| Error (`Parse msg) -> Error ("parse error: " ^ msg)
@ -96,7 +96,7 @@ let copy_from_new_build =
let old_build_console_script =
Caqti_type.unit ->*
Caqti_type.(t4 (Builder_db.Rep.id (`build : [ `build ]))
(t2 string Builder_db.Rep.uuid) Builder_db.Rep.cstruct string) @@
(t2 string Builder_db.Rep.uuid) octets string) @@
"SELECT b.id, job.name, b.uuid, b.console, b.script FROM build b, job WHERE b.job = job.id"
let update_new_build_console_script =
@ -112,7 +112,7 @@ let new_build_console_script =
"SELECT id, console, script FROM build"
let update_old_build_console_script =
Caqti_type.(t3 (Builder_db.Rep.id (`build : [ `build ])) Builder_db.Rep.cstruct string) ->.
Caqti_type.(t3 (Builder_db.Rep.id (`build : [ `build ])) octets string) ->.
Caqti_type.unit @@
"UPDATE new_build SET console = $2, script = $3 WHERE id = $1"

16
builder-web.opam
View file

@ -17,18 +17,16 @@ build: [
depends: [
"ocaml" {>= "4.13.0"}
"dune" {>= "2.7.0"}
"builder" {>= "0.2.0"}
"dream" {>= "1.0.0~alpha4"}
"cstruct" {>= "6.0.0"}
"builder" {>= "0.4.0"}
"dream" {>= "1.0.0~alpha7"}
"bos"
"hex"
"ohex" {>= "0.2.0"}
"lwt" {>= "5.7.0"}
"caqti" {>= "2.1.1"}
"caqti" {>= "2.1.2"}
"caqti-lwt"
"caqti-driver-sqlite3"
"pbkdf"
"mirage-crypto-rng" {>= "0.11.0"}
"scrypt-kdf"
"kdf"
"opam-core"
"opam-format" {>= "2.1.0"}
"metrics" {>= "0.3.0"}
@ -39,8 +37,7 @@ depends: [
"tyxml" {>= "4.3.0"}
"ptime"
"duration"
"mirage-crypto"
"asn1-combinators"
"asn1-combinators" {>= "0.3.0"}
"logs"
"cmdliner" {>= "1.1.0"}
"uri"
@ -51,6 +48,7 @@ depends: [
"owee"
"solo5-elftool" {>= "0.3.0"}
"decompress" {>= "1.5.0"}
"digestif" {>= "1.2.0"}
"alcotest" {>= "1.2.0" & with-test}
"ppx_deriving" {with-test}
"ppx_deriving_yojson" {with-test}

24
db/builder_db.ml
View file

@ -12,7 +12,7 @@ type 'a id = 'a Rep.id
type file = Rep.file = {
filepath : Fpath.t;
sha256 : Cstruct.t;
sha256 : string;
size : int;
}
@ -172,7 +172,7 @@ module Build_artifact = struct
"SELECT id, filepath, sha256, size FROM build_artifact WHERE build = ?"
let exists =
cstruct ->! Caqti_type.bool @@
Caqti_type.octets ->! Caqti_type.bool @@
"SELECT EXISTS(SELECT 1 FROM build_artifact WHERE sha256 = ?)"
let add =
@ -199,7 +199,7 @@ module Build = struct
script : Fpath.t;
platform : string;
main_binary : [`build_artifact] id option;
input_id : Cstruct.t option;
input_id : string option;
user_id : [`user] id;
job_id : [`job] id;
}
@ -224,7 +224,7 @@ module Build = struct
Fpath.pp t.script
t.platform
Fmt.(Dump.option int64) t.main_binary
Fmt.(Dump.option (using Cstruct.to_string string)) t.input_id
Fmt.(Dump.option string) t.input_id
t.user_id
t.job_id
@ -240,7 +240,7 @@ module Build = struct
fpath
string
(option (Rep.id `build_artifact))
(option Rep.cstruct)
(option octets)
(id `user)
(id `job))
in
@ -314,7 +314,7 @@ module Build = struct
|}
let get_all_artifact_sha =
Caqti_type.(t2 (id `job) (option string)) ->* Rep.cstruct @@
Caqti_type.(t2 (id `job) (option string)) ->* Caqti_type.octets @@
{| SELECT DISTINCT a.sha256
FROM build_artifact a, build b
WHERE b.job = $1 AND b.main_binary = a.id
@ -446,7 +446,7 @@ module Build = struct
|}
let get_same_input_different_output_hashes =
id `build ->* Rep.cstruct @@
id `build ->* Caqti_type.octets @@
{| SELECT DISTINCT a.sha256
FROM build b0, build_artifact a0, build b, build_artifact a
WHERE b0.id = ? AND a0.id = b0.main_binary AND a0.sha256 <> a.sha256
@ -455,7 +455,7 @@ module Build = struct
|}
let get_different_input_same_output_input_ids =
id `build ->* Rep.cstruct @@
id `build ->* Caqti_type.octets @@
{| SELECT DISTINCT b.input_id
FROM build b0, build_artifact a0, build b, build_artifact a
WHERE b0.id = ? AND a0.id = b0.main_binary AND a0.sha256 = a.sha256
@ -463,7 +463,7 @@ module Build = struct
|}
let get_one_by_input_id =
Rep.cstruct ->! t @@
Caqti_type.octets ->! t @@
{| SELECT uuid, start_d, start_ps, finish_d, finish_ps,
result_code, result_msg, console, script,
platform, main_binary, input_id, user, job
@ -487,7 +487,7 @@ module Build = struct
|}
let get_by_hash =
Rep.cstruct ->! t @@
Caqti_type.octets ->! t @@
{| SELECT
b.uuid, b.start_d, b.start_ps, b.finish_d, b.finish_ps,
b.result_code, b.result_msg, b.console, b.script,
@ -500,7 +500,7 @@ module Build = struct
|}
let get_with_main_binary_by_hash =
Rep.cstruct ->! Caqti_type.t2 t file_opt @@
Caqti_type.octets ->! Caqti_type.t2 t file_opt @@
{| SELECT b.uuid, b.start_d, b.start_ps, b.finish_d, b.finish_ps,
b.result_code, b.result_msg, b.console, b.script,
b.platform, b.main_binary, b.input_id, b.user, b.job,
@ -513,7 +513,7 @@ module Build = struct
|}
let get_with_jobname_by_hash =
Rep.cstruct ->? Caqti_type.t2 Caqti_type.string t @@
Caqti_type.octets ->? Caqti_type.t2 Caqti_type.string t @@
{| SELECT job.name,
b.uuid, b.start_d, b.start_ps, b.finish_d, b.finish_ps,
b.result_code, b.result_msg,

23
db/builder_db.mli
View file

@ -3,7 +3,7 @@ module Rep : sig
type 'a id
type file = {
filepath : Fpath.t;
sha256 : Cstruct.t;
sha256 : string;
size : int;
}
@ -13,7 +13,6 @@ module Rep : sig
val uuid : Uuidm.t Caqti_type.t
val ptime : Ptime.t Caqti_type.t
val fpath : Fpath.t Caqti_type.t
val cstruct : Cstruct.t Caqti_type.t
val file : file Caqti_type.t
val execution_result : Builder.execution_result Caqti_type.t
val console : (int * string) list Caqti_type.t
@ -22,7 +21,7 @@ type 'a id = 'a Rep.id
type file = Rep.file = {
filepath : Fpath.t;
sha256 : Cstruct.t;
sha256 : string;
size : int;
}
@ -85,7 +84,7 @@ module Build_artifact : sig
Caqti_request.t
val get_all_by_build :
([`build] id, [`build_artifact] id * file, [ `Many | `One | `Zero ]) Caqti_request.t
val exists : (Cstruct.t, bool, [ `One ]) Caqti_request.t
val exists : (string, bool, [ `One ]) Caqti_request.t
val add :
(file * [`build] id, unit, [ `Zero ]) Caqti_request.t
val remove_by_build :
@ -105,7 +104,7 @@ sig
script : Fpath.t;
platform : string;
main_binary : [`build_artifact] id option;
input_id : Cstruct.t option;
input_id : string option;
user_id : [`user] id;
job_id : [`job] id;
}
@ -120,7 +119,7 @@ sig
val get_all_failed :
(int * int * string option, string * t, [ `Many | `One | `Zero ]) Caqti_request.t
val get_all_artifact_sha :
([`job] id * string option, Cstruct.t, [ `Many | `One | `Zero ]) Caqti_request.t
([`job] id * string option, string, [ `Many | `One | `Zero ]) Caqti_request.t
val get_latest_successful_with_binary :
([`job] id * string, [`build] id * t * file, [ `One | `Zero ])
Caqti_request.t
@ -144,20 +143,20 @@ sig
val get_same_input_same_output_builds :
([`build] id, t, [ `Many | `One | `Zero ]) Caqti_request.t
val get_same_input_different_output_hashes :
([`build] id, Cstruct.t, [ `Many | `One | `Zero ]) Caqti_request.t
([`build] id, string, [ `Many | `One | `Zero ]) Caqti_request.t
val get_different_input_same_output_input_ids :
([`build] id, Cstruct.t, [ `Many | `One | `Zero ]) Caqti_request.t
([`build] id, string, [ `Many | `One | `Zero ]) Caqti_request.t
val get_one_by_input_id :
(Cstruct.t, t, [ `One ]) Caqti_request.t
(string, t, [ `One ]) Caqti_request.t
val get_platforms_for_job :
([`job] id, string, [ `Many | `One | `Zero ]) Caqti_request.t
val add : (t, unit, [ `Zero ]) Caqti_request.t
val get_by_hash :
(Cstruct.t, t, [ `One]) Caqti_request.t
(string, t, [ `One]) Caqti_request.t
val get_with_main_binary_by_hash :
(Cstruct.t, t * file option, [ `One]) Caqti_request.t
(string, t * file option, [ `One]) Caqti_request.t
val get_with_jobname_by_hash :
(Cstruct.t, string * t, [ `One | `Zero]) Caqti_request.t
(string, string * t, [ `One | `Zero]) Caqti_request.t
val set_main_binary : ([`build] id * [`build_artifact] id, unit, [ `Zero ]) Caqti_request.t
val remove : ([`build] id, unit, [ `Zero]) Caqti_request.t
end

3
db/dune
View file

@ -1,4 +1,3 @@
(library
(name builder_db)
(libraries builder caqti caqti-driver-sqlite3 asn1-combinators mirage-crypto
builder_web_auth))
(libraries builder caqti caqti-driver-sqlite3 asn1-combinators builder_web_auth))

25
db/representation.ml
View file

@ -1,8 +1,8 @@
module Asn = struct
let decode_strict codec cs =
match Asn.decode codec cs with
| Ok (a, cs) ->
if Cstruct.length cs = 0
| Ok (a, rest) ->
if String.length rest = 0
then Ok a
else Error "trailing bytes"
| Error (`Parse msg) -> Error ("parse error: " ^ msg)
@ -17,7 +17,7 @@ module Asn = struct
(required ~label:"delta" int)
(required ~label:"data" utf8_string)))
let console_of_cs, console_to_cs = projections_of console
let console_of_str, console_to_str = projections_of console
end
type untyped_id = int64
@ -30,7 +30,7 @@ let id_to_int64 (id : 'a id) : int64 = id
type file = {
filepath : Fpath.t;
sha256 : Cstruct.t;
sha256 : string;
size : int;
}
@ -56,20 +56,15 @@ let fpath =
|> 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; sha256; size } =
Ok (filepath, sha256, size) in
let decode (filepath, sha256, size) =
Ok { filepath; sha256; size } in
Caqti_type.custom ~encode ~decode Caqti_type.(t3 fpath cstruct int)
Caqti_type.custom ~encode ~decode Caqti_type.(t3 fpath octets int)
let file_opt =
let rep = Caqti_type.(t3 (option fpath) (option cstruct) (option int)) in
let rep = Caqti_type.(t3 (option fpath) (option octets) (option int)) in
let encode = function
| Some { filepath; sha256; size } ->
Ok (Some filepath, Some sha256, Some size)
@ -112,12 +107,12 @@ let execution_result =
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 encode console = Ok (Asn.console_to_str console) in
let decode data = Asn.console_of_str data in
Caqti_type.(custom ~encode ~decode octets)
let user_info =
let rep = Caqti_type.(t7 string cstruct cstruct int int int bool) in
let rep = Caqti_type.(t7 string octets octets 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

30
lib/builder_web.ml
View file

@ -134,14 +134,14 @@ module Viz_aux = struct
viz_dir ~cachedir ~viz_typ ~version
/ input_hash + "html"
)
let choose_versioned_viz_path
~cachedir
~viz_typ
~viz_input_hash
~current_version =
let ( >>= ) = Result.bind in
let rec aux current_version =
let rec aux current_version =
let path =
viz_path ~cachedir
~viz_typ
@ -153,7 +153,7 @@ module Viz_aux = struct
Error (`Msg (Fmt.str "viz '%s': There exist no version of the requested \
visualization"
(viz_type_to_string viz_typ)))
else
else
aux @@ pred current_version
)
in
@ -162,7 +162,7 @@ module Viz_aux = struct
let get_viz_version_from_dirs ~cachedir ~viz_typ =
let ( >>= ) = Result.bind in
Bos.OS.Dir.contents cachedir >>= fun versioned_dirs ->
let max_cached_version =
let max_cached_version =
let viz_typ_str = viz_type_to_string viz_typ ^ "_" in
versioned_dirs
|> List.filter_map (fun versioned_dir ->
@ -171,7 +171,7 @@ module Viz_aux = struct
Logs.warn (fun m -> m "%s" err);
None
| Ok false -> None
| Ok true ->
| Ok true ->
let dir_str = Fpath.filename versioned_dir in
if not (String.starts_with ~prefix:viz_typ_str dir_str) then
None
@ -199,10 +199,6 @@ module Viz_aux = struct
let hash_viz_input ~uuid typ db =
let open Builder_db in
let hex cstruct =
let `Hex hex_str = Hex.of_cstruct cstruct in
hex_str
in
main_binary_of_uuid uuid db >>= fun main_binary ->
Model.build uuid db
|> if_error "Error getting build" >>= fun (build_id, _build) ->
@ -210,7 +206,7 @@ module Viz_aux = struct
|> if_error "Error getting build artifacts" >>= fun artifacts ->
match typ with
| `Treemap ->
let debug_binary =
let debug_binary =
let bin = Fpath.base main_binary.filepath in
List.find_opt
(fun p -> Fpath.(equal (bin + "debug") (base p.filepath)))
@ -220,10 +216,10 @@ module Viz_aux = struct
Model.not_found debug_binary
|> not_found_error >>= fun debug_binary ->
debug_binary.sha256
|> hex
|> Ohex.encode
|> Lwt_result.return
end
| `Dependencies ->
end
| `Dependencies ->
let opam_switch =
List.find_opt
(fun p -> Fpath.(equal (v "opam-switch") (base p.filepath)))
@ -232,7 +228,7 @@ module Viz_aux = struct
Model.not_found opam_switch
|> not_found_error >>= fun opam_switch ->
opam_switch.sha256
|> hex
|> Ohex.encode
|> Lwt_result.return
let try_load_cached_visualization ~cachedir ~uuid viz_typ db =
@ -428,7 +424,7 @@ let routes ~datadir ~cachedir ~configdir ~expired_jobs =
|> if_error ~status:`Not_Found "File not found" >>= fun filepath ->
Dream.sql req (Model.build_artifact build filepath)
|> if_error "Error getting build artifact" >>= fun file ->
let etag = Base64.encode_string (Cstruct.to_string file.Builder_db.sha256) in
let etag = Base64.encode_string file.Builder_db.sha256 in
match if_none_match with
| Some etag' when etag = etag' ->
Dream.empty `Not_Modified |> Lwt_result.ok
@ -498,7 +494,7 @@ let routes ~datadir ~cachedir ~configdir ~expired_jobs =
let upload req =
let* body = Dream.body req in
Builder.Asn.exec_of_cs (Cstruct.of_string body) |> Lwt.return
Builder.Asn.exec_of_str body |> Lwt.return
|> if_error ~status:`Bad_Request "Bad request"
~log:(fun e ->
Log.warn (fun m -> m "Received bad builder ASN.1");
@ -530,7 +526,7 @@ let routes ~datadir ~cachedir ~configdir ~expired_jobs =
Dream.query req "sha256" |> Option.to_result ~none:(`Msg "Missing sha256 query parameter")
|> Lwt.return
|> if_error ~status:`Bad_Request "Bad request" >>= fun hash_hex ->
begin try Hex.to_cstruct (`Hex hash_hex) |> Lwt_result.return
begin try Ohex.decode hash_hex |> Lwt_result.return
with Invalid_argument e -> Lwt_result.fail (`Msg ("Bad hex: " ^ e))
end
|> if_error ~status:`Bad_Request "Bad request" >>= fun hash ->

4
lib/dune
View file

@ -1,5 +1,5 @@
(library
(name builder_web)
(libraries builder builder_db dream tyxml bos duration hex caqti-lwt
(libraries builder builder_db dream tyxml bos duration ohex caqti-lwt
opamdiff ptime.clock.os cmarkit tar tar.gz tar-unix owee solo5-elftool decompress.de
decompress.gz uri))
decompress.gz uri digestif))

13
lib/model.ml
View file

@ -20,7 +20,7 @@ let not_found = function
let staging datadir = Fpath.(datadir / "_staging")
let artifact_path artifact =
let (`Hex sha256) = Hex.of_cstruct artifact.Builder_db.sha256 in
let sha256 = Ohex.encode artifact.Builder_db.sha256 in
(* NOTE: [sha256] is 64 characters when it's a hex sha256 checksum *)
(* NOTE: We add the prefix to reduce the number of files in a directory - a
workaround for inferior filesystems. We can easily revert this by changing
@ -221,7 +221,7 @@ let save_artifacts staging artifacts =
List.fold_left
(fun r (file, data) ->
r >>= fun () ->
let (`Hex sha256) = Hex.of_cstruct file.Builder_db.sha256 in
let sha256 = Ohex.encode file.Builder_db.sha256 in
let destpath = Fpath.(staging / sha256) in
save destpath data)
(Lwt_result.return ())
@ -232,7 +232,7 @@ let commit_files datadir staging_dir job_name uuid artifacts =
List.fold_left
(fun r artifact ->
r >>= fun () ->
let (`Hex sha256) = Hex.of_cstruct artifact.Builder_db.sha256 in
let sha256 = Ohex.encode artifact.Builder_db.sha256 in
let src = Fpath.(staging_dir / sha256) in
let dest = Fpath.(datadir // artifact_path artifact) in
Lwt.return (Bos.OS.Dir.create (Fpath.parent dest)) >>= fun _created ->
@ -306,7 +306,8 @@ let compute_input_id artifacts =
get_hash (Fpath.v "build-environment"),
get_hash (Fpath.v "system-packages")
with
| Some a, Some b, Some c -> Some (Mirage_crypto.Hash.SHA256.digest (Cstruct.concat [a;b;c]))
| Some a, Some b, Some c ->
Some Digestif.SHA256.(to_raw_string (digestv_string [a;b;c]))
| _ -> None
let save_console_and_script staging_dir job_name uuid console script =
@ -377,7 +378,7 @@ let add_build
if not_interesting filepath then
Lwt_result.return acc
else
let sha256 = Mirage_crypto.Hash.SHA256.digest (Cstruct.of_string data)
let sha256 = Digestif.SHA256.(to_raw_string (digest_string data))
and size = String.length data in
Lwt_result.ok (Lwt.pause ()) >|= fun () ->
({ filepath; sha256; size }, data) :: acc)
@ -483,7 +484,7 @@ let add_build
and uuid = Uuidm.to_string uuid
and job = job.name
and platform = job.platform
and `Hex sha256 = Hex.of_cstruct main_binary.sha256
and sha256 = Ohex.encode main_binary.sha256
in
let fp_str p = Fpath.(to_string (datadir // p)) in
let args =

2
lib/model.mli
View file

@ -33,7 +33,7 @@ val build : Uuidm.t -> Caqti_lwt.connection ->
val build_with_main_binary : [`job] Builder_db.id -> string -> Caqti_lwt.connection ->
((Builder_db.Build.t * Builder_db.file) option, [> Caqti_error.call_or_retrieve ]) result Lwt.t
val build_hash : Cstruct.t -> Caqti_lwt.connection ->
val build_hash : string -> Caqti_lwt.connection ->
((string * Builder_db.Build.t) option, [> Caqti_error.call_or_retrieve ]) result Lwt.t
val build_exists : Uuidm.t -> Caqti_lwt.connection ->

4
lib/views.ml
View file

@ -202,7 +202,7 @@ let artifact
else txtf "%a" Fpath.pp filepath
];
H.txt " ";
H.code [txtf "SHA256:%a" Hex.pp (Hex.of_cstruct sha256)];
H.code [txtf "SHA256:%a" Ohex.pp sha256];
txtf " (%a)" Fmt.byte_size size;
]
@ -491,7 +491,7 @@ module Job_build = struct
pp_devices block_devices pp_devices net_devices]
in
let aux (file:Builder_db.file) =
let (`Hex sha256_hex) = Hex.of_cstruct file.sha256 in
let sha256_hex = Ohex.encode file.sha256 in
[
H.dt [
H.a ~a:H.[a_href @@ Link.Job_build_artifact.make

2
test/dune
View file

@ -1,7 +1,7 @@
(test
(name test_builder_db)
(modules test_builder_db)
(libraries ptime.clock.os builder_db caqti.blocking alcotest mirage-crypto-rng.unix))
(libraries ptime.clock.os builder_db caqti.blocking alcotest mirage-crypto-rng.unix ohex))
(test
(name markdown_to_html)

7
test/router.ml
View file

@ -165,10 +165,9 @@ let () =
.. to find them I follewed the trails of 'Albatross_cli.http_host'
*)
begin
let `Hex sha_str =
Cstruct.of_string "foo"
|> Mirage_crypto.Hash.SHA256.digest
|> Hex.of_cstruct
let sha_str =
Digestif.SHA256.(to_raw_string (digest_string "foo"))
|> Ohex.encode
in
Fmt.str "/hash?sha256=%s" sha_str
end;

14
test/test_builder_db.ml
View file

@ -25,8 +25,8 @@ module Testable = struct
x.restricted = y.restricted &&
match x.password_hash, y.password_hash with
| `Scrypt (hash, salt, params), `Scrypt (hash', salt', params') ->
Cstruct.equal hash hash' &&
Cstruct.equal salt salt' &&
String.equal hash hash' &&
String.equal salt salt' &&
params = params'
in
let pp ppf { Builder_web_auth.username; password_hash; restricted } =
@ -34,7 +34,7 @@ module Testable = struct
| `Scrypt (hash, salt, { Builder_web_auth.scrypt_n; scrypt_r; scrypt_p }) ->
Format.fprintf ppf "user:%s;(%d,%d,%d);%B;%a;%a" username
scrypt_n scrypt_r scrypt_p restricted
Cstruct.hexdump_pp hash Cstruct.hexdump_pp salt
Ohex.pp hash Ohex.pp salt
in
Alcotest.testable
pp
@ -43,7 +43,7 @@ module Testable = struct
let file =
let equal (x : Builder_db.Rep.file) (y : Builder_db.Rep.file) =
Fpath.equal x.filepath y.filepath &&
Cstruct.equal x.sha256 y.sha256 &&
String.equal x.sha256 y.sha256 &&
x.size = y.size
in
let pp ppf { Builder_db.Rep.filepath; sha256; size } =
@ -51,7 +51,7 @@ module Testable = struct
sha256 = %a;@;<1 0>\
size = %d;@;<1 0>\
@]@,}"
Fpath.pp filepath Cstruct.hexdump_pp sha256 size
Fpath.pp filepath Ohex.pp sha256 size
in
Alcotest.testable pp equal
@ -131,12 +131,12 @@ let result = Builder.Exited 0
let main_binary =
let filepath = Result.get_ok (Fpath.of_string "bin/hello.sh") in
let data = "#!/bin/sh\necho Hello, World\n" in
let sha256 = Mirage_crypto.Hash.SHA256.digest (Cstruct.of_string data) in
let sha256 = Digestif.SHA256.(to_raw_string (digest_string data)) in
let size = String.length data in
{ Builder_db.Rep.filepath; sha256; size }
let main_binary2 =
let data = "#!/bin/sh\necho Hello, World 2\n" in
let sha256 = Mirage_crypto.Hash.SHA256.digest (Cstruct.of_string data) in
let sha256 = Digestif.SHA256.(to_raw_string (digest_string data)) in
let size = String.length data in
{ main_binary with sha256 ; size }
let platform = "exotic-os"