├── .gitignore ├── Dockerfile ├── Makefile ├── README.md ├── compiler ├── Makefile ├── dune-project ├── extractor.opam ├── src │ ├── ast.ml │ ├── ast.mli │ ├── ast_pp.ml │ ├── ast_pp.mli │ ├── ast_transformation.ml │ ├── ast_transformation.mli │ ├── ast_utils.ml │ ├── ast_utils.mli │ ├── cic.ml │ ├── cic.mli │ ├── config.ml │ ├── config.mli │ ├── debug.ml │ ├── debug.mli │ ├── dune │ ├── extract.ml │ ├── extract.mli │ ├── extractor.mlg │ ├── extractor.mlpack │ ├── logger.ml │ ├── logger.mli │ ├── omega.ml │ ├── omega.mli │ ├── omicron.ml │ ├── omicron.mli │ ├── primitive.ml │ ├── primitive.mli │ ├── result.ml │ ├── result.mli │ ├── smtlib.ml │ ├── smtlib.mli │ ├── smtlib_pp.ml │ ├── smtlib_pp.mli │ ├── smtlib_utils.ml │ ├── smtlib_utils.mli │ ├── temporary.ml │ ├── utils.ml │ └── utils.mli └── theories │ ├── Array.v │ ├── Equality.v │ ├── Loader.v │ └── dune ├── docs └── report.pdf ├── model ├── Browser.v ├── BrowserLemmas.v ├── BrowserStates.v ├── CORSInvariant.v ├── CSPInvariant.v ├── HostInvariant.v ├── HttpOnlyInvariant.v ├── LSInvariant.v ├── LemmaCSPQuery.v ├── LemmaIframeSamesiteScriptState.v ├── LemmaScriptState.v ├── LoadPath.v ├── OCamlExtract.v ├── OriginInvariant.v ├── SOPInvariant.v ├── SWInvariant.v ├── SecureCookiesInvariant.v └── TTInvariant.v ├── nix ├── coq-procrastination.nix ├── z3-patched.nix └── z3_bmc_initial_unrolling_level.patch ├── scripts ├── display_trace.ml ├── run.sh ├── viz.ml └── z32coq.el ├── shell.nix ├── traces ├── CSPInvariant.trace.z3 ├── HostInvariant.trace.z3 ├── LSInvariant.trace.z3 ├── SWInvariant.trace.z3 └── TTInvariant.trace.z3 ├── verifier ├── .gitignore ├── Dockerfile ├── dune-project ├── model │ ├── .gitignore │ └── dune ├── src │ ├── cspcheck.ml │ ├── cspcheck.mli │ ├── dune │ ├── html.ml │ ├── html.mli │ ├── main.ml │ ├── script.ml │ ├── script.mli │ ├── serviceworker.ml │ ├── serviceworker.mli │ ├── states.ml │ ├── states.mli │ ├── test.ml │ ├── test.mli │ ├── trace.ml │ ├── types.ml │ ├── types.mli │ ├── utils.ml │ ├── utils.mli │ ├── uuid.ml │ ├── uuid.mli │ ├── visitor.ml │ ├── visitor.mli │ ├── wpt.ml │ └── wpt.mli └── templates │ ├── install.jingoo │ ├── launcher.jingoo │ └── sw.jingoo └── webspec /.gitignore: -------------------------------------------------------------------------------- 1 | # Coq Makefiles 2 | Makefile.coq 3 | Makefile.coq.conf 4 | 5 | # Ignore external libraries 6 | plugin/record-update 7 | 8 | # LaTeX temporary files 9 | *.aux 10 | *.log 11 | *.toc 12 | *.fls 13 | 14 | # PDF output - usually a bad idea to keep this in Git 15 | paper/*.pdf 16 | paper/auto/ 17 | 18 | # Latexmk 19 | *.fdb_latexmk 20 | 21 | # SyncTeX 22 | *.synctex.gz 23 | 24 | # LaTeX Beamer 25 | *.snm 26 | *.vrb 27 | *.nav 28 | *.out 29 | 30 | # BibTeX 31 | *.bbl 32 | *.blg 33 | 34 | # Sublime Text Project Files (usually contain absolute paths) 35 | *.sublime-project 36 | *.sublime-workspace 37 | 38 | # macOS hidden files 39 | .DS_Store 40 | 41 | # Texpad folder for temporary files 42 | .texpadtmp 43 | 44 | # WebStorm/PyCharm config files 45 | .idea 46 | 47 | # ocaml 48 | *.annot 49 | *.cmo 50 | *.cma 51 | *.cmi 52 | *.a 53 | *.o 54 | *.cmx 55 | *.cmxs 56 | *.cmxa 57 | *.mlg.d 58 | *.cmt 59 | *.cmti 60 | 61 | # ocamlbuild working directory 62 | _build/ 63 | 64 | # ocamlbuild targets 65 | *.byte 66 | *.native 67 | 68 | # oasis generated files 69 | setup.data 70 | setup.log 71 | 72 | # Merlin configuring file for Vim and Emacs 73 | .merlin 74 | 75 | # Dune generated files 76 | *.install 77 | 78 | # Local OPAM switch 79 | _opam/ 80 | 81 | ### Coq ### 82 | .*.aux 83 | .*.d 84 | *.a 85 | *.cma 86 | *.cmi 87 | *.cmo 88 | *.cmx 89 | *.cmxa 90 | *.cmxs 91 | *.glob 92 | *.ml.d 93 | *.ml4.d 94 | *.mli.d 95 | *.mllib.d 96 | *.mlpack.d 97 | *.native 98 | *.o 99 | *.v.d 100 | *.vio 101 | *.vo 102 | *.vok 103 | *.vos 104 | .coq-native/ 105 | .csdp.cache 106 | .lia.cache 107 | .nia.cache 108 | .nlia.cache 109 | .nra.cache 110 | csdp.cache 111 | lia.cache 112 | nia.cache 113 | nlia.cache 114 | nra.cache 115 | 116 | 117 | # Specific to this project 118 | plugin/src/extractor.ml 119 | -------------------------------------------------------------------------------- /Dockerfile: -------------------------------------------------------------------------------- 1 | FROM nixos/nix 2 | ENV NIXPKGS_ALLOW_UNFREE 1 3 | COPY shell.nix /opt/ 4 | ADD nix/ /opt/nix/ 5 | RUN nix-env -if /opt/shell.nix -A buildInputs --cores 9 -j 9 6 | RUN nix-shell /opt/shell.nix 7 | RUN nix-env -iA nixpkgs.emacs-nox 8 | WORKDIR /mnt 9 | RUN chmod -R 777 /nix/var/ 10 | RUN echo -e '#!/bin/sh\nnix-shell /opt/shell.nix --run "$(echo "$@")"' > /bin/entrypoint 11 | RUN chmod +x /bin/entrypoint 12 | ENTRYPOINT ["/bin/entrypoint"] 13 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: all compiler coq wrapper verifier 2 | SHELL=/usr/bin/env bash 3 | 4 | all: compiler 5 | 6 | coq: compiler Browser BrowserStates BrowserLemmas 7 | 8 | %: model/%.v 9 | cd model && dune exec -- coqc $(notdir $<) 10 | 11 | compiler: 12 | cd compiler && dune build 13 | 14 | wrapper: 15 | cd wrapper && make 16 | 17 | verifier/model/Browser.ml: coq OCamlExtract 18 | 19 | verifier: verifier/model/Browser.ml 20 | cd verifier && dune build 21 | 22 | clean-verifier-output: 23 | cd verifier && rm -fr output 24 | 25 | 26 | define DUNE_FILE 27 | (executable 28 | (name Z3_Trace) 29 | (modes (byte exe))) 30 | 31 | (env 32 | (dev 33 | (flags (:standard -w -33)))) 34 | endef 35 | 36 | define MARSHAL_PROGRAM 37 | 38 | type t = { 39 | events : Browser.coq_Event list; 40 | states : Browser.coq_State list; 41 | global : Browser.coq_Global 42 | } 43 | 44 | let () = 45 | let channel = open_out_bin "./trace.dat" in 46 | Fun.protect ~finally:(fun () -> close_out channel) 47 | (fun () -> 48 | Marshal.to_channel channel ({ events=events; states=states; global=global }) [Marshal.No_sharing]) 49 | endef 50 | export DUNE_FILE 51 | export MARSHAL_PROGRAM 52 | 53 | traces/%.trace.dat: traces/%.trace.z3 54 | scripts/z32coq.el $< > model/Z3_Trace.v && \ 55 | TMP=$$(grep -Po 'Cd "\K[^"]+' model/Z3_Trace.v) && \ 56 | pushd model && dune exec coqc Z3_Trace.v && rm Z3_Trace.{v,glob} && popd && \ 57 | echo "$$DUNE_FILE" > $$TMP/dune && \ 58 | echo "$$MARSHAL_PROGRAM" >> $$TMP/Z3_Trace.ml && \ 59 | pushd $$TMP && dune exec ./Z3_Trace.exe && popd && \ 60 | cp $$TMP/trace.dat $@ && rm -fr $$TMP 61 | 62 | clean: 63 | cd compiler && dune clean 64 | cd model && dune clean 65 | find ./model -type f -name "*.vos" -delete 66 | find ./model -type f -name "*.vok" -delete 67 | find ./model -type f -name "*.vo" -delete 68 | find ./model -type f -name "*.glob" -delete 69 | cd wrapper && make clean 70 | cd verifier && dune clean 71 | find ./verifier/model -type f -name "*.vo*" -delete 72 | find ./verifier/model -type f -name "*.glob" -delete 73 | find ./verifier/model -type f -name "*.ml*" -delete 74 | find ./traces -type f -name "*.trace.dat" -delete 75 | 76 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # WebSpec 2 | 3 | Towards Machine-Checked Analysis of Browser Security Mechanisms 4 | 5 | 6 | ## Repo Structure 7 | 8 | - `model`: Browser Model and Web Invariants 9 | - The proofs of our proposed changes to the Web platform are provided in the `{Host,CSP,TT,SW}Invariant.v` files 10 | - `compiler`: Compiler from Coq to SMT-LIB 11 | - `verifier`: Executable test generator for verifying counterexamples against browsers 12 | - The counterexamples traces are provided in the `traces` directory 13 | 14 | ## Running WebSpec 15 | 16 | WebSpec requires a working [docker](https://docker.io) installation and the `bash` shell. 17 | The `webspec` script is the main entrypoint for executing queries and running traces against browsers. 18 | 19 | - Download docker images of the WebSpec environment 20 | ``` 21 | ./webspec pull 22 | ``` 23 | - Compile the browser model, the compiler, the verifier and check all the proofs. 24 | Note: this may require up to 5 minutes! 25 | ``` 26 | ./webspec compile 27 | ``` 28 | - Run a query using the Z3 μZ fixed-point engine. 29 | When a counterexample is found, WebSpec displays the trace as a sequence diagram (if a lemma is applied by the solver, only the new events after the state defined by the lemma are displayed). 30 | Run the `SWInvariant` (I.5 _integrity of server-provided policies_) query (see `model/SWInvariant.v` for the invariant definition). 31 | Note: the query is expected to terminate in around 3 minutes. 32 | ``` 33 | ./webspec run SWInvariant 34 | ``` 35 | - Verify the discovered attack trace by running running it against the chromium browser. 36 | ``` 37 | ./webspec verify -b chromium SWInvariant 38 | ``` 39 | The output includes a human-readable summary of the test, which shows `OK` for a passing test, and a ([wpt.fyi](https://wpt.fyi) compatible) JSON object describing the results. 40 | 41 | When a test fails, the assertion is displayed, showing the expected result. 42 | If we verify the `LSInvariant` (I.7 _safe policy inheritance_) invariant, the test fails, showing that current browsers are not vulnerable to the discovered inconsistency. This happens because browsers are not yet implementing the planned modification to the `blob:` CSP inheritance behavior. 43 | ``` 44 | ./webspec verify -b chromium -c csp LSInvariant 45 | ``` 46 | Running the above test results in the following output. 47 | ``` 48 | ... 49 | Unexpected Results 50 | ------------------ 51 | /verifier/launcher.html 52 | FAIL LSInvariant.trace - assert_equals: test 0 expected "GPPPG" but got "GGGPG" 53 | ... 54 | ``` 55 | For this test, we use the `-c csp` flag, instructing the verifier to generate assertions that verify the Content-Security-Policy. 56 | 57 | The strings `GPPPG` and `GGGPG` are the expected and actual CSP signatures, respectively -- `G` represents an allowed request, and `P` represents a blocked request. This test fails because the actual CSP produces a signature different from the expected CSP, implying that these CSPs differ. 58 | 59 | - Build outputs and tests can be removed with the following command 60 | ``` 61 | ./webspec clean 62 | ``` 63 | -------------------------------------------------------------------------------- /compiler/Makefile: -------------------------------------------------------------------------------- 1 | all: 2 | dune build 3 | 4 | clean: 5 | dune clean 6 | find ./ -type f -name "*.aux" -delete 7 | find ./ -type f -name "*.vos" -delete 8 | find ./ -type f -name "*.vok" -delete 9 | find ./ -type f -name "*.vo" -delete 10 | find ./ -type f -name "*.glob" -delete 11 | 12 | .PHONY: all 13 | -------------------------------------------------------------------------------- /compiler/dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 2.7) 2 | (using coq 0.1) 3 | (name extractor) 4 | (cram enable) 5 | -------------------------------------------------------------------------------- /compiler/extractor.opam: -------------------------------------------------------------------------------- 1 | synopsis: "extractor" 2 | description: "extractor" 3 | name: "extractor" 4 | opam-version: "2.0" 5 | maintainer: "Benjamin Farinier " 6 | authors: "Benjamin Farinier " 7 | license: "GPL 3" 8 | 9 | depends: [ 10 | "ocaml" { >= "4.09.1" } 11 | "coq" { >= "8.11.0" & < "8.12" } 12 | "dune" { >= "2.6.0" } 13 | ] 14 | 15 | build: [ "dune" "build" "-p" name "-j" jobs ] 16 | -------------------------------------------------------------------------------- /compiler/src/ast_pp.mli: -------------------------------------------------------------------------------- 1 | (********************************************************************************) 2 | (* Copyright (c) 2021 Benjamin Farinier *) 3 | (* *) 4 | (* Permission is hereby granted, free of charge, to any person obtaining a *) 5 | (* copy of this software and associated documentation files (the "Software"), *) 6 | (* to deal in the Software without restriction, including without limitation *) 7 | (* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) 8 | (* and/or sell copies of the Software, and to permit persons to whom the *) 9 | (* Software is furnished to do so, subject to the following conditions: *) 10 | (* *) 11 | (* The above copyright notice and this permission notice shall be included in *) 12 | (* all copies or substantial portions of the Software. *) 13 | (* *) 14 | (* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR *) 15 | (* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) 16 | (* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) 17 | (* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER *) 18 | (* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) 19 | (* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) 20 | (* DEALINGS IN THE SOFTWARE. *) 21 | (* *) 22 | (********************************************************************************) 23 | 24 | val pp_sort : Format.formatter -> _ Ast.sort -> unit 25 | 26 | val pp_selector : Format.formatter -> Ast.selector -> unit 27 | 28 | val pp_constructor : Format.formatter -> Ast.constructor -> unit 29 | 30 | val pp_datatype : Format.formatter -> Ast.datatype -> unit 31 | 32 | val pp_var : Format.formatter -> Ast.var -> unit 33 | 34 | val pp_case : Format.formatter -> _ Ast.case -> unit 35 | 36 | val pp_term : Format.formatter -> _ Ast.term -> unit 37 | 38 | val pp_sortdefn : Format.formatter -> Ast.sortdefn -> unit 39 | 40 | val pp_fundecl : Format.formatter -> _ Ast.fundecl -> unit 41 | 42 | val pp_fundefn : Format.formatter -> _ Ast.fundefn -> unit 43 | 44 | val pp_rule : Format.formatter -> Ast.rule -> unit 45 | 46 | val pp_relation : Format.formatter -> Ast.relation -> unit 47 | 48 | val pp : Format.formatter -> Ast.t -> unit 49 | -------------------------------------------------------------------------------- /compiler/src/ast_transformation.mli: -------------------------------------------------------------------------------- 1 | (********************************************************************************) 2 | (* Copyright (c) 2021 Benjamin Farinier *) 3 | (* *) 4 | (* Permission is hereby granted, free of charge, to any person obtaining a *) 5 | (* copy of this software and associated documentation files (the "Software"), *) 6 | (* to deal in the Software without restriction, including without limitation *) 7 | (* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) 8 | (* and/or sell copies of the Software, and to permit persons to whom the *) 9 | (* Software is furnished to do so, subject to the following conditions: *) 10 | (* *) 11 | (* The above copyright notice and this permission notice shall be included in *) 12 | (* all copies or substantial portions of the Software. *) 13 | (* *) 14 | (* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR *) 15 | (* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) 16 | (* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) 17 | (* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER *) 18 | (* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) 19 | (* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) 20 | (* DEALINGS IN THE SOFTWARE. *) 21 | (* *) 22 | (********************************************************************************) 23 | 24 | val destruct_array : Ast.t -> Ast.t list 25 | val destruct_match : Ast.t -> Ast.t list 26 | val unify_equality : Ast.t -> Ast.t list 27 | val split_rule : Ast.t -> Ast.t list 28 | val rename_vars : Ast.t -> Ast.t list 29 | 30 | val destruct_rule : (string * int) list -> Ast.t -> Ast.t list 31 | val inline_relations : (string * int) list -> Ast.t -> Ast.t list 32 | -------------------------------------------------------------------------------- /compiler/src/ast_utils.mli: -------------------------------------------------------------------------------- 1 | (********************************************************************************) 2 | (* Copyright (c) 2021 Benjamin Farinier *) 3 | (* *) 4 | (* Permission is hereby granted, free of charge, to any person obtaining a *) 5 | (* copy of this software and associated documentation files (the "Software"), *) 6 | (* to deal in the Software without restriction, including without limitation *) 7 | (* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) 8 | (* and/or sell copies of the Software, and to permit persons to whom the *) 9 | (* Software is furnished to do so, subject to the following conditions: *) 10 | (* *) 11 | (* The above copyright notice and this permission notice shall be included in *) 12 | (* all copies or substantial portions of the Software. *) 13 | (* *) 14 | (* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR *) 15 | (* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) 16 | (* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) 17 | (* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER *) 18 | (* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) 19 | (* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) 20 | (* DEALINGS IN THE SOFTWARE. *) 21 | (* *) 22 | (********************************************************************************) 23 | 24 | val get_constructor : Ast.datatype -> int -> Ast.constructor 25 | val get_selector : Ast.datatype -> int -> int -> Ast.selector 26 | 27 | val get_name : Ast.t -> string 28 | val sort_to_string : _ Ast.sort -> string 29 | 30 | val subst_sort : (string -> Ast.set Ast.sort) -> 'a Ast.sort -> 'a Ast.sort 31 | val subst_term : (string -> Ast.set Ast.sort) -> (Ast.var -> Ast.set Ast.term) -> 32 | 'a Ast.term -> 'a Ast.term 33 | 34 | val subst_sort_list : (string * Ast.set Ast.sort) list -> 'a Ast.sort -> 'a Ast.sort 35 | val subst_term_list : (string * Ast.set Ast.sort) list -> (Ast.var * Ast.set Ast.term) list -> 36 | 'a Ast.term -> 'a Ast.term 37 | 38 | (******************************************************************************) 39 | 40 | type ('a,'b) fn = before:'a -> after:'a -> 'b -> 'a * 'b 41 | 42 | type 'a bind = { 43 | bind_sort : (string, 'a) fn; 44 | bind_decl : (Ast.var, 'a) fn; 45 | bind_defn : (Ast.var * Ast.set Ast.term, 'a) fn; 46 | unbind_sort : (string, 'a) fn; 47 | unbind_decl : (Ast.var, 'a) fn; 48 | unbind_defn : (Ast.var * Ast.set Ast.term, 'a) fn; 49 | } 50 | 51 | val bind_identity : 'a bind 52 | 53 | type 'a fold_map = { 54 | fold_map_sort : 'b. ('b Ast.sort, 'a) fn; 55 | fold_map_term : 'b. ('b Ast.term, 'a) fn; 56 | fold_map_dttp : (Ast.datatype, 'a) fn; 57 | fold_map_sdef : (Ast.sortdefn, 'a) fn; 58 | fold_map_fdec : 'b. ('b Ast.fundecl, 'a) fn; 59 | fold_map_fdef : 'b. ('b Ast.fundefn, 'a) fn; 60 | fold_map_var : (Ast.var, 'a) fn; 61 | } 62 | 63 | val fold_map_identity : 'a fold_map 64 | 65 | val fold_map_sort : 'a bind -> 'a fold_map -> 'b Ast.sort -> 'a -> 'b Ast.sort * 'a 66 | val fold_map_term : 'a bind -> 'a fold_map -> 'b Ast.term -> 'a -> 'b Ast.term * 'a 67 | val fold_map_dttp : 'a bind -> 'a fold_map -> Ast.datatype -> 'a -> Ast.datatype * 'a 68 | 69 | val fold_map : 'a bind -> 'a fold_map -> Ast.t -> 'a -> Ast.t * 'a 70 | 71 | -------------------------------------------------------------------------------- /compiler/src/cic.mli: -------------------------------------------------------------------------------- 1 | (********************************************************************************) 2 | (* Copyright (c) 2021 Benjamin Farinier *) 3 | (* *) 4 | (* Permission is hereby granted, free of charge, to any person obtaining a *) 5 | (* copy of this software and associated documentation files (the "Software"), *) 6 | (* to deal in the Software without restriction, including without limitation *) 7 | (* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) 8 | (* and/or sell copies of the Software, and to permit persons to whom the *) 9 | (* Software is furnished to do so, subject to the following conditions: *) 10 | (* *) 11 | (* The above copyright notice and this permission notice shall be included in *) 12 | (* all copies or substantial portions of the Software. *) 13 | (* *) 14 | (* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR *) 15 | (* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) 16 | (* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) 17 | (* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER *) 18 | (* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) 19 | (* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) 20 | (* DEALINGS IN THE SOFTWARE. *) 21 | (* *) 22 | (********************************************************************************) 23 | 24 | open Utils 25 | 26 | type recursivity_kind = 27 | | Finite 28 | | CoFinite 29 | | BiFinite 30 | 31 | type sort = Prop | Set | Type 32 | 33 | type term = private { 34 | term_hash : int; 35 | term_desc : term_desc; 36 | } 37 | 38 | and term_desc = 39 | | Rel of name 40 | | Sort of sort 41 | | Product of name * typ * typ 42 | | Lambda of name * typ * term 43 | | LetIn of name * term * typ * term 44 | | App of term * term array 45 | | Constant of constant 46 | | Inductive of (inductive * int) 47 | | Construct of (inductive * int) * int 48 | | Project of projection * term 49 | | Case of case * term * typ * term array 50 | | Int of int 51 | | Float of float 52 | | Array of term array * term * typ 53 | | Primitive of Primitive.t * typ 54 | 55 | and typ = term 56 | 57 | and constant = private { 58 | cnst_hash : int; 59 | cnst_ident: ident; 60 | cnst_type : typ; 61 | cnst_body : term option; 62 | } 63 | 64 | and inductive = private { 65 | indv_hash : int; 66 | indv_ident : ident; 67 | mutable indv_body : mutual_inductive; 68 | } 69 | 70 | and mutual_inductive = private { 71 | mind_hash : int; 72 | mind_finite : recursivity_kind; 73 | mind_npars : int; 74 | mind_npars_rec : int; 75 | mind_bodies : one_inductive array; 76 | } 77 | 78 | and one_inductive = private { 79 | oind_hash : int; 80 | oind_name : string; 81 | oind_type : typ; 82 | oind_nargs : int; 83 | oind_ndecls: int; 84 | oind_ctors : constructor array; 85 | oind_projs : (string * term * typ) array; 86 | } 87 | 88 | and constructor = private { 89 | ctor_hash : int; 90 | ctor_name : string; 91 | ctor_type : typ; 92 | ctor_nargs : int; 93 | ctor_ndecls: int; 94 | } 95 | 96 | and projection = private { 97 | proj_hash : int; 98 | proj_indv : inductive * int; 99 | proj_name : string; 100 | proj_npars : int; 101 | proj_arg : int; 102 | } 103 | 104 | and case = private { 105 | case_hash : int; 106 | case_ndecls : int array; 107 | case_nargs : int array; 108 | case_indv : inductive * int; 109 | } 110 | 111 | 112 | val get_inductive_body : inductive * int -> mutual_inductive * one_inductive 113 | 114 | val get_projection_body : projection -> string * term * typ 115 | 116 | val extract : Constrexpr.constr_expr -> (term, exn) result 117 | 118 | val pp_term : Format.formatter -> term -> unit 119 | -------------------------------------------------------------------------------- /compiler/src/config.mli: -------------------------------------------------------------------------------- 1 | (********************************************************************************) 2 | (* Copyright (c) 2021 Benjamin Farinier *) 3 | (* *) 4 | (* Permission is hereby granted, free of charge, to any person obtaining a *) 5 | (* copy of this software and associated documentation files (the "Software"), *) 6 | (* to deal in the Software without restriction, including without limitation *) 7 | (* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) 8 | (* and/or sell copies of the Software, and to permit persons to whom the *) 9 | (* Software is furnished to do so, subject to the following conditions: *) 10 | (* *) 11 | (* The above copyright notice and this permission notice shall be included in *) 12 | (* all copies or substantial portions of the Software. *) 13 | (* *) 14 | (* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR *) 15 | (* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) 16 | (* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) 17 | (* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER *) 18 | (* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) 19 | (* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) 20 | (* DEALINGS IN THE SOFTWARE. *) 21 | (* *) 22 | (********************************************************************************) 23 | 24 | module Env : 25 | sig 26 | 27 | module type ARG = 28 | sig 29 | type t 30 | 31 | val name : string 32 | val doc : string 33 | val default : t 34 | 35 | val get : unit -> t 36 | end 37 | 38 | module type BOOL = ARG with type t = bool 39 | module type INT = ARG with type t = int 40 | module type FLOAT = ARG with type t = float 41 | module type STRING = ARG with type t = string 42 | 43 | module Bool 44 | (Arg : sig 45 | val name : string 46 | val doc : string 47 | val default : bool 48 | end) : BOOL 49 | 50 | module Int 51 | (Arg : sig 52 | val name : string 53 | val doc : string 54 | val default : int 55 | end) : INT 56 | 57 | module Float 58 | (Arg : sig 59 | val name : string 60 | val doc : string 61 | val default : float 62 | end) : FLOAT 63 | 64 | module String 65 | (Arg : sig 66 | val name : string 67 | val doc : string 68 | val default : string 69 | end) : STRING 70 | 71 | end 72 | 73 | (********************************************************************************) 74 | 75 | module Coq : 76 | sig 77 | 78 | module type ARG = 79 | sig 80 | type t 81 | 82 | val default : t 83 | val set : t -> unit 84 | val get : unit -> t 85 | end 86 | 87 | module type BOOL = ARG with type t = bool 88 | module type INT = ARG with type t = int 89 | module type FLOAT = ARG with type t = float 90 | module type STRING = ARG with type t = string 91 | 92 | module type SET = 93 | sig 94 | type elt 95 | 96 | val clear : unit -> unit 97 | val add : elt -> unit 98 | val mem : elt -> bool 99 | val remove : elt -> unit 100 | 101 | val elements : unit -> elt list 102 | end 103 | 104 | module Set 105 | (Ord : sig 106 | type t 107 | val compare : t -> t -> int 108 | end) : SET with type elt = Ord.t 109 | 110 | module type MAP = 111 | sig 112 | type key 113 | type elt 114 | 115 | val clear : unit -> unit 116 | val add : key -> elt -> unit 117 | val find : key -> elt option 118 | val remove : key -> unit 119 | 120 | val bindings : unit -> (key * elt) list 121 | end 122 | 123 | module Map 124 | (Ord : sig 125 | type t 126 | val compare : t -> t -> int 127 | end) 128 | (Elt : sig type t end) : 129 | MAP with type key = Ord.t 130 | and type elt = Elt.t 131 | 132 | end 133 | 134 | (********************************************************************************) 135 | 136 | module Info : Env.BOOL 137 | module Debug : Env.BOOL 138 | module Warning : Env.BOOL 139 | module Error : Env.BOOL 140 | 141 | module ArraySize : Coq.INT 142 | module InlineDepth : Coq.INT 143 | 144 | module InlinedConstants : Coq.SET with type elt = Names.KerName.t 145 | module InlinedRelations : Coq.MAP with type key = string and type elt = int 146 | module DestructRelations: Coq.MAP with type key = string and type elt = int 147 | -------------------------------------------------------------------------------- /compiler/src/debug.mli: -------------------------------------------------------------------------------- 1 | (********************************************************************************) 2 | (* Copyright (c) 2021 Benjamin Farinier *) 3 | (* *) 4 | (* Permission is hereby granted, free of charge, to any person obtaining a *) 5 | (* copy of this software and associated documentation files (the "Software"), *) 6 | (* to deal in the Software without restriction, including without limitation *) 7 | (* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) 8 | (* and/or sell copies of the Software, and to permit persons to whom the *) 9 | (* Software is furnished to do so, subject to the following conditions: *) 10 | (* *) 11 | (* The above copyright notice and this permission notice shall be included in *) 12 | (* all copies or substantial portions of the Software. *) 13 | (* *) 14 | (* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR *) 15 | (* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) 16 | (* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) 17 | (* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER *) 18 | (* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) 19 | (* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) 20 | (* DEALINGS IN THE SOFTWARE. *) 21 | (* *) 22 | (********************************************************************************) 23 | 24 | val pp_constr : Format.formatter -> Constr.t -> unit 25 | val pp_constrexpr : Format.formatter -> Constrexpr.constr_expr -> unit 26 | -------------------------------------------------------------------------------- /compiler/src/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name extractor) ; This is the name you will use in 3 | ; Coq's `Declare ML Module`, and 4 | ; the name of the main OCaml 5 | ; module of your plugin. 6 | 7 | (public_name extractor.plugin) ; This makes the plugin 8 | ; installable; recommended, must 9 | ; match opam package name 10 | 11 | (synopsis "extractor") ; Synopsis, used in META generation 12 | 13 | (flags :standard -rectypes) ; Coq requires the `-rectypes` 14 | ; flag; CoqPP generated code 15 | ; requires to disable warning 27 16 | ; often. 17 | 18 | (libraries ; ML Libraries we want to link 19 | ; with, your choice here. 20 | 21 | coq.vernac ; needed for vernac extend 22 | coq.plugins.ltac ; needed for tactic extend 23 | z3 24 | ) 25 | ) 26 | 27 | ; This will let Dune know about Coq's .mlg grammar files. 28 | (coq.pp (modules extractor)) 29 | -------------------------------------------------------------------------------- /compiler/src/extract.ml: -------------------------------------------------------------------------------- 1 | (********************************************************************************) 2 | (* Copyright (c) 2021 Benjamin Farinier *) 3 | (* *) 4 | (* Permission is hereby granted, free of charge, to any person obtaining a *) 5 | (* copy of this software and associated documentation files (the "Software"), *) 6 | (* to deal in the Software without restriction, including without limitation *) 7 | (* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) 8 | (* and/or sell copies of the Software, and to permit persons to whom the *) 9 | (* Software is furnished to do so, subject to the following conditions: *) 10 | (* *) 11 | (* The above copyright notice and this permission notice shall be included in *) 12 | (* all copies or substantial portions of the Software. *) 13 | (* *) 14 | (* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR *) 15 | (* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) 16 | (* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) 17 | (* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER *) 18 | (* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) 19 | (* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) 20 | (* DEALINGS IN THE SOFTWARE. *) 21 | (* *) 22 | (********************************************************************************) 23 | 24 | open Result.Monad 25 | 26 | module Log = Logger.Default 27 | (struct 28 | let name = "ast" 29 | end) 30 | 31 | (******************************************************************************) 32 | 33 | let used_lemmas = ref [] 34 | 35 | let use_lemma def = 36 | let cn = 37 | return 38 | (Ok def 39 | >>= Cic.extract 40 | >>= Omega.extract_lemma 41 | >>= Omicron.extract_constant) 42 | in 43 | used_lemmas := cn :: !used_lemmas 44 | 45 | let inline_constant qualid = 46 | match Constrintern.locate_reference qualid with 47 | | Names.GlobRef.ConstRef cn -> 48 | Config.InlinedConstants.add (Names.Constant.canonical cn) 49 | | _ -> () 50 | 51 | let inline_relation depth qualid = 52 | match Constrintern.locate_reference qualid with 53 | | Names.GlobRef.IndRef (iv, _) -> 54 | let string = Names.(Label.to_string (MutInd.label iv)) in 55 | Config.InlinedRelations.add string 56 | (Stdlib.Option.value depth ~default:(Config.InlineDepth.get ())) 57 | | _ -> () 58 | 59 | let destruct_relation depth qualid = 60 | match Constrintern.locate_reference qualid with 61 | | Names.GlobRef.IndRef (iv, _) -> 62 | let string = Names.(Label.to_string (MutInd.label iv)) in 63 | Config.DestructRelations.add string (Stdlib.Option.value depth ~default:max_int) 64 | | _ -> () 65 | 66 | (******************************************************************************) 67 | 68 | let log name t = 69 | Log.debug (fun fmt -> fmt "%s" name); 70 | [t] 71 | 72 | let log_verbose name t = 73 | Log.Verbose.debug 74 | ~head:(fun fmt -> fmt "%s" name) 75 | ~body:(fun fmt -> fmt "%a" Ast_pp.pp t); 76 | [t] 77 | 78 | let (>|=) list (f: 'a -> 'b list) = List.flatten (List.map f list) 79 | 80 | let optimize t = 81 | log_verbose (Ast_utils.get_name t) t 82 | 83 | >|= log "destruct_rule" 84 | >|= Ast_transformation.destruct_rule (Config.DestructRelations.bindings ()) 85 | >|= log "inline_relations" 86 | >|= Ast_transformation.inline_relations (Config.InlinedRelations.bindings ()) 87 | >|= log "destruct_match" 88 | >|= Ast_transformation.destruct_match 89 | (* 90 | >|= pp_if "split_rule" 91 | >|= Ast_transformation.split_rule 92 | >|= pp_if "unify_equality" 93 | >|= Ast_transformation.unify_equality 94 | *) 95 | >|= log "destruct_array" 96 | >|= Ast_transformation.destruct_array 97 | >|= log "rename_vars" 98 | >|= Ast_transformation.rename_vars 99 | >|= log_verbose (Ast_utils.get_name t) 100 | 101 | (******************************************************************************) 102 | 103 | module type S = 104 | sig 105 | type t 106 | val extract : Constrexpr.constr_expr -> t list 107 | end 108 | 109 | module Horn = 110 | struct 111 | 112 | type t = Smtlib.command 113 | 114 | let extract def = 115 | return 116 | (Ok def 117 | >>= Cic.extract 118 | >>= Omega.extract_relation 119 | >>= Omicron.extract_inductive 120 | >>= Temporary.extract_inductive ~lemmas:!used_lemmas) 121 | >|= optimize 122 | >|= Smtlib_utils.ast_to_horn 123 | 124 | end 125 | 126 | module Smtlib = 127 | struct 128 | 129 | type t = Smtlib.command 130 | 131 | let extract def = 132 | return 133 | (Ok def 134 | >>= Cic.extract 135 | >>= Omega.extract_relation 136 | >>= Omicron.extract_inductive 137 | >>= Temporary.extract_inductive ~lemmas:!used_lemmas) 138 | >|= optimize 139 | >|= Smtlib_utils.ast_to_smtlib 140 | 141 | end 142 | -------------------------------------------------------------------------------- /compiler/src/extract.mli: -------------------------------------------------------------------------------- 1 | (********************************************************************************) 2 | (* Copyright (c) 2021 Benjamin Farinier *) 3 | (* *) 4 | (* Permission is hereby granted, free of charge, to any person obtaining a *) 5 | (* copy of this software and associated documentation files (the "Software"), *) 6 | (* to deal in the Software without restriction, including without limitation *) 7 | (* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) 8 | (* and/or sell copies of the Software, and to permit persons to whom the *) 9 | (* Software is furnished to do so, subject to the following conditions: *) 10 | (* *) 11 | (* The above copyright notice and this permission notice shall be included in *) 12 | (* all copies or substantial portions of the Software. *) 13 | (* *) 14 | (* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR *) 15 | (* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) 16 | (* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) 17 | (* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER *) 18 | (* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) 19 | (* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) 20 | (* DEALINGS IN THE SOFTWARE. *) 21 | (* *) 22 | (********************************************************************************) 23 | 24 | val use_lemma : Constrexpr.constr_expr -> unit 25 | val inline_constant : Libnames.qualid -> unit 26 | val inline_relation : int option -> Libnames.qualid -> unit 27 | val destruct_relation : int option -> Libnames.qualid -> unit 28 | 29 | module type S = 30 | sig 31 | type t 32 | val extract : Constrexpr.constr_expr -> t list 33 | end 34 | 35 | module Horn : S with type t = Smtlib.command 36 | module Smtlib : S with type t = Smtlib.command 37 | -------------------------------------------------------------------------------- /compiler/src/extractor.mlg: -------------------------------------------------------------------------------- 1 | (********************************************************************************) 2 | (* Copyright (c) 2021 Benjamin Farinier *) 3 | (* *) 4 | (* Permission is hereby granted, free of charge, to any person obtaining a *) 5 | (* copy of this software and associated documentation files (the "Software"), *) 6 | (* to deal in the Software without restriction, including without limitation *) 7 | (* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) 8 | (* and/or sell copies of the Software, and to permit persons to whom the *) 9 | (* Software is furnished to do so, subject to the following conditions: *) 10 | (* *) 11 | (* The above copyright notice and this permission notice shall be included in *) 12 | (* all copies or substantial portions of the Software. *) 13 | (* *) 14 | (* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR *) 15 | (* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) 16 | (* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) 17 | (* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER *) 18 | (* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) 19 | (* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) 20 | (* DEALINGS IN THE SOFTWARE. *) 21 | (* *) 22 | (********************************************************************************) 23 | 24 | DECLARE PLUGIN "extractor_plugin" 25 | 26 | { 27 | open Stdarg 28 | 29 | let output_language = ref `Horn 30 | 31 | let catch f def = try f def with exn -> (CErrors.(user_err (print_no_report exn))) 32 | 33 | let extract def = 34 | let defs = match !output_language with 35 | | `Horn -> Extract.Horn.extract def 36 | | `Smtlib -> Format.fprintf Format.std_formatter "(set-logic HORN)\n@."; 37 | Extract.Smtlib.extract def 38 | in 39 | List.iter 40 | (fun t -> Smtlib_pp.pp_command Format.std_formatter t) 41 | defs 42 | } 43 | 44 | VERNAC COMMAND EXTEND Extract CLASSIFIED AS SIDEFF 45 | | [ "Set" "Array" "Size" int(int) ] -> 46 | { Config.ArraySize.set int } 47 | | [ "Set" "Inline" "Depth" int(int) ] -> 48 | { Config.InlineDepth.set int } 49 | | [ "Set" "Output" "Smtlib" ] -> { output_language := `Smtlib } 50 | | [ "Set" "Output" "Horn" ] -> { output_language := `Horn } 51 | | [ "Extract" "Query" constr(def) ] -> 52 | { catch extract def } 53 | | [ "Extract" "Query" constr(def) "Using" "Lemma" constr(lem) ] -> 54 | { catch Extract.use_lemma lem; 55 | catch extract def } 56 | | [ "Extract" "Query" constr(def) "Using" "Lemmas" constr_list(lems) ] -> 57 | { List.iter (catch Extract.use_lemma) lems; 58 | catch extract def } 59 | | [ "InlineConstant" global(gb) ] -> 60 | { catch Extract.inline_constant gb } 61 | | [ "InlineRelation" global(gb) ] -> 62 | { catch (Extract.inline_relation None) gb } 63 | | [ "InlineRelation" global(gb) "With" "Depth" int(depth) ] -> 64 | { catch (Extract.inline_relation (Some depth)) gb } 65 | | [ "Destruct" "Relation" global(gb) ] -> 66 | { catch (Extract.destruct_relation None) gb } 67 | | [ "Destruct" "Relation" global(gb) "At" "Level" int(depth) ] -> 68 | { catch (Extract.destruct_relation (Some depth)) gb } 69 | END 70 | -------------------------------------------------------------------------------- /compiler/src/extractor.mlpack: -------------------------------------------------------------------------------- 1 | Result 2 | Logger 3 | 4 | Ast 5 | Ast_pp 6 | Ast_utils 7 | 8 | Cic 9 | Cic_utils 10 | 11 | Smtlib 12 | Smtlib_pp 13 | Smtlib_utils 14 | 15 | Tamarin 16 | Tamarin_pp 17 | 18 | Debug 19 | Extract 20 | 21 | Extractor 22 | -------------------------------------------------------------------------------- /compiler/src/logger.ml: -------------------------------------------------------------------------------- 1 | (********************************************************************************) 2 | (* Copyright (c) 2021 Benjamin Farinier *) 3 | (* *) 4 | (* Permission is hereby granted, free of charge, to any person obtaining a *) 5 | (* copy of this software and associated documentation files (the "Software"), *) 6 | (* to deal in the Software without restriction, including without limitation *) 7 | (* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) 8 | (* and/or sell copies of the Software, and to permit persons to whom the *) 9 | (* Software is furnished to do so, subject to the following conditions: *) 10 | (* *) 11 | (* The above copyright notice and this permission notice shall be included in *) 12 | (* all copies or substantial portions of the Software. *) 13 | (* *) 14 | (* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR *) 15 | (* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) 16 | (* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) 17 | (* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER *) 18 | (* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) 19 | (* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) 20 | (* DEALINGS IN THE SOFTWARE. *) 21 | (* *) 22 | (********************************************************************************) 23 | 24 | let () = Format.set_max_indent (Format.get_margin () / 2) 25 | let () = Format.set_max_boxes max_int 26 | 27 | type ('a,'b) msg = (('a, Format.formatter, unit, 'b) format4 -> 'a) -> 'b 28 | 29 | module type SRC = 30 | sig 31 | val name : string 32 | 33 | val info : unit -> bool 34 | val debug : unit -> bool 35 | val warning : unit -> bool 36 | val error : unit -> bool 37 | end 38 | 39 | module type LOG = 40 | sig 41 | val info : ('a,unit) msg -> unit 42 | val debug : ('a,unit) msg -> unit 43 | val warning : ('a,unit) msg -> unit 44 | val error : ('a,unit) msg -> unit 45 | 46 | module Verbose : 47 | sig 48 | type ('a,'b) verbose = 49 | head:('a,unit) msg -> 50 | body:('b,unit) msg -> 51 | unit 52 | 53 | val info : ('a,'b) verbose 54 | val debug : ('a,'b) verbose 55 | val warning : ('a,'b) verbose 56 | val error : ('a,'b) verbose 57 | end 58 | end 59 | 60 | let pp_time fmt () = 61 | let time = Unix.gettimeofday () in 62 | let local = Unix.localtime time in 63 | Format.fprintf fmt "%02i:%02i:%06.3f" 64 | local.Unix.tm_hour 65 | local.Unix.tm_min 66 | (Float.of_int local.Unix.tm_sec +. time -. (Float.round time)) 67 | 68 | type level = Info | Debug | Warning | Error 69 | 70 | let pp_level fmt = function 71 | | Info -> Format.fprintf fmt "info" 72 | | Debug -> Format.fprintf fmt "debug" 73 | | Warning -> Format.fprintf fmt "warning" 74 | | Error -> Format.fprintf fmt "error" 75 | 76 | type channel = { 77 | fmt : Format.formatter; 78 | lvl : level; 79 | src : string; 80 | enable : unit -> bool; 81 | } 82 | 83 | let pp_channel fmt chn = 84 | Format.fprintf fmt "[%a][%a][%s]" 85 | pp_time () pp_level chn.lvl chn.src 86 | 87 | let log chan msg = 88 | if chan.enable () then 89 | msg @@ fun fmt -> 90 | Format.kfprintf 91 | (fun chan -> 92 | Format.kfprintf 93 | (fun chan -> 94 | Format.fprintf chan "\n%!") 95 | chan fmt) 96 | chan.fmt "%a " pp_channel chan 97 | 98 | let sep = String.make 72 '-' 99 | 100 | let verbose chan ~head ~body = 101 | if chan.enable () then 102 | head @@ fun fmt -> 103 | Format.kfprintf 104 | (fun chan -> 105 | Format.kfprintf 106 | (fun chan -> 107 | body @@ fun fmt -> 108 | Format.kfprintf 109 | (fun chan -> 110 | Format.kfprintf 111 | (fun chan -> 112 | Format.fprintf chan "\n%s\n%!" sep) 113 | chan fmt) 114 | chan "\n%s\n%!" sep) 115 | chan fmt) 116 | chan.fmt "%a " pp_channel chan 117 | 118 | module Make (Src : SRC) : LOG = 119 | struct 120 | 121 | let info_channel = { 122 | fmt = Format.err_formatter; 123 | lvl = Info; 124 | src = Src.name; 125 | enable = Src.info; 126 | } 127 | 128 | let debug_channel = { 129 | fmt = Format.err_formatter; 130 | lvl = Debug; 131 | src = Src.name; 132 | enable = Src.debug; 133 | } 134 | 135 | let warning_channel = { 136 | fmt = Format.err_formatter; 137 | lvl = Warning; 138 | src = Src.name; 139 | enable = Src.warning; 140 | } 141 | 142 | let error_channel = { 143 | fmt = Format.err_formatter; 144 | lvl = Error; 145 | src = Src.name; 146 | enable = Src.error; 147 | } 148 | 149 | let info msg = log info_channel msg 150 | let debug msg = log debug_channel msg 151 | let warning msg = log warning_channel msg 152 | let error msg = log error_channel msg 153 | 154 | module Verbose = 155 | struct 156 | type ('a,'b) verbose = 157 | head:('a, unit) msg -> 158 | body:('b, unit) msg -> 159 | unit 160 | 161 | let info ~head ~body = verbose info_channel ~head ~body 162 | let debug ~head ~body = verbose debug_channel ~head ~body 163 | let warning ~head ~body = verbose warning_channel ~head ~body 164 | let error ~head ~body = verbose error_channel ~head ~body 165 | end 166 | end 167 | 168 | module Default (Src : sig val name : string end) = 169 | Make 170 | (struct 171 | let name = Src.name 172 | let info () = Config.Info.get () 173 | let debug () = Config.Debug.get () 174 | let warning () = Config.Warning.get () 175 | let error () = Config.Error.get () 176 | end) 177 | -------------------------------------------------------------------------------- /compiler/src/logger.mli: -------------------------------------------------------------------------------- 1 | (********************************************************************************) 2 | (* Copyright (c) 2021 Benjamin Farinier *) 3 | (* *) 4 | (* Permission is hereby granted, free of charge, to any person obtaining a *) 5 | (* copy of this software and associated documentation files (the "Software"), *) 6 | (* to deal in the Software without restriction, including without limitation *) 7 | (* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) 8 | (* and/or sell copies of the Software, and to permit persons to whom the *) 9 | (* Software is furnished to do so, subject to the following conditions: *) 10 | (* *) 11 | (* The above copyright notice and this permission notice shall be included in *) 12 | (* all copies or substantial portions of the Software. *) 13 | (* *) 14 | (* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR *) 15 | (* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) 16 | (* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) 17 | (* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER *) 18 | (* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) 19 | (* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) 20 | (* DEALINGS IN THE SOFTWARE. *) 21 | (* *) 22 | (********************************************************************************) 23 | 24 | type ('a,'b) msg = (('a, Format.formatter, unit, 'b) format4 -> 'a) -> 'b 25 | 26 | module type SRC = 27 | sig 28 | val name : string 29 | 30 | val info : unit -> bool 31 | val debug : unit -> bool 32 | val warning : unit -> bool 33 | val error : unit -> bool 34 | end 35 | 36 | module type LOG = 37 | sig 38 | val info : ('a,unit) msg -> unit 39 | val debug : ('a,unit) msg -> unit 40 | val warning : ('a,unit) msg -> unit 41 | val error : ('a,unit) msg -> unit 42 | 43 | module Verbose : 44 | sig 45 | type ('a,'b) verbose = 46 | head:('a,unit) msg -> 47 | body:('b,unit) msg -> unit 48 | 49 | val info : ('a,'b) verbose 50 | val debug : ('a,'b) verbose 51 | val warning : ('a,'b) verbose 52 | val error : ('a,'b) verbose 53 | end 54 | end 55 | 56 | module Make (Src:SRC) : LOG 57 | module Default (Src : sig val name : string end) : LOG 58 | -------------------------------------------------------------------------------- /compiler/src/omega.mli: -------------------------------------------------------------------------------- 1 | (********************************************************************************) 2 | (* Copyright (c) 2021 Benjamin Farinier *) 3 | (* *) 4 | (* Permission is hereby granted, free of charge, to any person obtaining a *) 5 | (* copy of this software and associated documentation files (the "Software"), *) 6 | (* to deal in the Software without restriction, including without limitation *) 7 | (* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) 8 | (* and/or sell copies of the Software, and to permit persons to whom the *) 9 | (* Software is furnished to do so, subject to the following conditions: *) 10 | (* *) 11 | (* The above copyright notice and this permission notice shall be included in *) 12 | (* all copies or substantial portions of the Software. *) 13 | (* *) 14 | (* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR *) 15 | (* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) 16 | (* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) 17 | (* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER *) 18 | (* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) 19 | (* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) 20 | (* DEALINGS IN THE SOFTWARE. *) 21 | (* *) 22 | (********************************************************************************) 23 | 24 | open Utils 25 | 26 | type ('a,'b) constant = private { 27 | cnst_hash : int; 28 | cnst_ident: ident; 29 | cnst_type : 'a; 30 | cnst_body : 'b option; 31 | } 32 | 33 | type 'a kind = { 34 | kind_hash : int; 35 | kind_desc : 'a kind_desc; 36 | } 37 | 38 | and _ kind_desc = 39 | | KdProp : prop kind_desc 40 | | KdSet : set kind_desc 41 | | KdArrowSort : _ sym * 'a kind -> 'a kind_desc 42 | | KdArrowTerm : _ var * 'a kind -> 'a kind_desc 43 | 44 | and 'a sym = private { 45 | sym_hash : int; 46 | sym_name : name; 47 | sym_kind : 'a kind; 48 | } 49 | 50 | and 'a var = private { 51 | var_hash : int; 52 | var_name : name; 53 | var_kind : 'a kind; 54 | var_sort : 'a sort; 55 | } 56 | 57 | and 'a sort = private { 58 | sort_hash : int; 59 | sort_kind : 'a kind; 60 | sort_desc : 'a sort_desc; 61 | } 62 | 63 | and _ sort_desc = 64 | | StTrue : prop sort_desc 65 | | StFalse : prop sort_desc 66 | | StBool : set sort_desc 67 | | StInt : set sort_desc 68 | | StFloat : set sort_desc 69 | | StArray : set sort -> set sort_desc 70 | 71 | | StSymbol : 'a sym * sort_or_term array -> 'a sort_desc 72 | | StLambdaSort : _ sym * 'a sort -> 'a sort_desc 73 | | StLambdaTerm : _ var * prop sort -> prop sort_desc 74 | | StApplySort : 'a sort * _ sort -> 'a sort_desc 75 | | StApplyTerm : prop sort * _ term -> prop sort_desc 76 | | StProductSort : _ sym * 'a sort -> 'a sort_desc 77 | | StProductTerm : _ var * 'a sort -> 'a sort_desc 78 | 79 | | StConstant : ('a kind,'a sort) constant * sort_or_term array -> 'a sort_desc 80 | | StInductive : ('a inductive * int) * sort_or_term array -> 'a sort_desc 81 | | StPrimitive : Primitive.relation * 'a kind * sort_or_term array -> 'a sort_desc 82 | | StCase : ('a,prop kind) case * 'a term * prop sort array -> prop sort_desc 83 | 84 | and 'a term = private { 85 | term_hash : int; 86 | term_kind : 'a kind; 87 | term_sort : 'a sort; 88 | term_desc : 'a term_desc; 89 | } 90 | 91 | and _ term_desc = 92 | | TmTrue : prop term_desc 93 | | TmBool : bool -> set term_desc 94 | | TmInt : int -> set term_desc 95 | | TmFloat : float -> set term_desc 96 | | TmArray : set term array * set term -> set term_desc 97 | 98 | | TmVariable : 'a var * sort_or_term array -> 'a term_desc 99 | | TmLambdaSort : _ sym * 'a term -> 'a term_desc 100 | | TmLambdaTerm : _ var * 'a term -> 'a term_desc 101 | | TmApplySort : 'a term * _ sort -> 'a term_desc 102 | | TmApplyTerm : 'a term * _ term -> 'a term_desc 103 | 104 | | TmConstant : ('a sort,'a term) constant * sort_or_term array -> 'a term_desc 105 | | TmConstruct : ('a inductive * int) * int * sort_or_term array -> 'a term_desc 106 | | TmProject : ('a,'b) projection * 'a term -> 'b term_desc 107 | | TmPrimitive : Primitive.constant * 'a sort * sort_or_term array -> 'a term_desc 108 | | TmCase : ('a,'b sort) case * 'a term * 'b term array -> 'b term_desc 109 | 110 | and sort_or_term = Sort : _ sort -> sort_or_term | Term : _ term -> sort_or_term 111 | 112 | and 'a inductive = private { 113 | indv_hash : int; 114 | indv_ident : ident; 115 | mutable indv_body : 'a mutual_inductive; 116 | } 117 | 118 | and 'a mutual_inductive = private { 119 | mind_hash : int; 120 | mind_npars : int; 121 | mind_bodies : 'a one_inductive array; 122 | } 123 | 124 | and 'a one_inductive = private { 125 | oind_hash : int; 126 | oind_name : string; 127 | oind_kind : 'a kind; 128 | oind_ctors : 'a constructor array; 129 | } 130 | 131 | and 'a constructor = private { 132 | ctor_hash : int; 133 | ctor_name : string; 134 | ctor_kind : 'a kind; 135 | ctor_sort : 'a sort; 136 | ctor_nargs : int; 137 | } 138 | 139 | and ('a,'b) projection = private { 140 | proj_hash : int; 141 | proj_indv : 'a inductive * int; 142 | proj_name : string; 143 | proj_sort : 'b sort; 144 | proj_indx : int; 145 | } 146 | 147 | and ('a,'b) case = private { 148 | case_hash : int; 149 | case_nargs : int array; 150 | case_indv : 'a inductive * int; 151 | case_type : 'b; 152 | } 153 | 154 | val witness : 'a kind -> 'a witness 155 | 156 | val extract_relation : Cic.term -> (prop inductive * int) Result.t 157 | val extract_datatype : Cic.term -> (set inductive * int) Result.t 158 | val extract_lemma : Cic.term -> (prop sort,prop term) constant Result.t 159 | 160 | val pp_kind : Format.formatter -> _ kind -> unit 161 | val pp_sort : Format.formatter -> _ sort -> unit 162 | val pp_term : Format.formatter -> _ term -> unit 163 | 164 | val pp_inductive : Format.formatter -> _ inductive -> unit 165 | -------------------------------------------------------------------------------- /compiler/src/omicron.mli: -------------------------------------------------------------------------------- 1 | (********************************************************************************) 2 | (* Copyright (c) 2021 Benjamin Farinier *) 3 | (* *) 4 | (* Permission is hereby granted, free of charge, to any person obtaining a *) 5 | (* copy of this software and associated documentation files (the "Software"), *) 6 | (* to deal in the Software without restriction, including without limitation *) 7 | (* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) 8 | (* and/or sell copies of the Software, and to permit persons to whom the *) 9 | (* Software is furnished to do so, subject to the following conditions: *) 10 | (* *) 11 | (* The above copyright notice and this permission notice shall be included in *) 12 | (* all copies or substantial portions of the Software. *) 13 | (* *) 14 | (* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR *) 15 | (* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) 16 | (* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) 17 | (* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER *) 18 | (* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) 19 | (* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) 20 | (* DEALINGS IN THE SOFTWARE. *) 21 | (* *) 22 | (********************************************************************************) 23 | 24 | open Utils 25 | 26 | type 'a kind = { 27 | kind_hash : int; 28 | kind_desc : 'a kind_desc; 29 | } 30 | 31 | and _ kind_desc = 32 | | KdProp : prop kind_desc 33 | | KdSet : set kind_desc 34 | | KdArrowSort : _ sym * 'a kind -> 'a kind_desc 35 | | KdArrowTerm : _ var * 'a kind -> 'a kind_desc 36 | 37 | and 'a sym = private { 38 | sym_hash : int; 39 | sym_name : name; 40 | sym_kind : 'a kind; 41 | } 42 | 43 | and 'a var = private { 44 | var_hash : int; 45 | var_name : name; 46 | var_kind : 'a kind; 47 | var_sort : 'a sort; 48 | } 49 | 50 | and sym_or_var = Sym : _ sym -> sym_or_var | Var : _ var -> sym_or_var 51 | 52 | and 'a sort = private { 53 | sort_hash : int; 54 | sort_kind : 'a kind; 55 | sort_desc : 'a sort_desc; 56 | } 57 | 58 | and _ sort_desc = 59 | | StTrue : prop sort_desc 60 | | StFalse : prop sort_desc 61 | | StBool : set sort_desc 62 | | StInt : set sort_desc 63 | | StFloat : set sort_desc 64 | | StArray : set sort -> set sort_desc 65 | 66 | | StSymbol : 'a sym * sort_or_term array -> 'a sort_desc 67 | | StProductSort : _ sym * 'a sort -> 'a sort_desc 68 | | StProductTerm : _ var * 'a sort -> 'a sort_desc 69 | | StConstant : ('a kind,'a sort) constant * sort_or_term array -> 'a sort_desc 70 | | StInductive : ('a inductive * int) * sort_or_term array -> 'a sort_desc 71 | | StPrimitive : Primitive.relation * 'a kind * sort_or_term array -> 'a sort_desc 72 | | StCase : ('a,prop kind,prop sort) case * 'a term -> prop sort_desc 73 | 74 | and 'a term = private { 75 | term_hash : int; 76 | term_kind : 'a kind; 77 | term_sort : 'a sort; 78 | term_desc : 'a term_desc; 79 | } 80 | 81 | and _ term_desc = 82 | | TmTrue : prop term_desc 83 | | TmBool : bool -> set term_desc 84 | | TmInt : int -> set term_desc 85 | | TmFloat : float -> set term_desc 86 | | TmArray : set term array * set term -> set term_desc 87 | 88 | | TmVariable : 'a var * sort_or_term array -> 'a term_desc 89 | | TmConstant : ('a sort,'a term) constant * sort_or_term array -> 'a term_desc 90 | | TmConstruct : ('a inductive * int) * int * sort_or_term array -> 'a term_desc 91 | | TmProject : ('a,'b) projection * 'a term -> 'b term_desc 92 | | TmPrimitive : Primitive.constant * 'a sort * sort_or_term array -> 'a term_desc 93 | | TmCase : ('a,'b sort,'b term) case * 'a term -> 'b term_desc 94 | 95 | and sort_or_term = Sort : _ sort -> sort_or_term | Term : _ term -> sort_or_term 96 | 97 | and ('a,'b) constant = private { 98 | cnst_hash : int; 99 | cnst_ident: ident; 100 | cnst_prms : sym_or_var array; 101 | cnst_type : 'a; 102 | cnst_body : 'b option; 103 | } 104 | 105 | and 'a inductive = private { 106 | indv_hash : int; 107 | indv_ident : ident; 108 | mutable indv_body : 'a mutual_inductive; 109 | } 110 | 111 | and 'a mutual_inductive = private { 112 | mind_hash : int; 113 | mind_npars : int; 114 | mind_bodies : 'a one_inductive array; 115 | } 116 | 117 | and 'a one_inductive = private { 118 | oind_hash : int; 119 | oind_name : string; 120 | oind_kind : 'a kind; 121 | oind_ctors : 'a constructor array; 122 | } 123 | 124 | and 'a constructor = private { 125 | ctor_hash : int; 126 | ctor_name : string; 127 | ctor_kind : 'a kind; 128 | ctor_sort : 'a sort; 129 | ctor_nargs : int; 130 | } 131 | 132 | and ('a,'b) projection = private { 133 | proj_hash : int; 134 | proj_indv : 'a inductive * int; 135 | proj_name : string; 136 | proj_sort : 'b sort; 137 | proj_indx : int; 138 | } 139 | 140 | and ('a,'b,'c) case = private { 141 | case_hash : int; 142 | case_indv : 'a inductive * int; 143 | case_type : 'b; 144 | case_branches : 'c branch array; 145 | } 146 | 147 | and 'a branch = private { 148 | bnch_hash : int; 149 | bnch_prms : sym_or_var array; 150 | bnch_desc : 'a; 151 | } 152 | 153 | val witness : 'a kind -> 'a witness 154 | 155 | val get_arrows : ?n:int -> 'a kind -> 'a kind * sym_or_var list 156 | val get_products : ?n:int -> 'a sort -> 'a sort * sym_or_var list 157 | 158 | val get_one_inductive : 'a inductive * int -> 'a one_inductive 159 | 160 | val extract_inductive : ('a Omega.inductive * int) -> ('a inductive * int) Result.t 161 | val extract_constant : ('a Omega.sort,'a Omega.term) Omega.constant -> ('a sort,'a term) constant Result.t 162 | 163 | val pp_kind : Format.formatter -> _ kind -> unit 164 | val pp_sort : Format.formatter -> _ sort -> unit 165 | val pp_term : Format.formatter -> _ term -> unit 166 | 167 | val pp_inductive : Format.formatter -> _ inductive -> unit 168 | -------------------------------------------------------------------------------- /compiler/src/primitive.ml: -------------------------------------------------------------------------------- 1 | (********************************************************************************) 2 | (* Copyright (c) 2021 Benjamin Farinier *) 3 | (* *) 4 | (* Permission is hereby granted, free of charge, to any person obtaining a *) 5 | (* copy of this software and associated documentation files (the "Software"), *) 6 | (* to deal in the Software without restriction, including without limitation *) 7 | (* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) 8 | (* and/or sell copies of the Software, and to permit persons to whom the *) 9 | (* Software is furnished to do so, subject to the following conditions: *) 10 | (* *) 11 | (* The above copyright notice and this permission notice shall be included in *) 12 | (* all copies or substantial portions of the Software. *) 13 | (* *) 14 | (* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR *) 15 | (* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) 16 | (* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) 17 | (* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER *) 18 | (* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) 19 | (* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) 20 | (* DEALINGS IN THE SOFTWARE. *) 21 | (* *) 22 | (********************************************************************************) 23 | 24 | type relation = 25 | | True 26 | | False 27 | | Eq 28 | | Lt 29 | | Le 30 | | Gt 31 | | Ge 32 | | And 33 | | Or 34 | | Not 35 | | ArrayDistinct 36 | 37 | let relation_to_string = function 38 | | True -> "True" 39 | | False-> "False" 40 | | Eq -> "eq" 41 | | Lt -> "lt" 42 | | Le -> "le" 43 | | Gt -> "gt" 44 | | Ge -> "ge" 45 | | And -> "and" 46 | | Or -> "or" 47 | | Not -> "not" 48 | | ArrayDistinct-> "array_distinct" 49 | 50 | let string_to_relation = function 51 | | "True" -> Some True 52 | | "False"-> Some False 53 | | "eq" -> Some Eq 54 | | "lt" -> Some Lt 55 | | "le" -> Some Le 56 | | "gt" -> Some Gt 57 | | "ge" -> Some Ge 58 | | "and" -> Some And 59 | | "or" -> Some Or 60 | | "not" -> Some Not 61 | | _ -> None 62 | 63 | 64 | type constant = 65 | | IntAdd 66 | | IntSub 67 | | IntMul 68 | | IntDiv 69 | | IntMod 70 | | IntEq 71 | | IntLt 72 | | IntLe 73 | | FloatAdd 74 | | FloatSub 75 | | FloatMul 76 | | FloatDiv 77 | | FloatAbs 78 | | FloatSqrt 79 | | FloatEq 80 | | FloatLt 81 | | FloatLe 82 | | ArrayMake 83 | | ArrayDefault 84 | | ArrayGet 85 | | ArraySet 86 | | ArrayCopy 87 | | ArrayLength 88 | | ArrayMap 89 | | Eqb 90 | 91 | let constant_to_string = function 92 | | IntAdd -> "int_add" 93 | | IntSub -> "int_sub" 94 | | IntMul -> "int_mul" 95 | | IntDiv -> "int_div" 96 | | IntMod -> "int_mod" 97 | | IntEq -> "int_eq" 98 | | IntLt -> "int_lt" 99 | | IntLe -> "int_le" 100 | | FloatAdd -> "float_add" 101 | | FloatSub -> "float_sub" 102 | | FloatMul -> "float_mul" 103 | | FloatDiv -> "float_div" 104 | | FloatAbs -> "float_abs" 105 | | FloatSqrt -> "float_sqrt" 106 | | FloatEq -> "float_eq" 107 | | FloatLt -> "float_lt" 108 | | FloatLe -> "float_le" 109 | | ArrayMake -> "array_make" 110 | | ArrayDefault -> "array_default" 111 | | ArrayGet -> "array_get" 112 | | ArraySet -> "array_set" 113 | | ArrayCopy -> "array_copy" 114 | | ArrayLength -> "array_length" 115 | | ArrayMap -> "array_map" 116 | | Eqb -> "eqb" 117 | 118 | 119 | type t = Relation of relation | Constant of constant 120 | 121 | let to_string = function 122 | | Relation rela -> relation_to_string rela 123 | | Constant cnst -> constant_to_string cnst 124 | -------------------------------------------------------------------------------- /compiler/src/primitive.mli: -------------------------------------------------------------------------------- 1 | (********************************************************************************) 2 | (* Copyright (c) 2021 Benjamin Farinier *) 3 | (* *) 4 | (* Permission is hereby granted, free of charge, to any person obtaining a *) 5 | (* copy of this software and associated documentation files (the "Software"), *) 6 | (* to deal in the Software without restriction, including without limitation *) 7 | (* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) 8 | (* and/or sell copies of the Software, and to permit persons to whom the *) 9 | (* Software is furnished to do so, subject to the following conditions: *) 10 | (* *) 11 | (* The above copyright notice and this permission notice shall be included in *) 12 | (* all copies or substantial portions of the Software. *) 13 | (* *) 14 | (* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR *) 15 | (* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) 16 | (* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) 17 | (* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER *) 18 | (* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) 19 | (* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) 20 | (* DEALINGS IN THE SOFTWARE. *) 21 | (* *) 22 | (********************************************************************************) 23 | 24 | type relation = 25 | | True 26 | | False 27 | | Eq 28 | | Lt 29 | | Le 30 | | Gt 31 | | Ge 32 | | And 33 | | Or 34 | | Not 35 | | ArrayDistinct 36 | 37 | val relation_to_string : relation -> string 38 | val string_to_relation : string -> relation option 39 | 40 | 41 | type constant = 42 | | IntAdd 43 | | IntSub 44 | | IntMul 45 | | IntDiv 46 | | IntMod 47 | | IntEq 48 | | IntLt 49 | | IntLe 50 | | FloatAdd 51 | | FloatSub 52 | | FloatMul 53 | | FloatDiv 54 | | FloatAbs 55 | | FloatSqrt 56 | | FloatEq 57 | | FloatLt 58 | | FloatLe 59 | | ArrayMake 60 | | ArrayDefault 61 | | ArrayGet 62 | | ArraySet 63 | | ArrayCopy 64 | | ArrayLength 65 | | ArrayMap 66 | | Eqb 67 | 68 | val constant_to_string : constant -> string 69 | 70 | 71 | type t = Relation of relation | Constant of constant 72 | 73 | val to_string : t -> string 74 | -------------------------------------------------------------------------------- /compiler/src/result.ml: -------------------------------------------------------------------------------- 1 | (********************************************************************************) 2 | (* Copyright (c) 2021 Benjamin Farinier *) 3 | (* *) 4 | (* Permission is hereby granted, free of charge, to any person obtaining a *) 5 | (* copy of this software and associated documentation files (the "Software"), *) 6 | (* to deal in the Software without restriction, including without limitation *) 7 | (* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) 8 | (* and/or sell copies of the Software, and to permit persons to whom the *) 9 | (* Software is furnished to do so, subject to the following conditions: *) 10 | (* *) 11 | (* The above copyright notice and this permission notice shall be included in *) 12 | (* all copies or substantial portions of the Software. *) 13 | (* *) 14 | (* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR *) 15 | (* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) 16 | (* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) 17 | (* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER *) 18 | (* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) 19 | (* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) 20 | (* DEALINGS IN THE SOFTWARE. *) 21 | (* *) 22 | (********************************************************************************) 23 | 24 | 25 | type 'a t = ('a, exn) result 26 | 27 | 28 | module Monad = 29 | struct 30 | 31 | let (>>=) r f = match r with Ok v -> f v | Error _ as e -> e 32 | 33 | let (>>|) r f = match r with Ok v -> Ok (f v) | Error _ as e -> e 34 | 35 | 36 | let return = function 37 | | Error exn -> raise exn 38 | | Ok x -> x 39 | 40 | 41 | let failure msg = 42 | Error (Failure (msg @@ fun fmt -> Format.sprintf fmt)) 43 | 44 | end 45 | 46 | 47 | module Option = 48 | struct 49 | 50 | let map f option = 51 | match option with 52 | | None -> Ok None 53 | | Some x -> 54 | match f x with 55 | | Ok x -> Ok (Some x) 56 | | Error _ as e -> e 57 | 58 | end 59 | 60 | 61 | module Array = 62 | struct 63 | 64 | let fold_left f acc array = 65 | match acc with 66 | | Ok acc -> 67 | (try 68 | Ok 69 | (Array.fold_left 70 | (fun acc x -> 71 | match f acc x with 72 | | Ok v -> v 73 | | Error exn -> raise exn) 74 | acc array) 75 | with exn -> Error exn) 76 | | Error _ as result -> result 77 | 78 | let fold_right f array acc = 79 | match acc with 80 | | Ok acc -> 81 | (try 82 | Ok 83 | (Array.fold_right 84 | (fun x acc -> 85 | match f x acc with 86 | | Ok v -> v 87 | | Error exn -> raise exn) 88 | array acc) 89 | with exn -> Error exn) 90 | | Error _ as result -> result 91 | 92 | let map f array = 93 | try 94 | Ok (Array.map 95 | (fun x -> match f x with 96 | | Ok v -> v 97 | | Error exn -> raise exn) 98 | array) 99 | with exn -> Error exn 100 | 101 | let map2 f array1 array2 = 102 | try 103 | Ok (Array.map2 104 | (fun x y -> match f x y with 105 | | Ok v -> v 106 | | Error exn -> raise exn) 107 | array1 array2) 108 | with exn -> Error exn 109 | 110 | end 111 | 112 | 113 | module List = 114 | struct 115 | 116 | let fold_left f acc list = 117 | match acc with 118 | | Ok acc -> 119 | (try 120 | Ok 121 | (List.fold_left 122 | (fun acc x -> 123 | match f acc x with 124 | | Ok v -> v 125 | | Error exn -> raise exn) 126 | acc list) 127 | with exn -> Error exn) 128 | | Error _ as result -> result 129 | 130 | let fold_right f list acc = 131 | match acc with 132 | | Ok acc -> 133 | (try 134 | Ok 135 | (List.fold_right 136 | (fun x acc -> 137 | match f x acc with 138 | | Ok v -> v 139 | | Error exn -> raise exn) 140 | list acc) 141 | with exn -> Error exn) 142 | | Error _ as result -> result 143 | 144 | let map f list = 145 | try 146 | Ok (List.map 147 | (fun x -> match f x with 148 | | Ok v -> v 149 | | Error exn -> raise exn) 150 | list) 151 | with exn -> Error exn 152 | 153 | let map2 f list1 list2 = 154 | try 155 | Ok (List.map2 156 | (fun x y -> match f x y with 157 | | Ok v -> v 158 | | Error exn -> raise exn) 159 | list1 list2) 160 | with exn -> Error exn 161 | 162 | let filter_map f list = 163 | try 164 | Ok (List.filter_map 165 | (fun x -> match f x with 166 | | Ok v -> v 167 | | Error exn -> raise exn) 168 | list) 169 | with exn -> Error exn 170 | end 171 | 172 | -------------------------------------------------------------------------------- /compiler/src/result.mli: -------------------------------------------------------------------------------- 1 | (********************************************************************************) 2 | (* Copyright (c) 2021 Benjamin Farinier *) 3 | (* *) 4 | (* Permission is hereby granted, free of charge, to any person obtaining a *) 5 | (* copy of this software and associated documentation files (the "Software"), *) 6 | (* to deal in the Software without restriction, including without limitation *) 7 | (* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) 8 | (* and/or sell copies of the Software, and to permit persons to whom the *) 9 | (* Software is furnished to do so, subject to the following conditions: *) 10 | (* *) 11 | (* The above copyright notice and this permission notice shall be included in *) 12 | (* all copies or substantial portions of the Software. *) 13 | (* *) 14 | (* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR *) 15 | (* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) 16 | (* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) 17 | (* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER *) 18 | (* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) 19 | (* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) 20 | (* DEALINGS IN THE SOFTWARE. *) 21 | (* *) 22 | (********************************************************************************) 23 | 24 | 25 | type 'a t = ('a, exn) result 26 | 27 | 28 | module Monad : 29 | sig 30 | 31 | val (>>=) : 'a t -> ('a -> 'b t) -> 'b t 32 | 33 | val (>>|) : 'a t -> ('a -> 'b) -> 'b t 34 | 35 | val return : 'a t -> 'a 36 | 37 | val failure : ((('a, unit, string) format -> 'a) -> string) -> 'b t 38 | 39 | end 40 | 41 | 42 | module Option : 43 | sig 44 | 45 | val map : ('a -> 'b t) -> 'a option -> 'b option t 46 | 47 | end 48 | 49 | 50 | module Array : 51 | sig 52 | 53 | val fold_left : ('a -> 'b -> 'a t) -> 'a t -> 'b array -> 'a t 54 | 55 | val fold_right : ('b -> 'a -> 'a t) -> 'b array -> 'a t -> 'a t 56 | 57 | val map : ('a -> 'b t) -> 'a array -> 'b array t 58 | 59 | val map2 : ('a -> 'b -> 'c t) -> 'a array -> 'b array -> 'c array t 60 | 61 | end 62 | 63 | 64 | module List : 65 | sig 66 | 67 | val fold_left : ('a -> 'b -> 'a t) -> 'a t -> 'b list -> 'a t 68 | 69 | val fold_right : ('b -> 'a -> 'a t) -> 'b list -> 'a t -> 'a t 70 | 71 | val map : ('a -> 'b t) -> 'a list -> 'b list t 72 | 73 | val map2 : ('a -> 'b -> 'c t) -> 'a list -> 'b list -> 'c list t 74 | 75 | val filter_map : ('a -> 'b option t) -> 'a list -> 'b list t 76 | 77 | end 78 | 79 | -------------------------------------------------------------------------------- /compiler/src/smtlib_pp.mli: -------------------------------------------------------------------------------- 1 | (********************************************************************************) 2 | (* Copyright (c) 2021 Benjamin Farinier *) 3 | (* *) 4 | (* Permission is hereby granted, free of charge, to any person obtaining a *) 5 | (* copy of this software and associated documentation files (the "Software"), *) 6 | (* to deal in the Software without restriction, including without limitation *) 7 | (* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) 8 | (* and/or sell copies of the Software, and to permit persons to whom the *) 9 | (* Software is furnished to do so, subject to the following conditions: *) 10 | (* *) 11 | (* The above copyright notice and this permission notice shall be included in *) 12 | (* all copies or substantial portions of the Software. *) 13 | (* *) 14 | (* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR *) 15 | (* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) 16 | (* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) 17 | (* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER *) 18 | (* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) 19 | (* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) 20 | (* DEALINGS IN THE SOFTWARE. *) 21 | (* *) 22 | (********************************************************************************) 23 | 24 | (** Pretty-printer for SMT-LIB AST *) 25 | val pp_spec_constant : Format.formatter -> Smtlib.constant -> unit 26 | 27 | val pp_symbol : Format.formatter -> Smtlib.symbol -> unit 28 | (** pretty-prints a SMT symbol *) 29 | 30 | val pp_sort : Format.formatter -> Smtlib.sort -> unit 31 | (** pretty-prints a SMT sort *) 32 | 33 | val pp_term : Format.formatter -> Smtlib.term -> unit 34 | (** pretty-prints a SMT term *) 35 | 36 | val pp_qual_identifier : Format.formatter -> Smtlib.qual_identifier -> unit 37 | (** pretty-prints a SMT qualified identifier *) 38 | 39 | val pp: Format.formatter -> Smtlib.script -> unit 40 | (** [pp fmt ast] pretty-prints a full SMT-LIB script onto a formatter *) 41 | 42 | val pp_command: Format.formatter -> Smtlib.command -> unit 43 | 44 | val pp_commands: Format.formatter -> Smtlib.commands -> unit 45 | (** pp_commands pretty_prints an arbitrary command list onto a formatter. 46 | Used by pp. 47 | *) 48 | 49 | val pp_tofile: string -> Smtlib.script -> unit 50 | (** [pp_tofile filename script] Prints a SMT-LIB script into the file named 51 | ** [filename]. The file is created if needed. Contents from any present file is 52 | ** not preserved. 53 | *) 54 | -------------------------------------------------------------------------------- /compiler/src/smtlib_utils.mli: -------------------------------------------------------------------------------- 1 | (********************************************************************************) 2 | (* Copyright (c) 2021 Benjamin Farinier *) 3 | (* *) 4 | (* Permission is hereby granted, free of charge, to any person obtaining a *) 5 | (* copy of this software and associated documentation files (the "Software"), *) 6 | (* to deal in the Software without restriction, including without limitation *) 7 | (* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) 8 | (* and/or sell copies of the Software, and to permit persons to whom the *) 9 | (* Software is furnished to do so, subject to the following conditions: *) 10 | (* *) 11 | (* The above copyright notice and this permission notice shall be included in *) 12 | (* all copies or substantial portions of the Software. *) 13 | (* *) 14 | (* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR *) 15 | (* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) 16 | (* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) 17 | (* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER *) 18 | (* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) 19 | (* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) 20 | (* DEALINGS IN THE SOFTWARE. *) 21 | (* *) 22 | (********************************************************************************) 23 | 24 | val term_to_term : _ Ast.term -> Smtlib.term 25 | 26 | val ast_to_horn : Ast.t -> Smtlib.command list 27 | val ast_to_smtlib : Ast.t -> Smtlib.command list 28 | -------------------------------------------------------------------------------- /compiler/src/utils.ml: -------------------------------------------------------------------------------- 1 | (********************************************************************************) 2 | (* Copyright (c) 2021 Benjamin Farinier *) 3 | (* *) 4 | (* Permission is hereby granted, free of charge, to any person obtaining a *) 5 | (* copy of this software and associated documentation files (the "Software"), *) 6 | (* to deal in the Software without restriction, including without limitation *) 7 | (* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) 8 | (* and/or sell copies of the Software, and to permit persons to whom the *) 9 | (* Software is furnished to do so, subject to the following conditions: *) 10 | (* *) 11 | (* The above copyright notice and this permission notice shall be included in *) 12 | (* all copies or substantial portions of the Software. *) 13 | (* *) 14 | (* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR *) 15 | (* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) 16 | (* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) 17 | (* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER *) 18 | (* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) 19 | (* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) 20 | (* DEALINGS IN THE SOFTWARE. *) 21 | (* *) 22 | (********************************************************************************) 23 | 24 | type set 25 | type prop 26 | 27 | type (_,_) eq = Eq : ('a,'a) eq | Nq : ('a,'b) eq 28 | 29 | type _ witness = Prop : prop witness | Set : set witness 30 | 31 | let equal_witness : type a b. a witness -> b witness -> (a,b) eq = 32 | fun u w -> 33 | match u, w with 34 | | Prop, Prop -> Eq 35 | | Set, Set -> Eq 36 | | _, _ -> Nq 37 | 38 | type ident = string * string list 39 | 40 | let kername_to_ident kn = 41 | let string = Names.KerName.to_string kn in 42 | match List.rev (String.split_on_char '.' string) with 43 | | hd :: tl -> hd, tl 44 | | [] -> assert false 45 | 46 | let ident_to_string (hd, tl) = 47 | String.concat "." (List.rev (hd :: tl)) 48 | 49 | let pp_ident fmt ident = Format.fprintf fmt "%s" (ident_to_string ident) 50 | 51 | module Name = 52 | struct 53 | 54 | type t = 55 | | Anonymous 56 | | Id of int 57 | | Name of string 58 | 59 | let fresh = ref 0 60 | let fresh () = incr fresh; Id !fresh 61 | 62 | let compare (nm1: t) (nm2: t) = compare nm1 nm2 63 | 64 | let equal nm1 nm2 = 65 | match nm1, nm2 with 66 | | Anonymous, Anonymous -> true 67 | | Id int1, Id int2 -> int1 = int2 68 | | Name string1, Name string2 -> String.equal string1 string2 69 | | _, _ -> false 70 | 71 | let of_string string = 72 | if String.equal "_" string then Anonymous 73 | else 74 | try Id (int_of_string String.(sub string 1 (length string - 2))) 75 | with _ -> Name string 76 | 77 | let to_string name = 78 | match name with 79 | | Anonymous -> Printf.sprintf "_" 80 | | Id int -> Printf.sprintf "<%i>" int 81 | | Name string -> string 82 | 83 | let pp fmt name = Format.fprintf fmt "%s" (to_string name) 84 | 85 | end 86 | 87 | type name = Name.t 88 | 89 | module IntSet = Set.Make 90 | (struct 91 | type t = int 92 | let compare i1 i2 = compare i1 i2 93 | end) 94 | 95 | module IntMap = Map.Make 96 | (struct 97 | type t = int 98 | let compare i1 i2 = compare i1 i2 99 | end) 100 | 101 | module IntHashtbl = Hashtbl.Make 102 | (struct 103 | type t = int 104 | let equal i1 i2 = i1 = i2 105 | let hash i = i 106 | end) 107 | 108 | module StringSet = Set.Make 109 | (struct 110 | type t = string 111 | let compare s1 s2 = String.compare s1 s2 112 | end) 113 | 114 | module StringMap = Map.Make 115 | (struct 116 | type t = string 117 | let compare s1 s2 = String.compare s1 s2 118 | end) 119 | 120 | module StringHashtbl = Hashtbl.Make 121 | (struct 122 | type t = string 123 | let equal s1 s2 = String.equal s1 s2 124 | let hash s = Hashtbl.hash s 125 | end) 126 | 127 | module NameSet = Set.Make 128 | (struct 129 | type t = name 130 | let compare nm1 nm2 = Name.compare nm1 nm2 131 | end) 132 | 133 | module NameMap = Map.Make 134 | (struct 135 | type t = name 136 | let compare nm1 nm2 = Name.compare nm1 nm2 137 | end) 138 | 139 | module List = 140 | struct 141 | include Stdlib.List 142 | 143 | let rec drop n list = 144 | if n > 0 then 145 | match list with 146 | | _ :: list -> drop (n-1) list 147 | | [] -> [] 148 | else list 149 | 150 | let rec take n list = 151 | if n > 0 then 152 | match list with 153 | | x :: list -> x :: take (n-1) list 154 | | [] -> [] 155 | else [] 156 | 157 | end 158 | -------------------------------------------------------------------------------- /compiler/src/utils.mli: -------------------------------------------------------------------------------- 1 | (********************************************************************************) 2 | (* Copyright (c) 2021 Benjamin Farinier *) 3 | (* *) 4 | (* Permission is hereby granted, free of charge, to any person obtaining a *) 5 | (* copy of this software and associated documentation files (the "Software"), *) 6 | (* to deal in the Software without restriction, including without limitation *) 7 | (* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) 8 | (* and/or sell copies of the Software, and to permit persons to whom the *) 9 | (* Software is furnished to do so, subject to the following conditions: *) 10 | (* *) 11 | (* The above copyright notice and this permission notice shall be included in *) 12 | (* all copies or substantial portions of the Software. *) 13 | (* *) 14 | (* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR *) 15 | (* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) 16 | (* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) 17 | (* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER *) 18 | (* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) 19 | (* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) 20 | (* DEALINGS IN THE SOFTWARE. *) 21 | (* *) 22 | (********************************************************************************) 23 | 24 | type set 25 | type prop 26 | 27 | 28 | type (_,_) eq = Eq : ('a,'a) eq | Nq : ('a,'b) eq 29 | 30 | type _ witness = Prop : prop witness | Set : set witness 31 | 32 | val equal_witness : 'a witness -> 'b witness -> ('a,'b) eq 33 | 34 | 35 | type ident = string * string list 36 | 37 | val kername_to_ident : Names.KerName.t -> ident 38 | val ident_to_string : ident -> string 39 | 40 | val pp_ident : Format.formatter -> ident -> unit 41 | 42 | 43 | module Name : 44 | sig 45 | type t = 46 | | Anonymous 47 | | Id of int 48 | | Name of string 49 | 50 | val fresh : unit -> t 51 | val equal : t -> t -> bool 52 | val of_string : string -> t 53 | val to_string : t -> string 54 | val pp : Format.formatter -> t -> unit 55 | end 56 | 57 | type name = Name.t 58 | 59 | 60 | module IntSet : Set.S with type elt = int 61 | module IntMap : Map.S with type key = int 62 | module IntHashtbl : Hashtbl.S with type key = int 63 | 64 | module StringSet : Set.S with type elt = string 65 | module StringMap : Map.S with type key = string 66 | module StringHashtbl : Hashtbl.S with type key = string 67 | 68 | module NameSet : Set.S with type elt = name 69 | module NameMap : Map.S with type key = name 70 | 71 | module List : 72 | sig 73 | include module type of List 74 | 75 | val drop : int -> 'a list -> 'a list 76 | val take : int -> 'a list -> 'a list 77 | end 78 | -------------------------------------------------------------------------------- /compiler/theories/Array.v: -------------------------------------------------------------------------------- 1 | (********************************************************************************) 2 | (* Copyright (c) 2021 Benjamin Farinier *) 3 | (* *) 4 | (* Permission is hereby granted, free of charge, to any person obtaining a *) 5 | (* copy of this software and associated documentation files (the "Software"), *) 6 | (* to deal in the Software without restriction, including without limitation *) 7 | (* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) 8 | (* and/or sell copies of the Software, and to permit persons to whom the *) 9 | (* Software is furnished to do so, subject to the following conditions: *) 10 | (* *) 11 | (* The above copyright notice and this permission notice shall be included in *) 12 | (* all copies or substantial portions of the Software. *) 13 | (* *) 14 | (* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR *) 15 | (* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) 16 | (* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) 17 | (* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER *) 18 | (* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) 19 | (* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) 20 | (* DEALINGS IN THE SOFTWARE. *) 21 | (* *) 22 | (********************************************************************************) 23 | 24 | Definition array (T : Type) := nat -> T. 25 | Definition const (T : Type) (e : T) : array T := fun (i : nat) => e. 26 | 27 | Definition select (T : Type) (a : array T) (i : nat) : T := a i. 28 | Definition store (T : Type) (a : array T) (i : nat) (e : T) : array T := 29 | fun j => if Nat.eqb i j then e else a j. 30 | 31 | Definition map {T U : Type} (f : T -> U) (a : array T) : array U := 32 | fun (i : nat) => f (select _ a i). 33 | 34 | Definition pairwise {T : Type} (P : T -> T -> Prop) (a : array T) : Prop := 35 | forall (i j : nat), i <> j -> P (select _ a i) (select _ a j). 36 | 37 | Definition distinct {T : Type} (a : array T) : Prop := pairwise (fun x y => x <> y) a. 38 | 39 | Notation "[| E |]" := (const _ E) (at level 80, format "[| E |]"). 40 | Notation "A .[ I ]" := (select _ A I) (at level 80, format "A .[ I ]"). 41 | Notation "A .[ I ] <- E" := (store _ A I E) (at level 80, format "A .[ I ] <- E"). 42 | -------------------------------------------------------------------------------- /compiler/theories/Equality.v: -------------------------------------------------------------------------------- 1 | (********************************************************************************) 2 | (* Copyright (c) 2021 Benjamin Farinier *) 3 | (* *) 4 | (* Permission is hereby granted, free of charge, to any person obtaining a *) 5 | (* copy of this software and associated documentation files (the "Software"), *) 6 | (* to deal in the Software without restriction, including without limitation *) 7 | (* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) 8 | (* and/or sell copies of the Software, and to permit persons to whom the *) 9 | (* Software is furnished to do so, subject to the following conditions: *) 10 | (* *) 11 | (* The above copyright notice and this permission notice shall be included in *) 12 | (* all copies or substantial portions of the Software. *) 13 | (* *) 14 | (* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR *) 15 | (* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) 16 | (* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) 17 | (* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER *) 18 | (* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) 19 | (* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) 20 | (* DEALINGS IN THE SOFTWARE. *) 21 | (* *) 22 | (********************************************************************************) 23 | 24 | Axiom eqb : forall (A: Set) (x y : A), bool. 25 | 26 | Axiom eqb_eq : forall A x y, eqb A x y = true <-> x = y. 27 | 28 | Notation "x =? y" := (eqb _ x y) (at level 30, no associativity). 29 | -------------------------------------------------------------------------------- /compiler/theories/Loader.v: -------------------------------------------------------------------------------- 1 | (********************************************************************************) 2 | (* Copyright (c) 2021 Benjamin Farinier *) 3 | (* *) 4 | (* Permission is hereby granted, free of charge, to any person obtaining a *) 5 | (* copy of this software and associated documentation files (the "Software"), *) 6 | (* to deal in the Software without restriction, including without limitation *) 7 | (* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) 8 | (* and/or sell copies of the Software, and to permit persons to whom the *) 9 | (* Software is furnished to do so, subject to the following conditions: *) 10 | (* *) 11 | (* The above copyright notice and this permission notice shall be included in *) 12 | (* all copies or substantial portions of the Software. *) 13 | (* *) 14 | (* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR *) 15 | (* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) 16 | (* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) 17 | (* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER *) 18 | (* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) 19 | (* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) 20 | (* DEALINGS IN THE SOFTWARE. *) 21 | (* *) 22 | (********************************************************************************) 23 | 24 | Declare ML Module "extractor". 25 | -------------------------------------------------------------------------------- /compiler/theories/dune: -------------------------------------------------------------------------------- 1 | (coq.theory 2 | (name Extractor) ; This will determine the toplevel 3 | ; module of your theory, modules will 4 | ; be MyPlugin.A, etc... when seen from 5 | ; outside. 6 | 7 | (package extractor) ; Adding this line will make your 8 | ; library installable in the package 9 | 10 | (libraries extractor.plugin)) ; Here you should declare the 11 | ; dependencies on the ML plugins your 12 | ; Coq files depend. 13 | -------------------------------------------------------------------------------- /docs/report.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/SecPriv/webspec/b7ff6b714b3a4b572c108cc3136506da3d263eff/docs/report.pdf -------------------------------------------------------------------------------- /model/CORSInvariant.v: -------------------------------------------------------------------------------- 1 | (********************************************************************************) 2 | (* Copyright (c) 2021 Lorenzo Veronese & Benjamin Farinier *) 3 | (* *) 4 | (* Permission is hereby granted, free of charge, to any person obtaining a *) 5 | (* copy of this software and associated documentation files (the "Software"), *) 6 | (* to deal in the Software without restriction, including without limitation *) 7 | (* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) 8 | (* and/or sell copies of the Software, and to permit persons to whom the *) 9 | (* Software is furnished to do so, subject to the following conditions: *) 10 | (* *) 11 | (* The above copyright notice and this permission notice shall be included in *) 12 | (* all copies or substantial portions of the Software. *) 13 | (* *) 14 | (* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR *) 15 | (* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) 16 | (* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) 17 | (* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER *) 18 | (* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) 19 | (* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) 20 | (* DEALINGS IN THE SOFTWARE. *) 21 | (* *) 22 | (********************************************************************************) 23 | 24 | Load LoadPath. 25 | From Extractor Require Import Loader. 26 | From Extractor Require Import Array. 27 | 28 | Require Import Browser. 29 | Require Import BrowserStates. 30 | 31 | Require Import Coq.Lists.List. 32 | 33 | 34 | Definition CORSInvariant (gb: Global) (evs: list Event) (st: State) : Prop := 35 | forall em rq corr scr_idx scr_pt rp rp_corr em_idx _evs, 36 | Reachable gb evs st -> 37 | (* Non-simple request made by a script *) 38 | evs = (EvRequest em rq corr :: _evs) -> 39 | em = EmitterScript scr_idx scr_pt /\ (emitters gb).[em_idx] = em -> 40 | is_cross_origin_request (st_window st) rq -> 41 | not (is_cors_simple_request rq) -> 42 | (* Get CORS preflight response *) 43 | is_cors_authorization_response gb st em_idx rq corr rp rp_corr -> 44 | (* The auth. comes from rq_url *) 45 | origin_of_url (rq_url rq) = origin_of_url (rp_url rp). 46 | 47 | 48 | (* Fix the issue by disabling preflight redirection with: 49 | c_redirect_preflight_requests (config gb) = false -> 50 | *) 51 | Inductive CORSQuery (gb: Global) (evs: list Event) (st: State) : Prop := 52 | | Query_state : forall em rq corr scr_idx scr_pt rp rp_corr em_idx _evs, 53 | Reachable gb evs st -> 54 | (* Non-simple request made by a script *) 55 | evs = (EvRequest em rq corr :: _evs) -> 56 | em = EmitterScript scr_idx scr_pt /\ (emitters gb).[em_idx] = em -> 57 | is_cross_origin_request (st_window st) rq -> 58 | not (is_cors_simple_request rq) -> 59 | (* Get CORS preflight response *) 60 | is_cors_authorization_response gb st em_idx rq corr rp rp_corr -> 61 | (* The auth. does not come from rq_url *) 62 | origin_of_url (rq_url rq) <> origin_of_url (rp_url rp) -> 63 | CORSQuery gb evs st. 64 | 65 | 66 | Theorem CORSQuery_invalidate_CORSInvariant : 67 | forall gb evs st (x:CORSQuery gb evs st), 68 | CORSInvariant gb evs st -> False. 69 | Proof. 70 | intros. 71 | unfold CORSInvariant in H. 72 | destruct x. 73 | specialize (H em rq corr scr_idx scr_pt rp rp_corr em_idx _evs H0 H1 H2 H3 H4 H5). 74 | congruence. 75 | Qed. 76 | 77 | 78 | InlineRelation is_secure_context With Depth 0. 79 | InlineRelation is_not_secure_context With Depth 0. 80 | InlineRelation window_ctx_of_dom_path_rec With Depth 0. 81 | InlineRelation window_ctx_of_dom_path With Depth 0. 82 | InlineRelation is_script_in_dom_path With Depth 0. 83 | InlineRelation is_form_in_dom_path With Depth 0. 84 | InlineRelation update_window_on_response With Depth 0. 85 | InlineRelation update_window_html_from_ctx With Depth 0. 86 | InlineRelation update_window_domain_from_ctx With Depth 0. 87 | InlineRelation update_html_req_initiator With Depth 0. 88 | InlineRelation is_valid_setcookie_from_ctx With Depth 0. 89 | InlineRelation in_redirect_history With Depth 2. 90 | InlineRelation Scriptstate With Depth 5. 91 | 92 | Set Array Size 5. 93 | Extract Query CORSQuery Using Lemma script_state_is_reachable. 94 | -------------------------------------------------------------------------------- /model/HttpOnlyInvariant.v: -------------------------------------------------------------------------------- 1 | (********************************************************************************) 2 | (* Copyright (c) 2021 Lorenzo Veronese & Benjamin Farinier *) 3 | (* *) 4 | (* Permission is hereby granted, free of charge, to any person obtaining a *) 5 | (* copy of this software and associated documentation files (the "Software"), *) 6 | (* to deal in the Software without restriction, including without limitation *) 7 | (* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) 8 | (* and/or sell copies of the Software, and to permit persons to whom the *) 9 | (* Software is furnished to do so, subject to the following conditions: *) 10 | (* *) 11 | (* The above copyright notice and this permission notice shall be included in *) 12 | (* all copies or substantial portions of the Software. *) 13 | (* *) 14 | (* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR *) 15 | (* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) 16 | (* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) 17 | (* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER *) 18 | (* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) 19 | (* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) 20 | (* DEALINGS IN THE SOFTWARE. *) 21 | (* *) 22 | (********************************************************************************) 23 | 24 | Load LoadPath. 25 | From Extractor Require Import Loader. 26 | From Extractor Require Import Array. 27 | 28 | Require Import Browser. 29 | Require Import BrowserStates. 30 | 31 | 32 | Definition HttpOnlyInvariant (gb: Global) (evs: list Event) (st: State) : Prop := 33 | forall sc cm c_idx cookie, 34 | Reachable gb evs st -> 35 | (* A script has access to the cookie cm *) 36 | Scriptstate gb st sc (SOCookie c_idx cm) -> 37 | (* The cookie is not httponly *) 38 | st_cookiejar st.[c_idx] = Some cookie -> 39 | cj_http_only cookie = false. 40 | 41 | 42 | (* Fix the issue by enabling forbidden headers with: 43 | (c_forbidden_headers (config gb)) = true -> 44 | *) 45 | Inductive HttpOnlyQuery (gb: Global) (evs: list Event) (st: State) : Prop := 46 | | Query_state : forall sc cm c_idx cookie, 47 | Reachable gb evs st -> 48 | (* A script has access to the cookie cm *) 49 | Scriptstate gb st sc (SOCookie c_idx cm) -> 50 | (* The cookie is httponly *) 51 | st_cookiejar st.[c_idx] = Some cookie -> 52 | cm_name cm = sc_name cookie /\ cm_value cm = sc_value cookie -> 53 | sc_http_only cookie = true -> 54 | HttpOnlyQuery gb evs st. 55 | 56 | 57 | Theorem HttpOnlyQuery_invalidate_HttpOnlyInvariant : 58 | forall gb evs st (x:HttpOnlyQuery gb evs st), 59 | HttpOnlyInvariant gb evs st -> False. 60 | Proof. 61 | intros. 62 | unfold HttpOnlyInvariant in H. 63 | destruct x. 64 | specialize (H sc cm c_idx cookie H0 H1 H2). 65 | unfold cj_http_only in H. 66 | congruence. 67 | Qed. 68 | 69 | 70 | InlineRelation is_secure_context With Depth 0. 71 | InlineRelation is_not_secure_context With Depth 0. 72 | InlineRelation window_ctx_of_dom_path_rec With Depth 0. 73 | InlineRelation window_ctx_of_dom_path With Depth 0. 74 | InlineRelation is_script_in_dom_path With Depth 0. 75 | InlineRelation is_form_in_dom_path With Depth 0. 76 | InlineRelation update_window_on_response With Depth 0. 77 | InlineRelation update_window_html_from_ctx With Depth 0. 78 | InlineRelation update_window_domain_from_ctx With Depth 0. 79 | InlineRelation is_valid_setcookie_from_ctx With Depth 0. 80 | InlineRelation update_html_req_initiator With Depth 0. 81 | InlineRelation in_redirect_history With Depth 2. 82 | InlineRelation Scriptstate With Depth 5. 83 | 84 | Set Array Size 5. 85 | Extract Query HttpOnlyQuery Using Lemma script_state_is_reachable. 86 | -------------------------------------------------------------------------------- /model/LSInvariant.v: -------------------------------------------------------------------------------- 1 | (********************************************************************************) 2 | (* Copyright (c) 2021 Lorenzo Veronese & Benjamin Farinier *) 3 | (* *) 4 | (* Permission is hereby granted, free of charge, to any person obtaining a *) 5 | (* copy of this software and associated documentation files (the "Software"), *) 6 | (* to deal in the Software without restriction, including without limitation *) 7 | (* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) 8 | (* and/or sell copies of the Software, and to permit persons to whom the *) 9 | (* Software is furnished to do so, subject to the following conditions: *) 10 | (* *) 11 | (* The above copyright notice and this permission notice shall be included in *) 12 | (* all copies or substantial portions of the Software. *) 13 | (* *) 14 | (* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR *) 15 | (* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) 16 | (* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) 17 | (* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER *) 18 | (* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) 19 | (* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) 20 | (* DEALINGS IN THE SOFTWARE. *) 21 | (* *) 22 | (********************************************************************************) 23 | 24 | Load LoadPath. 25 | From Extractor Require Import Loader. 26 | From Extractor Require Import Array. 27 | 28 | Require Import Browser. 29 | Require Import BrowserStates. 30 | 31 | Require Import Coq.Lists.List. 32 | Import List.ListNotations. 33 | 34 | 35 | Definition LSInvariant (gb: Global) (evs: list Event) (st: State) : Prop := 36 | forall evs pt _evs frm fhtml fwd ctx lv pt_idx init_idx, 37 | let get_csp wd := 38 | rp_hd_csp (dc_headers (wd_document wd)) in 39 | Reachable gb evs st -> 40 | (* A document has just been loaded in a frame *) 41 | evs = (EvDOMUpdate pt :: _evs) -> 42 | is_frame_in_dom_path gb (st_window st) pt frm fhtml fwd ctx -> 43 | is_local_scheme (wd_location fwd) -> 44 | (* get navigation initiator *) 45 | pt = DOMPath lv (DOMIndex pt_idx) -> 46 | is_wd_initiator_of_idx ctx pt_idx (Some init_idx) -> 47 | (* The csp is equal to the req. initiator *) 48 | get_csp fwd = get_csp (windows gb.[init_idx]). 49 | 50 | 51 | Inductive LSQuery (gb: Global) (evs: list Event) (st: State) : Prop := 52 | | Query_state2 : forall (pt : NestedDOMPath) (_evs : list Event) (frm : Frame) (fhtml : HTML) (fwd ctx : Window) (lv : list nat) (pt_idx init_idx : nat), 53 | Reachable gb evs st -> 54 | 55 | (* Change these values to change the model behavior *) 56 | c_csp_inherit_local_from_initiator (config gb) = true -> 57 | c_csp_inherit_blob_from_creator (config gb) = true -> 58 | 59 | (* A document has just been loaded in a frame *) 60 | evs = (EvDOMUpdate pt :: _evs) -> 61 | is_frame_in_dom_path gb (st_window st) pt frm fhtml fwd ctx -> 62 | is_local_scheme (wd_location fwd) -> 63 | (* get request initiator *) 64 | pt = DOMPath lv (DOMIndex pt_idx) -> 65 | in_body (dc_init (wd_document ctx)).[pt_idx] = Some init_idx -> 66 | (* The csp is equal to the req. initiator *) 67 | rp_hd_csp (dc_headers (wd_document fwd)) <> 68 | rp_hd_csp (dc_headers (wd_document (windows gb.[init_idx]))) -> 69 | LSQuery gb evs st. 70 | 71 | 72 | Theorem LSQuery_invalidate_LSInvariant : 73 | forall gb evs st, 74 | LSQuery gb evs st -> LSInvariant gb evs st -> False. 75 | Proof. 76 | intros gb evs st LSQuery LocScInvariant. 77 | 78 | unfold LSInvariant in LocScInvariant; destruct LSQuery. 79 | specialize (LocScInvariant evs pt _evs frm fhtml fwd ctx lv pt_idx init_idx H H2 H3 H4 H5 H6). 80 | congruence. 81 | Qed. 82 | 83 | 84 | InlineRelation is_frame_at_page_index. 85 | InlineRelation is_secure_context With Depth 1. 86 | InlineRelation is_not_secure_context With Depth 1. 87 | InlineRelation window_ctx_of_dom_path_rec With Depth 1. 88 | InlineRelation window_ctx_of_dom_path With Depth 1. 89 | InlineRelation is_script_in_dom_path With Depth 1. 90 | InlineRelation is_form_in_dom_path With Depth 1. 91 | InlineRelation update_window_on_response With Depth 1. 92 | InlineRelation update_window_html_from_ctx With Depth 1. 93 | InlineRelation update_window_domain_from_ctx With Depth 1. 94 | InlineRelation update_html_req_initiator With Depth 1. 95 | InlineRelation is_valid_setcookie_from_ctx With Depth 1. 96 | InlineRelation in_redirect_history With Depth 2. 97 | InlineRelation Scriptstate With Depth 5. 98 | 99 | 100 | Set Array Size 7. 101 | Extract Query LSQuery Using Lemma iframe_sameorigin_script_state_is_reachable. 102 | -------------------------------------------------------------------------------- /model/LemmaCSPQuery.v: -------------------------------------------------------------------------------- 1 | Load LoadPath. 2 | From Extractor Require Import Loader. 3 | From Extractor Require Import Array. 4 | 5 | Require Import Browser. 6 | Require Import BrowserStates. 7 | 8 | 9 | Require Import Coq.Lists.List. 10 | Import List.ListNotations. 11 | 12 | (* extracted_lemma_cspquery *) 13 | Inductive LemmaQuery (gb: Global) (evs: list Event) (st: State) : Prop := 14 | | Query_state : 15 | cspquery_state_6_constraints gb -> 16 | evs = cspquery_state_6_events -> 17 | st = cspquery_state_6 -> 18 | Reachable gb evs st -> 19 | LemmaQuery gb evs st. 20 | 21 | InlineRelation is_secure_context With Depth 1. 22 | InlineRelation is_not_secure_context With Depth 1. 23 | InlineRelation is_emitter_window_context With Depth 1. 24 | InlineRelation window_ctx_of_dom_path_rec With Depth 1. 25 | InlineRelation window_ctx_of_dom_path With Depth 1. 26 | InlineRelation is_script_in_dom_path With Depth 1. 27 | InlineRelation is_form_in_dom_path With Depth 1. 28 | InlineRelation update_window_on_response With Depth 1. 29 | InlineRelation update_window_html_from_ctx With Depth 1. 30 | InlineRelation update_window_domain_from_ctx With Depth 1. 31 | InlineRelation update_html_req_initiator With Depth 1. 32 | InlineRelation is_valid_setcookie_from_ctx With Depth 1. 33 | InlineRelation in_redirect_history With Depth 2. 34 | InlineRelation Scriptstate With Depth 5. 35 | 36 | Set Array Size 5. 37 | Extract Query LemmaQuery. 38 | 39 | 40 | -------------------------------------------------------------------------------- /model/LemmaIframeSamesiteScriptState.v: -------------------------------------------------------------------------------- 1 | Load LoadPath. 2 | From Extractor Require Import Loader. 3 | From Extractor Require Import Array. 4 | 5 | Require Import Browser. 6 | Require Import BrowserStates. 7 | 8 | (* iframe_samesite_script_state_is_reachable *) 9 | Inductive LemmaQuery (gb: Global) (evs: list Event) (st: State) : Prop := 10 | | Query_state : 11 | distinct (requests gb) -> 12 | distinct (responses gb) -> 13 | distinct (Array.map fst (origin_csp gb)) -> 14 | (origin_csp gb.[0]) = (TupleOrigin ProtocolHTTP (Some (domain 0)) (Some 0), None) -> 15 | c_origin_wide_csp (config gb) = false -> 16 | iframe_samesite_script_6_constraints gb -> 17 | iframe_samesite_script_constraints gb -> 18 | evs = iframe_samesite_script_events -> 19 | st = iframe_samesite_script_state -> 20 | Reachable gb evs st -> 21 | LemmaQuery gb evs st. 22 | 23 | InlineRelation is_secure_context With Depth 1. 24 | InlineRelation is_not_secure_context With Depth 1. 25 | InlineRelation window_ctx_of_dom_path_rec With Depth 1. 26 | InlineRelation window_ctx_of_dom_path With Depth 1. 27 | InlineRelation is_script_in_dom_path With Depth 1. 28 | InlineRelation is_form_in_dom_path With Depth 1. 29 | InlineRelation update_window_on_response With Depth 1. 30 | InlineRelation update_window_html_from_ctx With Depth 1. 31 | InlineRelation update_window_domain_from_ctx With Depth 1. 32 | InlineRelation update_html_req_initiator With Depth 1. 33 | InlineRelation is_valid_setcookie_from_ctx With Depth 1. 34 | InlineRelation in_redirect_history With Depth 2. 35 | InlineRelation Scriptstate With Depth 5. 36 | 37 | Set Array Size 7. 38 | Extract Query LemmaQuery. 39 | 40 | 41 | -------------------------------------------------------------------------------- /model/LemmaScriptState.v: -------------------------------------------------------------------------------- 1 | Load LoadPath. 2 | From Extractor Require Import Loader. 3 | From Extractor Require Import Array. 4 | 5 | Require Import Browser. 6 | Require Import BrowserStates. 7 | 8 | (* script_state_is_reachable *) 9 | Inductive LemmaQuery (gb: Global) (evs: list Event) (st: State) : Prop := 10 | | Query_state : 11 | distinct (requests gb) -> 12 | distinct (responses gb) -> 13 | distinct (map fst (origin_csp gb)) -> 14 | origin_csp gb.[0] = (TupleOrigin ProtocolHTTP (Some (domain 0)) (Some 0), None) -> 15 | script_state_constraints gb -> 16 | evs = (script_state_events gb) -> 17 | st = script_state -> 18 | Reachable gb evs st -> 19 | LemmaQuery gb evs st. 20 | 21 | InlineRelation is_secure_context With Depth 0. 22 | InlineRelation is_not_secure_context With Depth 0. 23 | InlineRelation window_ctx_of_dom_path_rec With Depth 0. 24 | InlineRelation window_ctx_of_dom_path With Depth 0. 25 | InlineRelation is_script_in_dom_path With Depth 0. 26 | InlineRelation is_form_in_dom_path With Depth 0. 27 | InlineRelation update_window_on_response With Depth 0. 28 | InlineRelation update_window_html_from_ctx With Depth 0. 29 | InlineRelation update_window_domain_from_ctx With Depth 0. 30 | InlineRelation update_html_req_initiator With Depth 0. 31 | InlineRelation is_valid_setcookie_from_ctx With Depth 0. 32 | InlineRelation in_redirect_history With Depth 2. 33 | InlineRelation Scriptstate With Depth 5. 34 | 35 | Set Array Size 5. 36 | Extract Query LemmaQuery. 37 | 38 | 39 | -------------------------------------------------------------------------------- /model/LoadPath.v: -------------------------------------------------------------------------------- 1 | (********************************************************************************) 2 | (* Copyright (c) 2021 Lorenzo Veronese & Benjamin Farinier *) 3 | (* *) 4 | (* Permission is hereby granted, free of charge, to any person obtaining a *) 5 | (* copy of this software and associated documentation files (the "Software"), *) 6 | (* to deal in the Software without restriction, including without limitation *) 7 | (* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) 8 | (* and/or sell copies of the Software, and to permit persons to whom the *) 9 | (* Software is furnished to do so, subject to the following conditions: *) 10 | (* *) 11 | (* The above copyright notice and this permission notice shall be included in *) 12 | (* all copies or substantial portions of the Software. *) 13 | (* *) 14 | (* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR *) 15 | (* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) 16 | (* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) 17 | (* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER *) 18 | (* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) 19 | (* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) 20 | (* DEALINGS IN THE SOFTWARE. *) 21 | (* *) 22 | (********************************************************************************) 23 | 24 | (* Until there is no support for dune in PG/CoqIDE, we will use this hack. *) 25 | (* https://github.com/ProofGeneral/PG/issues/477 *) 26 | 27 | Add LoadPath "../compiler/_build/default/src" as Extractor. 28 | Add LoadPath "../compiler/_build/default/theories" as Extractor. 29 | -------------------------------------------------------------------------------- /model/OCamlExtract.v: -------------------------------------------------------------------------------- 1 | Load LoadPath. 2 | From Extractor Require Import Loader. 3 | From Extractor Require Import Array. 4 | 5 | Require Import Browser. 6 | 7 | Require Extraction. 8 | Extraction Language OCaml. 9 | Extract Inductive list => "list" [ "[]" "(::)" ]. 10 | Extract Inductive prod => "(*)" [ "(,)" ]. 11 | Extract Inductive unit => "unit" [ "()" ]. 12 | Extract Inductive bool => "bool" [ "true" "false" ]. 13 | Extract Inductive option => "option" [ "Some" "None" ]. 14 | Extract Inductive nat => int [ "0" "succ" ] "(fun fO fS n -> if n=0 then fO () else fS (n-1))". 15 | Extract Constant plus => "( + )". 16 | Extract Constant Nat.eqb => "( = )". 17 | 18 | Extract Constant Array.array "'a" => "(int * 'a) list [@@deriving yojson, show, eq, ord]". 19 | Extract Constant Array.const => "(fun x -> [(-1, x)])". 20 | Extract Constant Array.store => "(fun a i x -> (i,x) :: a)". 21 | Extract Constant Array.select => "(fun a i -> Option.value (List.assoc_opt i a) ~default:(List.assoc (-1) a))". 22 | Extract Constant Array.map => "(fun f a -> List.map (fun (i, x) -> (i, f x)) a)". 23 | 24 | Cd "../verifier/model/". 25 | Separate Extraction Array State Global Event. 26 | -------------------------------------------------------------------------------- /model/OriginInvariant.v: -------------------------------------------------------------------------------- 1 | (********************************************************************************) 2 | (* Copyright (c) 2021 Lorenzo Veronese & Benjamin Farinier *) 3 | (* *) 4 | (* Permission is hereby granted, free of charge, to any person obtaining a *) 5 | (* copy of this software and associated documentation files (the "Software"), *) 6 | (* to deal in the Software without restriction, including without limitation *) 7 | (* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) 8 | (* and/or sell copies of the Software, and to permit persons to whom the *) 9 | (* Software is furnished to do so, subject to the following conditions: *) 10 | (* *) 11 | (* The above copyright notice and this permission notice shall be included in *) 12 | (* all copies or substantial portions of the Software. *) 13 | (* *) 14 | (* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR *) 15 | (* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) 16 | (* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) 17 | (* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER *) 18 | (* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) 19 | (* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) 20 | (* DEALINGS IN THE SOFTWARE. *) 21 | (* *) 22 | (********************************************************************************) 23 | 24 | Load LoadPath. 25 | From Extractor Require Import Loader. 26 | From Extractor Require Import Array. 27 | From Extractor Require Import Equality. 28 | 29 | Require Import Browser. 30 | 31 | Require Import Coq.Lists.List. 32 | 33 | 34 | Definition OriginInvariant (gb: Global) (evs: list Event) (st: State) : Prop := 35 | forall em rq corr _evs orghd orgsrc, 36 | Reachable gb evs st -> 37 | (* Request with origin header orgd *) 38 | evs = (EvRequest em rq corr :: _evs) -> 39 | rq_hd_origin (rq_headers rq) = Some orghd -> 40 | (* The source origin is equal to orghd *) 41 | is_request_source gb st rq (Some orgsrc) -> 42 | orgsrc = orghd. 43 | 44 | 45 | (* Fix the issue by setting the origin header to null on cross origin redirects 46 | c_origin_header_on_cross_origin_redirect (config gb) = false -> 47 | *) 48 | Inductive OriginQuery (gb: Global) (evs: list Event) (st: State) : Prop := 49 | | Query_state : forall em rq corr _evs orghd orgsrc, 50 | Reachable gb evs st -> 51 | (* POST request to origin o with origin header o *) 52 | evs = (EvRequest em rq corr :: _evs) -> 53 | rq_method rq = MethodPost /\ em <> EmitterWorker -> 54 | rq_hd_origin (rq_headers rq) = Some orghd -> 55 | origin_of_url (rq_url rq) = Some orghd -> 56 | (* The source origin is different to the header *) 57 | is_request_source gb st rq (Some orgsrc) -> 58 | orgsrc <> orghd -> 59 | OriginQuery gb evs st. 60 | 61 | 62 | Theorem OriginQuery_invalidate_OriginInvariant : 63 | forall gb evs st (x:OriginQuery gb evs st), 64 | OriginInvariant gb evs st -> False. 65 | Proof. 66 | intros. 67 | unfold OriginInvariant in H. 68 | destruct x. 69 | specialize (H em rq corr _evs orghd orgsrc H0 H1 H3 H5). 70 | congruence. 71 | Qed. 72 | 73 | 74 | InlineRelation is_secure_context With Depth 0. 75 | InlineRelation is_not_secure_context With Depth 0. 76 | InlineRelation window_ctx_of_dom_path_rec With Depth 0. 77 | InlineRelation window_ctx_of_dom_path With Depth 0. 78 | InlineRelation is_script_in_dom_path With Depth 0. 79 | InlineRelation is_form_in_dom_path With Depth 0. 80 | InlineRelation update_window_on_response With Depth 0. 81 | InlineRelation update_window_html_from_ctx With Depth 0. 82 | InlineRelation update_window_domain_from_ctx With Depth 0. 83 | InlineRelation update_html_req_initiator With Depth 0. 84 | InlineRelation is_valid_setcookie_from_ctx With Depth 0. 85 | InlineRelation in_redirect_history With Depth 2. 86 | InlineRelation is_request_source With Depth 0. 87 | InlineRelation Scriptstate With Depth 5. 88 | 89 | Set Array Size 5. 90 | Extract Query OriginQuery. 91 | -------------------------------------------------------------------------------- /model/SOPInvariant.v: -------------------------------------------------------------------------------- 1 | (********************************************************************************) 2 | (* Copyright (c) 2021 Lorenzo Veronese & Benjamin Farinier *) 3 | (* *) 4 | (* Permission is hereby granted, free of charge, to any person obtaining a *) 5 | (* copy of this software and associated documentation files (the "Software"), *) 6 | (* to deal in the Software without restriction, including without limitation *) 7 | (* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) 8 | (* and/or sell copies of the Software, and to permit persons to whom the *) 9 | (* Software is furnished to do so, subject to the following conditions: *) 10 | (* *) 11 | (* The above copyright notice and this permission notice shall be included in *) 12 | (* all copies or substantial portions of the Software. *) 13 | (* *) 14 | (* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR *) 15 | (* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) 16 | (* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) 17 | (* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER *) 18 | (* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) 19 | (* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) 20 | (* DEALINGS IN THE SOFTWARE. *) 21 | (* *) 22 | (********************************************************************************) 23 | 24 | Load LoadPath. 25 | From Extractor Require Import Loader. 26 | From Extractor Require Import Array. 27 | 28 | Require Import Browser. 29 | 30 | Require Import Coq.Lists.List. 31 | 32 | Definition IsEvRequestCORSPreflight rq ev := 33 | match ev with 34 | | EvRequest (EmitterCORSPreflight _ org_rq) _ _ => org_rq = rq 35 | | _ => False 36 | end. 37 | 38 | Definition SOPInvariant (gb: Global) (evs: list Event) (st: State) : Prop := 39 | forall rq corr em rest, 40 | Reachable gb evs st -> 41 | evs = (EvRequest em rq corr :: rest) -> 42 | (* The request is a non-simple request *) 43 | not (is_cors_simple_request rq) -> 44 | (* The request is cross origin *) 45 | is_cross_origin_request (st_window st) rq -> 46 | (* There needs to be a preflight request *) 47 | Exists (IsEvRequestCORSPreflight rq) rest. 48 | 49 | 50 | (* List.forall (fun x => not (IsEvRequestCORSPreflight rq x)) *) 51 | Inductive all_list (rq: Request) : list Event -> Prop := 52 | | AllList_empty : forall llst, 53 | llst = nil -> 54 | all_list rq llst 55 | | AllList_rec : forall llst x rest, 56 | llst = cons x rest -> 57 | (match x with 58 | | EvRequest (EmitterCORSPreflight _ org_rq) _ _ => org_rq <> rq 59 | | _ => True 60 | end) /\ all_list rq rest -> 61 | all_list rq llst. 62 | 63 | Lemma all_list_forall_preflight : 64 | forall rq _evs, List.Forall (fun x => not (IsEvRequestCORSPreflight rq x)) _evs 65 | <-> all_list rq _evs. 66 | Proof with unfold not; compute; try tauto. 67 | intros. 68 | induction _evs. 69 | - split; intros. 70 | induction H. 71 | * constructor. reflexivity. 72 | * apply AllList_rec with (x:=x) (rest:=l). reflexivity. 73 | unfold IsEvRequestCORSPreflight in H. 74 | split. induction x... induction evrq_em... apply IHForall. 75 | * constructor. 76 | - split; intros. 77 | induction H. constructor. reflexivity. 78 | apply AllList_rec with (x:= x) (rest:= l). reflexivity. 79 | unfold IsEvRequestCORSPreflight in H. 80 | split. induction x... induction evrq_em... apply IHForall. 81 | constructor 2. 82 | remember (a :: _evs) as evs. 83 | destruct H. congruence. destruct H0. 84 | assert (x = a) by congruence. subst. 85 | unfold IsEvRequestCORSPreflight. induction a... induction evrq_em... 86 | destruct IH_evs. remember (a :: _evs) as evs. 87 | destruct H. congruence. assert (rest = _evs) by congruence. subst. destruct H2. 88 | apply (H1 H3). 89 | Qed. 90 | 91 | 92 | 93 | (* Fix the issue by disabling early-html5 form methods with: 94 | c_earlyhtml5_form_methods (config gb) = false -> 95 | *) 96 | Inductive SOPQuery (gb: Global) (evs: list Event) (st: State) : Prop := 97 | | Query_state : forall rq corr em _evs, 98 | Reachable gb evs st -> 99 | evs = (EvRequest em rq corr :: _evs) -> 100 | not (is_cors_simple_request rq) -> 101 | (* The request is cross origin *) 102 | is_cross_origin_request (st_window st) rq -> 103 | (* There is no preceding preflight request *) 104 | all_list rq _evs -> 105 | match em with | EmitterForm _ _ => True | _ => False end -> 106 | SOPQuery gb evs st. 107 | 108 | 109 | Theorem SOPQuery_invalidate_SOPInvariant : 110 | forall gb evs st (x:SOPQuery gb evs st), 111 | SOPInvariant gb evs st -> False. 112 | Proof. 113 | intros. 114 | destruct x. 115 | unfold SOPInvariant in H. 116 | specialize (H rq corr em _evs H0 H1 H2 H3). 117 | apply all_list_forall_preflight in H4. 118 | apply Forall_Exists_neg in H4. congruence. 119 | Qed. 120 | 121 | 122 | InlineRelation all_list With Depth 6. 123 | InlineRelation is_secure_context With Depth 0. 124 | InlineRelation is_not_secure_context With Depth 0. 125 | InlineRelation window_ctx_of_dom_path_rec With Depth 0. 126 | InlineRelation window_ctx_of_dom_path With Depth 0. 127 | InlineRelation is_script_in_dom_path With Depth 0. 128 | InlineRelation is_form_in_dom_path With Depth 0. 129 | InlineRelation update_window_on_response With Depth 0. 130 | InlineRelation update_window_html_from_ctx With Depth 0. 131 | InlineRelation update_window_domain_from_ctx With Depth 0. 132 | InlineRelation update_html_req_initiator With Depth 0. 133 | InlineRelation is_valid_setcookie_from_ctx With Depth 0. 134 | InlineRelation in_redirect_history With Depth 2. 135 | InlineRelation Scriptstate With Depth 5. 136 | 137 | Set Array Size 5. 138 | Extract Query SOPQuery. 139 | -------------------------------------------------------------------------------- /model/SecureCookiesInvariant.v: -------------------------------------------------------------------------------- 1 | (********************************************************************************) 2 | (* Copyright (c) 2021 Lorenzo Veronese & Benjamin Farinier *) 3 | (* *) 4 | (* Permission is hereby granted, free of charge, to any person obtaining a *) 5 | (* copy of this software and associated documentation files (the "Software"), *) 6 | (* to deal in the Software without restriction, including without limitation *) 7 | (* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) 8 | (* and/or sell copies of the Software, and to permit persons to whom the *) 9 | (* Software is furnished to do so, subject to the following conditions: *) 10 | (* *) 11 | (* The above copyright notice and this permission notice shall be included in *) 12 | (* all copies or substantial portions of the Software. *) 13 | (* *) 14 | (* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR *) 15 | (* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) 16 | (* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) 17 | (* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER *) 18 | (* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) 19 | (* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) 20 | (* DEALINGS IN THE SOFTWARE. *) 21 | (* *) 22 | (********************************************************************************) 23 | 24 | Load LoadPath. 25 | From Extractor Require Import Loader. 26 | From Extractor Require Import Array. 27 | From Extractor Require Import Equality. 28 | 29 | Require Import Browser. 30 | 31 | Require Import Coq.Lists.List. 32 | Import List.ListNotations. 33 | 34 | 35 | Definition SecureCookiesInvariant (gb: Global) (evs: list Event) (st: State) : Prop := 36 | forall rp corr _evs cookie, 37 | Reachable gb evs st -> 38 | evs = (EvResponse rp corr :: _evs) -> 39 | rp_hd_set_cookie (rp_headers rp) = Some cookie -> 40 | sc_secure cookie = true -> 41 | url_protocol (rp_url rp) = ProtocolHTTPS. 42 | 43 | Definition SecureCookiesInvariantSC (gb: Global) (evs: list Event) (st: State) : Prop := 44 | forall pt target target_ctx c_idx cookie _evs, 45 | Reachable gb evs st -> 46 | evs = (EvScriptSetCookie pt target c_idx cookie :: _evs) -> 47 | sc_secure cookie = true -> 48 | window_ctx_of_dom_path gb (st_window st) target target_ctx -> 49 | url_protocol (wd_location target_ctx) = ProtocolHTTPS. 50 | 51 | 52 | Theorem secure_cookies_invariant_response : 53 | forall gb evs st, SecureCookiesInvariant gb evs st. 54 | Proof. 55 | unfold SecureCookiesInvariant. 56 | intros. 57 | induction H; try congruence. 58 | assert (rp = (responses gb.[rp_idx])). congruence. 59 | subst. 60 | rewrite H1 in H9. 61 | unfold is_valid_setcookie in H9. 62 | unfold check_secure_protocol in H9. 63 | unfold checkb_secure_protocol in H9. 64 | unfold implb in H9. 65 | rewrite H2 in *. 66 | destruct (sc_name cookie). 67 | - destruct H9, H3, H9. 68 | apply -> Equality.eqb_eq in H9. apply H9. 69 | - destruct H9, H3, H9, H10. 70 | apply -> Equality.eqb_eq in H10. apply H10. 71 | - destruct H9, H3, H9, H10. 72 | apply -> Equality.eqb_eq in H10. apply H10. 73 | Qed. 74 | 75 | 76 | Inductive SecureCookiesQuery (gb: Global) (evs: list Event) (st: State) : Prop := 77 | | Query_state : forall rp corr _evs cookie, 78 | Reachable gb evs st -> 79 | evs = (EvResponse rp corr :: _evs) -> 80 | rp_hd_set_cookie (rp_headers rp) = Some cookie -> 81 | sc_secure cookie = true -> 82 | url_protocol (rp_url rp) <> ProtocolHTTPS -> 83 | SecureCookiesQuery gb evs st. 84 | 85 | Inductive SecureCookiesQuerySC (gb: Global) (evs: list Event) (st: State) : Prop := 86 | | Query_state_sc : forall pt target target_ctx c_idx cookie _evs, 87 | Reachable gb evs st -> 88 | evs = (EvScriptSetCookie pt target c_idx cookie :: _evs) -> 89 | sc_secure cookie = true -> 90 | window_ctx_of_dom_path gb (st_window st) target target_ctx -> 91 | url_protocol (wd_location target_ctx) <> ProtocolHTTPS -> 92 | SecureCookiesQuerySC gb evs st. 93 | 94 | 95 | InlineRelation is_secure_context With Depth 2. 96 | InlineRelation is_not_secure_context With Depth 2. 97 | InlineRelation window_ctx_of_dom_path_rec With Depth 2. 98 | InlineRelation window_ctx_of_dom_path With Depth 2. 99 | InlineRelation is_script_in_dom_path With Depth 2. 100 | InlineRelation is_form_in_dom_path With Depth 2. 101 | InlineRelation update_window_on_response With Depth 2. 102 | InlineRelation update_window_html_from_ctx With Depth 2. 103 | InlineRelation update_window_domain_from_ctx With Depth 2. 104 | InlineRelation update_html_req_initiator With Depth 2. 105 | InlineRelation is_valid_setcookie_from_ctx With Depth 2. 106 | InlineRelation in_redirect_history With Depth 2. 107 | InlineRelation Scriptstate With Depth 5. 108 | Extract Query SecureCookiesQuery. 109 | -------------------------------------------------------------------------------- /nix/coq-procrastination.nix: -------------------------------------------------------------------------------- 1 | { stdenv, fetchFromGitHub, coq }: 2 | 3 | stdenv.mkDerivation { 4 | name = "coq-procrastination"; 5 | version = "199dab4435148e4bdfdf934836c644c2c4e44073"; 6 | src = fetchFromGitHub { 7 | owner = "Armael"; 8 | repo = "coq-procrastination"; 9 | rev = "199dab4435148e4bdfdf934836c644c2c4e44073"; 10 | sha256 = "0mnm0knzgn0mvq875pfghg3fhwvkr3fpkgwd6brb7hadfxh2xjay"; 11 | fetchSubmodules = true; 12 | }; 13 | 14 | buildInputs = [ coq ]; 15 | installFlags = "COQLIB=$(out)/lib/coq/${coq.coq-version}/"; 16 | 17 | meta = { 18 | description = "A small Coq library for collecting side conditions and deferring their proof."; 19 | homepage = "https://github.com/Armael/coq-procrastination"; 20 | }; 21 | } 22 | -------------------------------------------------------------------------------- /nix/z3-patched.nix: -------------------------------------------------------------------------------- 1 | { stdenv, z3 }: 2 | 3 | z3.overrideAttrs (oldAttrs: rec { 4 | patches = [ ./z3_bmc_initial_unrolling_level.patch ]; 5 | }) 6 | -------------------------------------------------------------------------------- /nix/z3_bmc_initial_unrolling_level.patch: -------------------------------------------------------------------------------- 1 | diff --git a/src/muz/base/fp_params.pyg b/src/muz/base/fp_params.pyg 2 | index 098922b1b..58abaad0e 100644 3 | --- a/src/muz/base/fp_params.pyg 4 | +++ b/src/muz/base/fp_params.pyg 5 | @@ -138,6 +138,7 @@ def_module_params('fp', 6 | ('spacer.blast_term_ite_inflation', UINT, 3, 'Maximum inflation for non-Boolean ite-terms expansion: 0 (none), k (multiplicative)'), 7 | ('spacer.reach_dnf', BOOL, True, "Restrict reachability facts to DNF"), 8 | ('bmc.linear_unrolling_depth', UINT, UINT_MAX, "Maximal level to explore"), 9 | + ('bmc.initial_unrolling_level', UINT, 0, "Initial level for the BMC exploration"), 10 | ('spacer.iuc.split_farkas_literals', BOOL, False, "Split Farkas literals"), 11 | ('spacer.native_mbp', BOOL, True, "Use native mbp of Z3"), 12 | ('spacer.eq_prop', BOOL, True, "Enable equality and bound propagation in arithmetic"), 13 | diff --git a/src/muz/bmc/dl_bmc_engine.cpp b/src/muz/bmc/dl_bmc_engine.cpp 14 | index a0233cc7b..db7dad056 100644 15 | --- a/src/muz/bmc/dl_bmc_engine.cpp 16 | +++ b/src/muz/bmc/dl_bmc_engine.cpp 17 | @@ -1164,11 +1164,17 @@ namespace datalog { 18 | 19 | lbool check() { 20 | setup(); 21 | + unsigned initial_level = b.m_ctx.get_params().bmc_initial_unrolling_level(); 22 | unsigned max_depth = b.m_ctx.get_params().bmc_linear_unrolling_depth(); 23 | for (unsigned i = 0; i < max_depth; ++i) { 24 | IF_VERBOSE(1, verbose_stream() << "level: " << i << "\n";); 25 | b.checkpoint(); 26 | compile(i); 27 | + if (i (name, expand_sexp env valu) 16 | | _ -> failwith "invalid let binding") new_binds) 17 | env 18 | and expand_sexp env sexp : Sexp.t = match sexp with 19 | | Sexp.Atom name -> Option.value 20 | (Option.map snd (List.find_opt (fun (vname, _) -> name = vname) env)) 21 | ~default:(Sexp.Atom name) 22 | | Sexp.List xs -> Sexp.List (List.map (fun x -> expand_sexp env x) xs) 23 | in 24 | (* Get the query!0 in the last hyper-ref clause and save hypotheses 25 | (NOTE: the query!0 depends on the format of the query) *) 26 | let rec go (env : environment) hyp form = 27 | let open Sexp in 28 | match form with 29 | | List [Atom "let"; List binds; body] -> go (cons_env env binds) hyp body 30 | | List [Atom "hyper-res"; fst; snd; body] -> go env (hyp @ get_hyp env fst @ get_hyp env snd) (expand_sexp env body) 31 | | List [Atom query; final_state; lst; global] when String.sub query 0 6 = "query!" -> Some (expand_sexp env final_state, expand_sexp env global, hyp, lst) 32 | | _ -> None 33 | and get_hyp env sexp = 34 | let open Sexp in 35 | match sexp with 36 | | Atom name -> get_hyp env (expand_sexp env sexp) 37 | | List (Atom "asserted" :: _) -> [] (* ignore asserted *) 38 | | List [Atom "hyper-res"; fst; snd; body] -> get_hyp env fst @ get_hyp env snd @ get_hyp env body 39 | | List [Atom "=>"; hyp'; body] -> [expand_sexp env hyp'] @ get_hyp env body 40 | | x -> [] 41 | in go [] [] form 42 | 43 | 44 | let _ = 45 | let answer = Sexp.load_sexp Sys.argv.(1) in 46 | let [@warning "-8"] Some (final_state, global, hyps, lst) = find_final_state answer in 47 | let states = 48 | List.filter_map (function | (Sexp.List [Sexp.Atom name; _; _; state]) 49 | when name = "Reachable" || name = "reachable" -> Some state 50 | | _ -> None) hyps in 51 | let [@warning "-8"] sorted_states = 52 | List.sort (fun (Sexp.List (Sexp.Atom "Build_State" :: Sexp.Atom n :: _)) 53 | (Sexp.List (Sexp.Atom "Build_State" :: Sexp.Atom n' :: _)) -> 54 | compare (int_of_string n) (int_of_string n')) states 55 | in 56 | printf "%s\n\n%s\n\n%s\n\n%s\n\n" 57 | (String.concat "\n\n" (List.map Sexp.to_string_hum sorted_states)) 58 | (Sexp.to_string_hum final_state) 59 | (Sexp.to_string_hum lst) 60 | (Sexp.to_string_hum global); 61 | 62 | let stlist = sorted_states @ [final_state] in 63 | let rec cons_to_list = function 64 | | Sexp.Atom n when String.sub n 0 3 = "nil" -> [] 65 | | Sexp.List [Sexp.Atom n; elm; rest] when String.sub n 0 4 = "cons" -> elm :: (cons_to_list rest) 66 | | _ -> failwith "invalid cons" 67 | in 68 | let rec take n lst = match (n, lst) with 69 | | n, _ when n<= 0 -> [] 70 | | _, [] -> [] 71 | | _, (x :: xs) -> (x :: take (n-1) xs) 72 | in 73 | let evlist = take (List.length stlist) ((cons_to_list lst) @ [Sexp.Atom "EvInit"]) |> List.rev in 74 | let vizstates = List.map2 (fun st ev -> 75 | match st with 76 | | Sexp.List (Sexp.Atom "Build_State" :: version :: rest ) -> 77 | Sexp.List (Sexp.Atom "Build_State" :: version :: ev :: rest ) 78 | | _ -> st 79 | ) stlist evlist in 80 | fprintf stderr "\n\n%s" (Viz.viz vizstates) 81 | -------------------------------------------------------------------------------- /scripts/run.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | set -e 3 | 4 | MODEL="$1" 5 | 6 | TMPDIR="$(mktemp -d -p /tmp)" 7 | 8 | echo -e "\e[1m⚙ Compiling . . .\e[0m" 9 | if [[ ! -d compiler/_build || ! -f model/Browser.vo ]]; then 10 | make 11 | make coq 12 | fi 13 | make -s "$MODEL" > "$TMPDIR/z3" 14 | 15 | echo -e "\e[1m💻 Running z3 . . .\e[0m" 16 | time \ 17 | z3 'fp.engine=bmc' 'fp.print-answer=true' "$TMPDIR/z3" -v:1 \ 18 | 1> "$TMPDIR/stdout" 2> "$TMPDIR/stderr" \ 19 | & tail -f "$TMPDIR/stderr" --pid "$!" \ 20 | | sed 's/\(.*level.*\)/\x1b[7;35;1m\1\x1b[0m/' 21 | 22 | echo -e "\e[1m🆗 Output:\e[0m $TMPDIR/$MODEL.trace.z3" 23 | 24 | echo -e "\e[1m🔎 Trace:\e[0m ↳" 25 | sed -i 's/sat//' "$TMPDIR/stdout" 26 | cp "$TMPDIR/stdout" "$TMPDIR/$MODEL.trace.z3" 27 | 28 | { utop scripts/display_trace.ml "$TMPDIR/stdout" 2>&3 \ 29 | | sed 's/\([0-9]\+\)/\x1b[32;1m\1\x1b[0m/g' \ 30 | | sed 's/Build_\([^ ]*\)/\x1b[2mBuild_\x1b[1m\1\x1b[0m/g' \ 31 | | sed 's/\(None[^ ]*\|Some[^ ]*\)/\x1b[2m\1\x1b[0m/g' \ 32 | | sed 's/\(Ev[^ ]*\)/\x1b[35;1m\1\x1b[0m/g' \ 33 | | sed 's/\(Emitter[^ ]*\)/\x1b[36;1m\1\x1b[0m/g' 34 | } 3>&1 1>&2 | plantuml -pipe -tutxt 35 | 36 | 37 | -------------------------------------------------------------------------------- /shell.nix: -------------------------------------------------------------------------------- 1 | let nixpkgs = fetchTarball { 2 | url = "https://github.com/nixos/nixpkgs/archive/29a15e2c1f5ad64c235d78ba5e29a56fe520ad45.tar.gz"; 3 | }; 4 | pkgs = import (nixpkgs) {}; 5 | customOCamlPackages = pkgs.ocaml-ng.ocamlPackages_4_11; 6 | customCoq = pkgs.callPackage (nixpkgs + "/pkgs/applications/science/logic/coq") { 7 | version = "8.13"; 8 | ocamlPackages_4_05 = null; ocamlPackages_4_09 = null; ocamlPackages_4_10 = null; 9 | inherit customOCamlPackages; 10 | }; 11 | coq_procrastination = with pkgs; callPackage ./nix/coq-procrastination.nix { coq = customCoq; }; 12 | patched_z3 = with pkgs; callPackage ./nix/z3-patched.nix {}; 13 | mkCoqDerivation = with pkgs; callPackage (nixpkgs + "/pkgs/build-support/coq") { coq = customCoq; }; 14 | coqhammer = (with pkgs; callPackage (nixpkgs + "/pkgs/development/coq-modules/coqhammer") { 15 | coq = customCoq; 16 | version = "v1.3.1-coq8.13"; 17 | inherit mkCoqDerivation; 18 | }).overrideAttrs (super: { 19 | src = fetchTarball { 20 | url = "https://github.com/lukaszcz/coqhammer/archive/refs/tags/v1.3.1-coq8.13.tar.gz"; 21 | }; 22 | }); 23 | customCoqPackages = pkgs.mkCoqPackages customCoq; 24 | coq-ext-lib = pkgs.stdenv.mkDerivation { 25 | name = "coq-ext-lib"; 26 | version = "0.11.6"; 27 | src = fetchTarball { 28 | url = "https://github.com/coq-community/coq-ext-lib/archive/refs/tags/v0.11.6.tar.gz"; 29 | }; 30 | buildInputs = [ customCoq ]; 31 | installFlags = "COQLIB=$(out)/lib/coq/${customCoq.coq-version}/"; 32 | 33 | meta = { 34 | description = "A collection of theories and plugins that may be useful in other Coq developments."; 35 | homepage = "https://github.com/coq-community/coq-ext-lib"; 36 | }; 37 | }; 38 | simple-io = pkgs.stdenv.mkDerivation { 39 | name = "coq-simple-io"; 40 | version = "1.3.0"; 41 | src = fetchTarball { 42 | url = "https://github.com/Lysxia/coq-simple-io/archive/refs/tags/1.3.0.tar.gz"; 43 | }; 44 | buildInputs = [ customCoq coq-ext-lib ] ++ (with customCoq.ocamlPackages; [ zarith ocaml ocamlbuild cppo findlib ]); 45 | installFlags = "COQLIB=$(out)/lib/coq/${customCoq.coq-version}/"; 46 | 47 | meta = { 48 | description = "Purely functional IO for Coq"; 49 | homepage = "https://github.com/Lysxia/coq-simple-io"; 50 | }; 51 | 52 | }; 53 | quickchick = pkgs.stdenv.mkDerivation rec { 54 | name = "quickchick"; 55 | version = "1.5.0"; 56 | src = fetchTarball { 57 | url = "https://github.com/QuickChick/QuickChick/archive/refs/tags/v1.5.0.tar.gz"; 58 | }; 59 | buildInputs = [ pkgs.ncurses customCoq customCoqPackages.coqPackages.ssreflect coq-ext-lib simple-io ] ++ (with customCoq.ocamlPackages; [ ocaml ocamlbuild zarith num findlib ]); 60 | installFlags = "COQLIB=$(out)/lib/coq/${customCoq.coq-version}/"; 61 | enableParallelBuilding = false; 62 | preConfigure = '' 63 | substituteInPlace Makefile --replace quickChickTool.byte quickChickTool.native 64 | ''; 65 | installPhase = '' 66 | runHook preInstall 67 | echo $out 68 | make -f Makefile.coq COQPREFIX=$out/lib/coq/${customCoq.coq-version}/ COQLIB=$out/lib/coq/${customCoq.coq-version}/ install 69 | runHook postInstall 70 | ''; 71 | 72 | meta = { 73 | description = "Randomized property-based testing plugin for Coq"; 74 | homepage = "https://github.com/QuickChick/QuickChick"; 75 | }; 76 | }; 77 | in 78 | pkgs.mkShell rec { 79 | name = "model"; 80 | buildInputs = (with pkgs; [ gnumake dune_2 customCoq patched_z3 coq_procrastination coqhammer plantuml z3-tptp vampire cvc4 eprover librsvg ]) 81 | ++ (with customOCamlPackages; [ 82 | ocaml z3 findlib ocamlbuild sexplib utop merlin yojson ppx_deriving ppx_deriving_yojson ppx_import jingoo base64 uuidm]) 83 | ++ ([ quickchick customCoqPackages.coqPackages.ssreflect coq-ext-lib simple-io ]); 84 | } 85 | -------------------------------------------------------------------------------- /verifier/.gitignore: -------------------------------------------------------------------------------- 1 | output 2 | -------------------------------------------------------------------------------- /verifier/Dockerfile: -------------------------------------------------------------------------------- 1 | FROM webplatformtests/wpt:0.52 as base 2 | ENV PIP_DISABLE_PIP_VERSION_CHECK=1 3 | RUN sed -i 's/depth=50/depth=1/' start.sh 4 | RUN ./start.sh https://github.com/webspec-framework/wpt.git master 5 | WORKDIR web-platform-tests 6 | RUN ./wpt run --help >/dev/null 7 | RUN ./wpt install --channel stable chromium browser && ./wpt install --channel stable chromium webdriver 8 | RUN ./wpt install --channel stable firefox browser && ./wpt install --channel stable firefox webdriver 9 | RUN sed -i 's#cert_path = "../tools/certs/cacert.pem"#cert_path = "/home/test/web-platform-tests/tools/certs/cacert.pem"#' verifier/server.py 10 | RUN sed -i 's#cert_path = "../tools/certs/cacert.pem"#cert_path = "/home/test/web-platform-tests/tools/certs/cacert.pem"#' verifier/csp.py 11 | 12 | # TEST SPECIFIC 13 | FROM base as test 14 | RUN rm -f /home/test/web-platform-tests/verifier/responses/* 15 | COPY output/config.json /home/test/web-platform-tests/ 16 | COPY output/launcher.html output/*_sw.js /home/test/web-platform-tests/verifier/ 17 | COPY output/*.body output/*.headers output/*.ver output/*_sw.html /home/test/web-platform-tests/verifier/responses/ 18 | 19 | FROM test as chromium 20 | ENV CHROMIUM_BINARY=/home/test/web-platform-tests/_venv3/browsers/stable/chrome-linux/chrome 21 | # ENTRYPOINT 22 | CMD ./wpt make-hosts-file | grep 127.0.0.1 | sudo tee -a /etc/hosts >/dev/null; \ 23 | ./wpt regen-certs --force ; \ 24 | fnm=`find tools/certs -exec bash -c 'basename "$0" ".${0##*.}"' {} \; | sort | uniq --repeated | grep .test | grep -v web-platform` ; \ 25 | mv "tools/certs/$fnm".key tools/certs/web-platform.test.key ; mv "tools/certs/$fnm".pem tools/certs/web-platform.test.pem ; \ 26 | xvfb-run ./wpt run --yes \ 27 | --log-mach-level=warning \ 28 | --log-mach=- \ 29 | --log-wptreport=/dev/stderr \ 30 | --channel stable \ 31 | --binary $CHROMIUM_BINARY \ 32 | --binary-arg no-gpu \ 33 | --binary-arg no-sandbox \ 34 | --binary-arg allow-running-insecure-content \ 35 | --binary-arg ignore-certificate-errors \ 36 | --no-pause-after-test \ 37 | chromium \ 38 | verifier/launcher.html 39 | 40 | from test as firefox 41 | ENV FIREFOX_BINARY=/home/test/web-platform-tests/_venv3/browsers/stable/firefox/firefox 42 | # ENTRYPOINTA 43 | USER root 44 | RUN chown -R test /home/test/web-platform-tests/verifier 45 | USER test 46 | CMD ./wpt make-hosts-file | grep 127.0.0.1 | sudo tee -a /etc/hosts >/dev/null; \ 47 | ./wpt regen-certs --force; \ 48 | fnm=`find tools/certs -exec bash -c 'basename "$0" ".${0##*.}"' {} \; | sort | uniq --repeated | grep .test | grep -v web-platform` ; \ 49 | mv "tools/certs/$fnm".key tools/certs/web-platform.test.key ; mv "tools/certs/$fnm".pem tools/certs/web-platform.test.pem ; \ 50 | ./wpt run --yes \ 51 | --log-mach-level=warning \ 52 | --log-mach=- \ 53 | --log-wptreport=/dev/stderr \ 54 | --channel stable \ 55 | --binary $FIREFOX_BINARY \ 56 | --headless \ 57 | --no-pause-after-test \ 58 | firefox \ 59 | verifier/launcher.html 60 | 61 | -------------------------------------------------------------------------------- /verifier/dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 2.8) 2 | ;(wrapped_executables false) 3 | -------------------------------------------------------------------------------- /verifier/model/.gitignore: -------------------------------------------------------------------------------- 1 | *.ml 2 | *.mli 3 | -------------------------------------------------------------------------------- /verifier/model/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name Model) 3 | (libraries yojson) 4 | (preprocess (staged_pps ppx_import ppx_deriving.show ppx_deriving_yojson ppx_deriving.show ppx_deriving.eq ppx_deriving.ord))) 5 | -------------------------------------------------------------------------------- /verifier/src/cspcheck.mli: -------------------------------------------------------------------------------- 1 | (********************************************************************************) 2 | (* Copyright (c) 2022 Pedro Bernardo *) 3 | (* *) 4 | (* Permission is hereby granted, free of charge, to any person obtaining a *) 5 | (* copy of this software and associated documentation files (the "Software"), *) 6 | (* to deal in the Software without restriction, including without limitation *) 7 | (* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) 8 | (* and/or sell copies of the Software, and to permit persons to whom the *) 9 | (* Software is furnished to do so, subject to the following conditions: *) 10 | (* *) 11 | (* The above copyright notice and this permission notice shall be included in *) 12 | (* all copies or substantial portions of the Software. *) 13 | (* *) 14 | (* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR *) 15 | (* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) 16 | (* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) 17 | (* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER *) 18 | (* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) 19 | (* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) 20 | (* DEALINGS IN THE SOFTWARE. *) 21 | (* *) 22 | (********************************************************************************) 23 | 24 | module type S = 25 | sig 26 | val generate_assertions : States.VerifierState.t -> States.VerifierState.t 27 | val generate_checks : States.VerifierState.t -> States.VerifierState.t 28 | end 29 | 30 | 31 | 32 | module CSPChecker : S -------------------------------------------------------------------------------- /verifier/src/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name main) 3 | (modes (byte exe)) 4 | (libraries Model yojson jingoo base64 uuidm) 5 | (preprocess (staged_pps ppx_import ppx_deriving.show ppx_deriving_yojson ppx_deriving.show ppx_deriving.eq ppx_deriving.ord ))) 6 | (env 7 | (dev 8 | (flags (:standard -w -27 -w -32)))) 9 | -------------------------------------------------------------------------------- /verifier/src/html.ml: -------------------------------------------------------------------------------- 1 | 2 | (********************************************************************************) 3 | (* Copyright (c) 2022 Pedro Bernardo *) 4 | (* *) 5 | (* Permission is hereby granted, free of charge, to any person obtaining a *) 6 | (* copy of this software and associated documentation files (the "Software"), *) 7 | (* to deal in the Software without restriction, including without limitation *) 8 | (* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) 9 | (* and/or sell copies of the Software, and to permit persons to whom the *) 10 | (* Software is furnished to do so, subject to the following conditions: *) 11 | (* *) 12 | (* The above copyright notice and this permission notice shall be included in *) 13 | (* all copies or substantial portions of the Software. *) 14 | (* *) 15 | (* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR *) 16 | (* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) 17 | (* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) 18 | (* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER *) 19 | (* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) 20 | (* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) 21 | (* DEALINGS IN THE SOFTWARE. *) 22 | (* *) 23 | (********************************************************************************) 24 | 25 | module type S = 26 | sig 27 | type t 28 | 29 | val html_to_string : t -> Types.HTML.t -> string list option -> string 30 | end 31 | 32 | module Translator : S with type t = States.VerifierState.t = 33 | struct 34 | type t = States.VerifierState.t 35 | 36 | let html_element_acc (st : t) (acc : string list) (elm : (int * Types.HTMLElement.t option)) : string list = 37 | match elm with 38 | | (_, None) -> acc 39 | | (_, Some(el)) -> ( 40 | let htmel = 41 | match el with 42 | | HTMLImage (url) -> ( 43 | Printf.sprintf "" 44 | (Types.URL.show (States.VerifierState.translate_url st url)) 45 | ) 46 | | HTMLScript (url) -> ( 47 | match url with 48 | | { url_protocol=ProtocolData ; url_host=_ ; url_port=_ ; url_path=Coq_url_path_data(nonce, idx) } -> ( 49 | let trace = Option.get st.trace in 50 | let script_src = 51 | match Model.Array.select trace.global.data_urls idx with 52 | | ContentElementScript (sc) -> sc.script_src 53 | | _ -> failwith "[html_element_acc] HTML script using data url is not pointing to a script content element" 54 | in 55 | let scr_path = try Option.get @@ States.VerifierState.find_script_by_src st script_src with 56 | Invalid_argument _ -> failwith "[html_element_acc] did not find script" in 57 | 58 | let scr = try Types.NestedDOMPath.Map.find scr_path st.scripts with 59 | Invalid_argument _ -> failwith "[html_element_acc] did not find script (internal)" in 60 | 61 | Base64.encode_exn scr.repr |> 62 | Printf.sprintf "data:text/javascript,eval(atob('%s'))" |> 63 | Printf.sprintf "" 64 | 65 | ) 66 | | _ -> ( 67 | Printf.sprintf "" 68 | (Types.URL.show (States.VerifierState.translate_url st url)) 69 | ) 70 | ) 71 | | HTMLForm (mthd, url) -> ( 72 | Printf.sprintf "
" 73 | (Types.URL.show (States.VerifierState.translate_url st url)) 74 | (Types.RequestMethod.show mthd) 75 | ) 76 | | HTMLFrame (url) -> ( 77 | Printf.sprintf "" 78 | (Types.URL.show (States.VerifierState.translate_url st url)) 79 | ) 80 | in 81 | acc @ [htmel] 82 | ) 83 | 84 | let html_csp_check (urls : string list option) : string = 85 | match urls with 86 | | Some(l) -> ( 87 | Printf.sprintf "%s" @@ 88 | List.fold_left (fun acc x -> Printf.sprintf "%s" acc x) "" l 89 | ) 90 | | None -> "" 91 | 92 | let html_to_string (st : t) (html : Types.HTML.t) (csp_urls : string list option): string = 93 | ignore ( 94 | match csp_urls with 95 | | Some(l) -> List.iter print_endline l 96 | | _ -> () 97 | ) ; 98 | let sorted_body = (List.sort (fun (k1, _v1) (k2, _v2) -> k1 - k2) html.html_body) in 99 | let body = String.concat "" (List.fold_left (html_element_acc st) [] sorted_body) in 100 | Printf.sprintf "%s%s" (html_csp_check csp_urls) body 101 | 102 | end 103 | -------------------------------------------------------------------------------- /verifier/src/html.mli: -------------------------------------------------------------------------------- 1 | (********************************************************************************) 2 | (* Copyright (c) 2022 Pedro Bernardo *) 3 | (* *) 4 | (* Permission is hereby granted, free of charge, to any person obtaining a *) 5 | (* copy of this software and associated documentation files (the "Software"), *) 6 | (* to deal in the Software without restriction, including without limitation *) 7 | (* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) 8 | (* and/or sell copies of the Software, and to permit persons to whom the *) 9 | (* Software is furnished to do so, subject to the following conditions: *) 10 | (* *) 11 | (* The above copyright notice and this permission notice shall be included in *) 12 | (* all copies or substantial portions of the Software. *) 13 | (* *) 14 | (* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR *) 15 | (* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) 16 | (* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) 17 | (* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER *) 18 | (* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) 19 | (* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) 20 | (* DEALINGS IN THE SOFTWARE. *) 21 | (* *) 22 | (********************************************************************************) 23 | 24 | module type S = 25 | sig 26 | type t 27 | 28 | val html_to_string : t -> Types.HTML.t -> string list option -> string 29 | end 30 | 31 | module Translator : S with type t = States.VerifierState.t 32 | -------------------------------------------------------------------------------- /verifier/src/main.ml: -------------------------------------------------------------------------------- 1 | (********************************************************************************) 2 | (* Copyright (c) 2022 Pedro Bernardo & Lorenzo Veronese *) 3 | (* *) 4 | (* Permission is hereby granted, free of charge, to any person obtaining a *) 5 | (* copy of this software and associated documentation files (the "Software"), *) 6 | (* to deal in the Software without restriction, including without limitation *) 7 | (* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) 8 | (* and/or sell copies of the Software, and to permit persons to whom the *) 9 | (* Software is furnished to do so, subject to the following conditions: *) 10 | (* *) 11 | (* The above copyright notice and this permission notice shall be included in *) 12 | (* all copies or substantial portions of the Software. *) 13 | (* *) 14 | (* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR *) 15 | (* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) 16 | (* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) 17 | (* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER *) 18 | (* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) 19 | (* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) 20 | (* DEALINGS IN THE SOFTWARE. *) 21 | (* *) 22 | (********************************************************************************) 23 | 24 | (* Args *) 25 | let verbose = ref false 26 | let lemma = ref None 27 | let check = ref None 28 | let trace = ref None 29 | let trace_name = ref None 30 | 31 | let usage = Printf.sprintf "%s [-v] [-l ] [-c ] " Sys.argv.(0) 32 | let speclist = 33 | [("-v", Arg.Set verbose, "Print debug info"); 34 | ("-l", Arg.String (fun s -> lemma := Some (Trace.get_trace s)), "Load (and merge) the lemma trace") ; 35 | ("-c", Arg.String (fun s -> check := Some (s)), "Perform additional check at the end of the trace")] 36 | 37 | 38 | let anon_fun filename = 39 | if Option.is_some !trace then 40 | raise (Arg.Bad "only one trace expected"); 41 | trace := Some (Trace.get_trace filename); 42 | trace_name := Some Filename.(filename |> remove_extension |> basename) 43 | 44 | let () = 45 | Arg.parse speclist anon_fun usage; 46 | if Option.is_some !lemma then 47 | trace := Some (Trace.merge_traces (Option.get !lemma) (Option.get !trace)); 48 | let trace = (Option.get !trace) in 49 | 50 | (* make the output directory if it does not exists *) 51 | if not (Sys.file_exists "output") then 52 | Unix.mkdir "output" 0o755; 53 | 54 | let pairs = Utils.event_state_pairs (List.rev trace.events) trace.states in 55 | 56 | let st = States.VerifierState.empty in 57 | let st = { st with trace=Some(trace) } in 58 | 59 | let st = List.fold_left Visitor.Preprocessor.handle st pairs in 60 | 61 | (* HERE, PASS FOR THE CSP CHECKS *) 62 | let st = if Option.is_some !check then (Cspcheck.CSPChecker.generate_checks st ) else ( st ) in 63 | let st = Script.Script.generate_scripts st in 64 | let st = List.fold_left Visitor.ResponseGenerator.handle st pairs in 65 | 66 | let all_asserts = List.concat [st.asserts ; st.asserts_ordered] in 67 | 68 | let asserts : Jingoo.Jg_types.tvalue list = 69 | List.fold_left (fun acc (e : States.assertion_t) -> ( 70 | (Jingoo.Jg_types.Tobj [ ("uuid", Jingoo.Jg_types.Tstr e.uuid) ; 71 | ("value", Jingoo.Jg_types.Tstr e.value) ; 72 | ("tag", Jingoo.Jg_types.Tstr (Printf.sprintf "test %d" (List.length acc))) 73 | ]) :: acc 74 | )) [] all_asserts 75 | in 76 | 77 | let actions : Jingoo.Jg_types.tvalue list = 78 | List.fold_left (fun acc (e : States.action_t) -> ( 79 | let ass = List.nth st.asserts_ordered e.assertion in 80 | acc @ [(Jingoo.Jg_types.Tobj [ 81 | ("repr", Jingoo.Jg_types.Tstr e.repr) ; 82 | ("wait", Jingoo.Jg_types.Tbool ( 83 | let w = States.VerifierState.get_wait_uuid st ass in 84 | match w with | Some(_) -> true | None -> false 85 | ) ) ; 86 | ("trigger", Jingoo.Jg_types.Tbool ( 87 | let w = States.VerifierState.get_next_uuid st ass in 88 | match w with | Some(_) -> true | None -> false 89 | ) ) ; 90 | ("lock", Jingoo.Jg_types.Tstr (ass.lock)) ; 91 | ("uuid", Jingoo.Jg_types.Tstr (ass.uuid)) ; 92 | ("value",Jingoo.Jg_types.Tstr (ass.value)) ; 93 | ("next", Jingoo.Jg_types.Tstr ( 94 | let w = States.VerifierState.get_next_uuid st ass in 95 | match w with | Some(x) -> x | None -> "" 96 | )) ; 97 | ])] 98 | )) [] st.actions 99 | in 100 | 101 | let setup = List.fold_left 102 | (fun acc x -> acc @ [Jingoo.Jg_types.Tstr (Script.Script.generate_sw st x)]) 103 | [] st.sws 104 | in 105 | 106 | let result = Jingoo.Jg_template.from_file "templates/launcher.jingoo" ~models:[ 107 | ("delay", Jingoo.Jg_types.Tint 10000) ; 108 | ("actions", Jingoo.Jg_types.Tlist actions) ; 109 | ("asserts", Jingoo.Jg_types.Tlist asserts) ; 110 | ("sws", Jingoo.Jg_types.Tlist setup) ; 111 | ("name", Jingoo.Jg_types.Tstr (Option.get !trace_name)) ; 112 | ] in 113 | 114 | Utils.write_to_file "output/launcher.html" result ; 115 | 116 | let conf = Yojson.Safe.pretty_to_string (Wpt.Config.to_yojson (Wpt.Config.state_to_config st)) in 117 | Utils.write_to_file "output/config.json" conf 118 | -------------------------------------------------------------------------------- /verifier/src/script.mli: -------------------------------------------------------------------------------- 1 | (********************************************************************************) 2 | (* Copyright (c) 2022 Pedro Bernardo *) 3 | (* *) 4 | (* Permission is hereby granted, free of charge, to any person obtaining a *) 5 | (* copy of this software and associated documentation files (the "Software"), *) 6 | (* to deal in the Software without restriction, including without limitation *) 7 | (* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) 8 | (* and/or sell copies of the Software, and to permit persons to whom the *) 9 | (* Software is furnished to do so, subject to the following conditions: *) 10 | (* *) 11 | (* The above copyright notice and this permission notice shall be included in *) 12 | (* all copies or substantial portions of the Software. *) 13 | (* *) 14 | (* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR *) 15 | (* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) 16 | (* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) 17 | (* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER *) 18 | (* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) 19 | (* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) 20 | (* DEALINGS IN THE SOFTWARE. *) 21 | (* *) 22 | (********************************************************************************) 23 | 24 | 25 | module type S = 26 | sig 27 | (* RoundTrip-related functions*) 28 | val generate_scripts : States.VerifierState.t -> States.VerifierState.t 29 | val generate_sw : States.VerifierState.t -> States.sw_t -> string 30 | end 31 | 32 | 33 | 34 | module Script : S -------------------------------------------------------------------------------- /verifier/src/serviceworker.ml: -------------------------------------------------------------------------------- 1 | (********************************************************************************) 2 | (* Copyright (c) 2022 Pedro Bernardo *) 3 | (* *) 4 | (* Permission is hereby granted, free of charge, to any person obtaining a *) 5 | (* copy of this software and associated documentation files (the "Software"), *) 6 | (* to deal in the Software without restriction, including without limitation *) 7 | (* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) 8 | (* and/or sell copies of the Software, and to permit persons to whom the *) 9 | (* Software is furnished to do so, subject to the following conditions: *) 10 | (* *) 11 | (* The above copyright notice and this permission notice shall be included in *) 12 | (* all copies or substantial portions of the Software. *) 13 | (* *) 14 | (* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR *) 15 | (* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) 16 | (* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) 17 | (* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER *) 18 | (* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) 19 | (* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) 20 | (* DEALINGS IN THE SOFTWARE. *) 21 | (* *) 22 | (********************************************************************************) 23 | 24 | 25 | module type S = 26 | sig 27 | val s_response : States.VerifierState.t -> int -> string 28 | val s_request : States.VerifierState.t -> int -> string 29 | (* RoundTrip-related functions*) 30 | end 31 | 32 | module ServiceWorker : S = 33 | struct 34 | 35 | let s_response (st : States.VerifierState.t) (rp_idx : int) : string = 36 | let trace = Option.get st.trace in 37 | List.iter (fun (i, el) -> print_endline (Printf.sprintf "%d: %s" i @@ Types.Response.show el)) trace.global.responses ; 38 | List.iter (fun (i, el) -> print_endline (Printf.sprintf "%d: %s" i @@ Types.Request.show el)) trace.global.requests ; 39 | print_endline ("RESP INDEX" ^ (string_of_int rp_idx)) ; 40 | let resp = Model.Array.select trace.global.responses rp_idx in 41 | 42 | print_endline @@ Types.Response.show resp ; 43 | 44 | let status = Types.ResponseCode.show resp.rp_code in 45 | let headers = Types.ResponseHeaders.to_yojson ( 46 | States.VerifierState.translate_response_headers st resp.rp_headers ) 47 | in 48 | print_endline (Types.ResponseHeaders.show (States.VerifierState.translate_response_headers st resp.rp_headers) ); 49 | 50 | let content = 51 | match resp.rp_content with 52 | | Some (ContentElementImage (url)) -> ( print_endline "TODO: ADD IMAGE AS RP CONTENT" ; Types.URL.show (States.VerifierState.translate_url st url) ) 53 | | Some (ContentElementScript (script)) -> ( 54 | let path = States.VerifierState.find_script_by_src st script.script_src in 55 | let path = try Option.get path with Invalid_argument _ -> failwith "[serviceworker.ml] Script not found" in 56 | let sc = Types.NestedDOMPath.Map.find path st.scripts in 57 | sc.repr 58 | 59 | ) 60 | | Some (ContentElementFrame (_frame, html)) -> ( 61 | Html.Translator.html_to_string st html None 62 | ) 63 | | Some (ContentElementHTML (html)) -> ( 64 | Html.Translator.html_to_string st html None 65 | ) 66 | | _ -> "" 67 | in 68 | 69 | Printf.sprintf "new Response('%s', {status: '%s', headers:%s})" 70 | (content) 71 | (status) 72 | (Yojson.Safe.pretty_to_string headers) 73 | 74 | let s_request (st : States.VerifierState.t) (rq_idx : int) : string = 75 | let trace = Option.get st.trace in 76 | let req = Model.Array.select trace.global.requests rq_idx in 77 | 78 | let url = States.VerifierState.translate_url st req.rq_url in 79 | let url_string = Types.URL.show url in 80 | 81 | let mthd = Types.RequestMethod.show req.rq_method in 82 | let headers = Types.RequestHeaders.to_yojson ( 83 | States.VerifierState.translate_request_headers 84 | st 85 | req.rq_headers ) 86 | in 87 | 88 | Printf.sprintf "new Request('%s', {method: '%s', headers:%s})" 89 | (url_string) 90 | (mthd) 91 | (Yojson.Safe.pretty_to_string headers) 92 | 93 | end 94 | -------------------------------------------------------------------------------- /verifier/src/serviceworker.mli: -------------------------------------------------------------------------------- 1 | (********************************************************************************) 2 | (* Copyright (c) 2022 Pedro Bernardo *) 3 | (* *) 4 | (* Permission is hereby granted, free of charge, to any person obtaining a *) 5 | (* copy of this software and associated documentation files (the "Software"), *) 6 | (* to deal in the Software without restriction, including without limitation *) 7 | (* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) 8 | (* and/or sell copies of the Software, and to permit persons to whom the *) 9 | (* Software is furnished to do so, subject to the following conditions: *) 10 | (* *) 11 | (* The above copyright notice and this permission notice shall be included in *) 12 | (* all copies or substantial portions of the Software. *) 13 | (* *) 14 | (* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR *) 15 | (* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) 16 | (* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) 17 | (* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER *) 18 | (* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) 19 | (* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) 20 | (* DEALINGS IN THE SOFTWARE. *) 21 | (* *) 22 | (********************************************************************************) 23 | 24 | 25 | module type S = 26 | sig 27 | val s_response : States.VerifierState.t -> int -> string 28 | val s_request : States.VerifierState.t -> int -> string 29 | (* RoundTrip-related functions*) 30 | end 31 | 32 | module ServiceWorker : S 33 | -------------------------------------------------------------------------------- /verifier/src/test.ml: -------------------------------------------------------------------------------- 1 | (********************************************************************************) 2 | (* Copyright (c) 2022 Pedro Bernardo *) 3 | (* *) 4 | (* Permission is hereby granted, free of charge, to any person obtaining a *) 5 | (* copy of this software and associated documentation files (the "Software"), *) 6 | (* to deal in the Software without restriction, including without limitation *) 7 | (* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) 8 | (* and/or sell copies of the Software, and to permit persons to whom the *) 9 | (* Software is furnished to do so, subject to the following conditions: *) 10 | (* *) 11 | (* The above copyright notice and this permission notice shall be included in *) 12 | (* all copies or substantial portions of the Software. *) 13 | (* *) 14 | (* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR *) 15 | (* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) 16 | (* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) 17 | (* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER *) 18 | (* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) 19 | (* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) 20 | (* DEALINGS IN THE SOFTWARE. *) 21 | (* *) 22 | (********************************************************************************) 23 | 24 | (* ACTIONS *) 25 | (* Request emitters *) 26 | 27 | module type S = 28 | sig 29 | type t 30 | 31 | val translate : States.VerifierState.t -> unit 32 | 33 | end 34 | 35 | type fetchCreds = 36 | | Omit 37 | | SameOrigin 38 | | Include 39 | 40 | type fetchRedirect = 41 | | Follow 42 | | Error 43 | | Manual 44 | 45 | type fetchCache = 46 | | Default 47 | | NoStore 48 | | Reload 49 | | NoCache 50 | | ForceCache 51 | | OnlyIfCached 52 | 53 | type fetchReferrer = 54 | | URL of Types.URL.t 55 | | AboutClient 56 | | Empty 57 | 58 | type fetchMode = 59 | | Cors 60 | | NoCors 61 | | SameOrigin 62 | 63 | type fetchMethod = 64 | | MethodGet 65 | | MethodPost 66 | | MethodPut 67 | | MethodDelete 68 | | MethodOptions 69 | 70 | type fetchReferrerPolicy = 71 | | NoReferrer 72 | | NoReferrerWhenDowngrade 73 | | SameOrigin 74 | | Origin 75 | | StrictOrigin 76 | | OriginWhenCrossOrigin 77 | | StrictOriginWhenCrossOrigin 78 | | UnsafeURL 79 | 80 | type fetchInit = { 81 | f_method : Types.String.t option ; 82 | f_headers : Types.String.t Types.String.Map.t option; 83 | f_body : Types.String.t option ; (* is this correct? *) 84 | f_mode : fetchMode option ; 85 | f_credentials : fetchCreds option ; 86 | f_cache : fetchCache option ; 87 | f_redirect : fetchRedirect option ; 88 | f_referrer : fetchReferrer option ; 89 | f_referrer_policy : fetchReferrerPolicy option ; 90 | f_integrity : Types.String.t option ; 91 | f_keepalive : bool option; (* true if present else false*) 92 | (* f_signal -> no support for now *) 93 | } 94 | 95 | type cookieAttribute = 96 | | Path of Types.String.t 97 | | Domain of Types.String.t 98 | | MaxAge of Types.Int.t 99 | | Expires of Types.String.t (*timestamp*) 100 | | Secure 101 | | SameSiteLax 102 | | SameSiteStrict 103 | | SameSiteNone 104 | 105 | type cookiePrefix = 106 | | Secure 107 | | Host 108 | 109 | type action = 110 | | Implicit (* CORS pre-flight and resource loading *) 111 | | WindowOpen of Types.URL.t * Types.String.t option (* (url, target) ; windowFeatures not supported by WebSpec *) 112 | | UPDATE_HTML 113 | | Fetch of Types.URL.t * fetchInit option (* fetch url, *) (* both for Script and Worker??*) 114 | | Location of Types.NestedDOMPath.t 115 | | FormSubmit of Types.String.t (* form ID *) 116 | | JSSetItem of Types.NestedDOMPath.t * Types.String.t * Types.String.t (* window.loalStorage.setItem(k, v)*) 117 | | JSCreateBlobURL of Types.NestedDOMPath.t * Types.URL.t 118 | | JSPostMessage of Types.String.t * Types.Origin.t 119 | | JSSetCookie of Types.String.t * Types.String.t * cookieAttribute option * cookiePrefix option(* document.cookie = newCookie*) 120 | | JSUpdateCache(*caches.open() -> add / addAll*) 121 | | JSDOmainRelaxation of Types.NestedDOMPath.t * Types.Domain.t 122 | | WorkerUpdateCache 123 | | WorkerCacheMatch 124 | 125 | 126 | type verification = 127 | | Implicit 128 | | DomUpdate of Types.NestedDOMPath.t * Types.String.t (* target ; value *) 129 | | AssertEquals of Types.NestedDOMPath.t * Types.String.t 130 | 131 | type setup = 132 | | Empty 133 | 134 | 135 | type event = {e_setup : setup option ; e_action : action ; e_verification : verification} 136 | 137 | type script = { s_script : Types.Script.t ; s_actions : action list } 138 | 139 | 140 | type test = { 141 | t_events : event list ; 142 | t_launcher : Types.String.t ; 143 | t_asserts : Types.String.t ; 144 | t_responses : Types.Response.t list; 145 | t_scripts : script list ; 146 | } 147 | 148 | module Wptest : S with type t = test = 149 | struct 150 | type t = test 151 | 152 | let produce_headers (headers : Types.ResponseHeaders.t) : Yojson.Safe.t = 153 | Types.ResponseHeaders.to_yojson headers 154 | 155 | let produce_response (st : States.VerifierState.t) (response : Types.Response.t) : Types.Response.t = 156 | { response with rp_url=(States.VerifierState.translate_url st response.rp_url)} 157 | 158 | 159 | let translate (st : States.VerifierState.t) : unit = 160 | print_endline "RESPONSES" ; 161 | Types.Int.Map.iter (fun key r -> print_endline (Yojson.Safe.pretty_to_string (Types.Response.to_yojson (produce_response st r)))) st.responses 162 | 163 | 164 | end 165 | -------------------------------------------------------------------------------- /verifier/src/test.mli: -------------------------------------------------------------------------------- 1 | (********************************************************************************) 2 | (* Copyright (c) 2022 Pedro Bernardo *) 3 | (* *) 4 | (* Permission is hereby granted, free of charge, to any person obtaining a *) 5 | (* copy of this software and associated documentation files (the "Software"), *) 6 | (* to deal in the Software without restriction, including without limitation *) 7 | (* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) 8 | (* and/or sell copies of the Software, and to permit persons to whom the *) 9 | (* Software is furnished to do so, subject to the following conditions: *) 10 | (* *) 11 | (* The above copyright notice and this permission notice shall be included in *) 12 | (* all copies or substantial portions of the Software. *) 13 | (* *) 14 | (* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR *) 15 | (* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) 16 | (* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) 17 | (* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER *) 18 | (* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) 19 | (* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) 20 | (* DEALINGS IN THE SOFTWARE. *) 21 | (* *) 22 | (********************************************************************************) 23 | 24 | 25 | module type S = 26 | sig 27 | type t 28 | 29 | val translate : States.VerifierState.t -> unit 30 | 31 | end 32 | 33 | type fetchCreds = 34 | | Omit 35 | | SameOrigin 36 | | Include 37 | 38 | type fetchRedirect = 39 | | Follow 40 | | Error 41 | | Manual 42 | 43 | type fetchCache = 44 | | Default 45 | | NoStore 46 | | Reload 47 | | NoCache 48 | | ForceCache 49 | | OnlyIfCached 50 | 51 | type fetchReferrer = 52 | | URL of Types.URL.t 53 | | AboutClient 54 | | Empty 55 | 56 | type fetchMode = 57 | | Cors 58 | | NoCors 59 | | SameOrigin 60 | 61 | type fetchMethod = 62 | | MethodGet 63 | | MethodPost 64 | | MethodPut 65 | | MethodDelete 66 | | MethodOptions 67 | 68 | type fetchReferrerPolicy = 69 | | NoReferrer 70 | | NoReferrerWhenDowngrade 71 | | SameOrigin 72 | | Origin 73 | | StrictOrigin 74 | | OriginWhenCrossOrigin 75 | | StrictOriginWhenCrossOrigin 76 | | UnsafeURL 77 | 78 | type fetchInit = { 79 | f_method : Types.String.t option ; 80 | f_headers : Types.String.t Types.String.Map.t option; 81 | f_body : Types.String.t option ; 82 | f_mode : fetchMode option ; 83 | f_credentials : fetchCreds option ; 84 | f_cache : fetchCache option ; 85 | f_redirect : fetchRedirect option ; 86 | f_referrer : fetchReferrer option ; 87 | f_referrer_policy : fetchReferrerPolicy option ; 88 | f_integrity : Types.String.t option ; 89 | f_keepalive : bool option; (* true if present else false*) 90 | } 91 | 92 | type cookieAttribute = 93 | | Path of Types.String.t 94 | | Domain of Types.String.t 95 | | MaxAge of Types.Int.t 96 | | Expires of Types.String.t (*timestamp*) 97 | | Secure 98 | | SameSiteLax 99 | | SameSiteStrict 100 | | SameSiteNone 101 | 102 | type cookiePrefix = 103 | | Secure 104 | | Host 105 | 106 | 107 | type action = 108 | | Implicit (* CORS pre-flight and resource loading *) 109 | | WindowOpen of Types.URL.t * Types.String.t option (* (url, target) ; windowFeatures not supported by WebSpec *) 110 | | UPDATE_HTML 111 | | Fetch of Types.URL.t * fetchInit option (* fetch url, *) (* both for Script and Worker??*) 112 | | Location of Types.NestedDOMPath.t 113 | | FormSubmit of Types.String.t (* form ID *) 114 | | JSSetItem of Types.NestedDOMPath.t * Types.String.t * Types.String.t (* window.loalStorage.setItem(k, v)*) 115 | | JSCreateBlobURL of Types.NestedDOMPath.t * Types.URL.t 116 | | JSPostMessage of Types.String.t * Types.Origin.t 117 | | JSSetCookie of Types.String.t * Types.String.t * cookieAttribute option * cookiePrefix option(* document.cookie = newCookie*) 118 | | JSUpdateCache(*caches.open() -> add / addAll*) 119 | | JSDOmainRelaxation of Types.NestedDOMPath.t * Types.Domain.t 120 | | WorkerUpdateCache 121 | | WorkerCacheMatch 122 | 123 | 124 | type verification = 125 | | Implicit 126 | | DomUpdate of Types.NestedDOMPath.t * Types.String.t (* target ; value *) 127 | | AssertEquals of Types.NestedDOMPath.t * Types.String.t 128 | 129 | type setup = 130 | | Empty 131 | 132 | 133 | type event = {e_setup : setup option ; e_action : action ; e_verification : verification} 134 | 135 | type script = { s_script : Types.Script.t ; s_actions : action list } 136 | 137 | type test = { 138 | t_events : event list ; 139 | t_launcher : Types.String.t ; 140 | t_asserts : Types.String.t ; 141 | t_responses : Types.Response.t list; 142 | t_scripts : script list ; 143 | } 144 | 145 | module Wptest : S with type t = test 146 | -------------------------------------------------------------------------------- /verifier/src/types.mli: -------------------------------------------------------------------------------- 1 | (********************************************************************************) 2 | (* Copyright (c) 2022 Pedro Bernardo *) 3 | (* *) 4 | (* Permission is hereby granted, free of charge, to any person obtaining a *) 5 | (* copy of this software and associated documentation files (the "Software"), *) 6 | (* to deal in the Software without restriction, including without limitation *) 7 | (* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) 8 | (* and/or sell copies of the Software, and to permit persons to whom the *) 9 | (* Software is furnished to do so, subject to the following conditions: *) 10 | (* *) 11 | (* The above copyright notice and this permission notice shall be included in *) 12 | (* all copies or substantial portions of the Software. *) 13 | (* *) 14 | (* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR *) 15 | (* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) 16 | (* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) 17 | (* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER *) 18 | (* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) 19 | (* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) 20 | (* DEALINGS IN THE SOFTWARE. *) 21 | (* *) 22 | (********************************************************************************) 23 | 24 | type 'a error_or = ('a, string) result 25 | 26 | 27 | module type S = 28 | sig 29 | type t 30 | 31 | val pp : Format.formatter -> t -> unit 32 | val show : t -> string 33 | 34 | val equal : t -> t -> bool 35 | val compare : t -> t -> int 36 | 37 | val of_yojson : Yojson.Safe.t -> (t, string) result 38 | val to_yojson : t -> Yojson.Safe.t 39 | 40 | module Set : Set.S with type elt = t 41 | module Map : Map.S with type key = t 42 | end 43 | 44 | module type SP = 45 | sig 46 | type 'a t 47 | 48 | val pp : (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a t -> unit 49 | val show : (Format.formatter -> 'a -> unit) -> 'a t -> string 50 | 51 | val equal :('a -> 'a -> Ppx_deriving_runtime.bool) -> 52 | 'a t -> 'a t -> Ppx_deriving_runtime.bool 53 | val compare :('a -> 'a -> Ppx_deriving_runtime.int) -> 54 | 'a t -> 'a t -> Ppx_deriving_runtime.int 55 | 56 | val of_yojson : (Yojson.Safe.t -> 'a error_or) -> 57 | Yojson.Safe.t -> 'a t error_or 58 | val to_yojson : ('a -> Yojson.Safe.t) -> 'a t -> Yojson.Safe.t 59 | end 60 | 61 | module Array : SP with type 'a t = 'a Model.Array.array 62 | module Index : SP with type 'a t = 'a Model.Browser.coq_Index 63 | 64 | module Int : S with type t = int 65 | module String : S with type t = string 66 | module Nonce : S with type t = Model.Browser.coq_Nonce 67 | module Protocol : S with type t = Model.Browser.coq_Protocol 68 | module Domain : S with type t = Model.Browser.coq_Domain 69 | module Path : S with type t = Model.Browser.coq_Path 70 | module Origin : S with type t = Model.Browser.coq_Origin 71 | module URLPath : S with type t = Model.Browser.coq_URLPath 72 | module URL : S with type t = Model.Browser.coq_URL 73 | module Image : S with type t = Model.Browser.coq_Image 74 | module Script : S with type t = Model.Browser.coq_Script 75 | module RequestMethod : S with type t = Model.Browser.coq_RequestMethod 76 | module Form : S with type t = Model.Browser.coq_Form 77 | module Frame : S with type t = Model.Browser.coq_Frame 78 | module HTMLElement : S with type t = Model.Browser.coq_HTMLElement 79 | module HTMLHead : S with type t = Model.Browser.coq_HTMLHead 80 | module HTMLBody : S with type t = Model.Browser.coq_HTMLBody 81 | module HTML : S with type t = Model.Browser.coq_HTML 82 | module ContentType : S with type t = Model.Browser.coq_ContentType 83 | module ContentElement : S with type t = Model.Browser.coq_ContentElement 84 | module DOMElement : S with type t = Model.Browser.coq_DOMElement 85 | module DOMHead : S with type t = Model.Browser.coq_DOMHead 86 | module DOMBody : S with type t = Model.Browser.coq_DOMBody 87 | module DOM : S with type t = Model.Browser.coq_DOM 88 | module CookieName : S with type t = Model.Browser.coq_CookieName 89 | module CookieMapping : S with type t = Model.Browser.coq_CookieMapping 90 | module SameSite : S with type t = Model.Browser.coq_SameSite 91 | module SetCookie : S with type t = Model.Browser.coq_SetCookie 92 | module Cookie : S with type t = Model.Browser.coq_Cookie 93 | module RequestHeaders : S with type t = Model.Browser.coq_RequestHeaders 94 | module Request : S with type t = Model.Browser.coq_Request 95 | module CSPSrc : S with type t = Model.Browser.coq_CSPSrc 96 | module TrustedTypes : S with type t = Model.Browser.coq_TrustedTypes 97 | module CSP : S with type t = Model.Browser.coq_CSP 98 | module ReferrerPolicy : S with type t = Model.Browser.coq_ReferrerPolicy 99 | module ResponseHeaders : S with type t = Model.Browser.coq_ResponseHeaders 100 | module ResponseCode : S with type t = Model.Browser.coq_ResponseCode 101 | module Response : S with type t = Model.Browser.coq_Response 102 | module DOMSelector : S with type t = Model.Browser.coq_DOMSelector 103 | module NestedDOMPath : S with type t = Model.Browser.coq_NestedDOMPath 104 | module Emitter : S with type t = Model.Browser.coq_Emitter 105 | module FetchEngine : S with type t = Model.Browser.coq_FetchEngine 106 | module ServiceWorker : S with type t = Model.Browser.coq_ServiceWorker 107 | module Initiators : S with type t = Model.Browser.coq_Initiators 108 | module Document : S with type t = Model.Browser.coq_Document 109 | module Window : S with type t = Model.Browser.coq_Window 110 | module Event : S with type t = Model.Browser.coq_Event 111 | module Blob : S with type t = Model.Browser.coq_Blob 112 | module StorageItem : S with type t = Model.Browser.coq_StorageItem 113 | 114 | 115 | module State : S with type t = Model.Browser.coq_State 116 | module Config : S with type t = Model.Browser.coq_Config 117 | module Global : S with type t = Model.Browser.coq_Global 118 | -------------------------------------------------------------------------------- /verifier/src/utils.ml: -------------------------------------------------------------------------------- 1 | (********************************************************************************) 2 | (* Copyright (c) 2022 Pedro Bernardo *) 3 | (* *) 4 | (* Permission is hereby granted, free of charge, to any person obtaining a *) 5 | (* copy of this software and associated documentation files (the "Software"), *) 6 | (* to deal in the Software without restriction, including without limitation *) 7 | (* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) 8 | (* and/or sell copies of the Software, and to permit persons to whom the *) 9 | (* Software is furnished to do so, subject to the following conditions: *) 10 | (* *) 11 | (* The above copyright notice and this permission notice shall be included in *) 12 | (* all copies or substantial portions of the Software. *) 13 | (* *) 14 | (* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR *) 15 | (* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) 16 | (* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) 17 | (* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER *) 18 | (* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) 19 | (* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) 20 | (* DEALINGS IN THE SOFTWARE. *) 21 | (* *) 22 | (********************************************************************************) 23 | 24 | let port_from_protocol (proto : Types.Protocol.t) : int = 25 | match proto with 26 | | ProtocolHTTP -> 8080 27 | | ProtocolHTTPS -> 8443 28 | | ProtocolData -> 8080 (* idk about these *) 29 | | ProtocolBlob -> 8080 (* idk about these *) 30 | 31 | 32 | let print_set (s : Types.Int.Set.t ) : string = 33 | Printf.sprintf "{ %s }" (String.concat "; " (List.map string_of_int (Types.Int.Set.elements s))) 34 | 35 | let print_int_map (domain : int) (subdomain : Types.Int.Set.t) : unit = 36 | print_string (String.concat ":" [string_of_int domain; "\n"]) ; 37 | ignore (print_set subdomain) 38 | 39 | let print_origin_set (s : Types.Origin.Set.t ) : unit = 40 | print_string "Origins -> {" ; 41 | Types.Origin.Set.iter (fun x -> print_string (" " ^ Types.Origin.show x ^ " ")) s ; 42 | print_string "}\n" 43 | 44 | let print_url_set (s : Types.URL.Set.t ) : unit = 45 | print_string "URLs -> {" ; 46 | Types.URL.Set.iter (fun x -> print_string (" " ^ Types.URL.show x ^ " ")) s ; 47 | print_string "}\n" 48 | 49 | let print_url_map (url : Types.URL.t) (dummy : Types.URL.t) : unit = 50 | print_string (String.concat ":" [Types.URL.show url; " -> "; Types.URL.show dummy ]) 51 | 52 | let write_to_file (filename : string) (content : string) : unit = 53 | let oc = open_out filename in 54 | 55 | Printf.fprintf oc "%s" content ; 56 | 57 | close_out oc 58 | 59 | let rec extend_list (idx : int) (sz : int) (acc : 'a option list) (ref : 'a list) : 'a option list = 60 | if idx < sz then 61 | let acc = acc @ [List.nth_opt ref idx] in 62 | extend_list (idx+1) sz acc ref 63 | else 64 | acc 65 | 66 | let event_state_pairs (ev : Types.Event.t list) (st : Types.State.t list) : (Types.Event.t * Types.State.t option) list = 67 | let st_rev = List.rev st in 68 | 69 | let new_st_rev = extend_list 0 (List.length ev) [] st_rev in 70 | let new_st = List.rev new_st_rev in 71 | 72 | List.fold_left2 (fun acc el1 el2 -> acc @ [(el1, el2)]) [] ev new_st 73 | 74 | 75 | let rand_chr () : char = 76 | Char.chr (97 + (Random.int 26)) 77 | 78 | let rand_str (sz : int) : string = 79 | String.init sz (fun _ -> rand_chr ()) 80 | -------------------------------------------------------------------------------- /verifier/src/utils.mli: -------------------------------------------------------------------------------- 1 | (********************************************************************************) 2 | (* Copyright (c) 2022 Pedro Bernardo *) 3 | (* *) 4 | (* Permission is hereby granted, free of charge, to any person obtaining a *) 5 | (* copy of this software and associated documentation files (the "Software"), *) 6 | (* to deal in the Software without restriction, including without limitation *) 7 | (* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) 8 | (* and/or sell copies of the Software, and to permit persons to whom the *) 9 | (* Software is furnished to do so, subject to the following conditions: *) 10 | (* *) 11 | (* The above copyright notice and this permission notice shall be included in *) 12 | (* all copies or substantial portions of the Software. *) 13 | (* *) 14 | (* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR *) 15 | (* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) 16 | (* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) 17 | (* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER *) 18 | (* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) 19 | (* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) 20 | (* DEALINGS IN THE SOFTWARE. *) 21 | (* *) 22 | (********************************************************************************) 23 | 24 | val port_from_protocol : Types.Protocol.t -> int 25 | val print_int_map : int -> Types.Int.Set.t -> unit 26 | val print_set : Types.Int.Set.t -> string 27 | val print_origin_set : Types.Origin.Set.t -> unit 28 | val print_url_set : Types.URL.Set.t -> unit 29 | val print_url_map : 30 | Types.URL.t -> Types.URL.t -> unit 31 | 32 | val write_to_file : string -> string -> unit 33 | 34 | val event_state_pairs : Types.Event.t list -> Types.State.t list -> (Types.Event.t * Types.State.t option) list 35 | 36 | val rand_chr : unit -> char 37 | val rand_str : int -> string -------------------------------------------------------------------------------- /verifier/src/uuid.ml: -------------------------------------------------------------------------------- 1 | (********************************************************************************) 2 | (* Copyright (c) 2022 Pedro Bernardo *) 3 | (* *) 4 | (* Permission is hereby granted, free of charge, to any person obtaining a *) 5 | (* copy of this software and associated documentation files (the "Software"), *) 6 | (* to deal in the Software without restriction, including without limitation *) 7 | (* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) 8 | (* and/or sell copies of the Software, and to permit persons to whom the *) 9 | (* Software is furnished to do so, subject to the following conditions: *) 10 | (* *) 11 | (* The above copyright notice and this permission notice shall be included in *) 12 | (* all copies or substantial portions of the Software. *) 13 | (* *) 14 | (* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR *) 15 | (* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) 16 | (* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) 17 | (* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER *) 18 | (* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) 19 | (* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) 20 | (* DEALINGS IN THE SOFTWARE. *) 21 | (* *) 22 | (********************************************************************************) 23 | 24 | module type S = 25 | sig 26 | val gen_uuid : unit -> string 27 | end 28 | 29 | 30 | module Generator : S = 31 | struct 32 | let gen_uuid () : string = 33 | let rst = Random.State.make_self_init () in 34 | Uuidm.v4_gen rst () 35 | |> Uuidm.to_string 36 | 37 | end 38 | -------------------------------------------------------------------------------- /verifier/src/uuid.mli: -------------------------------------------------------------------------------- 1 | (********************************************************************************) 2 | (* Copyright (c) 2022 Pedro Bernardo *) 3 | (* *) 4 | (* Permission is hereby granted, free of charge, to any person obtaining a *) 5 | (* copy of this software and associated documentation files (the "Software"), *) 6 | (* to deal in the Software without restriction, including without limitation *) 7 | (* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) 8 | (* and/or sell copies of the Software, and to permit persons to whom the *) 9 | (* Software is furnished to do so, subject to the following conditions: *) 10 | (* *) 11 | (* The above copyright notice and this permission notice shall be included in *) 12 | (* all copies or substantial portions of the Software. *) 13 | (* *) 14 | (* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR *) 15 | (* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) 16 | (* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) 17 | (* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER *) 18 | (* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) 19 | (* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) 20 | (* DEALINGS IN THE SOFTWARE. *) 21 | (* *) 22 | (********************************************************************************) 23 | 24 | 25 | module type S = 26 | sig 27 | val gen_uuid : unit -> string 28 | end 29 | 30 | 31 | module Generator : S -------------------------------------------------------------------------------- /verifier/src/visitor.mli: -------------------------------------------------------------------------------- 1 | (********************************************************************************) 2 | (* Copyright (c) 2022 Pedro Bernardo *) 3 | (* *) 4 | (* Permission is hereby granted, free of charge, to any person obtaining a *) 5 | (* copy of this software and associated documentation files (the "Software"), *) 6 | (* to deal in the Software without restriction, including without limitation *) 7 | (* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) 8 | (* and/or sell copies of the Software, and to permit persons to whom the *) 9 | (* Software is furnished to do so, subject to the following conditions: *) 10 | (* *) 11 | (* The above copyright notice and this permission notice shall be included in *) 12 | (* all copies or substantial portions of the Software. *) 13 | (* *) 14 | (* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR *) 15 | (* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) 16 | (* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) 17 | (* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER *) 18 | (* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) 19 | (* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) 20 | (* DEALINGS IN THE SOFTWARE. *) 21 | (* *) 22 | (********************************************************************************) 23 | 24 | module type Visitor = 25 | sig 26 | type t 27 | val request_handler : t -> Model.Browser.coq_Emitter -> Model.Browser.coq_Request -> int -> Types.State.t option -> t 28 | val response_handler : t -> Model.Browser.coq_Response -> int -> t 29 | val url_source_handler : t -> Model.Browser.coq_URL -> Model.Browser.coq_HTMLElement option -> t 30 | val url_handler : t -> Model.Browser.coq_URL -> t 31 | val domupdate_handler : t -> Types.NestedDOMPath.t -> t 32 | val default_handler : t -> Model.Browser.coq_Event -> t 33 | val handle : t -> (Types.Event.t * Types.State.t option) -> t 34 | end 35 | 36 | module Preprocessor : Visitor with type t = States.VerifierState.t 37 | module ResponseGenerator : Visitor with type t = States.VerifierState.t 38 | -------------------------------------------------------------------------------- /verifier/src/wpt.mli: -------------------------------------------------------------------------------- 1 | (********************************************************************************) 2 | (* Copyright (c) 2022 Pedro Bernardo *) 3 | (* *) 4 | (* Permission is hereby granted, free of charge, to any person obtaining a *) 5 | (* copy of this software and associated documentation files (the "Software"), *) 6 | (* to deal in the Software without restriction, including without limitation *) 7 | (* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) 8 | (* and/or sell copies of the Software, and to permit persons to whom the *) 9 | (* Software is furnished to do so, subject to the following conditions: *) 10 | (* *) 11 | (* The above copyright notice and this permission notice shall be included in *) 12 | (* all copies or substantial portions of the Software. *) 13 | (* *) 14 | (* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR *) 15 | (* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) 16 | (* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) 17 | (* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER *) 18 | (* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) 19 | (* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) 20 | (* DEALINGS IN THE SOFTWARE. *) 21 | (* *) 22 | (********************************************************************************) 23 | 24 | module type S = 25 | sig 26 | type t 27 | 28 | val empty : t 29 | val to_yojson : t -> Yojson.Safe.t 30 | val state_to_config : States.VerifierState.t -> t 31 | 32 | 33 | end 34 | 35 | type config = { 36 | ports : Types.Int.Set.t Types.Protocol.Map.t ; 37 | browser_host : Types.Domain.t; 38 | alternate_hosts : Types.Int.Set.t; 39 | subdomains : Types.Int.Set.t; 40 | } 41 | 42 | module Config : S with type t = config 43 | -------------------------------------------------------------------------------- /verifier/templates/install.jingoo: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 9 | 10 | 11 | 12 | -------------------------------------------------------------------------------- /verifier/templates/launcher.jingoo: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 59 | -------------------------------------------------------------------------------- /verifier/templates/sw.jingoo: -------------------------------------------------------------------------------- 1 | 2 | let STASH_RESPONDER = "wss://web-platform.test:8666/stash_responder_blocking"; 3 | 4 | class StashUtils { 5 | static putValue(key, value) { 6 | return new Promise(resolve => { 7 | const ws = new WebSocket(STASH_RESPONDER); 8 | ws.onopen = () => { 9 | ws.send(JSON.stringify({action: 'set', key: key, value: value})); 10 | }; 11 | ws.onmessage = e => { 12 | ws.close(); 13 | resolve(); 14 | }; 15 | }); 16 | } 17 | 18 | static takeValue(key) { 19 | return new Promise(resolve => { 20 | const ws = new WebSocket(STASH_RESPONDER); 21 | ws.onopen = () => { 22 | ws.send(JSON.stringify({action: 'get', key: key})); 23 | }; 24 | ws.onmessage = e => { 25 | ws.close(); 26 | resolve(JSON.parse(e.data).value); 27 | }; 28 | }); 29 | } 30 | } 31 | 32 | caches.open("{{cache}}"); 33 | 34 | asserts = { 35 | {% for ass in asserts %} 36 | '{{ass.url}}' : {'uuid' : '{{ass.uuid}}', 'val' : '{{ass.val}}', 'lock' : '{{ass.lock}}', 'next' : '{{ass.next}}'}, 37 | {% endfor %} 38 | }; 39 | 40 | 41 | {% for cupdate in cupdates %} 42 | {{ cupdate.repr | safe }} 43 | {% endfor %} 44 | 45 | 46 | 47 | self.addEventListener('fetch', (event) => { 48 | // check if request is meant to be matched 49 | let ass_match = asserts[event.request.url]; 50 | if (ass_match) { 51 | event.respondWith((async () => { 52 | await StashUtils.takeValue(ass_match['lock']) 53 | let mycache = await caches.open("{{cache}}") 54 | let response = await mycache.match(event.request, options={ignoreVary:true}) 55 | StashUtils.putValue(ass_match['uuid'], ass_match['val']) 56 | if (ass_match['next'] != '') { 57 | StashUtils.putValue(ass_match['next'], 'dummy') 58 | } 59 | return response 60 | })()) 61 | } else { 62 | // not meant to be matched, return as if the cache.match failed 63 | return 64 | } 65 | }); -------------------------------------------------------------------------------- /webspec: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | set -euo pipefail 3 | 4 | WEBSPEC_ROOT="$(dirname "$(realpath $0)")" 5 | WEBSPEC_DOCKER_IMAGE="webspec/webspec" 6 | 7 | WEBSPEC_RUN="docker run --rm --name=webspec -ti -v \"$WEBSPEC_ROOT:/mnt\" \"$WEBSPEC_DOCKER_IMAGE\"" 8 | 9 | print_usage () { 10 | echo "Usage: $0 [ -h ] ( compile | run | verify [ -c csp ] [ -b BROWSER ] )" 11 | } 12 | 13 | if [[ $# -gt 0 ]]; then 14 | case $1 in 15 | pull) 16 | docker pull "$WEBSPEC_DOCKER_IMAGE" 17 | docker pull webplatformtests/wpt:0.52 18 | ;; 19 | compile) 20 | echo -e "\e[1m⚙ Compiling WebSpec . . .\e[0m" 21 | eval $WEBSPEC_RUN make all coq verifier 22 | ;; 23 | clean) 24 | echo -e "\e[1m⚙ Cleaning . . .\e[0m" 25 | eval $WEBSPEC_RUN make clean 26 | ;; 27 | run) 28 | shift 29 | [[ $# -gt 0 ]] || { 30 | echo 'Invariant name required!' 31 | exit 1 32 | } 33 | if [[ ! -d "$WEBSPEC_ROOT/compiler/_build" || ! -f "$WEBSPEC_ROOT/model/Browser.vo" ]]; then 34 | $0 compile 35 | fi 36 | eval $WEBSPEC_RUN scripts/run.sh "$1" 37 | ;; 38 | verify) 39 | ADDITIONAL_ARGS="" 40 | BROWSER=chromium 41 | shift 42 | while getopts ":b:c:" ARG; do 43 | case "$ARG" in 44 | b) 45 | BROWSER="${OPTARG}" 46 | [[ $BROWSER == "chromium" || $BROWSER == "firefox" ]] || { 47 | echo "Invalid browser. Supported browsers: chromium, firefox." 48 | exit 1 49 | } 50 | ;; 51 | c) 52 | ADDITIONAL_ARGS="-c ${OPTARG}" 53 | ;; 54 | ?) 55 | echo "Invalid option: ${OPTARG}" 56 | ;; 57 | esac 58 | done 59 | shift "$((OPTIND - 1))" 60 | 61 | [[ $# -gt 0 && -f "$WEBSPEC_ROOT/traces/$1.trace.z3" ]] || { 62 | echo 'Valid trace name required! (see traces/)' 63 | exit 1 64 | } 65 | if [[ ! -d "$WEBSPEC_ROOT/verifier/_build" || ! -f "$WEBSPEC_ROOT/model/Browser.vo" ]]; then 66 | $0 compile 67 | fi 68 | IMAGE_NAME="webspec-verifier-${1,,}-$BROWSER" 69 | echo -e "\e[1m⚙ Generating Executable Test . . .\e[0m" 70 | eval $WEBSPEC_RUN make -s clean-verifier-output 71 | eval $WEBSPEC_RUN make "traces/$1.trace.dat" > /dev/null 72 | VERIFIER_CMD="cd verifier && dune exec src/main.exe -- ${ADDITIONAL_ARGS} \"../traces/$1.trace.dat\"" 73 | eval $WEBSPEC_RUN "'$VERIFIER_CMD'" > /dev/null || eval $WEBSPEC_RUN "'$VERIFIER_CMD'" 74 | echo -e "\e[1m⚙ [${BROWSER^^}] Building Test Container . . .\e[0m" 75 | docker build -t "$IMAGE_NAME" --target "$BROWSER" "$WEBSPEC_ROOT/verifier" 76 | echo -e "\e[1m💻 [${BROWSER^^}] Running Test . . .\e[0m" 77 | docker run --rm -ti --name "${IMAGE_NAME}_1" "$IMAGE_NAME" 78 | ;; 79 | *) 80 | echo 'Unknown command!' 81 | print_usage 82 | exit 1 83 | esac 84 | else 85 | print_usage 86 | fi 87 | --------------------------------------------------------------------------------