├── .github └── workflows │ └── main.yml ├── .gitignore ├── CHANGES.md ├── LICENSE.md ├── README.md ├── app ├── conex_key.ml ├── conex_mc.ml ├── conex_opts.ml ├── conex_root.ml ├── conex_snapshot.ml ├── conex_targets.ml ├── conex_timestamp.ml ├── conex_verify_app.ml ├── conex_verify_mirage_crypto.ml ├── conex_verify_openssl.ml └── dune ├── conex-mirage-crypto.opam ├── conex.opam ├── dune-project ├── mirage-crypto ├── conex_mirage_crypto.ml ├── conex_mirage_crypto.mli └── dune ├── openssl ├── conex_openssl.ml ├── conex_openssl.mli └── dune ├── src ├── conex.ml ├── conex.mli ├── conex_diff.ml ├── conex_diff.mli ├── conex_diff_provider.ml ├── conex_diff_provider.mli ├── conex_io.ml ├── conex_io.mli ├── conex_opam_encoding.ml ├── conex_opam_encoding.mli ├── conex_private.ml ├── conex_private.mli ├── conex_repository.ml ├── conex_repository.mli ├── conex_resource.ml ├── conex_resource.mli ├── conex_utils.ml ├── conex_utils.mli ├── conex_verify.ml ├── conex_verify.mli └── dune ├── test ├── common.ml ├── dune ├── test_conex.ml ├── test_path.ml ├── test_provider.ml ├── test_string.ml ├── test_tree.ml ├── test_uint.ml └── tests.ml └── unix ├── conex_unix_persistency.ml ├── conex_unix_persistency.mli ├── conex_unix_private_key.ml ├── conex_unix_private_key.mli ├── conex_unix_provider.ml ├── conex_unix_provider.mli └── dune /.github/workflows/main.yml: -------------------------------------------------------------------------------- 1 | name: Main workflow 2 | 3 | on: 4 | pull_request: 5 | push: 6 | schedule: 7 | # Prime the caches every Monday 8 | - cron: 0 1 * * MON 9 | 10 | jobs: 11 | build: 12 | strategy: 13 | fail-fast: false 14 | matrix: 15 | os: 16 | - macos-latest 17 | - ubuntu-latest 18 | - windows-latest 19 | ocaml-compiler: 20 | - 4.14.x 21 | 22 | runs-on: ${{ matrix.os }} 23 | 24 | steps: 25 | - name: Checkout code 26 | uses: actions/checkout@v2 27 | 28 | - name: Use OCaml ${{ matrix.ocaml-compiler }} 29 | uses: ocaml/setup-ocaml@v2 30 | with: 31 | ocaml-compiler: ${{ matrix.ocaml-compiler }} 32 | 33 | - run: opam install . --deps-only --with-test 34 | 35 | - run: opam exec -- dune build 36 | 37 | - run: opam exec -- dune runtest 38 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | _build/ 2 | coverage/ 3 | bisect*.out 4 | .merlin 5 | *.install 6 | *.native 7 | -------------------------------------------------------------------------------- /CHANGES.md: -------------------------------------------------------------------------------- 1 | ## v0.11.1 (2020-03-15) 2 | 3 | * Use mirage-crypto instead of nocrypto 4 | 5 | ## v0.11.0 (2019-12-21) 6 | 7 | * Adapt to X509 0.7.0 API 8 | * Avoid deprecation warnings by using stdlib-shims 9 | * Adjust opam repository file locations #13, now the whitelist is: 10 | packages/NV/opam and packages/NV/files/* 11 | where NV is either name.version or name/name.version 12 | * Various fixes for diff in the real world #13 13 | 14 | ## 0.10.1 (2018-09-08) 15 | 16 | * re-add LICENSE.md file (with a 2 clause BSD license) 17 | 18 | ## 0.10.0 (2018-09-03) 19 | 20 | * adjusted to new conex design, lots of breaking changes 21 | * opam_encoding: maps use identifiers now, instead of strings - as does alg_type 22 | * conex_resource: use alg=data for encoding digests (instead of [ alg ; data ]) 23 | * conex_resource: use hex encoding, rather than base64 for checksums 24 | * rename "package" to "releases" ; rename "release" to "checksums" (filenames) 25 | * conex_unix_private_key: store private keys in ~/.conex/.private, instead 26 | of having the repository included in the filename. this removes lots of magic 27 | from conex_author 28 | * conex_private: new module gathering private key handling and operations, 29 | replacing conex_unix_private_key and conex_crypto.SIGN 30 | 31 | ## 0.9.2 (2017-02-18) 32 | 33 | * conex_author: status subcommand: handle id argument properly 34 | 35 | ## 0.9.1 (2017-02-18) 36 | 37 | * conex_author: 38 | - key subcommand: argument 'all' queued invalid resources (using id = all) 39 | - init subcommand: sign at the end, to have a public key in the index 40 | - status subcommand: fix argument processing if both id and repo are present 41 | - verify subcommand: require repo, do not use id 42 | * crypto: trim result from `pub_of_priv` (nocrypto appends a newline, and breaks checksum) 43 | * conex: verify_janitors could never succeed (unless quorum = 0), because the 44 | team janitors (repo.teams) was empty while validating the team resource 45 | 46 | ## 0.9.0 (2017-02-16) 47 | 48 | * initial release -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015-2018 Hannes Mehnert 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions are met: 6 | 7 | 1. Redistributions of source code must retain the above copyright notice, this 8 | list of conditions and the following disclaimer. 9 | 2. Redistributions in binary form must reproduce the above copyright notice, 10 | this list of conditions and the following disclaimer in the documentation 11 | and/or other materials provided with the distribution. 12 | 13 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND 14 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 15 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 16 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR 17 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES 18 | (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 19 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND 20 | ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 21 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 22 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 23 | 24 | The views and conclusions contained in the software and documentation are those 25 | of the authors and should not be interpreted as representing official policies, 26 | either expressed or implied, of the conex project. 27 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ## Conex - establish trust in community repositories 2 | 3 | %%VERSION%% 4 | 5 | Conex is a utility for verify and attest release integrity and authenticity of community repositories through the use of cryptographic signatures (RSA-PSS-SHA256). It is based on [the update framework](https://theupdateframework.github.io/), especially on their [CCS 2010 paper](https://isis.poly.edu/~jcappos/papers/samuel_tuf_ccs_2010.pdf), and adapted to the requirements of the [opam](https://ocaml.opam.org) [repository](https://github.com/ocaml/opam-repository). 6 | 7 | The developer sign their release checksums and build instructions. A quorum (with a configurable threshold) of repository maintainers signs the package name to developer key relation. These repository maintainers are enrolled by a quorum of offline root keys. 8 | 9 | The [TUF spec](https://github.com/theupdateframework/specification/blob/master/tuf-spec.md) has a good overview of attacks and threat model, both of which are shared by conex. 10 | 11 | ## Project history 12 | 13 | Spring 2017, together with Justin Cappos [TAP 8](https://github.com/theupdateframework/taps/blob/master/tap8.md) was designed which extends TUF with key rotation and explicit self-revocation. 14 | 15 | Early 2017, a [blog post](https://hannes.robur.coop/Posts/Conex) introducing a prototype was published. 16 | 17 | We presented [an earlier design at OCaml 2016](https://github.com/hannesm/conex-paper/raw/master/paper.pdf) about an earlier design. 18 | 19 | Another article on an [even earlier design (from 2015)](http://opam.ocaml.org/blog/Signing-the-opam-repository/) is also available. 20 | 21 | ## Installation 22 | 23 | Conex release tarballs are accompanied with OpenPGP signatures in a separate .sig file in the download area. 24 | 25 | `opam instal conex` will install this library and tool, 26 | once you have installed OCaml (>= 4.13.0) and opam (>= 2.0.0beta). 27 | 28 | A small test repository with two maintainers is available [here](https://github.com/hannesm/testrepo) including transcripts of how it was setup, and how to setup opams `repo validation hook`. 29 | -------------------------------------------------------------------------------- /app/conex_key.ml: -------------------------------------------------------------------------------- 1 | open Conex_resource 2 | 3 | open Conex_opts 4 | open Conex_mc 5 | 6 | let ( let* ) = Result.bind 7 | 8 | let jump _ id force pub = 9 | Mirage_crypto_rng_unix.use_default () ; 10 | msg_to_cmdliner ( 11 | let* id = Option.to_result ~none:"need an id" id in 12 | let fp k = 13 | let public = PRIV.pub_of_priv k in 14 | Logs.app (fun m -> m "key %s created %s keyid %s" 15 | (PRIV.id k) (PRIV.created k) 16 | (Digest.to_string (Key.keyid V.raw_digest public))) ; 17 | if pub then 18 | Logs.app (fun m -> m "public key: %a@.%s" 19 | Conex_resource.Key.pp public 20 | (Conex_opam_encoding.encode (Key.wire public))) ; 21 | Ok () 22 | in 23 | let gen_or_err () = 24 | let* t = PRIV.generate to_ts `RSA id () in 25 | Logs.app (fun m -> m "generated fresh key") ; 26 | fp t 27 | in 28 | if force 29 | then gen_or_err () 30 | else match PRIV.read to_ts id with 31 | | Ok key -> fp key 32 | | Error `None -> gen_or_err () 33 | | Error e -> Error (Fmt.to_to_string PRIV.pp_r_err e)) 34 | 35 | let setup_log style_renderer level = 36 | Fmt_tty.setup_std_outputs ?style_renderer (); 37 | Logs.set_level level; 38 | Logs.set_reporter (Logs_fmt.reporter ~dst:Format.std_formatter ()) 39 | 40 | open Cmdliner 41 | 42 | let docs = Keys.docs 43 | 44 | let setup_log = 45 | Term.(const setup_log 46 | $ Fmt_cli.style_renderer ~docs () 47 | $ Logs_cli.level ~docs ()) 48 | 49 | let pub = 50 | let doc = "Display full public key." in 51 | Arg.(value & flag & info ["pub"] ~docs ~doc) 52 | 53 | let cmd = 54 | let doc = "key management" in 55 | let term = Term.(ret (const jump $ setup_log $ Keys.id $ Keys.force $ pub)) 56 | and info = Cmd.info "conex_key" ~version:"%%VERSION_NUM%%" ~doc 57 | in 58 | Cmd.v info term 59 | 60 | let () = exit (Cmd.eval cmd) 61 | -------------------------------------------------------------------------------- /app/conex_mc.ml: -------------------------------------------------------------------------------- 1 | module V = Conex_mirage_crypto.NC_V 2 | module C = Conex.Make(Logs)(V) 3 | module PRIV = Conex_private.Make(Conex_mirage_crypto.C)(Conex_unix_private_key) 4 | 5 | let to_str pp = Result.map_error (Fmt.to_to_string pp) 6 | 7 | let now = Ptime.to_rfc3339 ~tz_offset_s:0 (Ptime_clock.now ()) 8 | 9 | let to_ts f = 10 | Option.map (Ptime.to_rfc3339 ~tz_offset_s:0) (Ptime.of_float_s f) 11 | 12 | let init_priv_id id = 13 | let ( let* ) = Result.bind in 14 | let id' = match id with None -> "" | Some id -> id in 15 | let* priv = to_str PRIV.pp_r_err (PRIV.read to_ts id') in 16 | let id'' = PRIV.id priv in 17 | Ok (priv, id'') 18 | -------------------------------------------------------------------------------- /app/conex_opts.ml: -------------------------------------------------------------------------------- 1 | 2 | module Keys = struct 3 | open Cmdliner 4 | 5 | let docs = "COMMON OPTIONS" 6 | 7 | let id_c = 8 | let parse s = 9 | if Conex_utils.String.is_ascii ~p:(function '_' | '.' | '=' | '-' -> true | _ -> false) s then 10 | `Ok s 11 | else 12 | `Error "invalid identifier (valid: A-Za-z0-9)" 13 | in 14 | (parse, fun ppf s -> Format.pp_print_string ppf s) 15 | 16 | let id = 17 | let doc = "Use a specific identity (not needed unless you have more than one identity)." in 18 | Arg.(value & opt (some id_c) None & info ["id"] ~docs ~doc) 19 | 20 | let id_req = 21 | let doc = "Identity." in 22 | Arg.(value & opt (some id_c) None & info ["id"] ~docs ~doc) 23 | 24 | let key_alg = 25 | let doc = "Public key algorithm." in 26 | Arg.(value & opt (enum [ ("rsa", `RSA) ]) `RSA & info ["key-algorithm"] ~docs ~doc) 27 | 28 | let role = 29 | let doc = "Role." in 30 | Arg.(value & opt (some (enum [ ("snapshot", `Snapshot) ; 31 | ("timestamp", `Timestamp) ; 32 | ("maintainer", `Maintainer) ])) 33 | None & info ["role"] ~docs ~doc) 34 | 35 | let key_data = 36 | let doc = "Public key data." in 37 | Arg.(value & opt (some file) None & info ["key-data"] ~docs ~doc) 38 | 39 | let hash_alg = 40 | let doc = "Hash algorithm." in 41 | Arg.(value & opt (enum [ ("sha256", `SHA256) ]) `SHA256 & info ["hash-algorithm"] ~docs ~doc) 42 | 43 | let key_hash = 44 | let doc = "Public key hash." in 45 | Arg.(value & opt (some string) None & info ["key-hash"] ~docs ~doc) 46 | 47 | let uint_c = 48 | let parse s = 49 | match Conex_utils.Uint.of_string s with 50 | | None -> `Error "Invalid uint" 51 | | Some u -> `Ok u 52 | in 53 | (parse, Conex_utils.Uint.pp) 54 | 55 | let epoch = 56 | let doc = "Epoch." in 57 | Arg.(value & opt uint_c Conex_utils.Uint.zero & info ["epoch"] ~docs ~doc) 58 | 59 | let ignore_missing = 60 | let doc = "Non-strict verification mode. Packages where no release is signed are ignored." in 61 | Arg.(value & flag & info [ "ignore-missing" ; "nostrict" ] ~doc) 62 | 63 | let quorum = 64 | let doc = "The quorum of maintainers used for verification of the repository" in 65 | Arg.(value & opt (some int) None & info [ "quorum" ] ~doc) 66 | 67 | let repo = 68 | let doc = "Repository base directory (defaults to cwd)" in 69 | Arg.(value & opt (some dir) None & info [ "r" ; "repository" ] ~docs ~doc) 70 | 71 | let anchors = 72 | let doc = "Trust anchors (Hex encoded hashes, seperated by ','). Can be repeated." in 73 | Arg.(value & opt_all string [] & info [ "t" ; "trust-anchors" ] ~doc) 74 | 75 | let dry = 76 | let doc = "Dry run. Do not write anything to persistent storage." in 77 | Arg.(value & flag & info ["dry-run"] ~docs ~doc) 78 | 79 | let force = 80 | let doc = "Force." in 81 | Arg.(value & flag & info ["force"] ~docs ~doc) 82 | 83 | let no_incr = 84 | let doc = "Do not increment counter." in 85 | Arg.(value & flag & info ["no-incr"] ~docs ~doc) 86 | 87 | let root = 88 | let doc = "Root filename, defaults to root" in 89 | Arg.(value & opt string "root" & info ["root"] ~docs ~doc) 90 | 91 | let package = 92 | let doc = "Package name" in 93 | Arg.(value & opt (some id_c) None & info [ "pkg" ] ~doc) 94 | 95 | let incremental = 96 | let doc = "Incremental verification mode" in 97 | Arg.(value & flag & info [ "incremental" ] ~doc) 98 | 99 | let dir = 100 | let doc = "Directory which is verified." in 101 | Arg.(value & opt (some dir) None & info [ "dir" ] ~doc) 102 | 103 | let patch = 104 | let doc = "Patch file which is verified." in 105 | Arg.(value & opt (some file) None & info [ "patch" ] ~doc) 106 | 107 | let no_opam = 108 | let doc = "Do not verify opam repository layout" in 109 | Arg.(value & flag & info [ "no-opam" ] ~doc) 110 | 111 | let timestamp_expiry = 112 | let doc = "Expiration of timestamp signature (in seconds)." in 113 | Arg.(value & opt int64 900L & info [ "expiry" ] ~doc) 114 | end 115 | 116 | let repo ~rw repodir = 117 | let dir = Option.value ~default:(Unix.getcwd ()) repodir in 118 | if rw 119 | then Conex_unix_provider.fs_provider dir 120 | else Conex_unix_provider.fs_ro_provider dir 121 | 122 | let valid a = 123 | let ta = List.fold_left 124 | (fun acc str -> 125 | Result.fold 126 | ~error:(fun _ -> 127 | Printf.printf "ignoring malformed trust anchor %s" str ; 128 | acc) 129 | ~ok:(fun dgst -> dgst :: acc) 130 | (Conex_resource.Digest.of_string str)) 131 | [] (List.flatten (List.map (Conex_utils.String.cuts ',') a)) 132 | in 133 | let valid digest _ = List.exists (Conex_resource.Digest.equal digest) ta in 134 | valid 135 | 136 | let msg_to_cmdliner = function 137 | | Ok () -> `Ok () 138 | | Error m -> `Error (false, m) 139 | -------------------------------------------------------------------------------- /app/conex_root.ml: -------------------------------------------------------------------------------- 1 | open Conex_utils 2 | open Conex_resource 3 | 4 | open Conex_opts 5 | open Conex_mc 6 | 7 | module IO = Conex_io 8 | 9 | let ( let* ) = Result.bind 10 | 11 | let check_root root = 12 | let keys_present = 13 | M.fold (fun id _ s -> S.add id s) root.Root.keys S.empty 14 | and keys_used = Expression.local_keys root.valid 15 | and q = match root.valid with Quorum (n, _) -> n | _ -> 0 16 | in 17 | if min (S.cardinal keys_used) (S.cardinal keys_present) < q then 18 | Logs.warn (fun m -> m "root file with quorum greater than keys"); 19 | if S.equal keys_present keys_used then 20 | () 21 | else 22 | let present_not_used = S.diff keys_present keys_used 23 | and used_not_present = S.diff keys_used keys_present 24 | in 25 | if not (S.is_empty present_not_used) then 26 | Logs.warn (fun m -> m "keys %a are present but not used" 27 | Fmt.(list ~sep:(any ", ") string) 28 | (S.elements present_not_used)); 29 | if not (S.is_empty used_not_present) then 30 | Logs.warn (fun m -> m "keys %a are used but not present" 31 | Fmt.(list ~sep:(any ", ") string) 32 | (S.elements used_not_present)) 33 | 34 | let status _ repodir anchors filename = 35 | msg_to_cmdliner ( 36 | let valid = valid anchors in 37 | let* io = repo ~rw:false repodir in 38 | Result.fold 39 | ~error:(fun r -> 40 | Logs.err (fun m -> m "%a" IO.pp_r_err r) ; 41 | Error "failed loading") 42 | ~ok:(fun (root, warn) -> 43 | List.iter (fun msg -> Logs.warn (fun m -> m "%s" msg)) warn ; 44 | Logs.app (fun m -> m "root file %a" Root.pp root) ; 45 | check_root root ; 46 | Result.fold 47 | ~error:(fun e -> 48 | Logs.err (fun m -> m "couldn't verify root: %s" e) ; 49 | Error "failed verification") 50 | ~ok:(fun _ -> 51 | Logs.app (fun m -> m "verified successfully") ; 52 | Ok ()) 53 | (C.verify_root ~valid io filename)) 54 | (IO.read_root io filename)) 55 | 56 | let create _ dry repodir force filename = 57 | msg_to_cmdliner ( 58 | let* io = repo ~rw:(not dry) repodir in 59 | let valid = Expression.Quorum (0, Expression.KS.empty) in 60 | let root = Root.t ~name:filename now valid in 61 | let root' = 62 | Result.fold 63 | ~error:(fun _ -> root) 64 | ~ok:(fun (root', _) -> if force then root else root') 65 | (IO.read_root io filename) 66 | in 67 | Logs.app (fun m -> m "root file %a" Root.pp root') ; 68 | IO.write_root io root') 69 | 70 | let add_key _ dry repodir quorum id alg data filename = 71 | msg_to_cmdliner ( 72 | let* id = Option.to_result ~none:"Missing identity" id in 73 | let* data = Option.to_result ~none:"Missing key data" data in 74 | let* data = Conex_unix_persistency.read_file data in 75 | let* io = repo ~rw:(not dry) repodir in 76 | let* root, warn = to_str IO.pp_r_err (IO.read_root io filename) in 77 | List.iter (fun msg -> Logs.warn (fun m -> m "%s" msg)) warn ; 78 | let root' = 79 | let key = (id, now, alg, data) in 80 | let valid = match root.valid with 81 | | Expression.Quorum (q, ks) -> 82 | let q = Option.value ~default:q quorum in 83 | let keys = Expression.(KS.add (Local id) ks) in 84 | Expression.Quorum (q, keys) 85 | | a -> a 86 | in 87 | { root with keys = M.add id key root.keys ; valid } 88 | in 89 | Logs.app (fun m -> m "root file %a" Root.pp root') ; 90 | check_root root' ; 91 | IO.write_root io root') 92 | 93 | let remove_key _ dry repodir quorum id filename = 94 | msg_to_cmdliner ( 95 | let* id = Option.to_result ~none:"Missing identity" id in 96 | let* io = repo ~rw:(not dry) repodir in 97 | let* root, warn = to_str IO.pp_r_err (IO.read_root io filename) in 98 | List.iter (fun msg -> Logs.warn (fun m -> m "%s" msg)) warn ; 99 | let root' = 100 | let keys = M.remove id root.keys in 101 | let valid = match root.valid with 102 | | Expression.Quorum (q, ks) -> 103 | let q = Option.value ~default:q quorum in 104 | let keys = Expression.(KS.remove (Local id) ks) in 105 | Expression.Quorum (q, keys) 106 | | a -> a 107 | in 108 | { root with keys ; valid } 109 | in 110 | Logs.app (fun m -> m "root file %a" Root.pp root') ; 111 | check_root root' ; 112 | IO.write_root io root') 113 | 114 | let set_role _ dry repodir role id alg h epoch filename = 115 | msg_to_cmdliner ( 116 | let* id = Option.to_result ~none:"Missing identity" id in 117 | let* role = Option.to_result ~none:"Missing role" role in 118 | let* h = Option.to_result ~none:"Missing hash" h in 119 | let* io = repo ~rw:(not dry) repodir in 120 | let* root, warn = to_str IO.pp_r_err (IO.read_root io filename) in 121 | List.iter (fun msg -> Logs.warn (fun m -> m "%s" msg)) warn ; 122 | let root' = 123 | (match Root.(RM.find_opt role root.roles) with 124 | | None -> () 125 | | Some _ -> Logs.warn (fun m -> m "replacing role %s" 126 | (Root.role_to_string role))); 127 | let e = Expression.(Quorum (1, KS.singleton (Remote (id, (alg, h), epoch)))) in 128 | let roles = Root.RM.add role e root.roles in 129 | { root with roles } 130 | in 131 | Logs.app (fun m -> m "root file %a" Root.pp root') ; 132 | IO.write_root io root') 133 | 134 | let add_to_role _ dry repodir role id alg h epoch quorum filename = 135 | msg_to_cmdliner ( 136 | let* id = Option.to_result ~none:"Missing identity" id in 137 | let* role = Option.to_result ~none:"Missing role" role in 138 | let* h = Option.to_result ~none:"Missing hash" h in 139 | let* io = repo ~rw:(not dry) repodir in 140 | let* root, warn = to_str IO.pp_r_err (IO.read_root io filename) in 141 | List.iter (fun msg -> Logs.warn (fun m -> m "%s" msg)) warn ; 142 | let* roles = 143 | match Root.(RM.find_opt role root.roles) with 144 | | None -> 145 | let q = Option.value ~default:1 quorum in 146 | let e = Expression.(Quorum (q, KS.singleton (Remote (id, (alg, h), epoch)))) in 147 | Ok (Root.RM.add role e root.roles) 148 | | Some (Quorum (n, k)) -> 149 | let q = Option.value ~default:n quorum in 150 | let e = Expression.(Quorum (q, KS.add (Remote (id, (alg, h), epoch)) k)) in 151 | Ok (Root.RM.add role e root.roles) 152 | | Some _ -> 153 | Logs.warn (fun m -> m "The role %s expression is not a quorum, ignoring" 154 | (Root.role_to_string role)); 155 | Error "Bad expression for role" 156 | in 157 | let root' = { root with roles } in 158 | Logs.app (fun m -> m "root file %a" Root.pp root') ; 159 | IO.write_root io root') 160 | 161 | let remove_from_role _ dry repodir role id quorum filename = 162 | msg_to_cmdliner ( 163 | let* id = Option.to_result ~none:"Missing identity" id in 164 | let* role = Option.to_result ~none:"Missing role" role in 165 | let* io = repo ~rw:(not dry) repodir in 166 | let* root, warn = to_str IO.pp_r_err (IO.read_root io filename) in 167 | List.iter (fun msg -> Logs.warn (fun m -> m "%s" msg)) warn ; 168 | let* roles = 169 | match Root.(RM.find_opt role root.roles) with 170 | | None -> 171 | Logs.warn (fun m -> m "No role %s found" (Root.role_to_string role)); 172 | Error "Role not found" 173 | | Some (Quorum (n, k)) -> 174 | let q = Option.value ~default:n quorum in 175 | let e = 176 | Expression.KS.fold (fun e acc -> 177 | match e with 178 | | Expression.Local _ as l -> Expression.KS.add l acc 179 | | Remote (id', _, _) as r -> 180 | if id_equal id id' then 181 | acc 182 | else 183 | Expression.KS.add r acc) 184 | k Expression.KS.empty 185 | in 186 | Ok (Root.RM.add role Expression.(Quorum (q, e)) root.roles) 187 | | Some _ -> 188 | Logs.warn (fun m -> m "The role %s expression is not a quorum, ignoring" 189 | (Root.role_to_string role)); 190 | Error "Bad expression for role" 191 | in 192 | let root' = { root with roles } in 193 | Logs.app (fun m -> m "root file %a" Root.pp root') ; 194 | IO.write_root io root') 195 | 196 | let sign _ dry repodir id no_incr filename = 197 | Mirage_crypto_rng_unix.use_default () ; 198 | msg_to_cmdliner ( 199 | let* priv, id' = init_priv_id id in 200 | let* io = repo ~rw:(not dry) repodir in 201 | let* root, warn = to_str IO.pp_r_err (IO.read_root io filename) in 202 | List.iter (fun msg -> Logs.warn (fun m -> m "%s" msg)) warn ; 203 | let* root' = 204 | match no_incr, Uint.succ root.Root.counter with 205 | | false, (true, _) -> Error "couldn't increment counter" 206 | | true, _ -> Ok root 207 | | false, (false, counter) -> Ok { root with Root.counter } 208 | in 209 | let* signature = 210 | PRIV.sign (Root.wire_raw root') now id' `RSA_PSS_SHA256 priv 211 | in 212 | let root'' = Root.add_signature root' id' signature in 213 | IO.write_root io root'') 214 | 215 | let help _ _ _ _ man_format cmds = function 216 | | None -> `Help (`Pager, None) 217 | | Some t when List.mem t cmds -> `Help (man_format, Some t) 218 | | Some _ -> List.iter print_endline cmds; `Ok () 219 | 220 | let setup_log style_renderer level = 221 | Fmt_tty.setup_std_outputs ?style_renderer (); 222 | Logs.set_level level; 223 | Logs.set_reporter (Logs_fmt.reporter ~dst:Format.std_formatter ()) 224 | 225 | open Cmdliner 226 | 227 | let docs = Keys.docs 228 | 229 | let help_secs = [ 230 | `S "GENERAL"; 231 | `P "$(mname) is a tool for managing cryptographically signed community repositories."; 232 | `P "The signing metadata is kept in the same repository."; 233 | `S docs; 234 | `P "These options are common to all commands."; 235 | `S "SEE ALSO"; 236 | `P "Use `$(mname) $(i,COMMAND) --help' for help on a single command."; 237 | `S "BUGS"; `P "Please report bugs at https://github.com/hannesm/conex.";] 238 | 239 | let setup_log = 240 | Term.(const setup_log 241 | $ Fmt_cli.style_renderer ~docs () 242 | $ Logs_cli.level ~docs ()) 243 | 244 | let sign_cmd = 245 | let doc = "sign root file with provided key" in 246 | let man = 247 | [`S "DESCRIPTION"; 248 | `P "Cryptographically signs the root file."] 249 | in 250 | let term = 251 | Term.(ret Conex_opts.(const sign $ setup_log $ Keys.dry $ Keys.repo $ Keys.id $ Keys.no_incr $ Keys.root)) 252 | and info = Cmd.info "sign" ~doc ~man 253 | in 254 | Cmd.v info term 255 | 256 | let status_cmd = 257 | let doc = "information about provided root file" in 258 | let man = 259 | [`S "DESCRIPTION"; 260 | `P "Shows information about the root file. The provided anchors are used \ 261 | to validate the root file. The signatures are cryptographically \ 262 | verified."] 263 | in 264 | let term = 265 | Term.(ret Conex_opts.(const status $ setup_log $ Keys.repo $ Keys.anchors $ Keys.root)) 266 | and info = Cmd.info "status" ~doc ~man 267 | in 268 | Cmd.v info term 269 | 270 | let create_cmd = 271 | let doc = "create an empty root file" in 272 | let man = 273 | [`S "DESCRIPTION"; 274 | `P "Creates a fresh root file."] 275 | in 276 | let term = 277 | Term.(ret Conex_opts.(const create $ setup_log $ Keys.dry $ Keys.repo $ Keys.force $ Keys.root)) 278 | and info = Cmd.info "create" ~doc ~man 279 | in 280 | Cmd.v info term 281 | 282 | let add_key_cmd = 283 | let doc = "add a key to the root file" in 284 | let man = 285 | [`S "DESCRIPTION"; 286 | `P "Adds a public key to the root file."] 287 | in 288 | let term = 289 | Term.(ret Conex_opts.(const add_key $ setup_log $ Keys.dry $ Keys.repo $ Keys.quorum $ Keys.id_req $ Keys.key_alg $ Keys.key_data $ Keys.root)) 290 | and info = Cmd.info "add-key" ~doc ~man 291 | in 292 | Cmd.v info term 293 | 294 | let remove_key_cmd = 295 | let doc = "remove a key from the root file" in 296 | let man = 297 | [`S "DESCRIPTION"; 298 | `P "Removes a public key from the root file."] 299 | in 300 | let term = 301 | Term.(ret Conex_opts.(const remove_key $ setup_log $ Keys.dry $ Keys.repo $ Keys.quorum $ Keys.id_req $ Keys.root)) 302 | and info = Cmd.info "remove-key" ~doc ~man 303 | in 304 | Cmd.v info term 305 | 306 | let set_role_cmd = 307 | let doc = "set the role in the root file" in 308 | let man = 309 | [`S "DESCRIPTION"; 310 | `P "Sets the role in the root file."] 311 | in 312 | let term = 313 | Term.(ret Conex_opts.(const set_role $ setup_log $ Keys.dry $ Keys.repo $ Keys.role $ Keys.id_req $ Keys.hash_alg $ Keys.key_hash $ Keys.epoch $ Keys.root)) 314 | and info = Cmd.info "set-role" ~doc ~man 315 | in 316 | Cmd.v info term 317 | 318 | let add_to_role_cmd = 319 | let doc = "add key hash to role in the root file" in 320 | let man = 321 | [`S "DESCRIPTION"; 322 | `P "Adds key hash to role in the root file."] 323 | in 324 | let term = 325 | Term.(ret Conex_opts.(const add_to_role $ setup_log $ Keys.dry $ Keys.repo $ Keys.role $ Keys.id_req $ Keys.hash_alg $ Keys.key_hash $ Keys.epoch $ Keys.quorum $ Keys.root)) 326 | and info = Cmd.info "add-to-role" ~doc ~man 327 | in 328 | Cmd.v info term 329 | 330 | let remove_from_role_cmd = 331 | let doc = "removes key from role in the root file" in 332 | let man = 333 | [`S "DESCRIPTION"; 334 | `P "Removes key from role in the root file."] 335 | in 336 | let term = 337 | Term.(ret Conex_opts.(const remove_from_role $ setup_log $ Keys.dry $ Keys.repo $ Keys.role $ Keys.id_req $ Keys.quorum $ Keys.root)) 338 | and info = Cmd.info "remove-from-role" ~doc ~man 339 | in 340 | Cmd.v info term 341 | 342 | let help_cmd = 343 | let topic = 344 | let doc = "The topic to get help on. `topics' lists the topics." in 345 | Arg.(value & pos 0 (some string) None & info [] ~docv:"TOPIC" ~doc) 346 | in 347 | Term.(ret Conex_opts.(const help $ setup_log $ Keys.dry $ Keys.repo $ Keys.id $ Arg.man_format $ Term.choice_names $ topic)) 348 | 349 | let cmds = [ status_cmd ; sign_cmd ; create_cmd ; add_key_cmd ; remove_key_cmd ; 350 | set_role_cmd ; add_to_role_cmd ; remove_from_role_cmd ] 351 | 352 | let () = 353 | let doc = "Manage root file of a signed community repository" in 354 | let man = help_secs in 355 | let info = Cmd.info "conex_root" ~version:"%%VERSION_NUM%%" ~sdocs:docs ~doc ~man in 356 | let group = Cmd.group ~default:help_cmd info cmds in 357 | exit (Cmd.eval group) 358 | -------------------------------------------------------------------------------- /app/conex_snapshot.ml: -------------------------------------------------------------------------------- 1 | open Conex_utils 2 | open Conex_resource 3 | 4 | open Conex_mc 5 | 6 | module IO = Conex_io 7 | 8 | let ( let* ) = Result.bind 9 | 10 | let io_repo ~rw repodir root_file = 11 | let* io = Conex_opts.repo ~rw repodir in 12 | let* root, warn = to_str IO.pp_r_err (IO.read_root io root_file) in 13 | List.iter (fun msg -> Logs.warn (fun m -> m "%s" msg)) warn ; 14 | Logs.debug (fun m -> m "root file %a" Root.pp root) ; 15 | let repo = Conex_repository.create root in 16 | Ok (io, repo) 17 | 18 | let status _ repodir root_file id = 19 | Conex_opts.msg_to_cmdliner ( 20 | let* io, repo = io_repo ~rw:false repodir root_file in 21 | let* _ = C.verify_snapshot ?id io repo in 22 | Ok ()) 23 | 24 | let snap_id id repo = 25 | let* snap_id = Conex_repository.snapshot repo in 26 | match id, snap_id with 27 | | None, None -> Error "neither ID provided nor a snapshot role in root file present" 28 | | None, Some (snap_id, _, _) -> 29 | Logs.info (fun m -> m "using %a (as specified in root file)" pp_id snap_id); 30 | Ok snap_id 31 | | Some id, None -> 32 | Logs.info (fun m -> m "using %a (none specified in root file)" pp_id id); 33 | Ok id 34 | | Some id, Some (snap_id, _, _) -> 35 | if not (id_equal id snap_id) then 36 | Logs.warn (fun m -> m "using specified id %a, but in root file %a is specified" 37 | pp_id id pp_id snap_id); 38 | Ok id 39 | 40 | let create _ dry repodir root_file id = 41 | Conex_opts.msg_to_cmdliner ( 42 | let* io, repo = io_repo ~rw:(not dry) repodir root_file in 43 | let* id = snap_id id repo in 44 | let* targets = 45 | IO.compute_checksum ~prefix:(Conex_repository.keydir repo) 46 | io false V.raw_digest [] 47 | in 48 | let targets = 49 | let f = 50 | match Conex_repository.timestamp repo with 51 | | Ok (Some (tid, _, _)) -> (fun tgt_id -> not (id_equal tid tgt_id)) 52 | | _ -> (fun _ -> true) 53 | in 54 | List.filter (fun tgt -> 55 | let tgt_id = 56 | match List.rev tgt.Target.filename with 57 | | hd :: _ -> hd 58 | | _ -> assert false 59 | in 60 | not (id_equal tgt_id id) && f tgt_id) 61 | targets 62 | in 63 | let old_snap, warn = match IO.read_snapshot io id with 64 | | Ok snap -> snap 65 | | Error e -> 66 | Logs.warn (fun m -> m "error %a while reading snapshot" IO.pp_r_err e); 67 | Snapshot.t now id, [] 68 | in 69 | List.iter 70 | (fun w -> Logs.warn (fun m -> m "warning while reading snapshot: %s" w)) 71 | warn; 72 | let ts = 73 | Timestamp.t ~counter:old_snap.Snapshot.counter 74 | ~epoch:old_snap.Snapshot.epoch 75 | ~keys:old_snap.Snapshot.keys 76 | ~targets now id 77 | in 78 | Logs.app (fun m -> m "timestamp file %a" Timestamp.pp ts) ; 79 | IO.write_timestamp io ts) 80 | 81 | let sign _ dry repodir id no_incr root_file = 82 | Mirage_crypto_rng_unix.use_default () ; 83 | Conex_opts.msg_to_cmdliner ( 84 | let* io, repo = io_repo ~rw:(not dry) repodir root_file in 85 | let* snap_id = snap_id id repo in 86 | let* priv, id' = init_priv_id (Some snap_id) in 87 | let* snap, warn = to_str IO.pp_r_err (IO.read_snapshot io id') in 88 | List.iter 89 | (fun w -> Logs.warn (fun m -> m "warning while reading snapshot: %s" w)) 90 | warn; 91 | let* snap' = 92 | match no_incr, Uint.succ snap.Snapshot.counter with 93 | | false, (true, _) -> Error "couldn't increment counter" 94 | | true, _ -> Ok snap 95 | | false, (false, counter) -> Ok { snap with Snapshot.counter } 96 | in 97 | let* signature = 98 | PRIV.sign (Snapshot.wire_raw snap') now id' `RSA_PSS_SHA256 priv 99 | in 100 | let snap'' = Snapshot.add_signature snap' id' signature in 101 | IO.write_snapshot io snap'') 102 | 103 | let help _ _ _ _ man_format cmds = function 104 | | None -> `Help (`Pager, None) 105 | | Some t when List.mem t cmds -> `Help (man_format, Some t) 106 | | Some _ -> List.iter print_endline cmds; `Ok () 107 | 108 | let setup_log style_renderer level = 109 | Fmt_tty.setup_std_outputs ?style_renderer (); 110 | Logs.set_level level; 111 | Logs.set_reporter (Logs_fmt.reporter ~dst:Format.std_formatter ()) 112 | 113 | open Cmdliner 114 | 115 | let docs = Conex_opts.Keys.docs 116 | 117 | let help_secs = [ 118 | `S "GENERAL"; 119 | `P "$(mname) is a tool for managing cryptographically signed community repositories."; 120 | `P "The signing metadata is kept in the same repository."; 121 | `S docs; 122 | `P "These options are common to all commands."; 123 | `S "SEE ALSO"; 124 | `P "Use `$(mname) $(i,COMMAND) --help' for help on a single command."; 125 | `S "BUGS"; `P "Please report bugs at https://github.com/hannesm/conex.";] 126 | 127 | let setup_log = 128 | Term.(const setup_log 129 | $ Fmt_cli.style_renderer ~docs () 130 | $ Logs_cli.level ~docs ()) 131 | 132 | let sign_cmd = 133 | let doc = "sign snapshot file with provided key" in 134 | let man = 135 | [`S "DESCRIPTION"; 136 | `P "Cryptographically signs the snapshot file."] 137 | in 138 | let term = 139 | Term.(ret Conex_opts.(const sign $ setup_log $ Keys.dry $ Keys.repo $ Keys.id $ Keys.no_incr $ Keys.root)) 140 | and info = Cmd.info "sign" ~doc ~man 141 | in 142 | Cmd.v info term 143 | 144 | let status_cmd = 145 | let doc = "information about provided snapshot file" in 146 | let man = 147 | [`S "DESCRIPTION"; 148 | `P "Shows information about the snapshot file. The provided ID is used as \ 149 | snapshot identifier. The snapshot file is verified. If a snapshot role \ 150 | is present in the root file, it is validated."] 151 | in 152 | let term = 153 | Term.(ret Conex_opts.(const status $ setup_log $ Keys.repo $ Keys.root $ Keys.id)) 154 | and info = Cmd.info "status" ~doc ~man 155 | in 156 | Cmd.v info term 157 | 158 | let create_cmd = 159 | let doc = "create an empty snapshot file" in 160 | let man = 161 | [`S "DESCRIPTION"; 162 | `P "Creates a fresh snapshot file."] 163 | in 164 | let term = 165 | Term.(ret Conex_opts.(const create $ setup_log $ Keys.dry $ Keys.repo $ Keys.root $ Keys.id)) 166 | and info = Cmd.info "create" ~doc ~man 167 | in 168 | Cmd.v info term 169 | 170 | let help_cmd = 171 | let topic = 172 | let doc = "The topic to get help on. `topics' lists the topics." in 173 | Arg.(value & pos 0 (some string) None & info [] ~docv:"TOPIC" ~doc) 174 | in 175 | Term.(ret Conex_opts.(const help $ setup_log $ Keys.dry $ Keys.repo $ Keys.id $ Arg.man_format $ Term.choice_names $ topic)) 176 | 177 | let cmds = [ status_cmd ; sign_cmd ; create_cmd ] 178 | 179 | let () = 180 | let doc = "Manage snapshot file of a signed community repository" in 181 | let man = help_secs in 182 | let info = Cmd.info "conex_snapshot" ~version:"%%VERSION_NUM%%" ~sdocs:docs ~doc ~man in 183 | let group = Cmd.group ~default:help_cmd info cmds in 184 | exit (Cmd.eval group) 185 | -------------------------------------------------------------------------------- /app/conex_targets.ml: -------------------------------------------------------------------------------- 1 | open Conex_utils 2 | open Conex_resource 3 | 4 | open Conex_opts 5 | open Conex_mc 6 | 7 | module IO = Conex_io 8 | 9 | let ( let* ) = Result.bind 10 | 11 | let find_id io root id = 12 | let id = Option.value ~default:"" id in 13 | match List.filter (fun x -> String.is_prefix ~prefix:id x) (IO.targets io root) with 14 | | [ x ] -> Ok x 15 | | [] -> Error "no id found with given prefix" 16 | | _ -> Error "multiple ids found with given prefix" 17 | 18 | let status _ repodir id root_file no_opam = 19 | msg_to_cmdliner ( 20 | let* io = repo ~rw:false repodir in 21 | let* root, warn = to_str IO.pp_r_err (IO.read_root io root_file) in 22 | List.iter (fun msg -> Logs.warn (fun m -> m "%s" msg)) warn ; 23 | Logs.debug (fun m -> m "root file %a" Root.pp root) ; 24 | let repo = Conex_repository.create root in 25 | let* id' = find_id io root id in 26 | let* targets = C.verify_targets io repo (not no_opam) id' in 27 | Logs.app (fun m -> m "targets file %a" Targets.pp targets) ; 28 | Ok ()) 29 | 30 | let create _ repodir id dry root_file no_opam = 31 | (* given private key id, create an initial targets template! *) 32 | msg_to_cmdliner ( 33 | let* priv, id' = init_priv_id id in 34 | let* io = repo ~rw:(not dry) repodir in 35 | let* root, warn = to_str IO.pp_r_err (IO.read_root io root_file) in 36 | List.iter (fun msg -> Logs.warn (fun m -> m "%s" msg)) warn ; 37 | Logs.debug (fun m -> m "root file %a" Root.pp root) ; 38 | let targets = 39 | Result.fold 40 | ~error:(fun _ -> 41 | let pub = PRIV.pub_of_priv priv in 42 | let keyref = Expression.Local id' in 43 | let keys = M.add id' pub M.empty in 44 | let valid = Expression.(Quorum (1, KS.singleton keyref)) in 45 | Targets.t ~keys now id' valid) 46 | ~ok:(fun (targets, warn) -> 47 | List.iter (fun msg -> Logs.warn (fun m -> m "%s" msg)) warn ; 48 | targets) 49 | (IO.read_targets io root (not no_opam) id') 50 | in 51 | Logs.app (fun m -> m "targets file %a" Targets.pp targets) ; 52 | IO.write_targets io root targets) 53 | 54 | let hash _ repodir id root_file no_opam = 55 | msg_to_cmdliner ( 56 | let* id' = Option.to_result ~none:"requires id" id in 57 | let* io = repo ~rw:false repodir in 58 | let* root, warn = to_str IO.pp_r_err (IO.read_root io root_file) in 59 | List.iter (fun msg -> Logs.warn (fun m -> m "%s" msg)) warn ; 60 | Logs.debug (fun m -> m "root file %a" Root.pp root) ; 61 | let* targets, warn = 62 | to_str IO.pp_r_err (IO.read_targets io root (not no_opam) id') 63 | in 64 | List.iter (fun msg -> Logs.warn (fun m -> m "%s" msg)) warn ; 65 | let keys = 66 | M.fold 67 | (fun k v acc -> M.add k (Key.to_string v) acc) 68 | targets.Targets.keys M.empty 69 | in 70 | let* dgst = Expression.hash V.raw_digest keys targets.Targets.valid in 71 | Logs.app (fun m -> m "hash %a" Digest.pp dgst) ; 72 | Ok ()) 73 | 74 | let compute _ dry repodir id pkg root_file no_opam = 75 | msg_to_cmdliner ( 76 | let* io = repo ~rw:(not dry) repodir in 77 | let* root, warn = to_str IO.pp_r_err (IO.read_root io root_file) in 78 | List.iter (fun msg -> Logs.warn (fun m -> m "%s" msg)) warn ; 79 | Logs.debug (fun m -> m "root file %a" Root.pp root) ; 80 | let path = Option.fold ~none:[] ~some:(fun p -> [ p ]) pkg in 81 | let* targets = 82 | IO.compute_checksum ~prefix:root.Root.datadir io (not no_opam) V.raw_digest path 83 | in 84 | let out = 85 | let raw = List.map Target.wire_raw targets in 86 | M.add "targets" (Wire.List raw) M.empty 87 | in 88 | Logs.app (fun m -> m "computed targets: %s" (Conex_opam_encoding.encode out)) ; 89 | let* id' = Option.to_result ~none:"requires id for writing" id in 90 | let* t, warn = 91 | to_str IO.pp_r_err (IO.read_targets io root (not no_opam) id') 92 | in 93 | List.iter (fun msg -> Logs.warn (fun m -> m "%s" msg)) warn ; 94 | let t' = { t with Targets.targets = t.Targets.targets @ targets } in 95 | IO.write_targets io root t') 96 | 97 | let sign _ dry repodir id no_incr root_file no_opam = 98 | Mirage_crypto_rng_unix.use_default () ; 99 | msg_to_cmdliner ( 100 | let* priv, id' = init_priv_id id in 101 | let* io = repo ~rw:(not dry) repodir in 102 | let* root, warn = to_str IO.pp_r_err (IO.read_root io root_file) in 103 | List.iter (fun msg -> Logs.warn (fun m -> m "%s" msg)) warn ; 104 | Logs.debug (fun m -> m "root is %a" Root.pp root) ; 105 | let* targets, warn = 106 | to_str IO.pp_r_err (IO.read_targets io root (not no_opam) id') 107 | in 108 | List.iter (fun msg -> Logs.warn (fun m -> m "%s" msg)) warn ; 109 | let* targets' = 110 | match no_incr, Uint.succ targets.Targets.counter with 111 | | true, _ -> Ok targets 112 | | false, (false, counter) -> Ok { targets with Targets.counter } 113 | | false, (true, _) -> Error "couldn't increment counter" 114 | in 115 | let* signature = 116 | PRIV.sign (Targets.wire_raw targets') now id' `RSA_PSS_SHA256 priv 117 | in 118 | let targets'' = Targets.add_signature targets' id' signature in 119 | IO.write_targets io root targets'') 120 | 121 | let help _ _ _ _ man_format cmds = function 122 | | None -> `Help (`Pager, None) 123 | | Some t when List.mem t cmds -> `Help (man_format, Some t) 124 | | Some _ -> List.iter print_endline cmds; `Ok () 125 | 126 | let setup_log style_renderer level = 127 | Fmt_tty.setup_std_outputs ?style_renderer (); 128 | Logs.set_level level; 129 | Logs.set_reporter (Logs_fmt.reporter ~dst:Format.std_formatter ()) 130 | 131 | open Cmdliner 132 | 133 | let docs = Keys.docs 134 | 135 | let help_secs = [ 136 | `S "GENERAL"; 137 | `P "$(mname) is a tool for managing cryptographically signed community repositories."; 138 | `P "The signing metadata is kept in the same repository."; 139 | `S docs; 140 | `P "These options are common to all commands."; 141 | `S "SEE ALSO"; 142 | `P "Use `$(mname) $(i,COMMAND) --help' for help on a single command."; 143 | `S "BUGS"; `P "Please report bugs at https://github.com/hannesm/conex.";] 144 | 145 | let setup_log = 146 | Term.(const setup_log 147 | $ Fmt_cli.style_renderer ~docs () 148 | $ Logs_cli.level ~docs ()) 149 | 150 | let sign_cmd = 151 | let doc = "sign targets file with provided key" in 152 | let man = 153 | [`S "DESCRIPTION"; 154 | `P "Cryptographically signs queued changes to your resource list."] 155 | in 156 | let term = 157 | Term.(ret Conex_opts.(const sign $ setup_log $ Keys.dry $ Keys.repo $ Keys.id $ Keys.no_incr $ Keys.root $ Keys.no_opam)) 158 | and info = Cmd.info "sign" ~doc ~man 159 | in 160 | Cmd.v info term 161 | 162 | let status_cmd = 163 | let doc = "information about provided targets file" in 164 | let man = 165 | [`S "DESCRIPTION"; 166 | `P "Shows information targets file."] 167 | in 168 | let term = 169 | Term.(ret Conex_opts.(const status $ setup_log $ Keys.repo $ Keys.id $ Keys.root $ Keys.no_opam)) 170 | and info = Cmd.info "status" ~doc ~man 171 | in 172 | Cmd.v info term 173 | 174 | let create_cmd = 175 | let doc = "create a targets file" in 176 | let man = 177 | [`S "DESCRIPTION"; 178 | `P "Creates a fresh targets file."] 179 | in 180 | let term = 181 | Term.(ret Conex_opts.(const create $ setup_log $ Keys.repo $ Keys.id $ Keys.dry $ Keys.root $ Keys.no_opam)) 182 | and info = Cmd.info "create" ~doc ~man 183 | in 184 | Cmd.v info term 185 | 186 | let hash_cmd = 187 | let doc = "create a hash of the valid expression in a targets file" in 188 | let man = 189 | [`S "DESCRIPTION"; 190 | `P "Hash targets valid expression file."] 191 | in 192 | let term = 193 | Term.(ret Conex_opts.(const hash $ setup_log $ Keys.repo $ Keys.id $ Keys.root $ Keys.no_opam)) 194 | and info = Cmd.info "hash" ~doc ~man 195 | in 196 | Cmd.v info term 197 | 198 | let compute_cmd = 199 | let doc = "compute checksums for targets file" in 200 | let man = 201 | [`S "DESCRIPTION"; 202 | `P "Computes checksums."] 203 | in 204 | let term = 205 | Term.(ret Conex_opts.(const compute $ setup_log $ Keys.dry $ Keys.repo $ Keys.id $ Keys.package $ Keys.root $ Keys.no_opam)) 206 | and info = Cmd.info "compute" ~doc ~man 207 | in 208 | Cmd.v info term 209 | 210 | let help_cmd = 211 | let topic = 212 | let doc = "The topic to get help on. `topics' lists the topics." in 213 | Arg.(value & pos 0 (some string) None & info [] ~docv:"TOPIC" ~doc) 214 | in 215 | Term.(ret Conex_opts.(const help $ setup_log $ Keys.dry $ Keys.repo $ Keys.id $ Arg.man_format $ Term.choice_names $ topic)) 216 | 217 | let cmds = [ status_cmd ; sign_cmd ; create_cmd ; compute_cmd ; hash_cmd ] 218 | 219 | let () = 220 | let doc = "Manage targets files of a signed community repository" in 221 | let man = help_secs in 222 | let info = Cmd.info "conex_targets" ~version:"%%VERSION_NUM%%" ~sdocs:docs ~doc ~man in 223 | let group = Cmd.group ~default:help_cmd info cmds in 224 | exit (Cmd.eval group) 225 | -------------------------------------------------------------------------------- /app/conex_timestamp.ml: -------------------------------------------------------------------------------- 1 | open Conex_utils 2 | open Conex_resource 3 | 4 | open Conex_mc 5 | 6 | module IO = Conex_io 7 | 8 | let ( let* ) = Result.bind 9 | 10 | let io_repo ~rw repodir root_file = 11 | let* io = Conex_opts.repo ~rw repodir in 12 | let* root, warn = to_str IO.pp_r_err (IO.read_root io root_file) in 13 | List.iter (fun msg -> Logs.warn (fun m -> m "%s" msg)) warn ; 14 | Logs.debug (fun m -> m "root file %a" Root.pp root) ; 15 | let repo = Conex_repository.create root in 16 | Ok (io, repo) 17 | 18 | let status _ repodir root_file id timestamp_expiry = 19 | Conex_opts.msg_to_cmdliner ( 20 | let* io, repo = io_repo ~rw:false repodir root_file in 21 | let* _ts = C.verify_timestamp ?id io repo ~timestamp_expiry ~now in 22 | Ok ()) 23 | 24 | let time_id id repo = 25 | let* time_id = Conex_repository.timestamp repo in 26 | match id, time_id with 27 | | None, None -> Error "neither ID provided nor a timestamp role in root file present" 28 | | None, Some (time_id, _, _) -> 29 | Logs.info (fun m -> m "using %a (as specified in root file)" pp_id time_id); 30 | Ok time_id 31 | | Some id, None -> 32 | Logs.info (fun m -> m "using %a (none specified in root file)" pp_id id); 33 | Ok id 34 | | Some id, Some (time_id, _, _) -> 35 | if not (id_equal id time_id) then 36 | Logs.warn (fun m -> m "using specified id %a, but in root file %a is specified" 37 | pp_id id pp_id time_id); 38 | Ok id 39 | 40 | let create _ dry repodir root_file id = 41 | Conex_opts.msg_to_cmdliner ( 42 | let* io, repo = io_repo ~rw:(not dry) repodir root_file in 43 | let* id = time_id id repo in 44 | let* snap = Conex_repository.snapshot repo in 45 | let targets = 46 | match snap with 47 | | None -> 48 | Logs.warn (fun m -> m "no snapshots found in root file"); 49 | [] 50 | | Some (key, _, _) -> 51 | let path = Conex_repository.keydir repo @ [ key ] in 52 | match IO.compute_checksum_file io V.raw_digest path with 53 | | Ok target -> [ target ] 54 | | Error msg -> 55 | Logs.warn (fun m -> m "error %s while computing checksum for key %s" 56 | msg key); 57 | [] 58 | in 59 | let old_ts, warn = match IO.read_timestamp io id with 60 | | Ok ts -> ts 61 | | Error e -> 62 | Logs.warn (fun m -> m "error %a while reading timestamp" IO.pp_r_err e); 63 | Timestamp.t now id, [] 64 | in 65 | List.iter 66 | (fun w -> Logs.warn (fun m -> m "warning while reading timestamp: %s" w)) 67 | warn; 68 | let ts = 69 | Timestamp.t ~counter:old_ts.Timestamp.counter 70 | ~epoch:old_ts.Timestamp.epoch 71 | ~keys:old_ts.Timestamp.keys 72 | ~targets now id 73 | in 74 | Logs.app (fun m -> m "timestamp file %a" Timestamp.pp ts) ; 75 | IO.write_timestamp io ts) 76 | 77 | let sign _ dry repodir id no_incr root_file = 78 | Mirage_crypto_rng_unix.use_default () ; 79 | Conex_opts.msg_to_cmdliner ( 80 | let* io, repo = io_repo ~rw:(not dry) repodir root_file in 81 | let* time_id = time_id id repo in 82 | let* priv, id' = init_priv_id (Some time_id) in 83 | let* ts, warn = to_str IO.pp_r_err (IO.read_timestamp io id') in 84 | List.iter 85 | (fun w -> Logs.warn (fun m -> m "warning while reading timestamp: %s" w)) 86 | warn; 87 | let* ts' = 88 | match no_incr, Uint.succ ts.Timestamp.counter with 89 | | false, (true, _) -> Error "couldn't increment counter" 90 | | true, _ -> Ok ts 91 | | false, (false, counter) -> Ok { ts with Timestamp.counter } 92 | in 93 | let* signature = 94 | PRIV.sign (Timestamp.wire_raw ts') now id' `RSA_PSS_SHA256 priv 95 | in 96 | let ts'' = Timestamp.add_signature ts' id' signature in 97 | IO.write_timestamp io ts'') 98 | 99 | let help _ _ _ _ man_format cmds = function 100 | | None -> `Help (`Pager, None) 101 | | Some t when List.mem t cmds -> `Help (man_format, Some t) 102 | | Some _ -> List.iter print_endline cmds; `Ok () 103 | 104 | let setup_log style_renderer level = 105 | Fmt_tty.setup_std_outputs ?style_renderer (); 106 | Logs.set_level level; 107 | Logs.set_reporter (Logs_fmt.reporter ~dst:Format.std_formatter ()) 108 | 109 | open Cmdliner 110 | 111 | let docs = Conex_opts.Keys.docs 112 | 113 | let help_secs = [ 114 | `S "GENERAL"; 115 | `P "$(mname) is a tool for managing cryptographically signed community repositories."; 116 | `P "The signing metadata is kept in the same repository."; 117 | `S docs; 118 | `P "These options are common to all commands."; 119 | `S "SEE ALSO"; 120 | `P "Use `$(mname) $(i,COMMAND) --help' for help on a single command."; 121 | `S "BUGS"; `P "Please report bugs at https://github.com/hannesm/conex.";] 122 | 123 | let setup_log = 124 | Term.(const setup_log 125 | $ Fmt_cli.style_renderer ~docs () 126 | $ Logs_cli.level ~docs ()) 127 | 128 | let sign_cmd = 129 | let doc = "sign timestamp file with provided key" in 130 | let man = 131 | [`S "DESCRIPTION"; 132 | `P "Cryptographically signs the timestamp file."] 133 | in 134 | let term = 135 | Term.(ret Conex_opts.(const sign $ setup_log $ Keys.dry $ Keys.repo $ Keys.id $ Keys.no_incr $ Keys.root)) 136 | and info = Cmd.info "sign" ~doc ~man 137 | in 138 | Cmd.v info term 139 | 140 | let status_cmd = 141 | let doc = "information about provided timestamp file" in 142 | let man = 143 | [`S "DESCRIPTION"; 144 | `P "Shows information about the timestamp file. Th provided ID is used as \ 145 | timestamp identifier. The timestamp file is verified. If a timestamp \ 146 | role is present in the root file, it is validated."] 147 | in 148 | let term = 149 | Term.(ret Conex_opts.(const status $ setup_log $ Keys.repo $ Keys.root $ Keys.id $ Keys.timestamp_expiry)) 150 | and info = Cmd.info "status" ~doc ~man 151 | in 152 | Cmd.v info term 153 | 154 | let create_cmd = 155 | let doc = "create an empty timestamp file" in 156 | let man = 157 | [`S "DESCRIPTION"; 158 | `P "Creates a fresh timestamp file."] 159 | in 160 | let term = 161 | Term.(ret Conex_opts.(const create $ setup_log $ Keys.dry $ Keys.repo $ Keys.root $ Keys.id)) 162 | and info = Cmd.info "create" ~doc ~man 163 | in 164 | Cmd.v info term 165 | 166 | let help_cmd = 167 | let topic = 168 | let doc = "The topic to get help on. `topics' lists the topics." in 169 | Arg.(value & pos 0 (some string) None & info [] ~docv:"TOPIC" ~doc) 170 | in 171 | Term.(ret Conex_opts.(const help $ setup_log $ Keys.dry $ Keys.repo $ Keys.id $ Arg.man_format $ Term.choice_names $ topic)) 172 | 173 | let cmds = [ status_cmd ; sign_cmd ; create_cmd ] 174 | 175 | let () = 176 | let doc = "Manage timestamp file of a signed community repository" in 177 | let man = help_secs in 178 | let info = Cmd.info "conex_timestamp" ~version:"%%VERSION_NUM%%" ~sdocs:docs ~doc ~man in 179 | let group = Cmd.group ~default:help_cmd info cmds in 180 | exit (Cmd.eval group) 181 | -------------------------------------------------------------------------------- /app/conex_verify_app.ml: -------------------------------------------------------------------------------- 1 | open Conex_utils 2 | 3 | (* this is the barebones verify with minimal dependencies 4 | (goal: cmdliner, opam-file-format, Unix, external openssl) 5 | *) 6 | 7 | (* to be called by opam (see http://opam.ocaml.org/doc/2.0/Manual.html#configfield-repository-validation-command, https://github.com/ocaml/opam/pull/2754/files#diff-5f9ccd1bb288197c5cf2b18366a73363R312): 8 | 9 | %{quorum}% - a non-negative integer (--quorum) 10 | %{anchors}% - list of digests, separated by "," (--trust-anchors -- to be used in full verification) 11 | %{root}% - the repository root (--repository) 12 | 13 | (we need --strict and --no-strict [initially default]) 14 | 15 | two modes of operation (%{incremental}% will just be "true" or "false"): 16 | 17 | -full 18 | %{dir}% is only defined for a full update, and is the dir to verify (--dir) 19 | 20 | -incremental 21 | %{patch}% - path to a patch (to be applied with -p1, generated by diff -ruaN dir1 dir2) (--patch) 22 | 23 | exit code success = 0, failure otherwise 24 | 25 | example: 26 | 27 | repository-validation-command: [ 28 | "conex" "--root" "%{root}%" "--trust-anchors" "%{anchors}%" "--patch" "%{patch}%" 29 | ] 30 | 31 | > cat conex 32 | #!/bin/bash -ue 33 | echo "$*" 34 | true 35 | 36 | *) 37 | 38 | module IO = Conex_io 39 | 40 | let ( let* ) = Result.bind 41 | 42 | module VERIFY (L : LOGS) (V : Conex_verify.S) = struct 43 | 44 | module C = Conex.Make(L)(V) 45 | 46 | let verify_root_targets io valid quorum ignore_missing root_file opam ~timestamp_expiry ~now = 47 | let* repo = C.verify_root ~valid ?quorum io root_file in 48 | let* timestamp = C.verify_timestamp io repo ~timestamp_expiry ~now in 49 | let* snapshot = C.verify_snapshot ?timestamp io repo in 50 | C.verify ~ignore_missing ?snapshot io repo opam 51 | 52 | let verify_diff io patch valid quorum ignore_missing root_file opam ~timestamp_expiry ~now = 53 | let* x = Conex_unix_persistency.read_file patch in 54 | let newio, diffs = Conex_diff_provider.apply_diff io x in 55 | let* () = 56 | verify_root_targets newio valid quorum ignore_missing root_file opam ~timestamp_expiry ~now 57 | in 58 | let* () = C.verify_diffs root_file io newio diffs opam in 59 | Printf.printf "diff verification successfull\n" ; 60 | Ok () 61 | 62 | let verify_full io valid quorum ignore_missing root_file opam ~timestamp_expiry ~now = 63 | let* () = 64 | verify_root_targets io valid quorum ignore_missing root_file opam ~timestamp_expiry ~now 65 | in 66 | Printf.printf "full verification successfull\n" ; 67 | Ok () 68 | 69 | let verify_it repodir quorum anchors incremental dir patch nostrict root_file opam ~timestamp_expiry ~now = 70 | let valid = Conex_opts.valid anchors in 71 | match repodir, incremental, patch, dir with 72 | | Some repodir, true, Some p, None -> 73 | let* io = Conex_unix_provider.fs_ro_provider repodir in 74 | L.debug (fun m -> m "%a" Conex_io.pp io) ; 75 | verify_diff io p valid quorum nostrict root_file opam ~timestamp_expiry ~now 76 | | _, false, None, Some "" -> 77 | L.debug (fun m -> m "called with no incremental, and dir = empty -> no update") ; 78 | Ok () 79 | | _, false, None, Some d -> 80 | let* io = Conex_unix_provider.fs_ro_provider d in 81 | L.debug (fun m -> m "%a" Conex_io.pp io) ; 82 | verify_full io valid quorum nostrict root_file opam ~timestamp_expiry ~now 83 | | None, _, _, _ -> Error "--repo is required" 84 | | _ -> Error "invalid combination of incremental, patch and dir" 85 | end 86 | 87 | let doc = "Verify a signed community repository" 88 | and man = [ 89 | `S "DESCRIPTION" ; 90 | `P "$(tname) verifies a cryptographically signed community repository" ; 91 | `P "Two verification modes are supported: $(b,initial) and $(b,incremental)." ; 92 | `P "During $(b,initial) verification, the trust is rooted in $(b,--anchors), and the repository $(b,--dir) is verified." ; 93 | `P "In $(b,incremental) mode, an existing trusted repository is used as trust root, and a provided $(b,--patch) is verified: signed and monotonicity is preserved."; 94 | ] 95 | -------------------------------------------------------------------------------- /app/conex_verify_mirage_crypto.ml: -------------------------------------------------------------------------------- 1 | open Conex_verify_app 2 | 3 | open Conex_opts 4 | 5 | module V = VERIFY(Logs)(Conex_mirage_crypto.NC_V) 6 | 7 | let jump _ repo quorum anchors inc dir patch nostrict root no_opam timestamp_expiry = 8 | let now = Conex_mc.now in 9 | msg_to_cmdliner (V.verify_it repo quorum anchors inc dir patch nostrict root (not no_opam) ~timestamp_expiry ~now) 10 | 11 | let setup_log style_renderer level = 12 | Fmt_tty.setup_std_outputs ?style_renderer (); 13 | Logs.set_level level; 14 | Logs.set_reporter (Logs_fmt.reporter ~dst:Format.std_formatter ()) 15 | 16 | open Cmdliner 17 | 18 | let docs = Keys.docs 19 | 20 | let setup_log = 21 | Term.(const setup_log 22 | $ Fmt_cli.style_renderer ~docs () 23 | $ Logs_cli.level ~docs ()) 24 | 25 | let cmd = 26 | let term = 27 | Term.(ret (const jump $ setup_log $ Keys.repo $ Keys.quorum $ Keys.anchors $ Keys.incremental $ Keys.dir $ Keys.patch $ Keys.ignore_missing $ Keys.root $ Keys.no_opam $ Keys.timestamp_expiry)) 28 | and info = Cmd.info "conex_verify_mirage_crypto" ~version:"%%VERSION_NUM%%" 29 | ~doc:Conex_verify_app.doc ~man:Conex_verify_app.man 30 | in 31 | Cmd.v info term 32 | 33 | let () = exit (Cmd.eval cmd) 34 | -------------------------------------------------------------------------------- /app/conex_verify_openssl.ml: -------------------------------------------------------------------------------- 1 | open Conex_utils 2 | 3 | module type EXTLOGS = sig 4 | include LOGS 5 | 6 | type level = [ `Debug | `Info | `Warn ] 7 | val set_level : level -> unit 8 | val set_styled : bool -> unit 9 | end 10 | 11 | module Log : EXTLOGS = struct 12 | module Tag = struct 13 | type set 14 | end 15 | 16 | type ('a, 'b) msgf = 17 | (?header:string -> ?tags:Tag.set -> 18 | ('a, Format.formatter, unit, 'b) format4 -> 'a) -> 'b 19 | type 'a log = ('a, unit) msgf -> unit 20 | 21 | type src 22 | 23 | type level = [ `Debug | `Info | `Warn ] 24 | let curr_level = ref `Warn 25 | let set_level lvl = curr_level := lvl 26 | let level_to_string = function 27 | | `Debug -> "DEBUG" 28 | | `Info -> "INFO" 29 | | `Warn -> "WARN" 30 | 31 | let curr_styled = ref true 32 | let set_styled b = curr_styled := b 33 | let style level txt = 34 | if !curr_styled then 35 | let rst = "\027[m" in 36 | match level with 37 | | `Debug -> "\027[32m" ^ txt ^ rst 38 | | `Info -> "\027[34m" ^ txt ^ rst 39 | | `Warn -> "\027[33m" ^ txt ^ rst 40 | else 41 | txt 42 | 43 | let report level k msgf = 44 | let k _ = k () in 45 | msgf @@ fun ?header ?tags:_ fmt -> 46 | let hdr = Option.fold ~none:"" ~some:(fun s -> s ^ " ") header in 47 | Format.kfprintf k Format.std_formatter 48 | ("%s[%s] @[" ^^ fmt ^^ "@]@.") hdr (style level (level_to_string level)) 49 | 50 | let wcount = ref 0 51 | 52 | let warn_count () = !wcount 53 | 54 | let kunit _ = () 55 | let kmsg : type a b. (unit -> b) -> level -> (a, b) msgf -> b = 56 | fun k level msgf -> 57 | let doit = 58 | match level, !curr_level with 59 | | `Warn, _ -> true 60 | | `Info, `Debug | `Info, `Info -> true 61 | | `Debug, `Debug -> true 62 | | _ -> false 63 | in 64 | if doit then report level k msgf else k () 65 | 66 | let debug ?src:_ msgf = kmsg kunit `Debug msgf 67 | let info ?src:_ msgf = kmsg kunit `Info msgf 68 | let warn ?src:_ msgf = incr wcount ; kmsg kunit `Warn msgf 69 | end 70 | 71 | open Conex_verify_app 72 | open Conex_opts 73 | module V = VERIFY(Log)(Conex_openssl.O_V) 74 | 75 | let terminal () = 76 | let dumb = try Sys.getenv "TERM" = "dumb" with 77 | | Not_found -> true 78 | in 79 | let isatty = try Unix.(isatty (descr_of_out_channel Stdlib.stdout)) with 80 | | Unix.Unix_error _ -> false 81 | in 82 | if not dumb && isatty then `Ansi_tty else `None 83 | 84 | let now = 85 | let tm = Unix.(gmtime (time ())) in 86 | let y, m, d = Unix.(tm.tm_year + 1900, tm.tm_mon + 1, tm.tm_mday) in 87 | let hh, mm, ss = Unix.(tm.tm_hour, tm.tm_min, tm.tm_sec) in 88 | Printf.sprintf "%04d-%02d-%02dT%02d:%02d:%02dZ" y m d hh mm ss 89 | 90 | let setup repo quorum anchors incremental dir patch verbose quiet strict no_c root no_opam timestamp_expiry = 91 | let level = 92 | if quiet then `Warn 93 | else if verbose then `Debug 94 | else `Info 95 | in 96 | Log.set_level level ; 97 | let styled = 98 | if no_c then 99 | false 100 | else 101 | match terminal () with `Ansi_tty -> true | `None -> false 102 | in 103 | Log.set_styled styled ; 104 | let ( let* ) = Result.bind in 105 | msg_to_cmdliner ( 106 | let* () = Conex_openssl.V.check_version () in 107 | V.verify_it repo quorum anchors incremental dir patch strict root (not no_opam) ~timestamp_expiry ~now) 108 | 109 | open Conex_opts 110 | open Cmdliner 111 | 112 | let quiet = 113 | let doc = "Be quiet. Takes over $(b,--verbose)" in 114 | Arg.(value & flag & info [ "q" ; "quiet" ] ~doc) 115 | 116 | let verbose = 117 | let doc = "Be more verbose." in 118 | Arg.(value & flag & info [ "v" ; "verbose" ] ~doc) 119 | 120 | let no_color = 121 | let doc = "Don't colourise the output. Default is to colourise unless the output is not a terminal (or a dumb one)." in 122 | Arg.(value & flag & info [ "no-color" ] ~doc) 123 | 124 | let cmd = 125 | let term = 126 | Term.(ret (const setup $ Keys.repo $ Keys.quorum $ Keys.anchors $ Keys.incremental $ Keys.dir $ Keys.patch $ verbose $ quiet $ Keys.ignore_missing $ no_color $ Keys.root $ Keys.no_opam $ Keys.timestamp_expiry)) 127 | and info = Cmd.info "conex_verify_openssl" ~version:"%%VERSION_NUM%%" 128 | ~doc:Conex_verify_app.doc ~man:Conex_verify_app.man 129 | in 130 | Cmd.v info term 131 | 132 | let () = exit (Cmd.eval cmd) 133 | -------------------------------------------------------------------------------- /app/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name conex_cmd) 3 | (wrapped false) 4 | (modules conex_verify_app conex_opts) 5 | (libraries cmdliner conex conex.unix)) 6 | 7 | (executable 8 | (name conex_verify_openssl) 9 | (public_name conex_verify_openssl) 10 | (package conex) 11 | (modules conex_verify_openssl) 12 | (libraries cmdliner conex conex.openssl conex.unix conex_cmd)) 13 | 14 | (executable 15 | (name conex_verify_mirage_crypto) 16 | (public_name conex_verify_mirage_crypto) 17 | (package conex-mirage-crypto) 18 | (modules conex_verify_mirage_crypto) 19 | (libraries cmdliner conex conex-mirage-crypto conex.unix conex_cmd logs fmt logs.fmt fmt.tty logs.cli fmt.cli conex_cmd_mc)) 20 | 21 | (library 22 | (name conex_cmd_mc) 23 | (wrapped false) 24 | (modules conex_mc) 25 | (libraries conex-mirage-crypto conex.unix logs fmt ptime ptime.clock.os)) 26 | 27 | (executable 28 | (name conex_root) 29 | (public_name conex_root) 30 | (package conex-mirage-crypto) 31 | (modules conex_root) 32 | (libraries cmdliner conex conex-mirage-crypto conex.unix conex_cmd conex_cmd_mc logs fmt logs.fmt fmt.tty logs.cli fmt.cli mirage-crypto-rng.unix)) 33 | 34 | (executable 35 | (name conex_key) 36 | (public_name conex_key) 37 | (package conex-mirage-crypto) 38 | (modules conex_key) 39 | (libraries cmdliner conex conex-mirage-crypto conex.unix conex_cmd conex_cmd_mc logs fmt logs.fmt fmt.tty logs.cli fmt.cli mirage-crypto-rng.unix)) 40 | 41 | (executable 42 | (name conex_targets) 43 | (public_name conex_targets) 44 | (package conex-mirage-crypto) 45 | (modules conex_targets) 46 | (libraries cmdliner conex conex-mirage-crypto conex.unix conex_cmd conex_cmd_mc logs fmt logs.fmt fmt.tty logs.cli fmt.cli mirage-crypto-rng.unix)) 47 | 48 | (executable 49 | (name conex_timestamp) 50 | (public_name conex_timestamp) 51 | (package conex-mirage-crypto) 52 | (modules conex_timestamp) 53 | (libraries cmdliner conex conex-mirage-crypto conex.unix conex_cmd conex_cmd_mc logs fmt logs.fmt fmt.tty logs.cli fmt.cli mirage-crypto-rng.unix)) 54 | 55 | (executable 56 | (name conex_snapshot) 57 | (public_name conex_snapshot) 58 | (package conex-mirage-crypto) 59 | (modules conex_snapshot) 60 | (libraries cmdliner conex conex-mirage-crypto conex.unix conex_cmd conex_cmd_mc logs fmt logs.fmt fmt.tty logs.cli fmt.cli mirage-crypto-rng.unix)) 61 | -------------------------------------------------------------------------------- /conex-mirage-crypto.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "Hannes Mehnert " 3 | authors: "Hannes Mehnert " 4 | license: "BSD2" 5 | homepage: "https://github.com/hannesm/conex" 6 | doc: "https://hannesm.github.io/conex/doc" 7 | bug-reports: "https://github.com/hannesm/conex/issues" 8 | depends: [ 9 | "ocaml" {>= "4.13.0"} 10 | "dune" {>= "2.7"} 11 | "alcotest" {with-test} 12 | "bisect_ppx" {dev & >= "2.5.0"} 13 | "cmdliner" {>= "1.1.0"} 14 | "conex" {= version} 15 | "mirage-crypto-pk" {>= "1.0.0"} 16 | "mirage-crypto-rng" {>= "1.2.0"} 17 | "x509" {>= "1.0.0"} 18 | "logs" 19 | "fmt" 20 | "ptime" 21 | "base64" {>= "3.4.0"} 22 | "digestif" {>= "1.2.0"} 23 | "conf-openssl" {with-test} 24 | ] 25 | conflicts: [ "result" {< "1.5"} ] 26 | build: [ 27 | ["dune" "subst"] {dev} 28 | ["dune" "build" "-p" name "-j" jobs] 29 | ["dune" "runtest" "-p" name "-j" jobs] {with-test} 30 | ] 31 | dev-repo: "git+https://github.com/hannesm/conex.git" 32 | synopsis: "Establishing trust in community repositories: crypto provided via mirage-crypto" 33 | description: """ 34 | Conex is a system based on [TUF](https://theupdateframework.github.io/) to 35 | establish trust in community repositories. Since opam2, the required hooks 36 | are present. 37 | 38 | This package uses the crypto primitives provided by mirage-crypto. 39 | """ 40 | -------------------------------------------------------------------------------- /conex.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "Hannes Mehnert " 3 | authors: "Hannes Mehnert " 4 | license: "BSD2" 5 | homepage: "https://github.com/hannesm/conex" 6 | doc: "https://hannesm.github.io/conex/doc" 7 | bug-reports: "https://github.com/hannesm/conex/issues" 8 | depends: [ 9 | "ocaml" {>= "4.13.0"} 10 | "dune" {>= "2.7"} 11 | "cmdliner" {>= "1.1.0"} 12 | "opam-file-format" {>= "2.1.1"} 13 | ] 14 | build: [ 15 | ["dune" "subst"] {dev} 16 | ["dune" "build" "-p" name "-j" jobs] 17 | ] 18 | dev-repo: "git+https://github.com/hannesm/conex.git" 19 | synopsis: "Establishing trust in community repositories" 20 | description: """ 21 | Conex is a system based on [TUF](https://theupdateframework.github.io/) to 22 | establish trust in community repositories. Since opam2, the required hooks 23 | are present. 24 | 25 | This package uses openssl for the required crypto primitives (>=1.0.0u for RSA-PSS). 26 | """ 27 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 2.7) 2 | (name conex) 3 | (formatting disabled) -------------------------------------------------------------------------------- /mirage-crypto/conex_mirage_crypto.ml: -------------------------------------------------------------------------------- 1 | open Conex_utils 2 | 3 | module V = struct 4 | let good_rsa p = Mirage_crypto_pk.Rsa.pub_bits p >= 2048 5 | 6 | let encode_key pub = 7 | String.trim (X509.Public_key.encode_pem (`RSA pub)) 8 | 9 | let decode_key data = 10 | Result.fold 11 | ~error:(fun _ -> None) 12 | ~ok:(function `RSA pub -> Some pub | _ -> None) 13 | (X509.Public_key.decode_pem data) 14 | 15 | module Pss_sha256 = Mirage_crypto_pk.Rsa.PSS (Digestif.SHA256) 16 | 17 | let verify_rsa_pss ~key ~data ~signature id = 18 | let ( let* ) = Result.bind in 19 | let* signature = 20 | Result.map_error (fun _ -> `InvalidBase64Encoding id) 21 | (Base64.decode signature) 22 | in 23 | let* key = 24 | Option.to_result ~none:(`InvalidPublicKey id) (decode_key key) 25 | in 26 | let* () = guard (good_rsa key) (`InvalidPublicKey id) in 27 | guard (Pss_sha256.verify ~key ~signature (`Message data)) 28 | (`InvalidSignature id) 29 | 30 | let to_h i = 31 | if i < 10 then 32 | char_of_int (0x30 + i) 33 | else 34 | char_of_int (0x57 + i) 35 | 36 | let to_hex cs = 37 | let l = String.length cs in 38 | let out = Bytes.create (2 * l) in 39 | for i = 0 to pred l do 40 | let b = String.get_uint8 cs i in 41 | let up = b lsr 4 42 | and low = b land 0x0F 43 | in 44 | Bytes.set out (i * 2) (to_h up); 45 | Bytes.set out (i * 2 + 1) (to_h low); 46 | done; 47 | Bytes.to_string out 48 | 49 | let sha256 data = 50 | let check = Digestif.SHA256.(to_raw_string (digest_string data)) in 51 | to_hex check 52 | end 53 | 54 | module NC_V = Conex_verify.Make (V) 55 | 56 | module C = struct 57 | 58 | type t = 59 | Conex_resource.identifier * Conex_resource.timestamp * Mirage_crypto_pk.Rsa.priv 60 | 61 | let created (_, ts, _) = ts 62 | 63 | let id (id, _, _) = id 64 | 65 | let decode_priv id ts data = 66 | Result.fold 67 | ~ok:(function 68 | | `RSA priv -> Ok (id, ts, priv) 69 | | _ -> Error "only RSA keys supported") 70 | ~error:(function `Msg e -> Error e) 71 | (X509.Private_key.decode_pem data) 72 | 73 | let encode_priv priv = 74 | X509.Private_key.encode_pem (`RSA priv) 75 | 76 | let pub_of_priv_rsa_raw key = 77 | let pub = Mirage_crypto_pk.Rsa.pub_of_priv key in 78 | V.encode_key pub 79 | 80 | let generate_rsa ?(bits = 4096) () = 81 | let key = Mirage_crypto_pk.Rsa.generate ~bits () in 82 | encode_priv key, pub_of_priv_rsa_raw key 83 | 84 | let bits (_, _, k) = Mirage_crypto_pk.Rsa.priv_bits k 85 | 86 | let pub_of_priv_rsa (_, _, k) = pub_of_priv_rsa_raw k 87 | 88 | let sign_pss (_, _, key) data = 89 | let signature = V.Pss_sha256.sign ~key (`Message data) in 90 | Ok (Base64.encode_string signature) 91 | 92 | let sha256 = V.sha256 93 | end 94 | -------------------------------------------------------------------------------- /mirage-crypto/conex_mirage_crypto.mli: -------------------------------------------------------------------------------- 1 | (** Crypto provided by the mirage-crypto package *) 2 | 3 | module V : Conex_verify.S_RSA_BACK 4 | 5 | module NC_V : Conex_verify.S 6 | 7 | module C : Conex_private.S_RSA_BACK 8 | -------------------------------------------------------------------------------- /mirage-crypto/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name conex_mirage_crypto) 3 | (public_name conex-mirage-crypto) 4 | (wrapped false) 5 | (instrumentation (backend bisect_ppx)) 6 | (libraries conex x509 mirage-crypto-pk base64 digestif)) 7 | -------------------------------------------------------------------------------- /openssl/conex_openssl.ml: -------------------------------------------------------------------------------- 1 | 2 | (* why we have base64 here? well, OpenSSL seems to not be able to do base64 correctly 3 | 4 | command: echo -n 6w== | openssl base64 -d 5 | output: 6 | exit-code: 0 7 | 8 | command: echo 6w== | openssl base64 -d | hexdump 9 | output: 00eb 10 | exit-code: 0 11 | 12 | We could depend on base64/b64decode/..., but that's too much of a hassle. 13 | Instead, we ship a B64 decoder. *) 14 | module B64 = struct 15 | (* decoder from https://github.com/mirage/ocaml-base64, 16 | added checks when padding may occur to bail out early 17 | *) 18 | (* 19 | * Copyright (c) 2006-2009 Citrix Systems Inc. 20 | * Copyright (c) 2010 Thomas Gazagnaire 21 | * 22 | * Permission to use, copy, modify, and distribute this software for any 23 | * purpose with or without fee is hereby granted, provided that the above 24 | * copyright notice and this permission notice appear in all copies. 25 | * 26 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 27 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 28 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 29 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 30 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 31 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 32 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 33 | * 34 | *) 35 | 36 | let default_alphabet = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/" 37 | let padding = '=' 38 | 39 | let of_char ?(alphabet=default_alphabet) may x = 40 | if may && x = padding then 0 else String.index alphabet x 41 | 42 | let decode ?alphabet input = 43 | let length = String.length input in 44 | let input = 45 | if length mod 4 = 0 then input 46 | else input ^ (String.make (4 - length mod 4) padding) 47 | in 48 | let words = length / 4 in 49 | let padding = 50 | match length with 51 | | 0 -> 0 52 | | _ when input.[length - 2] = padding -> 2 53 | | _ when input.[length - 1] = padding -> 1 54 | | _ -> 0 55 | in 56 | let output = Bytes.make (words * 3 - padding) '\000' in 57 | let may_pad i idx = i = words - 1 && idx >= padding in 58 | for i = 0 to words - 1 do 59 | let a = of_char ?alphabet (may_pad i 0) (String.get input (4 * i + 0)) 60 | and b = of_char ?alphabet (may_pad i 1) (String.get input (4 * i + 1)) 61 | and c = of_char ?alphabet (may_pad i 2) (String.get input (4 * i + 2)) 62 | and d = of_char ?alphabet (may_pad i 3) (String.get input (4 * i + 3)) in 63 | let n = (a lsl 18) lor (b lsl 12) lor (c lsl 6) lor d in 64 | let x = (n lsr 16) land 255 65 | and y = (n lsr 8) land 255 66 | and z = n land 255 in 67 | Bytes.set output (3 * i + 0) (char_of_int x); 68 | if i <> words - 1 || padding < 2 then 69 | Bytes.set output (3 * i + 1) (char_of_int y); 70 | if i <> words - 1 || padding < 1 then 71 | Bytes.set output (3 * i + 2) (char_of_int z); 72 | done; 73 | Bytes.unsafe_to_string output 74 | end 75 | 76 | open Conex_utils 77 | 78 | let ( let* ) = Result.bind 79 | 80 | module V = struct 81 | 82 | (* good OpenSSL versions: 83 | "OpenSSL 1.0.2g 1 Mar 2016" ; Ubuntu at cl.cam 84 | "OpenSSL 1.0.2j-freebsd 26 Sep 2016" ; FreeBSD 11 & -CURRENT 85 | "OpenSSL 1.0.1e 11 Feb 2013" ; debian 7.11 86 | "OpenSSL 1.0.1t" ; mindy 87 | "OpenSSL 1.0.2j-fips 26 Sep 2016" ; fedora qubes vm 88 | "OpenSSL 1.0.0u-dev" ; ln5 89 | "OpenSSL 1.0.1 14 Mar 2012" ; Travis CI 90 | "OpenSSL 1.0.0g" ; reynir 91 | 92 | bad ones (no PSS): 93 | "OpenSSL 0.9.8zh-freebsd 3 Dec 2015" ; FreeBSD 9.3 94 | "OpenSSL 0.9.8o 01 Jun 2010" ; debian 6.0.10 95 | "OpenSSL 0.9.8k" ; reynir 96 | *) 97 | 98 | let check_version () = 99 | let cmd = "openssl version" in 100 | let input = Unix.open_process_in cmd in 101 | let output = input_line input in 102 | let _ = Unix.close_process_in input in 103 | if String.is_prefix ~prefix:"OpenSSL 0." output then 104 | Error ("need at least OpenSSL 1.0.0(u?), found: " ^ output) 105 | else 106 | Ok () 107 | 108 | let verify_rsa_pss ~key ~data ~signature id = 109 | let* signature = 110 | try Ok (B64.decode signature) with _ -> Error (`InvalidBase64Encoding id) 111 | in 112 | Result.map_error (function 113 | | "broken" -> `InvalidSignature id 114 | | _ -> `InvalidPublicKey id) 115 | (let filename = Filename.temp_file "conex" "sig" in 116 | let* () = Conex_unix_persistency.write_replace (filename ^ ".key") key in 117 | let* () = Conex_unix_persistency.write_replace (filename ^ ".txt") data in 118 | let* () = Conex_unix_persistency.write_replace (filename ^ ".sig") signature in 119 | let cmd = Printf.sprintf "openssl dgst -sha256 -verify %s.key -sigopt rsa_padding_mode:pss -signature %s.sig %s.txt > /dev/null" filename filename filename in 120 | let res = if 0 = Sys.command cmd then Ok () else Error "broken" in 121 | let _ = Conex_unix_persistency.remove (filename ^ ".txt") 122 | and _ = Conex_unix_persistency.remove (filename ^ ".key") 123 | and _ = Conex_unix_persistency.remove (filename ^ ".sig") 124 | and _ = Conex_unix_persistency.remove filename 125 | in 126 | res) 127 | 128 | (* TODO we may need another sha256 which takes a filename to avoid 129 | reading file X, writing file Y, sha256 Y, removing file Y 130 | and instead doing sha256 X directly! *) 131 | let sha256 data = 132 | Result.fold 133 | ~ok:Fun.id 134 | ~error:(fun e -> invalid_arg e) 135 | (let filename = Filename.temp_file "conex" "b64" in 136 | let* () = Conex_unix_persistency.write_replace filename data in 137 | let cmd = Printf.sprintf "openssl dgst -hex -r -sha256 %s | cut -d ' ' -f 1" filename in 138 | (* let cmd = Printf.sprintf "sha256 -q %s" filename in *) 139 | let input = Unix.open_process_in cmd in 140 | let output = input_line input in 141 | let _ = Unix.close_process_in input in 142 | let _ = Conex_unix_persistency.remove filename in 143 | Ok output) 144 | end 145 | 146 | module O_V = Conex_verify.Make (V) 147 | -------------------------------------------------------------------------------- /openssl/conex_openssl.mli: -------------------------------------------------------------------------------- 1 | (** Verification crypto provided by the OpenSSL command line tool *) 2 | 3 | module V : sig 4 | 5 | (** [check_openssl ()] checks the openssl version (required: >= 1.0.0). *) 6 | val check_version : unit -> (unit, string) result 7 | 8 | include Conex_verify.S_RSA_BACK 9 | end 10 | 11 | (** The instantiaed verify module *) 12 | module O_V : (Conex_verify.S) 13 | -------------------------------------------------------------------------------- /openssl/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name conex_openssl) 3 | (public_name conex.openssl) 4 | (wrapped false) 5 | (instrumentation (backend bisect_ppx)) 6 | (libraries conex unix conex_unix)) 7 | -------------------------------------------------------------------------------- /src/conex.ml: -------------------------------------------------------------------------------- 1 | open Conex_utils 2 | open Conex_resource 3 | 4 | module IO = Conex_io 5 | 6 | let ( let* ) = Result.bind 7 | 8 | module Make (L : LOGS) (C : Conex_verify.S) = struct 9 | 10 | let valid_ids valid sigs = 11 | Digest_map.fold (fun dgst id acc -> 12 | if valid dgst id 13 | then S.add id acc 14 | else begin 15 | L.info (fun m -> m "%a (%a) is not a valid root key" 16 | pp_id id Digest.pp dgst) ; 17 | acc 18 | end) 19 | sigs S.empty 20 | 21 | let verify_root ?(valid = fun _ _ -> false) ?quorum io filename = 22 | L.debug (fun m -> m "verifying root: %a" pp_name filename) ; 23 | let* root, warn = err_to_str IO.pp_r_err (IO.read_root io filename) in 24 | List.iter (fun msg -> L.warn (fun m -> m "%s" msg)) warn ; 25 | (* verify signatures *) 26 | let sigs, errs = 27 | C.verify (Root.wire_raw root) root.Root.keys root.Root.signatures 28 | in 29 | List.iter (fun e -> L.warn (fun m -> m "%a" Conex_verify.pp_error e)) errs ; 30 | (* need to unique over keyids *) 31 | let ids = valid_ids valid sigs in 32 | let quorum_satisfied = 33 | Option.fold ~none:true ~some:(fun q -> q <= S.cardinal ids) quorum 34 | in 35 | match 36 | Expression.eval root.Root.valid Digest_map.empty ids, 37 | quorum_satisfied 38 | with 39 | | true, true -> Ok (Conex_repository.create root) 40 | | false, _ -> Error "couldn't validate root role" 41 | | _, false -> Error "provided quorum was not matched" 42 | 43 | let verify_timestamp ?id io repo ~timestamp_expiry ~now = 44 | L.debug (fun m -> m "verifying timestamp") ; 45 | let* r = Conex_repository.timestamp repo in 46 | let read_and_verify id = 47 | let* ts, warn = err_to_str IO.pp_r_err (IO.read_timestamp io id) in 48 | List.iter (fun w -> L.warn (fun m -> m "%s" w)) warn ; 49 | let sigs, es = 50 | Timestamp.(C.verify (wire_raw ts) ts.keys ts.signatures) 51 | in 52 | List.iter (fun e -> L.warn (fun m -> m "%a" Conex_verify.pp_error e)) es ; 53 | Ok (ts, sigs) 54 | in 55 | let validate_with_root (id, dgst, epoch) ts sigs = 56 | match Digest_map.find_opt dgst sigs with 57 | | None -> Error "couldn't validate timestamp signature" 58 | | Some id' -> 59 | match id_equal id id', Uint.compare epoch ts.Timestamp.epoch = 0 with 60 | | false, _ -> 61 | L.warn (fun m -> m "delegated public key was not used for signature on timestamp"); 62 | Error "no valid signature on timestamp" 63 | | true, false -> 64 | L.warn (fun m -> m "timestamp epoch mismatch: root %a, timestamp %a" 65 | Uint.pp epoch Uint.pp ts.Timestamp.epoch); 66 | Error "timestamp with bad epoch" 67 | | true, true -> 68 | begin match 69 | timestamp_to_int64 ts.Timestamp.created, 70 | timestamp_to_int64 now 71 | with 72 | | Ok ts_sec, Ok now_sec -> 73 | if ts_sec > now_sec then 74 | L.warn (fun m -> m "timestamp is in the future (%s, now %s)" 75 | ts.Timestamp.created now); 76 | if ts_sec <= Int64.add now_sec timestamp_expiry then 77 | Ok (Some ts) 78 | else 79 | (L.warn (fun m -> m "timestamp is invalid (%s, now %s)" 80 | ts.Timestamp.created now); 81 | Error "timestamp is no longer valid") 82 | | Error _ as e, _ | _, (Error _ as e) -> 83 | L.warn (fun m -> m "error converting some timestamp %s or %s" 84 | ts.Timestamp.created now); 85 | e 86 | end 87 | in 88 | match r, id with 89 | | None, None -> 90 | L.warn (fun m -> m "no timestamp role found in root, and no ID provided") ; 91 | Ok None 92 | | Some (id, _, _), Some id' when not (id_equal id id') -> 93 | L.warn (fun m -> m "ID mismatch: timestamp in root %a, provided %a, \ 94 | using %a and not validating against root" 95 | pp_id id pp_id id' pp_id id') ; 96 | let* ts, _ = read_and_verify id' in 97 | Ok (Some ts) 98 | | Some (id, dgst, epoch), _ -> 99 | let* ts, sigs = read_and_verify id in 100 | validate_with_root (id, dgst, epoch) ts sigs 101 | | None, Some id -> 102 | L.warn (fun m -> m "no timestamp role found in root") ; 103 | let* ts, _ = read_and_verify id in 104 | Ok (Some ts) 105 | 106 | let verify_snapshot ?timestamp ?id io repo = 107 | L.debug (fun m -> m "verifying timestamp") ; 108 | let* r = Conex_repository.snapshot repo in 109 | let read_and_verify id = 110 | let* snap, warn = err_to_str IO.pp_r_err (IO.read_snapshot io id) in 111 | List.iter (fun w -> L.warn (fun m -> m "%s" w)) warn ; 112 | let sigs, es = 113 | Snapshot.(C.verify (wire_raw snap) snap.keys snap.signatures) 114 | in 115 | List.iter (fun e -> L.warn (fun m -> m "%a" Conex_verify.pp_error e)) es ; 116 | Ok (snap, sigs) 117 | in 118 | let validate_with_root (id, dgst, epoch) snap sigs = 119 | match Digest_map.find_opt dgst sigs with 120 | | None -> Error "couldn't validate snapshot signature" 121 | | Some id' -> 122 | match id_equal id id', Uint.compare epoch snap.Snapshot.epoch = 0 with 123 | | false, _ -> 124 | L.warn (fun m -> m "delegated public key was not used for signature on snapshot"); 125 | Error "no valid signature on snapshot" 126 | | true, false -> 127 | L.warn (fun m -> m "snapshot epoch mismatch: root %a, snapshot %a" 128 | Uint.pp epoch Uint.pp snap.Snapshot.epoch); 129 | Error "snapshot with bad epoch" 130 | | true, true -> 131 | begin match timestamp with 132 | | None -> 133 | L.warn (fun m -> m "no timestamp provided, taking snapshot as is"); 134 | Ok (Some snap) 135 | | Some ts -> 136 | let* tgt = 137 | let snap_path = Conex_repository.keydir repo @ [ id ] in 138 | IO.compute_checksum_file io C.raw_digest snap_path 139 | in 140 | if List.exists (Target.equal tgt) ts.Timestamp.targets then 141 | Ok (Some snap) 142 | else 143 | Error "couldn't validate snapshot: no match in timestamp target" 144 | end 145 | in 146 | match r, id with 147 | | None, None -> 148 | L.warn (fun m -> m "no snapshot role found in root and none provided") ; 149 | Ok None 150 | | Some (id, _, _), Some id' when not (id_equal id id') -> 151 | L.warn (fun m -> m "ID mismatch: snapshot in root %a, provided %a, \ 152 | using %a and not validating against root" 153 | pp_id id pp_id id' pp_id id') ; 154 | let* snap, _ = read_and_verify id' in 155 | Ok (Some snap) 156 | | Some (id, dgst, epoch), _ -> 157 | let* snap, sigs = read_and_verify id in 158 | validate_with_root (id, dgst, epoch) snap sigs 159 | | None, Some id -> 160 | L.warn (fun m -> m "no snapshot role found in root") ; 161 | let* snap, _ = read_and_verify id in 162 | Ok (Some snap) 163 | 164 | let targets_cache = ref M.empty 165 | 166 | let verify_targets ?snapshot io repo opam id = 167 | L.debug (fun m -> m "verifying target %a" pp_id id) ; 168 | match M.find_opt id !targets_cache with 169 | | Some targets -> 170 | L.debug (fun m -> m "found in cache") ; 171 | Ok targets 172 | | None -> 173 | let root = Conex_repository.root repo in 174 | let* targets, warn = 175 | err_to_str IO.pp_r_err (IO.read_targets io root opam id) 176 | in 177 | List.iter (fun msg -> L.warn (fun m -> m "%s" msg)) warn ; 178 | let* () = match snapshot with 179 | | None -> Ok () 180 | | Some snap -> 181 | let path = Conex_repository.keydir repo @ [ id ] in 182 | let* tgt = IO.compute_checksum_file io C.raw_digest path in 183 | if List.exists (Target.equal tgt) snap.Snapshot.targets then 184 | Ok () 185 | else 186 | let msg = 187 | "couldn't validate target " ^ id ^ ": no match in snapshot targets" 188 | in 189 | Error msg 190 | in 191 | let sigs, es = 192 | Targets.(C.verify (wire_raw targets) targets.keys targets.signatures) 193 | in 194 | List.iter (fun e -> L.warn (fun m -> m "%a" Conex_verify.pp_error e)) es ; 195 | let s = Digest_map.fold (fun _ id acc -> S.add id acc) sigs S.empty in 196 | (* assumes that expression is valid using only target-local (keys and) signatures! *) 197 | if Expression.eval targets.Targets.valid Digest_map.empty s then begin 198 | targets_cache := M.add id targets !targets_cache ; 199 | Ok targets 200 | end else 201 | Error ("couldn't validate expression in targets " ^ id) 202 | 203 | let compare_with_disk ignore_missing io repo = 204 | let non_strict_res = function 205 | | `Only_on_disk p -> 206 | (* we have sth like foo/foo.0/, and check that targets doesn't 207 | have anything in foo/ *) 208 | begin match p with 209 | | [] -> L.warn (fun m -> m "shouldn't happen, empty path") ; false (* unclear, should not happen *) 210 | | pkg::_ -> not (Tree.(is_empty (sub [pkg] (Conex_repository.targets repo)))) 211 | end 212 | | _ -> true 213 | in 214 | let* on_disk = IO.compute_checksum_tree io C.raw_digest in 215 | let errs = Conex_repository.validate_targets repo on_disk in 216 | List.iter (fun r -> 217 | L.warn (fun m -> m "%a" Conex_repository.pp_res r)) 218 | errs ; 219 | match ignore_missing, errs with 220 | | _, [] -> Ok () 221 | | false, _ -> Error "comparison failed" 222 | | true, _ -> match List.filter non_strict_res errs with 223 | | [] -> Ok () 224 | | _ -> Error "non-strict comparison failed" 225 | 226 | let collect_targets ?snapshot io repo opam keyrefs = 227 | M.fold (fun id (dgst, epoch) (dm, id_d, targets) -> 228 | match verify_targets ?snapshot io repo opam id with 229 | | Error msg -> 230 | L.warn (fun m -> m "couldn't load or verify target %a: %s" pp_id id msg) ; 231 | (dm, id_d, targets) 232 | | Ok target -> 233 | let keys = 234 | M.fold (fun id key m -> M.add id (Key.to_string key) m) 235 | target.Targets.keys M.empty 236 | in 237 | match Expression.hash C.raw_digest keys target.Targets.valid with 238 | | Error e -> 239 | L.warn (fun m -> m "%s" e) ; 240 | (dm, id_d, targets) 241 | | Ok valid_h -> 242 | if 243 | Uint.compare target.Targets.epoch epoch = 0 && 244 | Digest.equal valid_h dgst 245 | then 246 | (* now we add as _id_ (of our keyref) the epoch and dgst to dm *) 247 | let id_d' = M.add id (dgst, epoch) id_d in 248 | (Digest_map.add dgst (id, epoch) dm, id_d', target :: targets) 249 | else begin 250 | L.warn (fun m -> m "dropping %a since epoch (%a vs %a) or digest mismatch" 251 | pp_id id Uint.pp epoch Uint.pp target.Targets.epoch) ; 252 | (dm, id_d, targets) 253 | end) 254 | keyrefs (Digest_map.empty, M.empty, []) 255 | 256 | let verify_one ?snapshot io repo opam path expr terminating = 257 | let keyrefs = Expression.keys M.empty expr in 258 | let dm, id_d, targets = collect_targets ?snapshot io repo opam keyrefs in 259 | if Expression.eval expr dm S.empty then begin 260 | let tree = Conex_repository.targets repo in 261 | let tree' = Conex_repository.collect_and_validate_targets ~tree id_d path expr targets in 262 | let repo' = Conex_repository.with_targets repo tree' in 263 | let delegations = 264 | if terminating then begin 265 | L.debug (fun m -> m "terminating delegation, not inspecting further") ; 266 | [] 267 | end else 268 | Conex_repository.collect_and_validate_delegations id_d path expr targets 269 | in 270 | (repo', delegations) 271 | end else begin 272 | let pp_id_ep ppf (id, epoch) = Format.fprintf ppf "%a (#%s)" pp_id id (Uint.to_string epoch) in 273 | L.warn (fun m -> m "expression %a does not eval to true with %a" 274 | Expression.pp expr (Digest_map.pp pp_id_ep) dm) ; 275 | (repo, []) 276 | end 277 | 278 | let verify ?(ignore_missing = false) ?snapshot io repo opam = 279 | let* expr, term, supp = 280 | Option.to_result ~none:"no delegation for maintainers" 281 | (Conex_repository.maintainer_delegation repo) 282 | in 283 | (* queue is mutable, not thread safe, raises on pop when empty 284 | - it does not leave the scope here 285 | - pop is guarded by the is_empty *) 286 | let q = Queue.create () in 287 | (* termination argument is tricky here, but: 288 | - delegations may delegate (unless terminating = true) any subpath 289 | (subpath ~parent:p p is false forall p!) 290 | - maybe path should be limited in length (2?3?) 291 | *) 292 | (* TODO: if snapshot is provided, ensure all targets of snap are present (!?) *) 293 | let rec process_delegation repo = 294 | if Queue.is_empty q 295 | then repo 296 | else begin 297 | let (path, expr, terminating, _supp) = Queue.pop q in 298 | let repo', dels = verify_one ?snapshot io repo opam path expr terminating in 299 | List.iter (fun (p, e, t, s) -> 300 | L.debug (fun m -> m "pushing delegation path %a expr %a terminating %b s %a" 301 | pp_path p Expression.pp e t S.pp s) ; 302 | Queue.push (p, e, t, s) q) 303 | dels ; 304 | process_delegation repo' 305 | end 306 | in 307 | Queue.push (root, expr, term, supp) q ; 308 | let repo' = process_delegation repo in 309 | let pp_t ppf (dgst, len, s) = 310 | Format.fprintf ppf "digest %a len %s supporters %a@." 311 | Digest.pp dgst (Uint.decimal len) S.pp s 312 | in 313 | L.debug (fun m -> m "end of verification, targets tree is %a" 314 | (Tree.pp pp_t) (Conex_repository.targets repo')) ; 315 | compare_with_disk ignore_missing io repo' 316 | 317 | let verify_diffs root io newio diffs opam = 318 | let* old_root, warn = err_to_str IO.pp_r_err (IO.read_root io root) in 319 | List.iter (fun msg -> L.warn (fun m -> m "%s" msg)) warn ; 320 | let* new_root, warn' = err_to_str IO.pp_r_err (IO.read_root newio root) in 321 | List.iter (fun msg -> L.warn (fun m -> m "%s" msg)) warn' ; 322 | let* () = 323 | guard (path_equal old_root.Root.keydir new_root.Root.keydir) 324 | "old and new key directories are differrent" 325 | in 326 | let* r, ids = Conex_diff.ids root new_root.Root.keydir diffs in 327 | L.debug (fun m -> m "root is modified? %b, ids %a" r S.pp ids) ; 328 | let* () = 329 | match Uint.compare old_root.Root.counter new_root.Root.counter with 330 | | 0 when r -> Error "root counter same, expected to increase" 331 | | 0 (* when not r *) -> Ok () 332 | | x when x > 0 -> Error "root counter decremented" 333 | | _ (* when x < 0 *) -> Ok () 334 | in 335 | S.fold (fun id acc -> 336 | let* () = acc in 337 | match IO.read_targets io old_root opam id, IO.read_targets newio new_root opam id with 338 | | Error _, Ok _ -> Ok () 339 | | Error _, Error e -> err_to_str IO.pp_r_err (Error e) 340 | | Ok _, Error e -> err_to_str IO.pp_r_err (Error e) (* TODO allow delete? *) 341 | | Ok (t, _), Ok (t', _) -> 342 | match 343 | Uint.compare t.Targets.epoch t'.Targets.epoch, 344 | Uint.compare t.Targets.counter t'.Targets.counter 345 | with 346 | | 0, 0 -> Error ("counter and epoch of " ^ id ^ " same") 347 | | 0, y when y > 0 -> Error ("counter of " ^ id ^ " is moving backwards") 348 | | 0, _ (* when y < 0 *) -> Ok () 349 | | x, _ when x < 0 -> Ok () 350 | | _, _ (* when x > 0 *) -> Error ("epoch of " ^ id ^ " is moving backwards")) 351 | ids (Ok ()) 352 | end 353 | -------------------------------------------------------------------------------- /src/conex.mli: -------------------------------------------------------------------------------- 1 | (** Establish trust in community repositories 2 | 3 | Conex is a library to verify and attest package release integrity and 4 | authenticity through the use of cryptographic signatures. 5 | 6 | Each author cryptographically signs a list of resources (own public key, 7 | package releases) they vouch for. The {{!Conex_repository.t}repository} is 8 | a map where resource digests are the key, and the set of warrantors the 9 | value. Verification of the signature is done via 10 | {{!Conex_verify.S.verify}verify}. 11 | 12 | Given a {{!Conex_utils.LOGS}logs} and a {{!Conex_verify.S}verify} 13 | implementation, this modules provides functionality to verify identities and 14 | packages. All functions require {{!Conex_io.t}IO} explicitly. 15 | 16 | {e %%VERSION%% - {{:%%PKG_HOMEPAGE%% }homepage}} *) 17 | 18 | 19 | open Conex_utils 20 | open Conex_resource 21 | 22 | module Make (L : LOGS) (C : Conex_verify.S): sig 23 | 24 | val verify_root : ?valid:(Digest.t -> identifier -> bool) -> 25 | ?quorum : int -> Conex_io.t -> name -> (Conex_repository.t, string) result 26 | 27 | val verify_timestamp : ?id:identifier -> Conex_io.t -> Conex_repository.t -> 28 | timestamp_expiry:int64 -> now:string -> (Timestamp.t option, string) result 29 | 30 | val verify_snapshot : ?timestamp:Timestamp.t -> ?id:identifier -> 31 | Conex_io.t -> Conex_repository.t -> (Snapshot.t option, string) result 32 | 33 | val verify_targets : ?snapshot:Snapshot.t -> Conex_io.t -> 34 | Conex_repository.t -> bool -> identifier -> (Targets.t, string) result 35 | 36 | val verify : ?ignore_missing:bool -> ?snapshot:Snapshot.t -> Conex_io.t -> 37 | Conex_repository.t -> bool -> (unit, string) result 38 | 39 | val verify_diffs : string -> Conex_io.t -> Conex_io.t -> Conex_diff.t list -> bool -> 40 | (unit, string) result 41 | end 42 | -------------------------------------------------------------------------------- /src/conex_diff.ml: -------------------------------------------------------------------------------- 1 | open Conex_utils 2 | 3 | type hunk = { 4 | mine_start : int ; 5 | mine_len : int ; 6 | mine : string list ; 7 | their_start : int ; 8 | their_len : int ; 9 | their : string list ; 10 | } 11 | 12 | let unified_diff hunk = 13 | (* TODO *) 14 | String.concat "\n" (List.map (fun line -> "-" ^ line) hunk.mine @ 15 | List.map (fun line -> "+" ^ line) hunk.their) 16 | 17 | let pp_hunk ppf hunk = 18 | Format.fprintf ppf "@@@@ -%d,%d +%d,%d @@@@\n%s" 19 | hunk.mine_start hunk.mine_len hunk.their_start hunk.their_len 20 | (unified_diff hunk) 21 | [@@coverage off] 22 | 23 | let take data num = 24 | let rec take0 num data acc = 25 | match num, data with 26 | | 0, _ -> List.rev acc 27 | | n, x::xs -> take0 (pred n) xs (x :: acc) 28 | | _ -> invalid_arg "take0 broken" 29 | in 30 | take0 num data [] 31 | 32 | let drop data num = 33 | let rec drop data num = 34 | match num, data with 35 | | 0, _ -> data 36 | | n, _::xs -> drop xs (pred n) 37 | | _ -> invalid_arg "drop broken" 38 | in 39 | try drop data num with 40 | | Invalid_argument _ -> invalid_arg ("drop " ^ string_of_int num ^ " on " ^ string_of_int (List.length data)) 41 | 42 | (* TODO verify that it applies cleanly *) 43 | let apply_hunk old (index, to_build) hunk = 44 | try 45 | let prefix = take (drop old index) (hunk.mine_start - index) in 46 | (hunk.mine_start + hunk.mine_len, to_build @ prefix @ hunk.their) 47 | with 48 | | Invalid_argument _ -> invalid_arg ("apply_hunk " ^ string_of_int index ^ " old len " ^ string_of_int (List.length old) ^ 49 | " hunk start " ^ string_of_int hunk.mine_start ^ " hunk len " ^ string_of_int hunk.mine_len) 50 | 51 | let to_start_len data = 52 | (* input being "?19,23" *) 53 | match String.cut ',' (String.slice ~start:1 data) with 54 | | None when data = "+1" || data = "-1" -> (0, 1) 55 | | None -> invalid_arg ("start_len broken in " ^ data) 56 | | Some (start, len) -> 57 | let len = int_of_string len 58 | and start = int_of_string start 59 | in 60 | let st = if len = 0 || start = 0 then start else pred start in 61 | (st, len) 62 | 63 | let count_to_sl_sl data = 64 | if String.is_prefix ~prefix:"@@" data then 65 | (* input: "@@ -19,23 +19,12 @@ bla" *) 66 | (* output: ((19,23), (19, 12)) *) 67 | match List.filter (function "" -> false | _ -> true) (String.cuts '@' data) with 68 | | numbers::_ -> 69 | let nums = String.trim numbers in 70 | (match String.cut ' ' nums with 71 | | None -> invalid_arg "couldn't find space in count" 72 | | Some (mine, theirs) -> Some (to_start_len mine, to_start_len theirs)) 73 | | _ -> invalid_arg "broken line!" 74 | else 75 | None 76 | 77 | let sort_into_bags dir mine their m_nl t_nl str = 78 | if String.length str = 0 then 79 | None 80 | else if String.is_prefix ~prefix:"---" str then 81 | None 82 | else match String.get str 0, String.slice ~start:1 str with 83 | | ' ', data -> Some (`Both, (data :: mine), (data :: their), m_nl, t_nl) 84 | | '+', data -> Some (`Their, mine, (data :: their), m_nl, t_nl) 85 | | '-', data -> Some (`Mine, (data :: mine), their, m_nl, t_nl) 86 | | '\\', data -> 87 | (* diff: 'No newline at end of file' turns out to be context-sensitive *) 88 | (* so: -xxx\n\\No newline... means mine didn't have a newline *) 89 | (* but +xxx\n\\No newline... means theirs doesn't have a newline *) 90 | assert (data = " No newline at end of file"); 91 | let my_nl, their_nl = match dir with 92 | | `Both -> true, true 93 | | `Mine -> true, t_nl 94 | | `Their -> m_nl, true 95 | in 96 | Some (dir, mine, their, my_nl, their_nl) 97 | | _ -> None 98 | 99 | let to_hunk count data mine_no_nl their_no_nl = 100 | match count_to_sl_sl count with 101 | | None -> None, mine_no_nl, their_no_nl, count :: data 102 | | Some ((mine_start, mine_len), (their_start, their_len)) -> 103 | let rec step dir mine their mine_no_nl their_no_nl = function 104 | | [] -> (List.rev mine, List.rev their, mine_no_nl, their_no_nl, []) 105 | | x::xs -> match sort_into_bags dir mine their mine_no_nl their_no_nl x with 106 | | Some (dir, mine, their, mine_no_nl', their_no_nl') -> step dir mine their mine_no_nl' their_no_nl' xs 107 | | None -> (List.rev mine, List.rev their, mine_no_nl, their_no_nl, x :: xs) 108 | in 109 | let mine, their, mine_no_nl, their_no_nl, rest = step `Both [] [] mine_no_nl their_no_nl data in 110 | (Some { mine_start ; mine_len ; mine ; their_start ; their_len ; their }, mine_no_nl, their_no_nl, rest) 111 | 112 | let rec to_hunks (mine_no_nl, their_no_nl, acc) = function 113 | | [] -> (List.rev acc, mine_no_nl, their_no_nl, []) 114 | | count::data -> match to_hunk count data mine_no_nl their_no_nl with 115 | | None, mine_no_nl, their_no_nl, rest -> List.rev acc, mine_no_nl, their_no_nl, rest 116 | | Some hunk, mine_no_nl, their_no_nl, rest -> to_hunks (mine_no_nl, their_no_nl, hunk :: acc) rest 117 | 118 | type operation = 119 | | Edit of string 120 | | Rename of string * string 121 | | Delete of string 122 | | Create of string 123 | | Rename_only of string * string 124 | 125 | let operation_eq a b = match a, b with 126 | | Edit a, Edit b 127 | | Delete a, Delete b 128 | | Create a, Create b -> String.equal a b 129 | | Rename (a, a'), Rename (b, b') 130 | | Rename_only (a, a'), Rename_only (b, b') -> String.equal a b && String.equal a' b' 131 | | _ -> false 132 | 133 | let no_file = "/dev/null" 134 | 135 | let pp_operation ~git ppf op = 136 | let real_name direction name = 137 | if git then name else 138 | match direction with `Mine -> "a/" ^ name | `Theirs -> "b/" ^ name 139 | in 140 | let hdr mine their = 141 | (* even if create/delete, /dev/null is not used in this header *) 142 | (* according to git documentation *) 143 | if git then 144 | Format.fprintf ppf "diff --git %s %s\n" 145 | (real_name `Mine mine) (real_name `Theirs their) 146 | in 147 | match op with 148 | | Edit name -> 149 | hdr name name ; 150 | Format.fprintf ppf "--- %s\n" (real_name `Mine name) ; 151 | Format.fprintf ppf "+++ %s\n" (real_name `Theirs name) 152 | | Rename (old_name, new_name) -> 153 | hdr old_name new_name ; 154 | Format.fprintf ppf "--- %s\n" (real_name `Mine old_name) ; 155 | Format.fprintf ppf "+++ %s\n" (real_name `Theirs new_name) 156 | | Delete name -> 157 | hdr name name ; 158 | Format.fprintf ppf "--- %s\n" (real_name `Mine name) ; 159 | Format.fprintf ppf "+++ %s\n" no_file 160 | | Create name -> 161 | hdr name name ; 162 | Format.fprintf ppf "--- %s\n" no_file ; 163 | Format.fprintf ppf "+++ %s\n" (real_name `Theirs name) 164 | | Rename_only (old_name, new_name) -> 165 | hdr old_name new_name ; 166 | Format.fprintf ppf "rename from %s\n" old_name; 167 | Format.fprintf ppf "rename to %s\n" new_name 168 | [@@coverage off] 169 | 170 | type t = { 171 | operation : operation ; 172 | hunks : hunk list ; 173 | mine_no_nl : bool ; 174 | their_no_nl : bool ; 175 | } 176 | 177 | let pp ~git ppf t = 178 | pp_operation ~git ppf t.operation ; 179 | List.iter (pp_hunk ppf) t.hunks 180 | [@@coverage off] 181 | 182 | let operation_of_strings git mine their = 183 | let get_filename_opt n = 184 | let s = match String.cut '\t' n with None -> n | Some (x, _) -> x in 185 | if s = no_file then None else 186 | if git && (String.is_prefix ~prefix:"a/" s || String.is_prefix ~prefix:"b/" s) then 187 | Some (String.slice ~start:2 s) 188 | else Some s 189 | in 190 | match get_filename_opt mine, get_filename_opt their with 191 | | None, Some n -> Create n 192 | | Some n, None -> Delete n 193 | | Some a, Some b -> if String.equal a b then Edit a else Rename (a, b) 194 | | None, None -> assert false (* ??!?? *) 195 | 196 | (* parses a list of lines to a diff.t list *) 197 | let to_diff data = 198 | (* first locate --- and +++ lines *) 199 | let rec find_start git ?hdr = function 200 | | [] -> hdr, [] 201 | | x::xs when String.is_prefix ~prefix:"diff --git" x -> 202 | begin match hdr with None -> find_start true xs | Some _ -> hdr, x::xs end 203 | | x::y::xs when String.is_prefix ~prefix:"rename from" x && String.is_prefix ~prefix:"rename to" y -> 204 | let hdr = Rename_only (String.slice ~start:12 x, String.slice ~start:10 y) in 205 | find_start git ~hdr xs 206 | | x::y::xs when String.is_prefix ~prefix:"---" x -> 207 | let mine = String.slice ~start:4 x and their = String.slice ~start:4 y in 208 | Some (operation_of_strings git mine their), xs 209 | | _::xs -> find_start git ?hdr xs 210 | in 211 | match find_start false data with 212 | | Some (Rename_only _ as operation), rest -> 213 | let hunks = [] and mine_no_nl = false and their_no_nl = false in 214 | Some ({ operation ; hunks ; mine_no_nl ; their_no_nl }, rest) 215 | | Some operation, rest -> 216 | let hunks, mine_no_nl, their_no_nl, rest = to_hunks (false, false, []) rest in 217 | Some ({ operation ; hunks ; mine_no_nl ; their_no_nl }, rest) 218 | | None, [] -> None 219 | | None, _ -> assert false 220 | 221 | let to_lines = String.cuts '\n' 222 | 223 | let to_diffs data = 224 | let lines = to_lines data in 225 | let rec doit acc = function 226 | | [] -> List.rev acc 227 | | xs -> match to_diff xs with 228 | | None -> List.rev acc 229 | | Some (diff, rest) -> doit (diff :: acc) rest 230 | in 231 | doit [] lines 232 | 233 | let patch filedata diff = 234 | match diff.operation with 235 | | Rename_only _ -> filedata 236 | | Delete _ -> None 237 | | Create _ -> 238 | begin match diff.hunks with 239 | | [ the_hunk ] -> 240 | let d = the_hunk.their in 241 | let lines = if diff.their_no_nl then d else d @ [""] in 242 | Some (String.concat "\n" lines) 243 | | _ -> assert false 244 | end 245 | | _ -> 246 | let old = match filedata with None -> [] | Some x -> to_lines x in 247 | let idx, lines = List.fold_left (apply_hunk old) (0, []) diff.hunks in 248 | let lines = lines @ drop old idx in 249 | let lines = 250 | match diff.mine_no_nl, diff.their_no_nl with 251 | | false, true -> (match List.rev lines with ""::tl -> List.rev tl | _ -> lines) 252 | | true, false -> lines @ [ "" ] 253 | | false, false when filedata = None -> lines @ [ "" ] 254 | | false, false -> lines 255 | | true, true -> lines 256 | in 257 | Some (String.concat "\n" lines) 258 | 259 | (* TODO which equality to use here? is = ok? *) 260 | let ids root keydir diffs = 261 | let ( let* ) = Result.bind in 262 | List.fold_left (fun acc diff -> 263 | let add_name name (r, ids) = 264 | let* path = string_to_path name in 265 | if subpath ~parent:keydir path then 266 | (* TODO according to here, keydir must be flat! *) 267 | match List.rev path with 268 | | id :: _ -> Ok (r, S.add id ids) 269 | | [] -> Error "empty keydir path?" 270 | else match path with 271 | | [ x ] when x = root -> Ok (true, ids) 272 | | _ -> Ok (r, ids) 273 | in 274 | let* r, ids = acc in 275 | match diff.operation with 276 | | Create a | Delete a | Edit a -> add_name a (r, ids) 277 | | Rename (a, b) | Rename_only (a, b) -> 278 | let* ids' = add_name a (r, ids) in 279 | add_name b ids') 280 | (Ok (false, S.empty)) diffs 281 | -------------------------------------------------------------------------------- /src/conex_diff.mli: -------------------------------------------------------------------------------- 1 | open Conex_utils 2 | 3 | (** Diff: decode patch files into hunks. *) 4 | 5 | (** A hunk *) 6 | type hunk 7 | 8 | val pp_hunk : Format.formatter -> hunk -> unit 9 | 10 | type operation = 11 | | Edit of string 12 | | Rename of string * string 13 | | Delete of string 14 | | Create of string 15 | | Rename_only of string * string 16 | 17 | val pp_operation : git:bool -> Format.formatter -> operation -> unit 18 | 19 | val operation_eq : operation -> operation -> bool 20 | 21 | (** A diff is a list of hunks, and an operation. *) 22 | type t = { 23 | operation : operation ; 24 | hunks : hunk list ; 25 | mine_no_nl : bool ; 26 | their_no_nl : bool ; 27 | } 28 | 29 | val pp : git:bool -> Format.formatter -> t -> unit 30 | 31 | (** [to_diffs str] decodes the given patch into a list of [diff]. *) 32 | val to_diffs : string -> t list 33 | 34 | (** [patch data diff] is [data'], which is the result of applying [diff] to 35 | [data]. If [data'] is [None], it was deleted. *) 36 | val patch : string option -> t -> string option 37 | 38 | (** [ids rootname keydir diffs] returns whether the root file was changed, and 39 | the set of modified ids. *) 40 | val ids : string -> path -> t list -> (bool * S.t, string) result 41 | -------------------------------------------------------------------------------- /src/conex_diff_provider.ml: -------------------------------------------------------------------------------- 1 | open Conex_utils 2 | open Conex_io 3 | open Conex_diff 4 | 5 | (* this a very basic implementation, far from being general: 6 | - only a single (well-formed) patch file is used for creating a diff provider 7 | *) 8 | let target = function 9 | | Edit name 10 | | Rename (_, name) 11 | | Rename_only (_, name) 12 | | Create name -> Some name 13 | | Delete _ -> None 14 | 15 | let source = function 16 | | Rename (old, _) | Rename_only (old, _) | Delete old | Edit old -> Some old 17 | | _ -> None 18 | 19 | module FS = Set.Make(struct 20 | type t = file_type * string 21 | let compare (t, v) (t', v') = match t, t' with 22 | | File, File | Directory, Directory -> String.compare v v' 23 | | File, Directory -> 1 | Directory, File -> -1 24 | end) 25 | 26 | let apply provider diffs = 27 | let find_diff f path = 28 | List.find_opt (fun x -> 29 | match f x.operation with 30 | | None -> false 31 | | Some path' -> path_equal (string_to_path_exn path') path) 32 | diffs 33 | in 34 | let read path = 35 | match find_diff target path, find_diff source path with 36 | | None, None -> provider.read path 37 | | None, Some _ -> Error "no data" 38 | | Some diff, _ -> 39 | let res_patch old = match patch old diff with 40 | | None -> Error "no data" 41 | | Some data -> Ok data 42 | in 43 | match source diff.operation with 44 | | None -> res_patch None 45 | | Some x -> match provider.read (string_to_path_exn x) with 46 | | Error x -> Error x 47 | | Ok data -> res_patch (Some data) 48 | and file_type path = 49 | match find_diff target path, find_diff source path with 50 | | None, None -> provider.file_type path 51 | | None, Some _ -> Error "does not exist anymore (deleted)" 52 | | Some _, _ -> Ok File 53 | and read_dir path = 54 | (* this results in some empty directories which are not present on disk *) 55 | (* the reason is that I get the old files and directories, 56 | I also know the diffs (i.e. added and removed and renamed files), but 57 | for inspecting whether a directory is empty (i.e. all files are removed), 58 | I'd need the whole subdir information (prune empty ones) *) 59 | let old = 60 | Result.fold ~ok:(fun files -> FS.of_list files) ~error:(fun _ -> FS.empty) 61 | (provider.read_dir path) 62 | in 63 | let drop_pre dir path' = 64 | let rec dropit a b = match a, b with 65 | | [], [ x ] -> Some (File, x) 66 | | [], x::_ -> if dir then Some (Directory, x) else None 67 | | x::xs, y::ys when String.equal x y -> dropit xs ys 68 | | _ -> None 69 | in 70 | dropit path (string_to_path_exn path') 71 | and opt_add x xs = Option.fold ~none:xs ~some:(fun x -> FS.add x xs) x 72 | and opt_rem x xs = Option.fold ~none:xs ~some:(fun x -> FS.remove x xs) x 73 | in 74 | let stuff = 75 | List.fold_left (fun acc d -> 76 | match d.operation with 77 | | Create name | Edit name -> opt_add (drop_pre true name) acc 78 | | Rename (old, name) | Rename_only (old, name) -> 79 | opt_rem (drop_pre false old) (opt_add (drop_pre true name) acc) 80 | | Delete old -> opt_rem (drop_pre false old) acc) 81 | old diffs 82 | in 83 | Ok (FS.elements stuff) 84 | and write _ _ = Error "read only" 85 | and exists path = 86 | match find_diff target path, find_diff source path with 87 | | None, None -> provider.exists path 88 | | Some _, _ -> true 89 | | None, Some _ -> false 90 | and basedir = provider.basedir 91 | and description = "Patch provider" 92 | in 93 | { basedir ; description ; file_type ; read ; write ; read_dir ; exists } 94 | 95 | let apply_diff io data = 96 | let diffs = Conex_diff.to_diffs data in 97 | apply io diffs, diffs 98 | -------------------------------------------------------------------------------- /src/conex_diff_provider.mli: -------------------------------------------------------------------------------- 1 | (** Data provider using an existing provider and a diff *) 2 | 3 | val apply : Conex_io.t -> Conex_diff.t list -> Conex_io.t 4 | 5 | val apply_diff : Conex_io.t -> string -> (Conex_io.t * Conex_diff.t list) 6 | -------------------------------------------------------------------------------- /src/conex_io.ml: -------------------------------------------------------------------------------- 1 | open Conex_utils 2 | open Conex_resource 3 | open Conex_opam_encoding 4 | 5 | type t = { 6 | basedir : string ; 7 | description : string ; 8 | file_type : path -> (file_type, string) result ; 9 | read : path -> (string, string) result ; 10 | write : path -> string -> (unit, string) result ; 11 | read_dir : path -> (item list, string) result ; 12 | exists : path -> bool ; 13 | } 14 | 15 | let pp ppf t = 16 | Format.fprintf ppf "repository %s: %s" t.basedir t.description 17 | [@@coverage off] 18 | 19 | let ( let* ) = Result.bind 20 | 21 | type r_err = [ 22 | | `NotFound of typ * name 23 | | `ParseError of typ * name * string 24 | | `NameMismatch of typ * name * name 25 | | `InvalidPath of identifier * path 26 | ] 27 | 28 | let pp_r_err ppf = function 29 | | `NotFound (res, nam) -> Format.fprintf ppf "%a (type %a) was not found in repository" pp_name nam pp_typ res 30 | | `ParseError (res, n, e) -> Format.fprintf ppf "parse error while parsing %a (type %a): %s" pp_name n pp_typ res e 31 | | `NameMismatch (res, should, is) -> Format.fprintf ppf "%a (type %a) is named %a" pp_name should pp_typ res pp_name is 32 | | `InvalidPath (nam, path) -> Format.fprintf ppf "%a contains an invalid path %a" pp_id nam pp_path path 33 | [@@coverage off] 34 | 35 | let read_root t root_file = 36 | Result.fold 37 | ~error:(fun _ -> Error (`NotFound (`Root, root_file))) 38 | ~ok:(fun data -> 39 | Result.fold 40 | ~error:(fun p -> Error (`ParseError (`Root, root_file, p))) 41 | ~ok:(fun (root, warn) -> 42 | let* () = 43 | guard (id_equal root.Root.name root_file) 44 | (`NameMismatch (`Root, root_file, root.Root.name)) 45 | in 46 | Ok (root, warn)) 47 | Result.(join (map Root.of_wire (decode data)))) 48 | (t.read [ root_file ]) 49 | 50 | let write_root t root = 51 | let id = root.Root.name in 52 | t.write [ id ] (encode (Root.wire root)) 53 | 54 | let read_timestamp t timestamp_file = 55 | Result.fold 56 | ~error:(fun _ -> Error (`NotFound (`Timestamp, timestamp_file))) 57 | ~ok:(fun data -> 58 | Result.fold 59 | ~error:(fun p -> Error (`ParseError (`Timestamp, timestamp_file, p))) 60 | ~ok:(fun (timestamp, warn) -> 61 | let* () = 62 | guard (id_equal timestamp.Timestamp.name timestamp_file) 63 | (`NameMismatch (`Timestamp, timestamp_file, timestamp.Timestamp.name)) 64 | in 65 | Ok (timestamp, warn)) 66 | Result.(join (map Timestamp.of_wire (decode data)))) 67 | (t.read [ timestamp_file ]) 68 | 69 | let write_timestamp t timestamp = 70 | let id = timestamp.Timestamp.name in 71 | t.write [ id ] (encode (Timestamp.wire timestamp)) 72 | 73 | let read_snapshot t snapshot_file = 74 | Result.fold 75 | ~error:(fun _ -> Error (`NotFound (`Snapshot, snapshot_file))) 76 | ~ok:(fun data -> 77 | Result.fold 78 | ~error:(fun p -> Error (`ParseError (`Snapshot, snapshot_file, p))) 79 | ~ok:(fun (snap, warn) -> 80 | let* () = 81 | guard (id_equal snap.Snapshot.name snapshot_file) 82 | (`NameMismatch (`Snapshot, snapshot_file, snap.Snapshot.name)) 83 | in 84 | Ok (snap, warn)) 85 | Result.(join (map Snapshot.of_wire (decode data)))) 86 | (t.read [ snapshot_file ]) 87 | 88 | let write_snapshot t snapshot = 89 | let id = snapshot.Snapshot.name in 90 | t.write [ id ] (encode (Snapshot.wire snapshot)) 91 | 92 | let targets t root = 93 | match t.read_dir root.Root.keydir with 94 | | Error e -> 95 | Printf.printf "failed while listing keys with %s\n" e ; 96 | [] 97 | | Ok datas -> 98 | List.fold_left (fun acc -> function 99 | | File, name -> name :: acc 100 | | Directory, name -> 101 | Printf.printf "unexpected directory %s in keydir!" name ; 102 | acc) 103 | [] datas 104 | 105 | let read_targets t root opam id = 106 | let path = root.Root.keydir @ [ id ] in 107 | Result.fold 108 | ~error:(fun _ -> Error (`NotFound (`Targets, id))) 109 | ~ok:(fun data -> 110 | Result.fold 111 | ~error:(fun p -> Error (`ParseError (`Targets, id, p))) 112 | ~ok:(fun (targets, warn) -> 113 | let* () = 114 | guard (id_equal targets.Targets.name id) 115 | (`NameMismatch (`Targets, id, targets.Targets.name)) 116 | in 117 | let check_path t = 118 | if opam then 119 | guard (Target.valid_opam_path t) (`InvalidPath (id, t.Target.filename)) 120 | else 121 | Ok () 122 | in 123 | let* () = iterM check_path targets.Targets.targets in 124 | Ok (targets, warn)) 125 | Result.(join (map Targets.of_wire (decode data)))) 126 | (t.read path) 127 | 128 | let write_targets t root targets = 129 | let path = root.Root.keydir @ [ targets.Targets.name ] in 130 | Printf.printf "writing %s\n" (path_to_string path) ; 131 | t.write path (encode (Targets.wire targets)) 132 | 133 | let digest_len f data = 134 | let digest = f data 135 | and size = Uint.of_int_exn (String.length data) 136 | in 137 | (digest, size) 138 | 139 | let target f filename data = 140 | let digest, size = digest_len f data in 141 | { Target.digest = [ digest ] ; size ; filename } 142 | 143 | let compute_checksum_file t f filename = 144 | let* data = t.read filename in 145 | Ok (target f filename data) 146 | 147 | let compute_checksum ?(prefix = [ "packages" ]) t opam f path = 148 | let rec compute_item prefix acc = function 149 | | Directory, name -> 150 | let path = prefix @ [ name ] in 151 | let* items = t.read_dir path in 152 | foldM (compute_item path) acc items 153 | | File, name -> 154 | let filename = prefix @ [ name ] in 155 | let* target = compute_checksum_file t f filename in 156 | if not opam || opam && Target.valid_opam_path target then 157 | Ok (target :: acc) 158 | else 159 | Error ("invalid path " ^ path_to_string filename) 160 | in 161 | let go pre name = compute_item (prefix @ pre) [] (Directory, name) in 162 | match List.rev path with 163 | | [] -> 164 | let* items = t.read_dir prefix in 165 | foldM (fun acc e -> match e with 166 | | Directory, _ -> compute_item prefix acc e 167 | | File, _ -> Ok acc) 168 | [] items 169 | | [ name ] -> go [] name 170 | | name::rest -> go (List.rev rest) name 171 | 172 | let compute_checksum_tree ?(prefix = [ "packages" ]) t f = 173 | let rec compute_item prefix acc = function 174 | | Directory, name -> 175 | let path = prefix @ [ name ] in 176 | let* items = t.read_dir path in 177 | foldM (compute_item path) acc items 178 | | File, name -> 179 | let filename = prefix @ [ name ] in 180 | let* target = compute_checksum_file t f filename in 181 | Ok (Tree.insert filename (List.hd target.digest, target.size) acc) 182 | in 183 | let* items = t.read_dir prefix in 184 | foldM (compute_item prefix) Tree.empty items 185 | -------------------------------------------------------------------------------- /src/conex_io.mli: -------------------------------------------------------------------------------- 1 | (** IO operations 2 | 3 | Conex relies on providers to read data from and write data to. Each access 4 | consists of a {!path} used as key. Only basic file types are supported (no 5 | symbolic links). 6 | *) 7 | 8 | open Conex_utils 9 | open Conex_resource 10 | 11 | (** {1 IO provider} *) 12 | 13 | (** A provider contains its base directory, a description, and read/write/exist 14 | functionality. TODO: define this as a module type. *) 15 | type t = { 16 | basedir : string ; 17 | description : string ; 18 | file_type : path -> (file_type, string) result ; 19 | read : path -> (string, string) result ; 20 | write : path -> string -> (unit, string) result ; 21 | read_dir : path -> (item list, string) result ; 22 | exists : path -> bool ; 23 | } 24 | 25 | (** [pp t] is a pretty printer for [t]. *) 26 | val pp : t fmt 27 | 28 | (** {1 Reading of resource files} *) 29 | 30 | (** The variant of read and parse errors. *) 31 | type r_err = [ 32 | | `NotFound of typ * name 33 | | `ParseError of typ * name * string 34 | | `NameMismatch of typ * name * name 35 | | `InvalidPath of name * path 36 | ] 37 | 38 | (** [pp_r_err] is a pretty printer for {!r_err}. *) 39 | val pp_r_err : r_err fmt 40 | 41 | val read_root : t -> name -> (Root.t * string list, [> r_err ]) result 42 | 43 | val write_root : t -> Root.t -> (unit, string) result 44 | 45 | val read_timestamp : t -> name -> (Timestamp.t * string list, [> r_err ]) result 46 | 47 | val write_timestamp : t -> Timestamp.t -> (unit, string) result 48 | 49 | val read_snapshot : t -> name -> (Snapshot.t * string list, [> r_err ]) result 50 | 51 | val write_snapshot : t -> Snapshot.t -> (unit, string) result 52 | 53 | val targets : t -> Root.t -> identifier list 54 | 55 | val read_targets : t -> Root.t -> bool -> identifier -> (Targets.t * string list, [> r_err ]) result 56 | 57 | val write_targets : t -> Root.t -> Targets.t -> (unit, string) result 58 | 59 | val compute_checksum_file : t -> (string -> Digest.t) -> path -> 60 | (Target.t, string) result 61 | 62 | val compute_checksum : ?prefix:path -> t -> bool -> (string -> Digest.t) -> path -> 63 | (Target.t list, string) result 64 | 65 | val compute_checksum_tree : ?prefix:path -> t -> (string -> Digest.t) -> 66 | ((Digest.t * Uint.t) Tree.t, string) result 67 | -------------------------------------------------------------------------------- /src/conex_opam_encoding.ml: -------------------------------------------------------------------------------- 1 | open Conex_utils 2 | open Conex_resource 3 | 4 | module OpamParserTypes = OpamParserTypes.FullPos 5 | 6 | let ( let* ) = Result.bind 7 | 8 | let np pelem = 9 | let pos = OpamParserTypes.{ filename = ""; start = (0, 0); stop = (0, 0) } in 10 | OpamParserTypes.{ pelem; pos } 11 | 12 | let rec encode_s x = 13 | np (match x with 14 | | Wire.Map s -> 15 | if s = M.empty then 16 | OpamParserTypes.Ident "emptymap" 17 | else 18 | let data = 19 | np (M.fold (fun k v acc -> 20 | let ele = 21 | OpamParserTypes.(List (np [ np (Ident k) ; encode_s v ])) 22 | in 23 | np ele :: acc) 24 | s []) 25 | in 26 | OpamParserTypes.List data 27 | | Wire.List l -> OpamParserTypes.List (np (List.map encode_s l)) 28 | | Wire.Identifier i -> OpamParserTypes.Ident i 29 | | Wire.Data s -> OpamParserTypes.String s 30 | | Wire.Bigint i -> OpamParserTypes.Ident (Uint.to_string i) 31 | | Wire.Smallint i -> OpamParserTypes.Int i 32 | | Wire.Pair (i, s) -> OpamParserTypes.Group (np [ encode_s i ; encode_s s ]) 33 | | Wire.And (a, b) -> OpamParserTypes.Logop (np `And, encode_s a, encode_s b) 34 | | Wire.Or (a, b) -> OpamParserTypes.Logop (np `Or, encode_s a, encode_s b)) 35 | 36 | let encode t = 37 | let file_contents = 38 | M.fold (fun k v acc -> 39 | np (OpamParserTypes.Variable (np k, encode_s v)) :: acc) 40 | t [] 41 | in 42 | let file = { OpamParserTypes.file_contents ; file_name = "" } in 43 | (* TODO use OpamPrinter.Preserved.items txt orig f here, requires old data *) 44 | OpamPrinter.FullPos.format_opamfile Format.str_formatter file ; 45 | Format.flush_str_formatter () 46 | 47 | let rec decode_s s = 48 | match s.OpamParserTypes.pelem with 49 | | OpamParserTypes.Ident data -> 50 | if String.is_prefix ~prefix:"0x" data then 51 | match Uint.of_string (String.slice ~start:2 data) with 52 | | None -> Error "cannot parse unsigned integer" 53 | | Some x -> Ok (Wire.Bigint x) 54 | else if data = "emptymap" then 55 | Ok (Wire.Map M.empty) 56 | else 57 | Ok (Wire.Identifier data) 58 | | OpamParserTypes.String s -> Ok (Wire.Data (String.trim s)) 59 | | OpamParserTypes.List { OpamParserTypes.pelem = []; _} -> Ok (Wire.List []) 60 | | OpamParserTypes.List { OpamParserTypes.pelem = l; _} -> 61 | let is_pair = function 62 | | { OpamParserTypes.pelem = OpamParserTypes.List { OpamParserTypes.pelem = 63 | [{ OpamParserTypes.pelem = OpamParserTypes.Ident _; _} ; _]; _}; _} -> true 64 | | _ -> false 65 | in 66 | if List.for_all is_pair l then 67 | let* map = 68 | List.fold_left (fun m xs -> 69 | let* m = m in 70 | match xs.OpamParserTypes.pelem with 71 | OpamParserTypes.List { OpamParserTypes.pelem = 72 | [{ OpamParserTypes.pelem = OpamParserTypes.Ident (k); _} ; v ]; _} -> 73 | let* v = decode_s v in 74 | Ok (M.add (String.trim k) v m) 75 | | _ -> Error "can not happen") 76 | (Ok M.empty) l 77 | in 78 | Ok (Wire.Map map) 79 | else 80 | let* xs = 81 | List.fold_left (fun xs s -> 82 | let* xs = xs in 83 | let* x = decode_s s in 84 | Ok (x :: xs)) 85 | (Ok []) l 86 | in 87 | Ok (Wire.List (List.rev xs)) 88 | | OpamParserTypes.Int i -> Ok (Wire.Smallint i) 89 | | OpamParserTypes.Group { OpamParserTypes.pelem = 90 | [{ OpamParserTypes.pelem = OpamParserTypes.Logop (op, a, b); _}]; _} -> 91 | let* a = decode_s a in 92 | let* b = decode_s b in 93 | begin match op.OpamParserTypes.pelem with 94 | | `And -> Ok (Wire.And (a, b)) 95 | | `Or -> Ok (Wire.Or (a, b)) 96 | end 97 | | OpamParserTypes.Logop (op, a, b) -> 98 | let* a = decode_s a in 99 | let* b = decode_s b in 100 | begin match op.OpamParserTypes.pelem with 101 | | `And -> Ok (Wire.And (a, b)) 102 | | `Or -> Ok (Wire.Or (a, b)) 103 | end 104 | | OpamParserTypes.Group { OpamParserTypes.pelem = [a ; f]; _} -> 105 | let* a = decode_s a in 106 | let* f = decode_s f in 107 | Ok (Wire.Pair (a, f)) 108 | | _ -> Error "unexpected thing while decoding" 109 | 110 | let decode data = 111 | let* file = 112 | try Ok (OpamParser.FullPos.string data "noname") with 113 | Parsing.Parse_error -> Error "parse error" 114 | in 115 | let items = file.OpamParserTypes.file_contents in 116 | List.fold_left (fun acc v -> 117 | let* acc = acc in 118 | match v.OpamParserTypes.pelem with 119 | | OpamParserTypes.Section _ -> Error "unexpected section" 120 | | OpamParserTypes.Variable (k, v) -> 121 | let* v = decode_s v in 122 | Ok (M.add k.OpamParserTypes.pelem v acc)) 123 | (Ok M.empty) items 124 | -------------------------------------------------------------------------------- /src/conex_opam_encoding.mli: -------------------------------------------------------------------------------- 1 | (** Opam file encoding 2 | 3 | Persistent files of the opam repository should be kept in the same file 4 | format as opam files. This module uses the opam-file-format package to 5 | decode and encode the {{!Conex_resource.Wire.t}Wire.t} representation into 6 | opam files. 7 | *) 8 | 9 | (** [decode str] is either [Ok t] or [Error str], the input is a string in opam 10 | format. *) 11 | val decode : string -> (Conex_resource.Wire.t, string) result 12 | 13 | (** [encode t] encodes [t] into a string in opam format. *) 14 | val encode : Conex_resource.Wire.t -> string 15 | -------------------------------------------------------------------------------- /src/conex_private.ml: -------------------------------------------------------------------------------- 1 | open Conex_utils 2 | 3 | (* this is the FRONT *) 4 | module type S = sig 5 | open Conex_resource 6 | 7 | type t 8 | 9 | val ids : unit -> identifier list 10 | type r_err = [ `Decode of string | `Read of string | `None | `Multiple of string list ] 11 | val pp_r_err : r_err fmt 12 | val read : (float -> Conex_resource.timestamp option) -> identifier -> (t, r_err) result 13 | val bits : t -> int 14 | val created : t -> timestamp 15 | val id : t -> string 16 | val generate : ?bits:int -> (float -> Conex_resource.timestamp option) -> Key.alg -> identifier -> unit -> (t, string) result 17 | val pub_of_priv : t -> Key.t 18 | val sign : Wire.t -> timestamp -> identifier -> Signature.alg -> t -> 19 | (Signature.t, string) result 20 | end 21 | 22 | module type FS = sig 23 | val ids : unit -> Conex_resource.identifier list 24 | val read : (float -> Conex_resource.timestamp option) -> Conex_resource.identifier -> ((string * Conex_resource.timestamp), string) result 25 | val write : Conex_resource.identifier -> string -> (unit, string) result 26 | end 27 | 28 | module type S_RSA_BACK = sig 29 | type t 30 | 31 | val decode_priv : string -> Conex_resource.timestamp -> string -> (t, string) result 32 | val bits : t -> int 33 | val created : t -> Conex_resource.timestamp 34 | val id : t -> Conex_resource.identifier 35 | val generate_rsa : ?bits:int -> unit -> string * string 36 | val pub_of_priv_rsa : t -> string 37 | val sign_pss : t -> string -> (string, string) result 38 | val sha256 : string -> string 39 | end 40 | 41 | module Make (C : S_RSA_BACK) (F : FS) = struct 42 | open Conex_resource 43 | 44 | type t = C.t 45 | 46 | type r_err = [ `Decode of string | `Read of string | `None | `Multiple of string list ] 47 | 48 | let pp_r_err ppf = function 49 | | `Decode str -> Format.fprintf ppf "decode failure: %s" str 50 | | `Read str -> Format.fprintf ppf "read failure: %s" str 51 | | `None -> Format.pp_print_string ppf "id does not exist" 52 | | `Multiple ids -> Format.fprintf ppf "found multiple matching ids %a" 53 | (pp_list Format.pp_print_string) ids 54 | [@@coverage off] 55 | 56 | let ids = F.ids 57 | 58 | let get_id id = match String.cut '.' id with | None -> id | Some (a, _) -> a 59 | 60 | let read to_ts id = 61 | let decode_e = function Ok t -> Ok t | Error e -> Error (`Decode e) in 62 | match F.read to_ts id with 63 | | Ok (k, ts) -> decode_e (C.decode_priv (get_id id) ts k) 64 | | Error _ -> 65 | (* treat id as prefix, look whether we've something *) 66 | match List.filter (fun fn -> String.is_prefix ~prefix:id fn) (F.ids ()) with 67 | | [ id' ] -> 68 | begin match F.read to_ts id' with 69 | | Error e -> Error (`Read e) 70 | | Ok (k, ts) -> decode_e (C.decode_priv (get_id id') ts k) 71 | end 72 | | [] -> Error `None 73 | | ids -> Error (`Multiple ids) 74 | 75 | let bits = C.bits 76 | 77 | let created = C.created 78 | 79 | let id = C.id 80 | 81 | let ( let* ) = Result.bind 82 | 83 | let generate ?bits to_ts alg id () = 84 | match alg with 85 | | `RSA -> 86 | let key, pub = C.generate_rsa ?bits () in 87 | let filename = 88 | let pub' = (id, "", `RSA, pub) in 89 | let keyid = Key.keyid (fun s -> `SHA256, C.sha256 s) pub' in 90 | get_id id ^ "." ^ Digest.to_string keyid 91 | in 92 | let* () = F.write filename key in 93 | let* _, ts = F.read to_ts filename in 94 | C.decode_priv id ts key 95 | 96 | let pub_of_priv t = 97 | let pub = C.pub_of_priv_rsa t in 98 | (id t, created t, `RSA, pub) 99 | 100 | (* TODO allows data to be empty, is this good? *) 101 | let sign data now id alg t = 102 | match alg with 103 | | `RSA_PSS_SHA256 -> 104 | let data = Wire.to_string (to_be_signed data now id alg) in 105 | let* raw = C.sign_pss t data in 106 | Ok (id, now, alg, raw) 107 | end 108 | -------------------------------------------------------------------------------- /src/conex_private.mli: -------------------------------------------------------------------------------- 1 | (** Private key operations and handling *) 2 | 3 | open Conex_utils 4 | 5 | (** The private key module type *) 6 | module type S = sig 7 | open Conex_resource 8 | 9 | (** The type of a private key *) 10 | type t 11 | 12 | (** [ids ()] is the list of all available private keys. *) 13 | val ids : unit -> identifier list 14 | 15 | type r_err = [ `Decode of string | `Read of string | `None | `Multiple of string list ] 16 | 17 | val pp_r_err : r_err fmt 18 | 19 | (** [read id] is either [Ok priv], the private key corresponding to [id], or 20 | an [Error]. *) 21 | val read : (float -> Conex_resource.timestamp option) -> identifier -> (t, r_err) result 22 | 23 | (** [bits t] is the number of bits of the private key [t]. *) 24 | val bits : t -> int 25 | 26 | (** [created t] is the timestamp when [t] was created. *) 27 | val created : t -> timestamp 28 | 29 | (** [id t] is the identifier of [t]. *) 30 | val id : t -> identifier 31 | 32 | (** [generate ~bits alg id ()] generates a fresh private key using [alg] 33 | for [id], or an error. Generate also ensures to persistently store the 34 | generated key if desired. *) 35 | val generate : ?bits:int -> (float -> Conex_resource.timestamp option) -> 36 | Key.alg -> identifier -> unit -> (t, string) result 37 | 38 | (** [pub_of_priv priv] extracts the public key out of [priv]. *) 39 | val pub_of_priv : t -> Key.t 40 | 41 | (** [sign wire now id alg priv] signs [wire] with [priv] using [alg], and 42 | evaluates to a [signature], or an error. *) 43 | val sign : Wire.t -> timestamp -> identifier -> Signature.alg -> t -> 44 | (Signature.t, string) result 45 | end 46 | 47 | (** A simple IO module type for certain private key operations. *) 48 | module type FS = sig 49 | 50 | (** [ids ()] is the list of available identifiers. *) 51 | val ids : unit -> Conex_resource.identifier list 52 | 53 | (** [read id] is either the content and creation timestamp of [id], or an 54 | error. *) 55 | val read : (float -> Conex_resource.timestamp option) -> Conex_resource.identifier -> ((string * Conex_resource.timestamp), string) result 56 | 57 | (** [write id data] stores [data] as [id] persistently, or errors. *) 58 | val write : Conex_resource.identifier -> string -> (unit, string) result 59 | end 60 | 61 | (** The RSA backend module type *) 62 | module type S_RSA_BACK = sig 63 | 64 | (** The abstract type t for keys *) 65 | type t 66 | 67 | (** [decode_priv id ts data] decodes the private key from [data] and returns 68 | a [t] or an error. *) 69 | val decode_priv : string -> Conex_resource.timestamp -> string -> (t, string) result 70 | 71 | (** [bits t] is the number of bits in [t]. *) 72 | val bits : t -> int 73 | 74 | (** [created t] is the timestamp of creation of [t]. *) 75 | val created : t -> Conex_resource.timestamp 76 | 77 | (** [id t] is the identifier of [t]. *) 78 | val id : t -> Conex_resource.identifier 79 | 80 | (** [generate_rsa ~bits ()] generates an RSA private key. *) 81 | val generate_rsa : ?bits:int -> unit -> string * string 82 | 83 | (** [pub_of_priv_rsa priv] is the PEM-encoded PKCS8 public key of [priv]. *) 84 | val pub_of_priv_rsa : t -> string 85 | 86 | (** [sign_pss priv data] is either the raw PSS signature of [data] using 87 | [priv] or an error. *) 88 | val sign_pss : t -> string -> (string, string) result 89 | 90 | val sha256 : string -> string 91 | end 92 | 93 | (** Given a RSA backend, instantiate the private key module type S. *) 94 | module Make (C : S_RSA_BACK) (F : FS) : S 95 | -------------------------------------------------------------------------------- /src/conex_repository.ml: -------------------------------------------------------------------------------- 1 | open Conex_resource 2 | open Conex_utils 3 | 4 | (* the targets tree uses the datadir ["packages"] as root []! *) 5 | type t = { 6 | root : Root.t ; 7 | targets : (Digest.t * Uint.t * S.t) Tree.t ; 8 | } 9 | 10 | let root t = t.root 11 | 12 | let keydir t = t.root.Root.keydir 13 | 14 | let datadir t = t.root.Root.datadir 15 | 16 | let maintainer_delegation t = 17 | match Root.RM.find_opt `Maintainer t.root.Root.roles with 18 | | None -> None 19 | | Some e -> Some (e, false, S.singleton "root") 20 | 21 | let timestamp t = 22 | Option.fold 23 | ~none:(Ok None) 24 | ~some:(function 25 | | Expression.Quorum (1, ks) when Expression.KS.cardinal ks = 1 -> 26 | (* assume a single timestamp *) 27 | begin match Expression.KS.choose ks with 28 | | Local _ -> 29 | Error "only a single remote key expression allowed for timestamp" 30 | | Remote (id, dgst, epoch) -> Ok (Some (id, dgst, epoch)) 31 | end 32 | | _ -> 33 | Error "only a single key expression with quorum 1 allowed for timestamp") 34 | (Root.RM.find_opt `Timestamp (root t).Root.roles) 35 | 36 | let snapshot t = 37 | Option.fold 38 | ~none:(Ok None) 39 | ~some:(function 40 | | Expression.Quorum (1, ks) when Expression.KS.cardinal ks = 1 -> 41 | (* assume a single snapshot *) 42 | begin match Expression.KS.choose ks with 43 | | Local _ -> 44 | Error "only a single remote key expression allowed for snapshot" 45 | | Remote (id, dgst, epoch) -> Ok (Some (id, dgst, epoch)) 46 | end 47 | | _ -> 48 | Error "only a single key expression with quorum 1 allowed for snapshot") 49 | (Root.RM.find_opt `Snapshot (root t).Root.roles) 50 | 51 | let targets t = t.targets 52 | 53 | let with_targets t targets = { t with targets } 54 | 55 | let create root = 56 | let targets = Tree.empty in 57 | { root ; targets } 58 | 59 | type res = [ 60 | | `Only_on_disk of path 61 | | `Only_in_targets of path 62 | | `No_match of path * (Digest.t * Uint.t) list * (Digest.t * Uint.t * S.t) list 63 | ] 64 | 65 | let pp_res ppf = 66 | let pp_d ppf (dgst, len) = 67 | Format.fprintf ppf "%s bytes, %a" (Uint.decimal len) Digest.pp dgst 68 | and pp_t ppf (dgst, len, _) = 69 | Format.fprintf ppf "%s bytes, %a" (Uint.decimal len) Digest.pp dgst 70 | in 71 | function 72 | | `Only_on_disk p -> Format.fprintf ppf "path %a only exists on disk" pp_path p 73 | | `Only_in_targets p -> Format.fprintf ppf "path %a only exists in targets" pp_path p 74 | | `No_match (p, disk, targets) -> 75 | Format.fprintf ppf "no matching digest for %a (on_disk %a, targets %a)" 76 | pp_path p (pp_list pp_d) disk (pp_list pp_t) targets 77 | [@@coverage off] 78 | 79 | let validate_targets t on_disk = 80 | (* foreach digest in on_disk there exists a matching one in t.targets 81 | if there is no such digest -> `Only_on_disk 82 | if the digest does not match -> `No_match 83 | then, fold over t.targets, validate there exists a matching one in on_disk 84 | if there is no such digest -> `Only_in_targets 85 | if there is such a digest, it must match (see check above) 86 | *) 87 | let on_d = 88 | let matches (dgst, len) (dgst', len', _) = 89 | Digest.equal dgst dgst' && Uint.compare len len' = 0 90 | in 91 | Tree.fold (fun path ds acc -> 92 | match ds with 93 | | [] -> acc 94 | | _ -> match Tree.lookup path t.targets with 95 | | None -> `Only_on_disk path :: acc 96 | | Some xs -> 97 | let in_targets d = List.exists (matches d) xs in 98 | if List.exists in_targets ds 99 | then acc 100 | else `No_match (path, ds, xs) :: acc) 101 | [] on_disk 102 | in 103 | Tree.fold (fun path xs acc -> 104 | match xs with 105 | | [] -> acc 106 | | _ -> match Tree.lookup path on_disk with 107 | | None -> `Only_in_targets path :: acc 108 | | Some _ -> acc) 109 | on_d t.targets 110 | 111 | let fold_targets f acc id_d targets = 112 | (* M.iter (fun id (dgst, epoch) -> 113 | Printf.printf "[fold_targets] id %s digest %s epoch %s\n" 114 | id (Digest.to_string dgst) (Uint.decimal epoch)) 115 | id_d ; *) 116 | List.fold_left (fun acc target -> 117 | match M.find_opt target.Targets.name id_d with 118 | | None -> 119 | Format.printf "couldn't find id %a in id_d@." pp_id target.Targets.name ; 120 | acc 121 | | Some (dgst, epoch) -> f acc dgst epoch target) 122 | acc targets 123 | 124 | module Expr_map = struct 125 | include Map.Make(Expression) 126 | end 127 | 128 | let collect_and_validate_delegations id_d parent expr targets = 129 | let tree = 130 | fold_targets (fun tree dgst epoch target -> 131 | List.fold_left (fun tree delegation -> 132 | (* Format.printf "inserting delegation %a (origin %a)@." 133 | Delegation.pp delegation pp_id target.Targets.name ; *) 134 | List.fold_left (fun tree path -> 135 | if subpath ~parent path then begin 136 | Tree.insert path 137 | (delegation.Delegation.terminating, 138 | delegation.Delegation.valid, 139 | target.Targets.name, dgst, epoch) 140 | tree 141 | end else begin 142 | Format.printf "WARN ignoring delegation %a (path %a is not below parent %a)@." 143 | Delegation.pp delegation 144 | pp_path path pp_path parent ; 145 | tree 146 | end) 147 | tree delegation.Delegation.paths) 148 | tree target.Targets.delegations) 149 | Tree.empty id_d targets 150 | in 151 | (* now, tree contains at its nodes a list of 152 | (bool * Expression.t * identifier * Digest.t * Uint.t) *) 153 | let good_ones = 154 | Tree.fold (fun path stuff acc -> 155 | let em = 156 | List.fold_left (fun acc (terminating, expression, id, keyid, epoch) -> 157 | let supporter = (terminating, id, keyid, epoch) in 158 | (* Format.printf "inserting expr %a (terminating %b) (supporter %a) for %a@." 159 | Expression.pp expression terminating pp_id id pp_path path ; *) 160 | let v = match Expr_map.find_opt expression acc with 161 | | None -> [ supporter ] 162 | | Some m -> supporter :: m 163 | in 164 | Expr_map.add expression v acc) 165 | Expr_map.empty stuff 166 | in 167 | Expr_map.fold (fun expression ss acc -> 168 | (* eval expression foreach thing *) 169 | let t, nont = List.partition (fun (t, _, _, _) -> t) ss in 170 | (* Format.printf "expr %a path %a %d terminating, %d non-terminating@." 171 | Expression.pp expression pp_path path (List.length t) (List.length nont) ; *) 172 | let dms xs = 173 | List.fold_left (fun (dm, s) (_, id, keyid, epoch) -> 174 | (* Format.printf "adding %a for %a@." pp_id id pp_path path ; *) 175 | Digest_map.add keyid (id, epoch) dm, S.add id s) 176 | (Digest_map.empty, S.empty) xs 177 | in 178 | let ts, tss = dms t 179 | and nonts, nontss = dms nont 180 | in 181 | (* Format.printf "evaluating expr %a for %a and %a@." 182 | Expression.pp expr pp_path path Expression.pp expression ; *) 183 | if Expression.eval expr ts S.empty then 184 | (path, expression, true, tss) :: acc 185 | else if Expression.eval expr nonts S.empty then 186 | (path, expression, false, nontss) :: acc 187 | else begin 188 | Format.printf "expression %a couldn't evaluate for %a@." 189 | Expression.pp expression pp_path path ; 190 | acc 191 | end) em acc) 192 | [] tree 193 | in 194 | (* let pp_t ppf (path, expr, t, s) = 195 | Format.fprintf ppf "path %a expr %a terminating %b supporters %a@." 196 | pp_path path Expression.pp expr t S.pp s 197 | in 198 | Format.printf "at the end, our delegations %a@." (pp_list pp_t) good_ones ; *) 199 | (* each checksum that is good in that setting is allowed to return from here, 200 | and being inserted into a global tree of valid checksums *) 201 | good_ones 202 | 203 | let collect_and_validate_targets ?(tree = Tree.empty) id_d parent expr targets = 204 | let ttree = 205 | fold_targets (fun tree dgst epoch target -> 206 | List.fold_left (fun tree chk -> 207 | if subpath ~parent chk.Target.filename then begin 208 | (* Format.printf "inserting target %a (origin %a)@." 209 | Target.pp chk pp_id target.Targets.name ; *) 210 | Tree.insert chk.Target.filename 211 | (chk.Target.digest, chk.Target.size, 212 | target.Targets.name, dgst, epoch) 213 | tree 214 | end else begin 215 | Format.printf "WARN ignoring target %a (path %a is not below parent %a@." 216 | Target.pp chk pp_path chk.Target.filename pp_path parent ; 217 | tree 218 | end) 219 | tree target.Targets.targets) 220 | Tree.empty id_d targets 221 | in 222 | (* once that is in there, fold over tree and eval expr with the stored "digest maps" *) 223 | let good_ones = 224 | Tree.fold (fun path stuff acc -> 225 | (* need to go over the stuff list and sort by first projection: *) 226 | (* this is a digest list -- now we need to put all the digests somewhere *) 227 | (* and get the key_dgst, name, epoch as DigestMap on the RHS, *) 228 | let dm = 229 | List.fold_left (fun acc (chks, len, id, keyid, epoch) -> 230 | let supporter = (id, keyid, epoch) in 231 | List.fold_left (fun acc dgst -> 232 | (* Format.printf "inserting digest %a (supporter %a) for %a (digest %a, len %s)@." 233 | Digest.pp dgst pp_id id pp_path path Digest.pp dgst (Uint.decimal len) ; *) 234 | let v = match Digest_map.find_opt dgst acc with 235 | | None -> Uint_map.add len [ supporter ] Uint_map.empty 236 | | Some m -> 237 | match Uint_map.find_opt len m with 238 | | None -> Uint_map.add len [ supporter ] m 239 | | Some sups -> Uint_map.add len (supporter :: sups) m 240 | in 241 | Digest_map.add dgst v acc) acc chks) 242 | Digest_map.empty stuff 243 | in 244 | Digest_map.fold (fun dgst m tree -> 245 | (* eval expression foreach thing *) 246 | Uint_map.fold (fun len sups tree -> 247 | let dm, s = 248 | List.fold_left (fun (dm, s) (id, keyid, epoch) -> 249 | (* Format.printf "adding %a for %a (digest %a, len %s)@." 250 | pp_id id pp_path path Digest.pp dgst (Uint.decimal len) ; *) 251 | Digest_map.add keyid (id, epoch) dm, S.add id s) 252 | (Digest_map.empty, S.empty) sups 253 | in 254 | (* Format.printf "evaluating expr %a for %a (digest %a, len %s)@." 255 | Expression.pp expr pp_path path Digest.pp dgst (Uint.decimal len) ; *) 256 | if Expression.eval expr dm S.empty then 257 | Tree.insert path (dgst, len, s) tree 258 | else begin 259 | Format.printf "expression %a couldn't evaluate for %a (digest %a, len %s)@." 260 | Expression.pp expr pp_path path Digest.pp dgst (Uint.decimal len) ; 261 | tree 262 | end) m tree) 263 | dm acc) 264 | tree ttree 265 | in 266 | (* 267 | let pp_t ppf (dgst, len, s) = 268 | Format.fprintf ppf "digest %a len %s supporters %a@." 269 | Digest.pp dgst (Uint.decimal len) S.pp s 270 | in 271 | Format.printf "at the end, our tree %a@." (Tree.pp pp_t) good_ones ; *) 272 | (* each checksum that is good in that setting is allowed to return from here, 273 | and being inserted into a global tree of valid checksums *) 274 | good_ones 275 | -------------------------------------------------------------------------------- /src/conex_repository.mli: -------------------------------------------------------------------------------- 1 | open Conex_resource 2 | open Conex_utils 3 | 4 | type t 5 | 6 | val root : t -> Root.t 7 | 8 | val keydir : t -> path 9 | 10 | val datadir : t -> path 11 | 12 | val targets : t -> (Digest.t * Uint.t * S.t) Tree.t 13 | 14 | val with_targets : t -> (Digest.t * Uint.t * S.t) Tree.t -> t 15 | 16 | val maintainer_delegation : t -> (Expression.t * bool * S.t) option 17 | 18 | val timestamp : t -> ((identifier * Digest.t * Uint.t) option, string) result 19 | 20 | val snapshot : t -> ((identifier * Digest.t * Uint.t) option, string) result 21 | 22 | val create : Root.t -> t 23 | 24 | 25 | type res = [ 26 | | `Only_on_disk of path 27 | | `Only_in_targets of path 28 | | `No_match of path * (Digest.t * Uint.t) list * (Digest.t * Uint.t * S.t) list 29 | ] 30 | 31 | val pp_res : res fmt 32 | 33 | val validate_targets : t -> (Digest.t * Uint.t) Tree.t -> res list 34 | 35 | val collect_and_validate_delegations : (Digest.t * Uint.t) M.t -> path -> 36 | Expression.t -> Targets.t list -> (path * Expression.t * bool * S.t) list 37 | 38 | val collect_and_validate_targets : ?tree:(Digest.t * Uint.t * S.t) Tree.t -> 39 | (Digest.t * Uint.t) M.t -> path -> Expression.t -> Targets.t list -> 40 | (Digest.t * Uint.t * S.t) Tree.t 41 | -------------------------------------------------------------------------------- /src/conex_resource.mli: -------------------------------------------------------------------------------- 1 | (** Persistent data: on wire and record types 2 | 3 | Every resource in conex is a piece of data (or metadata), and has its own 4 | purpose. Resources stored on disk consists of a common header: a name, a 5 | type, a counter, an epoch, and a creation timestamp. There are 6 | broadly three kinds of resources: those containing identities ({!Team} and 7 | {!Author}), those regulating access to packages ({!Authorisation}), and 8 | those with the digests of the opam repository data ({!Releases} and 9 | {!Release}). 10 | *) 11 | 12 | open Conex_utils 13 | 14 | (* TODO: maybe move name, identifier, timestamp to conex_utils!? *) 15 | (** {1 Names and identifiers} *) 16 | 17 | (** The name of resources, used e.g. for package names. *) 18 | type name = string 19 | 20 | (** [pp_name name] is a pretty printer for [name]. *) 21 | val pp_name : name fmt 22 | 23 | (** [name_equal a b] is the result of a case insensitive comparison of [a] and [b]. *) 24 | val name_equal : name -> name -> bool 25 | 26 | (** The type of identifiers. *) 27 | type identifier = string 28 | 29 | (** [pp_id id] is a pretty printer for [identifier]. *) 30 | val pp_id : identifier fmt 31 | 32 | (** [id_equal a b] is the result of a case insensitive comparison of [a] and [b]. *) 33 | val id_equal : identifier -> identifier -> bool 34 | 35 | (** The type for a timestamp, always a RFC3339 string in UTC (no timezone 36 | information). *) 37 | type timestamp = string 38 | 39 | (* TODO: should we have a constructor and check for validity? 40 | NNNN'-'MM'-'DD'T'hh':'mm':'ss'Z' where 41 | ^^ year, 1 <= MM <= 12, 1 <= DD <= 31 (or depending on MM) 42 | 0 <= hh <= 23, 0 <= mm <= 59, 0 <= ss <= 59 *) 43 | 44 | val pp_timestamp : timestamp fmt 45 | 46 | (** {1 Wire format} *) 47 | 48 | (** The wire encoding is abstract here, one suitable decoding and encoding 49 | engine is {!Conex_opam_encoding}. The wire encoding is used for digest 50 | computations, and persistent storage on disk. *) 51 | module Wire : sig 52 | 53 | (** The values in the key value store: either a map, a list, an identifier, 54 | data (represented as string), or an unsigned integer. *) 55 | type s = 56 | | Map of s M.t 57 | | List of s list 58 | | Identifier of identifier 59 | | Data of string 60 | | Bigint of Uint.t 61 | | Smallint of int 62 | | Pair of s * s 63 | | And of s * s 64 | | Or of s * s 65 | 66 | (** The toplevel node, a Map *) 67 | type t = s M.t 68 | 69 | (** [to_string t] is a string representing [t]. This is used by 70 | {!Conex_verify.S} to compute digests and signatures. There is no parser for 71 | this string encoding available. *) 72 | val to_string : t -> string 73 | end 74 | 75 | (** {1 Resource types} *) 76 | 77 | (** The sum type of all possible resources. *) 78 | type typ = [ 79 | | `Root 80 | | `Timestamp 81 | | `Snapshot 82 | | `Targets 83 | ] 84 | 85 | (** [resource_to_string res] is the string representation of [res]. *) 86 | val typ_to_string : typ -> string 87 | 88 | (** [string_to_resource str] is either [Some resource] or [None]. *) 89 | val string_to_typ : string -> typ option 90 | 91 | (** [pp_resource pp] is a pretty printer for [resource]. *) 92 | val pp_typ : typ fmt 93 | 94 | (** [resource_equal a b] is [true] if they are the same, otherwise [false]. *) 95 | val typ_equal : typ -> typ -> bool 96 | 97 | val typ_of_wire : Wire.s -> (typ, string) result 98 | 99 | type err = [ 100 | | `Parse of string 101 | | `Unknown_alg of string 102 | | `Malformed 103 | ] 104 | 105 | val pp_err : err fmt 106 | 107 | (** Common header on disk *) 108 | module Header : sig 109 | 110 | (** The header consists of version, created, counter, epoch, name, and typ. *) 111 | type t = { 112 | version : int ; 113 | created : timestamp ; 114 | counter : Uint.t ; 115 | epoch : Uint.t ; 116 | name : name ; 117 | typ : typ 118 | } 119 | 120 | (** [pp] is a pretty printer. *) 121 | val pp : t fmt 122 | 123 | (** [wire t] is the wire representation of [t]. *) 124 | val wire : t -> Wire.t 125 | 126 | (** [of_wire t] converts [t] into a {!Header.t} or error. *) 127 | val of_wire : Wire.t -> (t, string) result 128 | 129 | (** [counter ctr epoch] prints [ctr, epoch] to a string containing the counter 130 | and epoch (unless zero). *) 131 | val counter : Uint.t -> Uint.t -> string 132 | end 133 | 134 | (** {1 Digests} *) 135 | 136 | module Digest : sig 137 | 138 | (** The sum type of supported digest algorithms. *) 139 | type alg = [ `SHA256 ] 140 | 141 | (** A digest is a pair of digest algorithm and value. *) 142 | type t = alg * string 143 | 144 | (** [pp digest] is a pretty printer for [digest]. *) 145 | val pp : t fmt 146 | 147 | (** [compare a b] compares [a] and [b], returns 0 if equal, -1 if smaller, 1 148 | if bigger. *) 149 | val compare : t -> t -> int 150 | 151 | (** [equal a b] is [true] when [a] and [b] use the same algorithm type, and 152 | have the same value. *) 153 | val equal : t -> t -> bool 154 | 155 | (** [of_wire w] converts [w] to a digest or error. *) 156 | val of_wire : Wire.s -> (t, err) result 157 | 158 | (** [wire_raw t] is the wire representation of [t]. *) 159 | val wire_raw : t -> Wire.s 160 | 161 | (** [of_string str] is t or an error. *) 162 | val of_string : string -> (t, err) result 163 | 164 | (** [to_string digest] is the [string] representing the [digest]. *) 165 | val to_string : t -> string 166 | end 167 | 168 | module Digest_map : sig 169 | include Map.S with type key = Digest.t 170 | val pp : (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a t -> unit 171 | end 172 | 173 | (** {1 Asymmetric key types} *) 174 | 175 | module Key : sig 176 | 177 | (** The sum type of supported asymmetric key algorithms. *) 178 | type alg = [ `RSA ] 179 | 180 | (** The type of public keys *) 181 | type t = identifier * timestamp * alg * string 182 | 183 | (** [equal a b] is [true] if id, created, alg, and key are identical. *) 184 | val equal : t -> t -> bool 185 | 186 | (** [pp] is a pretty printer for public keys *) 187 | val pp : t fmt 188 | 189 | (** [of_wire w] converts [w] to a key or error. *) 190 | val of_wire : Wire.s -> (t, err) result 191 | 192 | (** [many_of_wire w] uses {!of_wire} on the {!Wire.List} [w]. Prints errors 193 | to stdout if an unknown key algorithm or multiple keys with the same 194 | identifier are used. *) 195 | val many_of_wire : Wire.s list -> (t M.t * string list, string) result 196 | 197 | (** [wire_raw t] is the raw wire representation of [t]. *) 198 | val wire_raw : t -> Wire.s 199 | 200 | (** [wire t] is the wire representation of [t]. *) 201 | val wire : t -> Wire.t 202 | 203 | (** [keyid hash key] is [hash (to_string key)], the key hash. *) 204 | val keyid : (string -> Digest.t) -> t -> Digest.t 205 | 206 | val to_string : t -> string 207 | end 208 | 209 | (** {1 Cryptographic signatures} *) 210 | 211 | module Signature : sig 212 | (** The sum type of supported signature algorithms. *) 213 | type alg = [ `RSA_PSS_SHA256 ] 214 | 215 | (** A signature is a quadruple of timestamp, identifier, algorithm, and 216 | signature value. *) 217 | type t = identifier * timestamp * alg * string 218 | 219 | (** [equal a b] is [true] if id, created, alg, and signature are the same. *) 220 | val equal : t -> t -> bool 221 | 222 | (** [pp sig] is a pretty printer for a signature. *) 223 | val pp : t fmt 224 | 225 | (** [of_wire w] converts [w] to a signature or error. *) 226 | val of_wire : Wire.s -> (t, err) result 227 | 228 | (** [many_of_wire w] uses {!of_wire} on the {!Wire.List} [w]. Prints errors to 229 | stdout if an unknown signature algorithm or multiple signatures with the 230 | same identifier are used. *) 231 | val many_of_wire : Wire.s list -> (t M.t * string list, string) result 232 | 233 | (** [wire_raw t] is the wire representation of [t]. *) 234 | val wire_raw : t -> Wire.s 235 | end 236 | 237 | (** [to_be_signed data timestamp id algorithm] prepares the representation used 238 | by signing and verification *) 239 | val to_be_signed : Wire.t -> timestamp -> identifier -> Signature.alg -> Wire.t 240 | 241 | 242 | (** {1 Delegation key expression} *) 243 | module Expression : sig 244 | 245 | type keyref = 246 | | Remote of identifier * Digest.t * Uint.t 247 | | Local of identifier 248 | 249 | module KS : (Set.S with type elt = keyref) 250 | 251 | type t = 252 | | Quorum of int * KS.t 253 | | And of t * t 254 | | Or of t * t 255 | 256 | val compare : t -> t -> int 257 | 258 | val equal : t -> t -> bool 259 | 260 | val local_keys : t -> S.t 261 | 262 | val keys : (Digest.t * Uint.t) M.t -> t -> (Digest.t * Uint.t) M.t 263 | 264 | val pp : t fmt 265 | 266 | val of_wire : Wire.s -> (t, string) result 267 | 268 | val to_wire : t -> Wire.s 269 | 270 | val hash : (string -> Digest.t) -> string M.t -> t -> (Digest.t, string) result 271 | 272 | val eval : t -> (identifier * Uint.t) Digest_map.t -> S.t -> bool 273 | end 274 | 275 | (** {1 Root} *) 276 | 277 | (** The root contains the (offline) root keys, also defines snapshot, timestamp, 278 | and maintainers. Furthermore, it contains configuration information such as 279 | where keys are located in this repository and where the data is stored. *) 280 | module Root : sig 281 | type role = [ `Snapshot | `Timestamp | `Maintainer ] 282 | 283 | val role_to_string : role -> string 284 | 285 | module RM : sig 286 | include Map.S with type key = role 287 | val pp : (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a t -> unit 288 | end 289 | 290 | type t = { 291 | created : timestamp ; 292 | counter : Uint.t ; 293 | epoch : Uint.t ; 294 | name : identifier ; 295 | datadir : path ; 296 | keydir : path ; 297 | keys : Key.t M.t ; 298 | valid : Expression.t ; 299 | roles : Expression.t RM.t ; 300 | signatures : Signature.t M.t ; 301 | } 302 | 303 | val t : ?counter:Uint.t -> ?epoch:Uint.t -> ?name:identifier -> 304 | ?datadir:path -> ?keydir:path -> ?keys:Key.t M.t -> ?roles:Expression.t RM.t -> 305 | ?signatures:Signature.t M.t -> timestamp -> Expression.t -> t 306 | 307 | val add_signature : t -> identifier -> Signature.t -> t 308 | 309 | val pp : t fmt 310 | 311 | val of_wire : Wire.t -> (t * string list, string) result 312 | 313 | val wire : t -> Wire.t 314 | 315 | val wire_raw : t -> Wire.t 316 | 317 | end 318 | 319 | (** {1 Target} *) 320 | 321 | (** The target is a triple of filename, digest, and size. It is used by snapshot 322 | and targets. *) 323 | module Target : sig 324 | type t = { 325 | filename : path ; 326 | digest : Digest.t list ; 327 | size : Uint.t ; 328 | } 329 | 330 | (** [equal a b] is [true] if targets [a] and [b] are identical. *) 331 | val equal : t -> t -> bool 332 | 333 | (** [valid_path t] is [true] if the filename sticks to opam repository rules: 334 | [foo/foo.version/opam] of [foo.version/opam]. *) 335 | val valid_opam_path : t -> bool 336 | 337 | (** [pp] is a pretty printer for a target. *) 338 | val pp : t fmt 339 | 340 | (** [of_wire w] converts [w] to a target or error. *) 341 | val of_wire : Wire.s -> (t, string) result 342 | 343 | (** [wire_raw t] is the raw wire representation of [t]. *) 344 | val wire_raw : t -> Wire.s 345 | end 346 | 347 | (** {1 Timestamp} *) 348 | 349 | (** The timestamp is signed by the timestamp role. It lists the snapshot data, 350 | (its size, filename, and digest). The purpose is to prevent freeze attacks: 351 | It periodically signs the data, a client can discover it does not receive 352 | updates. 353 | *) 354 | module Timestamp : sig 355 | type t = { 356 | created : timestamp ; 357 | counter : Uint.t ; 358 | epoch : Uint.t ; 359 | name : identifier ; 360 | keys : Key.t M.t ; 361 | targets : Target.t list ; 362 | signatures : Signature.t M.t ; 363 | } 364 | 365 | val t : ?counter:Uint.t -> ?epoch:Uint.t -> ?keys:Key.t M.t -> 366 | ?targets:Target.t list -> ?signatures:Signature.t M.t -> timestamp -> 367 | identifier -> t 368 | 369 | (** [equal a b] is [true] if all fields of [a] and [b] are equal. *) 370 | val equal : t -> t -> bool 371 | 372 | val add_signature : t -> identifier -> Signature.t -> t 373 | 374 | val pp : t fmt 375 | 376 | val of_wire : Wire.t -> (t * string list, string) result 377 | 378 | val wire : t -> Wire.t 379 | 380 | val wire_raw : t -> Wire.t 381 | 382 | end 383 | 384 | 385 | (** {1 Snapshot} *) 386 | 387 | (** The snapshot is signed by the snapshot role. It lists all targets, with 388 | size, filename, and digest. The purpose is to prevent mix-and-match attacks, 389 | where an attacker mixes older targets files with newer ones. *) 390 | module Snapshot : sig 391 | type t = { 392 | created : timestamp ; 393 | counter : Uint.t ; 394 | epoch : Uint.t ; 395 | name : identifier ; 396 | keys : Key.t M.t ; 397 | targets : Target.t list ; 398 | signatures : Signature.t M.t ; 399 | } 400 | 401 | val t : ?counter:Uint.t -> ?epoch:Uint.t -> ?keys:Key.t M.t -> 402 | ?targets:Target.t list -> ?signatures:Signature.t M.t -> timestamp -> 403 | identifier -> t 404 | 405 | (** [equal a b] is [true] if all fields of [a] and [b] are equal. *) 406 | val equal : t -> t -> bool 407 | 408 | val add_signature : t -> identifier -> Signature.t -> t 409 | 410 | val pp : t fmt 411 | 412 | val of_wire : Wire.t -> (t * string list, string) result 413 | 414 | val wire : t -> Wire.t 415 | 416 | val wire_raw : t -> Wire.t 417 | 418 | end 419 | 420 | module Delegation : sig 421 | type t = { 422 | paths : path list ; 423 | valid : Expression.t ; 424 | terminating : bool 425 | } 426 | 427 | (** [equal a b] is [true] if delegations [a] and [b] are identical. *) 428 | val equal : t -> t -> bool 429 | 430 | (** [pp] is a pretty printer for a delegation. *) 431 | val pp : t fmt 432 | 433 | (** [of_wire w] converts [w] to a delegation or error. *) 434 | val of_wire : Wire.s -> (t, string) result 435 | 436 | (** [wire_raw t] is the raw wire representation of [t]. *) 437 | val wire_raw : t -> Wire.s 438 | end 439 | 440 | module Targets : sig 441 | type t = { 442 | created : timestamp ; 443 | counter : Uint.t ; 444 | epoch : Uint.t ; 445 | name : identifier ; 446 | keys : Key.t M.t ; 447 | valid : Expression.t ; 448 | delegations : Delegation.t list ; 449 | targets : Target.t list ; 450 | signatures : Signature.t M.t ; 451 | } 452 | 453 | val t : ?counter:Uint.t -> ?epoch:Uint.t -> ?keys:Key.t M.t -> 454 | ?delegations:Delegation.t list -> ?targets:Target.t list -> 455 | ?signatures:Signature.t M.t -> timestamp -> identifier -> Expression.t -> t 456 | 457 | val add_signature : t -> identifier -> Signature.t -> t 458 | 459 | (** [equal a b] is [true] if all fields of [a] and [b] are equal. *) 460 | val equal : t -> t -> bool 461 | 462 | (** [pp t] is a pretty printer for a targets. *) 463 | val pp : t fmt 464 | 465 | (** [of_wire w] converts [w] to a targets or error. *) 466 | val of_wire : Wire.t -> (t * string list, string) result 467 | 468 | (** [wire t] is the wire representation of [t]. *) 469 | val wire : t -> Wire.t 470 | 471 | (** [wire_raw t] is the wire representation of [t]. *) 472 | val wire_raw : t -> Wire.t 473 | end 474 | -------------------------------------------------------------------------------- /src/conex_utils.ml: -------------------------------------------------------------------------------- 1 | 2 | type 'a fmt = Format.formatter -> 'a -> unit 3 | 4 | let pp_list pe ppf xs = 5 | match xs with 6 | | [] -> Format.pp_print_string ppf "empty" 7 | | xs -> 8 | Format.pp_print_string ppf "[" ; 9 | let rec p1 = function 10 | | [] -> Format.pp_print_string ppf "]" ; 11 | | [x] -> Format.fprintf ppf "%a]" pe x 12 | | x::xs -> Format.fprintf ppf "%a;@ " pe x ; p1 xs 13 | in 14 | p1 xs 15 | [@@coverage off] 16 | 17 | module S = struct 18 | include Set.Make(String) 19 | 20 | let pp fmt t = 21 | pp_list Format.pp_print_string fmt (elements t) 22 | [@@coverage off] 23 | 24 | let of_list es = List.fold_right add es empty 25 | end 26 | 27 | let str_pp pp e = 28 | Format.(fprintf str_formatter "%a" pp e) ; 29 | Format.flush_str_formatter () 30 | 31 | let ( let* ) = Result.bind 32 | 33 | let guard p err = if p then Ok () else Error err 34 | 35 | let rec foldM f n = function 36 | | [] -> Ok n 37 | | x::xs -> 38 | let* n' = f n x in 39 | foldM f n' xs 40 | 41 | let rec iterM f = function 42 | | [] -> Ok () 43 | | x::xs -> 44 | let* () = f x in 45 | iterM f xs 46 | 47 | let foldS f a s = 48 | S.fold (fun id r -> 49 | let* r = r in 50 | f r id) s (Ok a) 51 | 52 | let err_to_str pp = function 53 | | Ok a -> Ok a 54 | | Error e -> Error (str_pp pp e) 55 | 56 | module String = struct 57 | type t = string 58 | 59 | let cuts sep str = 60 | String.split_on_char sep str 61 | 62 | let cut sep str = 63 | match cuts sep str with 64 | | [] -> None 65 | | [ _ ] -> None 66 | | [ a ; b ] -> Some (a, b) 67 | | a :: xs -> Some (a, String.concat (String.make 1 sep) xs) 68 | 69 | let slice ?(start = 0) ?stop str = 70 | let stop = match stop with 71 | | None -> String.length str 72 | | Some x -> x 73 | in 74 | let len = stop - start in 75 | String.sub str start len 76 | 77 | let is_prefix ~prefix str = 78 | let pl = String.length prefix in 79 | if String.length str < pl then 80 | false 81 | else 82 | String.(equal (sub str 0 (length prefix)) prefix) 83 | 84 | let is_suffix ~suffix str = 85 | let sl = String.length suffix in 86 | if String.length str < sl then 87 | false 88 | else 89 | String.(equal (sub str (length str - sl) sl) suffix) 90 | 91 | let lowercase_char = function 92 | | 'A' .. 'Z' as c -> char_of_int (int_of_char c + 0x20) 93 | | c -> c 94 | 95 | let to_lower s = 96 | let last = pred (String.length s) 97 | and bs = Bytes.of_string s 98 | in 99 | for k = 0 to last do 100 | Bytes.set bs k (lowercase_char (Bytes.get bs k)) 101 | done ; 102 | Bytes.to_string bs 103 | 104 | let ascii_char ?(p = fun _ -> false) = function 105 | | '0' .. '9' 106 | | 'A' .. 'Z' 107 | | 'a' .. 'z' -> true 108 | | x -> p x 109 | 110 | let is_ascii ?p s = 111 | let last = pred (String.length s) in 112 | let res = ref true in 113 | for k = 0 to last do 114 | res := !res && ascii_char ?p (String.get s k) 115 | done; 116 | !res 117 | 118 | let trim = String.trim 119 | 120 | let get = String.get 121 | 122 | let concat = String.concat 123 | 124 | let compare = String.compare 125 | 126 | let length = String.length 127 | 128 | let compare_insensitive a b = 129 | compare (to_lower a) (to_lower b) 130 | 131 | let equal = String.equal 132 | 133 | let get_uint8 = String.get_uint8 134 | end 135 | 136 | module Uint = struct 137 | type t = int64 138 | 139 | let zero = 0L 140 | 141 | let max = -1L (* this is 0xFFFFFFFFFFFFFFFF *) 142 | 143 | let compare a b = 144 | Int64.(compare (sub a min_int) (sub b min_int)) 145 | 146 | let succ x = 147 | if x = max then 148 | (true, 0L) 149 | else 150 | (false, Int64.succ x) 151 | 152 | let to_string s = Printf.sprintf "0x%LX" s 153 | 154 | let pp ppf i = Format.pp_print_string ppf (to_string i) [@@coverage off] 155 | 156 | let decimal s = Printf.sprintf "%Lu" s 157 | 158 | let of_string s = 159 | try Some (Int64.of_string s) with Failure _ -> None 160 | 161 | let of_float f = 162 | if f < 0. then 163 | None 164 | else 165 | try Some (Int64.of_float f) with Failure _ -> None 166 | 167 | let of_int_exn i = 168 | if i < 0 then 169 | invalid_arg "cannot convert integers smaller than 0" 170 | else 171 | Int64.of_int i 172 | 173 | let of_int i = try Some (of_int_exn i) with Failure _ -> None 174 | 175 | end 176 | 177 | module Uint_map = struct 178 | include Map.Make(Uint) 179 | end 180 | 181 | module M = struct 182 | include Map.Make(String) 183 | 184 | let pp pp_e ppf m = 185 | iter (fun k v -> Format.fprintf ppf "%s -> %a@ " k pp_e v) m 186 | [@@coverage off] 187 | end 188 | 189 | let rec filter_map ~f = function 190 | | [] -> [] 191 | | x::xs -> 192 | match f x with 193 | | None -> filter_map ~f xs 194 | | Some x' -> x' :: filter_map ~f xs 195 | 196 | (* this is stripped down from Logs library *) 197 | module type LOGS = sig 198 | module Tag : sig 199 | type set 200 | end 201 | 202 | type ('a, 'b) msgf = 203 | (?header:string -> ?tags:Tag.set -> 204 | ('a, Format.formatter, unit, 'b) format4 -> 'a) -> 'b 205 | type 'a log = ('a, unit) msgf -> unit 206 | 207 | type src 208 | 209 | val warn_count : unit -> int 210 | 211 | val debug : ?src:src -> 'a log 212 | val info : ?src:src -> 'a log 213 | val warn : ?src:src -> 'a log 214 | end 215 | 216 | type file_type = File | Directory 217 | 218 | type path = string list 219 | 220 | let root = [] 221 | 222 | let non_path = [ ".." ; "." ; "" ; "/" ] 223 | 224 | let path_to_string path = 225 | assert (not (List.exists (fun s -> List.mem s non_path) path)) ; 226 | List.fold_left Filename.concat "" path 227 | 228 | let string_to_path_exn str = 229 | let segments = String.cuts '/' str in 230 | let segs = match segments with 231 | | ""::xs -> xs 232 | | xs -> xs 233 | in 234 | if List.exists (fun s -> List.mem s non_path) segs then 235 | invalid_arg "invalid path" 236 | else 237 | segs 238 | 239 | let string_to_path str = 240 | try Ok (string_to_path_exn str) with 241 | | Invalid_argument m -> Error m 242 | 243 | let path_equal a b = 244 | let str_eq a b = String.compare a b = 0 in 245 | try List.for_all2 str_eq a b with _ -> false 246 | 247 | let rec subpath ~parent b = 248 | let str_eq a b = String.compare a b = 0 in 249 | match parent, b with 250 | | [], [] -> false 251 | | [], _ -> true 252 | | _, [] -> false 253 | | hd::tl, hd'::tl' -> if str_eq hd hd' then subpath ~parent:tl tl' else false 254 | 255 | let pp_path fmt p = 256 | Format.pp_print_string fmt (path_to_string p) 257 | [@@coverage off] 258 | 259 | type item = file_type * string 260 | 261 | module Tree = struct 262 | type 'a t = Node of 'a list * 'a t M.t 263 | 264 | let rec equal eq (Node (del, map)) (Node (del', map')) = 265 | (try List.for_all2 eq del del' with _ -> false) && 266 | M.equal (equal eq) map map' 267 | 268 | let empty = Node ([], M.empty) 269 | 270 | let is_empty = function 271 | | Node ([], m) when M.is_empty m -> true 272 | | Node (_, _) -> false 273 | 274 | let rec sub path t = match path, t with 275 | | [], n -> n 276 | | hd::tl, Node (_, m) -> match M.find_opt hd m with 277 | | None -> empty 278 | | Some n -> sub tl n 279 | 280 | let fold f acc root = 281 | let rec doit path (Node (v, map)) acc = 282 | let acc' = f path v acc in 283 | M.fold (fun k v acc -> doit (path @ [k]) v acc) map acc' 284 | in 285 | doit [] root acc 286 | 287 | let pp pp_e ppf node = 288 | let rec pp prefix ppf (Node (dels, map)) = 289 | let pp_map ppf map = 290 | List.iter (fun (key, node) -> 291 | let prefix' = prefix ^ "/" ^ key in 292 | Format.fprintf ppf "@[<2>%s@ ->@ %a@]@," 293 | prefix' (pp prefix') node) 294 | (M.bindings map) 295 | in 296 | Format.fprintf ppf "@[<2>values:@ %a@.%a@,@]@," 297 | (pp_list pp_e) dels 298 | pp_map map 299 | in 300 | (pp "") ppf node 301 | [@@coverage off] 302 | 303 | let rec lookup path (Node (dels, map)) = 304 | match path with 305 | | [] -> Some dels 306 | | hd::tl -> match M.find_opt hd map with 307 | | None -> None 308 | | Some x -> lookup tl x 309 | 310 | let lookup_prefix path node = 311 | let rec lookup sofar path (Node (dels, map)) = 312 | let ext = match dels with [] -> sofar | d -> d in 313 | match path with 314 | | [] -> ext 315 | | hd::tl -> match M.find_opt hd map with 316 | | None -> ext 317 | | Some x -> lookup ext tl x 318 | in 319 | lookup [] path node 320 | 321 | let rec insert path value (Node (dels, map)) = 322 | match path with 323 | | [] -> Node (dels @ [ value ], map) 324 | | hd::tl -> 325 | let n = match M.find_opt hd map with 326 | | None -> empty 327 | | Some x -> x 328 | in 329 | let res = insert tl value n in 330 | Node (dels, M.add hd res map) 331 | end 332 | 333 | let days_since_epoch (year, month, day) = 334 | (* following https://www.tondering.dk/claus/cal/julperiod.php#formula we 335 | compute the julian days of the provided date, and subtract the POSIX epoch 336 | from it. *) 337 | let open Int64 in 338 | let year = of_int year and month = of_int month and day = of_int day in 339 | let epoch = 2440588L in 340 | let a = div (sub 14L month) 12L in 341 | let y = sub (add year 4800L) a in 342 | let m = sub (add month (mul 12L a)) 3L in 343 | let m' = div (add (mul 153L m) 2L) 5L in 344 | let y' = mul 365L y in 345 | let y'' = div y 4L in 346 | let y''' = div y 100L in 347 | let y'''' = div y 400L in 348 | sub (sub (add (sub (add (add (add day m') y') y'') y''') y'''') 32045L) epoch 349 | 350 | let timestamp_to_int64 ts = 351 | let ( let* ) = Result.bind in 352 | let* date, time = 353 | Option.to_result 354 | ~none:"couldn't decode timestamp, missing 'T'" 355 | (String.cut 'T' ts) 356 | in 357 | let* date = 358 | match String.cuts '-' date with 359 | | [ year ; month ; day ] -> 360 | let* () = 361 | guard (String.length year = 4) 362 | "couldn't decode timestamp: year not 4 digits" 363 | in 364 | let* y, m, d = 365 | try Ok (int_of_string year, int_of_string month, int_of_string day) 366 | with 367 | Failure _ -> Error "couldn't decode timestamp: bad date (int_of_string)" 368 | in 369 | let* () = guard (m > 0 && m <= 12) "couldn't decode timestamp: bad month" in 370 | let* () = guard (d > 0 && d <= 31) "couldn't decode timestamp: bad day" in 371 | Ok (y, m, d) 372 | | _ -> Error "couldn't decode timestamp: date not a triple" 373 | in 374 | let* s = 375 | let* time, offset = 376 | match String.cut 'Z' time with 377 | | Some (time, "") -> Ok (time, 0L) 378 | | Some (_, _) -> 379 | Error "couldn't decode timestamp: bad time offset ('Z' at arbitrary position)" 380 | | None -> 381 | let* time, sign, offset = 382 | match String.cut '+' time, String.cut '-' time with 383 | | None, None -> Error "couldn't decode timestamp: no offset present" 384 | | Some _, Some _ -> Error "couldn't decode timestamp: both '+' and '-' present" 385 | | Some (time, off), None -> Ok (time, 1L, off) 386 | | None, Some (time, off) -> Ok (time, -1L, off) 387 | in 388 | let* off = 389 | let* h, m = 390 | Option.to_result ~none:"couldn't decode timestamp: bad offset" 391 | (String.cut ':' offset) 392 | in 393 | let* h, m = 394 | try Ok (int_of_string h, int_of_string m) with 395 | Failure _ -> Error "couldn't decode timestamp: offset not a number" 396 | in 397 | let* () = 398 | guard (h >= 0 && h <= 23) 399 | "couldn't decode timestamp: offset hour out of range" 400 | in 401 | let* () = 402 | guard (m >= 0 && m <= 59) 403 | "couldn't decode timestamp: offset minute out of range" 404 | in 405 | Ok Int64.(mul (add (mul (of_int h) 60L) (of_int m)) 60L) 406 | in 407 | Ok (time, Int64.mul sign off) 408 | in 409 | let* s = 410 | match String.cuts ':' time with 411 | | [ hour ; minute ; second ] -> 412 | let* h, m, s = 413 | try Ok (int_of_string hour, int_of_string minute, int_of_string second) 414 | with 415 | Failure _ -> Error "couldn't decode timestamp: bad date (int_of_string)" 416 | in 417 | let* () = guard (h >= 0 && h <= 23) "couldn't decode timestamp: bad hour" in 418 | let* () = guard (m >= 0 && m <= 59) "couldn't decode timestamp: bad minute" in 419 | let* () = guard (s >= 0 && s <= 60) "couldn't decode timestamp: bad second" in 420 | Ok Int64.(add (mul (add (mul (of_int h) 60L) (of_int m)) 60L) (of_int s)) 421 | | _ -> Error "couldn't decode timestamp: bad time" 422 | in 423 | Ok (Int64.add s offset) 424 | in 425 | let seconds_in_a_day = 86400L in (* 24 * 60 * 60 *) 426 | let r = Int64.(add (mul (days_since_epoch date) seconds_in_a_day) s) in 427 | let* () = guard (r > 0L) "couldn't decode timestamp: negative" in 428 | Ok r 429 | -------------------------------------------------------------------------------- /src/conex_utils.mli: -------------------------------------------------------------------------------- 1 | 2 | (** String, unsigned integers, logging, collections, and more *) 3 | 4 | (** {1 Sets, Maps, List utils} *) 5 | 6 | (** [S] is a string set. *) 7 | module S : sig 8 | (** {1 String sets} *) 9 | include Set.S with type elt = string 10 | 11 | (** [of_list xs] transforms the string list [xs] to a set. *) 12 | val of_list : string list -> t 13 | 14 | (** [pp fmt t] pretty prints [t]. *) 15 | val pp : Format.formatter -> t -> unit 16 | end 17 | 18 | (** [M] is a [Map] which keys are strings. *) 19 | module M : sig 20 | 21 | (** {1 String maps} *) 22 | include Map.S with type key = string 23 | 24 | (** [pp pp_e fmt t] pretty prints [t] using [pp_e] for printing the values. *) 25 | val pp : (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a t -> unit 26 | end 27 | 28 | (** [filter_map f xs] is [xs'], a list which contains all elements where [f] 29 | resulted in [Some _]. *) 30 | val filter_map : f:('a -> 'b option) -> 'a list -> 'b list 31 | 32 | (** {1 Format} *) 33 | 34 | (** ['a fmt] is the signature for pretty printers. *) 35 | type 'a fmt = Format.formatter -> 'a -> unit 36 | 37 | (** [pp_list pp] is a pretty printer for a list (surrounded by square brackets, 38 | elements are separated by semicolon). The [pp] is be a pretty printer for 39 | list elements. *) 40 | val pp_list : 'a fmt -> 'a list fmt 41 | 42 | (** [str_pp pp a] results in a string applying the pretty-printer to the value. *) 43 | val str_pp : 'a fmt -> 'a -> string 44 | 45 | (** {1 Result combinators} *) 46 | 47 | (** [guard pred err] is either [Ok ()] (if [pred] holds), [Error err] otherwise. *) 48 | val guard : bool -> 'a -> (unit, 'a) result 49 | 50 | (** [foldM f a xs] applies [f] to each element of [xs], returns either [Ok] and 51 | the produced value, or [Error]. *) 52 | val foldM : ('a -> 'b -> ('a, 'c) result) -> 'a -> 'b list -> ('a, 'c) result 53 | 54 | (** [iterM f xs] applies [f] to each element of [xs], returns either [Ok] and 55 | the produced value, or [Error]. *) 56 | val iterM : ('a -> (unit, 'b) result) -> 'a list -> (unit, 'b) result 57 | 58 | (** [foldS f a s] applies [f] to each element of the set [s], returns either 59 | [Ok] and the produced value, or [Error]. *) 60 | val foldS : ('a -> string -> ('a, 'c) result) -> 'a -> S.t -> ('a, 'c) result 61 | 62 | (** [err_to_str pp res] is either [Ok a] or [Error str] where [str] was produced 63 | by {!str_pp}. *) 64 | val err_to_str : 'b fmt -> ('a, 'b) result -> ('a, string) result 65 | 66 | 67 | (** {1 String} *) 68 | 69 | (** Some [String] utilities implemented here to avoid external 70 | dependencies. This is a subset of 71 | {{:http://erratique.ch/software/astring}Astring}. *) 72 | module String : sig 73 | 74 | (** Our string type is an OCaml [string] *) 75 | type t = string 76 | 77 | (** [cuts sep str] separates [str] into multiple substrings, stripping out the 78 | separating character [sep]. [String.concat "/" (String.cuts '/' xs)] is 79 | the identity. *) 80 | val cuts : char -> t -> t list 81 | 82 | (** [cut sep str] cuts the string [str] at the first occurence of [sep] into 83 | its left and right parts. If [sep] is not found, [None] is returned. 84 | If [Some (a, b)] is returned, [a ^ sep ^ b] is equal to [str]. *) 85 | val cut : char -> t -> (t * t) option 86 | 87 | (** [is_prefix ~prefix str] is [true] if [str] begins with [prefix], [false] 88 | otherwise. *) 89 | val is_prefix : prefix:t -> t -> bool 90 | 91 | (** [is_suffix ~suffix str] is [true] if [str] ends with [suffix], [false] 92 | otherwise. *) 93 | val is_suffix : suffix:t -> t -> bool 94 | 95 | (** [slice ~start ~stop str] slices [str] into a smaller piece, starting at 96 | offset [start] (default 0), ending at [stop] (default [String.length]). *) 97 | val slice : ?start:int -> ?stop:int -> t -> t 98 | 99 | (** [to_lower str] converts all printable ASCII characters to lowercase. *) 100 | val to_lower : t -> t 101 | 102 | (** [is_ascii ~p str] is [true] if all characters in [str] are ASCII 103 | characters: 0-9, a-z, A-Z OR satisfy [p]. Otherwise [false]. *) 104 | val is_ascii : ?p:(char -> bool) -> t -> bool 105 | 106 | (** [trim str] removes leading and trailing whitespaces of [str]. *) 107 | val trim : t -> t 108 | 109 | (** [get str offset] retrieves the character at [offset] in [str]. *) 110 | val get : t -> int -> char 111 | 112 | (** [concat sep xs] concatenates all [xs], using [sep] as separator. *) 113 | val concat : t -> t list -> t 114 | 115 | (** [compare a b] compares [a] with [b] using [String.compare]. *) 116 | val compare : t -> t -> int 117 | 118 | (** [length str] is the byte length of [str]. *) 119 | val length : t -> int 120 | 121 | (** [compare_insensitive a b] first converts [a] and [b] to lowercase strings, 122 | then uses [compare]. *) 123 | val compare_insensitive : t -> t -> int 124 | 125 | (** [equal a b] is [String.equal a b]. *) 126 | val equal : t -> t -> bool 127 | 128 | (** [get_uint8 str offset] retrieves the byte at [offset] in [str]. *) 129 | val get_uint8 : t -> int -> int 130 | end 131 | 132 | (** {1 Unsigned integers} *) 133 | 134 | (** 64 bit unsigned integer with explicit overflow behaviour (see 135 | {!Uint.succ}). *) 136 | module Uint : sig 137 | 138 | (** A 64 bit unsigned integer (using a [int64]). *) 139 | type t 140 | 141 | (** [zero] is the smallest member. *) 142 | val zero : t 143 | 144 | (** [compare a b] is [res]: 0 if [a = b], -1 if [a < b], 1 if [a > b] *) 145 | val compare : t -> t -> int 146 | 147 | (** [succ t] is [carry, next]: if [carry] is true, an overflow happened. 148 | [next] is always the next integer in the [Z/2^64-1Z] group. *) 149 | val succ : t -> bool * t 150 | 151 | (** [to_string t] is [t] converted to a string in hexadecimal ([0x%LX]). *) 152 | val to_string : t -> string 153 | 154 | (** [pp] is a pretty printer *) 155 | val pp : t fmt 156 | 157 | (** [decimal t] is [t] converted to a string in decimal ([%Lu]). *) 158 | val decimal : t -> string 159 | 160 | (** [of_string s] attempts to parse the string [s] as hexadecimal encoded 161 | number using [Int64.of_string s]. *) 162 | val of_string : string -> t option 163 | 164 | (** [of_float f] is [Int64.of_float f] if [f >= 0.0]. *) 165 | val of_float : float -> t option 166 | 167 | (** [of_int i] is [Int64.of_int i] if [i >= 0]. *) 168 | val of_int : int -> t option 169 | 170 | (** [of_int_exn i] is [Int64.of_int i] if [i >= 0]. 171 | @raise [Invalid_argument] on failure. *) 172 | val of_int_exn : int -> t 173 | end 174 | 175 | (** [Uint_map] is a [Map] which keys are Uint.t. *) 176 | module Uint_map : sig 177 | 178 | (** {1 String maps} *) 179 | include Map.S with type key = Uint.t 180 | end 181 | 182 | (** {1 Logging} *) 183 | 184 | (** [LOGS] is a subset of the {{:http://erratique.ch/software/logs}Logs} 185 | library, providing four log streams. *) 186 | module type LOGS = sig 187 | 188 | (** Tag, as in logs *) 189 | module Tag : sig type set end 190 | 191 | (** msgf *) 192 | type ('a, 'b) msgf = 193 | (?header:string -> ?tags:Tag.set -> 194 | ('a, Format.formatter, unit, 'b) format4 -> 'a) -> 'b 195 | type 'a log = ('a, unit) msgf -> unit 196 | 197 | type src 198 | 199 | (** [warn_count ()] is the number of warning messages. *) 200 | val warn_count : unit -> int 201 | 202 | (** [debug k] logs [k], a to the debug stream *) 203 | val debug : ?src:src -> 'a log 204 | 205 | (** [info k] logs [k], a to the information stream *) 206 | val info : ?src:src -> 'a log 207 | 208 | (** [warn k] logs [k], a to the warning stream *) 209 | val warn : ?src:src -> 'a log 210 | end 211 | 212 | (** {1 File system types} *) 213 | 214 | (** The sum type of possible file types we expect *) 215 | type file_type = File | Directory 216 | 217 | (** A [path] is a list of strings *) 218 | type path = string list 219 | 220 | (** [root] is the root path. *) 221 | val root : path 222 | 223 | (** [path_to_string path] is {{!Conex_utils.String.concat}String.concat} ["/" 224 | path]. 225 | @raise [Invalid_argument] if [path] includes either "." or "..". *) 226 | val path_to_string : path -> string 227 | 228 | (** [string_to_path str] is {{!Conex_utils.String.cuts}String.cuts} ["/" 229 | str] and ensuring no empty segments, ".", or ".." be present. If [str] 230 | contains a leading "/", it is discarded. *) 231 | val string_to_path : string -> (path, string) result 232 | 233 | (** [string_to_path_exb str] is {{!Conex_utils.String.cuts}String.cuts} ["/" 234 | str] and ensuring no empty segments, ".", or ".." be present. If [str] 235 | contains a leading "/", it is discarded. 236 | @raise [Invalid_argument] if [path] is invalid. *) 237 | val string_to_path_exn : string -> path 238 | 239 | (** [path_equal p p'] is [true] if [p] and [p'] are equal. *) 240 | val path_equal : path -> path -> bool 241 | 242 | (** [subpath ~parent p] is [true] if [p] starts with all segments of [parent]. *) 243 | val subpath : parent:path -> path -> bool 244 | 245 | (** [pp_path] is a pretty printer for a path. *) 246 | val pp_path : path fmt 247 | 248 | (** An [item] is a type and its payload *) 249 | type item = file_type * string 250 | 251 | (** {1 Tree} *) 252 | 253 | (** [Tree] is a simple tree datatype, edge is a [string], values are ['a lists]. *) 254 | module Tree : sig 255 | 256 | (** The main tree type *) 257 | type 'a t 258 | 259 | (** [equal eq a b] compares [a] with [b], using [eq] to compare values. *) 260 | val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool 261 | 262 | (** [empty] is the only constructor of a tree. *) 263 | val empty : 'a t 264 | 265 | val is_empty : 'a t -> bool 266 | 267 | val sub : path -> 'a t -> 'a t 268 | 269 | (** [fold f acc t] folds [f] over [t], using the accumulator [acc]. *) 270 | val fold : (path -> 'a list -> 'b -> 'b) -> 'b -> 'a t -> 'b 271 | 272 | (** [pp pp_e ppf t] pretty prints the tree [t] using [pp_e] for printing values. *) 273 | val pp : (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a t -> unit 274 | 275 | (** [lookup path t] returns either [Some values] or [None]. *) 276 | val lookup : path -> 'a t -> 'a list option 277 | 278 | (** [lookup_prefix path t] finds the closest non-empty ['a] on [path]. *) 279 | val lookup_prefix : path -> 'a t -> 'a list 280 | 281 | (** [insert path value t] inserts [value] into [t] at [path]. If the key is 282 | already in the tree, its value is prepended. *) 283 | val insert : path -> 'a -> 'a t -> 'a t 284 | end 285 | 286 | (** [timestamp_to_int64 timestamp] attempts to convert the provided RFC 3339 287 | timestamp to an int64 representing the seconds since Unix epoch 288 | (1970-01-01). When decoding leads to an error, or the timestamp is not in 289 | range (of the int64), an error message is returned. *) 290 | val timestamp_to_int64 : string -> (int64, string) result 291 | -------------------------------------------------------------------------------- /src/conex_verify.ml: -------------------------------------------------------------------------------- 1 | open Conex_utils 2 | open Conex_resource 3 | 4 | type error = [ 5 | | `UnknownKey of identifier 6 | | `InvalidBase64Encoding of identifier 7 | | `InvalidSignature of identifier 8 | | `InvalidPublicKey of identifier 9 | ] 10 | 11 | let pp_error ppf = function 12 | | `UnknownKey id -> Format.fprintf ppf "unknown public key %a" pp_id id 13 | | `InvalidBase64Encoding id -> Format.fprintf ppf "signature %a: no valid base64 encoding" pp_id id 14 | | `InvalidSignature id -> Format.fprintf ppf "invalid signature %a" pp_id id 15 | | `InvalidPublicKey id -> Format.fprintf ppf "invalid public key %a" pp_id id 16 | [@@coverage off] 17 | 18 | module type S_RSA_BACK = sig 19 | val verify_rsa_pss : key:string -> data:string -> signature:string -> identifier -> (unit, [> error ]) result 20 | 21 | val sha256 : string -> string 22 | end 23 | 24 | module type S = sig 25 | val raw_digest : string -> Digest.t 26 | 27 | val digest : Wire.t -> Digest.t 28 | 29 | val verify : Wire.t -> Key.t M.t -> Signature.t M.t -> 30 | identifier Digest_map.t * error list 31 | end 32 | 33 | (** Instantiation. *) 34 | module Make (C : S_RSA_BACK) = struct 35 | 36 | let raw_digest data = `SHA256, C.sha256 data 37 | 38 | let digest data = raw_digest (Wire.to_string data) 39 | 40 | let verify_signature data key (id, created, alg, signature) = 41 | match alg, key with 42 | | `RSA_PSS_SHA256, (_, _, `RSA, key) -> 43 | let data = Wire.to_string (to_be_signed data created id alg) in 44 | C.verify_rsa_pss ~key ~data ~signature id 45 | 46 | (* using a digest map here to uniquify the public keys! *) 47 | let verify data keys sigs = 48 | M.fold (fun _ (id, created, alg, s) (ok, err) -> 49 | match M.find_opt id keys with 50 | | None -> (ok, `UnknownKey id :: err) 51 | | Some key -> 52 | match verify_signature data key (id, created, alg, s) with 53 | | Ok () -> 54 | let dgst = Key.keyid raw_digest key in 55 | (Digest_map.add dgst id ok, err) 56 | | Error e -> (ok, e :: err)) 57 | sigs (Digest_map.empty, []) 58 | end 59 | -------------------------------------------------------------------------------- /src/conex_verify.mli: -------------------------------------------------------------------------------- 1 | (** Verification primitives 2 | 3 | Implementations are provided in {!Conex_mirage_crypto} and {!Conex_openssl}. *) 4 | 5 | open Conex_utils 6 | open Conex_resource 7 | 8 | (** Potential error case when verifying a signature *) 9 | type error = [ 10 | | `UnknownKey of identifier 11 | | `InvalidBase64Encoding of identifier 12 | | `InvalidSignature of identifier 13 | | `InvalidPublicKey of identifier 14 | ] 15 | 16 | (** [pp_error] is a pretty printer for [verification_error]. *) 17 | val pp_error : error fmt 18 | 19 | (** The verification module type *) 20 | module type S = sig 21 | 22 | (** [raw_digest str] is the digest of the given [str]. *) 23 | val raw_digest : string -> Digest.t 24 | 25 | (** [digest wire] is the digest of the {{!Conex_resource.Wire.to_string}string 26 | encoding} of [wire]. *) 27 | val digest : Wire.t -> Digest.t 28 | 29 | (** [verify wire keys sigs] is the set of valid signatures and errors *) 30 | val verify : Wire.t -> Key.t M.t -> Signature.t M.t -> 31 | identifier Digest_map.t * error list 32 | end 33 | 34 | (** The verification backend, to be implemented by a crypto provider *) 35 | module type S_RSA_BACK = sig 36 | 37 | (** [verify_rsa_pss ~key ~data ~signature] returns [Ok ()] on success, 38 | otherwise a [verification_error]. Currently, SHA256 is used as hash 39 | algorithm. *) 40 | val verify_rsa_pss : key:string -> data:string -> signature:string -> identifier -> 41 | (unit, [> error ]) result 42 | 43 | (** [sha356 str] computes the SHA256 digest of [str] and converts it to 44 | hex. *) 45 | val sha256 : string -> string 46 | end 47 | 48 | (** Instantiation. *) 49 | module Make (C : S_RSA_BACK) : S 50 | -------------------------------------------------------------------------------- /src/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name conex) 3 | (public_name conex) 4 | (wrapped false) 5 | (instrumentation (backend bisect_ppx)) 6 | (libraries opam-file-format)) 7 | -------------------------------------------------------------------------------- /test/common.ml: -------------------------------------------------------------------------------- 1 | open Conex_utils 2 | open Conex_resource 3 | 4 | module FS = struct 5 | let data = Hashtbl.create 3 6 | 7 | let ids () = Hashtbl.fold (fun k _ acc -> k :: acc) data [] 8 | let read _ id = match Hashtbl.find data id with 9 | | exception Not_found -> Error "not found" 10 | | v -> Ok (v, "") 11 | let write k v = Hashtbl.add data k v ; Ok () 12 | end 13 | 14 | module PRIV = Conex_private.Make(Conex_mirage_crypto.C)(FS) 15 | 16 | let sset = 17 | let module M = struct 18 | type t = S.t 19 | let pp = S.pp 20 | let equal = S.equal 21 | end in 22 | (module M: Alcotest.TESTABLE with type t = M.t) 23 | 24 | let privkey = ref None 25 | 26 | let gen_pub () = 27 | let priv = match !privkey with 28 | | Some p -> p 29 | | None -> 30 | match PRIV.generate ~bits:2048 (fun _ -> Some "") `RSA "foo" () with 31 | | Error e -> Alcotest.fail e 32 | | Ok p -> 33 | privkey := Some p ; 34 | p 35 | in 36 | let pub = PRIV.pub_of_priv priv in 37 | (pub, priv) 38 | 39 | let result (type a) (type e) a e = 40 | let (module A: Alcotest.TESTABLE with type t = a) = a in 41 | let (module E: Alcotest.TESTABLE with type t = e) = e in 42 | let module M = struct 43 | type t = (a, e) result 44 | let pp fmt t = match t with 45 | | Ok t -> Format.fprintf fmt "Ok @[(%a)@]" A.pp t 46 | | Error e -> Format.fprintf fmt "Error @[(%a)@]" E.pp e 47 | let equal x y = match x, y with 48 | | Ok x, Ok y -> A.equal x y 49 | | Error x, Error y -> E.equal x y 50 | | _ , _ -> false 51 | end in 52 | (module M: Alcotest.TESTABLE with type t = M.t) 53 | 54 | let str_err = 55 | let module M = struct 56 | type t = string 57 | let pp ppf x = Format.pp_print_string ppf x 58 | let equal _ _ = true 59 | end in 60 | (module M : Alcotest.TESTABLE with type t = M.t) 61 | 62 | let r_err = 63 | let module M = struct 64 | type t = err 65 | let pp = pp_err 66 | let equal a b = match a, b with 67 | | `Parse _, `Parse _ -> true 68 | | `Unknown_alg _, `Unknown_alg _ -> true 69 | | `Malformed, `Malformed -> true 70 | | _ -> false 71 | end in 72 | (module M : Alcotest.TESTABLE with type t = M.t) 73 | -------------------------------------------------------------------------------- /test/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name tests) 3 | (package conex-mirage-crypto) 4 | (libraries conex conex-mirage-crypto conex.openssl alcotest mirage-crypto-rng.unix)) 5 | -------------------------------------------------------------------------------- /test/test_path.ml: -------------------------------------------------------------------------------- 1 | open Conex_utils 2 | 3 | open Common 4 | 5 | let p = 6 | let module M = struct 7 | type t = path 8 | let pp = pp_path 9 | let equal = path_equal 10 | end in 11 | (module M: Alcotest.TESTABLE with type t = M.t) 12 | 13 | let of_string () = 14 | Alcotest.check (result p str_err) "of_string foo/bar works" 15 | (Ok [ "foo" ; "bar" ]) (string_to_path "foo/bar") ; 16 | Alcotest.check (result p str_err) "of_string /foo/bar works" 17 | (Ok [ "foo" ; "bar" ]) (string_to_path "/foo/bar") ; 18 | Alcotest.check (result p str_err) "of_string foo//bar results in error" 19 | (Error "") (string_to_path "foo//bar") ; 20 | Alcotest.check (result p str_err) "of_string foo/./bar results in error" 21 | (Error "") (string_to_path "foo/./bar") ; 22 | Alcotest.check (result p str_err) "of_string foo/../bar results in error" 23 | (Error "") (string_to_path "foo/../bar") 24 | 25 | let subpath () = 26 | Alcotest.(check bool "subpath ~parent:[] ['a';'b'] works" 27 | true (subpath ~parent:[] ["a";"b"])) ; 28 | Alcotest.(check bool "subpath ~parent:['a'] ['a';'b'] works" 29 | true (subpath ~parent:["a"] ["a";"b"])) ; 30 | Alcotest.(check bool "subpath ~parent:['a';'b'] ['a';'b'] is false" 31 | false (subpath ~parent:["a";"b"] ["a";"b"])) ; 32 | Alcotest.(check bool "subpath ~parent:['a';'b'] ['a'] is false" 33 | false (subpath ~parent:["a";"b"] ["a"])) ; 34 | Alcotest.(check bool "subpath ~parent:['a'] ['b'] is false" 35 | false (subpath ~parent:["a"] ["b"])) ; 36 | Alcotest.(check bool "subpath ~parent:['a';'b'] ['a';'c'] is false" 37 | false (subpath ~parent:["a";"b"] ["a";"c"])) 38 | 39 | let tests = [ 40 | "of_string path", `Quick, of_string ; 41 | "subpath", `Quick, subpath ; 42 | ] 43 | -------------------------------------------------------------------------------- /test/test_provider.ml: -------------------------------------------------------------------------------- 1 | open Conex_utils 2 | open Conex_io 3 | 4 | open Common 5 | 6 | let ( let* ) = Result.bind 7 | 8 | module Mem = struct 9 | type tree = Leaf of string * string | Node of string * tree list 10 | 11 | let name = function Leaf (x, _) -> x | Node (x, _) -> x 12 | 13 | let find_e x es = 14 | try Some (List.find (fun n -> name n = x) es) with Not_found -> None 15 | 16 | let rec find t path = 17 | match t, path with 18 | | x, [p] when name x = p -> Ok x 19 | | _, [_] -> Error "couldn't find what you were looking for" 20 | | Node (_, xs), _::p'::ps -> 21 | (match find_e p' xs with 22 | | None -> Error "not found what you're looking for" 23 | | Some x -> find x (p'::ps)) 24 | | _ -> Error "couldn't find" 25 | 26 | let rec insert t path v = 27 | match t, path with 28 | (* leaf case, just add the leaf *) 29 | | Node (x, xs), _::ps::[] -> 30 | let l = Leaf (ps, v) in 31 | let ns = List.filter (fun n -> name n <> ps) xs in 32 | Node (x, l::ns) 33 | (* on the route towards.. move along *) 34 | | Node (x, xs), _::p'::ps -> 35 | let node = 36 | match find_e p' xs with 37 | (* need to create an intermediary node *) 38 | | None -> 39 | let n = Node (p', []) in 40 | insert n (p'::ps) v 41 | (* follow on *) 42 | | Some n -> insert n (p'::ps) v 43 | in 44 | let xs = List.filter (fun n -> name n <> p') xs in 45 | Node (x, node::xs) 46 | | _ -> Alcotest.fail "should not happen" 47 | 48 | let find_f t path = find t ("/"::path) 49 | 50 | let ins t path v = insert t ("/"::path) v 51 | 52 | let mem_provider () : Conex_io.t = 53 | let root = ref (Node ("/", [])) in 54 | let file_type path = 55 | let* n = find_f !root path in 56 | match n with 57 | | Leaf _ -> Ok File 58 | | Node _ -> Ok Directory 59 | and read path = 60 | let* n = find_f !root path in 61 | match n with 62 | | Leaf (_, v) -> Ok v 63 | | _ -> Error "couldn't find what was searched for" 64 | and write path data = 65 | let r = ins !root path data in 66 | root := r ; 67 | Ok () 68 | and read_dir path = 69 | let* n = find_f !root path in 70 | match n with 71 | | Node (_, ch) -> Ok (List.map (function Node (x, _) -> Directory, x | Leaf (x, _) -> File, x) ch) 72 | | Leaf _ -> Error "reading a directory, but found files" 73 | and exists path = 74 | match find_f !root path with Ok _ -> true | Error _ -> false 75 | in 76 | { basedir = "mem" ; description = "Memory provider" ; file_type ; read ; write ;read_dir ; exists } 77 | end 78 | 79 | let str_err = 80 | let module M = struct 81 | type t = string 82 | let pp ppf x = Format.pp_print_string ppf x 83 | let equal _ _ = true 84 | end in 85 | (module M : Alcotest.TESTABLE with type t = M.t) 86 | 87 | let ft = 88 | let module M = struct 89 | type t = file_type 90 | let pp ppf = function 91 | | File -> Format.pp_print_string ppf "file" 92 | | Directory -> Format.pp_print_string ppf "directory" 93 | let equal a b = match a, b with 94 | | File, File -> true 95 | | Directory, Directory -> true 96 | | _ -> false 97 | end in 98 | (module M : Alcotest.TESTABLE with type t = M.t) 99 | 100 | let it = 101 | let module M = struct 102 | type t = Conex_utils.item 103 | let pp ppf = function 104 | | File, f -> Format.fprintf ppf "file %s" f 105 | | Directory, d -> Format.fprintf ppf "directory %s" d 106 | let equal a b = match a, b with 107 | | (File, f), (File, g) -> f = g 108 | | (Directory, a), (Directory, b) -> a = b 109 | | _ -> false 110 | end in 111 | (module M : Alcotest.TESTABLE with type t = M.t) 112 | 113 | let empty_p () = 114 | let p = Mem.mem_provider () in 115 | Alcotest.check Alcotest.bool "no 'foo' in empty mem store" false (p.exists ["foo"]) ; 116 | Alcotest.check (result Alcotest.string str_err) "reading 'foo' in empty mem store" (Error "") (p.read ["foo"]) ; 117 | Alcotest.check (result ft str_err) "file-type of 'foo' in empty mem store" (Error "") (p.file_type ["foo"]) ; 118 | Alcotest.check (result (Alcotest.list it) str_err) "read_dir of 'foo' in empty mem store" (Error "") (p.read_dir ["foo"]) 119 | 120 | let basic_p () = 121 | let p = Mem.mem_provider () in 122 | Alcotest.check (result Alcotest.unit str_err) "writing 'bar' to 'foo'" 123 | (Ok ()) (p.write ["foo"] "bar") ; 124 | Alcotest.check Alcotest.bool "foo in basic store" true (p.exists ["foo"]) ; 125 | Alcotest.check Alcotest.bool "foo/bar not in basic store" false (p.exists ["foo";"bar"]) ; 126 | Alcotest.check Alcotest.bool "foobar not in basic store" false (p.exists ["foobar"]) ; 127 | Alcotest.check (result Alcotest.string str_err) "foo contains bar in simple store" (Ok "bar") (p.read ["foo"]) ; 128 | Alcotest.check (result Alcotest.unit str_err) "writing 'barf' to 'foo" 129 | (Ok ()) (p.write ["foo"] "barf") ; 130 | Alcotest.check (result Alcotest.string str_err) "foo contains barf in simple store" (Ok "barf") (p.read ["foo"]) ; 131 | Alcotest.check (result (Alcotest.list it) str_err) "read_dir of 'foo' in simple store" (Error "") (p.read_dir ["foo"]) 132 | 133 | let more_p () = 134 | let p = Mem.mem_provider () in 135 | Alcotest.check (result Alcotest.unit str_err) "writing 'bar' to 'packages/foo'" 136 | (Ok ()) (p.write ["packages"; "foo"] "bar") ; 137 | Alcotest.check Alcotest.bool "packages in more store" true (p.exists ["packages"]) ; 138 | Alcotest.check Alcotest.bool "packages/foo in more store" true (p.exists ["packages"; "foo"]) ; 139 | Alcotest.check Alcotest.bool "packages/foo/bar not in more store" false (p.exists ["packages"; "foo"; "bar"]) ; 140 | Alcotest.check (result Alcotest.unit str_err) "writing 'bar2' to 'packages/foo2'" 141 | (Ok ()) (p.write ["packages"; "foo2"] "bar2") ; 142 | Alcotest.check (result (Alcotest.list it) str_err) "read_dir of 'packages' in more mem store" 143 | (Ok [ File, "foo2" ; File, "foo" ]) (p.read_dir ["packages"]) ; 144 | Alcotest.check (result Alcotest.unit str_err) "writing 'bar3' to 'packages/foo3'" 145 | (Ok ()) (p.write ["packages"; "foo3"] "bar3") ; 146 | Alcotest.check (result Alcotest.unit str_err) "writing 'bar4' to 'packages/foo4'" 147 | (Ok ()) (p.write ["packages"; "foo4"] "bar4") ; 148 | Alcotest.check (result (Alcotest.list it) str_err) "read_dir of 'packages' in even more mem store" 149 | (Ok [ File, "foo4" ; File, "foo3" ; File, "foo2" ; File, "foo" ]) (p.read_dir ["packages"]) ; 150 | Alcotest.check (result (Alcotest.list it) str_err) "read_dir of 'packages2' in even more mem store" 151 | (Error "") (p.read_dir ["packages2"]) ; 152 | Alcotest.check (result Alcotest.string str_err) "foo contains bar in more store" 153 | (Ok "bar") (p.read ["packages";"foo"]) ; 154 | Alcotest.check (result Alcotest.string str_err) "foo2 contains bar2 in more store" 155 | (Ok "bar2") (p.read ["packages"; "foo2"]) ; 156 | Alcotest.check (result Alcotest.string str_err) "foo3 contains bar3 in more store" 157 | (Ok "bar3") (p.read ["packages"; "foo3"]) ; 158 | Alcotest.check (result Alcotest.string str_err) "foo4 contains bar4 in more store" 159 | (Ok "bar4") (p.read ["packages"; "foo4"]) ; 160 | Alcotest.check (result Alcotest.string str_err) "foo5 not contained in more store" 161 | (Error "") (p.read ["packages"; "foo5"]) ; 162 | Alcotest.check (result Alcotest.unit str_err) "writing 'foobar' to 'packages/foobar/barfoo/foobar/foo'" 163 | (Ok ()) (p.write ["packages"; "foobar" ; "barfoo" ; "foobar" ; "foo"] "foobar") ; 164 | Alcotest.check (result Alcotest.string str_err) "packages/foobar/barfoo/foobar/foo contained in more store" 165 | (Ok "foobar") (p.read ["packages"; "foobar" ; "barfoo" ; "foobar" ; "foo"]) ; 166 | Alcotest.check Alcotest.bool "packages/foobar/barfoo/foobar contained in more store" 167 | true (p.exists ["packages"; "foobar" ; "barfoo" ; "foobar"]) 168 | 169 | let diff_test_create () = 170 | let p = Mem.mem_provider () in 171 | let diff = {| 172 | --- /dev/null 173 | +++ packages/foo 174 | @@ -0,0 +1 @@ 175 | +bar 176 | |} 177 | in 178 | let d, _ = Conex_diff_provider.apply_diff p diff in 179 | Alcotest.check Alcotest.bool __LOC__ 180 | true (d.exists ["packages" ; "foo"]) ; 181 | Alcotest.check (result (Alcotest.list it) str_err) __LOC__ 182 | (Ok [ Directory, "packages" ]) (d.read_dir []) ; 183 | Alcotest.check (result (Alcotest.list it) str_err) __LOC__ 184 | (Ok [ File, "foo" ]) (d.read_dir ["packages"]) ; 185 | Alcotest.check (result ft str_err) __LOC__ 186 | (Ok File) (d.file_type ["packages" ; "foo"]) ; 187 | Alcotest.check (result Alcotest.string str_err) __LOC__ 188 | (Ok "bar\n") (d.read ["packages" ; "foo"]) 189 | 190 | let diff_test_remove () = 191 | let p = Mem.mem_provider () in 192 | (match p.write ["packages" ; "foo" ] "bar\n" with 193 | | Ok () -> () 194 | | Error _ -> assert false) ; 195 | let diff = {| 196 | --- packages/foo 197 | +++ /dev/null 198 | @@ -1 +0,0 @@ 199 | -bar 200 | |} 201 | in 202 | let d, _ = Conex_diff_provider.apply_diff p diff in 203 | Alcotest.check Alcotest.bool __LOC__ 204 | false (d.exists ["packages" ; "foo"]) ; 205 | Alcotest.check (result (Alcotest.list it) str_err) __LOC__ 206 | (Ok []) (d.read_dir ["packages"]) ; 207 | Alcotest.check (result ft str_err) __LOC__ 208 | (Error "") (d.file_type ["packages" ; "foo"]) ; 209 | Alcotest.check (result Alcotest.string str_err) __LOC__ 210 | (Error "") (d.read ["packages" ; "foo"]) 211 | 212 | let diff_test_rename () = 213 | let p = Mem.mem_provider () in 214 | (match p.write ["packages" ; "foo" ] "bar\n" with 215 | | Ok () -> () 216 | | Error _ -> assert false) ; 217 | let diff = {| 218 | --- packages/foo 219 | +++ packages/bar 220 | @@ -1 +1 @@ 221 | -bar 222 | +foobar 223 | |} 224 | in 225 | let d, _ = Conex_diff_provider.apply_diff p diff in 226 | Alcotest.check Alcotest.bool __LOC__ 227 | false (d.exists ["packages" ; "foo"]) ; 228 | Alcotest.check Alcotest.bool __LOC__ 229 | true (d.exists ["packages" ; "bar"]) ; 230 | Alcotest.check (result (Alcotest.list it) str_err) __LOC__ 231 | (Ok [ File, "bar" ]) (d.read_dir ["packages"]) ; 232 | Alcotest.check (result ft str_err) __LOC__ 233 | (Error "") (d.file_type ["packages" ; "foo"]) ; 234 | Alcotest.check (result ft str_err) __LOC__ 235 | (Ok File) (d.file_type ["packages" ; "bar"]) ; 236 | Alcotest.check (result Alcotest.string str_err) __LOC__ 237 | (Error "") (d.read ["packages" ; "foo"]) ; 238 | Alcotest.check (result Alcotest.string str_err) __LOC__ 239 | (Ok "foobar\n") (d.read ["packages" ; "bar"]) 240 | 241 | let diff_test_edit () = 242 | let p = Mem.mem_provider () in 243 | (match p.write ["packages" ; "foo" ] "bar\n" with 244 | | Ok () -> () 245 | | Error _ -> assert false) ; 246 | let diff = {| 247 | --- packages/foo 248 | +++ packages/foo 249 | @@ -1 +1 @@ 250 | -bar 251 | +foobar 252 | |} 253 | in 254 | let d, _ = Conex_diff_provider.apply_diff p diff in 255 | Alcotest.check Alcotest.bool __LOC__ 256 | true (d.exists ["packages" ; "foo"]) ; 257 | Alcotest.check Alcotest.bool __LOC__ 258 | false (d.exists ["packages" ; "bar"]) ; 259 | Alcotest.check (result (Alcotest.list it) str_err) __LOC__ 260 | (Ok [ File, "foo" ]) (d.read_dir ["packages"]) ; 261 | Alcotest.check (result ft str_err) __LOC__ 262 | (Error "") (d.file_type ["packages" ; "bar"]) ; 263 | Alcotest.check (result ft str_err) __LOC__ 264 | (Ok File) (d.file_type ["packages" ; "foo"]) ; 265 | Alcotest.check (result Alcotest.string str_err) __LOC__ 266 | (Error "") (d.read ["packages" ; "bar"]) ; 267 | Alcotest.check (result Alcotest.string str_err) __LOC__ 268 | (Ok "foobar\n") (d.read ["packages" ; "foo"]) 269 | 270 | let diff_test_complex () = 271 | let p = Mem.mem_provider () in 272 | (match p.write ["packages" ; "foo" ] "bar\n" with 273 | | Ok () -> () 274 | | Error _ -> assert false) ; 275 | (match p.write ["packages" ; "foobar" ] "baz\n" with 276 | | Ok () -> () 277 | | Error _ -> assert false) ; 278 | (match p.write ["packages" ; "foobarbaz" ] "foobarbaz\n" with 279 | | Ok () -> () 280 | | Error _ -> assert false) ; 281 | (match p.write ["packages" ; "staying" ] "data\n" with 282 | | Ok () -> () 283 | | Error _ -> assert false) ; 284 | Alcotest.check (result (Alcotest.list it) str_err) __LOC__ 285 | (Ok [ File, "staying" ; File, "foobarbaz" ; File, "foobar" ; File, "foo" ]) 286 | (p.read_dir ["packages"]); 287 | let diff = {| 288 | --- packages/foo 289 | +++ packages/bar 290 | @@ -1 +1 @@ 291 | -bar 292 | +foobar 293 | --- packages/foobar 294 | +++ /dev/null 295 | @@ -1 +0,0 @@ 296 | -baz 297 | --- /dev/null 298 | +++ packages/baz 299 | @@ -0,0 +1 @@ 300 | +baz 301 | --- packages/foobarbaz 302 | +++ packages/foobarbaz 303 | @@ -1 +1 @@ 304 | -foobarbaz 305 | +foobar 306 | |} 307 | in 308 | let d, _diffs = Conex_diff_provider.apply_diff p diff in 309 | Alcotest.check (result (Alcotest.list it) str_err) __LOC__ 310 | (Ok [ File, "bar" ; File, "baz" ; File, "foobarbaz" ; File, "staying" ]) 311 | (d.read_dir ["packages"]) ; 312 | Alcotest.check Alcotest.bool __LOC__ false (d.exists ["packages" ; "foo"]) ; 313 | Alcotest.check Alcotest.bool __LOC__ false (d.exists ["packages" ; "foobar"]) ; 314 | Alcotest.check Alcotest.bool __LOC__ true (d.exists ["packages" ; "foobarbaz"]) ; 315 | Alcotest.check Alcotest.bool __LOC__ true (d.exists ["packages" ; "staying"]) ; 316 | Alcotest.check Alcotest.bool __LOC__ true (d.exists ["packages" ; "baz"]) ; 317 | Alcotest.check Alcotest.bool __LOC__ true (d.exists ["packages" ; "bar"]) ; 318 | Alcotest.check (result ft str_err) __LOC__ (Error "") (d.file_type ["packages" ; "foo"]) ; 319 | Alcotest.check (result ft str_err) __LOC__ (Error "") (d.file_type ["packages" ; "foobar"]) ; 320 | Alcotest.check (result ft str_err) __LOC__ (Ok File) (d.file_type ["packages" ; "foobarbaz"]) ; 321 | Alcotest.check (result ft str_err) __LOC__ (Ok File) (d.file_type ["packages" ; "staying"]) ; 322 | Alcotest.check (result ft str_err) __LOC__ (Ok File) (d.file_type ["packages" ; "baz"]) ; 323 | Alcotest.check (result ft str_err) __LOC__ (Ok File) (d.file_type ["packages" ; "bar"]) ; 324 | Alcotest.check (result Alcotest.string str_err) __LOC__ (Error "") (d.read ["packages" ; "foo"]) ; 325 | Alcotest.check (result Alcotest.string str_err) __LOC__ (Error "") (d.read ["packages" ; "foobar"]) ; 326 | Alcotest.check (result Alcotest.string str_err) __LOC__ (Ok "foobar\n") (d.read ["packages" ; "foobarbaz"]) ; 327 | Alcotest.check (result Alcotest.string str_err) __LOC__ (Ok "data\n") (d.read ["packages" ; "staying"]) ; 328 | Alcotest.check (result Alcotest.string str_err) __LOC__ (Ok "baz\n") (d.read ["packages" ; "baz"]) ; 329 | Alcotest.check (result Alcotest.string str_err) __LOC__ (Ok "foobar\n") (d.read ["packages" ; "bar"]) 330 | 331 | let tests = [ 332 | "empty provider", `Quick, empty_p ; 333 | "basic provider", `Quick, basic_p ; 334 | "more provider", `Quick, more_p ; 335 | "diff provider create", `Quick, diff_test_create ; 336 | "diff provider remove", `Quick, diff_test_remove ; 337 | "diff provider rename", `Quick, diff_test_rename ; 338 | "diff provider edit", `Quick, diff_test_edit ; 339 | "diff provider complex", `Quick, diff_test_complex ; 340 | ] 341 | -------------------------------------------------------------------------------- /test/test_string.ml: -------------------------------------------------------------------------------- 1 | 2 | (* String.concat "/" (String.cuts '/' xs) == xs *) 3 | let basic_cuts () = 4 | let sep = '/' 5 | and j = "/" 6 | and data = "" 7 | in 8 | Alcotest.(check string __LOC__ data 9 | (String.concat j (Conex_utils.String.cuts sep data))); 10 | let data = "foo" in 11 | Alcotest.(check string __LOC__ data 12 | (String.concat j (Conex_utils.String.cuts sep data))); 13 | let data = "///" in 14 | Alcotest.(check string __LOC__ data 15 | (String.concat j (Conex_utils.String.cuts sep data))); 16 | let data = "foo/bar/baz" in 17 | Alcotest.(check string __LOC__ data 18 | (String.concat j (Conex_utils.String.cuts sep data))); 19 | let data = "foo//bar///baz" in 20 | Alcotest.(check string __LOC__ data 21 | (String.concat j (Conex_utils.String.cuts sep data))); 22 | let data = "/foo/bar/baz/" in 23 | Alcotest.(check string __LOC__ data 24 | (String.concat j (Conex_utils.String.cuts sep data))); 25 | let data = "/foo//bar//baz/" in 26 | Alcotest.(check string __LOC__ data 27 | (String.concat j (Conex_utils.String.cuts sep data))) 28 | 29 | let tests = [ 30 | "basic cuts is good", `Quick, basic_cuts ; 31 | ] 32 | -------------------------------------------------------------------------------- /test/test_tree.ml: -------------------------------------------------------------------------------- 1 | open Conex_utils 2 | 3 | let t = 4 | let module M = struct 5 | type t = string Tree.t 6 | let pp = Tree.pp Format.pp_print_string 7 | let equal = Tree.equal (fun a b -> String.compare a b = 0) 8 | end in 9 | (module M: Alcotest.TESTABLE with type t = M.t) 10 | 11 | let lookp = Alcotest.(list string) 12 | let look = Alcotest.option lookp 13 | 14 | let basic_test () = 15 | Alcotest.check t "empty is really empty" 16 | Tree.empty Tree.empty ; 17 | Alcotest.check look "lookup for root in empty is Some []" 18 | (Some []) (Tree.lookup [] Tree.empty) ; 19 | Alcotest.check lookp "lookup_prefix for root in empty is []" 20 | [] (Tree.lookup_prefix [] Tree.empty) ; 21 | Alcotest.check look "lookup for foo in empty is None" 22 | None (Tree.lookup ["foo"] Tree.empty) ; 23 | Alcotest.check lookp "lookup_prefix for foo in empty is []" 24 | [] (Tree.lookup_prefix ["foo"] Tree.empty) ; 25 | let t = Tree.insert ["foo"] "abc" Tree.empty in 26 | Alcotest.check look "lookup for foo in tree with foo is abc" 27 | (Some ["abc"]) (Tree.lookup ["foo"] t) ; 28 | Alcotest.check lookp "lookup_prefix for foo in tree with foo is abc" 29 | ["abc"] (Tree.lookup_prefix ["foo"] t) ; 30 | Alcotest.check lookp "lookup_prefix for foo/bar in tree with foo is abc" 31 | ["abc"] (Tree.lookup_prefix ["foo";"bar"] t) ; 32 | Alcotest.check look "lookup for bar in tree with foo is None" 33 | None (Tree.lookup ["bar"] t) ; 34 | Alcotest.check lookp "lookup_prefix for bar in tree with foo is []" 35 | [] (Tree.lookup_prefix ["bar"] t) ; 36 | let t = Tree.insert ["foo"] "def" t in 37 | Alcotest.check look "lookup for foo in tree with foo is Some ['abc';'def']" 38 | (Some ["abc";"def"]) (Tree.lookup ["foo"] t) ; 39 | Alcotest.check look "lookup for bar in tree with foo is None" 40 | None (Tree.lookup ["bar"] t) ; 41 | let t = Tree.insert ["foo" ; "bar"] "ghi" t in 42 | Alcotest.check look "lookup for foo in tree with foo is Some ['abc';'def']" 43 | (Some ["abc";"def"]) (Tree.lookup ["foo"] t) ; 44 | Alcotest.check look "lookup for bar in tree with foo is None" 45 | None (Tree.lookup ["bar"] t) ; 46 | Alcotest.check look "lookup for foo/bar in tree with foo/bar is Some 'ghi'" 47 | (Some ["ghi"]) (Tree.lookup ["foo" ; "bar"] t) ; 48 | Alcotest.check lookp "lookup_prefix for foo/bar in tree with foo/bar is ['ghi']" 49 | ["ghi"] (Tree.lookup_prefix ["foo" ; "bar"] t) ; 50 | Alcotest.check lookp "lookup_prefix for foo in tree with foo/bar is ['abc';'def']" 51 | ["abc";"def"] (Tree.lookup_prefix ["foo"] t) ; 52 | let t = Tree.insert ["foo"] "jkl" t in 53 | Alcotest.check look "lookup for foo in tree with foo is Some ['abc';'def';'jkl']" 54 | (Some ["abc";"def";"jkl"]) (Tree.lookup ["foo"] t) ; 55 | Alcotest.check lookp "lookup_prefix for foo/bar in tree with foo is ['ghi']" 56 | ["ghi"] (Tree.lookup_prefix ["foo" ; "bar"] t) ; 57 | Alcotest.check look "lookup for bar in tree with foo is None" 58 | None (Tree.lookup ["bar"] t) ; 59 | Alcotest.check look "lookup for foo/bar in tree with foo/bar is Some 'ghi'" 60 | (Some ["ghi"]) (Tree.lookup ["foo" ; "bar"] t) 61 | 62 | 63 | let tests = [ 64 | "basic", `Quick, basic_test 65 | ] 66 | -------------------------------------------------------------------------------- /test/test_uint.ml: -------------------------------------------------------------------------------- 1 | open Conex_utils 2 | 3 | let ui = 4 | let module M = struct 5 | type t = Uint.t 6 | let pp ppf v = Format.pp_print_string ppf (Uint.to_string v) 7 | let equal a b = Uint.compare a b = 0 8 | end in 9 | (module M: Alcotest.TESTABLE with type t = M.t) 10 | 11 | let the x = match Uint.of_string x with Some x -> x | None -> Alcotest.fail "cannot parse" 12 | let max = the "0xFFFFFFFFFFFFFFFF" 13 | let max_int64 = the "0x7FFFFFFFFFFFFFFF" 14 | let min_int64 = the "0x8000000000000000" 15 | 16 | let compare_initial () = 17 | Alcotest.(check int "compare 0 0 is 0" 18 | 0 Uint.(compare zero zero)) ; 19 | Alcotest.(check int "compare 0 max is -1" 20 | (-1) Uint.(compare zero max)) ; 21 | Alcotest.(check int "compare max 0 is 1" 22 | 1 Uint.(compare max zero)) ; 23 | Alcotest.(check int "compare 0 max_int64 is -1" 24 | (-1) Uint.(compare zero max_int64)) ; 25 | Alcotest.(check int "compare max_int64 0 is 1" 26 | 1 Uint.(compare max_int64 zero)) ; 27 | Alcotest.(check int "compare 0 min_int64 is -1" 28 | (-1) Uint.(compare zero min_int64)) ; 29 | Alcotest.(check int "compare min_int64 0 is 1" 30 | 1 Uint.(compare min_int64 zero)) 31 | 32 | let succ_initial () = 33 | Alcotest.(check bool "succ max overflows" 34 | true (fst (Uint.succ max))) ; 35 | let one = snd Uint.(succ zero) in 36 | Alcotest.(check (pair bool ui) "succ 0 no overflow and one" 37 | (false, one) Uint.(succ zero)) ; 38 | Alcotest.(check (pair bool ui) "succ max_int64 no overflow and min_int64" 39 | (false, min_int64) Uint.(succ max_int64)) ; 40 | Alcotest.(check bool "succ min_int64 no overflow" 41 | false (fst Uint.(succ min_int64))) 42 | 43 | let r () = 44 | let buf = Bytes.create 16 in 45 | let one i = 46 | let r = 47 | let r = Random.int 16 in 48 | if i = 0 && r = 0 then r + 1 else r 49 | in 50 | let ascii = r + (if r < 10 then 0x30 else 0x37) in 51 | Bytes.set buf i (char_of_int ascii) 52 | in 53 | for i = 0 to 15 do one i done ; 54 | "0x" ^ Bytes.to_string buf 55 | 56 | let to_of_str_id n () = 57 | for _i = 0 to n do 58 | let r = r () in 59 | Alcotest.(check string "to_of_string is identity" 60 | r Uint.(to_string (the r))) 61 | done 62 | 63 | let compare_random n () = 64 | for _i = 0 to n do 65 | let r = the (r ()) in 66 | let r = if r = Uint.zero then snd (Uint.succ r) else r in 67 | Alcotest.(check int ("compare " ^ Uint.to_string r ^ " 0 is 1") 68 | 1 Uint.(compare r zero)) ; 69 | Alcotest.(check int ("compare 0 " ^ Uint.to_string r ^ " is -1") 70 | (-1) Uint.(compare zero r)) ; 71 | Alcotest.(check int ("compare " ^ Uint.to_string r ^ " with itself is 0") 72 | 0 Uint.(compare r r)) ; 73 | if r = max then begin 74 | Alcotest.(check int ("compare " ^ Uint.to_string r ^ " max is 0") 75 | 0 Uint.(compare r max)) ; 76 | Alcotest.(check int ("compare max " ^ Uint.to_string r ^ " is 0") 77 | 0 Uint.(compare max r)) 78 | end else begin 79 | Alcotest.(check int ("compare " ^ Uint.to_string r ^ " max is -1") 80 | (-1) Uint.(compare r max)) ; 81 | Alcotest.(check int ("compare max " ^ Uint.to_string r ^ " is 1") 82 | 1 Uint.(compare max r)) ; 83 | end 84 | done 85 | 86 | let tests = [ 87 | "basic compare is good", `Quick, compare_initial ; 88 | "succ is good", `Quick, succ_initial ; 89 | "to/of_string is identity", `Quick, to_of_str_id 10000 ; 90 | "compare r zero is good", `Quick, compare_random 1000 ; 91 | ] 92 | -------------------------------------------------------------------------------- /test/tests.ml: -------------------------------------------------------------------------------- 1 | 2 | let () = 3 | Mirage_crypto_rng_unix.use_default () ; 4 | let more = 5 | match Conex_openssl.V.check_version () with 6 | | Error e -> Printf.printf "no openssl tests, version %s\n" e ; [] 7 | | Ok () -> Test_conex.OC.tests ~openssl:true "OpenSSL" 8 | in 9 | Alcotest.run "Conex tests" ( 10 | ("Uint", Test_uint.tests) :: 11 | ("String", Test_string.tests) :: 12 | ("Path", Test_path.tests) :: 13 | ("Tree", Test_tree.tests) :: 14 | ("provider", Test_provider.tests) :: 15 | Test_conex.tests @ more) 16 | -------------------------------------------------------------------------------- /unix/conex_unix_persistency.ml: -------------------------------------------------------------------------------- 1 | open Conex_utils 2 | 3 | let ( let* ) = Result.bind 4 | 5 | let exists = Sys.file_exists 6 | 7 | let guard_unix f x = 8 | try Ok (f x) with 9 | | Unix.Unix_error (e, f, arg) -> 10 | let msg = Unix.error_message e in 11 | Error (Printf.sprintf "error %s while %s (%s)" msg f arg) 12 | | _ -> Error "unknown error" 13 | 14 | let mkdir ?(mode = 0o755) name = guard_unix (Unix.mkdir name) mode 15 | 16 | let guard_sys f x = 17 | try Ok (f x) with 18 | | Sys_error msg -> Error msg 19 | | _ -> Error "unknown error" 20 | 21 | let remove a = guard_sys Sys.remove a 22 | 23 | let rename a b = guard_sys (Sys.rename a) b 24 | 25 | let file_type filename = 26 | let* stat = guard_unix Unix.stat filename in 27 | match stat.Unix.st_kind with 28 | | Unix.S_REG -> Ok File 29 | | Unix.S_DIR -> Ok Directory 30 | | _ -> Error "unsupported file type" 31 | 32 | let read_file filename = 33 | guard_unix (fun file -> 34 | let open Unix in 35 | let fd = openfile file [ O_RDONLY ] 0 in 36 | let len = (fstat fd).st_size in 37 | let buf = Bytes.create len in 38 | let rec rread idx = 39 | let r = read fd buf idx (len - idx) in 40 | if r + idx = len then 41 | close fd 42 | else 43 | rread (r + idx) 44 | in 45 | rread 0 ; 46 | Bytes.to_string buf) filename 47 | 48 | let write_file ?(mode = 0o644) filename data = 49 | guard_unix (fun file -> 50 | let open Unix in 51 | let fd = openfile file [ O_WRONLY ; O_EXCL ; O_CREAT ] mode in 52 | let bytes = Bytes.of_string data in 53 | let length = Bytes.length bytes in 54 | let written = write fd bytes 0 length in 55 | assert (length = written) ; 56 | close fd) 57 | filename 58 | 59 | let write_replace ?mode filename data = 60 | if exists filename then 61 | let tmp = filename ^ ".tmp" in 62 | let* () = if exists tmp then remove tmp else Ok () in 63 | let* () = write_file ?mode tmp data in 64 | rename tmp filename 65 | else 66 | write_file ?mode filename data 67 | 68 | let collect_dir dir = 69 | guard_unix (fun dir -> 70 | let open Unix in 71 | let dh = opendir dir in 72 | let next () = try Some (readdir dh) with End_of_file -> None in 73 | let rec doone acc = function 74 | | Some "." | Some ".." -> doone acc (next ()) 75 | | Some s -> doone (s :: acc) (next ()) 76 | | None -> acc 77 | in 78 | let res = doone [] (next ()) in 79 | closedir dh ; 80 | res) 81 | dir 82 | -------------------------------------------------------------------------------- /unix/conex_unix_persistency.mli: -------------------------------------------------------------------------------- 1 | (** File system operations using Unix *) 2 | 3 | open Conex_utils 4 | 5 | (** [exists] is [Sys.exists]. *) 6 | val exists : string -> bool 7 | 8 | (** [mkdir ~mode name] creates a directory [name], or errors. *) 9 | val mkdir : ?mode:int -> string -> (unit, string) result 10 | 11 | (** [remove] is [Sys.remove] or error. *) 12 | val remove : string -> (unit, string) result 13 | 14 | (** [rename] is [Sys.rename] or error. *) 15 | val rename : string -> string -> (unit, string) result 16 | 17 | (** [file_type path] is the file type of [path] or error. *) 18 | val file_type : string -> (file_type, string) result 19 | 20 | (** [read_file path] is the contents of [path] or error. *) 21 | val read_file : string -> (string, string) result 22 | 23 | (** [write_file ~mode path data] writes [data] under [path] or error. *) 24 | val write_file : ?mode:int -> string -> string -> (unit, string) result 25 | 26 | (** [write_replace ~mode path data] writes [data] under [path.tmp] and 27 | renames [path.tmp] to [path] or error. *) 28 | val write_replace : ?mode:int -> string -> string -> (unit, string) result 29 | 30 | (** [collect_dir path] are the inhabitants of [path] or error. *) 31 | val collect_dir : string -> (string list, string) result 32 | -------------------------------------------------------------------------------- /unix/conex_unix_private_key.ml: -------------------------------------------------------------------------------- 1 | open Conex_utils 2 | open Conex_unix_persistency 3 | 4 | let ( let* ) = Result.bind 5 | 6 | let private_dir = Filename.concat (Sys.getenv "HOME") ".conex" 7 | 8 | let private_s = "private" 9 | 10 | let ids () = 11 | match collect_dir private_dir with 12 | | Ok files -> 13 | List.fold_left (fun acc s -> 14 | match List.rev (String.cuts '.' s) with 15 | | p::tl when p = private_s -> (String.concat "." (List.rev tl))::acc 16 | | _ -> acc (* TODO warn *) ) [] files 17 | | Error _ -> [] 18 | 19 | let private_key_path id = Filename.concat private_dir (id ^ "." ^ private_s) 20 | 21 | let backup id filename = 22 | if exists filename then begin 23 | let backfn = 24 | let open Unix in 25 | let t = gmtime (stat filename).st_mtime in 26 | Printf.sprintf "%s.%4d%2d%2d%2d%2d%2d" id 27 | (t.tm_year + 1900) (succ t.tm_mon) t.tm_mday t.tm_hour t.tm_min t.tm_sec 28 | in 29 | let backup = private_key_path backfn in 30 | let rec inc n = 31 | if n = 10 then Error "too many backup keys, only 10 supported" 32 | else 33 | let nam = backup ^ "." ^ string_of_int n in 34 | if exists nam then inc (succ n) else Ok nam 35 | in 36 | let* backup = if exists backup then inc 0 else Ok backup in 37 | rename filename backup 38 | end else 39 | Ok () 40 | 41 | let write id key = 42 | let filename = private_key_path id in 43 | let* () = backup id filename in 44 | let* () = 45 | if not (exists private_dir) then 46 | mkdir ~mode:0o700 private_dir 47 | else 48 | Ok () 49 | in 50 | match file_type private_dir with 51 | | Ok Directory -> write_file ~mode:0o400 filename key 52 | | _ -> Error (private_dir ^ " is not a directory!") 53 | 54 | let read to_ts id = 55 | let fn = private_key_path id in 56 | if exists fn then 57 | let* key = read_file fn in 58 | let stat = Unix.stat fn in 59 | match to_ts stat.Unix.st_mtime with 60 | | None -> Error ("couldn't convert modification time to Uint.t") 61 | | Some ts -> Ok (key, ts) 62 | else 63 | Error ("couldn't find private key for " ^ id) 64 | -------------------------------------------------------------------------------- /unix/conex_unix_private_key.mli: -------------------------------------------------------------------------------- 1 | (** Private key IO on Unix *) 2 | 3 | include Conex_private.FS 4 | -------------------------------------------------------------------------------- /unix/conex_unix_provider.ml: -------------------------------------------------------------------------------- 1 | open Conex_utils 2 | open Conex_unix_persistency 3 | open Conex_io 4 | 5 | let ( let* ) = Result.bind 6 | 7 | let fs_provider basedir = 8 | let basedir = Unix.realpath basedir in 9 | let* () = 10 | if not (exists basedir) then 11 | mkdir basedir 12 | else 13 | Ok () 14 | in 15 | let get path = path_to_string (basedir :: path) in 16 | let ensure_dir path = 17 | let rec mkdir base = function 18 | | [] -> Ok () 19 | | [_] -> Ok () 20 | | x::xs -> 21 | let path = base @ [x] in 22 | let str = path_to_string path in 23 | let* () = 24 | if not (exists str) then 25 | Conex_unix_persistency.mkdir (path_to_string path) 26 | else 27 | Ok () 28 | in 29 | let* ft = file_type str in 30 | match ft with 31 | | Directory -> mkdir path xs 32 | | File -> Error (str ^ " is not a directory") 33 | in 34 | mkdir [basedir] path 35 | in 36 | let file_type path = 37 | let p = get path in 38 | file_type p 39 | and read path = 40 | let fn = get path in 41 | read_file fn 42 | and write path data = 43 | let* () = ensure_dir path in 44 | let nam = get path in 45 | write_replace nam data 46 | and read_dir path = 47 | let abs = get path in 48 | let* files = collect_dir abs in 49 | foldM (fun acc fn -> 50 | let fullfn = Filename.concat abs fn in 51 | let* ft = file_type fullfn in 52 | match ft with 53 | | File -> Ok ((File, fn) :: acc) 54 | | Directory -> Ok ((Directory, fn) :: acc)) 55 | [] files 56 | and exists path = 57 | exists (get path) 58 | in 59 | Ok { basedir ; description = "File system provider" ; file_type ; read ; write ; read_dir ; exists } 60 | 61 | let fs_ro_provider basedir = 62 | let* fs = fs_provider basedir in 63 | let write _ _ = Ok () 64 | and description = "Read only file system provider" 65 | in 66 | Ok { fs with description ; write } 67 | -------------------------------------------------------------------------------- /unix/conex_unix_provider.mli: -------------------------------------------------------------------------------- 1 | (** Unix IO provider *) 2 | 3 | (** [fs_provider path] is a data provider backed by a file system or error. *) 4 | val fs_provider : string -> (Conex_io.t, string) result 5 | 6 | (** [fs_ro_provider path] is a read-only data provider backed by a file system 7 | or error. *) 8 | val fs_ro_provider : string -> (Conex_io.t, string) result 9 | -------------------------------------------------------------------------------- /unix/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name conex_unix) 3 | (public_name conex.unix) 4 | (wrapped false) 5 | (instrumentation (backend bisect_ppx)) 6 | (libraries conex unix)) 7 | --------------------------------------------------------------------------------